summaryrefslogtreecommitdiff
path: root/server/Server.hs
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--server/Server.hs64
1 files changed, 30 insertions, 34 deletions
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)