diff options
| -rw-r--r-- | lib/API.hs | 1 | ||||
| -rw-r--r-- | lib/Config.hs | 2 | ||||
| -rw-r--r-- | lib/Server.hs | 11 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 64 |
4 files changed, 10 insertions, 68 deletions
@@ -81,6 +81,7 @@ type CompleteAPI = "api" :> "openapi" :> Get '[JSON] Swagger :<|> "api" :> API :<|> "metrics" :> Get '[PlainText] Text + :<|> "assets" :> Raw :<|> Raw -- hook for yesod frontend diff --git a/lib/Config.hs b/lib/Config.hs index 65ac697..363a068 100644 --- a/lib/Config.hs +++ b/lib/Config.hs @@ -23,6 +23,7 @@ data ServerConfig = ServerConfig { serverConfigWarp :: Settings , serverConfigDbString :: ByteString , serverConfigGtfs :: FilePath + , serverConfigAssets :: FilePath , serverConfigZoneinfoPath :: FilePath , serverConfigLogin :: UffdConfig } deriving (Generic) @@ -34,6 +35,7 @@ instance DefaultConfig ServerConfig where { serverConfigWarp = configDef , serverConfigDbString = "" , serverConfigGtfs = "./gtfs.zip" + , serverConfigAssets = "./assets" , serverConfigZoneinfoPath = "/etc/zoneinfo/" , serverConfigLogin = configDef } diff --git a/lib/Server.hs b/lib/Server.hs index 6b32826..8d81127 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -13,7 +13,7 @@ module Server (application) where import Control.Concurrent.STM (TQueue, TVar, atomically, newTQueue, newTVar, readTQueue, - readTVar, writeTQueue, writeTVar) + readTVar, writeTQueue, writeTVar, newTVarIO) import Control.Monad (forever, unless, void, when) import Control.Monad.Catch (handle) import Control.Monad.Extra (ifM, maybeM, unlessM, whenJust, @@ -43,7 +43,7 @@ import Fmt ((+|), (|+)) import qualified Network.WebSockets as WS import Servant (Application, ServerError (errBody), err401, - err404, serve, throwError) + err404, serve, throwError, serveDirectoryFileServer) import Servant.API (NoContent (..), (:<|>) (..)) import Servant.Server (Handler, hoistServer) import Servant.Swagger (toSwagger) @@ -61,7 +61,7 @@ import Extrapolation (Extrapolator (..), LinearExtrapolator (..)) import System.IO.Unsafe -import Config (ServerConfig) +import Config (ServerConfig (serverConfigAssets)) import Data.ByteString (ByteString) import Data.ByteString.Lazy (toStrict) import Prometheus @@ -73,7 +73,7 @@ application gtfs dbpool settings = do metrics <- Metrics <$> register (gauge (Info "ws_connections" "Number of WS Connections")) register ghcMetrics - subscribers <- atomically $ newTVar mempty + subscribers <- newTVarIO mempty pure $ serve (Proxy @CompleteAPI) $ hoistServer (Proxy @CompleteAPI) runService $ server gtfs metrics subscribers dbpool settings -- databaseMigration :: ConnectionString -> IO () @@ -83,13 +83,14 @@ 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 TripID [TQueue (Maybe TrainPing)]) -> Pool SqlBackend -> ServerConfig -> Service CompleteAPI server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI :<|> (handleStations :<|> handleTimetable :<|> handleTrip :<|> handleRegister :<|> handleTrainPing (throwError err401) :<|> handleWS :<|> handleSubscribe :<|> handleDebugState :<|> handleDebugTrain :<|> handleDebugRegister :<|> gtfsRealtimeServer gtfs dbpool) :<|> metrics + :<|> serveDirectoryFileServer (serverConfigAssets settings) :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool settings))) where handleStations = pure stations handleTimetable station maybeDay = do diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index 2be0b3e..9cde587 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -124,69 +124,7 @@ instance Yesod ControlRoom where $maybe description <- pageDescription <meta name="description" content="#{description}"> ^{pageHead} - <style> - html { - overflow-x: hidden - } - section { - border: 0.1rem solid black; - padding: 1rem; - margin: 2vw; - margin-top: 0; - padding-top: 0; - } - body { - max-width: 50rem; - margin: auto; - } - form { - width:100%; - display: grid; - gap: 1rem; - } - label { - grid-column: 1; - } - form div { - display: grid; - grid-template-columns: 50% 50%; - width:100%; - } - input { - grid-column: 2; - } - .blocked { - background-color: red; - } - #map { - width: 100%; - height: 50vh; - } - nav { - padding: 0.5em; - position: relative; - text-align: center; - margin-left: 2vw; - margin-right: 2vw; - margin-top: 2rem; - } - .nav-left { - position: absolute; - left: 0; - } - .nav-right { - position: absolute; - right: 0; - } - ol { - padding: 0 - } - li { - list-style: none; - margin: 0.5vw; - border-bottom: 0.1rem black dashed; - padding-bottom: 0.5rem; - } + <link rel="stylesheet" href="/assets/style.css"> <body> $forall (status, msg) <- msgs <!-- <p class="message #{status}">#{msg} --> |