From cdb6329b6acaab0a15441554412d8f5ececece1b Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Thu, 10 Feb 2022 00:14:43 +0100
Subject: [PATCH] server: simple servant-lucid stuff
---
lib/CheckDir.hs | 3 +--
package.yaml | 3 +++
server/Main.hs | 25 +++++++++++++++------
server/Orphans.hs | 57 +++++++++++++++++++++++++++++++++++++++++++++++
server/Server.hs | 21 ++++++++++++++++-
stack.yaml | 2 +-
stack.yaml.lock | 7 ++++++
walint.cabal | 5 ++++-
8 files changed, 111 insertions(+), 12 deletions(-)
create mode 100644 server/Orphans.hs
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index f876084..eeb94a8 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -7,7 +7,7 @@
{-# LANGUAGE TypeFamilies #-}
-- | Module that contains high-level checking for an entire directory
-module CheckDir (recursiveCheckDir, DirResult(..), resultIsFatal) where
+module CheckDir (maximumLintLevel, recursiveCheckDir, DirResult(..), MissingAsset(..), MissingDep(..), resultIsFatal) where
import CheckMap (MapResult (..), loadAndLintMap)
import Control.Monad (void)
@@ -38,7 +38,6 @@ import Types (Dep (Local, LocalMap), Hint (Hint),
Level (..), hintLevel)
import Util (PrettyPrint (prettyprint), ellipsis)
-
-- based on the startling observation that Data.Map has lower complexity
-- for difference than Data.Set, but the same complexity for fromList
type Set a = Map a ()
diff --git a/package.yaml b/package.yaml
index a4681bc..6a3abc0 100644
--- a/package.yaml
+++ b/package.yaml
@@ -34,6 +34,7 @@ library:
- HList
exposed-modules:
- CheckDir
+ - CheckMap
- WriteRepo
- Util
- Types
@@ -74,3 +75,5 @@ executables:
- microlens
- microlens-th
- tomland
+ - lucid
+ - servant-lucid
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
diff --git a/stack.yaml b/stack.yaml
index 738b3ad..428eea3 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -27,7 +27,7 @@ extra-deps:
- logging-effect-1.3.12@sha256:72d168dd09887649ba9501627219b6027cbec2d5541931555b7885b133785ce3,1679
- which-0.2@sha256:db82ca7d83d64cce8ad579756f02d27c5bd289806ee02474726f7fafb87318e8,858
- cli-git-0.1.0.2@sha256:4e62e6b7357e4fe698df8b58ba53919f9d4a056e9617dbc00c869a365e316387,1122
-
+ - servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787
allow-newer: true
# use aeson with a non-hash-floodable implementation
diff --git a/stack.yaml.lock b/stack.yaml.lock
index a7bbaf3..93443e4 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -74,6 +74,13 @@ packages:
sha256: 1e81c51e2b60db2b1784901cf0af33c67384f5412ad8edaad8a7068135f5217f
original:
hackage: cli-git-0.1.0.2@sha256:4e62e6b7357e4fe698df8b58ba53919f9d4a056e9617dbc00c869a365e316387,1122
+- completed:
+ hackage: servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787
+ pantry-tree:
+ size: 392
+ sha256: 39e0e7b2b25980bfe4df036e89959188f9ef9e8c78c85e241fa9a682d1d78cf3
+ original:
+ hackage: servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787
snapshots:
- completed:
size: 586286
diff --git a/walint.cabal b/walint.cabal
index b9982d1..1129e23 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -15,13 +15,13 @@ build-type: Simple
library
exposed-modules:
CheckDir
+ CheckMap
WriteRepo
Util
Types
LintConfig
other-modules:
Badges
- CheckMap
Dirgraph
KindLinter
LayerData
@@ -61,6 +61,7 @@ executable server
main-is: Main.hs
other-modules:
Handlers
+ Orphans
Server
Paths_walint
hs-source-dirs:
@@ -79,11 +80,13 @@ executable server
, filepath
, http-media
, logging-effect
+ , lucid
, microlens
, microlens-th
, mtl
, process
, servant
+ , servant-lucid
, servant-server
, string-conversions
, text
--
GitLab