From 99463395ee9497256b794f4ad2c94b490ca5d0fd Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 23 Feb 2023 23:40:06 +0100
Subject: don't hardcode css
---
lib/API.hs | 1 +
lib/Config.hs | 2 ++
lib/Server.hs | 11 ++++----
lib/Server/ControlRoom.hs | 64 +----------------------------------------------
4 files changed, 10 insertions(+), 68 deletions(-)
diff --git a/lib/API.hs b/lib/API.hs
index 775bc4c..79a467a 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -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
^{pageHead}
-