Skip to content
Snippets Groups Projects
Commit 89ccd9e9 authored by stuebinm's avatar stuebinm
Browse files

server: admin interface 

(for now, just a list of all maps and their current status)
parent 0d2ba6d9
Branches
No related tags found
No related merge requests found
Show whitespace changes
Inline Side-by-side
server/Handlers.hs
+ 10
− 3
View file @ 89ccd9e9
......@@ -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
......
server/Orphans.hs → server/HtmlOrphans.hs
+ 67
− 23
View file @ 89ccd9e9
......@@ -10,7 +10,7 @@
-- | Module containing orphan instances of Lucid's ToHtml, used for rendering
-- linter results as html
module Orphans () where
module HtmlOrphans () where
import CheckDir (DirResult (..), MissingAsset (MissingAsset),
......@@ -23,14 +23,60 @@ 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 (class_, code_, div_, h2_, h3_, h4_, h5_, id_,
li_, p_, script_, span_, src_, ul_)
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 ()
badge level = span_ [class_ badgetype]
......@@ -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 ->
......
server/Main.hs
+ 10
− 4
View file @ 89ccd9e9
......@@ -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
......
server/Server.hs
+ 30
− 34
View file @ 89ccd9e9
{-# 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)
walint.cabal
+ 1
− 1
View file @ 89ccd9e9
......@@ -61,7 +61,7 @@ executable server
main-is: Main.hs
other-modules:
Handlers
Orphans
HtmlOrphans
Server
Paths_walint
hs-source-dirs:
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment

Impressum - Datenschutzerklärung