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/API.hs      |  2 +-
 lib/Persist.hs  |  8 ++++++--
 lib/Server.hs   |  8 +++++---
 messages/de.msg |  6 ++++++
 messages/en.msg |  3 +++
 site/obu.hamlet | 15 ++++++++++++++-
 6 files changed, 35 insertions(+), 7 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
diff --git a/messages/de.msg b/messages/de.msg
index 2da81b8..7243173 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -22,3 +22,9 @@ OnStationSequence idx: an Stationsindex #{idx}
 
 ChooseTrain: Fahrt auswählen
 TokenFailed: konnte kein Token erhalten
+PermissionFailed: Berechtigungsfehler
+WebsocketError: Websocketfehler
+Error: Fehler
+Estimated: Geschätzt
+Delay: Verspätung
+Sequence: Stationsindex
diff --git a/messages/en.msg b/messages/en.msg
index ddbfdfd..ac6aca0 100644
--- a/messages/en.msg
+++ b/messages/en.msg
@@ -31,3 +31,6 @@ TokenFailed: Failed to acquire token
 PermissionFailed: permission failed
 WebsocketError: Websocket Error
 Error: Error
+Estimated: Estimated
+Delay: Delay
+Sequence: Station Index
diff --git a/site/obu.hamlet b/site/obu.hamlet
index 9aec4c0..7068014 100644
--- a/site/obu.hamlet
+++ b/site/obu.hamlet
@@ -9,6 +9,11 @@
   <p><strong>Position: </strong><span id="lat"></span>, <span id="long"></span>
   <p><strong>Accuracy: </strong><span id="acc">
 
+<section>
+  <h2>_{MsgEstimated}
+  <p><strong>_{MsgDelay}</strong>: <span id="delay">
+  <p><strong>_{MsgSequence}</strong>: <span id="sequence">
+
 <section>
   <h2>Status
   <p id="status">_{MsgNone}
@@ -57,6 +62,14 @@
     setTimeout(openWebsocket, 1000);
   }
 
+  function wsMsg(msg) {
+    let json = JSON.parse(msg.data);
+    console.log(json);
+    document.getElementById("delay").innerText =
+      `${json.delay}s (${Math.floor(json.delay / 60)}min)`;
+    document.getElementById("sequence").innerText = json.sequence;
+  }
+
 
   function initGeopos() {
     document.getElementById("error").innerText = "";
@@ -72,7 +85,7 @@
     ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/ping/ws");
     ws.onerror = wsError;
     ws.onclose = wsClose;
-    ws.onmessage = (msg) => console.log(msg.data); // TODO: display delays etc.
+    ws.onmessage = wsMsg
     ws.onopen = (event) => initGeopos();
   }
 
-- 
cgit v1.2.3