test/f3b-probe.sgl

1;;; f3b-probe.sgl -- the in-process arm battery for gate-f3b.sh.

2;;;

3;;; Same harness contract as f3a-txn-probe.sgl: F3B_ARM_<name>_<GREEN|RED>

4;;; markers, F3B_PROBE_DONE arms=N green=N red=N, non-zero exit on any red,

5;;; F3B_PROBE_SELFTEST=1 proves the harness can fail. F3B_ROOT names a

6;;; DISPOSABLE copy of test/fixtures/f3b/. Kill/crash arms live in the gate,

7;;; which owns processes; the recovery-branch arms here CONSTRUCT the crashed

8;;; states through the same manifest API the engine uses, which produces the

9;;; identical bytes a real crash leaves (the gate's kill arms then prove the

10;;; all-or-nothing invariant against real SIGKILL).

11(import (sigil core) (sigil io) (sigil fs) (sigil string) (sigil path)

12 (folio doc revision) (folio doc bounded) (folio doc service)

13 (folio doc manifest) (folio doc coordinator) (folio doc transaction)

14 (folio doc structural))

15

16(define root (or (getenv "F3B_ROOT")

17 (begin (display "F3B_PROBE SETUP-FAILED: F3B_ROOT is not set\n") (exit 3))))

18(define lib-dir (or (getenv "F3B_LIB") "build/dev/lib"))

19(define src-dir (or (getenv "F3B_SRC") "src"))

20(define (rooted name) (path-join root name))

21

22(define greens (list 0))

23(define reds (list 0))

24

25(define (arm name thunk)

26 (guard (e (#t (set-car! reds (+ (car reds) 1))

27 (println "F3B_ARM_~a_RED: raised: ~a" name

28 (if (exception? e) (exception-message e) e))))

29 (thunk)

30 (set-car! greens (+ (car greens) 1))

31 (println "F3B_ARM_~a_GREEN" name)))

32

33(define (assert-true label v)

34 (unless v (error (format "assertion failed: ~a" label))))

35(define (assert-refusal label r reason)

36 (assert-true (format "~a: expected a refusal, got ~a" label r) (txn-refusal? r))

37 (unless (eq? (txn-refusal-reason r) reason)

38 (error (format "~a: expected reason ~a, got ~a: ~a" label reason

39 (txn-refusal-reason r) (txn-refusal-message r)))))

40(define (assert-sop label r)

41 (when (txn-refusal? r)

42 (error (format "~a: refused ~a: ~a" label (txn-refusal-reason r) (txn-refusal-message r))))

43 (assert-true (format "~a: expected a structural result" label) (sop-result? r)))

44(define (assert-txn label r)

45 (when (txn-refusal? r)

46 (error (format "~a: refused ~a: ~a" label (txn-refusal-reason r) (txn-refusal-message r))))

47 (assert-true (format "~a: expected a result" label) (txn-result? r)))

48

49(when (equal? (getenv "F3B_PROBE_SELFTEST") "1")

50 (arm "selftest" (lambda () (assert-true "1 = 2 must fail" (= 1 2))))

51 (println "F3B_PROBE_SELFTEST_DONE red=~a" (car reds))

52 (exit (if (= (car reds) 1) 0 1)))

53

54(define svc (make-service (default-worker-argv lib-dir src-dir) default-limits))

55(define coord (make-coordinator root svc))

56(define bystander-hash (revision-of-file (rooted "bystander.md")))

57

58;; ---------------------------------------------------------------------------

59;; b1-stand-down -- THE control: an ordinary single-file structural insert on

60;; an exact match succeeds, bytes outside the span identical.

61;; ---------------------------------------------------------------------------

62(arm "b1-stand-down"

63 (lambda ()

64 (let* ((pre (read-file-bytes (rooted "owner.sgd")))

65 (r (folio-insert-node! coord (rooted "owner.sgd") "work" 'task

66 (revision-of-file (rooted "owner.sgd"))

67 id: "t-standdown" title: "Inserted by the control"

68 status: 'ready priority: 'low

69 body-text: "The stand-down control's body.")))

70 (assert-txn "uncontended structural insert" r)

71 (let* ((post (read-file-bytes (rooted "owner.sgd")))

72 (start (txn-result-changed-span-start r)))

73 (assert-true "the new task landed"

74 (string-contains? (read-file-string (rooted "owner.sgd")) "t-standdown"))

75 (assert-true "bytes before the splice are untouched"

76 (let loop ((i 0))

77 (or (>= i start)

78 (and (= (bytevector-u8-ref post i) (bytevector-u8-ref pre i))

79 (loop (+ i 1))))))))))

80

81;; ---------------------------------------------------------------------------

82;; b2-structural-mismatch -- F3a's arm must not regress: stale structural

83;; requests refuse, never rebase.

84;; ---------------------------------------------------------------------------

85(arm "b2-structural-mismatch"

86 (lambda ()

87 (let ((stale (revision-of-file (rooted "owner.sgd"))))

88 (write-file-string (rooted "owner.sgd")

89 (string-append (read-file-string (rooted "owner.sgd")) "\n"))

90 (assert-refusal "stale insert"

91 (folio-insert-node! coord (rooted "owner.sgd") "work" 'task stale

92 id: "t-nope" title: "N" status: 'ready)

93 'structural-revision-mismatch)

94 (assert-refusal "stale delete"

95 (folio-delete-node! coord (rooted "owner.sgd") "t-lonely" stale)

96 'structural-revision-mismatch)

97 (assert-refusal "stale rename"

98 (folio-rename-id! coord "t-lonely" "t-fresh" stale)

99 'structural-revision-mismatch)

100 (assert-refusal "stale body edit"

101 (folio-edit-body! coord (rooted "owner.sgd") "t-lonely" "@p{x}" stale)

102 'structural-revision-mismatch))))

103

104;; ---------------------------------------------------------------------------

105;; b3-recovery-completes -- a VALIDATED manifest (constructed through the same

106;; API the engine calls, i.e. the exact bytes a crash leaves after the commit

107;; point) is COMPLETED by the next transaction, and the completion is the

108;; state the interrupted transaction intended -- checked by content.

109;; ---------------------------------------------------------------------------

110(arm "b3-recovery-completes"

111 (lambda ()

112 (let* ((target (rooted "ref-one.sgd"))

113 (pre-rev (revision-of-file target))

114 (post-src (string-replace (read-file-string target)

115 "one site" "one COMPLETED site"))

116 (temp ".folio-staging-ref-one.sgd.b3test")

117 (backup ".folio-backup-ref-one.sgd.b3test"))

118 (write-file-string (rooted temp) post-src)

119 (write-file-bytes (rooted backup) (read-file-bytes target))

120 (let ((post-rev (revision-of-file (rooted temp))))

121 (write-transaction-manifest! root "b3test" "probe-op"

122 (list (mentry "ref-one.sgd" pre-rev temp post-rev post-rev backup pre-rev)))

123 ;; The next transaction must complete it first and report doing so.

124 (let ((r (folio-insert-node! coord (rooted "owner.sgd") "work" 'update

125 (revision-of-file (rooted "owner.sgd"))

126 timestamp: "2026-08-25" id: "u-b3" body-text: "After recovery.")))

127 (assert-txn "the transaction after the crash runs" r)

128 (assert-true "recovery reported the completion"

129 (let loop ((rest (txn-result-recovery-actions r)))

130 (cond ((null? rest) #f)

131 ((string-contains? (car rest) "COMPLETED") #t)

132 (else (loop (cdr rest))))))

133 (assert-true "the completed content is the INTENDED content"

134 (string-contains? (read-file-string target) "one COMPLETED site"))

135 (assert-true "manifest cleared" (not (file-exists? (rooted ".folio-transaction-manifest"))))

136 (assert-true "backup cleared" (not (file-exists? (rooted backup)))))))))

137

138;; ---------------------------------------------------------------------------

139;; b4-recovery-rolls-back -- staged temps and backups WITHOUT a manifest are

140;; pre-commit debris: nothing was ever renamed, and the next transaction

141;; sweeps them and says so. This is the "unvalidated" branch, and the

142;; DISCRIMINATOR is the manifest's absence -- by construction there is no

143;; such thing as an unvalidated manifest on disk.

144;; ---------------------------------------------------------------------------

145(arm "b4-recovery-rolls-back"

146 (lambda ()

147 (let ((victim-rev (revision-of-file (rooted "ref-two.sgd"))))

148 (write-file-string (rooted ".folio-staging-ref-two.sgd.b4") "half-staged content")

149 (write-file-string (rooted ".folio-backup-ref-two.sgd.b4") "backup content")

150 (let ((r (folio-insert-node! coord (rooted "owner.sgd") "work" 'update

151 (revision-of-file (rooted "owner.sgd"))

152 timestamp: "2026-08-25" id: "u-b4" body-text: "After rollback.")))

153 (assert-txn "the transaction after the pre-commit crash runs" r)

154 (assert-true "the rollback was reported"

155 (let loop ((rest (txn-result-recovery-actions r)))

156 (cond ((null? rest) #f)

157 ((string-contains? (car rest) "ROLLED BACK") #t)

158 (else (loop (cdr rest))))))

159 (assert-true "debris swept"

160 (and (not (file-exists? (rooted ".folio-staging-ref-two.sgd.b4")))

161 (not (file-exists? (rooted ".folio-backup-ref-two.sgd.b4")))))

162 (assert-true "the target was never touched"

163 (equal? (revision-of-file (rooted "ref-two.sgd")) victim-rev))))))

164

165;; ---------------------------------------------------------------------------

166;; b5-rename -- N referrers across M files: all rewritten, or none.

167;; ---------------------------------------------------------------------------

168(arm "b5-rename"

169 (lambda ()

170 (let ((r (folio-rename-id! coord "t-target" "t-retargeted"

171 (revision-of-file (rooted "owner.sgd")))))

172 (assert-sop "the 3-file rename publishes" r)

173 (assert-true "three files in the result" (= (length (sop-result-files r)) 3))

174 (let ((all (string-append (read-file-string (rooted "owner.sgd"))

175 (read-file-string (rooted "ref-one.sgd"))

176 (read-file-string (rooted "ref-two.sgd")))))

177 (assert-true "closure: zero old-id residue anywhere"

178 (not (string-contains? all "t-target\"")))

179 (assert-true "the declaration moved"

180 (string-contains? (read-file-string (rooted "owner.sgd")) "@task[\"t-retargeted\""))

181 (assert-true "both ref-two sites moved"

182 (not (string-contains? (read-file-string (rooted "ref-two.sgd")) "t-target"))))

183 (assert-true "no manifest or debris left"

184 (not (file-exists? (rooted ".folio-transaction-manifest")))))))

185

186;; ---------------------------------------------------------------------------

187;; b6-rename-refusals -- each guard with its own reason.

188;; ---------------------------------------------------------------------------

189(arm "b6-rename-refusals"

190 (lambda ()

191 (let ((rev (revision-of-file (rooted "owner.sgd"))))

192 ;; A referrer the semantic parser cannot see IS FOUND by the raw pass.

193 (assert-refusal "raw-only prose referrer refuses the whole rename"

194 (folio-rename-id! coord "t-prosebound" "t-fresh" rev)

195 'unrewritable-reference)

196 (assert-true "the prose file is untouched"

197 (string-contains? (read-file-string (rooted "rawonly.sgd")) "t-prosebound"))

198 ;; Markdown occurrence refuses by policy.

199 (write-file-string (rooted "legacy.md") "# Legacy\nSee t-lonely.\n")

200 (assert-refusal "markdown occurrence refuses"

201 (folio-rename-id! coord "t-lonely" "t-fresh"

202 (revision-of-file (rooted "owner.sgd")))

203 'unrewritable-reference)

204 (delete-file (rooted "legacy.md"))

205 (assert-refusal "taken target refuses"

206 (folio-rename-id! coord "t-lonely" "t-mover"

207 (revision-of-file (rooted "owner.sgd")))

208 'rename-target-taken)

209 (assert-refusal "unknown id refuses"

210 (folio-rename-id! coord "t-nonesuch" "t-fresh"

211 (revision-of-file (rooted "owner.sgd")))

212 'unknown-node)

213 ;; A location the scan could not WALK is a population it cannot prove

214 ;; complete: a symlinked directory inside the root (discovery skips

215 ;; those deliberately) must refuse every root-wide destructive op.

216 (make-symlink (path-dirname (rooted "owner.sgd")) (rooted "esc-dir"))

217 (assert-refusal "an unwalkable location refuses the rename"

218 (folio-rename-id! coord "t-lonely" "t-fresh"

219 (revision-of-file (rooted "owner.sgd")))

220 'population-unprovable)

221 (delete-file (rooted "esc-dir"))

222 (assert-refusal "delete refuses over the same unprovable population"

223 (begin

224 (make-symlink (path-dirname (rooted "owner.sgd")) (rooted "esc-dir2"))

225 (let ((r (folio-delete-node! coord (rooted "owner.sgd") "t-lonely"

226 (revision-of-file (rooted "owner.sgd")))))

227 (delete-file (rooted "esc-dir2"))

228 r))

229 'population-unprovable))))

230

231;; ---------------------------------------------------------------------------

232;; b7-delete -- the referrer discipline, then the clean path.

233;; ---------------------------------------------------------------------------

234(arm "b7-delete"

235 (lambda ()

236 ;; t-mover is referenced from ref-two.sgd -> refuse.

237 (assert-refusal "deleting a referenced node refuses"

238 (folio-delete-node! coord (rooted "owner.sgd") "t-mover"

239 (revision-of-file (rooted "owner.sgd")))

240 'node-referenced)

241 ;; t-lonely has no referrers -> deletes.

242 (let ((r (folio-delete-node! coord (rooted "owner.sgd") "t-lonely"

243 (revision-of-file (rooted "owner.sgd")))))

244 (assert-txn "unreferenced delete publishes" r)

245 (assert-true "the node is gone"

246 (not (string-contains? (read-file-string (rooted "owner.sgd")) "t-lonely"))))))

247

248;; ---------------------------------------------------------------------------

249;; b8-move -- cross-file with reference re-addressing, all in one manifest

250;; transaction.

251;; ---------------------------------------------------------------------------

252(arm "b8-move"

253 (lambda ()

254 (let ((r (folio-move-node! coord (rooted "owner.sgd") "t-mover"

255 (rooted "dest.sgd") "incoming"

256 (revision-of-file (rooted "owner.sgd"))

257 expected-dest-revision: (revision-of-file (rooted "dest.sgd")))))

258 (assert-sop "the cross-file move publishes" r)

259 (assert-true "source lost it"

260 (not (string-contains? (read-file-string (rooted "owner.sgd")) "t-mover")))

261 (assert-true "dest gained it"

262 (string-contains? (read-file-string (rooted "dest.sgd")) "t-mover"))

263 (assert-true "the referrer was re-addressed to the destination document"

264 (string-contains? (read-file-string (rooted "ref-two.sgd"))

265 "document: \"topics/f3b-dest\" node: \"t-mover\""))

266 (assert-true "no manifest left"

267 (not (file-exists? (rooted ".folio-transaction-manifest")))))))

268

269;; ---------------------------------------------------------------------------

270;; b9-scoped-out -- deliberate walls say so in those words.

271;; ---------------------------------------------------------------------------

272(arm "b9-scoped-out"

273 (lambda ()

274 (let ((r (folio-delete-node! coord (rooted "owner.sgd") "work"

275 (revision-of-file (rooted "owner.sgd")))))

276 (assert-refusal "container delete" r 'scoped-out)

277 (assert-true "the refusal says SCOPED OUT, not unsupported"

278 (string-contains? (txn-refusal-message r) "SCOPED OUT")))

279 (assert-true "container insert raises with the scope ruling"

280 (string? (guard (e (#t (if (exception? e) (exception-message e) "raised")))

281 (folio-insert-node! coord (rooted "owner.sgd") "work" 'phase

282 (revision-of-file (rooted "owner.sgd"))

283 id: "p-x" title: "P" status: 'active)

284 #f)))))

285

286;; ---------------------------------------------------------------------------

287;; b10-invalid-readonly -- structural ops on an invalid document refuse it as

288;; read-only; a malformed document cannot kill the coordinator.

289;; ---------------------------------------------------------------------------

290(arm "b10-invalid-readonly"

291 (lambda ()

292 (let ((r (folio-insert-node! coord (rooted "broken.sgd") "topics/f3a-broken" 'update

293 (revision-of-file (rooted "broken.sgd"))

294 timestamp: "2026-08-25" id: "u-b10a")))

295 (assert-refusal "structural op on an invalid document" r 'document-invalid))

296 ;; The coordinator survives it and the next ordinary op works.

297 (assert-txn "the coordinator is alive after the malformed encounter"

298 (folio-insert-node! coord (rooted "owner.sgd") "work" 'update

299 (revision-of-file (rooted "owner.sgd"))

300 timestamp: "2026-08-25" id: "u-b10b" body-text: "Still alive."))))

301

302;; ---------------------------------------------------------------------------

303;; b11-body-replace -- the Q1 door end to end.

304;; ---------------------------------------------------------------------------

305(arm "b11-body-replace"

306 (lambda ()

307 (let ((r (folio-edit-body! coord (rooted "owner.sgd") "t-prosebound"

308 "\n@p{A replaced prose body.}\n"

309 (revision-of-file (rooted "owner.sgd")))))

310 (assert-txn "prose body replaces on exact match" r)

311 (assert-true "the body landed"

312 (string-contains? (read-file-string (rooted "owner.sgd"))

313 "A replaced prose body.")))))

314

315;; ---------------------------------------------------------------------------

316;; b12-bystander -- the Markdown bystander's hash is pinned across the WHOLE

317;; battery: every arm above ran against this root, and none may have touched

318;; it.

319;; ---------------------------------------------------------------------------

320(arm "b12-bystander"

321 (lambda ()

322 (assert-true "bystander.md untouched by the entire battery"

323 (equal? (revision-of-file (rooted "bystander.md")) bystander-hash))))

324

325;; ---------------------------------------------------------------------------

326;; b13-recovery-containment -- the reviewer's HIGH: a manifest whose target

327;; escapes the root via `..` must REFUSE TO A HUMAN and rename nothing.

328;; Recovery treats the on-disk manifest as UNTRUSTED input.

329;; ---------------------------------------------------------------------------

330(arm "b13-recovery-containment"

331 (lambda ()

332 ;; A private escape root so the outside file is disposable.

333 (let* ((base (path-dirname root))

334 (esc-root (path-join base "b13-esc-root"))

335 (esc-out (path-join base "b13-esc-outside"))

336 (victim (path-join esc-out "victim.sgd")))

337 (unless (directory-exists? esc-root) (make-directory esc-root))

338 (unless (directory-exists? esc-out) (make-directory esc-out))

339 (write-file-bytes victim (read-file-bytes (rooted "ref-one.sgd")))

340 (write-file-string (path-join esc-root ".folio-staging-esc.tmp")

341 "PAYLOAD: recovery wrote outside the locked root\n")

342 (let ((tr (revision-of-file (path-join esc-root ".folio-staging-esc.tmp")))

343 (vr (revision-of-file victim)))

344 (write-file-bytes (path-join esc-root ".folio-backup-esc") (read-file-bytes victim))

345 (write-transaction-manifest! esc-root "b13" "rename-id"

346 (list (mentry "../b13-esc-outside/victim.sgd" vr

347 ".folio-staging-esc.tmp" tr tr ".folio-backup-esc" vr)))

348 (let* ((victim-before (revision-of-file victim))

349 (coord2 (make-coordinator esc-root svc))

350 (raised (guard (e (#t (if (exception? e) (exception-message e) "raised")))

351 (folio-insert-node! coord2 (path-join esc-root "x.sgd") "c"

352

                                             'update "sha256:0000000000000000000000000000000000000000000000000000000000000000"

353 timestamp: "2026-08-25" id: "u-z")

354 #f)))

355 (assert-true "recovery refused the escaping manifest to a human"

356 (and (string? raised) (string-contains? raised "human")))

357 (assert-true "the file outside the root was NOT written"

358 (equal? (revision-of-file victim) victim-before))

359 (assert-true "the manifest is kept for the human"

360 (file-exists? (path-join esc-root ".folio-transaction-manifest"))))))))

361

362;; ---------------------------------------------------------------------------

363;; b14-sweep-depth -- the reviewer's MEDIUM 1: pre-commit debris nested TWO

364;; directories deep is swept by the rollback branch, not left to accumulate.

365;; ---------------------------------------------------------------------------

366(arm "b14-sweep-depth"

367 (lambda ()

368 (let ((d0 (rooted ".folio-staging-b14-d0.tmp"))

369 (d1 (rooted "sub14/.folio-staging-b14-d1.tmp"))

370 (d2 (rooted "sub14/deep14/.folio-backup-b14-d2")))

371 (unless (directory-exists? (rooted "sub14")) (make-directory (rooted "sub14")))

372 (unless (directory-exists? (rooted "sub14/deep14")) (make-directory (rooted "sub14/deep14")))

373 (write-file-string d0 "d0") (write-file-string d1 "d1") (write-file-string d2 "d2")

374 ;; No manifest exists -> the next transaction's recovery rolls back.

375 (let ((r (folio-insert-node! coord (rooted "dest.sgd") "incoming" 'update

376 (revision-of-file (rooted "dest.sgd"))

377 timestamp: "2026-08-25" id: "u-b14")))

378 (assert-txn "the transaction runs" r)

379 (assert-true "depth-0 debris swept" (not (file-exists? d0)))

380 (assert-true "depth-1 debris swept" (not (file-exists? d1)))

381 (assert-true "depth-2 debris swept" (not (file-exists? d2)))))))

382

383;; ---------------------------------------------------------------------------

384;; b15-dot-population -- the reviewer's MEDIUM 2: discovery drops dot-prefixed

385;; names without a census record, so a referrer in a dot-directory is unseen.

386;; The population guard must independently detect the dot-entry and refuse

387;; every root-wide destructive op (delete AND rename) rather than proceed

388;; against a population it cannot prove complete.

389;; ---------------------------------------------------------------------------

390(arm "b15-dot-population"

391 (lambda ()

392 ;; A fresh, unreferenced node so the population guard (not unknown-node or

393 ;; node-referenced) is the reason under test.

394 (assert-txn "seed a fresh target"

395 (folio-insert-node! coord (rooted "owner.sgd") "work" 'task

396 (revision-of-file (rooted "owner.sgd"))

397 id: "t-b15" title: "Guard subject" status: 'ready))

398 (unless (directory-exists? (rooted ".hidden15")) (make-directory (rooted ".hidden15")))

399 (write-file-string (rooted ".hidden15/note.sgd")

400 "#lang folio/doc\n@note[\"topics/h15\" title: \"H\"]\n@p{prose only, no referrer}\n@end note\n")

401 (assert-refusal "delete refuses over a dot-directory population"

402 (folio-delete-node! coord (rooted "owner.sgd") "t-b15"

403 (revision-of-file (rooted "owner.sgd")))

404 'population-unprovable)

405 (assert-refusal "rename refuses over the same population"

406 (folio-rename-id! coord "t-b15" "t-fresh15"

407 (revision-of-file (rooted "owner.sgd")))

408 'population-unprovable)

409 ;; And the coordinator's OWN dot-artifacts must NOT trip the guard: after

410 ;; removing the intruder, an ordinary op proceeds.

411 (delete-file (rooted ".hidden15/note.sgd"))

412 (delete-directory (rooted ".hidden15"))

413 (assert-txn "an ordinary op proceeds once the dot-intruder is gone"

414 (folio-insert-node! coord (rooted "owner.sgd") "work" 'update

415 (revision-of-file (rooted "owner.sgd"))

416 timestamp: "2026-08-25" id: "u-b15"))))

417

418(println "F3B_PROBE_DONE arms=~a green=~a red=~a"

419 (+ (car greens) (car reds)) (car greens) (car reds))

420(exit (if (= (car reds) 0) 0 1))