From 46a24c8a90d4e6e794a2c6ed79da94e02e2c7eab Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sun, 11 Sep 2022 13:07:02 +0200
Subject: on-board-unit: display estimated delay etc.

---
 lib/Server.hs | 8 +++++---
 1 file changed, 5 insertions(+), 3 deletions(-)

(limited to 'lib/Server.hs')

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
-- 
cgit v1.2.3