diff options
| -rw-r--r-- | GLOSSARY.md | 35 | ||||
| -rw-r--r-- | lib/API.hs | 12 | ||||
| -rw-r--r-- | lib/Extrapolation.hs | 22 | ||||
| -rw-r--r-- | lib/GTFS.hs | 32 | ||||
| -rw-r--r-- | lib/MultiLangText.hs | 12 | ||||
| -rw-r--r-- | lib/Persist.hs | 55 | ||||
| -rw-r--r-- | lib/Server.hs | 91 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 224 | ||||
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 49 | ||||
| -rw-r--r-- | messages/de.msg | 3 | ||||
| -rw-r--r-- | messages/en.msg | 3 | ||||
| -rw-r--r-- | todo.org | 1 | ||||
| -rwxr-xr-x | tools/obu-guess-trip | 7 | ||||
| -rw-r--r-- | tools/obu-state.edn | 2 | ||||
| -rw-r--r-- | tracktrain.cabal | 1 |
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. @@ -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: '© <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 @@ -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 |