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
|
module Job (
Job(..),
JobOutput(..),
JobName(..), stringJobName,
ArtifactName(..),
runJobs,
) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Except
import Data.List
import Data.Text (Text)
import Data.Text qualified as T
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.Process
data Job = Job
{ jobName :: JobName
, jobRecipe :: [CreateProcess]
, jobArtifacts :: [(ArtifactName, CreateProcess)]
, jobUses :: [(JobName, ArtifactName)]
}
data JobOutput = JobOutput
{ outName :: JobName
, outStatus :: Bool
, outArtifacts :: [ArtifactOutput]
}
data JobName = JobName Text
deriving (Eq, Ord, Show)
stringJobName :: JobName -> String
stringJobName (JobName name) = T.unpack name
data ArtifactName = ArtifactName Text
deriving (Eq, Ord, Show)
data ArtifactOutput = ArtifactOutput
{ aoutName :: ArtifactName
, aoutWorkPath :: FilePath
, aoutStorePath :: FilePath
}
runJobs :: FilePath -> String -> [Job] -> IO [TVar (Maybe JobOutput)]
runJobs dir cid jobs = do
results <- forM jobs $ \job -> (job,) <$> newTVarIO Nothing
gitLock <- newMVar ()
forM_ results $ \(job, outVar) -> void $ forkIO $ do
uses <- forM (jobUses job) $ \(ujobName, uartName) -> do
Just (_, uoutVar) <- return $ find ((==ujobName) . jobName . fst) results
uout <- atomically $ maybe retry return =<< readTVar uoutVar
Just uart <- return $ find ((==uartName) . aoutName) $ outArtifacts uout
return uart
out <- runJob gitLock dir cid job uses
atomically $ writeTVar outVar $ Just out
return $ map snd results
runJob :: MVar () -> FilePath -> String -> Job -> [ArtifactOutput] -> IO JobOutput
runJob gitLock dir cid job uses = do
[checkoutPath] <- lines <$> readProcess "mktemp" ["-d", "-t", "minici.XXXXXXXXXX"] ""
tid <- withMVar gitLock $ \_ -> do
"" <- readProcess "git" ["--work-tree=" <> checkoutPath, "restore", "--source=" <> cid, "--", "."] ""
["tree", tid]:_ <- map words . lines <$> readProcess "git" ["cat-file", "-p", cid] ""
return tid
let jdir = dir </> "jobs" </> tid </> stringJobName (jobName job)
createDirectoryIfMissing True jdir
logs <- openFile (jdir </> "log") WriteMode
forM_ uses $ \aout -> do
let target = checkoutPath </> aoutWorkPath aout
createDirectoryIfMissing True $ takeDirectory target
copyFile (aoutStorePath aout) target
res <- runExceptT $ do
forM_ (jobRecipe job) $ \p -> do
(Just hin, _, _, hp) <- liftIO $ createProcess_ "" p
{ cwd = Just checkoutPath
, std_in = CreatePipe
, std_out = UseHandle logs
, std_err = UseHandle logs
}
liftIO $ hClose hin
exit <- liftIO $ waitForProcess hp
when (exit /= ExitSuccess) $
throwError ()
hClose logs
writeFile (jdir </> "status") $
if res == Right () then "success\n" else "failure\n"
let adir = jdir </> "artifacts"
artifacts <- forM (jobArtifacts job) $ \(name@(ArtifactName tname), pathCmd) -> do
[path] <- lines <$> readCreateProcess pathCmd { cwd = Just checkoutPath } ""
let target = adir </> T.unpack tname
createDirectoryIfMissing True adir
copyFile (checkoutPath </> path) target
return $ ArtifactOutput
{ aoutName = name
, aoutWorkPath = path
, aoutStorePath = target
}
removeDirectoryRecursive checkoutPath
return JobOutput
{ outName = jobName job
, outStatus = res == Right ()
, outArtifacts = artifacts
}
|