diff options
Diffstat (limited to '')
-rw-r--r-- | lib/API.hs | 18 |
1 files changed, 16 insertions, 2 deletions
@@ -1,10 +1,11 @@ {-# 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 (..)) @@ -51,12 +52,22 @@ import Prometheus import Proto.GtfsRealtime (FeedMessage) import Servant.API.ContentTypes (Accept (..)) +-- | a bare ping as sent by a tracker device +data SentPing = SentPing + { sentPingToken :: TrackerId + , sentPingGeopos :: Geopos + , sentPingTimestamp :: UTCTime + } deriving (Generic) + +instance FromJSON SentPing where + parseJSON = genericParseJSON (aesonOptions "sentPing") + -- | tracktrain's API type API = -- ingress API (put this behind BasicAuth?) -- TODO: perhaps require a first ping for registration? "tracker" :> "register" :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token - :<|> "tracker" :> "ping" :> ReqBody '[JSON] TrainPing :> Post '[JSON] (Maybe TrainAnchor) + :<|> "tracker" :> "ping" :> ReqBody '[JSON] SentPing :> Post '[JSON] (Maybe TrainAnchor) :<|> "tracker" :> "ping" :> "ws" :> WebSocket :<|> "ticket" :> "subscribe" :> Capture "Ticket Id" UUID :> WebSocket :<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing]) @@ -94,6 +105,8 @@ instance ToSchema RegisterJson where instance ToSchema Value where declareNamedSchema _ = pure $ NamedSchema (Just "json") $ mempty & type_ ?~ SwaggerObject +instance ToSchema SentPing where + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainPing") @@ -124,3 +137,4 @@ instance Message msg => MimeRender Proto msg where instance {-# OVERLAPPABLE #-} Message msg => ToSchema msg where declareNamedSchema proxy = pure (NamedSchema (Just (messageName proxy)) mempty) + |