From a4045a5b0a898042cd78eba9b22550c965a1bbd9 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sat, 27 Aug 2022 01:45:12 +0200 Subject: controlroom: lots of pretty little knobs (also some database schema changes, for good measure) --- lib/API.hs | 55 +++++++++++++----------------- lib/GTFS.hs | 10 ++++++ lib/Persist.hs | 48 ++++++++++++++++---------- lib/Server.hs | 78 +++++++++++++++++++++---------------------- lib/Server/ControlRoom.hs | 85 ++++++++++++++++++++++++++++++++++++----------- lib/Server/GTFS_RT.hs | 20 +++++------ lib/Server/Util.hs | 12 +++++-- 7 files changed, 185 insertions(+), 123 deletions(-) (limited to 'lib') diff --git a/lib/API.hs b/lib/API.hs index 99e96ae..9016524 100644 --- a/lib/API.hs +++ b/lib/API.hs @@ -1,15 +1,17 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -- | The sole authorative definition of this server's API, given as a Servant-style -- Haskell type. All other descriptions of the API are generated from this one. -module API (API, CompleteAPI, GtfsRealtimeAPI, AdminAPI) where +module API (API, CompleteAPI, GtfsRealtimeAPI, RegisterJson(..)) where import Data.Map (Map) import Data.Proxy (Proxy (..)) -import Data.Swagger (Swagger) +import Data.Swagger (Swagger, ToSchema (..), + genericDeclareNamedSchema) import Data.Swagger.ParamSchema (ToParamSchema (..)) import Data.Text (Text) import Data.Time (Day, UTCTime) @@ -25,12 +27,22 @@ import Servant.GTFS.Realtime (Proto) import Servant.Swagger (HasSwagger (..)) import Web.Internal.FormUrlEncoded (Form) +import Data.Aeson (FromJSON (..), genericParseJSON) +import GHC.Generics (Generic) import GTFS import GTFS.Realtime.FeedEntity import GTFS.Realtime.FeedMessage (FeedMessage) import Persist import Server.ControlRoom +data RegisterJson = RegisterJson + { registerAgent :: Text } + deriving (Show, Generic) + +instance FromJSON RegisterJson where + parseJSON = genericParseJSON (aesonOptions "register") +instance ToSchema RegisterJson where + declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "station") -- | The server's API (as it is actually intended). type API = "stations" :> Get '[JSON] (Map StationID Station) @@ -38,52 +50,31 @@ type API = "stations" :> Get '[JSON] (Map StationID Station) :<|> "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 :> Post '[JSON] Token + :<|> "train" :> "register" :> Capture "Trip ID" TripID :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token -- TODO: perhaps a websocket instead? - :<|> "train" :> "ping" :> ReqBody '[JSON] TripPing :> Post '[JSON] NoContent + :<|> "train" :> "ping" :> ReqBody '[JSON] TrainPing :> Post '[JSON] NoContent :<|> "train" :> "ping" :> "ws" :> WebSocket -- debug things - :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing]) + :<|> "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 :<|> "gtfs" :> GtfsRealtimeAPI - -- TODO: this should be behind auth / OpenID or something - :<|> "admin" :> AdminAPI -- | The API used for publishing gtfs realtime updates type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage :<|> "tripupdates" :> Get '[Proto] FeedMessage :<|> "vehiclepositions" :> Get '[Proto] FeedMessage --- | Admin API used for short-term timetable changes etc. ("leitstelle") -type AdminAPI = - "trip" :> "announce" :> ReqBody '[JSON] Announcement :> Post '[JSON] UUID - :<|> "trip" :> "announce" :> "delete" :> Capture "Announcement ID" UUID :> Post '[JSON] NoContent - :<|> "trip" :> "date" :> "add" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] NoContent - :<|> "trip" :> "date" :> "cancel" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] NoContent --- TODO for this to be useful there ought to be a half-deep Trip type --- (that has stops but not shapes) - :<|> "extraordinary" :> "trip" :> ReqBody '[JSON] (Trip Deep Shallow) :> Post '[JSON] NoContent - -- | The server's API with an additional debug route for accessing the specification -- itself. Split from API to prevent the API documenting the format in which it is -- documented, which would be silly and way to verbose. -type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger - :<|> API - :<|> "cr" :> Raw +type CompleteAPI = + "api" :> "openapi" :> Get '[JSON] Swagger + :<|> "api" :> API + :<|> Raw -- hook for yesod frontend -- TODO write something useful here! (and if it's just "hey this is some websocket thingie") instance HasSwagger WebSocket where toSwagger _ = toSwagger (Proxy @(Post '[JSON] NoContent)) -{- -TODO: -there should be a basic API allowing the questions: - - what are the next trips leaving from $station? (or $geolocation?) - - all stops of a given tripID - -then the "ingress" API: - - train ping (location, estimated delay, etc.) - - cancel trip - - add trip? - --} diff --git a/lib/GTFS.hs b/lib/GTFS.hs index 9259649..bfb1c49 100644 --- a/lib/GTFS.hs +++ b/lib/GTFS.hs @@ -51,6 +51,7 @@ import Web.Internal.FormUrlEncoded (FromForm (..)) import Web.Internal.HttpApiData (FromHttpApiData (..)) -- import Data.Aeson.Generic (Options(fieldLabelModifier), deriveJSON, defaultOptions) import Control.Lens +import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Char (toLower) import Data.Foldable (Foldable (fold)) import Data.Map (Map) @@ -459,3 +460,12 @@ tripsAtStation GTFS{..} at = fmap stopTrip stops tripsOnDay :: GTFS -> Day -> Map TripID (Trip Deep Deep) tripsOnDay gtfs today = foldMap (tripsOfService gtfs) (servicesOnDay gtfs today) + +runsOnDay :: GTFS -> TripID -> Day -> Bool +runsOnDay gtfs trip day = not . null . M.filter same $ tripsOnDay gtfs day + where same Trip{..} = tripTripID == trip + +runsToday :: MonadIO m => GTFS -> TripID -> m Bool +runsToday gtfs trip = do + today <- liftIO getCurrentTime <&> utctDay + pure (runsOnDay gtfs trip today) diff --git a/lib/Persist.hs b/lib/Persist.hs index 611da9e..39cdca1 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -58,32 +58,51 @@ instance ToSchema Token where instance ToParamSchema Token where toParamSchema _ = toParamSchema (Proxy @String) -data AmendmentStatus = Cancelled | Added +data AmendmentStatus = Cancelled | Added | PartiallyCancelled Int Int deriving (ToJSON, FromJSON, Generic, Show, Read, Eq) derivePersistField "AmendmentStatus" -instance FromHttpApiData AmendmentStatus where - parseUrlPiece "Cancelled" = Right Cancelled - parseUrlPiece "Added" = Right Added - parseUrlPiece other = Left ("unknown AmendmentStatus: "<>other) +-- instance FromHttpApiData AmendmentStatus where +-- parseUrlPiece "Cancelled" = Right Cancelled +-- parseUrlPiece "Added" = Right Added +-- parseUrlPiece other = Left ("unknown AmendmentStatus: "<>other) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- | tokens which have been issued -RunningTrip sql=tt_tracker_token +Running sql=tt_tracker_token Id Token default=uuid_generate_v4() expires UTCTime blocked Bool - tripNumber Text + trip Text + day Day vehicle Text Maybe + agent Text deriving Eq Show Generic -TripPing json sql=tt_trip_ping - token RunningTripId +-- raw frames as received from OBUs +TrainPing json sql=tt_trip_ping + token RunningId lat Double long Double - delay Double timestamp UTCTime deriving Show Generic Eq ToSchema +-- status of a train somewhen in time (may be in the future), +-- inferred from trainpings / entered via controlRoom +TrainStatus sql=tt_train_status + timestamp UTCTime + trip TripID + day Day + when UTCTime + deriving Show Generic Eq ToSchema + +TripAnchor json sql=tt_trip_anchor + trip TripID + day Day + timestamp UTCTime + delay Int Maybe + msg Text Maybe + deriving Show Generic Eq ToSchema + -- TODO: multi-language support? Announcement json sql=tt_announcements Id UUID default=uuid_generate_v4() @@ -102,16 +121,9 @@ ScheduleAmendment json sql=tt_schedule_amendement status AmendmentStatus -- only one special rule per TripID and Day (else incoherent) TripAndDay trip day - --- TODO: possible to have regular trips moved in time without changing TripID? -ExtraordinaryTrip sql=tt_extra_trip - trip TripID - day Text - stops (Vector Text) - stopTimes (Vector TimeOfDay) |] -instance ToSchema RunningTripId where +instance ToSchema RunningId where declareNamedSchema _ = declareNamedSchema (Proxy @UUID) runSql :: MonadIO m => Pool SqlBackend -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a diff --git a/lib/Server.hs b/lib/Server.hs index f7ee81b..75617bd 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -11,8 +11,8 @@ -- Implementation of the API. This module is the main point of the program. module Server (application) where -import Control.Monad (forever, void, when) -import Control.Monad.Extra (maybeM, whenM) +import Control.Monad (forever, unless, void, when) +import Control.Monad.Extra (maybeM, unlessM, whenM) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (logWarnN) import Control.Monad.Reader (forM) @@ -35,8 +35,9 @@ import Database.Persist import Database.Persist.Postgresql (SqlBackend, runMigration) import Fmt ((+|), (|+)) import qualified Network.WebSockets as WS -import Servant (Application, err401, err404, - serve, throwError) +import Servant (Application, + ServerError (errBody), err401, + err404, serve, throwError) import Servant.API (NoContent (..), (:<|>) (..)) import Servant.Server (Handler, hoistServer) import Servant.Swagger (toSwagger) @@ -46,7 +47,8 @@ import GTFS import Persist import Server.ControlRoom import Server.GTFS_RT (gtfsRealtimeServer) -import Server.Util (Service, ServiceM, runService) +import Server.Util (Service, ServiceM, runService, + sendErrorMsg) import Yesod (toWaiAppPlain) import System.IO.Unsafe @@ -64,11 +66,12 @@ doMigration pool = runSql pool $ runMigration migrateAll server :: GTFS -> Pool SqlBackend -> Service CompleteAPI -server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTimetable :<|> handleTrip - :<|> handleRegister :<|> handleTripPing :<|> handleWS :<|> handleDebugState :<|> - gtfsRealtimeServer gtfs dbpool - :<|> adminServer gtfs dbpool) - :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom "http://localhost:4000/cr" gtfs dbpool))) +server gtfs@GTFS{..} dbpool = handleDebugAPI + :<|> (handleStations :<|> handleTimetable :<|> handleTrip + :<|> handleRegister :<|> handleTripPing :<|> handleWS + :<|> handleDebugState :<|> handleDebugTrain :<|> handleDebugRegister + :<|> gtfsRealtimeServer gtfs dbpool) + :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool))) where handleStations = pure stations handleTimetable station maybeDay = do -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?) @@ -80,13 +83,19 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTim handleTrip trip = case M.lookup trip trips of Just res -> pure res Nothing -> throwError err404 - handleRegister tripID = do - -- TODO registration may carry extra information! + handleRegister tripID RegisterJson{..} = do + today <- liftIO getCurrentTime <&> utctDay + when (not $ runsOnDay gtfs tripID today) + $ sendErrorMsg "this trip does not run today." expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod - RunningTripKey token <- runSql dbpool $ insert (RunningTrip expires False tripID Nothing) + RunningKey token <- runSql dbpool $ insert (Running expires False tripID today Nothing registerAgent) + pure token + handleDebugRegister tripID day = do + expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod + RunningKey token <- runSql dbpool $ insert (Running expires False tripID day Nothing "debug key") pure token handleTripPing ping = do - lift $ checkTokenValid dbpool (coerce $ tripPingToken ping) + lift $ checkTokenValid dbpool (coerce $ trainPingToken ping) -- TODO: are these always inserted in order? runSql dbpool $ insert ping pure NoContent @@ -100,47 +109,34 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTim logWarnN ("stray websocket message: "+|show msg|+" (could not decode: "+|err|+")") liftIO $ WS.sendClose conn (C8.pack err) Right ping -> do - lift $ checkTokenValid dbpool (coerce $ tripPingToken ping) + lift $ checkTokenValid dbpool (coerce $ trainPingToken ping) void $ runSql dbpool $ insert ping handleDebugState = do now <- liftIO getCurrentTime runSql dbpool $ do - running <- selectList [RunningTripBlocked ==. False, RunningTripExpires >=. now] [] - pairs <- forM running $ \(Entity token@(RunningTripKey uuid) _) -> do - entities <- selectList [TripPingToken ==. token] [] + running <- selectList [RunningBlocked ==. False, RunningExpires >=. now] [] + pairs <- forM running $ \(Entity token@(RunningKey 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|+".") + runSql dbpool $ do + tokens <- selectList [RunningTrip ==. tripId, RunningDay ==. day] [] + pings <- forM tokens $ \(Entity token _) -> do + selectList [TrainPingToken ==. token] [] <&> fmap entityVal + pure (concat pings) handleDebugAPI = pure $ toSwagger (Proxy @API) -adminServer :: GTFS -> Pool SqlBackend -> Service AdminAPI -adminServer gtfs dbpool = - addAnnounce :<|> delAnnounce :<|> modTripDate Added Cancelled - :<|> modTripDate Cancelled Added :<|> extraTrip - where addAnnounce ann@Announcement{..} = runSql dbpool $ do - AnnouncementKey uuid <- insert ann - pure uuid - delAnnounce uuid = runSql dbpool $ do - delete (AnnouncementKey uuid) - pure NoContent - modTripDate one two tripId day = runSql dbpool $ do - getBy (TripAndDay tripId day) >>= \case - Just (Entity key (ScheduleAmendment _ _ status)) -> do - when (status == two) $ delete key - pure NoContent - Nothing -> do - insert (ScheduleAmendment tripId day one) - pure NoContent - extraTrip = error "unimplemented!" - - -- TODO: proper debug logging for expired tokens checkTokenValid :: Pool SqlBackend -> Token -> Handler () checkTokenValid dbpool token = do trip <- try $ runSql dbpool $ get (coerce token) - when (runningTripBlocked trip) + when (runningBlocked trip) $ throwError err401 - whenM (hasExpired (runningTripExpires trip)) + whenM (hasExpired (runningExpires trip)) $ throwError err401 where try m = m >>= \case Just a -> pure a diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index 9ebea42..4ef3784 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -28,7 +28,7 @@ import qualified Data.Map as M import Data.Pool (Pool) import Data.Text (Text) import qualified Data.Text as T -import Data.Time (getCurrentTime, utctDay) +import Data.Time (UTCTime, getCurrentTime, utctDay) import Data.Time.Calendar (Day) import Data.Time.Format.ISO8601 (iso8601Show) import Data.UUID (UUID) @@ -40,13 +40,9 @@ import Database.Persist.Sql (PersistFieldSql, SqlBackend, runSqlPool) import Fmt ((+|), (|+)) import GHC.Generics (Generic) -import Persist (AmendmentStatus, Announcement (..), - EntityField (..), Key (..), - ScheduleAmendment (ScheduleAmendment), - runSql) import Server.Util (Service) import Text.Blaze.Html (ToMarkup (..)) -import Text.Blaze.Internal (MarkupM(Empty)) +import Text.Blaze.Internal (MarkupM (Empty)) import Text.ProtocolBuffers (Default (defaultValue)) import Text.Read (readMaybe) import Text.Shakespeare.Text @@ -54,12 +50,12 @@ import Yesod import Yesod.Form import GTFS +import Persist data ControlRoom = ControlRoom - { getBaseurl :: Text - , getGtfs :: GTFS - , getPool :: Pool SqlBackend + { getGtfs :: GTFS + , getPool :: Pool SqlBackend } mkMessage "ControlRoom" "messages" "en" @@ -70,17 +66,16 @@ mkYesod "ControlRoom" [parseRoutes| /train/id/#TripID/#Day TrainViewR GET /train/announce/#TripID/#Day AnnounceR POST /train/del-announce/#UUID DelAnnounceR GET +/token/block/#Token TokenBlock GET /trips TripsViewR GET /trip/#TripID TripViewR GET |] emptyMarkup :: MarkupM a -> Bool emptyMarkup (Empty _) = True -emptyMarkup _ = False +emptyMarkup _ = False instance Yesod ControlRoom where - approot = ApprootMaster (\cr -> getBaseurl cr) - defaultLayout w = do PageContent{..} <- widgetToPageContent w msgs <- getMessages @@ -125,6 +120,9 @@ instance Yesod ControlRoom where input { grid-column: 2; } + .blocked { + background-color: red; + } $forall (status, msg) <- msgs

#{msg} @@ -169,11 +167,27 @@ getTrainViewR trip day = do Nothing -> notFound Just res@Trip{..} -> do anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] [] + tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [] + lastPing <- runDB $ selectFirst [ TrainPingToken <-. (fmap entityKey tokens) ] [Desc TrainPingTimestamp] defaultLayout $ do mr <- getMessageRender setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text)) [whamlet|

_{MsgTrip} #{tripTripID} _{Msgon} #{day} +
+

_{MsgLive} +

_{MsgLastPing}: + $maybe Entity _ TrainPing{..} <- lastPing + _{MsgTrainPing trainPingLat trainPingLong trainPingTimestamp} + (_{Msgraw}) + $nothing + (_{MsgNoTrainPing}) +

Estimated Delay: Todo! +

+

_{MsgStops} +
    + $forall Stop{..} <- tripStops +
  1. #{stopArrival} #{stationName stopStation}

    _{MsgAnnouncements}
      @@ -186,13 +200,18 @@ getTrainViewR trip day = do ^{widget}