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;
+             }
           <body>
             $forall (status, msg) <- msgs
               <p class="message #{status}">#{msg}
@@ -199,6 +204,7 @@ getTrainViewR trip day = do
         \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")})
     $nothing
       <em> (_{MsgNone})
+  <p><a href="@{TrainMapViewR tripTripID day}">_{MsgMap}</a>
 <section>
   <h2>_{MsgStops}
   <ol>
@@ -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|
+<h1>_{MsgTrip} <a href="@{TrainViewR tripTripID day}">#{tripName res} _{Msgon} #{day}</a>
+<link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css"
+     integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI="
+     crossorigin=""/>
+<script src="https://unpkg.com/leaflet@1.9.3/dist/leaflet.js"
+     integrity="sha256-WBkoXOwTeyKclOHuWtc+i2uENFpDZ9YPdf5Hf+D7ewM="
+     crossorigin=""></script>
+<div id="map">
+<p id="status">
+<script>
+  let map = L.map('map');
+
+  L.tileLayer('https://tile.openstreetmap.org/{z}/{x}/{y}.png', {
+      attribution: '&copy; <a href="https://www.openstreetmap.org/copyright">OpenStreetMap</a> contributors'
+  }).addTo(map);
+
+  ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{tripTripID}/#{day}");
+
+  var marker = null;
+
+  ws.onmessage = (msg) => {
+    let json = JSON.parse(msg.data);
+    if (marker === null) {
+      marker = L.marker([json.lat, json.long]);
+      marker.addTo(map);
+    } else {
+      marker.setLatLng([json.lat, json.long]);
+    }
+    map.setView([json.lat, json.long], 13);
+    document.getElementById("status").innerText = "_{MsgLastPing}: "+json.lat+","+json.long+" ("+json.timestamp+")";
+  }
+|]
+
+
+
 getTripsViewR :: Handler Html
 getTripsViewR = do
   GTFS{..} <- getYesod <&> getGtfs
diff --git a/messages/de.msg b/messages/de.msg
index 7243173..425b7c2 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -19,6 +19,7 @@ NoTrainPing: keine empfangen
 raw: roh
 EstimatedDelay: Geschätzte Verspätung
 OnStationSequence idx: an Stationsindex #{idx}
+Map: Karte
 
 ChooseTrain: Fahrt auswählen
 TokenFailed: konnte kein Token erhalten
diff --git a/messages/en.msg b/messages/en.msg
index 161b716..2c1d861 100644
--- a/messages/en.msg
+++ b/messages/en.msg
@@ -27,6 +27,7 @@ NoTrainPing: none received
 raw: raw
 EstimatedDelay: Estimated Delay
 OnStationSequence idx@String: on station index #{idx}
+Map: Map
 
 OBU: Onboard-Unit
 ChooseTrain: Choose a Train
-- 
cgit v1.2.3