Server.GtfsRealtime: yet another TripUpdateTooOld

Google really is picky about these … and does not even seem willing to
tell which thresholds it uses …

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 .~
diff --git a/todo.org b/todo.org
index 8eb388c..eeed2c4 100644
--- a/todo.org
+++ b/todo.org
@@ -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