restructure: save a ticket's stop in the database

now mostly independent of the gtfs, but still no live-reloading of it.

1 files changed, 172 insertions, 102 deletions

diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 4fb5ba8..e89b184 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -17,12 +17,13 @@ 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.Function             (on, (&))
 import           Data.Functor              ((<&>))
-import           Data.List                 (lookup)
+import           Data.List                 (lookup, nubBy)
 import           Data.List.NonEmpty        (nonEmpty)
 import           Data.Map                  (Map)
 import qualified Data.Map                  as M
-import           Data.Maybe                (catMaybes, fromJust)
+import           Data.Maybe                (catMaybes, fromJust, isJust)
 import           Data.Pool                 (Pool)
 import           Data.Text                 (Text)
 import qualified Data.Text                 as T
@@ -42,7 +43,7 @@ import           Extrapolation             (Extrapolator (..),
 import           Fmt                       ((+|), (|+))
 import           GHC.Float                 (int2Double)
 import           GHC.Generics              (Generic)
-import           GTFS
+import qualified GTFS
 import           Numeric                   (showFFloat)
 import           Persist
 import           Server.Util               (Service, secondsNow)
@@ -60,7 +61,7 @@ import           Yesod.Orphans             ()
 
 
 data ControlRoom = ControlRoom
-  { getGtfs     :: GTFS
+  { getGtfs     :: GTFS.GTFS
   , getPool     :: Pool SqlBackend
   , getSettings :: ServerConfig
   }
@@ -70,17 +71,21 @@ mkMessage "ControlRoom" "messages" "en"
 mkYesod "ControlRoom" [parseRoutes|
 / RootR GET
 /auth AuthR Auth getAuth
-/trains TrainsR GET
-/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
+
+/tickets TicketsR GET
+/ticket/#UUID TicketViewR GET
+/ticket/map/#UUID TicketMapViewR GET
+/ticket/announce/#UUID AnnounceR POST
+/ticket/del-announce/#UUID DelAnnounceR GET
+
 /token/block/#Token TokenBlock GET
-/trips TripsViewR GET
-/trip/#TripId TripViewR GET
+
+/gtfs/trips GtfsTripsViewR GET
+/gtfs/trip/#GTFS.TripId GtfsTripViewR GET
+/gtfs/import/#Day GtfsTicketImportR POST
+
 /obu OnboardUnitMenuR GET
-/obu/#TripId/#Day OnboardUnitR GET
+/obu/#UUID OnboardUnitR GET
 |]
 
 emptyMarkup :: MarkupM a -> Bool
@@ -90,10 +95,10 @@ emptyMarkup _         = False
 instance Yesod ControlRoom where
   authRoute _ = Just $ AuthR LoginR
   isAuthorized OnboardUnitMenuR _ = pure Authorized
-  isAuthorized (OnboardUnitR _ _) _ = pure Authorized
+  isAuthorized (OnboardUnitR _) _ = pure Authorized
   isAuthorized (AuthR _) _ = pure Authorized
   isAuthorized _ _ = do
-    UffdConfig{..} <- getYesod <&> getSettings <&> serverConfigLogin
+    UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings
     if uffdConfigEnable then maybeAuthId >>= \case
       Just _  -> pure Authorized
       Nothing -> pure AuthenticationRequired
@@ -176,10 +181,10 @@ instance YesodAuth ControlRoom where
 
 
 getRootR :: Handler Html
-getRootR = redirect TrainsR
+getRootR = redirect TicketsR
 
-getTrainsR :: Handler Html
-getTrainsR = do
+getTicketsR :: Handler Html
+getTicketsR = do
   req <- getRequest
   let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack)
   mdisplayname <- maybeAuthId <&> fmap uffdDisplayName
@@ -194,14 +199,13 @@ getTrainsR = do
   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))
+  tickets <- runDB $ selectList [ TicketDay ==. day ] [] >>= mapM (\ticket -> do
+    stops <- selectList [ StopTicket ==. entityKey ticket ] []
+    startStation <- getJust (stopStation $ entityVal $ head stops)
+    pure (ticket, startStation, fmap entityVal stops))
+
+  let trips = GTFS.tripsOnDay gtfs day
+
   (widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips)))
   defaultLayout $ do
     [whamlet|
@@ -209,77 +213,130 @@ getTrainsR = do
 $maybe name <- mdisplayname
   <p>_{MsgLoggedInAs name} - <a href="@{AuthR LogoutR}">_{MsgLogout}</a>
 <nav>
-  <a class="nav-left" href="@?{(TrainsR, [("day", prevday)])}">← #{prevday}
+  <a class="nav-left" href="@?{(TicketsR, [("day", prevday)])}">← #{prevday}
   $if isToday
     _{Msgtoday}
   $else
-    <a href="@{TrainsR}">_{Msgtoday}
-  <a class="nav-right" href="@?{(TrainsR, [("day", nextday)])}">#{nextday} →
+    <a href="@{TicketsR}">_{Msgtoday}
+  <a class="nav-right" href="@?{(TicketsR, [("day", nextday)])}">#{nextday} →
 <section>
   <h2>_{MsgTickets}
   <ol>
-   $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}
+   $forall (Entity (TicketKey ticketId) Ticket{..}, startStation, stops) <- tickets
+    <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{ticketTripName}</a>
+         : _{Msgdep} #{stopDeparture (head stops)} #{stationName startStation} → #{ticketHeadsign}
    $if null tickets
      <li style="text-align: center"><em>(_{MsgNone})
 <section>
   <h2>_{MsgAccordingToGtfs}
-  <form method=post action="@{TicketImportR day}" enctype=#{enctype}>
+  <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}>
     ^{widget}
     <button>_{MsgImportTrips}
 |]
 
-postTicketImportR :: Day -> Handler Html
-postTicketImportR day = do
+
+-- TODO: this function should probably look for duplicate imports
+postGtfsTicketImportR :: Day -> Handler Html
+postGtfsTicketImportR day = do
   gtfs <- getYesod <&> getGtfs
-  let trips = tripsOnDay gtfs day
+  let trips = GTFS.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|
+
+      shapeMap <- selected
+        <&> (\(trip@GTFS.Trip{..}, _) -> (GTFS.shapeId tripShape, tripShape))
+        & nubBy ((==) `on` fst)
+        & mapM (\(shapeId, shape) -> runDB $ do
+           key <- insert Shape
+           insertMany
+             $ shape
+             & GTFS.shapePoints
+             & V.indexed
+             & V.toList
+             <&> \(idx, pos) -> ShapePoint (Geopos pos) idx key
+           pure (shapeId, key))
+        <&> M.fromList
+
+      stationMap <- selected
+        <&> (\(trip@GTFS.Trip{..}, _) -> V.toList (tripStops <&> GTFS.stopStation))
+        & concat
+        & nubBy ((==) `on` GTFS.stationId)
+        & mapM (\GTFS.Station{..} -> runDB $ do
+            maybeExists <- selectFirst [ StationShortName ==. stationId ] []
+            case maybeExists of
+              Nothing -> do
+                key <- insert Station
+                  { stationGeopos = Geopos (stationLat, stationLon)
+                  , stationShortName = stationId , stationName }
+                pure (stationId, key)
+              Just (Entity key _) -> pure (stationId, key))
+        <&> M.fromList
+
+      selected
+        <&> (\(trip@GTFS.Trip{..}, day) ->
+            let
+              ticket = Ticket
+                   { ticketTripName = tripTripId, ticketDay = day, ticketImported = now
+                   , ticketSchedule_version = Nothing, ticketVehicle = Nothing
+                   , ticketCompleted = False, ticketHeadsign = gtfsHeadsign trip
+                   , ticketShape = fromJust (M.lookup (GTFS.shapeId tripShape) shapeMap)}
+              stops = V.toList tripStops <&> \GTFS.Stop{..} ticketId -> Stop
+                   { stopTicket = ticketId
+                   , stopStation = fromJust (M.lookup (GTFS.stationId stopStation) stationMap)
+                   , stopArrival, stopDeparture, stopSequence}
+            in (ticket, stops))
+        & unzip
+        & \(tickets, stops) -> runDB $ do
+            ticketIds <- insertMany tickets
+            forM (zip ticketIds stops) $ \(ticketId, unfinishedStops) ->
+              insertMany (fmap (\s -> s ticketId) unfinishedStops)
+
+      redirect (TicketsR, [("day", T.pack (iso8601Show day))])
+
+    FormFailure _ -> defaultLayout [whamlet|
 <section>
   <h2>_{MsgAccordingToGtfs}
-  <form method=post action="@{TicketImportR day}" enctype=#{enctype}>
+  <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}>
     ^{widget}
     <button>_{MsgImportTrips}
 |]
 
 getTicketViewR :: UUID -> Handler Html
 getTicketViewR ticketId = do
-  Ticket{..} <- runDB $ get (TicketKey ticketId)
+  let ticketKey = TicketKey ticketId
+  Ticket{..} <- runDB $ get ticketKey
      >>= \case {Nothing -> notFound; Just a -> pure a}
 
-  GTFS{..} <- getYesod <&> getGtfs
+  stops <- runDB $ selectList [StopTicket ==. ticketKey] [] >>= mapM (\stop -> do
+    station <- getJust (stopStation (entityVal stop))
+    pure (entityVal stop, station))
+
+  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
+
   (widget, enctype) <- generateFormPost (announceForm ticketId)
-  case M.lookup ticketTrip trips of
-    Nothing -> notFound
-    Just res@Trip{..} -> do
-      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 ticketDay
-      defaultLayout $ do
-        mr <- getMessageRender
-        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 ticketDay))])}">#{ticketDay}</a>
+
+  nowSeconds <- secondsNow ticketDay
+  defaultLayout $ do
+    mr <- getMessageRender
+    setTitle (toHtml (""+|mr MsgTrip|+" "+|ticketTripName|+" "+|mr Msgon|+" "+|ticketDay|+"" :: Text))
+    [whamlet|
+<h1>_{MsgTrip} #
+  <a href="@{GtfsTripViewR ticketTripName}">#{ticketTripName}
+  _{Msgon}
+  <a href="@?{(TicketsR, [("day", T.pack (iso8601Show ticketDay))])}">#{ticketDay}
 <section>
   <h2>_{MsgLive}
   <p><strong>_{MsgLastPing}: </strong>
     $maybe Entity _ TrainPing{..} <- lastPing
-      _{MsgTrainPing trainPingLat trainPingLong trainPingTimestamp}
+      _{MsgTrainPing (latitude trainPingGeopos) (longitude trainPingGeopos) trainPingTimestamp}
       (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>)
     $nothing
       <em>(_{MsgNoTrainPing})
@@ -289,12 +346,12 @@ getTicketViewR ticketId = do
         \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")})
     $nothing
       <em> (_{MsgNone})
-  <p><a href="@{TrainMapViewR ticketId}">_{MsgMap}</a>
+  <p><a href="@{TicketMapViewR ticketId}">_{MsgMap}</a>
 <section>
   <h2>_{MsgStops}
   <ol>
-    $forall Stop{..} <- tripStops
-      <li value="#{stopSequence}"> #{stopArrival} #{stationName stopStation}
+    $forall (Stop{..}, Station{..}) <- stops
+      <li value="#{stopSequence}"> #{stopArrival} #{stationName}
         $maybe history <- anchors
           $maybe delay <- guessDelay history (int2Double stopSequence)
             \ (#{delay})
@@ -329,16 +386,19 @@ getTicketViewR ticketId = do
                 guessAtSeconds = extrapolateAtSeconds LinearExtrapolator
 
 
-getTrainMapViewR :: UUID -> Handler Html
-getTrainMapViewR ticketId = do
+getTicketMapViewR :: UUID -> Handler Html
+getTicketMapViewR ticketId = do
   Ticket{..} <- runDB $ get (TicketKey ticketId)
     >>= \case { Nothing -> notFound ; Just ticket -> pure ticket }
-  GTFS{..} <- getYesod <&> getGtfs
+
+  stops <- runDB $ selectList [StopTicket ==. TicketKey ticketId] [] >>= mapM (\stop -> do
+    station <- getJust (stopStation (entityVal stop))
+    pure (entityVal stop, station))
+
   (widget, enctype) <- generateFormPost (announceForm ticketId)
-  case M.lookup ticketTrip trips of
-    Nothing -> notFound
-    Just res@Trip{..} -> do defaultLayout [whamlet|
-<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{tripName res} _{Msgon} #{ticketDay}</a>
+
+  defaultLayout [whamlet|
+<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{ticketTripName} _{Msgon} #{ticketDay}</a>
 <link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css"
      integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI="
      crossorigin=""/>
@@ -354,7 +414,7 @@ getTrainMapViewR ticketId = 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}/#{ticketDay}");
+  ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{UUID.toText ticketId}");
 
   var marker = null;
 
@@ -373,27 +433,27 @@ getTrainMapViewR ticketId = do
 
 
 
-getTripsViewR :: Handler Html
-getTripsViewR = do
-  GTFS{..} <- getYesod <&> getGtfs
+getGtfsTripsViewR :: Handler Html
+getGtfsTripsViewR = do
+  GTFS.GTFS{..} <- getYesod <&> getGtfs
   defaultLayout $ do
     setTitle "List of Trips"
     [whamlet|
 <h1>List of Trips
 <section><ul>
-  $forall trip@Trip{..} <- trips
-    <li><a href="@{TripViewR tripTripId}">#{tripName trip}</a>
-      : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
+  $forall trip@GTFS.Trip{..} <- trips
+    <li><a href="@{GtfsTripViewR tripTripId}">#{GTFS.tripName trip}</a>
+      : #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))}
 |]
 
 
-getTripViewR :: TripId -> Handler Html
-getTripViewR tripId = do
-  GTFS{..} <- getYesod <&> getGtfs
+getGtfsTripViewR :: GTFS.TripId -> Handler Html
+getGtfsTripViewR tripId = do
+  GTFS.GTFS{..} <- getYesod <&> getGtfs
   case M.lookup tripId trips of
     Nothing -> notFound
-    Just trip@Trip{..} -> defaultLayout [whamlet|
-<h1>_{MsgTrip} #{tripName trip}
+    Just trip@GTFS.Trip{..} -> defaultLayout [whamlet|
+<h1>_{MsgTrip} #{GTFS.tripName trip}
 <section>
   <h2>_{MsgInfo}
   <p><strong>_{MsgtripId}:</strong> #{tripTripId}
@@ -402,8 +462,8 @@ getTripViewR tripId = do
 <section>
   <h2>_{MsgStops}
   <ol>
-    $forall Stop{..} <- tripStops
-      <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation}
+    $forall GTFS.Stop{..} <- tripStops
+      <div>(#{stopSequence}) #{stopArrival} #{GTFS.stationName stopStation}
 <section>
   <h2>Dates
   <ul>
@@ -454,21 +514,28 @@ getTokenBlock token = do
 getOnboardUnitMenuR :: Handler Html
 getOnboardUnitMenuR = do
   day <- liftIO getCurrentTime <&> utctDay
-  gtfs <- getYesod <&> getGtfs
-  let trips = tripsOnDay gtfs day
+
+  tickets <-
+    runDB $ selectList [ TicketCompleted ==. False, TicketDay ==. day ] [] >>= mapM (\ticket -> do
+      firstStop <- selectFirst [StopTicket ==. entityKey ticket] [ Asc StopDeparture ]
+      pure (ticket, entityVal $ fromJust firstStop))
+
   defaultLayout $ do
     [whamlet|
 <h1>_{MsgOBU}
 <section>
   _{MsgChooseTrain}
-  $forall Trip{..} <- trips
+  $forall (Entity (TicketKey ticketId) Ticket{..}, firstStop) <- tickets
     <hr>
-    <a href="@{OnboardUnitR tripTripId day}">
-      #{tripTripId}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)}
+    <a href="@{OnboardUnitR ticketId}">
+      #{ticketTripName}: #{ticketHeadsign} #{stopDeparture firstStop}
 |]
 
-getOnboardUnitR :: TripId -> Day -> Handler Html
-getOnboardUnitR tripId day =
+getOnboardUnitR :: UUID -> Handler Html
+getOnboardUnitR ticketId = do
+  Ticket{..} <- runDB $ get (TicketKey ticketId) >>= \case
+    Nothing -> notFound
+    Just ticket -> pure ticket
   defaultLayout $(whamletFile "site/obu.hamlet")
 
 announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget)
@@ -481,7 +548,10 @@ announceForm ticketId = renderDivs $ Announcement
 
 
 
-tripImportForm :: [(Trip Deep Deep, Day)] -> Html -> MForm Handler (FormResult [(Trip Deep Deep, Day)], Widget)
+tripImportForm
+  :: [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)]
+  -> Html
+  -> MForm Handler (FormResult [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)], Widget)
 tripImportForm trips extra = do
   forms <- forM trips $ \(trip, day) -> do
     (aRes, aView) <- mreq checkBoxField "import" Nothing
@@ -491,15 +561,15 @@ tripImportForm trips extra = do
   let widget = toWidget [whamlet|
      #{extra}
      <ol>
-       $forall (trip@Trip{..}, day, res, view) <- forms
+       $forall (trip@GTFS.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}
+             _{MsgTrip} #{GTFS.tripName trip}
+               : _{Msgdep} #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} → #{gtfsHeadsign trip}
   |]
 
-  let (a :: FormResult [Maybe (Trip Deep Deep, Day)]) =
+  let (a :: FormResult [Maybe (GTFS.Trip GTFS.Deep GTFS.Deep, Day)]) =
         sequenceA (fmap (\(_,_,res,_) -> res) forms)
 
   pure (fmap catMaybes a, widget)
@@ -510,8 +580,8 @@ mightbe (Just a) = a
 mightbe Nothing  = ""
 
 
-headsign :: Trip 'Deep 'Deep -> Text
-headsign (Trip{..} :: Trip Deep Deep) =
+gtfsHeadsign :: GTFS.Trip GTFS.Deep GTFS.Deep -> Text
+gtfsHeadsign GTFS.Trip{..} =
   case tripHeadsign of
     Just headsign -> headsign
-    Nothing       -> stationName (stopStation (V.last tripStops))
+    Nothing       -> GTFS.stationName (GTFS.stopStation (V.last tripStops))