don't hardcode css

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} -->