diff options
author | stuebinm | 2022-12-13 00:30:21 +0100 |
---|---|---|
committer | stuebinm | 2022-12-13 00:30:21 +0100 |
commit | 6c0f21b276ad73f383a80fe00729c6520a6b874a (patch) | |
tree | a8d89dd98b94f2752c82ac97af093794e0e528a5 /lib/Server.hs | |
parent | 7d94d4d02bc729a1879524ff9420cf4a2f697afd (diff) |
simple realtime position map
(what was that about doing the realtime stuff somewhere else and /not/
in this monolithic server thingie? oh well …)
Diffstat (limited to 'lib/Server.hs')
-rw-r--r-- | lib/Server.hs | 10 |
1 files changed, 9 insertions, 1 deletions
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 |