diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/API.hs | 2 | ||||
| -rw-r--r-- | lib/Server.hs | 10 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 48 |
3 files changed, 58 insertions, 2 deletions
@@ -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: '© <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 |