aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/API.hs8
-rw-r--r--lib/Extrapolation.hs143
-rw-r--r--lib/GTFS.hs16
-rw-r--r--lib/Persist.hs66
-rw-r--r--lib/Server.hs207
-rw-r--r--lib/Server/ControlRoom.hs274
-rw-r--r--lib/Server/GTFS_RT.hs115
7 files changed, 502 insertions, 327 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
<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: '&copy; <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