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
|
module Command.Run (
RunCommand,
) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Control.Monad.Reader
import Data.List
import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import System.Exit
import System.Process
import Command
import Config
import Job
import Repo
import Terminal
data RunCommand = RunCommand Text
instance Command RunCommand where
commandName _ = "run"
commandDescription _ = "Execude jobs per minici.yaml for given commits"
type CommandArguments RunCommand = Maybe Text
commandUsage _ = T.pack $ unlines $
[ "Usage: minici run"
, " run jobs for commits on current branch not yet in upstream branch"
, " or: minici run <ref>"
, " run jobs for commits on <ref> not yet in its upstream ref"
, " or: minici run <commit>..<commit>"
, " run jobs for commits in given range"
]
commandInit _ _ = RunCommand . fromMaybe "HEAD"
commandExec = cmdRun
cmdRun :: RunCommand -> CommandExec ()
cmdRun (RunCommand changeset) = do
CommonOptions {..} <- getCommonOptions
( base, tip ) <- case T.splitOn (T.pack "..") changeset of
base : tip : _ -> return ( T.unpack base, T.unpack tip )
[ param ] -> liftIO $ do
[ deref ] <- readProcessWithExitCode "git" [ "symbolic-ref", "--quiet", T.unpack param ] "" >>= \case
( ExitSuccess, out, _ ) -> return $ lines out
( _, _, _ ) -> return [ T.unpack param ]
[ _, tip ] : _ <- fmap words . lines <$> readProcess "git" [ "show-ref", deref ] ""
[ base ] <- lines <$> readProcess "git" [ "for-each-ref", "--format=%(upstream)", tip ] ""
return ( base, tip )
[] -> error "splitOn should not return empty list"
tout <- getTerminalOutput
liftIO $ do
mngr <- newJobManager "./.minici" optJobs
Just repo <- openRepo "."
commits <- listCommits repo (base <> ".." <> tip)
jobssets <- mapM loadJobSetForCommit commits
let names = nub $ map jobName $ concatMap jobsetJobs jobssets
void $ newLine tout $ T.concat $
T.replicate (8 + 50) " " :
map ((" "<>) . fitToLength 7 . textJobName) names
threadCount <- newTVarIO (0 :: Int)
let changeCount f = atomically $ do
writeTVar threadCount . f =<< readTVar threadCount
let waitForJobs = atomically $ do
flip when retry . (0 <) =<< readTVar threadCount
handle @SomeException (\_ -> cancelAllJobs mngr) $ do
forM_ jobssets $ \jobset -> do
let commit = jobsetCommit jobset
shortCid = T.pack $ take 7 $ showCommitId $ commitId commit
shortDesc <- fitToLength 50 <$> getCommitTitle commit
case jobsetJobsEither jobset of
Right jobs -> do
outs <- runJobs mngr commit jobs
let findJob name = snd <$> find ((name ==) . jobName . fst) outs
line <- newLine tout ""
mask $ \restore -> do
changeCount (+ 1)
void $ forkIO $ (>> changeCount (subtract 1)) $
try @SomeException $ restore $ do
displayStatusLine tout line shortCid (" " <> shortDesc) $ map findJob names
Left err -> do
void $ newLine tout $
"\ESC[91m" <> shortCid <> "\ESC[0m" <> " " <> shortDesc <> " \ESC[91m" <> T.pack err <> "\ESC[0m"
waitForJobs
waitForJobs
fitToLength :: Int -> Text -> Text
fitToLength maxlen str | len <= maxlen = str <> T.replicate (maxlen - len) " "
| otherwise = T.take (maxlen - 1) str <> "…"
where len = T.length str
showStatus :: Bool -> JobStatus a -> Text
showStatus blink = \case
JobQueued -> "\ESC[94m…\ESC[0m "
JobWaiting uses -> "\ESC[94m~" <> fitToLength 6 (T.intercalate "," (map textJobName uses)) <> "\ESC[0m"
JobSkipped -> "\ESC[0m-\ESC[0m "
JobRunning -> "\ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m "
JobError _ -> "\ESC[91m!!\ESC[0m "
JobFailed -> "\ESC[91m✗\ESC[0m "
JobCancelled -> "\ESC[0mC\ESC[0m "
JobDone _ -> "\ESC[92m✓\ESC[0m "
JobDuplicate _ s -> case s of
JobQueued -> "\ESC[94m^\ESC[0m "
JobWaiting _ -> "\ESC[94m^\ESC[0m "
JobSkipped -> "\ESC[0m-\ESC[0m "
JobRunning -> "\ESC[96m" <> (if blink then "*" else "^") <> "\ESC[0m "
_ -> showStatus blink s
displayStatusLine :: TerminalOutput -> TerminalLine -> Text -> Text -> [ Maybe (TVar (JobStatus JobOutput)) ] -> IO ()
displayStatusLine tout line prefix1 prefix2 statuses = do
go "\0"
where
go prev = do
(ss, cur) <- atomically $ do
ss <- mapM (sequence . fmap readTVar) statuses
blink <- terminalBlinkStatus tout
let cur = T.concat $ map (maybe " " ((" " <>) . showStatus blink)) ss
when (cur == prev) retry
return (ss, cur)
let prefix1' = if any (maybe False jobStatusFailed) ss
then "\ESC[91m" <> prefix1 <> "\ESC[0m"
else prefix1
redrawLine line $ prefix1' <> prefix2 <> cur
if all (maybe True jobStatusFinished) ss
then return ()
else go cur
|