diff options
Diffstat (limited to 'lib/API.hs')
| -rw-r--r-- | lib/API.hs | 85 |
1 files changed, 44 insertions, 41 deletions
@@ -1,14 +1,11 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE UndecidableInstances #-} -- | The sole authorative definition of this server's API, given as a Servant-style -- Haskell type. All other descriptions of the API are generated from this one. -module API (API, CompleteAPI, GtfsRealtimeAPI, RegisterJson(..), Metrics(..)) where +module API (API, CompleteAPI, GtfsRealtimeAPI, RegisterJson(..), Metrics(..), SentPing(..)) where import Data.Map (Map) import Data.Proxy (Proxy (..)) @@ -34,7 +31,6 @@ import Servant.API (Accept, Capture, Get, JSON, Post, QueryParam, Raw, ReqBody, type (:<|>) (..)) import Servant.API.WebSocket (WebSocket) --- import Servant.GTFS.Realtime (Proto) import Servant.Swagger (HasSwagger (..)) import Web.Internal.FormUrlEncoded (Form) @@ -44,55 +40,47 @@ 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 +import GTFS (Depth (Deep), GTFSFile (..), + StationID, Trip, TripId, + aesonOptions, swaggerOptions) import Network.HTTP.Media ((//)) import Persist import Prometheus import Proto.GtfsRealtime (FeedMessage) import Servant.API.ContentTypes (Accept (..)) -newtype RegisterJson = RegisterJson - { registerAgent :: Text } - deriving (Show, Generic) +-- | a bare ping as sent by a tracker device +data SentPing = SentPing + { sentPingToken :: TrackerId + , sentPingGeopos :: Geopos + , sentPingTimestamp :: UTCTime + } deriving (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 +instance FromJSON SentPing where + parseJSON = genericParseJSON (aesonOptions "sentPing") --- | The server's API (as it is actually intended). -type API = "stations" :> Get '[JSON] (Map StationID Station) - :<|> "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 "Trip ID" TripID :> 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 "Trip ID" TripID :> Capture "Day" Day :> WebSocket - -- debug things + "tracker" :> "register" :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token + :<|> "tracker" :> "ping" :> ReqBody '[JSON] SentPing :> Post '[JSON] (Maybe TrainAnchor) + :<|> "tracker" :> "ping" :> "ws" :> WebSocket + :<|> "ticker" :> "current" :> Get '[JSON] Value + :<|> "ticket" :> "subscribe" :> Capture "Ticket Id" UUID :> WebSocket :<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing]) - :<|> "debug" :> "pings" :> Capture "Trip ID" TripID :> Capture "day" Day :> Get '[JSON] [TrainPing] - :<|> "debug" :> "register" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] Token + :<|> "debug" :> "pings" :> Capture "Ticket Id" UUID :> Get '[JSON] [TrainPing] :<|> "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 @@ -107,6 +95,20 @@ 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 +instance ToSchema SentPing where + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainPing") + -- TODO write something useful here! (and if it's just "hey this is some websocket thingie") @@ -132,7 +134,8 @@ 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) + |