diff options
Diffstat (limited to 'server/Git.hs')
-rw-r--r-- | server/Git.hs | 60 |
1 files changed, 0 insertions, 60 deletions
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 |