From f10f80a2ae99aa9c57c4ceefa67e7e5aa3fa53c8 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Mon, 7 Feb 2022 18:03:08 +0100
Subject: [PATCH] server: proper job handling
Note: the server will not check submissions for duplicates!
(nor does it do any kind of rate-limiting)
---
package.yaml | 2 +
server/Handlers.hs | 108 +++++++++++++++++++++++++++------------------
server/Main.hs | 42 ++++++++++--------
server/Server.hs | 27 +++++++++---
walint.cabal | 2 +
5 files changed, 114 insertions(+), 67 deletions(-)
diff --git a/package.yaml b/package.yaml
index 84e1e96..7208cd9 100644
--- a/package.yaml
+++ b/package.yaml
@@ -71,3 +71,5 @@ executables:
- walint
- uuid
- containers
+ - microlens
+ - microlens-th
diff --git a/server/Handlers.hs b/server/Handlers.hs
index 67c7cdf..382af64 100644
--- a/server/Handlers.hs
+++ b/server/Handlers.hs
@@ -1,85 +1,105 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
-module Handlers (App, submitImpl,statusImpl) where
+module Handlers (App, submitImpl,statusImpl,relintImpl) where
import Bindings.Cli.Git (gitProc)
-import CheckDir (DirResult, recursiveCheckDir)
-import Cli.Extras (CliT, ProcessFailure, Severity (..),
- callProcessAndLogOutput, getCliConfig,
- prettyProcessFailure, runCli)
-import Control.Concurrent (MVar, forkIO, withMVar)
+import CheckDir (recursiveCheckDir)
+import Cli.Extras (CliConfig, CliT, ProcessFailure,
+ Severity (..), callProcessAndLogOutput,
+ getCliConfig, prettyProcessFailure,
+ runCli)
+import Control.Concurrent (MVar, ThreadId, forkIO, withMVar)
import Control.Monad.Extra (ifM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans (lift)
import qualified Data.Map as M
-import Data.Text (Text)
import qualified Data.Text as T
+import Data.UUID (UUID)
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
-import Servant (Handler, err404, err500, throwError)
+import Lens.Micro.Extras (view)
+import Servant (Handler, NoContent (NoContent), err404,
+ err500, throwError)
import Server (Config (entrypoint, lintconfig, tmpdir),
JobStatus (..),
RemoteRef (reporef, repourl), State,
- setJobStatus)
+ jobs, registry, setJobStatus,
+ setRegistry)
import System.Directory (doesDirectoryExist)
import System.FilePath ((</>))
-- | this servant app can run cli programs!
type App = CliT ProcessFailure Handler
-type App' = CliT ProcessFailure IO
-- | 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 State -> RemoteRef -> App ()
+submitImpl :: Config True -> MVar State -> 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 …
- _ <- liftIO $ forkIO $ do
- res <- runCli cliconfig $ do
- ifM (liftIO $ doesDirectoryExist gitdir)
- gitfetch gitclone
- checkPath config gitdir (reporef ref)
- setJobStatus state ref $ case res of
- Right res -> Linted res
- Left err -> Failed (prettyProcessFailure err)
+ _ <- checkRef config cliconfig state ref
-- the submission itself can't really fail or return anything useful
- pure ()
- where
- -- TODO: these calls fail for dumb http, add some fallback!
- gitclone = callProcessAndLogOutput (Debug, Error)
- $ gitProc gitdir [ "clone", T.unpack $ repourl ref, "--bare", "--depth", "1", "-b", T.unpack (reporef ref)]
- gitfetch = callProcessAndLogOutput (Debug, Error)
- $ gitProc gitdir [ "fetch", "origin", T.unpack (reporef ref), "--depth", "1" ]
- gitdir = tmpdir config </> hashedname
- hashedname = fmap escapeSlash . T.unpack . repourl $ ref
- escapeSlash = \case { '/' -> '-'; a -> a }
+ pure jobid
+
+relintImpl :: Config True -> MVar State -> 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
-statusImpl :: MVar State -> RemoteRef -> App JobStatus
-statusImpl state ref = do
- status <- liftIO $ withMVar state (pure . M.lookup ref)
+statusImpl :: MVar State -> UUID -> App JobStatus
+statusImpl state uuid = do
+ status <- liftIO $ withMVar state $ \state ->
+ case M.lookup uuid (view registry state) of
+ Nothing -> pure Nothing
+ Just ref -> pure $ M.lookup ref (view jobs state)
case status of
Just res -> pure res
Nothing -> lift $ throwError err404
+-- | 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
+checkRef :: Config True -> CliConfig -> MVar State -> RemoteRef -> App ThreadId
+checkRef config cliconfig state ref = liftIO $ forkIO $ do
+ res <- liftIO $ runCli cliconfig $ do
+ ifM (liftIO $ doesDirectoryExist gitdir)
+ -- TODO: these calls fail for dumb http, add some fallback!
+ (callgit gitdir
+ [ "fetch", "origin", T.unpack (reporef ref), "--depth", "1" ])
+ (callgit gitdir
+ [ "clone", T.unpack $ repourl ref, "--bare"
+ , "--depth", "1", "-b", T.unpack (reporef ref)])
+ rand <- liftIO UUID.nextRandom
+ let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
+ callgit gitdir [ "worktree", "add", workdir ]
+ callgit workdir [ "checkout", T.unpack (reporef ref) ]
+ res <- liftIO $ recursiveCheckDir (lintconfig config) workdir (entrypoint config)
+ callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
+ pure res
+ liftIO $ setJobStatus state ref $ case res of
+ Right res -> Linted res
+ Left err -> Failed (prettyProcessFailure err)
+ where
+ callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir
+ gitdir = tmpdir config </> hashedname
+ hashedname = fmap escapeSlash . T.unpack . repourl $ ref
+ escapeSlash = \case { '/' -> '-'; a -> a }
-checkPath :: Config True -> FilePath -> Text -> App' DirResult
-checkPath config gitdir ref = do
- rand <- liftIO UUID.nextRandom
- let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
- callProcessAndLogOutput (Debug, Error)
- $ gitProc gitdir [ "worktree", "add", workdir ]
- callProcessAndLogOutput (Debug, Error)
- $ gitProc workdir [ "checkout", T.unpack ref ]
- res <- liftIO $ recursiveCheckDir (lintconfig config) gitdir (entrypoint config)
- callProcessAndLogOutput (Debug, Error)
- $ gitProc gitdir [ "worktree", "remove", "-f", "-f", workdir ]
- pure res
diff --git a/server/Main.hs b/server/Main.hs
index 33c2c5c..ecaf6b7 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -1,11 +1,11 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
-- | simple server offering linting "as a service"
@@ -15,16 +15,20 @@ import Cli.Extras (mkDefaultCliConfig, runCli)
import Control.Concurrent (MVar, newMVar)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString.Lazy.Char8 as C8
-import Handlers (App, statusImpl, submitImpl)
+import Data.UUID (UUID)
+import Handlers (App, relintImpl, statusImpl,
+ submitImpl)
import Network.Wai.Handler.Warp (run)
-import Servant (Application, Get, Handler,
+import Servant (Application, Capture, Get, Handler,
HasServer (ServerT), JSON,
- Proxy (Proxy), ReqBody,
- ServerError (errBody), err500,
- hoistServer, serve, throwError,
- type (:<|>) (..), type (:>), Post)
+ NoContent, Post, Proxy (Proxy),
+ ReqBody, ServerError (errBody),
+ err500, hoistServer, serve,
+ throwError, type (:<|>) (..),
+ type (:>))
import Server (Config (..), JobStatus,
- RemoteRef (..), State, loadConfig)
+ RemoteRef (..), State,
+ defaultState, loadConfig)
{-
Needed:
@@ -40,8 +44,9 @@ Needed:
-}
-- | Main API type
type API format =
- "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] ()
- :<|> "status" :> ReqBody '[JSON] RemoteRef :> Get '[format] JobStatus
+ "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID
+ :<|> "status" :> Capture "jobid" UUID :> Get '[format] JobStatus
+ :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent
-- | API's implementation
@@ -49,6 +54,7 @@ jsonAPI :: Config True -> MVar State -> ServerT (API JSON) App
jsonAPI config state =
submitImpl config state
:<|> statusImpl state
+ :<|> relintImpl config state
-- | make an application; convert any cli errors into a 500
app :: Config True -> MVar State -> Application
@@ -65,7 +71,7 @@ app config =
main :: IO ()
main = do
- state <- newMVar (mempty :: State)
+ state <- newMVar defaultState
let config = Config "/tmp" 8080 "main.json" "./config.json"
config' <- loadConfig config
run (port config) (app config' state)
diff --git a/server/Server.hs b/server/Server.hs
index 41e5bde..93bfb30 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -3,12 +3,13 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-module Server (loadConfig, Config(..), RemoteRef(..), State, JobStatus(..),
- setJobStatus) where
+module Server (loadConfig, Config(..), RemoteRef(..), State, registry, jobs, JobStatus(..),
+ setJobStatus,defaultState,setRegistry) where
import CheckDir (DirResult)
import Control.Concurrent (MVar, modifyMVar_)
@@ -17,9 +18,13 @@ import qualified Data.ByteString.Lazy as LB
import Data.Map (Map)
import qualified Data.Map as M
import Data.Text (Text)
+import Data.UUID (UUID)
import GHC.Generics (Generic)
+import Lens.Micro (over)
+import Lens.Micro.TH
import LintConfig (LintConfig')
+
-- | a reference in a remote git repository
data RemoteRef = RemoteRef
{ repourl :: Text
@@ -44,7 +49,15 @@ data JobStatus =
Pending | Linted DirResult | Failed Text
deriving (Generic, ToJSON)
-type State = Map RemoteRef JobStatus
+data State = State
+ { _jobs :: Map RemoteRef JobStatus
+ , _registry :: Map UUID RemoteRef
+ }
+
+makeLenses ''State
+
+defaultState :: State
+defaultState = State mempty mempty
loadConfig :: Config False -> IO (Config True)
@@ -57,5 +70,9 @@ loadConfig config = do
setJobStatus :: MVar State -> RemoteRef -> JobStatus -> IO ()
-setJobStatus mvar ref status = modifyMVar_ mvar $ \state ->
- pure $ M.insert ref status state
+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
+ $ pure . over registry (M.insert uuid ref)
diff --git a/walint.cabal b/walint.cabal
index 3786ce5..9f37d59 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -79,6 +79,8 @@ executable server
, filepath
, http-media
, logging-effect
+ , microlens
+ , microlens-th
, mtl
, process
, servant
--
GitLab