From ff8eeb131db9e9a0d9d3cef60ddcaa83692fb62c Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Wed, 16 Feb 2022 16:57:49 +0100
Subject: [PATCH] server: add mapservice GET endpoint
---
config.toml | 4 +++
server/Handlers.hs | 79 +++++++++++++++++++++----------------------
server/HtmlOrphans.hs | 8 ++---
server/Main.hs | 13 ++++---
server/Server.hs | 16 ++++++---
server/Worker.hs | 12 ++++---
6 files changed, 75 insertions(+), 57 deletions(-)
diff --git a/config.toml b/config.toml
index 1c8825b..1f0f349 100644
--- a/config.toml
+++ b/config.toml
@@ -10,13 +10,17 @@ interval = 30
[[org]]
slug = "divoc"
+url = "https://world.di.c3voc.de/maps/"
+webdir = "/var/www/divoc"
lintconfig = "./config.json"
entrypoint = "main.json"
[[org.repo]] # I hate TOML
url = "https://gitlab.infra4future.de/hacc/events/hacc-map"
ref = "master"
+name = "hacc"
[[org.repo]]
url = "https://github.com/namiko/assembly_2021"
ref = "master"
+name = "haecksen"
diff --git a/server/Handlers.hs b/server/Handlers.hs
index a4ddab4..719b475 100644
--- a/server/Handlers.hs
+++ b/server/Handlers.hs
@@ -1,56 +1,36 @@
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
module Handlers (
-- , submitImpl
statusImpl
-- , relintImpl
- , adminOverviewImpl
+ , stateImpl
, AdminOverview(..)
,MapService(..)) where
import Universum
-import Control.Concurrent.MVar (withMVar)
-import Data.Aeson (ToJSON (..), (.=))
-import qualified Data.Aeson as A
-import qualified Data.Map as M
-import Servant (Handler, err404, throwError)
-import Server (JobStatus (..), ServerState, Sha1,
- getJobStatus, unState)
-
--- | annoying (and afaik unused), but has to be here for type system reasons
--- instance MonadFail Handler where
--- fail _ = throwError err500
-
--- -- | someone submitted a map; lint it (synchronously for now)
--- submitImpl :: Config True -> MVar ServerState -> RemoteRef -> App UUID
--- submitImpl config state ref = do
--- jobid <- liftIO UUID.nextRandom
--- -- TODO: these two should really be atomic
--- liftIO $ setJobStatus state ref Pending
--- liftIO $ setRegistry state jobid ref
--- cliconfig <- getCliConfig
--- -- we'll just forget the thread id for now and trust this terminates …
--- _ <- checkRef config cliconfig state ref
--- -- the submission itself can't really fail or return anything useful
--- pure jobid
-
--- relintImpl :: Config True -> MVar ServerState -> UUID -> App NoContent
--- relintImpl config state uuid = do
--- mref <- liftIO $ withMVar state (pure . M.lookup uuid . view registry)
--- case mref of
--- Nothing -> lift $ throwError err404
--- Just ref -> do
--- cliconfig <- getCliConfig
--- _ <- checkRef config cliconfig state ref
--- pure NoContent
+import CheckDir (DirResult (dirresultMaps))
+import CheckMap (MapResult (MapResult, mapresultBadges))
+import Data.Aeson (ToJSON (..), (.=))
+import qualified Data.Aeson as A
+import qualified Data.Aeson.Key as A
+import Data.Coerce (coerce)
+import qualified Data.Map as M
+import Servant (Handler, err404, throwError)
+import Server (JobStatus (..), Org (orgUrl),
+ RemoteRef (RemoteRef, reponame), ServerState,
+ Sha1, getJobStatus, unState)
-- | an info type wrapped around the server state, to carry serialisation instances.
newtype AdminOverview =
AdminOverview { unAdminOverview :: ServerState }
+
newtype MapService =
MapService { unMapService :: ServerState }
@@ -61,6 +41,23 @@ instance ToJSON AdminOverview where
, "status" .= status
]
+instance ToJSON MapService where
+ toJSON (MapService state) =
+ toJSON $ M.mapWithKey orgObject (view unState state)
+ where
+ orgObject org = A.object . mapMaybe worldObject . M.elems
+ where
+ worldObject (RemoteRef {..}, job) = case job of
+ Linted res rev ->
+ Just (A.fromText reponame .=
+ M.mapWithKey (mapInfo rev) (dirresultMaps res))
+ _ -> Nothing
+ mapInfo rev mappath MapResult { .. } = A.object
+ [ "badges" .= mapresultBadges
+ , "url" .= (orgUrl org <> rev <> "/" <> toText mappath) ]
+
+
+
statusImpl :: MVar ServerState -> Text -> Sha1 -> Handler JobStatus
statusImpl state orgslug sha1 = do
status <- liftIO $ getJobStatus state orgslug sha1
@@ -68,8 +65,10 @@ statusImpl state orgslug sha1 = do
Just res -> pure $ snd res
Nothing -> throwError err404
-
-adminOverviewImpl :: MVar ServerState -> Handler AdminOverview
-adminOverviewImpl state = do
- state <- readMVar state
- pure (AdminOverview state)
+-- | since there are multiple apis that just get state information …
+stateImpl
+ :: forall s
+ . Coercible s ServerState
+ => MVar ServerState
+ -> Handler s
+stateImpl state = readMVar state <&> coerce
diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs
index 0472f24..c9fa852 100644
--- a/server/HtmlOrphans.hs
+++ b/server/HtmlOrphans.hs
@@ -52,7 +52,7 @@ instance ToHtml JobStatus where
Pending -> do
h1_ "Pending …"
p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)"
- Linted res -> do
+ Linted res _rev -> do
h1_ "Linter Result"
toHtml res
Failed err -> do
@@ -68,9 +68,9 @@ instance ToHtml AdminOverview where
if null jobs then em_ "(nothing yet)"
else flip M.foldMapWithKey jobs $ \sha1 (ref, status) -> li_ $ do
case status of
- Pending -> badge Info "pending"
- (Linted res) -> toHtml $ maximumLintLevel res
- (Failed _) -> badge Error "system error"
+ Pending -> badge Info "pending"
+ (Linted res rev) -> toHtml $ maximumLintLevel res
+ (Failed _) -> badge Error "system error"
" "; a_ [href_ ("/status/"+|orgSlug org|+"/"+|prettySha sha1|+"/")] $ do
mono $ toHtml $ reporef ref; " on "; mono $ toHtml $ repourl ref
diff --git a/server/Main.hs b/server/Main.hs
index 0d5dfd6..8b41c92 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -19,9 +19,9 @@ import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO,
writeTQueue)
import qualified Data.Text as T
import Fmt ((+|), (|+))
-import Handlers (AdminOverview,
- adminOverviewImpl,
- statusImpl)
+import Handlers (AdminOverview (AdminOverview),
+ MapService (MapService),
+ stateImpl, statusImpl)
import HtmlOrphans ()
import Network.Wai.Handler.Warp (defaultSettings,
runSettings, setPort)
@@ -43,6 +43,9 @@ import Server (JobStatus, Org (..),
import Worker (Job (Job), linterThread)
+-- | that thing we need to replace the hub
+type MapServiceAPI = "api" :> "maps" :> "list" :> Get '[JSON] MapService
+
-- | abstract api
type API format =
-- "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID
@@ -52,17 +55,19 @@ type API format =
-- | actual set of routes: api for json & html + static pages from disk
type Routes = "api" :> API JSON
+ :<|> MapServiceAPI
:<|> API HTML -- websites mirror the API exactly
:<|> Raw
-- | API's implementation
jsonAPI :: forall format. MVar ServerState -> Server (API format)
jsonAPI state = statusImpl state
- :<|> adminOverviewImpl state
+ :<|> stateImpl @AdminOverview state
-- | Complete set of routes: API + HTML sites
server :: MVar ServerState -> Server Routes
server state = jsonAPI @JSON state
+ :<|> stateImpl @MapService state
:<|> jsonAPI @HTML state
:<|> serveDirectoryWebApp "./static"
diff --git a/server/Server.hs b/server/Server.hs
index 77eebbc..bcb96a0 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -37,8 +37,7 @@ import qualified Data.Aeson as A
import qualified Data.ByteString.Base64.URL as Base64
import Data.Functor.Contravariant (contramap)
import qualified Data.Map as M
-import Lens.Micro.Platform (at, ix, makeLenses, traverseOf,
- traversed)
+import Lens.Micro.Platform (at, ix, makeLenses, traverseOf)
import LintConfig (LintConfig')
import Servant (FromHttpApiData)
import Toml (TomlCodec, prettyTomlDecodeErrors,
@@ -47,8 +46,10 @@ import qualified Toml as T
-- | a reference in a remote git repository
data RemoteRef = RemoteRef
- { repourl :: Text
- , reporef :: Text
+ { repourl :: Text
+ , reporef :: Text
+ , reponame :: Text
+ -- ^ the "world name" for the hub / world:// links
} deriving (Generic, FromJSON, ToJSON, Eq, Ord, Show)
type family ConfigRes (b :: Bool) a where
@@ -78,6 +79,8 @@ data Org (loaded :: Bool) = Org
, orgLintconfig :: ConfigRes loaded LintConfig'
, orgEntrypoint :: FilePath
, orgRepos :: [RemoteRef]
+ , orgUrl :: Text
+ , orgWebdir :: Text
} deriving Generic
-- | Orgs are compared via their slugs only
@@ -116,6 +119,7 @@ remoteCodec :: TomlCodec RemoteRef
remoteCodec = RemoteRef
<$> T.text "url" .= repourl
<*> T.text "ref" .= reporef
+ <*> T.text "name" .= reponame
orgCodec :: TomlCodec (Org False)
orgCodec = Org
@@ -123,6 +127,8 @@ orgCodec = Org
<*> T.string "lintconfig" .= orgLintconfig
<*> T.string "entrypoint" .= orgEntrypoint
<*> T.list remoteCodec "repo" .= orgRepos
+ <*> T.text "url" .= orgUrl
+ <*> T.text "webdir" .= orgWebdir
configCodec :: TomlCodec (Config False)
@@ -135,7 +141,7 @@ configCodec = Config
-- | a job status (of a specific uuid)
data JobStatus =
- Pending | Linted DirResult | Failed Text
+ Pending | Linted DirResult Text | Failed Text
deriving (Generic, ToJSON)
-- | the server's global state; might eventually end up with more
diff --git a/server/Worker.hs b/server/Worker.hs
index 1672026..40a267b 100644
--- a/server/Worker.hs
+++ b/server/Worker.hs
@@ -13,7 +13,8 @@ import CheckDir (recursiveCheckDir)
import Cli.Extras (CliConfig, ProcessFailure,
Severity (..),
callProcessAndLogOutput,
- prettyProcessFailure, runCli)
+ prettyProcessFailure,
+ readProcessAndLogStderr, runCli)
import Control.Concurrent.Async (async, link)
import Control.Concurrent.STM.TQueue
import qualified Data.Text as T
@@ -54,16 +55,19 @@ runJob config Job {..} cliconfig done = runCli cliconfig $ do
(callgit gitdir
[ "clone", toString ref, "--bare"
, "--depth", "1", "-b", toString ref])
+ rev <- map T.strip -- git returns a newline here
+ $ readProcessAndLogStderr Error
+ $ gitProc gitdir ["rev-parse", toString ref]
rand <- liftIO UUID.nextRandom
let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
callgit gitdir [ "worktree", "add", workdir ]
callgit workdir [ "checkout", toString ref ]
res <- liftIO $ recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg)
callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
- pure res
+ pure (res, rev)
liftIO $ setJobStatus done jobOrg jobRef $ case res of
- Right res -> Linted res
- Left err -> Failed (prettyProcessFailure err)
+ Right thing -> uncurry Linted thing
+ Left err -> Failed (prettyProcessFailure err)
where
url = repourl jobRef
ref = reporef jobRef
--
GitLab