1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
|
{-# 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
|
