aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorstuebinm2024-04-20 03:18:46 +0200
committerstuebinm2024-04-20 03:18:46 +0200
commit607b9486a81ed6cb65d30227aeecea3412bd1ccd (patch)
tree0bfde1a39d2af5e56d53dbaea05638458c478de5
parent9301b4b012d3cae1a481320b1460c5bea674fd8c (diff)
restructure: have "tickets" independent of gtfs
this is mostly meant to guard against the gtfs changing under tracktrain, and not yet complete (e.g. a ticket does not yet save its expected stops, which it probably should).
Diffstat (limited to '')
-rw-r--r--GLOSSARY.md35
-rw-r--r--lib/API.hs12
-rw-r--r--lib/Extrapolation.hs22
-rw-r--r--lib/GTFS.hs32
-rw-r--r--lib/MultiLangText.hs12
-rw-r--r--lib/Persist.hs55
-rw-r--r--lib/Server.hs91
-rw-r--r--lib/Server/ControlRoom.hs224
-rw-r--r--lib/Server/GTFS_RT.hs49
-rw-r--r--messages/de.msg3
-rw-r--r--messages/en.msg3
-rw-r--r--todo.org1
-rwxr-xr-xtools/obu-guess-trip7
-rw-r--r--tools/obu-state.edn2
-rw-r--r--tracktrain.cabal1
15 files changed, 341 insertions, 208 deletions
diff --git a/GLOSSARY.md b/GLOSSARY.md
index 664edd9..062f897 100644
--- a/GLOSSARY.md
+++ b/GLOSSARY.md
@@ -8,24 +8,33 @@ terminology used by GTFS.
## Terms
+Ticket
+: A single tracked trip. These are imported from the GTFS (or couple be created
+ manually via the web interface), and are independent from it, i.e. they are
+ saved in tracktrain's data base and won't change with subsequent GTFS updates,
+ but would have to be deleted and reimported instead.
+
+ This prevents tracktrain from ending up with invalid data if a trip's id
+ or stops change retroactively.
+
+Trip (don't confuse with Train)
+: Used as in GTFS: a trip is a defined sequence of *stops*, referred to by
+ a number (called its trip ID, e.g. IC 94). Usually runs on multiple
+ days. Always has an associated *shape*.
+
+ (might match your intuition for "train line")
+
(Calendar-)Date / Day
: A single, unique day (e.g. 1970-01-01). Usually used to indicate if a
*trip* is running on that day or not.
-Time (of Day)
+Seconds (on a given Day)
: Time on a given day, given in seconds (though often displayed as
minutes) since midnight. If a trip crosses midnight it is treated as if
it took place entirely on the previous day, and times simply count up
beyond the total number of seconds in a day (note that that's a
timezone-series dependent number).
-Trip (don't confuse with Train)
-: Used as in GTFS: a trip is a defined sequence of *stops*, referred to by
- a number (called its trip ID, e.g. IC 94). Usually runs on multiple
- days. Always has an associated *shape*.
-
- (might match your intuition for "train line")
-
Stop
: A *station* with associated arrival/departure *time*.
@@ -37,11 +46,6 @@ Shape
: A sequence of geolocations describing a line between stations,
describing the physical railway along which trains travel.
-Train (don't confuse with Trip)
-: A single instance of a *trip* on a concrete *date*. Tracktrain mostly
- concerns itself with keeping track of those; the rest is just additional
- stuff.
-
Vehicle
: An actual, physical vehicle, which might act as the *train* going along
a *trip* on a certain *date*.
@@ -57,6 +61,11 @@ Announcement
: A single packet of data sent from a train's *OBU*. Might arrive in some
arbitrary order.
+(Train-)Anchor
+: An "anchored" point of position of a train along a trip; a snapshot of its
+ delay and state at a known position. These are generated from train pings,
+ and are the basis for extrapolating future delays for passanger information.
+
Control Room
: The "admin interface" of tracktrain, which is not meant to be used by
on-board staff.
diff --git a/lib/API.hs b/lib/API.hs
index b18ebdd..ab04a53 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -63,20 +63,20 @@ instance ToSchema Value where
-- | 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))
+ :<|> "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)
+ :<|> "trip" :> Capture "Trip Id" TripId :> Get '[JSON] (Trip Deep Deep)
-- ingress API (put this behind BasicAuth?)
-- TODO: perhaps require a first ping for registration?
- :<|> "train" :> "register" :> Capture "Trip ID" TripID :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token
+ :<|> "train" :> "register" :> Capture "Ticket Id" UUID :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token
-- TODO: perhaps a websocket instead?
:<|> "train" :> "ping" :> ReqBody '[JSON] TrainPing :> Post '[JSON] (Maybe TrainAnchor)
:<|> "train" :> "ping" :> "ws" :> WebSocket
- :<|> "train" :> "subscribe" :> Capture "Trip ID" TripID :> Capture "Day" Day :> WebSocket
+ :<|> "train" :> "subscribe" :> Capture "Ticket Id" UUID :> WebSocket
-- debug things
:<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing])
- :<|> "debug" :> "pings" :> Capture "Trip ID" TripID :> Capture "day" Day :> Get '[JSON] [TrainPing]
- :<|> "debug" :> "register" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] Token
+ :<|> "debug" :> "pings" :> Capture "Ticket Id" UUID :> Get '[JSON] [TrainPing]
+ :<|> "debug" :> "register" :> Capture "Ticket Id" UUID :> Post '[JSON] Token
:<|> "gtfs.zip" :> Get '[OctetStream] GTFSFile
:<|> "gtfs" :> GtfsRealtimeAPI
diff --git a/lib/Extrapolation.hs b/lib/Extrapolation.hs
index 6a2d88a..8edcc25 100644
--- a/lib/Extrapolation.hs
+++ b/lib/Extrapolation.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
@@ -24,8 +23,8 @@ import GTFS (Depth (Deep), GTFS (..), Seconds (..),
Shape (..), Station (stationName),
Stop (..), Time, Trip (..), seconds2Double,
stationGeopos, toSeconds)
-import Persist (Running (..), TrainAnchor (..),
- TrainPing (..))
+import Persist (Ticket (..), Token (..), Tracker (..),
+ TrainAnchor (..), TrainPing (..))
import Server.Util (utcToSeconds)
-- | Determines how to extrapolate delays (and potentially other things) from the real-time
@@ -33,7 +32,7 @@ import Server.Util (utcToSeconds)
-- TODO: maybe split into two classes?
class Extrapolator a where
-- | here's a position ping, guess things from that!
- extrapolateAnchorFromPing :: a -> GTFS -> Running -> TrainPing -> TrainAnchor
+ extrapolateAnchorFromPing :: a -> GTFS -> Ticket -> TrainPing -> TrainAnchor
-- | extrapolate status at some time (i.e. "how much delay does the train have *now*?")
extrapolateAtSeconds :: a -> NonEmpty TrainAnchor -> Seconds -> Maybe TrainAnchor
@@ -47,7 +46,7 @@ instance Extrapolator LinearExtrapolator where
extrapolateAtSeconds _ history secondsNow =
fmap (minimumBy (compare `on` difference))
$ NE.nonEmpty $ NE.filter (\a -> trainAnchorWhen a < secondsNow) history
- where difference status = secondsNow - (trainAnchorWhen status)
+ where difference status = secondsNow - trainAnchorWhen status
-- note that this sorts (descending) for time first as a tie-breaker
-- (in case the train just stands still for a while, take the most recent update)
@@ -55,19 +54,18 @@ instance Extrapolator LinearExtrapolator where
fmap (minimumBy (compare `on` difference))
$ NE.nonEmpty $ sortOn (Down . trainAnchorWhen)
$ NE.filter (\a -> trainAnchorSequence a < positionNow) history
- where difference status = positionNow - (trainAnchorSequence status)
+ where difference status = positionNow - trainAnchorSequence status
- extrapolateAnchorFromPing _ gtfs@GTFS{..} Running{..} ping@TrainPing{..} = TrainAnchor
+ extrapolateAnchorFromPing _ gtfs@GTFS{..} Ticket{..} ping@TrainPing{..} = TrainAnchor
{ trainAnchorCreated = trainPingTimestamp
- , trainAnchorTrip = runningTrip
- , trainAnchorDay = runningDay
- , trainAnchorWhen = utcToSeconds trainPingTimestamp runningDay
+ , trainAnchorTicket = trainPingTicket
+ , trainAnchorWhen = utcToSeconds trainPingTimestamp ticketDay
, trainAnchorSequence
, trainAnchorDelay
, trainAnchorMsg = Nothing
}
- where Just trip = M.lookup runningTrip trips
- (trainAnchorDelay, trainAnchorSequence) = linearDelay gtfs trip ping runningDay
+ where Just trip = M.lookup ticketTrip trips
+ (trainAnchorDelay, trainAnchorSequence) = linearDelay gtfs trip ping ticketDay
linearDelay :: GTFS -> Trip Deep Deep -> TrainPing -> Day -> (Seconds, Double)
linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = (observedDelay, observedSequence)
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index 6d8bcc5..c4652e8 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -193,7 +193,7 @@ type family Optional c a where
Optional Shallow _ = ()
type StationID = Text
-type TripID = Text
+type TripId = Text
type ServiceID = Text
@@ -218,7 +218,7 @@ stationGeopos Station{..} = (stationLat, stationLon)
-- | This is what's called a stop time in GTFS
data Stop (deep :: Depth) = Stop
- { stopTrip :: TripID
+ { stopTrip :: TripId
, stopArrival :: Switch deep Time RawTime
, stopDeparture :: Switch deep Time RawTime
, stopStation :: Switch deep Station StationID
@@ -274,7 +274,7 @@ instance FromForm CalendarDate
data Trip (deep :: Depth) (shape :: Depth)= Trip
{ tripRoute :: Switch deep (Route Deep) Text
- , tripTripID :: TripID
+ , tripTripId :: TripId
, tripHeadsign :: Maybe Text
, tripShortName :: Maybe Text
, tripDirection :: Maybe Bool
@@ -487,7 +487,7 @@ data RawGTFS = RawGTFS
data GTFS = GTFS
{ stations :: Map StationID Station
- , trips :: Map TripID (Trip Deep Deep)
+ , trips :: Map TripId (Trip Deep Deep)
, calendar :: Map DayOfWeek (Vector Calendar)
, calendarDates :: Map Day (Vector CalendarDate)
, shapes :: Map Text Shape
@@ -549,7 +549,7 @@ loadGtfs path zoneinforoot = do
trips' <- V.mapM (pushTrip routes' stops' shapes) rawTrips
pure $ GTFS
{ stations = mapFromVector stationId rawStations
- , trips = mapFromVector tripTripID trips'
+ , trips = mapFromVector tripTripId trips'
, calendar =
fmap V.fromList
$ M.fromListWith (<>)
@@ -591,18 +591,18 @@ loadGtfs path zoneinforoot = do
, stopArrival = unRawTime (stopArrival stop) tzseries 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"
+ then fail $ "trip with id "+|tripTripId trip|+" has no stops"
else do
shape <- case M.lookup (tripShape trip) shapes of
- Nothing -> fail $ "trip with id "+|tripTripID trip|+" mentions a shape that does not exist."
+ Nothing -> fail $ "trip with id "+|tripTripId trip|+" mentions a shape that does not exist."
Just shape -> pure shape
route <- case M.lookup (tripRoute trip) routes of
- Nothing -> fail $ "trip with id "+|tripTripID trip|+" specifies a route_id which does not exist."
+ Nothing -> fail $ "trip with id "+|tripTripId trip|+" specifies a route_id which does not exist."
Just route -> pure route
pure $ trip { tripStops = alongRoute, tripShape = shape, tripRoute = route}
where alongRoute =
V.modify (V.sortBy (compare `on` stopSequence))
- $ V.filter (\s -> stopTrip s == tripTripID trip) stops
+ $ V.filter (\s -> stopTrip s == tripTripId trip) stops
pushRoute :: Vector (Agency Deep) -> Route Shallow -> IO (Route Deep)
pushRoute agencies route = case routeAgency route of
Nothing -> do
@@ -636,27 +636,27 @@ servicesOnDay GTFS{..} day =
notCancelled serviceID =
null (tableLookup caldateServiceId serviceID removed)
-tripsOfService :: GTFS -> ServiceID -> Map TripID (Trip Deep Deep)
+tripsOfService :: GTFS -> ServiceID -> Map TripId (Trip Deep Deep)
tripsOfService GTFS{..} serviceId =
M.filter (\trip -> tripServiceId trip == serviceId ) trips
-- TODO: this should filter out trips ending there
-tripsAtStation :: GTFS -> StationID -> Vector TripID
+tripsAtStation :: GTFS -> StationID -> Vector TripId
tripsAtStation GTFS{..} at = fmap stopTrip stops
where
stops = V.filter (\(stop :: Stop Deep) -> stationId (stopStation stop) == at) stops
-tripsOnDay :: GTFS -> Day -> Map TripID (Trip Deep Deep)
+tripsOnDay :: GTFS -> Day -> Map TripId (Trip Deep Deep)
tripsOnDay gtfs today = foldMap (tripsOfService gtfs) (servicesOnDay gtfs today)
-runsOnDay :: GTFS -> TripID -> Day -> Bool
+runsOnDay :: GTFS -> TripId -> Day -> Bool
runsOnDay gtfs trip day = not . null . M.filter same $ tripsOnDay gtfs day
- where same Trip{..} = tripTripID == trip
+ where same Trip{..} = tripTripId == trip
-runsToday :: MonadIO m => GTFS -> TripID -> m Bool
+runsToday :: MonadIO m => GTFS -> TripId -> m Bool
runsToday gtfs trip = do
today <- liftIO getCurrentTime <&> utctDay
pure (runsOnDay gtfs trip today)
tripName :: Trip a b -> Text
-tripName Trip{..} = fromMaybe tripTripID tripShortName
+tripName Trip{..} = fromMaybe tripTripId tripShortName
diff --git a/lib/MultiLangText.hs b/lib/MultiLangText.hs
new file mode 100644
index 0000000..4cd3fc3
--- /dev/null
+++ b/lib/MultiLangText.hs
@@ -0,0 +1,12 @@
+
+-- | simple translated text
+module MultiLangText (MultiLangText, monolingual) where
+
+import Data.Map (Map, singleton)
+import Data.Text (Text)
+import Text.Shakespeare.I18N (Lang)
+
+type MultiLangText = Map Lang Text
+
+monolingual :: Lang -> Text -> MultiLangText
+monolingual = singleton
diff --git a/lib/Persist.hs b/lib/Persist.hs
index cd77b7a..b52d7c6 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -29,6 +29,7 @@ import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (NoLoggingT)
import Control.Monad.Reader (ReaderT)
import Data.Data (Proxy (..))
+import Data.Map (Map)
import Data.Pool (Pool)
import Data.Time (NominalDiffTime, TimeOfDay,
UTCTime (utctDay), addUTCTime,
@@ -39,7 +40,9 @@ import Data.Vector (Vector)
import Database.Persist.Postgresql (SqlBackend)
import Fmt
import GHC.Generics (Generic)
+import MultiLangText (MultiLangText)
import Web.PathPieces (PathPiece)
+import Yesod (Lang)
newtype Token = Token UUID
@@ -54,28 +57,38 @@ instance ToParamSchema Token where
deriving newtype instance PersistField Seconds
deriving newtype instance PersistFieldSql Seconds
--- deriving newtype instance PathPiece Seconds
--- deriving newtype instance ToParamSchema Seconds
-
-data AmendmentStatus = Cancelled | Added | PartiallyCancelled Int Int
- deriving (ToJSON, FromJSON, Generic, Show, Read, Eq)
-derivePersistField "AmendmentStatus"
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+Ticket sql=tt_ticket
+ Id UUID default=uuid_generate_v4()
+ trip TripId
+ day Day
+ imported UTCTime
+ schedule_version ImportId Maybe
+ vehicle Text Maybe
+
+Import sql=tt_imports
+ url Text
+ date UTCTime
+
-- | tokens which have been issued
-Running sql=tt_tracker_token
+Tracker sql=tt_tracker_token
Id Token default=uuid_generate_v4()
expires UTCTime
blocked Bool
- trip Text
- day Day
- vehicle Text Maybe
agent Text
deriving Eq Show Generic
+TrackerTicket
+ ticket TicketId
+ tracker TrackerId
+ UniqueTrackerTicket ticket tracker
+
+
-- raw frames as received from OBUs
TrainPing json sql=tt_trip_ping
- token RunningId
+ ticket TicketId
+ token TrackerId
lat Double
long Double
timestamp UTCTime
@@ -84,36 +97,28 @@ TrainPing json sql=tt_trip_ping
-- status of a train somewhen in time (may be in the future),
-- inferred from trainpings / entered via controlRoom
TrainAnchor json sql=tt_trip_anchor
- trip TripID
- day Day
+ ticket TicketId
created UTCTime
when Seconds
sequence Double
delay Seconds
- msg Text Maybe
+ msg MultiLangText Maybe
deriving Show Generic Eq
-- TODO: multi-language support?
Announcement json sql=tt_announcements
Id UUID default=uuid_generate_v4()
- trip TripID
+ ticket TicketId
header Text
message Text
- day Day
url Text Maybe
announcedAt UTCTime Maybe
deriving Generic Show
-
--- | this table works as calendar_dates.txt in GTFS
-ScheduleAmendment json sql=tt_schedule_amendement
- trip TripID
- day Day
- status AmendmentStatus
- -- only one special rule per TripID and Day (else incoherent)
- TripAndDay trip day
|]
-instance ToSchema RunningId where
+instance ToSchema TicketId where
+ declareNamedSchema _ = declareNamedSchema (Proxy @UUID)
+instance ToSchema TrackerId where
declareNamedSchema _ = declareNamedSchema (Proxy @UUID)
instance ToSchema TrainPing where
declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trainPing")
diff --git a/lib/Server.hs b/lib/Server.hs
index 016707b..c6d2d94 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -1,8 +1,9 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE ExplicitNamespaces #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RecordWildCards #-}
-- Implementation of the API. This module is the main point of the program.
@@ -16,8 +17,8 @@ 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, logWarnN)
-import Control.Monad.Reader (forM)
+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
@@ -61,9 +62,11 @@ 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 Prometheus
import Prometheus.Metric.GHC
@@ -83,7 +86,7 @@ doMigration pool = runSql pool $
-- returns an empty list
runMigration migrateAll
-server :: GTFS -> Metrics -> TVar (M.Map TripID [TQueue (Maybe TrainPing)]) -> Pool SqlBackend -> ServerConfig -> Service CompleteAPI
+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
:<|> handleRegister :<|> handleTrainPing (throwError err401) :<|> handleWS
@@ -101,7 +104,7 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
pure . A.toJSON . fmap mkJson . M.elems $ tripsOnDay gtfs day
where mkJson :: Trip Deep Deep -> A.Value
mkJson Trip {..} = A.object
- [ "trip" .= tripTripID
+ [ "trip" .= tripTripId
, "sequencelength" .= (stopSequence . V.last) tripStops
, "stops" .= fmap (\Stop{..} -> A.object
[ "departure" .= toUTC stopDeparture tzseries day
@@ -114,34 +117,35 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
handleTrip trip = case M.lookup trip trips of
Just res -> pure res
Nothing -> throwError err404
- handleRegister tripID RegisterJson{..} = do
+ handleRegister (ticketId :: UUID) RegisterJson{..} = do
today <- liftIO getCurrentTime <&> utctDay
- unless (runsOnDay gtfs tripID today)
- $ sendErrorMsg "this trip does not run today."
expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod
- RunningKey token <- runSql dbpool $ insert (Running expires False tripID today Nothing registerAgent)
- pure token
- handleDebugRegister tripID day = do
+ runSql dbpool $ do
+ TrackerKey tracker <- insert (Tracker expires False registerAgent)
+ insert (TrackerTicket (TicketKey ticketId) (TrackerKey tracker))
+ pure tracker
+ handleDebugRegister (ticketId :: UUID) = do
expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod
- RunningKey token <- runSql dbpool $ insert (Running expires False tripID day Nothing "debug key")
- pure token
- handleTrainPing onError ping = isTokenValid dbpool (coerce $ trainPingToken ping) >>= \case
+ runSql dbpool $ do
+ 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
Nothing -> do
onError
pure Nothing
- Just running@Running{..} -> do
- let anchor = extrapolateAnchorFromPing LinearExtrapolator gtfs running ping
+ Just (tracker@Tracker{..}, ticket@Ticket{..}) -> do
+ let anchor = extrapolateAnchorFromPing LinearExtrapolator gtfs ticket ping
-- TODO: are these always inserted in order?
runSql dbpool $ do
insert ping
- last <- selectFirst
- [TrainAnchorTrip ==. runningTrip, TrainAnchorDay ==. runningDay]
- [Desc TrainAnchorWhen]
+ 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 runningTrip
+ queues <- readTVar subscribers <&> M.lookup (coerce trainPingTicket)
whenJust queues $
mapM_ (\q -> writeTQueue q (Just ping))
pure queues
@@ -162,18 +166,18 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
liftIO $ handleTrainPing (WS.sendClose conn ("" :: ByteString)) ping >>= \case
Just anchor -> WS.sendTextData conn (A.encode anchor)
Nothing -> pure ()
- handleSubscribe tripId day conn = liftIO $ WS.withPingThread conn 30 (pure ()) $ do
+ handleSubscribe (ticketId :: UUID) conn = liftIO $ WS.withPingThread conn 30 (pure ()) $ do
queue <- atomically $ do
queue <- newTQueue
qs <- readTVar subscribers
writeTVar subscribers
- $ M.insertWith (<>) tripId [queue] qs
+ $ M.insertWith (<>) ticketId [queue] qs
pure queue
-- send most recent ping, if any (so we won't have to wait for movement)
lastPing <- runSql dbpool $ do
- tokens <- selectList [RunningDay ==. day, RunningTrip ==. tripId] []
+ trackers <- getTicketTrackers ticketId
<&> fmap entityKey
- selectFirst [TrainPingToken <-. tokens] [Desc TrainPingTimestamp]
+ selectFirst [TrainPingToken <-. trackers] [Desc TrainPingTimestamp]
<&> fmap entityVal
whenJust lastPing $ \ping ->
WS.sendTextData conn (A.encode lastPing)
@@ -187,34 +191,39 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
where removeSubscriber queue = atomically $ do
qs <- readTVar subscribers
writeTVar subscribers
- $ M.adjust (filter (/= queue)) tripId qs
+ $ M.adjust (filter (/= queue)) ticketId qs
handleDebugState = do
now <- liftIO getCurrentTime
runSql dbpool $ do
- running <- selectList [RunningBlocked ==. False, RunningExpires >=. now] []
- pairs <- forM running $ \(Entity token@(RunningKey uuid) _) -> do
+ tracker <- selectList [TrackerBlocked ==. False, TrackerExpires >=. now] []
+ pairs <- forM tracker $ \(Entity token@(TrackerKey uuid) _) -> do
entities <- selectList [TrainPingToken ==. token] []
pure (uuid, fmap entityVal entities)
pure (M.fromList pairs)
- handleDebugTrain tripId day = do
- unless (runsOnDay gtfs tripId day)
- $ sendErrorMsg ("this trip does not run on "+|day|+".")
+ handleDebugTrain ticketId = do
runSql dbpool $ do
- tokens <- selectList [RunningTrip ==. tripId, RunningDay ==. day] []
- pings <- forM tokens $ \(Entity token _) -> do
+ trackers <- getTicketTrackers ticketId
+ pings <- forM trackers $ \(Entity token _) -> do
selectList [TrainPingToken ==. token] [] <&> fmap entityVal
pure (concat pings)
handleDebugAPI = pure $ toSwagger (Proxy @API)
metrics = exportMetricsAsText <&> (decodeUtf8 . toStrict)
+getTicketTrackers :: UUID -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) [Entity Tracker]
+getTicketTrackers ticketId = do
+ joins <- selectList [TrackerTicketTicket ==. TicketKey ticketId] []
+ <&> fmap (trackerTicketTracker . entityVal)
+ selectList [TrackerId <-. joins] []
+
-- TODO: proper debug logging for expired tokens
-isTokenValid :: MonadIO m => Pool SqlBackend -> Token -> m (Maybe Running)
-isTokenValid dbpool token = runSql dbpool $ get (coerce token) >>= \case
- Just trip | not (runningBlocked trip) -> do
- ifM (hasExpired (runningExpires trip))
+isTokenValid :: MonadIO m => Pool SqlBackend -> TrackerId -> TicketId -> m (Maybe (Tracker, Ticket))
+isTokenValid dbpool token ticketId = runSql dbpool $ get token >>= \case
+ Just tracker | not (trackerBlocked tracker) -> do
+ ifM (hasExpired (trackerExpires tracker))
(pure Nothing)
- (pure (Just trip))
+ $ runSql dbpool $ get ticketId
+ <&> (\case { Nothing -> Nothing; Just ticket -> Just (tracker, ticket) })
_ -> pure Nothing
hasExpired :: MonadIO m => UTCTime -> m Bool
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 773468a..4fb5ba8 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -1,16 +1,17 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
module Server.ControlRoom (ControlRoom(..)) where
-import Control.Monad (forM_, join)
+import Config (ServerConfig (..), UffdConfig (..))
+import Control.Monad (forM, forM_, join)
import Control.Monad.Extra (maybeM)
import Control.Monad.IO.Class (MonadIO (liftIO))
import qualified Data.Aeson as A
@@ -21,6 +22,7 @@ import Data.List (lookup)
import Data.List.NonEmpty (nonEmpty)
import Data.Map (Map)
import qualified Data.Map as M
+import Data.Maybe (catMaybes, fromJust)
import Data.Pool (Pool)
import Data.Text (Text)
import qualified Data.Text as T
@@ -35,9 +37,14 @@ import Database.Persist (Entity (..), delete, entityVal, get,
insert, selectList, (==.))
import Database.Persist.Sql (PersistFieldSql, SqlBackend,
runSqlPool)
+import Extrapolation (Extrapolator (..),
+ LinearExtrapolator (..))
import Fmt ((+|), (|+))
import GHC.Float (int2Double)
import GHC.Generics (Generic)
+import GTFS
+import Numeric (showFFloat)
+import Persist
import Server.Util (Service, secondsNow)
import Text.Blaze.Html (ToMarkup (..))
import Text.Blaze.Internal (MarkupM (Empty))
@@ -46,16 +53,9 @@ import Text.Shakespeare.Text
import Yesod
import Yesod.Auth
import Yesod.Auth.OAuth2.Prelude
-import Yesod.Form
-
-import Config (ServerConfig (..), UffdConfig (..))
-import Extrapolation (Extrapolator (..),
- LinearExtrapolator (..))
-import GTFS
-import Numeric (showFFloat)
-import Persist
import Yesod.Auth.OpenId (IdentifierType (..), authOpenId)
import Yesod.Auth.Uffd (UffdUser (..), uffdClient)
+import Yesod.Form
import Yesod.Orphans ()
@@ -71,15 +71,16 @@ mkYesod "ControlRoom" [parseRoutes|
/ RootR GET
/auth AuthR Auth getAuth
/trains TrainsR GET
-/train/id/#TripID/#Day TrainViewR GET
-/train/map/#TripID/#Day TrainMapViewR GET
-/train/announce/#TripID/#Day AnnounceR POST
+/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
/token/block/#Token TokenBlock GET
/trips TripsViewR GET
-/trip/#TripID TripViewR GET
+/trip/#TripId TripViewR GET
/obu OnboardUnitMenuR GET
-/obu/#TripID/#Day OnboardUnitR GET
+/obu/#TripId/#Day OnboardUnitR GET
|]
emptyMarkup :: MarkupM a -> Bool
@@ -191,7 +192,17 @@ getTrainsR = do
let prevday = (T.pack . iso8601Show . addDays (-1)) day
let nextday = (T.pack . iso8601Show . addDays 1) day
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))
+ (widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips)))
defaultLayout $ do
[whamlet|
<h1> _{MsgTrainsOnDay (iso8601Show day)}
@@ -205,38 +216,71 @@ $maybe name <- mdisplayname
<a href="@{TrainsR}">_{Msgtoday}
<a class="nav-right" href="@?{(TrainsR, [("day", nextday)])}">#{nextday} →
<section>
+ <h2>_{MsgTickets}
<ol>
- $forall trip@Trip{..} <- trips
- <li><a href="@{TrainViewR tripTripID day}">_{MsgTrip} #{tripName trip}</a>
- : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
- $if null trips
+ $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}
+ $if null tickets
<li style="text-align: center"><em>(_{MsgNone})
+<section>
+ <h2>_{MsgAccordingToGtfs}
+ <form method=post action="@{TicketImportR day}" enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgImportTrips}
|]
-getTrainViewR :: TripID -> Day -> Handler Html
-getTrainViewR trip day = do
+postTicketImportR :: Day -> Handler Html
+postTicketImportR day = do
+ gtfs <- getYesod <&> getGtfs
+ let trips = 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|
+<section>
+ <h2>_{MsgAccordingToGtfs}
+ <form method=post action="@{TicketImportR day}" enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgImportTrips}
+|]
+
+getTicketViewR :: UUID -> Handler Html
+getTicketViewR ticketId = do
+ Ticket{..} <- runDB $ get (TicketKey ticketId)
+ >>= \case {Nothing -> notFound; Just a -> pure a}
+
GTFS{..} <- getYesod <&> getGtfs
- (widget, enctype) <- generateFormPost (announceForm day trip)
- case M.lookup trip trips of
+ (widget, enctype) <- generateFormPost (announceForm ticketId)
+ case M.lookup ticketTrip trips of
Nothing -> notFound
Just res@Trip{..} -> do
- anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
- tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [Asc RunningExpires]
- lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp]
- anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] []
+ 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 day
+ nowSeconds <- secondsNow ticketDay
defaultLayout $ do
mr <- getMessageRender
- setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text))
+ 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 day))])}">#{day}</a>
+<h1>_{MsgTrip} <a href="@{TripViewR tripTripId}">#{tripName res}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show ticketDay))])}">#{ticketDay}</a>
<section>
<h2>_{MsgLive}
<p><strong>_{MsgLastPing}: </strong>
$maybe Entity _ TrainPing{..} <- lastPing
_{MsgTrainPing trainPingLat trainPingLong trainPingTimestamp}
- (<a href="/api/debug/pings/#{trip}/#{day}">_{Msgraw}</a>)
+ (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>)
$nothing
<em>(_{MsgNoTrainPing})
<p><strong>_{MsgEstimatedDelay}</strong>:
@@ -245,7 +289,7 @@ getTrainViewR trip day = do
\ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")})
$nothing
<em> (_{MsgNone})
- <p><a href="@{TrainMapViewR tripTripID day}">_{MsgMap}</a>
+ <p><a href="@{TrainMapViewR ticketId}">_{MsgMap}</a>
<section>
<h2>_{MsgStops}
<ol>
@@ -262,21 +306,21 @@ getTrainViewR trip day = do
$if null anns
<li><em>(_{MsgNone})</em>
<h3>_{MsgNewAnnouncement}
- <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
+ <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}>
^{widget}
<button>_{MsgSubmit}
<section>
<h2>_{MsgTokens}
<table>
<tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th>
- $if null tokens
+ $if null trackers
<tr><td></td><td style="text-align:center"><em>(_{MsgNone})
- $forall Entity (RunningKey key) Running{..} <- tokens
- <tr :runningBlocked:.blocked>
- <td title="#{runningAgent}">#{runningAgent}
+ $forall Entity (TrackerKey key) Tracker{..} <- trackers
+ <tr :trackerBlocked:.blocked>
+ <td title="#{trackerAgent}">#{trackerAgent}
<td title="#{key}">#{key}
- <td title="#{runningExpires}">#{runningExpires}
- $if runningBlocked
+ <td title="#{trackerExpires}">#{trackerExpires}
+ $if trackerBlocked
<td title="_{MsgUnblockToken}"><a href="@?{(TokenBlock key, [("unblock", "true")])}">_{MsgUnblockToken}</a>
$else
<td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a>
@@ -285,14 +329,16 @@ getTrainViewR trip day = do
guessAtSeconds = extrapolateAtSeconds LinearExtrapolator
-getTrainMapViewR :: TripID -> Day -> Handler Html
-getTrainMapViewR tripId day = do
+getTrainMapViewR :: UUID -> Handler Html
+getTrainMapViewR ticketId = do
+ Ticket{..} <- runDB $ get (TicketKey ticketId)
+ >>= \case { Nothing -> notFound ; Just ticket -> pure ticket }
GTFS{..} <- getYesod <&> getGtfs
- (widget, enctype) <- generateFormPost (announceForm day tripId)
- case M.lookup tripId trips of
+ (widget, enctype) <- generateFormPost (announceForm ticketId)
+ case M.lookup ticketTrip trips of
Nothing -> notFound
Just res@Trip{..} -> do defaultLayout [whamlet|
-<h1>_{MsgTrip} <a href="@{TrainViewR tripTripID day}">#{tripName res} _{Msgon} #{day}</a>
+<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{tripName res} _{Msgon} #{ticketDay}</a>
<link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css"
integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI="
crossorigin=""/>
@@ -308,7 +354,7 @@ getTrainMapViewR tripId day = 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}/#{day}");
+ ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{tripTripId}/#{ticketDay}");
var marker = null;
@@ -336,12 +382,12 @@ getTripsViewR = do
<h1>List of Trips
<section><ul>
$forall trip@Trip{..} <- trips
- <li><a href="@{TripViewR tripTripID}">#{tripName trip}</a>
+ <li><a href="@{TripViewR tripTripId}">#{tripName trip}</a>
: #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
|]
-getTripViewR :: TripID -> Handler Html
+getTripViewR :: TripId -> Handler Html
getTripViewR tripId = do
GTFS{..} <- getYesod <&> getGtfs
case M.lookup tripId trips of
@@ -350,7 +396,7 @@ getTripViewR tripId = do
<h1>_{MsgTrip} #{tripName trip}
<section>
<h2>_{MsgInfo}
- <p><strong>_{MsgtripId}:</strong> #{tripTripID}
+ <p><strong>_{MsgtripId}:</strong> #{tripTripId}
<p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign}
<p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName}
<section>
@@ -365,17 +411,17 @@ getTripViewR tripId = do
|]
-postAnnounceR :: TripID -> Day -> Handler Html
-postAnnounceR trip day = do
- ((result, widget), enctype) <- runFormPost (announceForm day trip)
+postAnnounceR :: UUID -> Handler Html
+postAnnounceR ticketId = do
+ ((result, widget), enctype) <- runFormPost (announceForm ticketId)
case result of
FormSuccess ann -> do
runDB $ insert ann
- redirect (TrainViewR trip day)
+ redirect RootR -- (TicketViewR trip day)
_ -> defaultLayout
[whamlet|
<p>_{MsgInvalidInput}.
- <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
+ <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}>
^{widget}
<button>_{MsgSubmit}
|]
@@ -389,19 +435,20 @@ getDelAnnounceR uuid = do
case ann of
Nothing -> notFound
Just Announcement{..} ->
- redirect (TrainViewR announcementTrip announcementDay)
+ let (TicketKey ticketId) = announcementTicket
+ in redirect (TicketViewR ticketId)
getTokenBlock :: Token -> Handler Html
getTokenBlock token = do
YesodRequest{..} <- getRequest
let blocked = lookup "unblock" reqGetParams /= Just "true"
maybe <- runDB $ do
- update (RunningKey token) [ RunningBlocked =. blocked ]
- get (RunningKey token)
+ update (TrackerKey token) [ TrackerBlocked =. blocked ]
+ get (TrackerKey token)
case maybe of
- Just r@Running{..} -> do
+ Just r@Tracker{..} -> do
liftIO $ print r
- redirect (TrainViewR runningTrip runningDay)
+ redirect RootR
Nothing -> notFound
getOnboardUnitMenuR :: Handler Html
@@ -416,24 +463,55 @@ getOnboardUnitMenuR = do
_{MsgChooseTrain}
$forall Trip{..} <- trips
<hr>
- <a href="@{OnboardUnitR tripTripID day}">
- #{tripTripID}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)}
+ <a href="@{OnboardUnitR tripTripId day}">
+ #{tripTripId}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)}
|]
-getOnboardUnitR :: TripID -> Day -> Handler Html
+getOnboardUnitR :: TripId -> Day -> Handler Html
getOnboardUnitR tripId day =
defaultLayout $(whamletFile "site/obu.hamlet")
-announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget)
-announceForm day tripId = renderDivs $ Announcement
- <$> pure tripId
+announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget)
+announceForm ticketId = renderDivs $ Announcement
+ <$> pure (TicketKey ticketId)
<*> areq textField (fieldSettingsLabel MsgHeader) Nothing
<*> areq textField (fieldSettingsLabel MsgText) Nothing
- <*> pure day
<*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing
<*> lift (liftIO getCurrentTime <&> Just)
+
+
+tripImportForm :: [(Trip Deep Deep, Day)] -> Html -> MForm Handler (FormResult [(Trip Deep Deep, Day)], Widget)
+tripImportForm trips extra = do
+ forms <- forM trips $ \(trip, day) -> do
+ (aRes, aView) <- mreq checkBoxField "import" Nothing
+ let dings = fmap (\res -> if res then Just (trip, day) else Nothing) aRes
+ pure (trip, day, dings, aView)
+
+ let widget = toWidget [whamlet|
+ #{extra}
+ <ol>
+ $forall (trip@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}
+ |]
+
+ let (a :: FormResult [Maybe (Trip Deep Deep, Day)]) =
+ sequenceA (fmap (\(_,_,res,_) -> res) forms)
+
+ pure (fmap catMaybes a, widget)
+
+
mightbe :: Maybe Text -> Text
mightbe (Just a) = a
mightbe Nothing = ""
+
+headsign :: Trip 'Deep 'Deep -> Text
+headsign (Trip{..} :: Trip Deep Deep) =
+ case tripHeadsign of
+ Just headsign -> headsign
+ Nothing -> stationName (stopStation (V.last tripStops))
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index 740f71c..412284f 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -1,8 +1,9 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE DataKinds #-}
module Server.GTFS_RT (gtfsRealtimeServer) where
@@ -30,21 +31,22 @@ import qualified Data.UUID as UUID
import qualified Data.Vector as V
import Database.Persist (Entity (..),
PersistQueryRead (selectFirst),
- selectList, (==.))
+ getJust, selectKeysList,
+ selectList, (<-.), (==.))
import Database.Persist.Postgresql (SqlBackend)
import Extrapolation (Extrapolator (extrapolateAtPosition, extrapolateAtSeconds),
LinearExtrapolator (..))
import GHC.Float (double2Float, int2Double)
import GTFS (Depth (..), GTFS (..),
Seconds (..), Stop (..),
- Trip (..), TripID,
+ Trip (..), TripId,
showTimeWithSeconds, stationId,
toSeconds, toUTC, tripsOnDay)
import Persist (Announcement (..),
EntityField (..), Key (..),
- Running (..), Token (..),
- TrainAnchor (..), TrainPing (..),
- runSql)
+ Ticket (..), Token (..),
+ Tracker (..), TrainAnchor (..),
+ TrainPing (..), runSql)
import qualified Proto.GtfsRealtime as RT
import qualified Proto.GtfsRealtime_Fields as RT
import Servant.API ((:<|>) (..))
@@ -70,17 +72,20 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
where
handleServiceAlerts = runSql dbpool $ do
announcements <- selectList [] []
- defFeedMessage (fmap mkAlert announcements)
+ alerts <- forM announcements $ \(Entity (AnnouncementKey uuid) announcement@Announcement{..}) -> do
+ ticket <- getJust announcementTicket
+ pure $ mkAlert uuid announcement ticket
+ defFeedMessage alerts
where
- mkAlert :: Entity Announcement -> RT.FeedEntity
- mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) =
+ mkAlert :: UUID.UUID -> Announcement -> Ticket -> RT.FeedEntity
+ mkAlert uuid Announcement{..} Ticket{..} =
defMessage
& RT.id .~ UUID.toText uuid
& RT.alert .~ (defMessage
& RT.activePeriod .~ [ defMessage :: RT.TimeRange ]
& RT.informedEntity .~ [ defMessage
- & RT.trip .~ defTripDescriptor announcementTrip (Just announcementDay) Nothing
+ & RT.trip .~ defTripDescriptor ticketTrip (Just ticketDay) Nothing
]
& RT.maybe'url .~ fmap (monolingual "de") announcementUrl
& RT.headerText .~ monolingual "de" announcementHeader
@@ -92,7 +97,8 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
nowSeconds <- secondsNow today
let running = M.toList (tripsOnDay gtfs today)
anchors <- flip mapMaybeM running $ \(tripId, trip@Trip{..}) -> do
- entities <- selectList [TrainAnchorTrip ==. tripId, TrainAnchorDay ==. today] []
+ tickets <- selectKeysList [TicketTrip ==. tripId, TicketDay ==. today] []
+ entities <- selectList [TrainAnchorTicket <-. tickets] []
case nonEmpty (fmap entityVal entities) of
Nothing -> pure Nothing
Just anchors -> pure $ Just (tripId, trip, anchors)
@@ -138,18 +144,23 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
& RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED
handleVehiclePositions = runSql dbpool $ do
- (running :: [Entity Running]) <- selectList [] []
- pings <- forM running $ \(Entity key entity) -> do
- selectFirst [TrainPingToken ==. key] [] <&> fmap (, entity)
+ (trackers :: [Entity Tracker]) <- selectList [] []
+ pings <- forM trackers $ \(Entity trackerId tracker) -> do
+ selectFirst [TrainPingToken ==. trackerId] [] >>= \case
+ Nothing -> pure Nothing
+ Just ping -> do
+ ticket <- getJust (trainPingTicket (entityVal ping))
+ pure (Just (ping, ticket, tracker))
+
defFeedMessage (mkPosition <$> catMaybes pings)
where
- mkPosition :: (Entity TrainPing, Running) -> RT.FeedEntity
- mkPosition (Entity (TrainPingKey key) TrainPing{..}, Running{..}) = defMessage
+ mkPosition :: (Entity TrainPing, Ticket, Tracker) -> RT.FeedEntity
+ mkPosition (Entity (TrainPingKey key) TrainPing{..}, Ticket{..}, Tracker{..}) = defMessage
& RT.id .~ T.pack (show key)
& RT.vehicle .~ (defMessage
- & RT.trip .~ defTripDescriptor runningTrip Nothing Nothing
- & RT.maybe'vehicle .~ case runningVehicle of
+ & RT.trip .~ defTripDescriptor ticketTrip Nothing Nothing
+ & RT.maybe'vehicle .~ case ticketVehicle of
Nothing -> Nothing
Just trainset -> Just $ defMessage
& RT.label .~ trainset
@@ -180,7 +191,7 @@ defFeedMessage entities = do
)
& RT.entity .~ entities
-defTripDescriptor :: TripID -> Maybe Day -> Maybe Text -> RT.TripDescriptor
+defTripDescriptor :: TripId -> Maybe Day -> Maybe Text -> RT.TripDescriptor
defTripDescriptor tripId day starttime = defMessage
& RT.tripId .~ tripId
& RT.scheduleRelationship .~ RT.TripDescriptor'SCHEDULED
diff --git a/messages/de.msg b/messages/de.msg
index 016ebbb..f3a9e2b 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -36,7 +36,10 @@ OnStationSequence idx: an Stationsindex #{idx}
Map: Karte
InvalidInput: Ungültige Eingabe, bitte noch einmal
Submit: Ok
+ImportTrips: Fahrten importieren
+Tickets: Tickets
delete: löschen
+AccordingToGtfs: Fahrten im GTFS
OBU: Onboard-Unit
ChooseTrain: Fahrt auswählen
diff --git a/messages/en.msg b/messages/en.msg
index ecaad0a..2c734d2 100644
--- a/messages/en.msg
+++ b/messages/en.msg
@@ -36,7 +36,10 @@ OnStationSequence idx@String: on station index #{idx}
Map: Map
InvalidInput: Invalid input, let's try again
Submit: Submit
+Tickets: Tickets
+ImportTrips: import selected trips
delete: delete
+AccordingToGtfs: Trips contained in the Gtfs
OBU: Onboard-Unit
ChooseTrain: Choose a Train
diff --git a/todo.org b/todo.org
index 7c5d891..b621e53 100644
--- a/todo.org
+++ b/todo.org
@@ -1,5 +1,6 @@
#+TITLE: Traintrack Todos
+* TODO be consistent & use lat/lon everywhere (not lat/long!)
* DONE Handle service announcements
(per trip & day, nothing else needs to be supported)
diff --git a/tools/obu-guess-trip b/tools/obu-guess-trip
index b9264f6..32aa6d4 100755
--- a/tools/obu-guess-trip
+++ b/tools/obu-guess-trip
@@ -44,8 +44,9 @@ Arguments:
(define pos
(with-input-from-process `(obu-ping -s ,statefile -n 1 -d) read))
(define guessed
- (closest-stop-to stops pos))
+ (closest-stop-to stops pos))
(define trip (assoc-ref guessed 'trip))
+ (display stops)
(do-process `(obu-config -s ,statefile sequencelength ,(assoc-ref guessed 'sequencelength)))
(display trip))
@@ -68,7 +69,7 @@ Arguments:
(define day (date->string (current-date) "~1"))
(define tls
(equal? (uri-ref url 'scheme) "https"))
- (parameterize
+ (define thing (parameterize
; replace all json keys with symbols; everything else is confusing
([json-object-handler
(cut map (lambda p `(,(string->symbol (car (car p))) . ,(cdr (car p)))) <>)])
@@ -76,3 +77,5 @@ Arguments:
(values-ref (http-get (uri-ref url 'host+port)
(format "/api/timetable/stops/~a" day)
:secure tls) 2))))
+ (display thing)
+ thing)
diff --git a/tools/obu-state.edn b/tools/obu-state.edn
index db989c8..b0c4b0e 100644
--- a/tools/obu-state.edn
+++ b/tools/obu-state.edn
@@ -1 +1 @@
-{token "5ab95c26-367e-40fc-8d3e-2956af6f61e4"} \ No newline at end of file
+{sequencelength "#f"} \ No newline at end of file
diff --git a/tracktrain.cabal b/tracktrain.cabal
index f245250..1179bdd 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -109,6 +109,7 @@ library
other-modules: Server.Util
, Yesod.Auth.Uffd
, Yesod.Orphans
+ , MultiLangText
default-language: GHC2021
default-extensions: OverloadedStrings
, ScopedTypeVariables