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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
module Handlers (App, submitImpl,statusImpl,relintImpl,adminOverviewImpl) where
import Bindings.Cli.Git (gitProc)
import CheckDir (recursiveCheckDir)
import Cli.Extras (CliConfig, CliT, ProcessFailure,
Severity (..), callProcessAndLogOutput,
getCliConfig, prettyProcessFailure,
runCli)
import Control.Concurrent (MVar, ThreadId, forkIO, readMVar,
withMVar)
import Control.Monad.Extra (ifM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans (lift)
import qualified Data.Map as M
import qualified Data.Text as T
import Data.UUID (UUID)
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Lens.Micro.Extras (view)
import Servant (Handler, NoContent (NoContent), err404,
err500, throwError)
import Server (AdminOverview (AdminOverview),
Config (entrypoint, lintconfig, tmpdir),
JobStatus (..),
RemoteRef (reporef, repourl), State,
jobs, registry, setJobStatus,
setRegistry)
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 -> MVar State -> RemoteRef -> App UUID
submitImpl config state ref = do
jobid <- liftIO UUID.nextRandom
-- TODO: these two should really be atomic
liftIO $ setJobStatus state ref Pending
liftIO $ setRegistry state jobid ref
cliconfig <- getCliConfig
-- we'll just forget the thread id for now and trust this terminates …
_ <- checkRef config cliconfig state ref
-- the submission itself can't really fail or return anything useful
pure jobid
relintImpl :: Config True -> MVar State -> UUID -> App NoContent
relintImpl config state uuid = do
mref <- liftIO $ withMVar state (pure . M.lookup uuid . view registry)
case mref of
Nothing -> lift $ throwError err404
Just ref -> do
cliconfig <- getCliConfig
_ <- checkRef config cliconfig state ref
pure NoContent
statusImpl :: MVar State -> UUID -> App JobStatus
statusImpl state uuid = do
status <- liftIO $ withMVar state $ \state ->
case M.lookup uuid (view registry state) of
Nothing -> pure Nothing
Just ref -> pure $ M.lookup ref (view jobs state)
case status of
Just res -> pure res
Nothing -> lift $ throwError err404
adminOverviewImpl :: MVar State -> App AdminOverview
adminOverviewImpl state = do
state <- liftIO $ readMVar state
pure (AdminOverview state)
-- | the actual check function. forks, calls out to git to update the
-- repository, create a new worktree, lints it, then tells git to
-- delete that tree again
checkRef :: Config True -> CliConfig -> MVar State -> RemoteRef -> App ThreadId
checkRef config cliconfig state ref = liftIO $ forkIO $ do
res <- liftIO $ runCli cliconfig $ do
ifM (liftIO $ doesDirectoryExist gitdir)
-- TODO: these calls fail for dumb http, add some fallback!
(callgit gitdir
[ "fetch", "origin", T.unpack (reporef ref), "--depth", "1" ])
(callgit gitdir
[ "clone", T.unpack $ repourl ref, "--bare"
, "--depth", "1", "-b", T.unpack (reporef ref)])
rand <- liftIO UUID.nextRandom
let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
callgit gitdir [ "worktree", "add", workdir ]
callgit workdir [ "checkout", T.unpack (reporef ref) ]
res <- liftIO $ recursiveCheckDir (lintconfig config) workdir (entrypoint config)
callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
pure res
liftIO $ setJobStatus state ref $ case res of
Right res -> Linted res
Left err -> Failed (prettyProcessFailure err)
where
callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir
gitdir = tmpdir config </> hashedname
hashedname = fmap escapeSlash . T.unpack . repourl $ ref
escapeSlash = \case { '/' -> '-'; a -> a }
|
