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, 30 insertions, 19 deletions

diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index 740f71c..412284f 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -1,8 +1,9 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE TupleSections         #-}
-{-# LANGUAGE DataKinds #-}
 
 module Server.GTFS_RT (gtfsRealtimeServer) where
 
@@ -30,21 +31,22 @@ import qualified Data.UUID                   as UUID
 import qualified Data.Vector                 as V
 import           Database.Persist            (Entity (..),
                                               PersistQueryRead (selectFirst),
-                                              selectList, (==.))
+                                              getJust, selectKeysList,
+                                              selectList, (<-.), (==.))
 import           Database.Persist.Postgresql (SqlBackend)
 import           Extrapolation               (Extrapolator (extrapolateAtPosition, extrapolateAtSeconds),
                                               LinearExtrapolator (..))
 import           GHC.Float                   (double2Float, int2Double)
 import           GTFS                        (Depth (..), GTFS (..),
                                               Seconds (..), Stop (..),
-                                              Trip (..), TripID,
+                                              Trip (..), TripId,
                                               showTimeWithSeconds, stationId,
                                               toSeconds, toUTC, tripsOnDay)
 import           Persist                     (Announcement (..),
                                               EntityField (..), Key (..),
-                                              Running (..), Token (..),
-                                              TrainAnchor (..), TrainPing (..),
-                                              runSql)
+                                              Ticket (..), Token (..),
+                                              Tracker (..), TrainAnchor (..),
+                                              TrainPing (..), runSql)
 import qualified Proto.GtfsRealtime          as RT
 import qualified Proto.GtfsRealtime_Fields   as RT
 import           Servant.API                 ((:<|>) (..))
@@ -70,17 +72,20 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
   where
     handleServiceAlerts = runSql dbpool $ do
       announcements <- selectList [] []
-      defFeedMessage (fmap mkAlert announcements)
+      alerts <- forM announcements $ \(Entity (AnnouncementKey uuid) announcement@Announcement{..}) -> do
+        ticket <- getJust announcementTicket
+        pure $ mkAlert uuid announcement ticket
+      defFeedMessage alerts
 
       where
-        mkAlert :: Entity Announcement -> RT.FeedEntity
-        mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) =
+        mkAlert :: UUID.UUID -> Announcement -> Ticket -> RT.FeedEntity
+        mkAlert uuid Announcement{..} Ticket{..} =
               defMessage
               & RT.id .~ UUID.toText uuid
               & RT.alert .~ (defMessage
                   & RT.activePeriod .~ [ defMessage :: RT.TimeRange ]
                   & RT.informedEntity .~ [ defMessage
-                       & RT.trip .~ defTripDescriptor announcementTrip (Just announcementDay) Nothing
+                       & RT.trip .~ defTripDescriptor ticketTrip (Just ticketDay) Nothing
                     ]
                   & RT.maybe'url .~ fmap (monolingual "de") announcementUrl
                   & RT.headerText .~ monolingual "de" announcementHeader
@@ -92,7 +97,8 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
       nowSeconds <- secondsNow today
       let running = M.toList (tripsOnDay gtfs today)
       anchors <- flip mapMaybeM running $ \(tripId, trip@Trip{..}) -> do
-        entities <- selectList [TrainAnchorTrip ==. tripId, TrainAnchorDay ==. today] []
+        tickets <- selectKeysList [TicketTrip ==. tripId, TicketDay ==. today] []
+        entities <- selectList [TrainAnchorTicket <-. tickets] []
         case nonEmpty (fmap entityVal entities) of
           Nothing      -> pure Nothing
           Just anchors -> pure $ Just (tripId, trip, anchors)
@@ -138,18 +144,23 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
               & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED
 
     handleVehiclePositions = runSql dbpool $ do
-      (running :: [Entity Running]) <- selectList [] []
-      pings <- forM running $ \(Entity key entity) -> do
-        selectFirst [TrainPingToken ==. key] [] <&> fmap (, entity)
+      (trackers :: [Entity Tracker]) <- selectList [] []
+      pings <- forM trackers $ \(Entity trackerId tracker) -> do
+        selectFirst [TrainPingToken ==. trackerId] [] >>= \case
+          Nothing -> pure Nothing
+          Just ping -> do
+            ticket <- getJust (trainPingTicket (entityVal ping))
+            pure (Just (ping, ticket, tracker))
+
       defFeedMessage (mkPosition <$> catMaybes pings)
 
       where
-        mkPosition :: (Entity TrainPing, Running) -> RT.FeedEntity
-        mkPosition (Entity (TrainPingKey key) TrainPing{..}, Running{..}) = defMessage
+        mkPosition :: (Entity TrainPing, Ticket, Tracker) -> RT.FeedEntity
+        mkPosition (Entity (TrainPingKey key) TrainPing{..}, Ticket{..}, Tracker{..}) = defMessage
           & RT.id .~ T.pack (show key)
           & RT.vehicle .~ (defMessage
-              & RT.trip .~ defTripDescriptor runningTrip Nothing Nothing
-              & RT.maybe'vehicle .~ case runningVehicle of
+              & RT.trip .~ defTripDescriptor ticketTrip Nothing Nothing
+              & RT.maybe'vehicle .~ case ticketVehicle of
                   Nothing -> Nothing
                   Just trainset -> Just $ defMessage
                     & RT.label .~ trainset
@@ -180,7 +191,7 @@ defFeedMessage entities = do
    )
    & RT.entity .~ entities
 
-defTripDescriptor :: TripID -> Maybe Day -> Maybe Text -> RT.TripDescriptor
+defTripDescriptor :: TripId -> Maybe Day -> Maybe Text -> RT.TripDescriptor
 defTripDescriptor tripId day starttime = defMessage
   & RT.tripId .~ tripId
   & RT.scheduleRelationship .~ RT.TripDescriptor'SCHEDULED