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
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
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
|
