server: simple servant-lucid stuff

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 ()

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

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 []

server/Orphans.hs

+
+{-# 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)

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

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

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

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