aboutsummaryrefslogtreecommitdiff
path: root/lib/Server/GTFS_RT.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Server/GTFS_RT.hs')
-rw-r--r--lib/Server/GTFS_RT.hs150
1 files changed, 88 insertions, 62 deletions
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index cfb02ce..5ad4b40 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
@@ -12,17 +12,18 @@ import Control.Lens ((&), (.~))
import Control.Monad (forM)
import Control.Monad.Extra (mapMaybeM)
import Control.Monad.IO.Class (MonadIO (..))
+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)
@@ -31,21 +32,24 @@ import qualified Data.UUID as UUID
import qualified Data.Vector as V
import Database.Persist (Entity (..),
PersistQueryRead (selectFirst),
- selectList, (==.))
+ SelectOpt (Asc, Desc), get,
+ getJust, selectKeysList,
+ selectList, (<-.), (==.))
import Database.Persist.Postgresql (SqlBackend)
import Extrapolation (Extrapolator (extrapolateAtPosition, extrapolateAtSeconds),
LinearExtrapolator (..))
import GHC.Float (double2Float, int2Double)
import GTFS (Depth (..), GTFS (..),
- Seconds (..), Stop (..),
- Trip (..), TripID,
+ Seconds (..), Trip (..), TripId,
showTimeWithSeconds, stationId,
toSeconds, toUTC, tripsOnDay)
import Persist (Announcement (..),
EntityField (..), Key (..),
- Running (..), Token (..),
- TrainAnchor (..), TrainPing (..),
- runSql)
+ Station (..), Stop (..),
+ Ticket (..), Token (..),
+ Tracker (..), TrainAnchor (..),
+ TrainPing (..), latitude,
+ longitude, runSql)
import qualified Proto.GtfsRealtime as RT
import qualified Proto.GtfsRealtime_Fields as RT
import Servant.API ((:<|>) (..))
@@ -71,17 +75,20 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
where
handleServiceAlerts = runSql dbpool $ do
announcements <- selectList [] []
- defFeedMessage (fmap mkAlert announcements)
+ alerts <- forM announcements $ \(Entity (AnnouncementKey uuid) announcement@Announcement{..}) -> do
+ ticket <- getJust announcementTicket
+ pure $ mkAlert uuid announcement ticket
+ defFeedMessage alerts
where
- mkAlert :: Entity Announcement -> RT.FeedEntity
- mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) =
+ mkAlert :: UUID.UUID -> Announcement -> Ticket -> RT.FeedEntity
+ mkAlert uuid Announcement{..} Ticket{..} =
defMessage
& RT.id .~ UUID.toText uuid
& RT.alert .~ (defMessage
& RT.activePeriod .~ [ defMessage :: RT.TimeRange ]
& RT.informedEntity .~ [ defMessage
- & RT.trip .~ defTripDescriptor announcementTrip (Just announcementDay) Nothing
+ & RT.trip .~ defTripDescriptor ticketTripName (Just ticketDay) Nothing
]
& RT.maybe'url .~ fmap (monolingual "de") announcementUrl
& RT.headerText .~ monolingual "de" announcementHeader
@@ -89,74 +96,93 @@ 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)
- anchors <- flip mapMaybeM running $ \(tripId, trip@Trip{..}) -> do
- entities <- selectList [TrainAnchorTrip ==. tripId, TrainAnchorDay ==. today] []
- case nonEmpty (fmap entityVal entities) of
+ -- let running = M.toList (tripsOnDay gtfs today)
+ tickets <- selectList [TicketCompleted ==. False, TicketDay ==. today] [Asc TicketTripName]
+
+ tripUpdates <- forM tickets $ \(Entity key Ticket{..}) -> do
+ selectList [TrainAnchorTicket ==. key] [] >>= \a -> case nonEmpty a of
Nothing -> pure Nothing
- Just anchors -> pure $ Just (tripId, trip, anchors)
+ Just anchors -> do
+ stops <- selectList [StopTicket ==. key] [Asc StopArrival] >>= mapM (\(Entity _ stop) -> do
+ station <- getJust (stopStation stop)
+ pure (stop, station))
- defFeedMessage (mapMaybe (mkTripUpdate today nowSeconds) anchors)
- where
- mkTripUpdate :: Day -> Seconds -> (Text, Trip 'Deep 'Deep, NonEmpty TrainAnchor) -> Maybe RT.FeedEntity
- mkTripUpdate today nowSeconds (tripId :: Text, Trip{..} :: Trip Deep Deep, anchors) =
- let lastCall = extrapolateAtSeconds LinearExtrapolator anchors nowSeconds
- stations = tripStops
- <&> (\stop@Stop{..} -> (, stop)
- <$> extrapolateAtPosition LinearExtrapolator anchors (int2Double stopSequence))
- (lastAnchor, lastStop) = V.last (V.catMaybes stations)
- stillRunning = trainAnchorDelay lastAnchor + toSeconds (stopArrival lastStop) tzseries today
- < nowSeconds + 5 * 60
- in if not stillRunning then Nothing else Just $ defMessage
- & RT.id .~ (tripId <> "-" <> T.pack (iso8601Show today))
- & RT.tripUpdate .~ (defMessage
- & RT.trip .~ defTripDescriptor tripId (Just today) (Just $ T.pack (showTimeWithSeconds $ stopDeparture $ V.head tripStops))
- & RT.stopTimeUpdate .~ fmap mkStopTimeUpdate (catMaybes $ V.toList stations)
- & RT.maybe'delay .~ Nothing -- lastCall <&> (fromIntegral . unSeconds . trainAnchorDelay)
- & RT.maybe'timestamp .~ fmap (toStupidTime . trainAnchorCreated) lastCall
- )
- where
- mkStopTimeUpdate :: (TrainAnchor, Stop Deep) -> RT.TripUpdate'StopTimeUpdate
- mkStopTimeUpdate (TrainAnchor{..}, Stop{..}) = defMessage
- & RT.stopSequence .~ fromIntegral stopSequence
- & RT.stopId .~ stationId stopStation
- & RT.arrival .~ (defMessage
+ let anchorEntities = fmap entityVal anchors
+ let lastCall = extrapolateAtSeconds LinearExtrapolator anchorEntities nowSeconds
+ 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 && not isOutdated then Nothing else Just $ defMessage
+ & RT.id .~ UUID.toText (coerce key)
+ & RT.tripUpdate .~ (defMessage
+ & RT.trip .~
+ defTripDescriptor
+ ticketTripName (Just today)
+ (Just $ T.pack (showTimeWithSeconds $ stopDeparture $ fst $ head stops))
+ & RT.stopTimeUpdate .~ fmap mkStopTimeUpdate (catMaybes atStations)
+ & RT.maybe'delay .~ Nothing -- lastCall <&> (fromIntegral . unSeconds . trainAnchorDelay)
+ & RT.maybe'timestamp .~ fmap (toStupidTime . trainAnchorCreated) lastCall
+ )
+ where
+ mkStopTimeUpdate :: (TrainAnchor, Stop, Station) -> RT.TripUpdate'StopTimeUpdate
+ mkStopTimeUpdate (TrainAnchor{..}, Stop{..}, Station{..}) = defMessage
+ & RT.stopSequence .~ fromIntegral stopSequence
+ & RT.stopId .~ stationShortName
+ & RT.arrival .~ (defMessage
& RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
& RT.time .~ toStupidTime (addUTCTime
(fromIntegral $ unSeconds trainAnchorDelay)
(toUTC stopArrival tzseries today))
& RT.uncertainty .~ 60
- )
- & RT.departure .~ (defMessage
- & RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
- & RT.time .~ toStupidTime (addUTCTime
+ )
+ & RT.departure .~ (defMessage
+ & RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
+ & RT.time .~ toStupidTime (addUTCTime
(fromIntegral $ unSeconds trainAnchorDelay)
(toUTC stopDeparture tzseries today))
- & RT.uncertainty .~ 60
- )
- & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED
+ & RT.uncertainty .~ 60
+ )
+ & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED
+
+ defFeedMessage (catMaybes tripUpdates)
handleVehiclePositions = runSql dbpool $ do
- (running :: [Entity Running]) <- selectList [] []
- pings <- forM running $ \(Entity key entity) -> do
- selectFirst [TrainPingToken ==. key] [] <&> fmap (, entity)
- defFeedMessage (mkPosition <$> catMaybes pings)
+
+ ticket <- selectList [TicketCompleted ==. False] []
+
+ -- TODO: reimplement this (since trainpings no longer reference tickets it's gone for now)
+ -- positions <- forM ticket $ \(Entity key ticket) -> do
+ -- selectFirst [TrainPingTicket ==. key] [Desc TrainPingTimestamp] >>= \case
+ -- Nothing -> pure Nothing
+ -- Just lastPing ->
+ -- pure (Just $ mkPosition (lastPing, ticket))
+
+ defFeedMessage [] -- (catMaybes positions)
where
- mkPosition :: (Entity TrainPing, Running) -> RT.FeedEntity
- mkPosition (Entity (TrainPingKey key) TrainPing{..}, Running{..}) = defMessage
+ mkPosition :: (Entity TrainPing, Ticket) -> RT.FeedEntity
+ mkPosition (Entity key TrainPing{..}, Ticket{..}) = defMessage
& RT.id .~ T.pack (show key)
& RT.vehicle .~ (defMessage
- & RT.trip .~ defTripDescriptor runningTrip Nothing Nothing
- & RT.maybe'vehicle .~ case runningVehicle of
+ & RT.trip .~ defTripDescriptor ticketTripName Nothing Nothing
+ & RT.maybe'vehicle .~ case ticketVehicle of
Nothing -> Nothing
Just trainset -> Just $ defMessage
& RT.label .~ trainset
& RT.position .~ (defMessage
- & RT.latitude .~ double2Float trainPingLat
- & RT.longitude .~ double2Float trainPingLong
+ & RT.latitude .~ double2Float (latitude trainPingGeopos)
+ & RT.longitude .~ double2Float (longitude trainPingGeopos)
)
-- TODO: should probably give currentStopSequence/stopId here as well
& RT.timestamp .~ toStupidTime trainPingTimestamp
@@ -181,7 +207,7 @@ defFeedMessage entities = do
)
& RT.entity .~ entities
-defTripDescriptor :: TripID -> Maybe Day -> Maybe Text -> RT.TripDescriptor
+defTripDescriptor :: TripId -> Maybe Day -> Maybe Text -> RT.TripDescriptor
defTripDescriptor tripId day starttime = defMessage
& RT.tripId .~ tripId
& RT.scheduleRelationship .~ RT.TripDescriptor'SCHEDULED
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-06 16:35:38 +0000