summaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
authorstuebinm2022-02-10 00:14:43 +0100
committerstuebinm2022-02-10 00:14:43 +0100
commit485af1d460be0979b7093da307f379ef088a98db (patch)
tree8d0358713b5915f73bb2a72b42b0ead1472ad0bd /server
parent3a109e79363b52e22da35aaecf666014a75fcb63 (diff)
server: simple servant-lucid stuff
Diffstat (limited to 'server')
-rw-r--r--server/Main.hs25
-rw-r--r--server/Orphans.hs57
-rw-r--r--server/Server.hs21
3 files changed, 95 insertions, 8 deletions
diff --git a/server/Main.hs b/server/Main.hs
index 0fbc4b4..00b4689 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -22,14 +22,15 @@ import Network.Wai.Handler.Warp (run)
import Servant (Application, Capture, Get, Handler,
HasServer (ServerT), JSON,
NoContent, Post, Proxy (Proxy),
- ReqBody, ServerError (errBody),
- err500, hoistServer, serve,
- throwError, type (:<|>) (..),
- type (:>))
+ Raw, ReqBody,
+ ServerError (errBody), err500,
+ hoistServer, serve, throwError,
+ type (:<|>) (..), type (:>))
+import Servant.HTML.Lucid (HTML)
+import Servant.Server.StaticFiles (serveDirectoryWebApp)
import Server (Config (..), JobStatus,
RemoteRef (..), State,
defaultState, loadConfig)
-
{-
Needed:
- admin overview (perhaps on seperate port?)
@@ -48,6 +49,10 @@ type API format =
:<|> "status" :> Capture "jobid" UUID :> Get '[format] JobStatus
:<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent
+type Routes =
+ "api" :> API JSON
+ :<|> "status" :> Capture "jobid" UUID :> Get '[HTML] JobStatus
+ :<|> Raw
-- | API's implementation
jsonAPI :: Config True -> MVar State -> ServerT (API JSON) App
@@ -56,11 +61,17 @@ jsonAPI config state =
:<|> statusImpl state
:<|> relintImpl config state
+server :: Config True -> MVar State -> ServerT Routes App
+server config state =
+ jsonAPI config state
+ :<|> statusImpl state
+ :<|> serveDirectoryWebApp "./static"
+
-- | make an application; convert any cli errors into a 500
app :: Config True -> MVar State -> Application
app config =
- serve api . hoistServer api conv . jsonAPI config
- where api = Proxy @(API JSON)
+ serve api . hoistServer api conv . server config
+ where api = Proxy @Routes
conv :: App a -> Handler a
conv m = do
config <- liftIO $ mkDefaultCliConfig []
diff --git a/server/Orphans.hs b/server/Orphans.hs
new file mode 100644
index 0000000..b46f728
--- /dev/null
+++ b/server/Orphans.hs
@@ -0,0 +1,57 @@
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+
+module Orphans where
+
+
+import Control.Monad (forM_, unless)
+import qualified Data.Map as M
+import Data.Text (Text)
+import Lucid (ToHtml)
+import Lucid.Base (ToHtml (toHtml))
+import Lucid.Html5
+
+import CheckDir
+import CheckMap
+import Types
+import Util (prettyprint)
+
+instance ToHtml Hint where
+ toHtml (Hint l m) = do
+ span_ [class_ "level"] $ toHtml (show l)
+ toHtml m
+
+
+instance ToHtml DirResult where
+ toHtml res@DirResult { .. } = do
+ h3_ $ toHtml (show $ maximumLintLevel res)
+ unless (null dirresultMissingAssets && null dirresultDeps) $ do
+ h2_ "Dependencies"
+ ul_ $ do
+ forM_ dirresultMissingAssets $ \(MissingAsset missing) -> do
+ li_ $ toHtml (prettyprint missing)
+ forM_ dirresultDeps $ \missing -> do
+ li_ $ toHtml (prettyprint missing)
+ unless (null dirresultMaps) $ do
+ h2_ "Maps"
+ flip M.foldMapWithKey dirresultMaps $ \name MapResult { .. } -> do
+ h3_ (toHtml name)
+ ul_ $ do
+ forM_ mapresultGeneral $ \lint ->
+ li_ (toHtml lint)
+ flip M.foldMapWithKey mapresultLayer $ \lint layers ->
+ li_ $ do
+ toHtml lint
+ toHtml ("(in layer" :: Text)
+ forM_ layers $ \layer ->
+ span_ [class_ "layer"] (toHtml layer)
+ toHtml (")" :: Text)
+ flip M.foldMapWithKey mapresultTileset $ \lint tilesets ->
+ li_ $ do
+ toHtml lint
+ toHtml ("( in layer" :: Text)
+ forM_ tilesets $ \tileset ->
+ span_ [class_ "tileset"] (toHtml tileset)
+ toHtml (")" :: Text)
diff --git a/server/Server.hs b/server/Server.hs
index a5a820a..536350f 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -27,12 +27,14 @@ import GHC.Generics (Generic)
import Lens.Micro (over)
import Lens.Micro.TH
import LintConfig (LintConfig')
+import Lucid (ToHtml (..))
+import Lucid.Html5
+import Orphans ()
import System.Exit.Compat (exitFailure)
import Toml (TomlCodec)
import qualified Toml
import Toml.Codec ((.=))
-
-- | a reference in a remote git repository
data RemoteRef = RemoteRef
{ repourl :: Text
@@ -69,6 +71,23 @@ data State = State
, _registry :: Map UUID RemoteRef
}
+instance ToHtml JobStatus where
+ toHtml status = html_ $ do
+ head_ $ do
+ title_ "Job Status"
+ link_ [rel_ "stylesheet", type_ "text/css", href_ "/styles.css"]
+ body_ $ div_ [class_ "main-content"] $ case status of
+ Pending -> do
+ h2_ "Pending …"
+ p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)"
+ Linted res -> do
+ p_ "Linted"
+ toHtml res
+ Failed err -> do
+ h2_ "System Error"
+ p_ $ "error: " <> toHtml err
+ p_ "you should probably ping an admin about this or sth"
+
makeLenses ''State
defaultState :: State