restructure: have "tickets" independent of gtfs

this is mostly meant to guard against the gtfs changing under
tracktrain, and not yet complete (e.g. a ticket does not yet save its
expected stops, which it probably should).

1 files changed, 151 insertions, 73 deletions

diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 773468a..4fb5ba8 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -1,16 +1,17 @@
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DefaultSignatures     #-}
-{-# LANGUAGE DeriveAnyClass        #-}
-{-# LANGUAGE LambdaCase            #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE RecordWildCards       #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeFamilies      #-}
 
 module Server.ControlRoom (ControlRoom(..)) where
 
-import           Control.Monad             (forM_, join)
+import           Config                    (ServerConfig (..), UffdConfig (..))
+import           Control.Monad             (forM, forM_, join)
 import           Control.Monad.Extra       (maybeM)
 import           Control.Monad.IO.Class    (MonadIO (liftIO))
 import qualified Data.Aeson                as A
@@ -21,6 +22,7 @@ import           Data.List                 (lookup)
 import           Data.List.NonEmpty        (nonEmpty)
 import           Data.Map                  (Map)
 import qualified Data.Map                  as M
+import           Data.Maybe                (catMaybes, fromJust)
 import           Data.Pool                 (Pool)
 import           Data.Text                 (Text)
 import qualified Data.Text                 as T
@@ -35,9 +37,14 @@ import           Database.Persist          (Entity (..), delete, entityVal, get,
                                             insert, selectList, (==.))
 import           Database.Persist.Sql      (PersistFieldSql, SqlBackend,
                                             runSqlPool)
+import           Extrapolation             (Extrapolator (..),
+                                            LinearExtrapolator (..))
 import           Fmt                       ((+|), (|+))
 import           GHC.Float                 (int2Double)
 import           GHC.Generics              (Generic)
+import           GTFS
+import           Numeric                   (showFFloat)
+import           Persist
 import           Server.Util               (Service, secondsNow)
 import           Text.Blaze.Html           (ToMarkup (..))
 import           Text.Blaze.Internal       (MarkupM (Empty))
@@ -46,16 +53,9 @@ import           Text.Shakespeare.Text
 import           Yesod
 import           Yesod.Auth
 import           Yesod.Auth.OAuth2.Prelude
-import           Yesod.Form
-
-import           Config                    (ServerConfig (..), UffdConfig (..))
-import           Extrapolation             (Extrapolator (..),
-                                            LinearExtrapolator (..))
-import           GTFS
-import           Numeric                   (showFFloat)
-import           Persist
 import           Yesod.Auth.OpenId         (IdentifierType (..), authOpenId)
 import           Yesod.Auth.Uffd           (UffdUser (..), uffdClient)
+import           Yesod.Form
 import           Yesod.Orphans             ()
 
 
@@ -71,15 +71,16 @@ mkYesod "ControlRoom" [parseRoutes|
 / RootR GET
 /auth AuthR Auth getAuth
 /trains TrainsR GET
-/train/id/#TripID/#Day TrainViewR GET
-/train/map/#TripID/#Day TrainMapViewR GET
-/train/announce/#TripID/#Day AnnounceR POST
+/train/id/#UUID TicketViewR GET
+/train/import/#Day TicketImportR POST
+/train/map/#UUID TrainMapViewR GET
+/train/announce/#UUID AnnounceR POST
 /train/del-announce/#UUID DelAnnounceR GET
 /token/block/#Token TokenBlock GET
 /trips TripsViewR GET
-/trip/#TripID TripViewR GET
+/trip/#TripId TripViewR GET
 /obu OnboardUnitMenuR GET
-/obu/#TripID/#Day OnboardUnitR GET
+/obu/#TripId/#Day OnboardUnitR GET
 |]
 
 emptyMarkup :: MarkupM a -> Bool
@@ -191,7 +192,17 @@ getTrainsR = do
   let prevday = (T.pack . iso8601Show . addDays (-1))  day
   let nextday = (T.pack . iso8601Show . addDays 1) day
   gtfs <- getYesod <&> getGtfs
+
+  -- TODO: tickets should have all trip information saved
+  tickets <- runDB $ selectList [ TicketDay ==. day ] []
+    <&> fmap (\(Entity (TicketKey ticketId) ticket) ->
+                (ticketId, ticket, fromJust $ M.lookup (ticketTrip ticket) (trips gtfs)))
+
   let trips = tripsOnDay gtfs day
+  let headsign (Trip{..} :: Trip Deep Deep) = case tripHeadsign of
+        Just headsign -> headsign
+        Nothing       -> stationName (stopStation (V.last tripStops))
+  (widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips)))
   defaultLayout $ do
     [whamlet|
 <h1> _{MsgTrainsOnDay (iso8601Show day)}
@@ -205,38 +216,71 @@ $maybe name <- mdisplayname
     <a href="@{TrainsR}">_{Msgtoday}
   <a class="nav-right" href="@?{(TrainsR, [("day", nextday)])}">#{nextday} →
 <section>
+  <h2>_{MsgTickets}
   <ol>
-   $forall trip@Trip{..} <- trips
-    <li><a href="@{TrainViewR tripTripID day}">_{MsgTrip} #{tripName trip}</a>
-         : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
-   $if null trips
+   $forall (ticketId, Ticket{..}, trip@Trip{..}) <- tickets
+    <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{tripName trip}</a>
+         : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} → #{headsign trip}
+   $if null tickets
      <li style="text-align: center"><em>(_{MsgNone})
+<section>
+  <h2>_{MsgAccordingToGtfs}
+  <form method=post action="@{TicketImportR day}" enctype=#{enctype}>
+    ^{widget}
+    <button>_{MsgImportTrips}
 |]
 
-getTrainViewR :: TripID -> Day -> Handler Html
-getTrainViewR trip day = do
+postTicketImportR :: Day -> Handler Html
+postTicketImportR day = do
+  gtfs <- getYesod <&> getGtfs
+  let trips = tripsOnDay gtfs day
+  ((result, widget), enctype) <- runFormPost (tripImportForm (fmap (,day) (M.elems trips)))
+  case result of
+    FormSuccess selected -> do
+      now <- liftIO getCurrentTime
+      let tickets = flip fmap selected $ \(Trip{..}, day) -> Ticket
+            { ticketTrip = tripTripId, ticketDay = day, ticketImported = now
+            , ticketSchedule_version = Nothing, ticketVehicle = Nothing }
+      runDB $ insertMany tickets
+      redirect (TrainsR, [("day", T.pack (iso8601Show day))])
+    _ -> defaultLayout [whamlet|
+<section>
+  <h2>_{MsgAccordingToGtfs}
+  <form method=post action="@{TicketImportR day}" enctype=#{enctype}>
+    ^{widget}
+    <button>_{MsgImportTrips}
+|]
+
+getTicketViewR :: UUID -> Handler Html
+getTicketViewR ticketId = do
+  Ticket{..} <- runDB $ get (TicketKey ticketId)
+     >>= \case {Nothing -> notFound; Just a -> pure a}
+
   GTFS{..} <- getYesod <&> getGtfs
-  (widget, enctype) <- generateFormPost (announceForm day trip)
-  case M.lookup trip trips of
+  (widget, enctype) <- generateFormPost (announceForm ticketId)
+  case M.lookup ticketTrip trips of
     Nothing -> notFound
     Just res@Trip{..} -> do
-      anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
-      tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [Asc RunningExpires]
-      lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp]
-      anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] []
+      let ticketKey = TicketKey ticketId
+      anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] []
+      trackerIds <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] []
+        <&> fmap (trackerTicketTracker . entityVal)
+      trackers <- runDB $ selectList [ TrackerId <-. trackerIds ] [Asc TrackerExpires]
+      lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey trackers ] [Desc TrainPingTimestamp]
+      anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] []
         <&> nonEmpty . fmap entityVal
-      nowSeconds <- secondsNow day
+      nowSeconds <- secondsNow ticketDay
       defaultLayout $ do
         mr <- getMessageRender
-        setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text))
+        setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripId|+" "+|mr Msgon|+" "+|ticketDay|+"" :: Text))
         [whamlet|
-<h1>_{MsgTrip} <a href="@{TripViewR tripTripID}">#{tripName res}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{day}</a>
+<h1>_{MsgTrip} <a href="@{TripViewR tripTripId}">#{tripName res}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show ticketDay))])}">#{ticketDay}</a>
 <section>
   <h2>_{MsgLive}
   <p><strong>_{MsgLastPing}: </strong>
     $maybe Entity _ TrainPing{..} <- lastPing
       _{MsgTrainPing trainPingLat trainPingLong trainPingTimestamp}
-      (<a href="/api/debug/pings/#{trip}/#{day}">_{Msgraw}</a>)
+      (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>)
     $nothing
       <em>(_{MsgNoTrainPing})
   <p><strong>_{MsgEstimatedDelay}</strong>:
@@ -245,7 +289,7 @@ getTrainViewR trip day = do
         \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")})
     $nothing
       <em> (_{MsgNone})
-  <p><a href="@{TrainMapViewR tripTripID day}">_{MsgMap}</a>
+  <p><a href="@{TrainMapViewR ticketId}">_{MsgMap}</a>
 <section>
   <h2>_{MsgStops}
   <ol>
@@ -262,21 +306,21 @@ getTrainViewR trip day = do
     $if null anns
       <li><em>(_{MsgNone})</em>
   <h3>_{MsgNewAnnouncement}
-  <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
+  <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}>
     ^{widget}
     <button>_{MsgSubmit}
 <section>
   <h2>_{MsgTokens}
   <table>
     <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th>
-    $if null tokens
+    $if null trackers
       <tr><td></td><td style="text-align:center"><em>(_{MsgNone})
-    $forall Entity (RunningKey key) Running{..} <- tokens
-      <tr :runningBlocked:.blocked>
-        <td title="#{runningAgent}">#{runningAgent}
+    $forall Entity (TrackerKey key) Tracker{..} <- trackers
+      <tr :trackerBlocked:.blocked>
+        <td title="#{trackerAgent}">#{trackerAgent}
         <td title="#{key}">#{key}
-        <td title="#{runningExpires}">#{runningExpires}
-        $if runningBlocked
+        <td title="#{trackerExpires}">#{trackerExpires}
+        $if trackerBlocked
           <td title="_{MsgUnblockToken}"><a href="@?{(TokenBlock key, [("unblock", "true")])}">_{MsgUnblockToken}</a>
         $else
           <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a>
@@ -285,14 +329,16 @@ getTrainViewR trip day = do
                 guessAtSeconds = extrapolateAtSeconds LinearExtrapolator
 
 
-getTrainMapViewR :: TripID -> Day -> Handler Html
-getTrainMapViewR tripId day = do
+getTrainMapViewR :: UUID -> Handler Html
+getTrainMapViewR ticketId = do
+  Ticket{..} <- runDB $ get (TicketKey ticketId)
+    >>= \case { Nothing -> notFound ; Just ticket -> pure ticket }
   GTFS{..} <- getYesod <&> getGtfs
-  (widget, enctype) <- generateFormPost (announceForm day tripId)
-  case M.lookup tripId trips of
+  (widget, enctype) <- generateFormPost (announceForm ticketId)
+  case M.lookup ticketTrip trips of
     Nothing -> notFound
     Just res@Trip{..} -> do defaultLayout [whamlet|
-<h1>_{MsgTrip} <a href="@{TrainViewR tripTripID day}">#{tripName res} _{Msgon} #{day}</a>
+<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{tripName res} _{Msgon} #{ticketDay}</a>
 <link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css"
      integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI="
      crossorigin=""/>
@@ -308,7 +354,7 @@ getTrainMapViewR tripId day = do
       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}");
+  ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{tripTripId}/#{ticketDay}");
 
   var marker = null;
 
@@ -336,12 +382,12 @@ getTripsViewR = do
 <h1>List of Trips
 <section><ul>
   $forall trip@Trip{..} <- trips
-    <li><a href="@{TripViewR tripTripID}">#{tripName trip}</a>
+    <li><a href="@{TripViewR tripTripId}">#{tripName trip}</a>
       : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
 |]
 
 
-getTripViewR :: TripID -> Handler Html
+getTripViewR :: TripId -> Handler Html
 getTripViewR tripId = do
   GTFS{..} <- getYesod <&> getGtfs
   case M.lookup tripId trips of
@@ -350,7 +396,7 @@ getTripViewR tripId = do
 <h1>_{MsgTrip} #{tripName trip}
 <section>
   <h2>_{MsgInfo}
-  <p><strong>_{MsgtripId}:</strong> #{tripTripID}
+  <p><strong>_{MsgtripId}:</strong> #{tripTripId}
   <p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign}
   <p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName}
 <section>
@@ -365,17 +411,17 @@ getTripViewR tripId = do
 |]
 
 
-postAnnounceR :: TripID -> Day -> Handler Html
-postAnnounceR trip day = do
-    ((result, widget), enctype) <- runFormPost (announceForm day trip)
+postAnnounceR :: UUID -> Handler Html
+postAnnounceR ticketId = do
+    ((result, widget), enctype) <- runFormPost (announceForm ticketId)
     case result of
         FormSuccess ann -> do
           runDB $ insert ann
-          redirect (TrainViewR trip day)
+          redirect RootR -- (TicketViewR trip day)
         _ -> defaultLayout
             [whamlet|
                 <p>_{MsgInvalidInput}.
-                <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
+                <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}>
                     ^{widget}
                     <button>_{MsgSubmit}
             |]
@@ -389,19 +435,20 @@ getDelAnnounceR uuid = do
   case ann of
     Nothing -> notFound
     Just Announcement{..} ->
-      redirect (TrainViewR announcementTrip announcementDay)
+      let (TicketKey ticketId) = announcementTicket
+      in redirect (TicketViewR ticketId)
 
 getTokenBlock :: Token -> Handler Html
 getTokenBlock token = do
   YesodRequest{..} <- getRequest
   let blocked = lookup "unblock" reqGetParams /= Just "true"
   maybe <- runDB $ do
-    update (RunningKey token) [ RunningBlocked =. blocked ]
-    get (RunningKey token)
+    update (TrackerKey token) [ TrackerBlocked =. blocked ]
+    get (TrackerKey token)
   case maybe of
-    Just r@Running{..} -> do
+    Just r@Tracker{..} -> do
       liftIO $ print r
-      redirect (TrainViewR runningTrip runningDay)
+      redirect RootR
     Nothing -> notFound
 
 getOnboardUnitMenuR :: Handler Html
@@ -416,24 +463,55 @@ getOnboardUnitMenuR = do
   _{MsgChooseTrain}
   $forall Trip{..} <- trips
     <hr>
-    <a href="@{OnboardUnitR tripTripID day}">
-      #{tripTripID}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)}
+    <a href="@{OnboardUnitR tripTripId day}">
+      #{tripTripId}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)}
 |]
 
-getOnboardUnitR :: TripID -> Day -> Handler Html
+getOnboardUnitR :: TripId -> Day -> Handler Html
 getOnboardUnitR tripId day =
   defaultLayout $(whamletFile "site/obu.hamlet")
 
-announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget)
-announceForm day tripId = renderDivs $ Announcement
-  <$> pure tripId
+announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget)
+announceForm ticketId = renderDivs $ Announcement
+  <$> pure (TicketKey ticketId)
   <*> areq textField (fieldSettingsLabel MsgHeader) Nothing
   <*> areq textField (fieldSettingsLabel MsgText) Nothing
-  <*> pure day
   <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing
   <*> lift (liftIO getCurrentTime <&> Just)
 
+
+
+tripImportForm :: [(Trip Deep Deep, Day)] -> Html -> MForm Handler (FormResult [(Trip Deep Deep, Day)], Widget)
+tripImportForm trips extra = do
+  forms <- forM trips $ \(trip, day) -> do
+    (aRes, aView) <- mreq checkBoxField "import" Nothing
+    let dings = fmap (\res -> if res then Just (trip, day) else Nothing) aRes
+    pure (trip, day, dings, aView)
+
+  let widget = toWidget [whamlet|
+     #{extra}
+     <ol>
+       $forall (trip@Trip{..}, day, res, view) <- forms
+         <li>
+           ^{fvInput view}
+           <label for="^{fvId view}">
+             _{MsgTrip} #{tripName trip}
+               : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} → #{headsign trip}
+  |]
+
+  let (a :: FormResult [Maybe (Trip Deep Deep, Day)]) =
+        sequenceA (fmap (\(_,_,res,_) -> res) forms)
+
+  pure (fmap catMaybes a, widget)
+
+
 mightbe :: Maybe Text -> Text
 mightbe (Just a) = a
 mightbe Nothing  = ""
 
+
+headsign :: Trip 'Deep 'Deep -> Text
+headsign (Trip{..} :: Trip Deep Deep) =
+  case tripHeadsign of
+    Just headsign -> headsign
+    Nothing       -> stationName (stopStation (V.last tripStops))