diff options
author | stuebinm | 2024-05-15 01:12:09 +0200 |
---|---|---|
committer | stuebinm | 2024-05-15 01:12:09 +0200 |
commit | 0c9b3a6dba6850ce526d1d397f35aa6ad76beb50 (patch) | |
tree | f7b307548904ed0c0bb1459b9d09da63ed0a4243 /lib/API.hs | |
parent | 59670bdb6f0a3bba898274eadf47707e93bea195 (diff) |
Server.Ingest: new handling of unassigned trackers
now takes all potential stops along each trip into account when guessing
tickets; also checks if a ticket is still likely in case the tracker
switched its direction. This should solve many cases where a tracker is
accidentally turned off or falls asleep halfway before the last station
of one trip, then wakes up in the middle of the next.
Diffstat (limited to 'lib/API.hs')
-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) + |