From 6c0f21b276ad73f383a80fe00729c6520a6b874a Mon Sep 17 00:00:00 2001 From: stuebinm Date: Tue, 13 Dec 2022 00:30:21 +0100 Subject: simple realtime position map (what was that about doing the realtime stuff somewhere else and /not/ in this monolithic server thingie? oh well …) --- lib/API.hs | 2 +- lib/Server.hs | 10 +++++++++- lib/Server/ControlRoom.hs | 48 +++++++++++++++++++++++++++++++++++++++++++++++ messages/de.msg | 1 + messages/en.msg | 1 + 5 files changed, 60 insertions(+), 2 deletions(-) diff --git a/lib/API.hs b/lib/API.hs index 3e29249..775bc4c 100644 --- a/lib/API.hs +++ b/lib/API.hs @@ -61,7 +61,7 @@ type API = "stations" :> Get '[JSON] (Map StationID Station) -- TODO: perhaps a websocket instead? :<|> "train" :> "ping" :> ReqBody '[JSON] TrainPing :> Post '[JSON] (Maybe TrainAnchor) :<|> "train" :> "ping" :> "ws" :> WebSocket - :<|> "train" :> "subscribe" :> Capture "Trip ID" TripID :> WebSocket + :<|> "train" :> "subscribe" :> Capture "Trip ID" TripID :> Capture "Day" Day :> WebSocket -- debug things :<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing]) :<|> "debug" :> "pings" :> Capture "Trip ID" TripID :> Capture "day" Day :> Get '[JSON] [TrainPing] diff --git a/lib/Server.hs b/lib/Server.hs index 84dc27e..8cab47a 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -151,13 +151,21 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool = handleDebugAPI liftIO $ handleTrainPing (WS.sendClose conn ("" :: ByteString)) ping >>= \case Just anchor -> WS.sendTextData conn (A.encode anchor) Nothing -> pure () - handleSubscribe tripId conn = liftIO $ WS.withPingThread conn 30 (pure ()) $ do + handleSubscribe tripId day conn = liftIO $ WS.withPingThread conn 30 (pure ()) $ do queue <- atomically $ do queue <- newTQueue qs <- readTVar subscribers writeTVar subscribers $ M.insertWith (<>) tripId [queue] qs pure queue + -- send most recent ping, if any (so we won't have to wait for movement) + lastPing <- runSql dbpool $ do + tokens <- selectList [RunningDay ==. day, RunningTrip ==. tripId] [] + <&> fmap entityKey + selectFirst [TrainPingToken <-. tokens] [Desc TrainPingTimestamp] + <&> fmap entityVal + whenJust lastPing $ \ping -> + WS.sendTextData conn (A.encode lastPing) handle (\(e :: WS.ConnectionException) -> removeSubscriber queue) $ forever $ do res <- atomically $ readTQueue queue case res of diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index ef3cb1e..ee0f686 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -70,6 +70,7 @@ mkYesod "ControlRoom" [parseRoutes| / RootR GET /trains TrainsR GET /train/id/#TripID/#Day TrainViewR GET +/train/map/#TripID/#Day TrainMapViewR GET /train/announce/#TripID/#Day AnnounceR POST /train/del-announce/#UUID DelAnnounceR GET /token/block/#Token TokenBlock GET @@ -131,6 +132,10 @@ instance Yesod ControlRoom where .blocked { background-color: red; } + #map { + width: 100%; + height: 50vh; + } $forall (status, msg) <- msgs

#{msg} @@ -199,6 +204,7 @@ getTrainViewR trip day = do \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")}) $nothing (_{MsgNone}) +

_{MsgStops}
@@ -238,6 +244,48 @@ getTrainViewR trip day = do guessAtSeconds = extrapolateAtSeconds LinearExtrapolator +getTrainMapViewR :: TripID -> Day -> Handler Html +getTrainMapViewR tripId day = do + GTFS{..} <- getYesod <&> getGtfs + (widget, enctype) <- generateFormPost (announceForm day tripId) + case M.lookup tripId trips of + Nothing -> notFound + Just res@Trip{..} -> do defaultLayout $ [whamlet| +
_{MsgTrip} #{tripName res} _{Msgon} #{day} + + +
+
+