diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Server/Frontend/Routes.hs | 17 | ||||
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 14 |
2 files changed, 19 insertions, 12 deletions
diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs index 18cf0a1..9245e6a 100644 --- a/lib/Server/Frontend/Routes.hs +++ b/lib/Server/Frontend/Routes.hs @@ -69,11 +69,12 @@ instance Yesod Frontend where isAuthorized OnboardTrackerR _ = pure Authorized isAuthorized (AuthR _) _ = pure Authorized isAuthorized _ _ = do - UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings - if uffdConfigEnable then maybeAuthId >>= \case - Just _ -> pure Authorized - Nothing -> pure AuthenticationRequired - else pure Authorized + maybeUffd <- getYesod <&> serverConfigLogin . getSettings + case maybeUffd of + Nothing -> pure Authorized + Just UffdConfig{..} -> maybeAuthId >>= \case + Just _ -> pure Authorized + Nothing -> pure AuthenticationRequired defaultLayout w = do @@ -118,9 +119,9 @@ instance YesodAuth Frontend where type AuthId Frontend = UffdUser authPlugins cr = case config of - UffdConfig {..} -> if uffdConfigEnable - then [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ] - else [] + Just UffdConfig {..} -> + [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ] + Nothing -> [] where config = serverConfigLogin (getSettings cr) maybeAuthId = do diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs index 9c52e9c..5ad4b40 100644 --- a/lib/Server/GTFS_RT.hs +++ b/lib/Server/GTFS_RT.hs @@ -16,14 +16,14 @@ import Data.Coerce (coerce) import Data.Functor ((<&>)) import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.Map as M -import Data.Maybe (catMaybes, mapMaybe) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Pool (Pool) import Data.ProtoLens (defMessage) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day, toGregorian) import Data.Time.Clock (UTCTime (utctDay), addUTCTime, - getCurrentTime) + diffUTCTime, getCurrentTime) import Data.Time.Clock.System (SystemTime (systemSeconds), getSystemTime, utcToSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) @@ -96,7 +96,8 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = ) handleTripUpdates = runSql dbpool $ do - today <- liftIO $ getCurrentTime <&> utctDay + now <- liftIO getCurrentTime + let today = utctDay now nowSeconds <- secondsNow today -- let running = M.toList (tripsOnDay gtfs today) tickets <- selectList [TicketCompleted ==. False, TicketDay ==. today] [Asc TicketTripName] @@ -114,10 +115,15 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = let atStations = flip fmap stops $ \(stop, station) -> (, stop, station) <$> extrapolateAtPosition LinearExtrapolator anchorEntities (int2Double (stopSequence stop)) let (lastAnchor, lastStop, lastStation) = last (catMaybes atStations) + + -- google's TripUpdateTooOld does not like information on trips which have ended let stillRunning = trainAnchorDelay lastAnchor + toSeconds (stopArrival lastStop) tzseries today > nowSeconds + 5 * 60 + -- google's TripUpdateTooOld check fails if the given timestamp is older than ~ half an hour + let isOutdated = maybe False + (\a -> trainAnchorCreated a `diffUTCTime` now < 20 * 60) lastCall - pure $ if not stillRunning then Nothing else Just $ defMessage + pure $ if not stillRunning && not isOutdated then Nothing else Just $ defMessage & RT.id .~ UUID.toText (coerce key) & RT.tripUpdate .~ (defMessage & RT.trip .~ |