diff options
| -rw-r--r-- | lib/API.hs | 8 | ||||
| -rw-r--r-- | lib/Extrapolation.hs | 143 | ||||
| -rw-r--r-- | lib/GTFS.hs | 16 | ||||
| -rw-r--r-- | lib/Persist.hs | 66 | ||||
| -rw-r--r-- | lib/Server.hs | 207 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 274 | ||||
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 115 | ||||
| -rw-r--r-- | messages/de.msg | 2 | ||||
| -rw-r--r-- | messages/en.msg | 2 | ||||
| -rw-r--r-- | site/obu.hamlet | 6 | ||||
| -rw-r--r-- | tracktrain.cabal | 1 |
11 files changed, 508 insertions, 332 deletions
@@ -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 <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 diff --git a/messages/de.msg b/messages/de.msg index f3a9e2b..53e5ede 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -39,7 +39,7 @@ Submit: Ok ImportTrips: Fahrten importieren Tickets: Tickets delete: löschen -AccordingToGtfs: Fahrten im GTFS +AccordingToGtfs: Weitere Fahrten im GTFS OBU: Onboard-Unit ChooseTrain: Fahrt auswählen diff --git a/messages/en.msg b/messages/en.msg index 2c734d2..41ced10 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -39,7 +39,7 @@ Submit: Submit Tickets: Tickets ImportTrips: import selected trips delete: delete -AccordingToGtfs: Trips contained in the Gtfs +AccordingToGtfs: Additional Trips contained in the Gtfs OBU: Onboard-Unit ChooseTrain: Choose a Train diff --git a/site/obu.hamlet b/site/obu.hamlet index 7068014..ed8017a 100644 --- a/site/obu.hamlet +++ b/site/obu.hamlet @@ -1,7 +1,7 @@ <h1>_{MsgOBU} <section> - <h2>#{tripId} _{Msgon} #{day} + <h2>#{ticketTripName} _{Msgon} #{ticketDay} <strong>Token:</strong> <span id="token"> <section> @@ -107,10 +107,10 @@ async function main() { - let trip = await (await fetch("/api/trip/#{tripId}")).json(); + let trip = await (await fetch("/api/trip/#{ticketTripName}")).json(); console.log("got trip info"); - token = await (await fetch("/api/train/register/#{tripId}", { + token = await (await fetch("/api/train/register/#{UUID.toText ticketId}", { method: "POST", body: JSON.stringify({agent: "onboard-unit"}), headers: {"Content-Type": "application/json"} diff --git a/tracktrain.cabal b/tracktrain.cabal index 1179bdd..ad1624f 100644 --- a/tracktrain.cabal +++ b/tracktrain.cabal @@ -96,6 +96,7 @@ library , exceptions , proto-lens , http-media + , filepath hs-source-dirs: lib exposed-modules: GTFS , Server |