server: simple servant-lucid stuff

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