summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--server/Handlers.hs13
-rw-r--r--server/HtmlOrphans.hs (renamed from server/Orphans.hs)90
-rw-r--r--server/Main.hs14
-rw-r--r--server/Server.hs64
-rw-r--r--walint.cabal2
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 3881a7f..d4ffcf6 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: