aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorstuebinm2023-02-23 23:40:06 +0100
committerstuebinm2023-02-23 23:40:06 +0100
commit99463395ee9497256b794f4ad2c94b490ca5d0fd (patch)
treeca85eb03a35267409ceea973b0029273944fbdef
parent1612bb5aec55af06f66012ff2627f533e7a57c67 (diff)
don't hardcode css
Diffstat (limited to '')
-rw-r--r--lib/API.hs1
-rw-r--r--lib/Config.hs2
-rw-r--r--lib/Server.hs11
-rw-r--r--lib/Server/ControlRoom.hs64
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
<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} -->