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
113
114
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Worker (linterThread, Job(..)) where
import Universum
import CheckDir (recursiveCheckDir,
shrinkDirResult)
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, adjustedPath,
setJobStatus, tmpdir)
import System.Directory (doesDirectoryExist)
import System.Exit (ExitCode (ExitFailure))
import System.FilePath ((</>))
import System.Process
import WriteRepo (writeAdjustedRepository)
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
writeAdjustedRepository (orgLintconfig jobOrg) workdir (toString $ adjustedPath rev jobOrg) res
>>= \case ExitFailure 1 ->
-- error's in the result anyways
pure ()
ExitFailure 2 ->
-- TODO: use a fastlogger for this or sth
-- TODO: shouldn't have linted this map at all
putTextLn "ERROR: outpath already exists"
ExitFailure n -> do -- impossible
print n
pure ()
_ -> pure () -- all good
putTextLn "still here!"
setJobStatus done jobOrg jobRef $
Linted (shrinkDirResult 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)
|
