From 89ccd9e970fe1c736cd68ad6f1def666e5275e6b Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Fri, 11 Feb 2022 22:25:23 +0100
Subject: server: admin interface

(for now, just a list of all maps and their current status)
---
 server/Server.hs | 64 ++++++++++++++++++++++++++------------------------------
 1 file changed, 30 insertions(+), 34 deletions(-)

(limited to 'server/Server.hs')

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)
-- 
cgit v1.2.3