diff options
Diffstat (limited to 'lib/Server/GTFS_RT.hs')
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 115 |
1 files changed, 62 insertions, 53 deletions
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs index 412284f..48a84db 100644 --- a/lib/Server/GTFS_RT.hs +++ b/lib/Server/GTFS_RT.hs @@ -12,6 +12,7 @@ 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 @@ -31,6 +32,7 @@ import qualified Data.UUID as UUID import qualified Data.Vector as V import Database.Persist (Entity (..), PersistQueryRead (selectFirst), + SelectOpt (Asc, Desc), get, getJust, selectKeysList, selectList, (<-.), (==.)) import Database.Persist.Postgresql (SqlBackend) @@ -38,15 +40,16 @@ import Extrapolation (Extrapolator (extrapolateAtPositio 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 (..), + Station (..), Stop (..), Ticket (..), Token (..), Tracker (..), TrainAnchor (..), - TrainPing (..), runSql) + TrainPing (..), latitude, + longitude, runSql) import qualified Proto.GtfsRealtime as RT import qualified Proto.GtfsRealtime_Fields as RT import Servant.API ((:<|>) (..)) @@ -85,7 +88,7 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = & RT.alert .~ (defMessage & RT.activePeriod .~ [ defMessage :: RT.TimeRange ] & RT.informedEntity .~ [ defMessage - & RT.trip .~ defTripDescriptor ticketTrip (Just ticketDay) Nothing + & RT.trip .~ defTripDescriptor ticketTripName (Just ticketDay) Nothing ] & RT.maybe'url .~ fmap (monolingual "de") announcementUrl & RT.headerText .~ monolingual "de" announcementHeader @@ -95,78 +98,84 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = handleTripUpdates = runSql dbpool $ do today <- liftIO $ getCurrentTime <&> utctDay nowSeconds <- secondsNow today - let running = M.toList (tripsOnDay gtfs today) - anchors <- flip mapMaybeM running $ \(tripId, trip@Trip{..}) -> do - tickets <- selectKeysList [TicketTrip ==. tripId, TicketDay ==. today] [] - entities <- selectList [TrainAnchorTicket <-. tickets] [] - case nonEmpty (fmap entityVal entities) of + -- let running = M.toList (tripsOnDay gtfs today) + tickets <- selectList [TicketCompleted ==. False] [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 + 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) + let 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 + + pure $ 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 - (trackers :: [Entity Tracker]) <- selectList [] [] - pings <- forM trackers $ \(Entity trackerId tracker) -> do - selectFirst [TrainPingToken ==. trackerId] [] >>= \case + + ticket <- selectList [TicketCompleted ==. False] [] + + positions <- forM ticket $ \(Entity key ticket) -> do + selectFirst [TrainPingTicket ==. key] [Desc TrainPingTimestamp] >>= \case Nothing -> pure Nothing - Just ping -> do - ticket <- getJust (trainPingTicket (entityVal ping)) - pure (Just (ping, ticket, tracker)) + Just lastPing -> + pure (Just $ mkPosition (lastPing, ticket)) - defFeedMessage (mkPosition <$> catMaybes pings) + defFeedMessage (catMaybes positions) where - mkPosition :: (Entity TrainPing, Ticket, Tracker) -> RT.FeedEntity - mkPosition (Entity (TrainPingKey key) TrainPing{..}, Ticket{..}, Tracker{..}) = 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 ticketTrip Nothing Nothing + & 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 |