From d4f4208fe66d3813b65312dac0bf895c4cdc53d6 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Wed, 24 Apr 2024 21:52:45 +0200 Subject: restructure: save a ticket's stop in the database now mostly independent of the gtfs, but still no live-reloading of it. --- lib/API.hs | 8 +- lib/Extrapolation.hs | 143 ++++++++++++++---------- lib/GTFS.hs | 16 +-- lib/Persist.hs | 66 +++++++++-- lib/Server.hs | 207 +++++++++++++++++++--------------- lib/Server/ControlRoom.hs | 274 +++++++++++++++++++++++++++++----------------- lib/Server/GTFS_RT.hs | 115 ++++++++++--------- messages/de.msg | 2 +- messages/en.msg | 2 +- site/obu.hamlet | 6 +- tracktrain.cabal | 1 + 11 files changed, 508 insertions(+), 332 deletions(-) diff --git a/lib/API.hs b/lib/API.hs index ab04a53..2c8123a 100644 --- a/lib/API.hs +++ b/lib/API.hs @@ -30,7 +30,6 @@ import Servant.API (Accept, Capture, Get, JSON, Post, QueryParam, Raw, ReqBody, type (:<|>) (..)) import Servant.API.WebSocket (WebSocket) --- import Servant.GTFS.Realtime (Proto) import Servant.Swagger (HasSwagger (..)) import Web.Internal.FormUrlEncoded (Form) @@ -42,7 +41,9 @@ import qualified Data.ByteString.Lazy as LB import Data.HashMap.Strict.InsOrd (singleton) import Data.ProtoLens (Message, encodeMessage) import GHC.Generics (Generic) -import GTFS +import GTFS (Depth (Deep), GTFSFile (..), + StationID, Trip, TripId, + aesonOptions, swaggerOptions) import Network.HTTP.Media ((//)) import Persist import Prometheus @@ -62,8 +63,7 @@ instance ToSchema Value where & type_ ?~ SwaggerObject -- | The server's API (as it is actually intended). -type API = "stations" :> Get '[JSON] (Map StationID Station) - :<|> "timetable" :> Capture "Station Id" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripId (Trip Deep Deep)) +type API = "timetable" :> Capture "Station Id" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripId (Trip Deep Deep)) :<|> "timetable" :> "stops" :> Capture "Date" Day :> Get '[JSON] Value :<|> "trip" :> Capture "Trip Id" TripId :> Get '[JSON] (Trip Deep Deep) -- ingress API (put this behind BasicAuth?) diff --git a/lib/Extrapolation.hs b/lib/Extrapolation.hs index 8edcc25..01e5f6f 100644 --- a/lib/Extrapolation.hs +++ b/lib/Extrapolation.hs @@ -4,40 +4,52 @@ {-# LANGUAGE RecordWildCards #-} module Extrapolation (Extrapolator(..), LinearExtrapolator(..), linearDelay, distanceAlongLine, euclid) where -import Data.Foldable (maximumBy, minimumBy) -import Data.Function (on) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import Data.Time (Day, UTCTime (UTCTime, utctDay), - diffUTCTime, getCurrentTime, - nominalDiffTimeToSeconds) -import qualified Data.Vector as V -import GHC.Float (int2Double) -import GHC.IO (unsafePerformIO) - -import Conduit (MonadIO (liftIO)) -import Data.List (sortBy, sortOn) -import Data.Ord (Down (..)) -import GTFS (Depth (Deep), GTFS (..), Seconds (..), - Shape (..), Station (stationName), - Stop (..), Time, Trip (..), seconds2Double, - stationGeopos, toSeconds) -import Persist (Ticket (..), Token (..), Tracker (..), - TrainAnchor (..), TrainPing (..)) -import Server.Util (utcToSeconds) +import Data.Foldable (maximumBy, minimumBy) +import Data.Function (on) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import Data.Time (Day, + UTCTime (UTCTime, utctDay), + diffUTCTime, + getCurrentTime, + nominalDiffTimeToSeconds) +import qualified Data.Vector as V +import GHC.Float (int2Double) +import GHC.IO (unsafePerformIO) + +import Conduit (MonadIO (liftIO)) +import Data.List (sortBy, sortOn) +import Data.Ord (Down (..)) +import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) +import GTFS (Seconds (..), + seconds2Double, toSeconds) +import Persist (Geopos (..), + ShapePoint (shapePointGeopos), + Station (..), Stop (..), + Ticket (..), Token (..), + Tracker (..), + TrainAnchor (..), + TrainPing (..)) +import Server.Util (utcToSeconds) -- | Determines how to extrapolate delays (and potentially other things) from the real-time -- data sent in by the OBU. Potentially useful to swap out the algorithm, or give it options. -- TODO: maybe split into two classes? -class Extrapolator a where +class Extrapolator strategy where -- | here's a position ping, guess things from that! - extrapolateAnchorFromPing :: a -> GTFS -> Ticket -> TrainPing -> TrainAnchor + extrapolateAnchorFromPing + :: strategy + -> Ticket + -> V.Vector (Stop, Station, TimeZoneSeries) + -> V.Vector ShapePoint + -> TrainPing + -> TrainAnchor -- | extrapolate status at some time (i.e. "how much delay does the train have *now*?") - extrapolateAtSeconds :: a -> NonEmpty TrainAnchor -> Seconds -> Maybe TrainAnchor + extrapolateAtSeconds :: strategy -> NonEmpty TrainAnchor -> Seconds -> Maybe TrainAnchor -- | extrapolate status at some places (i.e. "how much delay will it have at the next station?") - extrapolateAtPosition :: a -> NonEmpty TrainAnchor -> Double -> Maybe TrainAnchor + extrapolateAtPosition :: strategy -> NonEmpty TrainAnchor -> Double -> Maybe TrainAnchor data LinearExtrapolator = LinearExtrapolator @@ -56,7 +68,7 @@ instance Extrapolator LinearExtrapolator where $ NE.filter (\a -> trainAnchorSequence a < positionNow) history where difference status = positionNow - trainAnchorSequence status - extrapolateAnchorFromPing _ gtfs@GTFS{..} Ticket{..} ping@TrainPing{..} = TrainAnchor + extrapolateAnchorFromPing _ Ticket{..} stops shape ping@TrainPing{..} = TrainAnchor { trainAnchorCreated = trainPingTimestamp , trainAnchorTicket = trainPingTicket , trainAnchorWhen = utcToSeconds trainPingTimestamp ticketDay @@ -64,45 +76,55 @@ instance Extrapolator LinearExtrapolator where , trainAnchorDelay , trainAnchorMsg = Nothing } - where Just trip = M.lookup ticketTrip trips - (trainAnchorDelay, trainAnchorSequence) = linearDelay gtfs trip ping ticketDay + where + (trainAnchorDelay, trainAnchorSequence) = linearDelay stops shape ping ticketDay + tzseries = undefined -linearDelay :: GTFS -> Trip Deep Deep -> TrainPing -> Day -> (Seconds, Double) -linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = (observedDelay, observedSequence) - where -- | at which sequence number is the ping? +linearDelay :: V.Vector (Stop, Station, TimeZoneSeries) -> V.Vector ShapePoint -> TrainPing -> Day -> (Seconds, Double) +linearDelay tripStops shape TrainPing{..} runningDay = (observedDelay, observedSequence) + where -- at which (fractional) sequence number is the ping? observedSequence = int2Double (stopSequence lastStop) + observedProgress * int2Double (stopSequence nextStop - stopSequence lastStop) - -- | how much later/earlier is the ping than would be expected? + + -- how much later/earlier is the ping than would be expected? observedDelay = Seconds $ round $ (expectedProgress - observedProgress) * int2Double (unSeconds expectedTravelTime) + + if expectedProgress == 1 -- if the hypothetical on-time train is already at (or past) the next station, -- just add the time distance we're behind - + if expectedProgress /= 1 then 0 - else seconds2Double (utcToSeconds trainPingTimestamp runningDay - - toSeconds (stopArrival nextStop) tzseries runningDay) + then seconds2Double (utcToSeconds trainPingTimestamp runningDay - nextSeconds) + -- otherwise the above is sufficient + else 0 - -- | how far along towards the next station is the ping (between 0 and 1)? + -- how far along towards the next station is the ping (between 0 and 1)? observedProgress = - distanceAlongLine line (stationGeopos $ stopStation lastStop) closestPoint - / distanceAlongLine line (stationGeopos $ stopStation lastStop) (stationGeopos $ stopStation nextStop) - -- | to compare: where would a linearly-moving train be (between 0 and 1)? + distanceAlongLine line (stationGeopos lastStation) closestPoint + / distanceAlongLine line (stationGeopos lastStation) (stationGeopos nextStation) + + -- to compare: where would a linearly-moving train be (between 0 and 1)? expectedProgress = if | p < 0 -> 0 | p > 1 -> 1 | otherwise -> p - where p = seconds2Double (utcToSeconds trainPingTimestamp runningDay - - toSeconds (stopDeparture lastStop) tzseries runningDay) - / seconds2Double expectedTravelTime - -- | how long do we expect the trip from last to next station to take? - expectedTravelTime = - toSeconds (stopArrival nextStop) tzseries runningDay - - toSeconds (stopDeparture lastStop) tzseries runningDay - - closestPoint = minimumBy (compare `on` euclid (trainPingLat, trainPingLong)) line - line = shapePoints tripShape - lastStop = tripStops V.! (nextIndex - 1) - nextStop = tripStops V.! nextIndex - -- | index of the /next/ stop in the list, except when we're already at the last stop + where p = seconds2Double (utcToSeconds trainPingTimestamp runningDay - lastSeconds) + / seconds2Double expectedTravelTime + + -- scheduled duration between last and next stops + expectedTravelTime = nextSeconds - lastSeconds + + -- closest point on the shape; this is where we assume the train to be + closestPoint = minimumBy (compare `on` euclid trainPingGeopos) line + + -- scheduled departure at last & arrival at next stop + lastSeconds = toSeconds (stopDeparture lastStop) lastTzSeries runningDay + nextSeconds = toSeconds (stopArrival nextStop) nextTzSeries runningDay + + (lastStop, lastStation, lastTzSeries) = tripStops V.! (nextIndex - 1) + (nextStop, nextStation, nextTzSeries) = tripStops V.! nextIndex + + line = fmap shapePointGeopos shape + + -- index of the /next/ stop in the list, except when we're already at the last stop -- (in which case it stays the same) nextIndex = if | null remaining -> length tripStops - 1 @@ -110,23 +132,24 @@ linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = (observedDelay, ob | otherwise -> idx' where idx' = fst $ V.minimumBy (compare `on` snd) remaining remaining = V.filter (\(_,dist) -> dist > 0) $ V.indexed - $ fmap (distanceAlongLine line closestPoint . stationGeopos . stopStation) tripStops + $ fmap (distanceAlongLine line closestPoint . stationGeopos . \(_,stop,_) -> stop) tripStops -distanceAlongLine :: V.Vector (Double, Double) -> (Double, Double) -> (Double, Double) -> Double +-- | approximate (but euclidean) distance along a geoline +distanceAlongLine :: V.Vector Geopos -> Geopos -> Geopos -> Double distanceAlongLine line p1 p2 = along2 - along1 where along1 = along p1 along2 = along p2 - along p@(x,y) = + along p@(Geopos (x,y)) = sumSegments $ V.take (index + 1) line where index = V.minIndexBy (compare `on` euclid p) line - sumSegments :: V.Vector (Double, Double) -> Double + sumSegments :: V.Vector Geopos -> Double sumSegments line = snd - $ foldl (\(p,a) p' -> (p', a + euclid p p')) (V.head line,0) $ line + $ foldl (\(p,a) p' -> (p', a + euclid p p')) (V.head line,0) line -- | euclidean distance. Notably not applicable when you're on a sphere -- (but good enough when the sphere is the earth) -euclid :: Floating f => (f,f) -> (f,f) -> f -euclid (x1,y1) (x2,y2) = sqrt (x*x + y*y) +euclid :: Geopos -> Geopos -> Double +euclid (Geopos (x1,y1)) (Geopos (x2,y2)) = sqrt (x*x + y*y) where x = x1 - x2 y = y1 - y2 diff --git a/lib/GTFS.hs b/lib/GTFS.hs index c4652e8..cb9be2a 100644 --- a/lib/GTFS.hs +++ b/lib/GTFS.hs @@ -88,11 +88,11 @@ swaggerOptions prefix = -- whatsoever, but are given in the timezone of the transport agency, and -- potentially displayed in a different timezone depending on the station they -- apply to. -data Time = Time { timeSeconds :: Int, timeTZseries :: TimeZoneSeries, timeTZname :: Text } +data Time = Time { timeSeconds :: Int, tzname :: Text } deriving (Generic) instance ToJSON Time where - toJSON (Time seconds _ tzname) = + toJSON (Time seconds tzname) = A.object [ "seconds" A..= seconds, "timezone" A..= tzname ] -- | a type for all timetable values lacking context @@ -115,7 +115,7 @@ seconds2Double = int2Double . unSeconds -- at the given number of seconds since midnight (note that this may lead to -- strange effects for timezone changes not taking place at midnight) toSeconds :: Time -> TimeZoneSeries -> Day -> Seconds -toSeconds (Time seconds _ _) tzseries refday = +toSeconds (Time seconds _) tzseries refday = Seconds $ seconds - timeZoneMinutes timezone * 60 where timezone = timeZoneFromSeries tzseries reftime reftime = UTCTime refday (fromInteger $ toInteger seconds) @@ -130,7 +130,7 @@ toUTC time tzseries refday = -- | Times in GTFS are given without timezone info, which is handled -- seperately (as an attribute of the stop / the agency). We attach that information -- back to the Time, this is just an intermediate step during parsing. -newtype RawTime = RawTime { unRawTime :: TimeZoneSeries -> Text -> Time } +newtype RawTime = RawTime { unRawTime :: Text -> Time } deriving (Generic) instance CSV.FromField RawTime where @@ -143,7 +143,7 @@ instance CSV.FromField RawTime where _ -> fail $ "encountered an invalid date: " <> text instance Show Time where - show (Time seconds _ _) = "" + show (Time seconds _) = "" +|pad (seconds `div` 3600)|+":" +|pad ((seconds `mod` 3600) `div` 60)|+ if seconds `mod` 60 /= 0 then":"+|pad (seconds `mod` 60)|+"" @@ -154,7 +154,7 @@ instance Show Time where where str = show num showTimeWithSeconds :: Time -> String -showTimeWithSeconds (Time seconds _ _) = "" +showTimeWithSeconds (Time seconds _) = "" +|pad (seconds `div` 3600)|+":" +|pad ((seconds `mod` 3600) `div` 60)|+ ":"+|pad (seconds `mod` 60)|+"" @@ -587,8 +587,8 @@ loadGtfs path zoneinforoot = do tzseries <- getTimeZoneSeriesFromOlsonFile (T.unpack $ "/etc/zoneinfo/"<>tzname) pure (tzseries, tzname) pure $ stop { stopStation = station - , stopDeparture = unRawTime (stopDeparture stop) tzseries tzname - , stopArrival = unRawTime (stopArrival stop) tzseries tzname } + , stopDeparture = unRawTime (stopDeparture stop) tzname + , stopArrival = unRawTime (stopArrival stop) tzname } pushTrip :: Map Text (Route Deep) -> Vector (Stop Deep) -> Map Text Shape -> Trip Shallow Shallow -> IO (Trip Deep Deep) pushTrip routes stops shapes trip = if V.length alongRoute < 2 then fail $ "trip with id "+|tripTripId trip|+" has no stops" diff --git a/lib/Persist.hs b/lib/Persist.hs index b52d7c6..7613fd9 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -16,10 +16,10 @@ import Data.Swagger (ToParamSchema (..), ToSchema (..), import Data.Text (Text) import Data.UUID (UUID) import Database.Persist -import Database.Persist.Sql (PersistFieldSql, +import Database.Persist.Sql (PersistFieldSql (..), runSqlPersistMPool) import Database.Persist.TH -import GTFS +import qualified GTFS import PersistOrphans import Servant (FromHttpApiData (..), ToHttpApiData) @@ -55,22 +55,65 @@ instance ToSchema Token where instance ToParamSchema Token where toParamSchema _ = toParamSchema (Proxy @String) -deriving newtype instance PersistField Seconds -deriving newtype instance PersistFieldSql Seconds +deriving newtype instance PersistField GTFS.Seconds +deriving newtype instance PersistFieldSql GTFS.Seconds + +instance PersistField GTFS.Time where + toPersistValue :: GTFS.Time -> PersistValue + toPersistValue (GTFS.Time seconds zone) = toPersistValue (seconds, zone) + fromPersistValue :: PersistValue -> Either Text GTFS.Time + fromPersistValue = fmap (uncurry GTFS.Time) . fromPersistValue + +instance PersistFieldSql GTFS.Time where + sqlType :: Proxy GTFS.Time -> SqlType + sqlType _ = sqlType (Proxy @(Int, Text)) + + +-- TODO: postgres actually has a native type for this +newtype Geopos = Geopos { unGeoPos :: (Double, Double) } + deriving newtype (PersistField, PersistFieldSql, Show, Eq, FromJSON, ToJSON, ToSchema) + +latitude :: Geopos -> Double +latitude = fst . unGeoPos + +longitude :: Geopos -> Double +longitude = snd . unGeoPos share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| Ticket sql=tt_ticket Id UUID default=uuid_generate_v4() - trip TripId + tripName Text day Day imported UTCTime schedule_version ImportId Maybe vehicle Text Maybe + completed Bool + headsign Text + shape ShapeId Import sql=tt_imports url Text date UTCTime +Stop sql=tt_stop + ticket TicketId + station StationId + arrival GTFS.Time + departure GTFS.Time + sequence Int + +Station sql=tt_station + geopos Geopos + shortName Text + name Text + +ShapePoint sql=tt_shape_point + geopos Geopos + index Int + shape ShapeId + +Shape sql=tt_shape + -- | tokens which have been issued Tracker sql=tt_tracker_token Id Token default=uuid_generate_v4() @@ -89,8 +132,7 @@ TrackerTicket TrainPing json sql=tt_trip_ping ticket TicketId token TrackerId - lat Double - long Double + geopos Geopos timestamp UTCTime deriving Show Generic Eq @@ -99,9 +141,9 @@ TrainPing json sql=tt_trip_ping TrainAnchor json sql=tt_trip_anchor ticket TicketId created UTCTime - when Seconds + when GTFS.Seconds sequence Double - delay Seconds + delay GTFS.Seconds msg MultiLangText Maybe deriving Show Generic Eq @@ -121,11 +163,11 @@ instance ToSchema TicketId where instance ToSchema TrackerId where declareNamedSchema _ = declareNamedSchema (Proxy @UUID) instance ToSchema TrainPing where - declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trainPing") + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainPing") instance ToSchema TrainAnchor where - declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trainAnchor") + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainAnchor") instance ToSchema Announcement where - declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "announcement") + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "announcement") runSql :: MonadIO m => Pool SqlBackend -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a runSql pool = liftIO . flip runSqlPersistMPool pool 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

_{MsgLoggedInAs name} - _{MsgLogout}