summaryrefslogtreecommitdiff
path: root/server/Git.hs
diff options
context:
space:
mode:
Diffstat (limited to 'server/Git.hs')
-rw-r--r--server/Git.hs60
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