aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/Server/GTFS_RT.hs14
-rw-r--r--todo.org2
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