From 24e5ccd98aa33250327d36e3859c461699026859 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Mon, 7 Feb 2022 16:05:55 +0100
Subject: [PATCH] non-blocking server
---
package.yaml | 3 +-
server/Git.hs | 60 -------------------
server/Handlers.hs | 85 +++++++++++++++++++++++++++
server/Main.hs | 45 +++++++-------
server/{Serverconfig.hs => Server.hs} | 24 ++++++--
walint.cabal | 11 ++--
6 files changed, 134 insertions(+), 94 deletions(-)
delete mode 100644 server/Git.hs
create mode 100644 server/Handlers.hs
rename server/{Serverconfig.hs => Server.hs} (63%)
diff --git a/package.yaml b/package.yaml
index 95ed5fb..84e1e96 100644
--- a/package.yaml
+++ b/package.yaml
@@ -5,7 +5,7 @@ homepage: https://stuebinm.eu/git/walint
author: stuebinm
maintainer: stuebinm@disroot.org
copyright: 2022 stuebinm
-ghc-options: -Wall -Wno-name-shadowing
+ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors
dependencies:
- base
@@ -70,3 +70,4 @@ executables:
- directory
- walint
- uuid
+ - containers
diff --git a/server/Git.hs b/server/Git.hs
deleted file mode 100644
index e32d801..0000000
--- a/server/Git.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Git (App, submitImpl) where
-
-import Bindings.Cli.Git (gitProc)
-import CheckDir (DirResult, recursiveCheckDir)
-import Cli.Extras (CliT, ProcessFailure, Severity (..),
- callProcessAndLogOutput)
-import Control.Monad.Extra (ifM)
-import Control.Monad.IO.Class (liftIO)
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.UUID as UUID
-import qualified Data.UUID.V4 as UUID
-import Servant
-import Serverconfig
-import System.Directory (doesDirectoryExist)
-import System.FilePath ((</>))
-
-
--- | this servant app can run cli programs!
-type App = CliT ProcessFailure Handler
-
--- | 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 -> RemoteRef -> App DirResult
-submitImpl config ref = do
- ifM (liftIO $ doesDirectoryExist gitdir)
- (callProcessAndLogOutput (Debug, Error) gitfetch)
- (callProcessAndLogOutput (Debug, Error) gitclone)
- checkPath config gitdir (reporef ref)
- where gitclone = gitProc gitdir -- TODO: these calls fail for dumb http, add some fallback!
- [ "clone", T.unpack $ repourl ref, "--bare", "--depth", "1", "-b", T.unpack (reporef ref)]
- gitfetch = 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
-
-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/Handlers.hs b/server/Handlers.hs
new file mode 100644
index 0000000..67c7cdf
--- /dev/null
+++ b/server/Handlers.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Handlers (App, submitImpl,statusImpl) 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 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 qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+import Servant (Handler, err404, err500, throwError)
+import Server (Config (entrypoint, lintconfig, tmpdir),
+ JobStatus (..),
+ RemoteRef (reporef, repourl), State,
+ setJobStatus)
+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 state ref = do
+ liftIO $ setJobStatus state ref Pending
+ 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)
+ -- 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 }
+
+statusImpl :: MVar State -> RemoteRef -> App JobStatus
+statusImpl state ref = do
+ status <- liftIO $ withMVar state (pure . M.lookup ref)
+ case status of
+ Just res -> pure res
+ Nothing -> lift $ throwError err404
+
+
+
+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 77c8fde..33c2c5c 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -1,15 +1,8 @@
{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
@@ -18,16 +11,20 @@
-- | simple server offering linting "as a service"
module Main where
-import CheckDir (DirResult)
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 Data.Text (Text)
-import Git (App, submitImpl)
+import Handlers (App, statusImpl, submitImpl)
import Network.Wai.Handler.Warp (run)
-import Servant
-import Serverconfig (Config (..), RemoteRef (..),
- loadConfig)
+import Servant (Application, Get, Handler,
+ HasServer (ServerT), JSON,
+ Proxy (Proxy), ReqBody,
+ ServerError (errBody), err500,
+ hoistServer, serve, throwError,
+ type (:<|>) (..), type (:>), Post)
+import Server (Config (..), JobStatus,
+ RemoteRef (..), State, loadConfig)
{-
Needed:
@@ -43,21 +40,20 @@ Needed:
-}
-- | Main API type
type API format =
- "submit" :> ReqBody '[JSON] RemoteRef :> Get '[format] DirResult
- :<|> "status" :> Capture "sha1" Text :> Get '[format] [Int]
+ "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] ()
+ :<|> "status" :> ReqBody '[JSON] RemoteRef :> Get '[format] JobStatus
+
-- | API's implementation
-jsonAPI :: Config True -> ServerT (API JSON) App
-jsonAPI config =
- submitImpl config
- :<|> (\sha -> do
- liftIO $ print sha
- pure [1])
+jsonAPI :: Config True -> MVar State -> ServerT (API JSON) App
+jsonAPI config state =
+ submitImpl config state
+ :<|> statusImpl state
-- | make an application; convert any cli errors into a 500
-app :: Config True -> Application
+app :: Config True -> MVar State -> Application
app config =
- serve api $ hoistServer api conv (jsonAPI config)
+ serve api . hoistServer api conv . jsonAPI config
where api = Proxy @(API JSON)
conv :: App a -> Handler a
conv m = do
@@ -69,6 +65,7 @@ app config =
main :: IO ()
main = do
+ state <- newMVar (mempty :: State)
let config = Config "/tmp" 8080 "main.json" "./config.json"
config' <- loadConfig config
- run (port config) (app config')
+ run (port config) (app config' state)
diff --git a/server/Serverconfig.hs b/server/Server.hs
similarity index 63%
rename from server/Serverconfig.hs
rename to server/Server.hs
index d919567..41e5bde 100644
--- a/server/Serverconfig.hs
+++ b/server/Server.hs
@@ -2,16 +2,20 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-module Serverconfig (loadConfig, Config(..), RemoteRef(..)) where
+module Server (loadConfig, Config(..), RemoteRef(..), State, JobStatus(..),
+ setJobStatus) where
-import Data.Aeson (FromJSON, eitherDecode)
+import CheckDir (DirResult)
+import Control.Concurrent (MVar, modifyMVar_)
+import Data.Aeson (FromJSON, ToJSON, eitherDecode)
import qualified Data.ByteString.Lazy as LB
+import Data.Map (Map)
+import qualified Data.Map as M
import Data.Text (Text)
import GHC.Generics (Generic)
import LintConfig (LintConfig')
@@ -20,7 +24,7 @@ import LintConfig (LintConfig')
data RemoteRef = RemoteRef
{ repourl :: Text
, reporef :: Text
- } deriving (Generic, FromJSON)
+ } deriving (Generic, FromJSON, Eq, Ord)
type family ConfigRes (b :: Bool) a where
ConfigRes True a = a
@@ -36,6 +40,13 @@ data Config l = Config
, lintconfig :: ConfigRes l LintConfig'
}
+data JobStatus =
+ Pending | Linted DirResult | Failed Text
+ deriving (Generic, ToJSON)
+
+type State = Map RemoteRef JobStatus
+
+
loadConfig :: Config False -> IO (Config True)
loadConfig config = do
loaded <- LB.readFile (lintconfig config) >>= \res ->
@@ -43,3 +54,8 @@ loadConfig config = do
Left err -> error $ "config file invalid: " <> err
Right file -> pure file
pure $ config { lintconfig = loaded }
+
+
+setJobStatus :: MVar State -> RemoteRef -> JobStatus -> IO ()
+setJobStatus mvar ref status = modifyMVar_ mvar $ \state ->
+ pure $ M.insert ref status state
diff --git a/walint.cabal b/walint.cabal
index 096d396..3786ce5 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -34,7 +34,7 @@ library
Paths_walint
hs-source-dirs:
lib
- ghc-options: -Wall -Wno-name-shadowing
+ ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors
build-depends:
HList
, aeson
@@ -60,12 +60,12 @@ library
executable server
main-is: Main.hs
other-modules:
- Git
- Serverconfig
+ Handlers
+ Server
Paths_walint
hs-source-dirs:
server
- ghc-options: -Wall -Wno-name-shadowing
+ ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors
build-depends:
aeson
, base
@@ -73,6 +73,7 @@ executable server
, bytestring
, cli-extras
, cli-git
+ , containers
, directory
, extra
, filepath
@@ -93,7 +94,7 @@ executable server
executable walint
main-is: Main.hs
- ghc-options: -Wall -Wno-name-shadowing
+ ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors
build-depends:
aeson
, aeson-pretty
--
GitLab