From 24e5ccd98aa33250327d36e3859c461699026859 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Mon, 7 Feb 2022 16:05:55 +0100 Subject: non-blocking server --- server/Git.hs | 60 ----------------------------------- server/Handlers.hs | 85 ++++++++++++++++++++++++++++++++++++++++++++++++++ server/Main.hs | 45 +++++++++++++------------- server/Server.hs | 61 ++++++++++++++++++++++++++++++++++++ server/Serverconfig.hs | 45 -------------------------- 5 files changed, 167 insertions(+), 129 deletions(-) delete mode 100644 server/Git.hs create mode 100644 server/Handlers.hs create mode 100644 server/Server.hs delete mode 100644 server/Serverconfig.hs (limited to 'server') 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/Server.hs b/server/Server.hs new file mode 100644 index 0000000..41e5bde --- /dev/null +++ b/server/Server.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Server (loadConfig, Config(..), RemoteRef(..), State, JobStatus(..), + setJobStatus) where + +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') + +-- | a reference in a remote git repository +data RemoteRef = RemoteRef + { repourl :: Text + , reporef :: Text + } deriving (Generic, FromJSON, Eq, Ord) + +type family ConfigRes (b :: Bool) a where + ConfigRes True a = a + ConfigRes False a = FilePath + +-- | the server's configuration +data Config l = Config + { tmpdir :: FilePath + -- ^ dir to clone git things in + , port :: Int + -- ^ port to bind to + , entrypoint :: FilePath + , 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 -> + case eitherDecode res :: Either String LintConfig' of + 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/server/Serverconfig.hs b/server/Serverconfig.hs deleted file mode 100644 index d919567..0000000 --- a/server/Serverconfig.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Serverconfig (loadConfig, Config(..), RemoteRef(..)) where - -import Data.Aeson (FromJSON, eitherDecode) -import qualified Data.ByteString.Lazy as LB -import Data.Text (Text) -import GHC.Generics (Generic) -import LintConfig (LintConfig') - --- | a reference in a remote git repository -data RemoteRef = RemoteRef - { repourl :: Text - , reporef :: Text - } deriving (Generic, FromJSON) - -type family ConfigRes (b :: Bool) a where - ConfigRes True a = a - ConfigRes False a = FilePath - --- | the server's configuration -data Config l = Config - { tmpdir :: FilePath - -- ^ dir to clone git things in - , port :: Int - -- ^ port to bind to - , entrypoint :: FilePath - , lintconfig :: ConfigRes l LintConfig' - } - -loadConfig :: Config False -> IO (Config True) -loadConfig config = do - loaded <- LB.readFile (lintconfig config) >>= \res -> - case eitherDecode res :: Either String LintConfig' of - Left err -> error $ "config file invalid: " <> err - Right file -> pure file - pure $ config { lintconfig = loaded } -- cgit v1.2.3