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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
module Worker (linterThread, Job(..)) where
import Universum
import CheckDir (recursiveCheckDir,
resultIsFatal, shrinkDirResult)
import Control.Concurrent.Async (async, link)
import Control.Concurrent.STM (writeTChan)
import Control.Concurrent.STM.TQueue
import Control.Exception (IOException, handle, throw)
import Control.Monad.Logger (logError, logErrorN, logInfoN,
runStdoutLoggingT)
import qualified Data.Text as T
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Fmt ((+|), (|+))
import GHC.IO.Exception (ioException)
import LintConfig (stuffConfig)
import Server (Config, JobStatus (..),
Org (..),
RealtimeMsg (RelintPending, Reload),
RemoteRef (..), ServerState,
adjustedPath,
newRealtimeChannel,
overJobStatus, tmpdir)
import System.Directory (doesDirectoryExist)
import System.Exit (ExitCode (ExitFailure, ExitSuccess))
import System.FilePath ((</>))
import System.Process
import WriteRepo (writeAdjustedRepository)
data Job = Job
{ jobRef :: RemoteRef
, jobOrg :: Org True
}
linterThread :: Bool -> Config True -> TQueue Job -> MVar ServerState -> IO Void
linterThread offline 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 offline 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 :: Bool -> Config True -> Job -> MVar ServerState -> IO ()
runJob offline config Job {..} done = do
rand <- UUID.nextRandom
let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
handle whoops
$ finally (lint workdir) (cleanup workdir)
where
lintConfig = stuffConfig (orgLintconfig jobOrg) (reponame jobRef)
lint workdir = runStdoutLoggingT $ do
-- set the "is being linted" flag in the assembly's state
-- (to show on the site even after reloads etc.)
oldstate <- liftIO $ overJobStatus done jobOrg jobRef $ \case
Just (ref, Linted res rev (_, realtime), oldstatus) ->
Just (ref, Linted res rev (True, realtime), oldstatus)
a -> a
-- send an update message to all connected websocket clients
maybeRealtime <- case oldstate of
Just (_, Linted _ _ (_, realtime), _) -> do
atomically $ writeTChan realtime RelintPending
pure (Just realtime)
_ -> pure Nothing
-- TODO: these calls fail for dumb http, add some fallback!
liftIO (doesDirectoryExist gitdir) >>= \case
False | offline -> logErrorN $ "offline mode but not cached; linting "
<> show gitdir <> " will fail"
| otherwise ->
(liftIO $ callProcess "git"
[ "clone", toString url, "--bare"
, "--depth", "1", "-b", toString ref, gitdir])
True | offline -> logInfoN $ "offline mode: not updating " <> show gitdir
| otherwise ->
(liftIO $ callgit gitdir
[ "fetch", "origin", toString (ref <> ":" <> ref) ])
rev <- map T.strip -- git returns a newline here
$ readgit' gitdir ["rev-parse", toString ref]
let outPath = adjustedPath rev jobOrg
let humanOutPath = orgHumanWebdir jobOrg <> "/" <> reponame jobRef
callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ]
res <- liftIO $ recursiveCheckDir lintConfig workdir (orgEntrypoint jobOrg)
>>= evaluateNF
liftIO (writeAdjustedRepository lintConfig workdir (toString outPath) res)
>>= \case
ExitSuccess -> do
logInfoN $ "linted map "+| (show jobRef :: Text) |+"."
logInfoN $ "symlinking"+|outPath|+"into human web dir at"+|humanOutPath|+""
liftIO $ callProcess "ln" [ "-sfn", toString outPath, toString humanOutPath ]
ExitFailure 1 ->
logInfoN $ "linted map "+| (show jobRef :: Text) |+ ", which failed."
ExitFailure 2 -> do
-- TODO: shouldn't have linted this map at all
logErrorN $ "outpath "+|outPath|+" already exists!"
logInfoN $ "symlinking"+|outPath|+"into human web dir at"+|humanOutPath|+""
liftIO $ callProcess "ln" [ "-sfn", toString outPath, toString humanOutPath ]
ExitFailure _ ->
-- writeAdjustedRepository does not return other codes
$(logError) "wtf, this is impossible"
realtime <- case maybeRealtime of
Just realtime -> do
atomically $ writeTChan realtime Reload
pure realtime
Nothing ->
liftIO newRealtimeChannel
-- the fact that `realtime` can't be defined in here is horrifying
void $ liftIO $ overJobStatus done jobOrg jobRef $ \maybeOld ->
let status = Linted (shrinkDirResult res) rev (False, realtime)
lastvalid = case maybeOld of
Just (_,_,lastvalid) -> lastvalid
Nothing -> Nothing
in Just ( jobRef
, status
, if resultIsFatal lintConfig res
then lastvalid
else Just status
)
cleanup workdir = do
callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
whoops (error :: IOException) = runStdoutLoggingT $ do
logErrorN (show error)
void $ liftIO $ overJobStatus done jobOrg jobRef $ \case
Nothing -> Just (jobRef, Failed (show error), Nothing)
Just (_,_,lastvalid) -> Just (jobRef, Failed (show error), lastvalid)
url = repourl jobRef
ref = reporef jobRef
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)
|
