test/test-scheduler.sgl

1(import (sigil test)

2 (sigil sqlite)

3 (sigil fs)

4 (kiln db)

5 (kiln scheduler)

6 ;; For the fail-fast group: these tests compile a REAL .kiln file

7 ;; and schedule its plan, rather than hand-writing `plan_form`

8 ;; strings. A hand-written plan_form would let the sweep pass while

9 ;; `fail-fast:` never actually reached the stored datum -- the gate

10 ;; would be measuring a fixture instead of the shipped path

11 ;; (grammar -> plan -> plan_form -> scheduler).

12 (sigil core)

13 (sigil string)

14 (kiln nodeexec)

15 (kiln lang errors)

16 (kiln lang lint))

18;; ============================================================

19;; Helpers

20;; ============================================================

22(define test-jobs-dir #f)

24(define (make-test-env)

25 (let ((db (sqlite-open ":memory:"))

26 (dir (make-temp-directory)))

27 (init-database! db)

28 (set! test-jobs-dir dir)

29 ;; Create a repo

30 (db-create-repo! db "codeberg/daviwil/sigil"

31 "https://codeberg.org/daviwil/sigil.git"

32 "whsec_test")

33 db))

35(define (write-job-script! name content)

36 (write-file-string (string-append test-jobs-dir "/" name) content))

38;; ============================================================

39;; Run Scheduling

40;; ============================================================

42(test-group "schedule-runs!"

43 (test "creates runs for all jobs watching a repo"

44 (let ((db (make-test-env)))

45 (db-create-job! db "sigil-linux" "codeberg/daviwil/sigil" "main")

46 (db-create-job! db "sigil-openbsd" "codeberg/daviwil/sigil" "main")

47 (write-job-script! "sigil-linux.run" "#!/bin/sh\necho test\n")

48 (write-job-script! "sigil-openbsd.run" "#!/bin/sh\necho test\n")

50 (let ((ids (schedule-runs! db test-jobs-dir

51 "codeberg/daviwil/sigil"

52 "refs/heads/main" "sha-abc"

53 'push #f #f)))

54 (assert-equal 2 (length ids))

55 ;; Both should be pending

56 (let ((r1 (db-get-run db (car ids)))

57 (r2 (db-get-run db (cadr ids))))

58 (assert-equal "pending" (assoc-ref 'status r1))

59 (assert-equal "pending" (assoc-ref 'status r2))))

60 (sqlite-close db)))

62 (test "jobs with after dependencies get waiting status"

63 (let ((db (make-test-env)))

64 (db-create-job! db "sigil-linux" "codeberg/daviwil/sigil" "main")

65 (db-create-job! db "sigil-release" "codeberg/daviwil/sigil" "main")

66 (write-job-script! "sigil-linux.run" "#!/bin/sh\necho build\n")

67 (write-job-script! "sigil-release.run"

68 (string-append "#!/bin/sh\n"

69 "#kiln: after sigil-linux\n"

70 "echo release\n"))

72 (let ((ids (schedule-runs! db test-jobs-dir

73 "codeberg/daviwil/sigil"

74 "refs/heads/main" "sha-def"

75 'push #f #f)))

76 (assert-equal 2 (length ids))

77 ;; Find the release run - it should be waiting

78 (let loop ((ids ids))

79 (when (pair? ids)

80 (let ((run (db-get-run db (car ids))))

81 (if (string=? "sigil-release" (assoc-ref 'job_name run))

82 (assert-equal "waiting" (assoc-ref 'status run))

83 (assert-equal "pending" (assoc-ref 'status run))))

84 (loop (cdr ids)))))

85 (sqlite-close db)))

87 (test "fork PRs create untrusted runs"

88 (let ((db (make-test-env)))

89 (db-create-job! db "sigil-linux" "codeberg/daviwil/sigil" "main")

90 (write-job-script! "sigil-linux.run" "#!/bin/sh\necho test\n")

92 (let* ((ids (schedule-runs! db test-jobs-dir

93 "codeberg/daviwil/sigil"

94 "refs/pull/42/head" "pr-sha"

95 'pull-request #t 42))

96 (run (db-get-run db (car ids))))

97 (assert-equal 0 (assoc-ref 'trusted run))

98 (assert-equal "pull-request" (assoc-ref 'trigger_type run))

99 (assert-equal 42 (assoc-ref 'pr_number run)))

100 (sqlite-close db)))

101

102 (test "push creates trusted runs"

103 (let ((db (make-test-env)))

104 (db-create-job! db "sigil-linux" "codeberg/daviwil/sigil" "main")

105 (write-job-script! "sigil-linux.run" "#!/bin/sh\necho test\n")

106

107 (let* ((ids (schedule-runs! db test-jobs-dir

108 "codeberg/daviwil/sigil"

109 "refs/heads/main" "push-sha"

110 'push #f #f))

111 (run (db-get-run db (car ids))))

112 (assert-equal 1 (assoc-ref 'trusted run)))

113 (sqlite-close db)))

114

115 (test "increments run numbers per job"

116 (let ((db (make-test-env)))

117 (db-create-job! db "sigil-linux" "codeberg/daviwil/sigil" "main")

118 (write-job-script! "sigil-linux.run" "#!/bin/sh\necho test\n")

119

120 (schedule-runs! db test-jobs-dir "codeberg/daviwil/sigil"

121 "refs/heads/main" "sha-1" 'push #f #f)

122 (schedule-runs! db test-jobs-dir "codeberg/daviwil/sigil"

123 "refs/heads/main" "sha-2" 'push #f #f)

124

125 (let ((runs (db-list-runs db '(job . "sigil-linux"))))

126 (assert-equal 2 (length runs))

127 ;; Most recent first (ORDER BY id DESC)

128 (assert-equal 2 (assoc-ref 'number (car runs)))

129 (assert-equal 1 (assoc-ref 'number (cadr runs))))

130 (sqlite-close db))))

131

132;; ============================================================

133;; Fan-In

134;; ============================================================

135

136(test-group "check-fan-in!"

137 (test "transitions waiting to pending when all predecessors pass"

138 (let ((db (make-test-env)))

139 (db-create-job! db "build-linux" "codeberg/daviwil/sigil" "main")

140 (db-create-job! db "build-arm" "codeberg/daviwil/sigil" "main")

141 (db-create-job! db "release" "codeberg/daviwil/sigil" "main")

142 (write-job-script! "build-linux.run" "#!/bin/sh\necho build\n")

143 (write-job-script! "build-arm.run" "#!/bin/sh\necho build\n")

144 (write-job-script! "release.run"

145 (string-append "#!/bin/sh\n"

146 "#kiln: after build-linux build-arm\n"

147 "echo release\n"))

148

149 ;; Schedule all runs

150 (let ((ids (schedule-runs! db test-jobs-dir

151 "codeberg/daviwil/sigil"

152 "refs/heads/main" "sha-fan"

153 'push #f #f)))

154 ;; Mark both builds as passed

155 (for-each

156 (lambda (id)

157 (let ((run (db-get-run db id)))

158 (when (not (string=? "release" (assoc-ref 'job_name run)))

159 (db-update-run-status! db id "passed"))))

160 ids)

161

162 ;; Check fan-in

163 (let ((newly-pending (check-fan-in! db test-jobs-dir "sha-fan")))

164 (assert-equal 1 (length newly-pending))

165 ;; The release run should now be pending

166 (let ((release-run (db-get-run db (car newly-pending))))

167 (assert-equal "pending" (assoc-ref 'status release-run))

168 (assert-equal "release" (assoc-ref 'job_name release-run)))))

169 (sqlite-close db)))

170

171 (test "transitions waiting to skipped when predecessor fails"

172 (let ((db (make-test-env)))

173 (db-create-job! db "build-linux" "codeberg/daviwil/sigil" "main")

174 (db-create-job! db "release" "codeberg/daviwil/sigil" "main")

175 (write-job-script! "build-linux.run" "#!/bin/sh\necho build\n")

176 (write-job-script! "release.run"

177 (string-append "#!/bin/sh\n"

178 "#kiln: after build-linux\n"

179 "echo release\n"))

180

181 (let ((ids (schedule-runs! db test-jobs-dir

182 "codeberg/daviwil/sigil"

183 "refs/heads/main" "sha-fail"

184 'push #f #f)))

185 ;; Mark build as failed

186 (for-each

187 (lambda (id)

188 (let ((run (db-get-run db id)))

189 (when (string=? "build-linux" (assoc-ref 'job_name run))

190 (db-update-run-status! db id "failed"))))

191 ids)

192

193 ;; Check fan-in

194 (let ((newly-pending (check-fan-in! db test-jobs-dir "sha-fail")))

195 (assert-equal 0 (length newly-pending))

196 ;; The release run should be skipped

197 (let ((waiting (db-waiting-runs-for-job db "sha-fail")))

198 (assert-equal 0 (length waiting)))))

199 (sqlite-close db)))

200

201 (test "stays waiting when predecessors still running"

202 (let ((db (make-test-env)))

203 (db-create-job! db "build-linux" "codeberg/daviwil/sigil" "main")

204 (db-create-job! db "build-arm" "codeberg/daviwil/sigil" "main")

205 (db-create-job! db "release" "codeberg/daviwil/sigil" "main")

206 (write-job-script! "build-linux.run" "#!/bin/sh\necho build\n")

207 (write-job-script! "build-arm.run" "#!/bin/sh\necho build\n")

208 (write-job-script! "release.run"

209 (string-append "#!/bin/sh\n"

210 "#kiln: after build-linux build-arm\n"

211 "echo release\n"))

212

213 (let ((ids (schedule-runs! db test-jobs-dir

214 "codeberg/daviwil/sigil"

215 "refs/heads/main" "sha-partial"

216 'push #f #f)))

217 ;; Only mark one build as passed

218 (for-each

219 (lambda (id)

220 (let ((run (db-get-run db id)))

221 (when (string=? "build-linux" (assoc-ref 'job_name run))

222 (db-update-run-status! db id "passed"))))

223 ids)

224

225 ;; Check fan-in - should not transition

226 (let ((newly-pending (check-fan-in! db test-jobs-dir "sha-partial")))

227 (assert-equal 0 (length newly-pending))

228 ;; Release should still be waiting

229 (let ((waiting (db-waiting-runs-for-job db "sha-partial")))

230 (assert-equal 1 (length waiting)))))

231 (sqlite-close db))))

232

233;; ============================================================

234;; Queue Management

235;; ============================================================

236

237(test-group "dequeue-run"

238 (test "returns next pending run"

239 (let ((db (make-test-env)))

240 (db-create-job! db "sigil-linux" "codeberg/daviwil/sigil" "main")

241 (write-job-script! "sigil-linux.run" "#!/bin/sh\necho test\n")

242

243 (schedule-runs! db test-jobs-dir "codeberg/daviwil/sigil"

244 "refs/heads/main" "sha-q" 'push #f #f)

245

246 (let ((run (dequeue-run db 3)))

247 (assert-true (pair? run))

248 ;; The RECORD is the row as it was selected, so it still reads

249 ;; "pending". The DATABASE does not -- see the claim test below.

250 (assert-equal "pending" (assoc-ref 'status run))

251 (assert-equal "sigil-linux" (assoc-ref 'job_name run)))

252 (sqlite-close db)))

253

254 ;; THE REGRESSION TEST FOR THE DISPATCH RACE.

255 ;;

256 ;; Before `dequeue-run` claimed, this second call returned the SAME run: the

257 ;; row stayed `pending` until the goroutine the dispatcher spawned got round

258 ;; to writing `starting`, and under write-lock contention that write suspends

259 ;; the fiber and lets the drain loop dispatch the row again -- 66 times for

260 ;; one run in the measurement that found this, ending with a dead controller.

261 ;;

262 ;; It is written as "the second call must not hand back the first run"

263 ;; rather than "the row is now starting", because the second call is what the

264 ;; drain loop actually does and what actually went wrong.

265 (test "claims the run, so a second dequeue cannot return it"

266 (let ((db (make-test-env)))

267 (db-create-job! db "sigil-linux" "codeberg/daviwil/sigil" "main")

268 (write-job-script! "sigil-linux.run" "#!/bin/sh\necho test\n")

269

270 (schedule-runs! db test-jobs-dir "codeberg/daviwil/sigil"

271 "refs/heads/main" "sha-claim" 'push #f #f)

272

273 (let ((first (dequeue-run db 3)))

274 (assert-true (pair? first))

275 ;; With max-concurrent 3 the concurrency cap is nowhere near binding on

276 ;; one run, so a #f here is the claim talking and nothing else.

277 (assert-false (dequeue-run db 3)))

278 (sqlite-close db)))

279

280 ;; SPLIT FROM THE TEST ABOVE ON PURPOSE. The framework reports one assertion

281 ;; failure per test, so folding these in with the second-dequeue assertion

282 ;; meant a break in the product always blamed the second dequeue and hid

283 ;; whether the row had moved at all. Two tests, two diagnoses.

284 (test "the claim is visible in the database, with started_at stamped"

285 (let ((db (make-test-env)))

286 (db-create-job! db "sigil-linux" "codeberg/daviwil/sigil" "main")

287 (write-job-script! "sigil-linux.run" "#!/bin/sh\necho test\n")

288

289 (schedule-runs! db test-jobs-dir "codeberg/daviwil/sigil"

290 "refs/heads/main" "sha-claim2" 'push #f #f)

291

292 (let* ((first (dequeue-run db 3))

293 (row (db-get-run db (assoc-ref 'id first))))

294 (assert-equal "starting" (assoc-ref 'status row))

295 (assert-true (string? (assoc-ref 'started_at row))))

296 (sqlite-close db)))

297

298 (test "returns #f when at concurrency limit"

299 (let ((db (make-test-env)))

300 (db-create-job! db "sigil-linux" "codeberg/daviwil/sigil" "main")

301 (write-job-script! "sigil-linux.run" "#!/bin/sh\necho test\n")

302

303 ;; Create a pending run

304 (schedule-runs! db test-jobs-dir "codeberg/daviwil/sigil"

305 "refs/heads/main" "sha-limit" 'push #f #f)

306 ;; Mark it as running

307 (let ((run (dequeue-run db 3)))

308 (db-update-run-status! db (assoc-ref 'id run) "running"))

309

310 ;; Create another pending run

311 (schedule-runs! db test-jobs-dir "codeberg/daviwil/sigil"

312 "refs/heads/main" "sha-limit2" 'push #f #f)

313

314 ;; With max_concurrent=1, should not dequeue

315 (assert-false (dequeue-run db 1))

316 ;; With max_concurrent=3, should dequeue

317 (assert-true (pair? (dequeue-run db 3)))

318 (sqlite-close db)))

319

320 (test "returns #f when no pending runs"

321 (let ((db (make-test-env)))

322 (assert-false (dequeue-run db 3))

323 (sqlite-close db))))

324

325(test-group "count-active-runs"

326 (test "counts running jobs"

327 (let ((db (make-test-env)))

328 (assert-equal 0 (count-active-runs db))

329 (db-create-job! db "sigil-linux" "codeberg/daviwil/sigil" "main")

330 (let ((id (db-create-run! db "sigil-linux" 1 "ref" "sha"

331 "running" #t 'push)))

332 (assert-equal 1 (count-active-runs db)))

333 (sqlite-close db))))

334

335;; ============================================================

336;; fail-fast sibling cancellation

337;; ============================================================

338;;

339;; THESE TESTS COMPILE A REAL .kiln FILE AND SCHEDULE ITS PLAN. That is

340;; deliberate and it is the difference between a gate and a fixture. The

341;; sweep reads `fail-fast` back out of `runs.plan_form`, so a hand-written

342;; plan_form string would let every assertion below pass while the key

343;; never left the grammar -- the whole path (job-keys -> job record ->

344;; plan-node -> build-node-plan-form -> pf-fail-fast) would be untested by

345;; the tests that appear to cover it.

346;;

347;; `test-jobs/k2b-failfast.kiln` holds TWO fan-out jobs, only `alpha`

348;; carrying `fail-fast:`, because a GROUP-WIDE sweep passes every other

349;; assertion in this group and fails only the per-job one.

350

351(define (failfast-plan path)

352 (let* ((sink (make-diag-sink))

353 (plans (compile-file-plans path sink)))

354 (if (diags-have-errors? sink)

355 #f

356 (car (filter (lambda (x) x) plans)))))

357

358(define (failfast-group db path sha)

359 (car (schedule-plan-group! db (failfast-plan path)

360 "local/test/test" "refs/heads/main" sha 'manual #t)))

361

362(define (group-db)

363 (let ((db (sqlite-open ":memory:")))

364 (init-database! db)

365 db))

366

367(define (nstatus db gid node-id)

368 (let ((r (db-group-node-run db gid node-id)))

369 (and r (assoc-ref 'status r))))

370

371(define (nid db gid node-id)

372 (assoc-ref 'id (db-group-node-run db gid node-id)))

373

374;; Drive one cell to a terminal status the way the runner does, then let

375;; the scheduler react. Every test below fails a cell through this, so

376;; none of them can accidentally cancel siblings by writing 'cancelled'

377;; itself.

378(define (fail-cell! db gid node-id)

379 (db-update-run-status! db (nid db gid node-id) "failed")

380 (advance-group! db gid))

381

382(test-group "fail-fast sibling cancellation"

383

384 ;; The plan compiles at all, and the key survives into the STORED form.

385 ;; Asserted separately from behaviour: if this breaks, every test below

386 ;; fails for a reason that has nothing to do with the sweep.

387 (test "fail-fast reaches runs.plan_form for the declaring job only"

388 (let* ((db (group-db))

389 (gid (failfast-group db "test-jobs/k2b-failfast.kiln" "ff-form")))

390 (assert-true

391 (pf-fail-fast (parse-node-plan-form

392 (assoc-ref 'plan_form

393 (db-group-node-run db gid "alpha[target=a1]")))))

394 (assert-false

395 (pf-fail-fast (parse-node-plan-form

396 (assoc-ref 'plan_form

397 (db-group-node-run db gid "beta[target=b1]")))))

398 (sqlite-close db)))

399

400 (test "a red cell cancels its own job's still-pending siblings"

401 (let* ((db (group-db))

402 (gid (failfast-group db "test-jobs/k2b-failfast.kiln" "ff-basic")))

403 (assert-equal "pending" (nstatus db gid "alpha[target=a2]"))

404 (fail-cell! db gid "alpha[target=a1]")

405 (assert-equal "cancelled" (nstatus db gid "alpha[target=a2]"))

406 (assert-equal "cancelled" (nstatus db gid "alpha[target=a3]"))

407 (sqlite-close db)))

408

409 ;; The failed cell itself must keep its own verdict. A sweep that took

410 ;; every row of the job would overwrite `failed` with `cancelled` and

411 ;; erase the only evidence of what went wrong.

412 (test "the cell that failed keeps its failed status"

413 (let* ((db (group-db))

414 (gid (failfast-group db "test-jobs/k2b-failfast.kiln" "ff-self")))

415 (fail-cell! db gid "alpha[target=a1]")

416 (assert-equal "failed" (nstatus db gid "alpha[target=a1]"))

417 (sqlite-close db)))

418

419 ;; RULE 2, THE RULING. A group-wide sweep passes every other test in

420 ;; this file and fails exactly this one.

421 ;;

422 ;; EVERY ASSERTION HERE IS AN ABSENCE, so the sweep is shown to have

423 ;; RUN before beta's survival is allowed to mean anything. Without that

424 ;; control the test passes against a deleted sweep, a fixture that

425 ;; failed to load, and an implementation that cancels nothing at all.

426 (test "PER-JOB SCOPE: another job's pending cells are untouched"

427 (let* ((db (group-db))

428 (gid (failfast-group db "test-jobs/k2b-failfast.kiln" "ff-scope")))

429 (fail-cell! db gid "alpha[target=a1]")

430 ;; positive control: the sweep is live on this call...

431 (assert-equal "cancelled" (nstatus db gid "alpha[target=a2]"))

432 ;; ...and it did not reach past its own job.

433 (assert-equal "pending" (nstatus db gid "beta[target=b1]"))

434 (assert-equal "pending" (nstatus db gid "beta[target=b2]"))

435 (sqlite-close db)))

436

437 ;; RULE 1. `gamma` carries fail-fast WITHOUT allow-failure and is the

438 ;; positive control: failing one of its cells in the same advance

439 ;; proves the sweep is live in this database, so alpha's siblings

440 ;; surviving means allow-failure SUPPRESSED it rather than nothing

441 ;; having happened.

442 (test "allow-failure: #t suppresses the sweep entirely"

443 (let* ((db (group-db))

444 (gid (failfast-group db "test-jobs/k2b-failfast-allow.kiln" "ff-allow")))

445 (db-update-run-status! db (nid db gid "gamma[target=g1]") "failed")

446 (fail-cell! db gid "alpha[target=a1]")

447 ;; positive control: an unexcused fail-fast job IS swept here.

448 (assert-equal "cancelled" (nstatus db gid "gamma[target=g2]"))

449 ;; the assertion under test.

450 (assert-equal "pending" (nstatus db gid "alpha[target=a2]"))

451 (assert-equal "pending" (nstatus db gid "alpha[target=a3]"))

452 (sqlite-close db)))

453

454 ;; THE DEFAULT IS OFF AND MUST STAY OFF. `beta` declares no fail-fast,

455 ;; so a red beta cell cancels nothing -- not its own siblings and not

456 ;; alpha's. `alpha` is failed in the same advance as the positive

457 ;; control, for the same reason as the two tests above.

458 (test "without fail-fast: a red cell cancels nothing"

459 (let* ((db (group-db))

460 (gid (failfast-group db "test-jobs/k2b-failfast.kiln" "ff-default")))

461 (db-update-run-status! db (nid db gid "alpha[target=a1]") "failed")

462 (fail-cell! db gid "beta[target=b1]")

463 ;; positive control: a job that DOES declare fail-fast is swept on

464 ;; this very call.

465 (assert-equal "cancelled" (nstatus db gid "alpha[target=a2]"))

466 ;; beta declares none, so its own siblings survive.

467 (assert-equal "pending" (nstatus db gid "beta[target=b2]"))

468 (sqlite-close db)))

469

470 ;; A cell already executing is NOT cancelled: it holds a worker lease,

471 ;; and cancelling its row would leave that worker running a job whose

472 ;; row says it stopped.

473 (test "a running sibling is left alone"

474 (let* ((db (group-db))

475 (gid (failfast-group db "test-jobs/k2b-failfast.kiln" "ff-running")))

476 (db-update-run-status! db (nid db gid "alpha[target=a2]") "running")

477 (fail-cell! db gid "alpha[target=a1]")

478 (assert-equal "running" (nstatus db gid "alpha[target=a2]"))

479 ;; ...while the one that had NOT started is swept. Without this the

480 ;; test passes on an implementation that cancels nothing at all.

481 (assert-equal "cancelled" (nstatus db gid "alpha[target=a3]"))

482 (sqlite-close db)))

483

484 ;; RULE 3, DRIVEN THROUGH THE REAL `dequeue-run` RATHER THAN A MOCK.

485 ;; Claim-wins: a sibling claimed into `starting` between candidate-scan

486 ;; and the sweep survives it, so no worker is left executing a run whose

487 ;; row reads `cancelled`.

488 (test "CLAIM RACE: a sibling claimed by dequeue-run survives the sweep"

489 (let* ((db (group-db))

490 (gid (failfast-group db "test-jobs/k2b-failfast.kiln" "ff-claim")))

491 ;; Two dequeues, the way the drain loop makes them: the first claims

492 ;; a1, the second claims a2. Both are `starting` before anything

493 ;; fails, which is the state the race is actually about.

494 (let* ((first (dequeue-run db 5))

495 (second (dequeue-run db 5)))

496 ;; Assert WHICH cells were claimed rather than assuming the queue

497 ;; order. If dequeue order ever changes, this says so instead of

498 ;; quietly testing a different pair of runs.

499 (assert-equal "alpha[target=a1]" (assoc-ref 'node_id first))

500 (assert-equal "alpha[target=a2]" (assoc-ref 'node_id second))

501 (let ((in-flight (assoc-ref 'id second)))

502 (assert-equal "starting" (assoc-ref 'status (db-get-run db in-flight)))

503 ;; a1 -- already claimed -- now fails, exactly as its runner

504 ;; would report it.

505 (fail-cell! db gid "alpha[target=a1]")

506 ;; The sibling still executing keeps its claim and its worker.

507 (assert-equal "starting" (assoc-ref 'status (db-get-run db in-flight)))

508 ;; ...and the one never claimed is swept. Without this the test

509 ;; passes on an implementation that cancels nothing at all.

510 (assert-equal "cancelled" (nstatus db gid "alpha[target=a3]"))))

511 (sqlite-close db)))

512

513 ;; Sweep-wins, the other half of the same window: a cancelled sibling is

514 ;; no longer claimable, so nothing is dispatched for it and nothing ever

515 ;; acquires a lease on its behalf.

516 (test "CLAIM RACE: a swept sibling can no longer be dequeued"

517 (let* ((db (group-db))

518 (gid (failfast-group db "test-jobs/k2b-failfast.kiln" "ff-claim2")))

519 (fail-cell! db gid "alpha[target=a1]")

520 (assert-false (db-claim-pending-run! db (nid db gid "alpha[target=a2]")))

521 ;; Positive control for the assertion above: the claim primitive is

522 ;; working, it is the CANCELLATION that refused it. Without this, a

523 ;; db-claim-pending-run! that returned #f unconditionally would pass.

524 (assert-true (db-claim-pending-run! db (nid db gid "beta[target=b1]")))

525 (sqlite-close db)))

526

527 ;; A cancelled cell never executed, so it never posted a forge commit

528 ;; status and never held a lease -- `report-commit-status!` is only

529 ;; reached from the execute path. `started_at` is the artifact property

530 ;; that says so, rather than the absence of an HTTP call nobody watched.

531 ;;

532 ;; THE CONTROL IS THE TEST HERE. Adversarial review pointed out that

533 ;; asserting NULL `started_at` on a swept cell is tautological on its

534 ;; own: the sweep writes only `status` and `finished_at`, so the column

535 ;; is NULL by construction AND equally NULL on a do-nothing sweep. What

536 ;; makes the assertion mean something is showing, in the same group,

537 ;; that `started_at` is a column which DOES get set on a run that was

538 ;; dispatched -- so NULL is evidence of never-dispatched rather than

539 ;; evidence that nothing ever writes it.

540 (test "swept siblings never started, while a dispatched run does"

541 (let* ((db (group-db))

542 (gid (failfast-group db "test-jobs/k2b-failfast.kiln" "ff-nostart")))

543 ;; Dispatch one cell for real, through the queue.

544 (let ((claimed (dequeue-run db 5)))

545 (assert-true (pair? claimed))

546 ;; positive control: the column can be non-NULL.

547 (assert-true (string? (assoc-ref 'started_at

548 (db-get-run db (assoc-ref 'id claimed))))))

549 (fail-cell! db gid "alpha[target=a1]")

550 (assert-equal "cancelled" (nstatus db gid "alpha[target=a3]"))

551 (assert-false (assoc-ref 'started_at

552 (db-get-run db (nid db gid "alpha[target=a3]"))))

553 (sqlite-close db)))

554

555 ;; THE ORDERING ARM. `late` needs ONE cell -- `(alpha target: "a3")` --

556 ;; so its only predecessor is a cell that becomes terminal solely

557 ;; BECAUSE the sweep cancelled it.

558 ;;

559 ;; `gather` cannot test this and used to be claimed to: it needs the

560 ;; whole of alpha, so an edge runs from the failed cell to it and it is

561 ;; skipped by that cell's own failure whether the sweep ran or not.

562 ;; Sweep AFTER the fixpoint instead of before and `late` is stranded

563 ;; `waiting` forever -- a group with nothing runnable never triggers

564 ;; another advance. Found by adversarial review.

565 (test "ORDERING: a dependent of only a SWEPT cell is skipped, not stranded"

566 (let* ((db (group-db))

567 (gid (failfast-group db "test-jobs/k2b-failfast.kiln" "ff-order")))

568 (assert-equal "waiting" (nstatus db gid "late"))

569 (fail-cell! db gid "alpha[target=a1]")

570 (assert-equal "cancelled" (nstatus db gid "alpha[target=a3]"))

571 (assert-equal "skipped" (nstatus db gid "late"))

572 (sqlite-close db)))

573

574 ;; REGRESSION, HIGH, found by adversarial review and confirmed by probe.

575 ;;

576 ;; An undecidable `when:` clause lands a node in `errored`, NOT

577 ;; `skipped` -- and `errored` is a fail-fast trigger. Worse, the

578 ;; scheduler force-clears `allow-failure` on exactly those nodes, so

579 ;; `bad?` was unconditionally true there and the job's own

580 ;; `allow-failure: #t` could not suppress it. Two cells whose own gates

581 ;; said RUN were cancelled before their shared predecessor was even

582 ;; dequeued.

583 ;;

584 ;; Fixed by clearing `fail-fast` alongside `allow-failure` in

585 ;; `build-node-plan-form` when the gate could not be decided: neither

586 ;; key is a declaration about kiln failing to decide whether the job

587 ;; should run.

588 (test "an UNDECIDABLE when: gate does not cancel its decidable siblings"

589 (let* ((db (group-db))

590 (gid (failfast-group db "test-jobs/k2b-failfast-undecidable.kiln"

591 "ff-undec")))

592 ;; The mixed case really was produced: one cell errored at

593 ;; scheduling, and it is the one whose binding is not a ref string.

594 (assert-equal "errored" (nstatus db gid "alpha[target=main]"))

595 ;; The cells whose gate opened must still be waiting on `prep`.

596 (assert-equal "waiting" (nstatus db gid "alpha[target=refs/heads/main]"))

597 (assert-equal "waiting" (nstatus db gid "alpha[target=refs/heads/dev]"))

598 ;; And `prep` itself, which had not run, is untouched.

599 (assert-equal "pending" (nstatus db gid "prep"))

600 (sqlite-close db)))

601

602 ;; The other half of the same fix: `fail-fast` must be ABSENT from the

603 ;; stored form of a gate-errored node, and PRESENT on its siblings.

604 ;; Asserted on the artifact the scheduler actually reads, so this fails

605 ;; if the clearing is ever moved to a consumer and missed by one.

606 (test "an undecidable gate clears fail-fast in the STORED plan form"

607 (let* ((db (group-db))

608 (gid (failfast-group db "test-jobs/k2b-failfast-undecidable.kiln"

609 "ff-undec2"))

610 (pf-of (lambda (n) (parse-node-plan-form

611 (assoc-ref 'plan_form

612 (db-group-node-run db gid n))))))

613 (assert-false (pf-fail-fast (pf-of "alpha[target=main]")))

614 ;; positive control: the key IS set on the cells kiln could decide,

615 ;; so the #f above is the clearing and not a serialisation failure.

616 (assert-true (pf-fail-fast (pf-of "alpha[target=refs/heads/main]")))

617 (sqlite-close db)))

618

619 ;; `cancelled` is written by three unrelated mechanisms and reads as one

620 ;; word on the run page. The swept cell has to say which one it was.

621 (test "a swept cell's log says fail-fast cancelled it, and names the trigger"

622 (let* ((db (group-db))

623 (gid (failfast-group db "test-jobs/k2b-failfast.kiln" "ff-log"))

624 (trigger-id (nid db gid "alpha[target=a1]")))

625 (fail-cell! db gid "alpha[target=a1]")

626 (let ((log (apply string-append

627 (map (lambda (r) (string-append (assoc-ref 'line r) "\n"))

628 (db-get-logs db (nid db gid "alpha[target=a2]"))))))

629 (assert-true (and (string-find log "fail-fast") #t))

630 ;; It must name the SIBLING that caused it, not just the policy.

631 (assert-true (and (string-find log "alpha[target=a1]") #t))

632 (assert-true (and (string-find log (number->string trigger-id)) #t)))

633 (sqlite-close db)))

634

635 ;; The sweep needs no code for dependents: `gather` needs alpha, and the

636 ;; existing cancelled -> skipped cascade in `predecessor-verdict` stops

637 ;; it. Asserted in ONE advance call, because a group with nothing

638 ;; runnable never triggers another one.

639 (test "dependents of the swept fan-out are skipped in the SAME advance"

640 (let* ((db (group-db))

641 (gid (failfast-group db "test-jobs/k2b-failfast.kiln" "ff-deps")))

642 (assert-equal "waiting" (nstatus db gid "gather"))

643 (fail-cell! db gid "alpha[target=a1]")

644 (assert-equal "skipped" (nstatus db gid "gather"))

645 (sqlite-close db)))

646

647 ;; The vacuous-case guard in update-group-aggregate! must not regress: a

648 ;; group holding a real failure is `failed`, never `skipped` (nothing

649 ;; ran) and never `passed`.

650 (test "group aggregate after a sweep is failed, not skipped or passed"

651 (let* ((db (group-db))

652 (gid (failfast-group db "test-jobs/k2b-failfast.kiln" "ff-agg")))

653 ;; Drive the untouched job to terminal so the group is fully decided;

654 ;; otherwise the aggregate is legitimately still "pending" and the

655 ;; assertion would be about the wrong thing.

656 (db-update-run-status! db (nid db gid "beta[target=b1]") "passed")

657 (db-update-run-status! db (nid db gid "beta[target=b2]") "passed")

658 (fail-cell! db gid "alpha[target=a1]")

659 (assert-true (group-terminal? db gid))

660 (assert-equal "failed" (assoc-ref 'status (db-get-group db gid)))

661 (sqlite-close db)))

662

663 ;; `advance-group!` is called on every terminal transition and its

664 ;; contract is idempotence. A second sweep must find nothing left to do

665 ;; rather than, say, re-cancelling a cell that has since been retried.

666 (test "the sweep is idempotent across repeated advances"

667 (let* ((db (group-db))

668 (gid (failfast-group db "test-jobs/k2b-failfast.kiln" "ff-idem")))

669 (fail-cell! db gid "alpha[target=a1]")

670 (advance-group! db gid)

671 (advance-group! db gid)

672 (assert-equal "cancelled" (nstatus db gid "alpha[target=a2]"))

673 (assert-equal "failed" (nstatus db gid "alpha[target=a1]"))

674 (assert-equal "pending" (nstatus db gid "beta[target=b1]"))

675 (sqlite-close db))))