diff options
author | stuebinm | 2022-02-07 16:05:55 +0100 |
---|---|---|
committer | stuebinm | 2022-02-07 16:05:55 +0100 |
commit | f429cbc0d56dc8426285bc2d5ca7301ec241da98 (patch) | |
tree | 2505368b5c78d95cbfe0c22781be9a47974bc987 /server/Handlers.hs | |
parent | 2ce9a23fe7de72f4c8bf33a8c26f555cf08f8715 (diff) |
non-blocking server
Diffstat (limited to 'server/Handlers.hs')
-rw-r--r-- | server/Handlers.hs | 85 |
1 files changed, 85 insertions, 0 deletions
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 |