Skip to content

Commit 92aaca6

Browse files
paolinopaolino
committed
[cli] feat: add trust-all-requesters switch to anti-agent
1 parent 4a4ca1e commit 92aaca6

File tree

2 files changed

+161
-137
lines changed

2 files changed

+161
-137
lines changed

‎cli/CD/anti-agent/docker-compose.yaml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@ services:
1717
restart:
1818
always
1919
privileged: true
20-
command: "--poll-interval 60 --days 1"
20+
command: "--poll-interval 60 --days 1 --trust-all-requesters"
2121
volumes:
2222
- tmp:/tmp
2323
# Mount CA certificates, curl seems not to find them when the pkgs.cacert is included in the image

‎cli/src/User/Agent/Process.hs‎

Lines changed: 160 additions & 136 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@ The process
44
- monitors the antithesis recipients email inbox for new test results.
55
- monitors the running test-run facts
66
- publish a report-test transaction for each new result found.
7-
- automatically accepts pending test-runs from trusted creators, downloading their assets and pushing them to Antithesis.
7+
- automatically accepts pending test-runs from trusted requesters, downloading their assets and pushing them to Antithesis.
88
99
Trickery:
1010
- To avoid pushing to Antithesis twice the same test-run, we have to track also the test-runs that are changing state (pending->running or running->done).
@@ -123,6 +123,13 @@ parseArgs =
123123
secretsFileOption
124124
processOptionsParser
125125

126+
data Requesters = Some [Username] | AnyRequester
127+
deriving (Eq, Show)
128+
129+
allowRequester :: Requesters -> Username -> Bool
130+
allowRequester AnyRequester _ = True
131+
allowRequester (Some users) user = user `elem` users
132+
126133
data ProcessOptions = ProcessOptions
127134
{ poAuth :: Auth
128135
, poPollIntervalSeconds :: Int
@@ -132,7 +139,7 @@ data ProcessOptions = ProcessOptions
132139
, poAntithesisEmail :: EmailUser
133140
, poAntithesisEmailPassword :: EmailPassword
134141
, poDays :: Int
135-
, poTrustedCreators :: [Username]
142+
, poTrustedRequesters :: Requesters
136143
, poRegistry :: Registry
137144
, poAntithesisAuth :: AntithesisAuth
138145
, poVerbose :: Bool
@@ -149,7 +156,7 @@ processOptionsParser =
149156
<*> agentEmailOption
150157
<*> agentEmailPasswordOption
151158
<*> daysOption
152-
<*> creatorsOption
159+
<*> requestersOption
153160
<*> registryOption
154161
<*> antithesisAuthOption
155162
<*> verboseOption
@@ -164,172 +171,189 @@ verboseOption =
164171
, value False
165172
]
166173

167-
creatorsOption :: Parser [Username]
168-
creatorsOption =
174+
someRequestersOption :: Parser Requesters
175+
someRequestersOption =
169176
let fromOption =
170177
many
171178
$ Username
172179
<$> strOption
173-
[ long "trusted-test-creator"
180+
[ long "trusted-test-requester"
174181
, short 'c'
175182
, metavar "GITHUB_USERNAME"
176183
, help
177-
"GitHub username of a trusted test-run creator. \
178-
\Can be specified multiple times to add multiple trusted creators. \
179-
\All test-runs pending from trusted creators will be run by the agent."
184+
"GitHub username of a trusted test-run requester. \
185+
\Can be specified multiple times to add multiple trusted requesters. \
186+
\All test-runs pending from trusted requesters will be run by the agent."
180187
]
181188
fromConfig =
182189
fmap (fromMaybe [])
183190
$ optional
184191
$ fmap Username
185192
<$> setting
186193
[ conf "trustedRequesters"
187-
, help "List of trusted test-run creators GitHub usernames."
194+
, help "List of trusted test-run requesters GitHub usernames."
188195
, metavar "GITHUB_USERNAMES"
189196
]
190-
in (<>) <$> fromOption <*> fromConfig
197+
in fmap Some $ (<>) <$> fromOption <*> fromConfig
198+
199+
allRequestersOption :: Parser Requesters
200+
allRequestersOption =
201+
setting
202+
[ long "trust-all-requesters"
203+
, help
204+
"Trust all test-run requesters. All pending test-runs will be run by the agent."
205+
, switch AnyRequester
206+
]
207+
208+
requestersOption :: Parser Requesters
209+
requestersOption = allRequestersOption <|> someRequestersOption
191210

192211
agentProcess
193212
:: ProcessOptions
194213
-> IO ()
195-
agentProcess opts@ProcessOptions{poPollIntervalSeconds, poVerbose} = do
196-
putStrLn "Starting agent process service..."
197-
forever $ runExceptT $ do
198-
results <- liftIO $ pollEmails opts
199-
loggin
200-
$ "Found " ++ show (length results) ++ " email results."
201-
efacts <- liftIO $ pollTestRuns opts
202-
(pendingTests, runningTests, doneTests, stateChanging) <- case efacts of
203-
ValidationFailure err -> do
204-
loggin $ "Failed to get test-run facts: " ++ show err
205-
throwE ()
206-
ValidationSuccess facts -> pure facts
214+
agentProcess
215+
opts@ProcessOptions
216+
{ poPollIntervalSeconds
217+
, poVerbose
218+
, poTrustedRequesters
219+
} = do
220+
putStrLn "Starting agent process service..."
221+
forever $ runExceptT $ do
222+
results <- liftIO $ pollEmails opts
223+
loggin
224+
$ "Found " ++ show (length results) ++ " email results."
225+
efacts <- liftIO $ pollTestRuns opts
226+
(pendingTests, runningTests, doneTests, stateChanging) <- case efacts of
227+
ValidationFailure err -> do
228+
loggin $ "Failed to get test-run facts: " ++ show err
229+
throwE ()
230+
ValidationSuccess facts -> pure facts
207231

208-
loggin
209-
$ "Found "
210-
++ show (length pendingTests)
211-
++ " pending tests (excluding changing state), "
212-
++ show (length runningTests)
213-
++ " running tests (excluding changing state), and "
214-
++ show (length doneTests)
215-
++ " done tests (excluding changing state). and "
216-
++ show (length stateChanging)
217-
++ " changing state tests."
218-
for_ results $ \result@Result{description} -> do
219-
let sameKey :: [Fact TestRun v] -> Maybe (Fact TestRun v)
220-
sameKey = find $ (description ==) . factKey
221-
matchingTests =
222-
Left <$> sameKey runningTests
223-
<|> Right <$> sameKey doneTests
224-
TestRunId trId = mkTestRunId description
225-
case matchingTests of
226-
Nothing ->
227-
loggin
228-
$ "No matching test-run found in facts for email result: "
229-
++ trId
230-
Just (Left (Fact testRun testState)) -> do
231-
loggin
232-
$ "Publishing result for test-run: "
233-
++ show testRun
234-
eres <- liftIO $ submitDone opts (testRunDuration testState) result
235-
case eres of
236-
ValidationFailure err ->
237-
loggin
238-
$ "Failed to publish result for test-run "
239-
++ trId
240-
++ ": "
241-
++ show err
242-
ValidationSuccess txHash ->
243-
loggin
244-
$ "Published result for test-run "
245-
++ trId
246-
++ " in transaction "
247-
++ show txHash
248-
Just (Right _) -> when poVerbose $ do
249-
loggin
250-
$ "Test-run "
251-
++ trId
252-
++ " has email result and is already in done state."
253-
for_ pendingTests $ \(Fact testRun _) -> runExceptT $ do
254-
let TestRunId trId = mkTestRunId testRun
255-
user = requester testRun
256-
testId = mkTestRunId testRun
257-
if user `elem` poTrustedCreators opts
258-
then do
259-
loggin
260-
$ "Test-run "
261-
++ trId
262-
++ " is pending from trusted creator "
263-
++ show user
264-
++ ", starting it."
265-
withSystemTempDirectory "antithesis-agent-" $ \directoryPath -> do
266-
let directory = Directory directoryPath
267-
dres <- liftIO $ downloadAssets opts directory testId
268-
case dres of
269-
ValidationFailure err -> do
232+
loggin
233+
$ "Found "
234+
++ show (length pendingTests)
235+
++ " pending tests (excluding changing state), "
236+
++ show (length runningTests)
237+
++ " running tests (excluding changing state), and "
238+
++ show (length doneTests)
239+
++ " done tests (excluding changing state). and "
240+
++ show (length stateChanging)
241+
++ " changing state tests."
242+
for_ results $ \result@Result{description} -> do
243+
let sameKey :: [Fact TestRun v] -> Maybe (Fact TestRun v)
244+
sameKey = find $ (description ==) . factKey
245+
matchingTests =
246+
Left <$> sameKey runningTests
247+
<|> Right <$> sameKey doneTests
248+
TestRunId trId = mkTestRunId description
249+
case matchingTests of
250+
Nothing ->
251+
loggin
252+
$ "No matching test-run found in facts for email result: "
253+
++ trId
254+
Just (Left (Fact testRun testState)) -> do
255+
loggin
256+
$ "Publishing result for test-run: "
257+
++ show testRun
258+
eres <- liftIO $ submitDone opts (testRunDuration testState) result
259+
case eres of
260+
ValidationFailure err ->
270261
loggin
271-
$ "Failed to download assets for test-run "
262+
$ "Failed to publish result for test-run "
272263
++ trId
273264
++ ": "
274265
++ show err
275-
throwE ()
276-
ValidationSuccess _ -> pure ()
277-
pushes <- liftIO $ pushTest opts directory testId
278-
case pushes of
266+
ValidationSuccess txHash ->
267+
loggin
268+
$ "Published result for test-run "
269+
++ trId
270+
++ " in transaction "
271+
++ show txHash
272+
Just (Right _) -> when poVerbose $ do
273+
loggin
274+
$ "Test-run "
275+
++ trId
276+
++ " has email result and is already in done state."
277+
for_ pendingTests $ \(Fact testRun _) -> runExceptT $ do
278+
let TestRunId trId = mkTestRunId testRun
279+
user = requester testRun
280+
testId = mkTestRunId testRun
281+
if allowRequester poTrustedRequesters user
282+
then do
283+
loggin
284+
$ "Test-run "
285+
++ trId
286+
++ " is pending from trusted requester "
287+
++ show user
288+
++ ", starting it."
289+
withSystemTempDirectory "antithesis-agent-" $ \directoryPath -> do
290+
let directory = Directory directoryPath
291+
dres <- liftIO $ downloadAssets opts directory testId
292+
case dres of
293+
ValidationFailure err -> do
294+
loggin
295+
$ "Failed to download assets for test-run "
296+
++ trId
297+
++ ": "
298+
++ show err
299+
throwE ()
300+
ValidationSuccess _ -> pure ()
301+
pushes <- liftIO $ pushTest opts directory testId
302+
case pushes of
303+
ValidationFailure err -> do
304+
loggin
305+
$ "Failed to push test-run "
306+
++ trId
307+
++ ": "
308+
++ show err
309+
throwE ()
310+
ValidationSuccess _ -> do
311+
loggin
312+
$ "Pushed test-run "
313+
++ trId
314+
++ " to Antithesis."
315+
eres <- liftIO $ submitRunning opts testId
316+
case eres of
279317
ValidationFailure err -> do
280318
loggin
281-
$ "Failed to push test-run "
319+
$ "Failed to accept test-run "
282320
++ trId
283321
++ ": "
284322
++ show err
285-
throwE ()
286-
ValidationSuccess _ -> do
323+
ValidationSuccess txHash ->
287324
loggin
288-
$ "Pushed test-run "
325+
$ "Accepted test-run "
289326
++ trId
290-
++ " to Antithesis."
291-
eres <- liftIO $ submitRunning opts testId
292-
case eres of
293-
ValidationFailure err -> do
294-
loggin
295-
$ "Failed to accept test-run "
296-
++ trId
297-
++ ": "
298-
++ show err
299-
ValidationSuccess txHash ->
300-
loggin
301-
$ "Accepted test-run "
302-
++ trId
303-
++ " in transaction "
304-
++ show txHash
305-
else
306-
loggin
307-
$ "Test-run "
308-
++ trId
309-
++ " is pending from untrusted creator "
310-
++ show user
311-
++ ", waiting for it to start running."
312-
for_ runningTests $ \(Fact testRun _) -> do
313-
let TestRunId trId = mkTestRunId testRun
314-
sameKey = (== testRun) . description
315-
case find sameKey results of
316-
Just _ -> pure ()
317-
Nothing ->
318-
loggin
319-
$ "Test-run "
320-
++ trId
321-
++ " is still running, waiting for it to complete."
322-
for_ stateChanging $ \testRun -> do
323-
let TestRunId trId = mkTestRunId testRun
327+
++ " in transaction "
328+
++ show txHash
329+
else
330+
loggin
331+
$ "Test-run "
332+
++ trId
333+
++ " is pending from untrusted requester "
334+
++ show user
335+
++ ", waiting for it to start running."
336+
for_ runningTests $ \(Fact testRun _) -> do
337+
let TestRunId trId = mkTestRunId testRun
338+
sameKey = (== testRun) . description
339+
case find sameKey results of
340+
Just _ -> pure ()
341+
Nothing ->
342+
loggin
343+
$ "Test-run "
344+
++ trId
345+
++ " is still running, waiting for it to complete."
346+
for_ stateChanging $ \testRun -> do
347+
let TestRunId trId = mkTestRunId testRun
348+
loggin
349+
$ "Test-run "
350+
++ trId
351+
++ " is changing state (pending->running or running->done), waiting for it to settle."
324352
loggin
325-
$ "Test-run "
326-
++ trId
327-
++ " is changing state (pending->running or running->done), waiting for it to settle."
328-
loggin
329-
$ "Sleeping for "
330-
++ show poPollIntervalSeconds
331-
++ " seconds..."
332-
liftIO $ threadDelay (poPollIntervalSeconds * 1000000)
353+
$ "Sleeping for "
354+
++ show poPollIntervalSeconds
355+
++ " seconds..."
356+
liftIO $ threadDelay (poPollIntervalSeconds * 1000000)
333357

334358
loggin :: MonadIO m => String -> m ()
335359
loggin = liftIO . putStrLn

0 commit comments

Comments
 (0)