server: admin interface

(for now, just a list of all maps and their current status)

5 files changed, 118 insertions, 65 deletions

diff --git a/server/Handlers.hs b/server/Handlers.hs
index 382af64..d89d2c5 100644
--- a/server/Handlers.hs
+++ b/server/Handlers.hs
@@ -5,7 +5,7 @@
 {-# LANGUAGE LambdaCase       #-}
 {-# LANGUAGE TypeApplications #-}
 
-module Handlers (App, submitImpl,statusImpl,relintImpl) where
+module Handlers (App, submitImpl,statusImpl,relintImpl,adminOverviewImpl) where
 
 import           Bindings.Cli.Git       (gitProc)
 import           CheckDir               (recursiveCheckDir)
@@ -13,7 +13,8 @@ import           Cli.Extras             (CliConfig, CliT, ProcessFailure,
                                          Severity (..), callProcessAndLogOutput,
                                          getCliConfig, prettyProcessFailure,
                                          runCli)
-import           Control.Concurrent     (MVar, ThreadId, forkIO, withMVar)
+import           Control.Concurrent     (MVar, ThreadId, forkIO, readMVar,
+                                         withMVar)
 import           Control.Monad.Extra    (ifM)
 import           Control.Monad.IO.Class (liftIO)
 import           Control.Monad.Trans    (lift)
@@ -25,7 +26,8 @@ import qualified Data.UUID.V4           as UUID
 import           Lens.Micro.Extras      (view)
 import           Servant                (Handler, NoContent (NoContent), err404,
                                          err500, throwError)
-import           Server                 (Config (entrypoint, lintconfig, tmpdir),
+import           Server                 (AdminOverview (AdminOverview),
+                                         Config (entrypoint, lintconfig, tmpdir),
                                          JobStatus (..),
                                          RemoteRef (reporef, repourl), State,
                                          jobs, registry, setJobStatus,
@@ -74,6 +76,11 @@ statusImpl state uuid = do
      Nothing  -> lift $ throwError err404
 
 
+adminOverviewImpl :: MVar State -> App AdminOverview
+adminOverviewImpl state = do
+  state <- liftIO $ readMVar state
+  pure (AdminOverview state)
+
 -- | the actual check function. forks, calls out to git to update the
 -- repository, create a new worktree, lints it, then tells git to
 -- delete that tree again
diff --git a/server/Orphans.hs b/server/HtmlOrphans.hs
index c307520..bb4932d 100644
--- a/server/Orphans.hs
+++ b/server/HtmlOrphans.hs
@@ -10,26 +10,72 @@
 
 -- | Module containing orphan instances of Lucid's ToHtml, used for rendering
 -- linter results as html
-module Orphans () where
-
-
-import           CheckDir        (DirResult (..), MissingAsset (MissingAsset),
-                                  MissingDep (..), maximumLintLevel)
-import           CheckMap        (MapResult (..))
-import           Control.Monad   (forM_, unless)
-import           Data.Functor    ((<&>))
-import           Data.List       (intersperse)
-import           Data.List.Extra (escapeJSON)
-import qualified Data.Map        as M
-import           Data.Text       (Text)
-import qualified Data.Text       as T
-import           Lucid           (HtmlT, ToHtml)
-import           Lucid.Base      (ToHtml (toHtml))
-import           Lucid.Html5     (class_, code_, div_, h2_, h3_, h4_, h5_, id_,
-                                  li_, p_, script_, span_, src_, ul_)
-import           Text.Dot        (showDot)
-import           Types           (Hint (Hint), Level (..))
-
+module HtmlOrphans () where
+
+
+import           CheckDir          (DirResult (..), MissingAsset (MissingAsset),
+                                    MissingDep (..), maximumLintLevel)
+import           CheckMap          (MapResult (..))
+import           Control.Monad     (forM_, unless)
+import           Data.Functor      ((<&>))
+import           Data.List         (intersperse)
+import           Data.List.Extra   (escapeJSON)
+import qualified Data.Map          as M
+import           Data.Text         (Text)
+import qualified Data.Text         as T
+import           Lens.Micro.Extras (view)
+import           Lucid             (HtmlT, ToHtml)
+import           Lucid.Base        (ToHtml (toHtml))
+import           Lucid.Html5       (a_, body_, class_, code_, div_, em_, h1_,
+                                    h2_, h3_, h4_, h5_, head_, href_, html_,
+                                    id_, li_, link_, main_, p_, rel_, script_,
+                                    span_, src_, title_, type_, ul_)
+import           Server            (AdminOverview (..), JobStatus (..),
+                                    RemoteRef (reporef, repourl), jobs,
+                                    registry)
+import           Text.Dot          (showDot)
+import           Types             (Hint (Hint), Level (..))
+
+
+mono :: Monad m => HtmlT m () -> HtmlT m ()
+mono = code_ [class_ "small text-muted"]
+
+
+htmldoc :: Monad m => HtmlT m () -> HtmlT m ()
+htmldoc inner = html_ $ do
+    head_ $ do
+      title_ "Job Status"
+      link_ [rel_ "stylesheet", type_ "text/css", href_ "/bootstrap.min.css" ]
+      link_ [rel_ "stylesheet", type_ "text/css", href_ "/style.css" ]
+    body_ $ main_ [class_ "main-content"] inner
+
+instance ToHtml JobStatus where
+  toHtml status = htmldoc $ case status of
+      Pending -> do
+        h1_ "Pending …"
+        p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)"
+      Linted res -> do
+        h1_ "Linter Result"
+        toHtml res
+      Failed err -> do
+        h1_ "System Error"
+        p_ $ "error: " <> toHtml err
+        p_ "you should probably ping an admin about this or sth"
+
+instance ToHtml AdminOverview where
+  toHtml (AdminOverview state) = htmldoc $ do
+    h1_ "Map List"
+    if null (view registry state)
+      then em_ "(nothing yet)"
+      else ul_ . flip M.foldMapWithKey (view registry state)
+        $ \uuid ref -> li_ $ do
+          case M.lookup ref (view jobs state) of
+            Just Pending      -> badge Info "pending"
+            Just (Linted res) -> toHtml $ maximumLintLevel res
+            Just (Failed _)   -> badge Error "system error"
+            Nothing           -> toHtml Fatal
+          " "; a_ [href_ (T.pack $ "/status/"<>show uuid)] $ do
+            mono $ toHtml $ reporef ref; " on "; mono $ toHtml $ repourl ref
 
 
 badge :: Monad m => Level -> HtmlT m () -> HtmlT m ()
@@ -111,7 +157,7 @@ instance ToHtml DirResult where
       h3_ "Maps"
       flip M.foldMapWithKey dirresultMaps $ \name MapResult { .. } -> do
         h4_ (toHtml name)
-        forM_ mapresultGeneral $ \lint ->
+        ul_ $ forM_ mapresultGeneral $ \lint ->
           li_ (toHtml lint)
         h5_ "Layers"
         ul_ (listMapWithKey mapresultLayer)
@@ -121,8 +167,6 @@ instance ToHtml DirResult where
     where
       maxlevel = maximumLintLevel res
 
-      mono text = code_ [class_ "small text-muted"] text
-
       placeList :: (Monad m, ToHtml a) => [a] -> HtmlT m ()
       placeList occurances =
         sequence_ . intersperse ", " $ occurances <&> \place ->
diff --git a/server/Main.hs b/server/Main.hs
index 00b4689..0f142de 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -16,8 +16,9 @@ import           Control.Concurrent         (MVar, newMVar)
 import           Control.Monad.IO.Class     (liftIO)
 import qualified Data.ByteString.Lazy.Char8 as C8
 import           Data.UUID                  (UUID)
-import           Handlers                   (App, relintImpl, statusImpl,
-                                             submitImpl)
+import           Handlers                   (App, adminOverviewImpl, relintImpl,
+                                             statusImpl, submitImpl)
+import           HtmlOrphans                ()
 import           Network.Wai.Handler.Warp   (run)
 import           Servant                    (Application, Capture, Get, Handler,
                                              HasServer (ServerT), JSON,
@@ -28,9 +29,10 @@ import           Servant                    (Application, Capture, Get, Handler,
                                              type (:<|>) (..), type (:>))
 import           Servant.HTML.Lucid         (HTML)
 import           Servant.Server.StaticFiles (serveDirectoryWebApp)
-import           Server                     (Config (..), JobStatus,
-                                             RemoteRef (..), State,
+import           Server                     (AdminOverview, Config (..),
+                                             JobStatus, RemoteRef (..), State,
                                              defaultState, loadConfig)
+
 {-
 Needed:
  - admin overview (perhaps on seperate port?)
@@ -48,10 +50,12 @@ type API format =
        "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID
   :<|> "status" :> Capture "jobid" UUID :> Get '[format] JobStatus
   :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent
+  :<|> "admin" :> "overview" :> Get '[format] AdminOverview
 
 type Routes =
    "api" :> API JSON
   :<|> "status" :> Capture "jobid" UUID :> Get '[HTML] JobStatus
+  :<|> "admin" :> "overview" :> Get '[HTML] AdminOverview
   :<|> Raw
 
 -- | API's implementation
@@ -60,11 +64,13 @@ jsonAPI config state =
   submitImpl config state
   :<|> statusImpl state
   :<|> relintImpl config state
+  :<|> adminOverviewImpl state
 
 server :: Config True -> MVar State -> ServerT Routes App
 server config state =
   jsonAPI config state
   :<|> statusImpl state
+  :<|> adminOverviewImpl state
   :<|> serveDirectoryWebApp "./static"
 
 -- | make an application; convert any cli errors into a 500
diff --git a/server/Server.hs b/server/Server.hs
index ac79237..d7205bc 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns               #-}
 {-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE DeriveGeneric              #-}
@@ -13,11 +14,13 @@
 {-# LANGUAGE TypeOperators              #-}
 
 module Server (loadConfig, Config(..), RemoteRef(..), State, registry, jobs, JobStatus(..),
-                    setJobStatus,defaultState,setRegistry) where
+                    setJobStatus,defaultState,setRegistry, AdminOverview(..)) where
 
 import           CheckDir             (DirResult)
 import           Control.Concurrent   (MVar, modifyMVar_)
-import           Data.Aeson           (FromJSON, ToJSON, eitherDecode)
+import           Data.Aeson           (FromJSON, ToJSON (toJSON), eitherDecode,
+                                       (.=))
+import qualified Data.Aeson           as A
 import qualified Data.ByteString.Lazy as LB
 import           Data.Map             (Map)
 import qualified Data.Map             as M
@@ -25,21 +28,18 @@ import           Data.Text            (Text)
 import           Data.UUID            (UUID)
 import           GHC.Generics         (Generic)
 import           Lens.Micro           (over)
+import           Lens.Micro.Extras    (view)
 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           ((.=))
+import qualified Toml                 as T
 
 -- | a reference in a remote git repository
 data RemoteRef = RemoteRef
   { repourl :: Text
   , reporef :: Text
-  } deriving (Generic, FromJSON, Eq, Ord)
+  } deriving (Generic, FromJSON, ToJSON, Eq, Ord)
 
 type family ConfigRes (b :: Bool) a where
   ConfigRes True a = a
@@ -57,46 +57,42 @@ data Config (loaded :: Bool) = Config
 
 configCodec :: TomlCodec (Config False)
 configCodec = Config
-    <$> Toml.string "tmpdir" .= tmpdir
-    <*> Toml.int "port" .= port
-    <*> Toml.string "entrypoint" .= entrypoint
-    <*> Toml.string "lintconfig" .= lintconfig
+    <$> T.string "tmpdir" T..= tmpdir
+    <*> T.int "port" T..= port
+    <*> T.string "entrypoint" T..= entrypoint
+    <*> T.string "lintconfig" T..= lintconfig
 
+-- | a job status (of a specific uuid)
 data JobStatus =
   Pending | Linted DirResult | Failed Text
   deriving (Generic, ToJSON)
 
+-- | the server's global state
 data State = State
   { _jobs     :: Map RemoteRef JobStatus
   , _registry :: Map UUID RemoteRef
   }
-
-instance ToHtml JobStatus where
-  toHtml status = html_ $ do
-    head_ $ do
-      title_ "Job Status"
-      link_ [rel_ "stylesheet", type_ "text/css", href_ "/bootstrap.min.css" ]
-      link_ [rel_ "stylesheet", type_ "text/css", href_ "/style.css" ]
-    body_ $ main_ [class_ "main-content"] $ case status of
-      Pending -> do
-        h1_ "Pending …"
-        p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)"
-      Linted res -> do
-        h1_ "Linter Result"
-        toHtml res
-      Failed err -> do
-        h1_ "System Error"
-        p_ $ "error: " <> toHtml err
-        p_ "you should probably ping an admin about this or sth"
-
 makeLenses ''State
 
 defaultState :: State
 defaultState = State mempty mempty
 
+newtype AdminOverview =
+  AdminOverview { unAdminOverview :: State }
+
+instance ToJSON AdminOverview where
+  toJSON (AdminOverview state) =
+    toJSON . flip M.mapWithKey (view registry state) $ \uuid ref ->
+      A.object [ "reference" .= uuid
+               , "remote" .= ref
+               , "status" .= M.lookup ref (view jobs state)
+               ]
+
+
+
 loadConfig :: FilePath -> IO (Config True)
 loadConfig path = do
-  res <- Toml.decodeFileEither configCodec path
+  res <- T.decodeFileEither configCodec path
   case res of
     Right config -> loadConfig' config
     Left err -> do
@@ -113,9 +109,9 @@ loadConfig' config = do
 
 
 setJobStatus :: MVar State -> RemoteRef -> JobStatus -> IO ()
-setJobStatus mvar ref status = modifyMVar_ mvar
+setJobStatus mvar !ref !status = modifyMVar_ mvar
   $ pure . over jobs (M.insert ref status)
 
 setRegistry :: MVar State -> UUID -> RemoteRef -> IO ()
-setRegistry mvar uuid ref = modifyMVar_ mvar
+setRegistry mvar !uuid !ref = modifyMVar_ mvar
   $ pure . over registry (M.insert uuid ref)
diff --git a/walint.cabal b/walint.cabal
index 4aad7ac..397e317 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -61,7 +61,7 @@ executable server
   main-is: Main.hs
   other-modules:
       Handlers
-      Orphans
+      HtmlOrphans
       Server
       Paths_walint
   hs-source-dirs: