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
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Worker (linterThread, Job(..)) where
import Universum
import CheckDir (recursiveCheckDir)
import Control.Concurrent.Async (async, link)
import Control.Concurrent.STM.TQueue
import Control.Exception (IOException, handle)
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 ((</>))
import System.Process
data Job = Job
{ jobRef :: RemoteRef
, jobOrg :: Org True
}
linterThread :: Config True -> TQueue Job -> MVar ServerState -> IO Void
linterThread config 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 done
-- TODO: is this a good idea? will crash the server if a job thread fails
link job
-- | the actual check function. Calls out to git to update the
-- repository, create a new worktree, lints it, then tells git to
-- delete that tree again.
--
-- May occasionally be brittle (if someone else changed files)
-- TODO: re-add proper fancy (colourful?) logging
runJob :: Config True -> Job -> MVar ServerState -> IO ()
runJob config Job {..} done = do
rand <- UUID.nextRandom
let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
handle whoops
$ finally (lint workdir) (cleanup workdir)
where
lint workdir = do
ifM (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])
rev <- map T.strip -- git returns a newline here
$ readgit' gitdir ["rev-parse", toString ref]
callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ]
res <- recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg)
>>= evaluateNF
setJobStatus done jobOrg jobRef $
Linted res rev
cleanup workdir = do
callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
whoops (error :: IOException) = do
-- TODO: should also log this error
setJobStatus done jobOrg jobRef $ Failed (show error)
url = repourl jobRef
ref = reporef jobRef
callgit = callgit'
gitdir = view tmpdir config </> toString hashedname
hashedname = T.map escapeSlash url
where escapeSlash = \case { '/' -> '-'; a -> a }
readgit' :: MonadIO m => FilePath -> [String] -> m Text
readgit' dir args = map toText $
liftIO $ do
print args
readProcess "git" ([ "-C", toString dir ] <> args) ""
callgit' :: MonadIO m => FilePath -> [String] -> m ()
callgit' dir args =
liftIO $ do
print args
callProcess "git" ([ "-C", toString dir ] <> args)
|
