restructure: get the tracker to work again

This should hopefully be the final (major) part of the restructuring: a
tracker no longer has to know which trip it is on (and indeed it has no
idea for now), instead the server keeps state about which trips are
currently running and will insert incoming pings in a hopefully
reasonable manner, based on their geoposition & time.

There's lots of associated TODO items here (especially there should be
manual overrides for all this logic in the web ui), but that's work for
a future me.

(incidentally, this also adds support for sending all log messages out
via ntfy-sh)

1 files changed, 23 insertions, 31 deletions

diff --git a/lib/API.hs b/lib/API.hs
index 2c8123a..b2635c1 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -39,7 +39,8 @@ import           Data.Aeson                  (FromJSON (..), Value,
 import           Data.ByteString             (ByteString)
 import qualified Data.ByteString.Lazy        as LB
 import           Data.HashMap.Strict.InsOrd  (singleton)
-import           Data.ProtoLens              (Message, encodeMessage)
+import           Data.ProtoLens              (Message (messageName),
+                                              encodeMessage)
 import           GHC.Generics                (Generic)
 import           GTFS                        (Depth (Deep), GTFSFile (..),
                                               StationID, Trip, TripId,
@@ -50,45 +51,24 @@ import           Prometheus
 import           Proto.GtfsRealtime          (FeedMessage)
 import           Servant.API.ContentTypes    (Accept (..))
 
-newtype RegisterJson = RegisterJson
-  { registerAgent :: Text }
-  deriving (Show, Generic)
-
-instance FromJSON RegisterJson where
-  parseJSON = genericParseJSON (aesonOptions "register")
-instance ToSchema RegisterJson where
-  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "register")
-instance ToSchema Value where
-  declareNamedSchema _ = pure $ NamedSchema (Just "json") $ mempty
-      & type_ ?~ SwaggerObject
-
--- | The server's API (as it is actually intended).
-type API =  "timetable" :> Capture "Station Id" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripId (Trip Deep Deep))
-  :<|> "timetable" :> "stops" :> Capture "Date" Day :> Get '[JSON] Value
-  :<|> "trip" :> Capture "Trip Id" TripId :> Get '[JSON] (Trip Deep Deep)
+-- | tracktrain's API
+type API =
   -- ingress API (put this behind BasicAuth?)
   -- TODO: perhaps require a first ping for registration?
-  :<|> "train" :> "register" :> Capture "Ticket Id" UUID :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token
-  -- TODO: perhaps a websocket instead?
-  :<|> "train" :> "ping" :> ReqBody '[JSON] TrainPing :> Post '[JSON] (Maybe TrainAnchor)
-  :<|> "train" :> "ping" :> "ws" :> WebSocket
-  :<|> "train" :> "subscribe" :> Capture "Ticket Id" UUID :> WebSocket
-  -- debug things
+       "tracker" :> "register" :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token
+  :<|> "tracker" :> "ping" :> ReqBody '[JSON] TrainPing :> Post '[JSON] (Maybe TrainAnchor)
+  :<|> "tracker" :> "ping" :> "ws" :> WebSocket
+  :<|> "ticket" :> "subscribe" :> Capture "Ticket Id" UUID :> WebSocket
   :<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing])
   :<|> "debug" :> "pings" :> Capture "Ticket Id" UUID :> Get '[JSON] [TrainPing]
-  :<|> "debug" :> "register" :> Capture "Ticket Id" UUID :> Post '[JSON] Token
   :<|> "gtfs.zip" :> Get '[OctetStream] GTFSFile
   :<|> "gtfs" :> GtfsRealtimeAPI
 
--- | The API used for publishing gtfs realtime updates
 type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage
   :<|> "tripupdates" :> Get '[Proto] FeedMessage
   :<|> "vehiclepositions" :> Get '[Proto] FeedMessage
 
 
--- | The server's API with an additional debug route for accessing the specification
--- itself. Split from API to prevent the API documenting the format in which it is
--- documented, which would be silly and way to verbose.
 type CompleteAPI =
   "api" :> "openapi" :> Get '[JSON] Swagger
   :<|> "api" :> API
@@ -103,6 +83,18 @@ data Metrics = Metrics
 instance MimeRender OctetStream GTFSFile where
   mimeRender p (GTFSFile bytes) = mimeRender p bytes
 
+newtype RegisterJson = RegisterJson
+  { registerAgent :: Text }
+  deriving (Show, Generic)
+
+instance FromJSON RegisterJson where
+  parseJSON = genericParseJSON (aesonOptions "register")
+instance ToSchema RegisterJson where
+  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "register")
+instance ToSchema Value where
+  declareNamedSchema _ = pure $ NamedSchema (Just "json") $ mempty
+      & type_ ?~ SwaggerObject
+
 
 
 -- TODO write something useful here! (and if it's just "hey this is some websocket thingie")
@@ -128,7 +120,7 @@ instance Accept Proto where
 instance Message msg => MimeRender Proto msg where
   mimeRender _ = LB.fromStrict . encodeMessage
 
--- TODO: this instance is horrible; ideally it should at least include
--- the name of the message type (if at all possible)
+-- | Not an ideal instance, hides fields of the protobuf message
 instance {-# OVERLAPPABLE #-} Message msg => ToSchema msg where
-  declareNamedSchema _ = declareNamedSchema (Proxy @String)
+  declareNamedSchema proxy =
+    pure (NamedSchema (Just (messageName proxy)) mempty)