aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorstuebinm2022-09-11 13:07:02 +0200
committerstuebinm2022-09-11 13:07:02 +0200
commit46a24c8a90d4e6e794a2c6ed79da94e02e2c7eab (patch)
tree3fd4dac9910d58034a0d3a487a30fa2453dfc4a1 /lib
parent9cb73aa181a8e28aea2268b8fdfd65332710a9fe (diff)
on-board-unit: display estimated delay etc.
Diffstat (limited to 'lib')
-rw-r--r--lib/API.hs2
-rw-r--r--lib/Persist.hs8
-rw-r--r--lib/Server.hs8
3 files changed, 12 insertions, 6 deletions
diff --git a/lib/API.hs b/lib/API.hs
index 4c80535..32465c7 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -56,7 +56,7 @@ type API = "stations" :> Get '[JSON] (Map StationID Station)
-- 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] NoContent
+ :<|> "train" :> "ping" :> ReqBody '[JSON] TrainPing :> Post '[JSON] (Maybe TrainAnchor)
:<|> "train" :> "ping" :> "ws" :> WebSocket
-- debug things
:<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing])
diff --git a/lib/Persist.hs b/lib/Persist.hs
index 769db2a..a8ed15e 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -99,7 +99,7 @@ TrainAnchor json sql=tt_trip_anchor
sequence Double
delay Seconds
msg Text Maybe
- deriving Show Generic Eq ToSchema
+ deriving Show Generic Eq
-- TODO: multi-language support?
Announcement json sql=tt_announcements
@@ -110,7 +110,7 @@ Announcement json sql=tt_announcements
day Day
url Text Maybe
announcedAt UTCTime Maybe
- deriving Generic ToSchema Show
+ deriving Generic Show
-- | this table works as calendar_dates.txt in GTFS
ScheduleAmendment json sql=tt_schedule_amendement
@@ -125,6 +125,10 @@ instance ToSchema RunningId where
declareNamedSchema _ = declareNamedSchema (Proxy @UUID)
instance ToSchema TrainPing where
declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trainPing")
+instance ToSchema TrainAnchor where
+ declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trainAnchor")
+instance ToSchema Announcement where
+ declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "announcement")
runSql :: MonadIO m => Pool SqlBackend -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a
runSql pool = liftIO . flip runSqlPersistMPool pool
diff --git a/lib/Server.hs b/lib/Server.hs
index db23932..3c1e84b 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -103,7 +103,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI
handleTrainPing onError ping = isTokenValid dbpool (coerce $ trainPingToken ping) >>= \case
Nothing -> do
onError
- pure NoContent
+ pure Nothing
Just running@Running{..} -> do
let anchor = extrapolateAnchorFromPing @LinearExtrapolator gtfs running ping
-- TODO: are these always inserted in order?
@@ -115,7 +115,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI
-- only insert new estimates if they've actually changed anything
when (fmap (trainAnchorDelay . entityVal) last /= Just (trainAnchorDelay anchor))
$ void $ insert anchor
- pure NoContent
+ pure (Just anchor)
handleWS conn = do
liftIO $ WS.forkPingThread conn 30
forever $ do
@@ -127,7 +127,9 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI
Right ping ->
-- if invalid token, send a "polite" close request. Note that the client may
-- ignore this and continue sending messages, which will continue to be handled.
- liftIO $ void $ handleTrainPing (WS.sendClose conn ("" :: ByteString)) ping
+ liftIO $ handleTrainPing (WS.sendClose conn ("" :: ByteString)) ping >>= \case
+ Just anchor -> WS.sendTextData conn (A.encode anchor)
+ Nothing -> pure ()
handleDebugState = do
now <- liftIO getCurrentTime
runSql dbpool $ do