diff options
Diffstat (limited to 'lib/Server/GTFS_RT.hs')
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 27 |
1 files changed, 16 insertions, 11 deletions
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs index 5ad4b40..6ef6ed2 100644 --- a/lib/Server/GTFS_RT.hs +++ b/lib/Server/GTFS_RT.hs @@ -54,6 +54,7 @@ import qualified Proto.GtfsRealtime as RT import qualified Proto.GtfsRealtime_Fields as RT import Servant.API ((:<|>) (..)) import Server.Util (Service, secondsNow) +import Config (ServerConfig (..)) -- | formats a day in the "stupid" format used by gtfs realtime toStupidDate :: Day -> Text @@ -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,10 +160,9 @@ 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] [] @@ -168,7 +173,7 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = -- Just lastPing -> -- pure (Just $ mkPosition (lastPing, ticket)) - defFeedMessage [] -- (catMaybes positions) + pure [] -- (catMaybes positions) where mkPosition :: (Entity TrainPing, Ticket) -> RT.FeedEntity |