From 7da030ea5cedbdedea09d37f94678b0b5a6834fa Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Sun, 6 Mar 2022 08:02:30 +0100
Subject: [PATCH] server: add a very simple relint button
---
server/Handlers.hs | 49 ++++++++++++++++++++++++++++---------------
server/HtmlOrphans.hs | 18 ++++++++++++++--
server/Main.hs | 26 +++++++++++++----------
server/Server.hs | 19 ++++++++++-------
server/Worker.hs | 7 ++++---
5 files changed, 79 insertions(+), 40 deletions(-)
diff --git a/server/Handlers.hs b/server/Handlers.hs
index 93a7ae2..a7c8395 100644
--- a/server/Handlers.hs
+++ b/server/Handlers.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
@@ -10,21 +11,24 @@ module Handlers (
-- , relintImpl
, stateImpl
, AdminOverview(..)
- , MapService(..)) where
+ , MapService(..),relintImpl) where
import Universum
-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, adjustedPath, getJobStatus, unState)
+import CheckDir (DirResult (dirresultMaps))
+import CheckMap (MapResult (MapResult, mapresultBadges))
+import Control.Concurrent.STM (TQueue, writeTQueue)
+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, adjustedPath,
+ getJobStatus, unState)
+import Worker (Job (Job))
-- | an info type wrapped around the server state, to carry serialisation instances.
@@ -37,16 +41,19 @@ newtype MapService =
instance ToJSON AdminOverview where
toJSON (AdminOverview state) =
- toJSON $ view unState state <&> \org -> flip map org $ \(ref, status) ->
+ toJSON $ view unState state <&> \org -> flip map (snd org) $ \(ref, status) ->
A.object [ "remote" .= ref
, "status" .= status
]
instance ToJSON MapService where
toJSON (MapService state) =
- toJSON $ M.mapWithKey orgObject (view unState state)
+ toJSON . map orgObject $ view unState state
where
- orgObject org = A.object . mapMaybe worldObject . M.elems
+ orgObject (org, statuses) =
+ A.object
+ . mapMaybe worldObject
+ $ M.elems statuses
where
worldObject (RemoteRef {..}, job) = case job of
Linted res rev ->
@@ -64,8 +71,8 @@ statusImpl :: MVar ServerState -> Text -> Sha1 -> Handler JobStatus
statusImpl state orgslug sha1 = do
status <- liftIO $ getJobStatus state orgslug sha1
case status of
- Just res -> pure $ snd res
- Nothing -> throwError err404
+ Just (_,_,jobstatus) -> pure jobstatus
+ Nothing -> throwError err404
-- | since there are multiple apis that just get state information …
stateImpl
@@ -74,3 +81,11 @@ stateImpl
=> MVar ServerState
-> Handler s
stateImpl state = readMVar state <&> coerce
+
+relintImpl :: TQueue Job -> MVar ServerState -> Text -> Sha1 -> Handler Text
+relintImpl queue state orgslug sha1 =
+ liftIO $ getJobStatus state orgslug sha1 >>= \case
+ Nothing -> pure "something went wrong"
+ Just (org, ref, _oldjob) -> do
+ atomically $ writeTQueue queue (Job ref org)
+ pure "hello"
diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs
index 9b09f1d..9475045 100644
--- a/server/HtmlOrphans.hs
+++ b/server/HtmlOrphans.hs
@@ -20,7 +20,7 @@ import CheckMap (MapResult (..))
import Data.List.Extra (escapeJSON)
import qualified Data.Map as M
import Handlers (AdminOverview (..))
-import Lucid (HtmlT, ToHtml)
+import Lucid (HtmlT, ToHtml, button_, onclick_)
import Lucid.Base (ToHtml (toHtml))
import Lucid.Html5 (a_, body_, class_, code_, div_, em_, h1_, h2_,
h3_, h4_, h5_, head_, href_, html_, id_, li_,
@@ -53,7 +53,21 @@ instance ToHtml JobStatus where
p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)"
Linted res _rev -> do
h1_ "Linter Result"
+ button_ [onclick_ "relint()", class_ "btn btn-primary", id_ "relint_button"] "relint"
toHtml res
+ script_
+ "function relint() {\n\
+ \ var xhr = new XMLHttpRequest ();\n\
+ \ xhr.open('POST', 'relint', true);\n\
+ \ xhr.onreadystatechange = (e) => {if (xhr.status == 200) {\n\
+ \ console.log(e);\n\
+ \ let btn = document.getElementById('relint_button');\n\
+ \ btn.innerText = 'pending … (please reload)';\n\
+ \ btn.disabled = true;\n\
+ \ btn.class = 'btn btn-disabled';\n\
+ \ }}\n\
+ \ xhr.send(null);\n\
+ \}"
Failed err -> do
h1_ "System Error"
p_ $ "error: " <> toHtml err
@@ -62,7 +76,7 @@ instance ToHtml JobStatus where
instance ToHtml AdminOverview where
toHtml (AdminOverview state) = htmldoc $ do
h1_ "Map List"
- flip M.foldMapWithKey (view unState state) $ \org jobs -> do
+ forM_ (view unState state) $ \(org, jobs) -> do
h2_ (toHtml $ orgSlug org)
if null jobs then em_ "(nothing yet)"
else flip M.foldMapWithKey jobs $ \sha1 (ref, status) -> li_ $ do
diff --git a/server/Main.hs b/server/Main.hs
index d9a8db7..7109583 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -20,7 +20,8 @@ import qualified Data.Text as T
import Fmt ((+|), (|+))
import Handlers (AdminOverview (AdminOverview),
MapService (MapService),
- stateImpl, statusImpl)
+ relintImpl, stateImpl,
+ statusImpl)
import HtmlOrphans ()
import Network.HTTP.Client (defaultManagerSettings,
newManager)
@@ -43,13 +44,14 @@ import Server (JobStatus, Org (..),
emptyState, exneuland,
interval, loadConfig,
orgs, port, token,
- unState, verbose)
+ verbose)
import Worker (Job (Job), linterThread)
+import Control.Monad.Logger (logInfoN,
+ runStdoutLoggingT)
import Servant.API (Header)
import Servant.Client (ClientM, client,
mkClientEnv, runClientM)
-import Control.Monad.Logger (logInfoN, runStdoutLoggingT)
type family PolyEndpoint method format payload where
PolyEndpoint Get format payload =
@@ -64,6 +66,7 @@ type MapServiceAPI method =
-- | abstract api
type API format =
"status" :> Capture "org" Text :> Capture "jobid" Sha1 :> Get '[format] JobStatus
+ :<|> "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> "relint" :> Post '[format] Text
:<|> "admin" :> "overview" :> Get '[format] AdminOverview
-- | actual set of routes: api for json & html + static pages from disk
@@ -73,19 +76,20 @@ type Routes = "api" :> API JSON
:<|> Raw
-- | API's implementation
-jsonAPI :: forall format. MVar ServerState -> Server (API format)
-jsonAPI state = statusImpl state
+jsonAPI :: forall format. TQueue Job -> MVar ServerState -> Server (API format)
+jsonAPI queue state = statusImpl state
+ :<|> relintImpl queue state
:<|> stateImpl @AdminOverview state
-- | Complete set of routes: API + HTML sites
-server :: MVar ServerState -> Server Routes
-server state = jsonAPI @JSON state
+server :: TQueue Job -> MVar ServerState -> Server Routes
+server queue state = jsonAPI @JSON queue state
:<|> stateImpl @MapService state
- :<|> jsonAPI @HTML state
+ :<|> jsonAPI @HTML queue state
:<|> serveDirectoryWebApp "./static"
-app :: MVar ServerState -> Application
-app = serve (Proxy @Routes) . server
+app :: TQueue Job -> MVar ServerState -> Application
+app queue = serve (Proxy @Routes) . server queue
postNewMaps :: Maybe Text -> MapService -> ClientM Text
postNewMaps = client (Proxy @(MapServiceAPI Post))
@@ -133,7 +137,7 @@ main = do
putTextLn $ "starting server on port " <> show (view port config)
runSettings warpsettings
. loggerMiddleware
- $ app state
+ $ app queue state
waitEither_ linter poker
where
diff --git a/server/Server.hs b/server/Server.hs
index 46a1c8c..97f87ee 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -179,7 +179,7 @@ instance TS.Show JobStatus where
-- | the server's global state; might eventually end up with more
-- stuff in here, hence the newtype
newtype ServerState = ServerState
- { _unState :: Map (Org True) (Map Sha1 (RemoteRef, JobStatus)) }
+ { _unState :: Map Text (Org True, Map Sha1 (RemoteRef, JobStatus)) }
deriving Generic
instance NFData LintConfig' => NFData ServerState
@@ -190,7 +190,7 @@ makeLenses ''ServerState
-- will default to a noop otherwise
emptyState :: Config True -> ServerState
emptyState config = ServerState
- $ M.fromList $ map (, mempty) (view orgs config)
+ $ M.fromList $ map (\org -> (orgSlug org, (org, mempty))) (view orgs config)
-- | loads a config, along with all things linked in it
-- (e.g. linterconfigs for each org)
@@ -216,13 +216,18 @@ setJobStatus mvar !org !ref !status = do
-- will otherwise cause a thunk leak, since Data.Map is annoyingly un-strict
-- even in its strict variety. for some reason it also doesn't work when
-- moved inside the `over` though …
- _ <- evaluateNF (view (unState . ix org) state)
- pure $ over (unState . ix org . at (toSha ref))
+ _ <- evaluateNF (view (unState . ix (orgSlug org) . _2) state)
+ pure $ over (unState . ix (orgSlug org) . _2 . at (toSha ref))
(const $ Just (ref, status)) state
-getJobStatus :: MVar ServerState -> Text -> Sha1 -> IO (Maybe (RemoteRef, JobStatus))
-getJobStatus mvar orgslug sha = withMVar mvar $ \state ->
- pure (M.lookup sha (view (unState . ix (Org { orgSlug = orgslug })) state))
+getJobStatus :: MVar ServerState -> Text -> Sha1 -> IO (Maybe (Org True, RemoteRef, JobStatus))
+getJobStatus mvar orgslug sha = withMVar mvar $ \state -> pure $ do
+ (org, jobs) <- view (unState . at orgslug) state
+ (ref, status) <- M.lookup sha jobs
+ Just (org, ref, status)
+ -- pure $ second (M.lookup sha) orgIndex
+ -- pure (M.lookup sha (view (unState . ix orgslug) state))
+
-- | the path (relative to a baseurl / webdir) where an adjusted
-- map should go
diff --git a/server/Worker.hs b/server/Worker.hs
index 7de9cd3..6092c78 100644
--- a/server/Worker.hs
+++ b/server/Worker.hs
@@ -4,7 +4,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell #-}
module Worker (linterThread, Job(..)) where
@@ -15,9 +15,12 @@ import CheckDir (recursiveCheckDir,
import Control.Concurrent.Async (async, link)
import Control.Concurrent.STM.TQueue
import Control.Exception (IOException, handle)
+import Control.Monad.Logger (logError, logErrorN, logInfoN,
+ runStdoutLoggingT)
import qualified Data.Text as T
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
+import Fmt ((+|), (|+))
import Server (Config, JobStatus (..),
Org (..),
RemoteRef (reporef, repourl),
@@ -28,8 +31,6 @@ import System.Exit (ExitCode (ExitFailure, ExitSucce
import System.FilePath ((</>))
import System.Process
import WriteRepo (writeAdjustedRepository)
-import Control.Monad.Logger (runStdoutLoggingT, logErrorN, logInfoN, logError)
-import Fmt ((+|), (|+))
data Job = Job
{ jobRef :: RemoteRef
--
GitLab