diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Server.hs | 11 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 64 |
2 files changed, 7 insertions, 68 deletions
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} --> |