diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Server.hs | 207 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 274 | ||||
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 115 |
3 files changed, 353 insertions, 243 deletions
diff --git a/lib/Server.hs b/lib/Server.hs index c6d2d94..3922a7b 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -8,113 +8,128 @@ -- Implementation of the API. This module is the main point of the program. module Server (application) where -import Control.Concurrent.STM (TQueue, TVar, atomically, - newTQueue, newTVar, newTVarIO, - readTQueue, readTVar, writeTQueue, - writeTVar) -import Control.Monad (forever, unless, void, when) -import Control.Monad.Catch (handle) -import Control.Monad.Extra (ifM, maybeM, unlessM, whenJust, - whenM) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger (LoggingT, NoLoggingT, logWarnN) -import Control.Monad.Reader (ReaderT, forM) -import Control.Monad.Trans (lift) -import Data.Aeson ((.=)) -import qualified Data.Aeson as A -import qualified Data.ByteString.Char8 as C8 -import Data.Coerce (coerce) -import Data.Functor ((<&>)) -import qualified Data.Map as M -import Data.Pool (Pool) -import Data.Proxy (Proxy (Proxy)) -import Data.Swagger (toSchema) -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8) -import Data.Time (NominalDiffTime, - UTCTime (utctDay), addUTCTime, - diffUTCTime, getCurrentTime, - nominalDay) -import qualified Data.Vector as V +import Control.Concurrent.STM (TQueue, TVar, atomically, + newTQueue, newTVar, + newTVarIO, readTQueue, + readTVar, writeTQueue, + writeTVar) +import Control.Monad (forever, unless, void, + when) +import Control.Monad.Catch (handle) +import Control.Monad.Extra (ifM, maybeM, unlessM, + whenJust, whenM) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Logger (LoggingT, NoLoggingT, + logWarnN) +import Control.Monad.Reader (ReaderT, forM) +import Control.Monad.Trans (lift) +import Data.Aeson ((.=)) +import qualified Data.Aeson as A +import qualified Data.ByteString.Char8 as C8 +import Data.Coerce (coerce) +import Data.Functor ((<&>)) +import qualified Data.Map as M +import Data.Pool (Pool) +import Data.Proxy (Proxy (Proxy)) +import Data.Swagger (toSchema) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Data.Time (NominalDiffTime, + UTCTime (utctDay), + addUTCTime, diffUTCTime, + getCurrentTime, + nominalDay) +import qualified Data.Vector as V import Database.Persist -import Database.Persist.Postgresql (SqlBackend, runMigration) -import Fmt ((+|), (|+)) -import qualified Network.WebSockets as WS -import Servant (Application, - ServerError (errBody), err401, - err404, serve, - serveDirectoryFileServer, - throwError) -import Servant.API (NoContent (..), (:<|>) (..)) -import Servant.Server (Handler, hoistServer) -import Servant.Swagger (toSwagger) +import Database.Persist.Postgresql (SqlBackend, + migrateEnableExtension, + runMigration) +import Fmt ((+|), (|+)) +import qualified Network.WebSockets as WS +import Servant (Application, + ServerError (errBody), + err401, err404, serve, + serveDirectoryFileServer, + throwError) +import Servant.API (NoContent (..), + (:<|>) (..)) +import Servant.Server (Handler, hoistServer) +import Servant.Swagger (toSwagger) import API -import GTFS +import qualified GTFS import Persist import Server.ControlRoom -import Server.GTFS_RT (gtfsRealtimeServer) -import Server.Util (Service, ServiceM, runService, - sendErrorMsg) -import Yesod (toWaiAppPlain) +import Server.GTFS_RT (gtfsRealtimeServer) +import Server.Util (Service, ServiceM, + runService, sendErrorMsg) +import Yesod (toWaiAppPlain) -import Extrapolation (Extrapolator (..), - LinearExtrapolator (..)) +import Extrapolation (Extrapolator (..), + LinearExtrapolator (..)) import System.IO.Unsafe -import Conduit (ResourceT) -import Config (ServerConfig (serverConfigAssets)) -import Data.ByteString (ByteString) -import Data.ByteString.Lazy (toStrict) -import Data.UUID (UUID) +import Conduit (ResourceT) +import Config (ServerConfig (serverConfigAssets, serverConfigZoneinfoPath)) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy (toStrict) +import qualified Data.Text as T +import Data.Time.LocalTime.TimeZone.Olson (getTimeZoneSeriesFromOlsonFile) +import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) +import Data.UUID (UUID) import Prometheus import Prometheus.Metric.GHC +import System.FilePath ((</>)) -application :: GTFS -> Pool SqlBackend -> ServerConfig -> IO Application +application :: GTFS.GTFS -> Pool SqlBackend -> ServerConfig -> IO Application application gtfs dbpool settings = do doMigration dbpool metrics <- Metrics <$> register (gauge (Info "ws_connections" "Number of WS Connections")) register ghcMetrics + + -- TODO: maybe cache these in a TVar, we're not likely to ever need + -- more than one of these + let getTzseries tzname = getTimeZoneSeriesFromOlsonFile + (serverConfigZoneinfoPath settings </> T.unpack tzname) + subscribers <- newTVarIO mempty - pure $ serve (Proxy @CompleteAPI) $ hoistServer (Proxy @CompleteAPI) runService $ server gtfs metrics subscribers dbpool settings + pure $ serve (Proxy @CompleteAPI) $ hoistServer (Proxy @CompleteAPI) runService + $ server gtfs getTzseries metrics subscribers dbpool settings -- databaseMigration :: ConnectionString -> IO () -doMigration pool = runSql pool $ - -- TODO: before that, check if the uuid module is enabled - -- in sql: check if SELECT * FROM pg_extension WHERE extname = 'uuid-ossp'; - -- returns an empty list - runMigration migrateAll - -server :: GTFS -> Metrics -> TVar (M.Map UUID [TQueue (Maybe TrainPing)]) -> Pool SqlBackend -> ServerConfig -> Service CompleteAPI -server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI - :<|> (handleStations :<|> handleTimetable :<|> handleTimetableStops :<|> handleTrip +doMigration pool = runSql pool $ runMigration $ do + migrateEnableExtension "uuid-ossp" + migrateAll + +server :: GTFS.GTFS -> (Text -> IO TimeZoneSeries) -> Metrics -> TVar (M.Map UUID [TQueue (Maybe TrainPing)]) -> Pool SqlBackend -> ServerConfig -> Service CompleteAPI +server gtfs getTzseries Metrics{..} subscribers dbpool settings = handleDebugAPI + :<|> (handleTimetable :<|> handleTimetableStops :<|> handleTrip :<|> handleRegister :<|> handleTrainPing (throwError err401) :<|> handleWS :<|> handleSubscribe :<|> handleDebugState :<|> handleDebugTrain - :<|> handleDebugRegister :<|> pure gtfsFile :<|> gtfsRealtimeServer gtfs dbpool) + :<|> handleDebugRegister :<|> pure (GTFS.gtfsFile gtfs) :<|> gtfsRealtimeServer gtfs dbpool) :<|> metrics :<|> serveDirectoryFileServer (serverConfigAssets settings) :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool settings))) - where handleStations = pure stations - handleTimetable station maybeDay = - M.filter isLastStop . tripsOnDay gtfs <$> liftIO day - where isLastStop = (==) station . stationId . stopStation . V.last . tripStops + where handleTimetable station maybeDay = + M.filter isLastStop . GTFS.tripsOnDay gtfs <$> liftIO day + where isLastStop = (==) station . GTFS.stationId . GTFS.stopStation . V.last . GTFS.tripStops day = maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay) handleTimetableStops day = - pure . A.toJSON . fmap mkJson . M.elems $ tripsOnDay gtfs day - where mkJson :: Trip Deep Deep -> A.Value - mkJson Trip {..} = A.object + pure . A.toJSON . fmap mkJson . M.elems $ GTFS.tripsOnDay gtfs day + where mkJson :: GTFS.Trip GTFS.Deep GTFS.Deep -> A.Value + mkJson GTFS.Trip {..} = A.object [ "trip" .= tripTripId - , "sequencelength" .= (stopSequence . V.last) tripStops - , "stops" .= fmap (\Stop{..} -> A.object - [ "departure" .= toUTC stopDeparture tzseries day - , "arrival" .= toUTC stopArrival tzseries day - , "station" .= stationId stopStation - , "lat" .= stationLat stopStation - , "lon" .= stationLon stopStation + , "sequencelength" .= (GTFS.stopSequence . V.last) tripStops + , "stops" .= fmap (\GTFS.Stop{..} -> A.object + [ "departure" .= GTFS.toUTC stopDeparture (GTFS.tzseries gtfs) day + , "arrival" .= GTFS.toUTC stopArrival (GTFS.tzseries gtfs) day + , "station" .= GTFS.stationId stopStation + , "lat" .= GTFS.stationLat stopStation + , "lon" .= GTFS.stationLon stopStation ]) tripStops ] - handleTrip trip = case M.lookup trip trips of + handleTrip trip = case M.lookup trip (GTFS.trips gtfs) of Just res -> pure res Nothing -> throwError err404 handleRegister (ticketId :: UUID) RegisterJson{..} = do @@ -130,26 +145,41 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI TrackerKey tracker <- insert (Tracker expires False "debug key") insert (TrackerTicket (TicketKey ticketId) (TrackerKey tracker)) pure tracker - handleTrainPing onError ping@TrainPing{..} = isTokenValid dbpool trainPingToken trainPingTicket - >>= \case + handleTrainPing onError ping@TrainPing{..} = + let ticketId = trainPingTicket in + isTokenValid dbpool trainPingToken ticketId >>= \case Nothing -> do onError pure Nothing Just (tracker@Tracker{..}, ticket@Ticket{..}) -> do - let anchor = extrapolateAnchorFromPing LinearExtrapolator gtfs ticket ping - -- TODO: are these always inserted in order? runSql dbpool $ do + + stations <- selectList [ StopTicket ==. ticketId ] [Asc StopArrival] + >>= mapM (\stop -> do + station <- getJust (stopStation (entityVal stop)) + tzseries <- liftIO $ getTzseries (GTFS.tzname (stopArrival (entityVal stop))) + pure (entityVal stop, station, tzseries)) + <&> V.fromList + + shapePoints <- selectList [ShapePointShape ==. ticketShape] [Asc ShapePointIndex] + <&> (V.fromList . fmap entityVal) + + let anchor = extrapolateAnchorFromPing LinearExtrapolator + ticket stations shapePoints ping + insert ping + last <- selectFirst [TrainAnchorTicket ==. trainPingTicket] [Desc TrainAnchorWhen] -- only insert new estimates if they've actually changed anything when (fmap (trainAnchorDelay . entityVal) last /= Just (trainAnchorDelay anchor)) $ void $ insert anchor - queues <- liftIO $ atomically $ do - queues <- readTVar subscribers <&> M.lookup (coerce trainPingTicket) - whenJust queues $ - mapM_ (\q -> writeTQueue q (Just ping)) - pure queues - pure (Just anchor) + + queues <- liftIO $ atomically $ do + queues <- readTVar subscribers <&> M.lookup (coerce trainPingTicket) + whenJust queues $ + mapM_ (\q -> writeTQueue q (Just ping)) + pure queues + pure (Just anchor) handleWS conn = do liftIO $ WS.forkPingThread conn 30 incGauge metricsWSGauge @@ -233,3 +263,4 @@ hasExpired limit = do validityPeriod :: NominalDiffTime validityPeriod = nominalDay + diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index 4fb5ba8..e89b184 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -17,12 +17,13 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as LB +import Data.Function (on, (&)) import Data.Functor ((<&>)) -import Data.List (lookup) +import Data.List (lookup, nubBy) import Data.List.NonEmpty (nonEmpty) import Data.Map (Map) import qualified Data.Map as M -import Data.Maybe (catMaybes, fromJust) +import Data.Maybe (catMaybes, fromJust, isJust) import Data.Pool (Pool) import Data.Text (Text) import qualified Data.Text as T @@ -42,7 +43,7 @@ import Extrapolation (Extrapolator (..), import Fmt ((+|), (|+)) import GHC.Float (int2Double) import GHC.Generics (Generic) -import GTFS +import qualified GTFS import Numeric (showFFloat) import Persist import Server.Util (Service, secondsNow) @@ -60,7 +61,7 @@ import Yesod.Orphans () data ControlRoom = ControlRoom - { getGtfs :: GTFS + { getGtfs :: GTFS.GTFS , getPool :: Pool SqlBackend , getSettings :: ServerConfig } @@ -70,17 +71,21 @@ mkMessage "ControlRoom" "messages" "en" mkYesod "ControlRoom" [parseRoutes| / RootR GET /auth AuthR Auth getAuth -/trains TrainsR GET -/train/id/#UUID TicketViewR GET -/train/import/#Day TicketImportR POST -/train/map/#UUID TrainMapViewR GET -/train/announce/#UUID AnnounceR POST -/train/del-announce/#UUID DelAnnounceR GET + +/tickets TicketsR GET +/ticket/#UUID TicketViewR GET +/ticket/map/#UUID TicketMapViewR GET +/ticket/announce/#UUID AnnounceR POST +/ticket/del-announce/#UUID DelAnnounceR GET + /token/block/#Token TokenBlock GET -/trips TripsViewR GET -/trip/#TripId TripViewR GET + +/gtfs/trips GtfsTripsViewR GET +/gtfs/trip/#GTFS.TripId GtfsTripViewR GET +/gtfs/import/#Day GtfsTicketImportR POST + /obu OnboardUnitMenuR GET -/obu/#TripId/#Day OnboardUnitR GET +/obu/#UUID OnboardUnitR GET |] emptyMarkup :: MarkupM a -> Bool @@ -90,10 +95,10 @@ emptyMarkup _ = False instance Yesod ControlRoom where authRoute _ = Just $ AuthR LoginR isAuthorized OnboardUnitMenuR _ = pure Authorized - isAuthorized (OnboardUnitR _ _) _ = pure Authorized + isAuthorized (OnboardUnitR _) _ = pure Authorized isAuthorized (AuthR _) _ = pure Authorized isAuthorized _ _ = do - UffdConfig{..} <- getYesod <&> getSettings <&> serverConfigLogin + UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings if uffdConfigEnable then maybeAuthId >>= \case Just _ -> pure Authorized Nothing -> pure AuthenticationRequired @@ -176,10 +181,10 @@ instance YesodAuth ControlRoom where getRootR :: Handler Html -getRootR = redirect TrainsR +getRootR = redirect TicketsR -getTrainsR :: Handler Html -getTrainsR = do +getTicketsR :: Handler Html +getTicketsR = do req <- getRequest let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) mdisplayname <- maybeAuthId <&> fmap uffdDisplayName @@ -194,14 +199,13 @@ getTrainsR = do gtfs <- getYesod <&> getGtfs -- TODO: tickets should have all trip information saved - tickets <- runDB $ selectList [ TicketDay ==. day ] [] - <&> fmap (\(Entity (TicketKey ticketId) ticket) -> - (ticketId, ticket, fromJust $ M.lookup (ticketTrip ticket) (trips gtfs))) - - let trips = tripsOnDay gtfs day - let headsign (Trip{..} :: Trip Deep Deep) = case tripHeadsign of - Just headsign -> headsign - Nothing -> stationName (stopStation (V.last tripStops)) + tickets <- runDB $ selectList [ TicketDay ==. day ] [] >>= mapM (\ticket -> do + stops <- selectList [ StopTicket ==. entityKey ticket ] [] + startStation <- getJust (stopStation $ entityVal $ head stops) + pure (ticket, startStation, fmap entityVal stops)) + + let trips = GTFS.tripsOnDay gtfs day + (widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips))) defaultLayout $ do [whamlet| @@ -209,77 +213,130 @@ getTrainsR = do $maybe name <- mdisplayname <p>_{MsgLoggedInAs name} - <a href="@{AuthR LogoutR}">_{MsgLogout}</a> <nav> - <a class="nav-left" href="@?{(TrainsR, [("day", prevday)])}">← #{prevday} + <a class="nav-left" href="@?{(TicketsR, [("day", prevday)])}">← #{prevday} $if isToday _{Msgtoday} $else - <a href="@{TrainsR}">_{Msgtoday} - <a class="nav-right" href="@?{(TrainsR, [("day", nextday)])}">#{nextday} → + <a href="@{TicketsR}">_{Msgtoday} + <a class="nav-right" href="@?{(TicketsR, [("day", nextday)])}">#{nextday} → <section> <h2>_{MsgTickets} <ol> - $forall (ticketId, Ticket{..}, trip@Trip{..}) <- tickets - <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{tripName trip}</a> - : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} → #{headsign trip} + $forall (Entity (TicketKey ticketId) Ticket{..}, startStation, stops) <- tickets + <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{ticketTripName}</a> + : _{Msgdep} #{stopDeparture (head stops)} #{stationName startStation} → #{ticketHeadsign} $if null tickets <li style="text-align: center"><em>(_{MsgNone}) <section> <h2>_{MsgAccordingToGtfs} - <form method=post action="@{TicketImportR day}" enctype=#{enctype}> + <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}> ^{widget} <button>_{MsgImportTrips} |] -postTicketImportR :: Day -> Handler Html -postTicketImportR day = do + +-- TODO: this function should probably look for duplicate imports +postGtfsTicketImportR :: Day -> Handler Html +postGtfsTicketImportR day = do gtfs <- getYesod <&> getGtfs - let trips = tripsOnDay gtfs day + let trips = GTFS.tripsOnDay gtfs day ((result, widget), enctype) <- runFormPost (tripImportForm (fmap (,day) (M.elems trips))) case result of FormSuccess selected -> do now <- liftIO getCurrentTime - let tickets = flip fmap selected $ \(Trip{..}, day) -> Ticket - { ticketTrip = tripTripId, ticketDay = day, ticketImported = now - , ticketSchedule_version = Nothing, ticketVehicle = Nothing } - runDB $ insertMany tickets - redirect (TrainsR, [("day", T.pack (iso8601Show day))]) - _ -> defaultLayout [whamlet| + + shapeMap <- selected + <&> (\(trip@GTFS.Trip{..}, _) -> (GTFS.shapeId tripShape, tripShape)) + & nubBy ((==) `on` fst) + & mapM (\(shapeId, shape) -> runDB $ do + key <- insert Shape + insertMany + $ shape + & GTFS.shapePoints + & V.indexed + & V.toList + <&> \(idx, pos) -> ShapePoint (Geopos pos) idx key + pure (shapeId, key)) + <&> M.fromList + + stationMap <- selected + <&> (\(trip@GTFS.Trip{..}, _) -> V.toList (tripStops <&> GTFS.stopStation)) + & concat + & nubBy ((==) `on` GTFS.stationId) + & mapM (\GTFS.Station{..} -> runDB $ do + maybeExists <- selectFirst [ StationShortName ==. stationId ] [] + case maybeExists of + Nothing -> do + key <- insert Station + { stationGeopos = Geopos (stationLat, stationLon) + , stationShortName = stationId , stationName } + pure (stationId, key) + Just (Entity key _) -> pure (stationId, key)) + <&> M.fromList + + selected + <&> (\(trip@GTFS.Trip{..}, day) -> + let + ticket = Ticket + { ticketTripName = tripTripId, ticketDay = day, ticketImported = now + , ticketSchedule_version = Nothing, ticketVehicle = Nothing + , ticketCompleted = False, ticketHeadsign = gtfsHeadsign trip + , ticketShape = fromJust (M.lookup (GTFS.shapeId tripShape) shapeMap)} + stops = V.toList tripStops <&> \GTFS.Stop{..} ticketId -> Stop + { stopTicket = ticketId + , stopStation = fromJust (M.lookup (GTFS.stationId stopStation) stationMap) + , stopArrival, stopDeparture, stopSequence} + in (ticket, stops)) + & unzip + & \(tickets, stops) -> runDB $ do + ticketIds <- insertMany tickets + forM (zip ticketIds stops) $ \(ticketId, unfinishedStops) -> + insertMany (fmap (\s -> s ticketId) unfinishedStops) + + redirect (TicketsR, [("day", T.pack (iso8601Show day))]) + + FormFailure _ -> defaultLayout [whamlet| <section> <h2>_{MsgAccordingToGtfs} - <form method=post action="@{TicketImportR day}" enctype=#{enctype}> + <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}> ^{widget} <button>_{MsgImportTrips} |] getTicketViewR :: UUID -> Handler Html getTicketViewR ticketId = do - Ticket{..} <- runDB $ get (TicketKey ticketId) + let ticketKey = TicketKey ticketId + Ticket{..} <- runDB $ get ticketKey >>= \case {Nothing -> notFound; Just a -> pure a} - GTFS{..} <- getYesod <&> getGtfs + stops <- runDB $ selectList [StopTicket ==. ticketKey] [] >>= mapM (\stop -> do + station <- getJust (stopStation (entityVal stop)) + pure (entityVal stop, station)) + + anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] [] + trackerIds <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] [] + <&> fmap (trackerTicketTracker . entityVal) + trackers <- runDB $ selectList [ TrackerId <-. trackerIds ] [Asc TrackerExpires] + lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey trackers ] [Desc TrainPingTimestamp] + anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] [] + <&> nonEmpty . fmap entityVal + (widget, enctype) <- generateFormPost (announceForm ticketId) - case M.lookup ticketTrip trips of - Nothing -> notFound - Just res@Trip{..} -> do - let ticketKey = TicketKey ticketId - anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] [] - trackerIds <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] [] - <&> fmap (trackerTicketTracker . entityVal) - trackers <- runDB $ selectList [ TrackerId <-. trackerIds ] [Asc TrackerExpires] - lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey trackers ] [Desc TrainPingTimestamp] - anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] [] - <&> nonEmpty . fmap entityVal - nowSeconds <- secondsNow ticketDay - defaultLayout $ do - mr <- getMessageRender - setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripId|+" "+|mr Msgon|+" "+|ticketDay|+"" :: Text)) - [whamlet| -<h1>_{MsgTrip} <a href="@{TripViewR tripTripId}">#{tripName res}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show ticketDay))])}">#{ticketDay}</a> + + nowSeconds <- secondsNow ticketDay + defaultLayout $ do + mr <- getMessageRender + setTitle (toHtml (""+|mr MsgTrip|+" "+|ticketTripName|+" "+|mr Msgon|+" "+|ticketDay|+"" :: Text)) + [whamlet| +<h1>_{MsgTrip} # + <a href="@{GtfsTripViewR ticketTripName}">#{ticketTripName} + _{Msgon} + <a href="@?{(TicketsR, [("day", T.pack (iso8601Show ticketDay))])}">#{ticketDay} <section> <h2>_{MsgLive} <p><strong>_{MsgLastPing}: </strong> $maybe Entity _ TrainPing{..} <- lastPing - _{MsgTrainPing trainPingLat trainPingLong trainPingTimestamp} + _{MsgTrainPing (latitude trainPingGeopos) (longitude trainPingGeopos) trainPingTimestamp} (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>) $nothing <em>(_{MsgNoTrainPing}) @@ -289,12 +346,12 @@ getTicketViewR ticketId = do \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")}) $nothing <em> (_{MsgNone}) - <p><a href="@{TrainMapViewR ticketId}">_{MsgMap}</a> + <p><a href="@{TicketMapViewR ticketId}">_{MsgMap}</a> <section> <h2>_{MsgStops} <ol> - $forall Stop{..} <- tripStops - <li value="#{stopSequence}"> #{stopArrival} #{stationName stopStation} + $forall (Stop{..}, Station{..}) <- stops + <li value="#{stopSequence}"> #{stopArrival} #{stationName} $maybe history <- anchors $maybe delay <- guessDelay history (int2Double stopSequence) \ (#{delay}) @@ -329,16 +386,19 @@ getTicketViewR ticketId = do guessAtSeconds = extrapolateAtSeconds LinearExtrapolator -getTrainMapViewR :: UUID -> Handler Html -getTrainMapViewR ticketId = do +getTicketMapViewR :: UUID -> Handler Html +getTicketMapViewR ticketId = do Ticket{..} <- runDB $ get (TicketKey ticketId) >>= \case { Nothing -> notFound ; Just ticket -> pure ticket } - GTFS{..} <- getYesod <&> getGtfs + + stops <- runDB $ selectList [StopTicket ==. TicketKey ticketId] [] >>= mapM (\stop -> do + station <- getJust (stopStation (entityVal stop)) + pure (entityVal stop, station)) + (widget, enctype) <- generateFormPost (announceForm ticketId) - case M.lookup ticketTrip trips of - Nothing -> notFound - Just res@Trip{..} -> do defaultLayout [whamlet| -<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{tripName res} _{Msgon} #{ticketDay}</a> + + defaultLayout [whamlet| +<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{ticketTripName} _{Msgon} #{ticketDay}</a> <link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css" integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI=" crossorigin=""/> @@ -354,7 +414,7 @@ getTrainMapViewR ticketId = do attribution: '© <a href="https://www.openstreetmap.org/copyright">OpenStreetMap</a> contributors' }).addTo(map); - ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{tripTripId}/#{ticketDay}"); + ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{UUID.toText ticketId}"); var marker = null; @@ -373,27 +433,27 @@ getTrainMapViewR ticketId = do -getTripsViewR :: Handler Html -getTripsViewR = do - GTFS{..} <- getYesod <&> getGtfs +getGtfsTripsViewR :: Handler Html +getGtfsTripsViewR = do + GTFS.GTFS{..} <- getYesod <&> getGtfs defaultLayout $ do setTitle "List of Trips" [whamlet| <h1>List of Trips <section><ul> - $forall trip@Trip{..} <- trips - <li><a href="@{TripViewR tripTripId}">#{tripName trip}</a> - : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} + $forall trip@GTFS.Trip{..} <- trips + <li><a href="@{GtfsTripViewR tripTripId}">#{GTFS.tripName trip}</a> + : #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} |] -getTripViewR :: TripId -> Handler Html -getTripViewR tripId = do - GTFS{..} <- getYesod <&> getGtfs +getGtfsTripViewR :: GTFS.TripId -> Handler Html +getGtfsTripViewR tripId = do + GTFS.GTFS{..} <- getYesod <&> getGtfs case M.lookup tripId trips of Nothing -> notFound - Just trip@Trip{..} -> defaultLayout [whamlet| -<h1>_{MsgTrip} #{tripName trip} + Just trip@GTFS.Trip{..} -> defaultLayout [whamlet| +<h1>_{MsgTrip} #{GTFS.tripName trip} <section> <h2>_{MsgInfo} <p><strong>_{MsgtripId}:</strong> #{tripTripId} @@ -402,8 +462,8 @@ getTripViewR tripId = do <section> <h2>_{MsgStops} <ol> - $forall Stop{..} <- tripStops - <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation} + $forall GTFS.Stop{..} <- tripStops + <div>(#{stopSequence}) #{stopArrival} #{GTFS.stationName stopStation} <section> <h2>Dates <ul> @@ -454,21 +514,28 @@ getTokenBlock token = do getOnboardUnitMenuR :: Handler Html getOnboardUnitMenuR = do day <- liftIO getCurrentTime <&> utctDay - gtfs <- getYesod <&> getGtfs - let trips = tripsOnDay gtfs day + + tickets <- + runDB $ selectList [ TicketCompleted ==. False, TicketDay ==. day ] [] >>= mapM (\ticket -> do + firstStop <- selectFirst [StopTicket ==. entityKey ticket] [ Asc StopDeparture ] + pure (ticket, entityVal $ fromJust firstStop)) + defaultLayout $ do [whamlet| <h1>_{MsgOBU} <section> _{MsgChooseTrain} - $forall Trip{..} <- trips + $forall (Entity (TicketKey ticketId) Ticket{..}, firstStop) <- tickets <hr> - <a href="@{OnboardUnitR tripTripId day}"> - #{tripTripId}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)} + <a href="@{OnboardUnitR ticketId}"> + #{ticketTripName}: #{ticketHeadsign} #{stopDeparture firstStop} |] -getOnboardUnitR :: TripId -> Day -> Handler Html -getOnboardUnitR tripId day = +getOnboardUnitR :: UUID -> Handler Html +getOnboardUnitR ticketId = do + Ticket{..} <- runDB $ get (TicketKey ticketId) >>= \case + Nothing -> notFound + Just ticket -> pure ticket defaultLayout $(whamletFile "site/obu.hamlet") announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget) @@ -481,7 +548,10 @@ announceForm ticketId = renderDivs $ Announcement -tripImportForm :: [(Trip Deep Deep, Day)] -> Html -> MForm Handler (FormResult [(Trip Deep Deep, Day)], Widget) +tripImportForm + :: [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)] + -> Html + -> MForm Handler (FormResult [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)], Widget) tripImportForm trips extra = do forms <- forM trips $ \(trip, day) -> do (aRes, aView) <- mreq checkBoxField "import" Nothing @@ -491,15 +561,15 @@ tripImportForm trips extra = do let widget = toWidget [whamlet| #{extra} <ol> - $forall (trip@Trip{..}, day, res, view) <- forms + $forall (trip@GTFS.Trip{..}, day, res, view) <- forms <li> ^{fvInput view} <label for="^{fvId view}"> - _{MsgTrip} #{tripName trip} - : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} → #{headsign trip} + _{MsgTrip} #{GTFS.tripName trip} + : _{Msgdep} #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} → #{gtfsHeadsign trip} |] - let (a :: FormResult [Maybe (Trip Deep Deep, Day)]) = + let (a :: FormResult [Maybe (GTFS.Trip GTFS.Deep GTFS.Deep, Day)]) = sequenceA (fmap (\(_,_,res,_) -> res) forms) pure (fmap catMaybes a, widget) @@ -510,8 +580,8 @@ mightbe (Just a) = a mightbe Nothing = "" -headsign :: Trip 'Deep 'Deep -> Text -headsign (Trip{..} :: Trip Deep Deep) = +gtfsHeadsign :: GTFS.Trip GTFS.Deep GTFS.Deep -> Text +gtfsHeadsign GTFS.Trip{..} = case tripHeadsign of Just headsign -> headsign - Nothing -> stationName (stopStation (V.last tripStops)) + Nothing -> GTFS.stationName (GTFS.stopStation (V.last tripStops)) 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 |