aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/API.hs2
-rw-r--r--lib/Server.hs10
-rw-r--r--lib/Server/ControlRoom.hs48
3 files changed, 58 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