restructure: get the tracker to work again

This should hopefully be the final (major) part of the restructuring: a
tracker no longer has to know which trip it is on (and indeed it has no
idea for now), instead the server keeps state about which trips are
currently running and will insert incoming pings in a hopefully
reasonable manner, based on their geoposition & time.

There's lots of associated TODO items here (especially there should be
manual overrides for all this logic in the web ui), but that's work for
a future me.

(incidentally, this also adds support for sending all log messages out
via ntfy-sh)

1 files changed, 27 insertions, 12 deletions

diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 9d15bcf..5292620 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -17,6 +17,7 @@ import           Control.Monad.IO.Class    (MonadIO (liftIO))
 import qualified Data.Aeson                as A
 import qualified Data.ByteString.Char8     as C8
 import qualified Data.ByteString.Lazy      as LB
+import           Data.Coerce               (coerce)
 import           Data.Function             (on, (&))
 import           Data.Functor              ((<&>))
 import           Data.List                 (lookup, nubBy)
@@ -86,6 +87,7 @@ mkYesod "ControlRoom" [parseRoutes|
 
 /obu OnboardUnitMenuR GET
 /obu/#UUID OnboardUnitR GET
+/tracker OnboardTrackerR GET
 |]
 
 emptyMarkup :: MarkupM a -> Bool
@@ -96,6 +98,7 @@ instance Yesod ControlRoom where
   authRoute _ = Just $ AuthR LoginR
   isAuthorized OnboardUnitMenuR _ = pure Authorized
   isAuthorized (OnboardUnitR _) _ = pure Authorized
+  isAuthorized OnboardTrackerR _ = pure Authorized
   isAuthorized (AuthR _) _ = pure Authorized
   isAuthorized _ _ = do
     UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings
@@ -200,7 +203,7 @@ getTicketsR = do
   gtfs <- getYesod <&> getGtfs
 
   -- TODO: tickets should have all trip information saved
-  tickets <- runDB $ selectList [ TicketDay ==. day ] [] >>= mapM (\ticket -> do
+  tickets <- runDB $ selectList [ TicketDay ==. day ] [ Asc TicketTripName ] >>= mapM (\ticket -> do
     stops <- selectList [ StopTicket ==. entityKey ticket ] []
     startStation <- getJust (stopStation $ entityVal $ head stops)
     pure (ticket, startStation, fmap entityVal stops))
@@ -317,9 +320,11 @@ getTicketViewR ticketId = do
     pure (entityVal stop, station))
 
   anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] []
-  trackerIds <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] []
+  joins <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] []
     <&> fmap (trackerTicketTracker . entityVal)
-  trackers <- runDB $ selectList [ TrackerId <-. trackerIds ] [Asc TrackerExpires]
+  trackers <- runDB $ selectList
+    ([ TrackerId <-. joins ] ||. [ TrackerCurrentTicket ==. Just ticketKey ])
+    [Asc TrackerExpires]
   lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey trackers ] [Desc TrainPingTimestamp]
   anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] []
     <&> nonEmpty . fmap entityVal
@@ -511,7 +516,9 @@ getTokenBlock token = do
   case maybe of
     Just r@Tracker{..} -> do
       liftIO $ print r
-      redirect RootR
+      redirect $ case trackerCurrentTicket of
+        Just ticket -> TicketViewR (coerce ticket)
+        Nothing     -> RootR
     Nothing -> notFound
 
 getOnboardUnitMenuR :: Handler Html
@@ -525,14 +532,16 @@ getOnboardUnitMenuR = do
 
   defaultLayout $ do
     [whamlet|
-<h1>_{MsgOBU}
-<section>
-  _{MsgChooseTrain}
-  $forall (Entity (TicketKey ticketId) Ticket{..}, firstStop) <- tickets
-    <hr>
-    <a href="@{OnboardUnitR ticketId}">
-      #{ticketTripName}: #{ticketHeadsign} #{stopDeparture firstStop}
-|]
+      <h1>_{MsgOBU}
+      <section>
+       _{MsgChooseTrain}
+       $forall (Entity (TicketKey ticketId) Ticket{..}, firstStop) <- tickets
+         <hr>
+         <a href="@{OnboardUnitR ticketId}">
+          #{ticketTripName}: #{ticketHeadsign} #{stopDeparture firstStop}
+      <section>
+        <a href="@{OnboardTrackerR}">_{MsgStartTracking}
+    |]
 
 getOnboardUnitR :: UUID -> Handler Html
 getOnboardUnitR ticketId = do
@@ -541,6 +550,12 @@ getOnboardUnitR ticketId = do
     Just ticket -> pure ticket
   defaultLayout $(whamletFile "site/obu.hamlet")
 
+getOnboardTrackerR :: Handler Html
+getOnboardTrackerR = do
+  defaultLayout
+    $( whamletFile "site/tracker.hamlet")
+
+
 announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget)
 announceForm ticketId = renderDivs $ Announcement
   <$> pure (TicketKey ticketId)