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
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Worker (linterThread, Job(..)) where
import Universum
import Bindings.Cli.Git (gitProc)
import CheckDir (recursiveCheckDir)
import Cli.Extras (CliConfig, ProcessFailure,
Severity (..),
callProcessAndLogOutput,
prettyProcessFailure, runCli)
import Control.Concurrent.Async (async, link)
import Control.Concurrent.STM.TQueue
import qualified Data.Text as T
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Server (Config, JobStatus (..),
Org (..),
RemoteRef (reporef, repourl),
ServerState, setJobStatus,
tmpdir)
import System.Directory (doesDirectoryExist)
import System.FilePath ((</>))
data Job = Job
{ jobRef :: RemoteRef
, jobOrg :: Org True
}
linterThread :: Config True -> CliConfig -> TQueue Job -> MVar ServerState -> IO Void
linterThread config cliconfig queue done = forever $ do
next <- atomically (readTQueue queue)
-- TODO: this doesn't guard against two jobs running on the same repo!
job <- async $ runJob config next cliconfig done
link job -- TODO: is this a good idea? will crash the server if a job fails
-- | 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
runJob :: Config True -> Job -> CliConfig -> MVar ServerState -> IO (Either ProcessFailure ())
runJob config Job {..} cliconfig done = runCli cliconfig $ do
res <- liftIO $ runCli cliconfig $ do
ifM (liftIO $ doesDirectoryExist gitdir)
-- TODO: these calls fail for dumb http, add some fallback!
(callgit gitdir
[ "fetch", "origin", toString ref, "--depth", "1" ])
(callgit gitdir
[ "clone", toString ref, "--bare"
, "--depth", "1", "-b", toString ref])
rand <- liftIO UUID.nextRandom
let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
callgit gitdir [ "worktree", "add", workdir ]
callgit workdir [ "checkout", toString ref ]
res <- liftIO $ recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg)
callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
pure res
liftIO $ setJobStatus done jobOrg jobRef $ case res of
Right res -> Linted res
Left err -> Failed (prettyProcessFailure err)
where
url = repourl jobRef
ref = reporef jobRef
callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir
gitdir = view tmpdir config </> toString hashedname
hashedname = T.map escapeSlash url
where escapeSlash = \case { '/' -> '-'; a -> a }
|
