diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 14 |
1 files changed, 10 insertions, 4 deletions
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 .~ |