diff options
Diffstat (limited to '')
-rw-r--r-- | lib/Server/GTFS_RT.hs | 49 |
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 |