diff options
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 14 | ||||
| -rw-r--r-- | todo.org | 2 |
2 files changed, 12 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 .~ @@ -16,6 +16,8 @@ that time, since we assume linear movement. ** DONE /tracker should remember its token, not constantly open a new one either via a cookie or url parameter & redirect ** DONE do not give tripupdates after tickets are completed or outdated +another update: this is also triggered for tickets which are still running, +but their last ping was a while ago. ** TODO tickets are not reliably marked completed ** TODO any kind of check against unrealistically fast travel? ** DONE matching of tokens to trip ought not to assume trips are at their start position |