diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 47 |
1 files changed, 26 insertions, 21 deletions
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs index 5ad4b40..4b16a5b 100644 --- a/lib/Server/GTFS_RT.hs +++ b/lib/Server/GTFS_RT.hs @@ -8,6 +8,7 @@ module Server.GTFS_RT (gtfsRealtimeServer) where import API (GtfsRealtimeAPI) +import Config (ServerConfig (..)) import Control.Lens ((&), (.~)) import Control.Monad (forM) import Control.Monad.Extra (mapMaybeM) @@ -45,10 +46,10 @@ import GTFS (Depth (..), GTFS (..), toSeconds, toUTC, tripsOnDay) import Persist (Announcement (..), EntityField (..), Key (..), - Station (..), Stop (..), - Ticket (..), Token (..), - Tracker (..), TrainAnchor (..), - TrainPing (..), latitude, + Ping (..), Station (..), + Stop (..), Ticket (..), + Tracker (..), TrackerId (..), + TrainAnchor (..), latitude, longitude, runSql) import qualified Proto.GtfsRealtime as RT import qualified Proto.GtfsRealtime_Fields as RT @@ -69,17 +70,22 @@ toStupidDate date = toStupidTime :: Num i => UTCTime -> i toStupidTime = fromIntegral . systemSeconds . utcToSystemTime -gtfsRealtimeServer :: GTFS -> Pool SqlBackend -> Service GtfsRealtimeAPI -gtfsRealtimeServer gtfs@GTFS{..} dbpool = +gtfsRealtimeServer :: ServerConfig -> GTFS -> Pool SqlBackend -> Service GtfsRealtimeAPI +gtfsRealtimeServer settings@ServerConfig{..} gtfs@GTFS{..} dbpool = handleServiceAlerts :<|> handleTripUpdates :<|> handleVehiclePositions + where - handleServiceAlerts = runSql dbpool $ do + + -- return an empty message if we're in silent mode & not force=yes + doNothingIfSilent m force = + if serverConfigBeSilent && not force then defFeedMessage mempty + else m >>= defFeedMessage + + handleServiceAlerts = doNothingIfSilent $ runSql dbpool $ do announcements <- selectList [] [] - alerts <- forM announcements $ \(Entity (AnnouncementKey uuid) announcement@Announcement{..}) -> do + forM announcements $ \(Entity (AnnouncementKey uuid) announcement@Announcement{..}) -> do ticket <- getJust announcementTicket pure $ mkAlert uuid announcement ticket - defFeedMessage alerts - where mkAlert :: UUID.UUID -> Announcement -> Ticket -> RT.FeedEntity mkAlert uuid Announcement{..} Ticket{..} = @@ -95,7 +101,7 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = & RT.descriptionText .~ monolingual "de" announcementMessage ) - handleTripUpdates = runSql dbpool $ do + handleTripUpdates = doNothingIfSilent $ runSql dbpool $ do now <- liftIO getCurrentTime let today = utctDay now nowSeconds <- secondsNow today @@ -154,25 +160,24 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = & RT.uncertainty .~ 60 ) & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED + pure (catMaybes tripUpdates) - defFeedMessage (catMaybes tripUpdates) - - handleVehiclePositions = runSql dbpool $ do + handleVehiclePositions = doNothingIfSilent $ runSql dbpool $ do ticket <- selectList [TicketCompleted ==. False] [] -- TODO: reimplement this (since trainpings no longer reference tickets it's gone for now) -- positions <- forM ticket $ \(Entity key ticket) -> do - -- selectFirst [TrainPingTicket ==. key] [Desc TrainPingTimestamp] >>= \case + -- selectFirst [PingTicket ==. key] [Desc PingTimestamp] >>= \case -- Nothing -> pure Nothing -- Just lastPing -> -- pure (Just $ mkPosition (lastPing, ticket)) - defFeedMessage [] -- (catMaybes positions) + pure [] -- (catMaybes positions) where - mkPosition :: (Entity TrainPing, Ticket) -> RT.FeedEntity - mkPosition (Entity key TrainPing{..}, Ticket{..}) = defMessage + mkPosition :: (Entity Ping, Ticket) -> RT.FeedEntity + mkPosition (Entity key Ping{..}, Ticket{..}) = defMessage & RT.id .~ T.pack (show key) & RT.vehicle .~ (defMessage & RT.trip .~ defTripDescriptor ticketTripName Nothing Nothing @@ -181,11 +186,11 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = Just trainset -> Just $ defMessage & RT.label .~ trainset & RT.position .~ (defMessage - & RT.latitude .~ double2Float (latitude trainPingGeopos) - & RT.longitude .~ double2Float (longitude trainPingGeopos) + & RT.latitude .~ double2Float (latitude pingGeopos) + & RT.longitude .~ double2Float (longitude pingGeopos) ) -- TODO: should probably give currentStopSequence/stopId here as well - & RT.timestamp .~ toStupidTime trainPingTimestamp + & RT.timestamp .~ toStupidTime pingTimestamp ) |