restructure: save a ticket's stop in the database

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

2 files changed, 234 insertions, 155 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))
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index 412284f..48a84db 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -12,6 +12,7 @@ import           Control.Lens                ((&), (.~))
 import           Control.Monad               (forM)
 import           Control.Monad.Extra         (mapMaybeM)
 import           Control.Monad.IO.Class      (MonadIO (..))
+import           Data.Coerce                 (coerce)
 import           Data.Functor                ((<&>))
 import           Data.List.NonEmpty          (NonEmpty, nonEmpty)
 import qualified Data.Map                    as M
@@ -31,6 +32,7 @@ import qualified Data.UUID                   as UUID
 import qualified Data.Vector                 as V
 import           Database.Persist            (Entity (..),
                                               PersistQueryRead (selectFirst),
+                                              SelectOpt (Asc, Desc), get,
                                               getJust, selectKeysList,
                                               selectList, (<-.), (==.))
 import           Database.Persist.Postgresql (SqlBackend)
@@ -38,15 +40,16 @@ import           Extrapolation               (Extrapolator (extrapolateAtPositio
                                               LinearExtrapolator (..))
 import           GHC.Float                   (double2Float, int2Double)
 import           GTFS                        (Depth (..), GTFS (..),
-                                              Seconds (..), Stop (..),
-                                              Trip (..), TripId,
+                                              Seconds (..), Trip (..), TripId,
                                               showTimeWithSeconds, stationId,
                                               toSeconds, toUTC, tripsOnDay)
 import           Persist                     (Announcement (..),
                                               EntityField (..), Key (..),
+                                              Station (..), Stop (..),
                                               Ticket (..), Token (..),
                                               Tracker (..), TrainAnchor (..),
-                                              TrainPing (..), runSql)
+                                              TrainPing (..), latitude,
+                                              longitude, runSql)
 import qualified Proto.GtfsRealtime          as RT
 import qualified Proto.GtfsRealtime_Fields   as RT
 import           Servant.API                 ((:<|>) (..))
@@ -85,7 +88,7 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
               & RT.alert .~ (defMessage
                   & RT.activePeriod .~ [ defMessage :: RT.TimeRange ]
                   & RT.informedEntity .~ [ defMessage
-                       & RT.trip .~ defTripDescriptor ticketTrip (Just ticketDay) Nothing
+                       & RT.trip .~ defTripDescriptor ticketTripName (Just ticketDay) Nothing
                     ]
                   & RT.maybe'url .~ fmap (monolingual "de") announcementUrl
                   & RT.headerText .~ monolingual "de" announcementHeader
@@ -95,78 +98,84 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
     handleTripUpdates = runSql dbpool $ do
       today <- liftIO $ getCurrentTime <&> utctDay
       nowSeconds <- secondsNow today
-      let running = M.toList (tripsOnDay gtfs today)
-      anchors <- flip mapMaybeM running $ \(tripId, trip@Trip{..}) -> do
-        tickets <- selectKeysList [TicketTrip ==. tripId, TicketDay ==. today] []
-        entities <- selectList [TrainAnchorTicket <-. tickets] []
-        case nonEmpty (fmap entityVal entities) of
+      -- let running = M.toList (tripsOnDay gtfs today)
+      tickets <- selectList [TicketCompleted ==. False] [Asc TicketTripName]
+
+      tripUpdates <- forM tickets $ \(Entity key Ticket{..}) -> do
+        selectList [TrainAnchorTicket ==. key] [] >>= \a -> case nonEmpty a of
           Nothing      -> pure Nothing
-          Just anchors -> pure $ Just (tripId, trip, anchors)
+          Just anchors -> do
+            stops <- selectList [StopTicket ==. key] [Asc StopArrival] >>= mapM (\(Entity _ stop) -> do
+              station <- getJust (stopStation stop)
+              pure (stop, station))
 
-      defFeedMessage (mapMaybe (mkTripUpdate today nowSeconds) anchors)
-      where
-        mkTripUpdate :: Day -> Seconds -> (Text, Trip 'Deep 'Deep, NonEmpty TrainAnchor) -> Maybe RT.FeedEntity
-        mkTripUpdate today nowSeconds (tripId :: Text, Trip{..} :: Trip Deep Deep, anchors) =
-              let lastCall = extrapolateAtSeconds LinearExtrapolator anchors nowSeconds
-                  stations = tripStops
-                    <&> (\stop@Stop{..} -> (, stop)
-                          <$> extrapolateAtPosition LinearExtrapolator anchors (int2Double stopSequence))
-                  (lastAnchor, lastStop) = V.last (V.catMaybes stations)
-                  stillRunning = trainAnchorDelay lastAnchor + toSeconds (stopArrival lastStop) tzseries today
+            let anchorEntities = fmap entityVal anchors
+            let lastCall = extrapolateAtSeconds LinearExtrapolator anchorEntities nowSeconds
+            let atStations = flip fmap stops $ \(stop, station) ->
+                  (, stop, station) <$> extrapolateAtPosition LinearExtrapolator anchorEntities (int2Double (stopSequence stop))
+            let (lastAnchor, lastStop, lastStation) = last (catMaybes atStations)
+            let stillRunning = trainAnchorDelay lastAnchor + toSeconds (stopArrival lastStop) tzseries today
                     < nowSeconds + 5 * 60
-              in if not stillRunning then Nothing else Just $ defMessage
-                & RT.id .~ (tripId <> "-" <> T.pack (iso8601Show today))
-                & RT.tripUpdate .~ (defMessage
-                    & RT.trip .~ defTripDescriptor tripId (Just today) (Just $ T.pack (showTimeWithSeconds $ stopDeparture $ V.head tripStops))
-                    & RT.stopTimeUpdate .~ fmap mkStopTimeUpdate (catMaybes $ V.toList stations)
-                    & RT.maybe'delay .~ Nothing -- lastCall <&> (fromIntegral . unSeconds . trainAnchorDelay)
-                    & RT.maybe'timestamp .~ fmap (toStupidTime . trainAnchorCreated) lastCall
-                )
-          where
-            mkStopTimeUpdate :: (TrainAnchor, Stop Deep) -> RT.TripUpdate'StopTimeUpdate
-            mkStopTimeUpdate (TrainAnchor{..}, Stop{..}) = defMessage
-              & RT.stopSequence .~ fromIntegral stopSequence
-              & RT.stopId .~ stationId stopStation
-              & RT.arrival .~ (defMessage
+
+            pure $ Just $ defMessage
+              & RT.id .~ UUID.toText (coerce key)
+              & RT.tripUpdate .~ (defMessage
+                 & RT.trip .~
+                   defTripDescriptor
+                     ticketTripName (Just today)
+                     (Just $ T.pack (showTimeWithSeconds $ stopDeparture $ fst $ head stops))
+                 & RT.stopTimeUpdate .~ fmap mkStopTimeUpdate (catMaybes atStations)
+                 & RT.maybe'delay .~ Nothing -- lastCall <&> (fromIntegral . unSeconds . trainAnchorDelay)
+                 & RT.maybe'timestamp .~ fmap (toStupidTime . trainAnchorCreated) lastCall
+              )
+            where
+              mkStopTimeUpdate :: (TrainAnchor, Stop, Station) -> RT.TripUpdate'StopTimeUpdate
+              mkStopTimeUpdate (TrainAnchor{..}, Stop{..}, Station{..}) = defMessage
+                & RT.stopSequence .~ fromIntegral stopSequence
+                & RT.stopId .~ stationShortName
+                & RT.arrival .~ (defMessage
                   & RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
                   & RT.time .~ toStupidTime (addUTCTime
                       (fromIntegral $ unSeconds trainAnchorDelay)
                       (toUTC stopArrival tzseries today))
                   & RT.uncertainty .~ 60
-              )
-              & RT.departure .~ (defMessage
-                  & RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
-                  & RT.time .~ toStupidTime (addUTCTime
+                )
+                & RT.departure .~ (defMessage
+                    & RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
+                    & RT.time .~ toStupidTime (addUTCTime
                       (fromIntegral $ unSeconds trainAnchorDelay)
                       (toUTC stopDeparture tzseries today))
-                  & RT.uncertainty .~ 60
-              )
-              & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED
+                    & RT.uncertainty .~ 60
+                )
+                & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED
+
+      defFeedMessage (catMaybes tripUpdates)
 
     handleVehiclePositions = runSql dbpool $ do
-      (trackers :: [Entity Tracker]) <- selectList [] []
-      pings <- forM trackers $ \(Entity trackerId tracker) -> do
-        selectFirst [TrainPingToken ==. trackerId] [] >>= \case
+
+      ticket <- selectList [TicketCompleted ==. False] []
+
+      positions <- forM ticket $ \(Entity key ticket) -> do
+        selectFirst [TrainPingTicket ==. key] [Desc TrainPingTimestamp] >>= \case
           Nothing -> pure Nothing
-          Just ping -> do
-            ticket <- getJust (trainPingTicket (entityVal ping))
-            pure (Just (ping, ticket, tracker))
+          Just lastPing ->
+            pure (Just $ mkPosition (lastPing, ticket))
 
-      defFeedMessage (mkPosition <$> catMaybes pings)
+      defFeedMessage (catMaybes positions)
 
       where
-        mkPosition :: (Entity TrainPing, Ticket, Tracker) -> RT.FeedEntity
-        mkPosition (Entity (TrainPingKey key) TrainPing{..}, Ticket{..}, Tracker{..}) = defMessage
+        mkPosition :: (Entity TrainPing, Ticket) -> RT.FeedEntity
+        mkPosition (Entity key TrainPing{..}, Ticket{..}) = defMessage
           & RT.id .~ T.pack (show key)
           & RT.vehicle .~ (defMessage
-              & RT.trip .~ defTripDescriptor ticketTrip Nothing Nothing
+              & RT.trip .~ defTripDescriptor ticketTripName Nothing Nothing
               & RT.maybe'vehicle .~ case ticketVehicle of
                   Nothing -> Nothing
                   Just trainset -> Just $ defMessage
                     & RT.label .~ trainset
               & RT.position .~ (defMessage
-                  & RT.latitude .~ double2Float trainPingLat
-                  & RT.longitude .~ double2Float trainPingLong
+                  & RT.latitude .~ double2Float (latitude trainPingGeopos)
+                  & RT.longitude .~ double2Float (longitude trainPingGeopos)
               )
               -- TODO: should probably give currentStopSequence/stopId here as well
               & RT.timestamp .~ toStupidTime trainPingTimestamp