From 607b9486a81ed6cb65d30227aeecea3412bd1ccd Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sat, 20 Apr 2024 03:18:46 +0200 Subject: 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). --- lib/API.hs | 12 +-- lib/Extrapolation.hs | 22 +++-- lib/GTFS.hs | 32 +++---- lib/MultiLangText.hs | 12 +++ lib/Persist.hs | 55 ++++++------ lib/Server.hs | 91 ++++++++++--------- lib/Server/ControlRoom.hs | 224 +++++++++++++++++++++++++++++++--------------- lib/Server/GTFS_RT.hs | 49 ++++++---- 8 files changed, 305 insertions(+), 192 deletions(-) create mode 100644 lib/MultiLangText.hs (limited to 'lib') 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|

_{MsgTrainsOnDay (iso8601Show day)} @@ -205,38 +216,71 @@ $maybe name <- mdisplayname _{Msgtoday} #{nextday} →
+

_{MsgTickets}
    - $forall trip@Trip{..} <- trips -
  1. _{MsgTrip} #{tripName trip} - : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} - $if null trips + $forall (ticketId, Ticket{..}, trip@Trip{..}) <- tickets +
  2. _{MsgTrip} #{tripName trip} + : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} → #{headsign trip} + $if null tickets
  3. (_{MsgNone}) +
    +

    _{MsgAccordingToGtfs} +
    + ^{widget} +