test/f3a-txn-probe.sgl

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

2;;;

3;;; Direct script with a hand-rolled harness (the f1a probe pattern): each arm

4;;; prints F3A_ARM_<name>_GREEN or F3A_ARM_<name>_RED with a reason, the run

5;;; ends with F3A_PROBE_DONE arms=N green=N red=N, and the exit status is

6;;; non-zero when any arm is red. Multi-process arms (real contention, crash

7;;; release, the fake-flock filesystem) live in gate-f3a.sh, which owns

8;;; processes; this file owns semantics.

9;;;

10;;; F3A_ROOT must name a DISPOSABLE fixture root (the gate copies

11;;; test/fixtures/f3a/ into a temp dir). This probe mutates it freely and

12;;; assumes nothing survives the run.

13;;;

14;;; F3A_PROBE_SELFTEST=1 runs one deliberately failing assertion and exits:

15;;; the prerequisite check that the harness CAN fail. A harness that cannot

16;;; go red makes every arm decoration.

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

18 (sigil process)

19 (folio doc revision) (folio doc bounded) (folio doc service)

20 (folio doc lock) (folio doc coordinator) (folio doc transaction))

21

22(define root (or (getenv "F3A_ROOT")

23 (begin (display "F3A_PROBE SETUP-FAILED: F3A_ROOT is not set\n") (exit 3))))

24(define lib-dir (or (getenv "F3A_LIB") "build/dev/lib"))

25(define src-dir (or (getenv "F3A_SRC") "src"))

26(define note (path-join root "note.sgd"))

27(define broken (path-join root "broken.sgd"))

28

29(define greens (list 0))

30(define reds (list 0))

31(define current-arm (list "unnamed"))

32

33(define (arm name thunk)

34 (set-car! current-arm name)

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

36 (println "F3A_ARM_~a_RED: raised: ~a" name

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

38 (thunk)

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

40 (println "F3A_ARM_~a_GREEN" name)))

41

42(define (assert-true label v)

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

44(define (assert-equal label a b)

45 (unless (equal? a b)

46 (error (format "assertion failed: ~a: ~s vs ~s" label a b))))

47(define (assert-refusal label r reason)

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

49 (assert-equal (format "~a: refusal reason" label) (txn-refusal-reason r) reason))

50(define (assert-result label r)

51 (when (txn-refusal? r)

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

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

54

55;; The prerequisite: the harness can fail.

56(when (equal? (getenv "F3A_PROBE_SELFTEST") "1")

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

58 (println "F3A_PROBE_SELFTEST_DONE red=~a" (car reds))

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

60

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

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

63

64(define (rev-of path) (revision-of-file path))

65(define (bytes-of path) (read-file-bytes path))

66(define (text-of path) (read-file-string path))

67(define (external-write! path text) (write-file-string path text))

68(define (bytes-equal-range? a a-start b b-start count)

69 (let loop ((i 0))

70 (or (>= i count)

71 (and (= (bytevector-u8-ref a (+ a-start i))

72 (bytevector-u8-ref b (+ b-start i)))

73 (loop (+ i 1))))))

74(define (substring-index s needle)

75 (let ((sl (string-length s)) (nl (string-length needle)))

76 (let loop ((i 0))

77 (cond ((> (+ i nl) sl) #f)

78 ((equal? (substring s i (+ i nl)) needle) i)

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

80

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

82;; a1-stand-down -- THE control. A coordinator that refuses everything passes

83;; every contention test; this arm is what it cannot pass.

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

85(arm "a1-stand-down"

86 (lambda ()

87 (let* ((pre (bytes-of note))

88 (rev0 (rev-of note))

89 (r (folio-update-field! coord note "t-alpha" 'priority 'low rev0

90 expected-node-kind: 'task

91 expected-old-value: 'high)))

92 (assert-result "uncontended priority edit" r)

93 (assert-true "not reported as a rebase" (not (txn-result-rebased? r)))

94 (assert-equal "old value" (txn-result-old-value r) 'high)

95 (assert-equal "old revision" (txn-result-old-revision r) rev0)

96 (let* ((post (bytes-of note))

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

98 (end (txn-result-changed-span-end r))

99 (tail-len (- (bytevector-length pre) end))

100 (post-tail-start (- (bytevector-length post) tail-len)))

101 (assert-true "revision moved" (not (equal? (rev-of note) rev0)))

102 (assert-equal "new revision is the published file's" (txn-result-new-revision r) (rev-of note))

103 (assert-true "bytes before the span are untouched"

104 (bytes-equal-range? post 0 pre 0 start))

105 (assert-true "bytes after the span are untouched"

106 (bytes-equal-range? post post-tail-start pre end tail-len))

107 (assert-true "diff names the changed line"

108 (string-contains? (txn-result-diff r) "priority: 'low"))))))

109

110;; ---------------------------------------------------------------------------

111;; a11-duplicate-text -- the prose above the task carries the same literals;

112;; only the recorded span may move.

113;; ---------------------------------------------------------------------------

114(arm "a11-duplicate-text"

115 (lambda ()

116 (let* ((pre (text-of note))

117 (r (folio-update-field! coord note "t-alpha" 'due "2026-09-30" (rev-of note)

118 expected-old-value: "2026-08-30")))

119 (assert-result "due edit with duplicate text in prose" r)

120 (let ((post (text-of note)))

121 (assert-true "the prose duplicate \"2026-08-30\" survives"

122 (string-contains? post "appear here verbatim"))

123 (assert-true "prose occurrence untouched"

124 (string-contains? post "'active and 'high and \"2026-08-30\""))

125 (assert-true "the task's due moved"

126 (string-contains? post "due: \"2026-09-30\""))))))

127

128;; ---------------------------------------------------------------------------

129;; a12-multibyte -- the fixture puts multi-byte text before every span; the

130;; prose must survive byte-for-byte and the value must land inside the task.

131;; ---------------------------------------------------------------------------

132(arm "a12-multibyte"

133 (lambda ()

134 (let ((r (folio-update-field! coord note "t-alpha" 'tags (list "alpha" "edited")

135 (rev-of note))))

136 (assert-result "tags edit behind multi-byte prose" r)

137 (let ((post (text-of note)))

138 (assert-true "multi-byte prose intact"

139 (and (string-contains? post "Ünïcode, naïve,")

140 (string-contains? post "café -- so every span")))

141 (assert-true "tags landed" (string-contains? post "tags: '(\"alpha\" \"edited\")"))))))

142

143;; ---------------------------------------------------------------------------

144;; a10-journalled-transition -- the pair lands atomically, and the check is a

145;; count increase: t-journalled ALREADY has an @update child.

146;; ---------------------------------------------------------------------------

147(arm "a10-journalled-transition"

148 (lambda ()

149 (let ((r (folio-transition-status! coord note "t-alpha" 'done (rev-of note)

150 timestamp: "2026-08-25" author: "probe"

151 update-id: "u-a10"

152 update-text: "Transitioned by the probe."

153 expected-node-kind: 'task

154 expected-old-status: 'active)))

155 (assert-result "journalled active->done" r)

156 (assert-equal "result carries the update id" (txn-result-update-id r) "u-a10")

157 (let ((post (text-of note)))

158 (assert-true "status landed" (string-contains? post "status: 'done"))

159 (assert-true "journal landed" (string-contains? post "u-a10"))))

160 ;; The vacuity killer: a node with a PRIOR journal entry must still be

161 ;; shown to gain a NEW one.

162 (let ((r (folio-transition-status! coord note "t-journalled" 'active (rev-of note)

163 timestamp: "2026-08-25" update-id: "u-a10b"

164 update-text: "Second journal entry."

165 expected-old-status: 'ready)))

166 (assert-result "transition on an already-journalled node" r)

167 (let ((post (text-of note)))

168 (assert-true "prior entry survives" (string-contains? post "u-prior"))

169 (assert-true "new entry landed" (string-contains? post "u-a10b"))))))

170

171;; ---------------------------------------------------------------------------

172;; a-reopen -- the ruled edges, and only those edges.

173;; ---------------------------------------------------------------------------

174(arm "a-reopen"

175 (lambda ()

176 (let ((r (folio-transition-status! coord note "t-done" 'ready (rev-of note)

177 timestamp: "2026-08-25" update-id: "u-reopen"

178 update-text: "Reopened." expected-old-status: 'done)))

179 (assert-result "done->ready (the ruled reopen edge)" r))

180 ;; ready is the ONLY exit that was added: ready->inbox stays illegal.

181 (assert-refusal "ready->inbox refused"

182 (folio-transition-status! coord note "t-done" 'inbox (rev-of note)

183 timestamp: "2026-08-25" update-id: "u-illegal")

184 'illegal-transition)))

185

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

187;; a-status-door -- there is no unjournalled status door.

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

189(arm "a-status-door"

190 (lambda ()

191 (assert-refusal "status via folio-update-field!"

192 (folio-update-field! coord note "t-alpha" 'status 'ready (rev-of note))

193 'status-requires-journal)))

194

195;; ---------------------------------------------------------------------------

196;; a4-approved-rebase -- stale revision, an UNRELATED field moved externally;

197;; the rebase succeeds AND reports itself (precondition 5's green half).

198;; ---------------------------------------------------------------------------

199(arm "a4-approved-rebase"

200 (lambda ()

201 (let* ((stale (rev-of note))

202 ;; An external editor touches the note's TITLE line (a different

203 ;; field of a different node), moving the revision and every span.

204 (_ (external-write! note

205 (let ((t (text-of note)))

206 (string-replace t "F3a transaction fixture" "F3a fixture, externally retitled"))))

207 (r (folio-update-field! coord note "t-alpha" 'due "2026-10-01" stale

208 expected-old-value: "2026-09-30")))

209 (assert-result "allowlisted rebase over an unrelated external edit" r)

210 (assert-true "PRECONDITION 5: the rebase REPORTS itself" (txn-result-rebased? r))

211 (assert-equal "the stale base revision is named" (txn-result-rebase-base-revision r) stale)

212 (assert-true "the fresh spans landed the value in the task line"

213 (string-contains? (text-of note) "due: \"2026-10-01\"")))))

214

215;; ---------------------------------------------------------------------------

216;; a3-preconditions -- each of D11's five rebase preconditions individually

217;; falsified, each with its own reason. (3) is span recomputation, shown by

218;; an external edit that SHIFTS every offset before the rebase; (4)'s red

219;; direction requires a product-layer plant and lives in sabotage-f3a.sh leg

220;; S4a, recorded here so the arm inventory is honest.

221;; ---------------------------------------------------------------------------

222(arm "a3p1-node-missing"

223 (lambda ()

224 (let ((stale (rev-of note)))

225 (external-write! note (string-replace (text-of note) "\"t-done\"" "\"t-done-renamed\""))

226 (assert-refusal "rebase after the target node vanished"

227 (folio-update-field! coord note "t-done" 'priority 'high stale

228 expected-old-value: 'low)

229 'rebase-node-missing))))

230

231(arm "a3p2-value-changed"

232 (lambda ()

233 (let ((stale (rev-of note)))

234 ;; A concurrent edit moves the SAME field the rebase wants.

235 (external-write! note (string-replace (text-of note) "due: \"2026-10-01\"" "due: \"2027-01-01\""))

236 (let ((r (folio-update-field! coord note "t-alpha" 'due "2026-11-11" stale

237 expected-old-value: "2026-10-01")))

238 (assert-refusal "same-field conflict" r 'rebase-value-changed)

239 (assert-equal "refusal carries the CURRENT revision"

240 (txn-refusal-current-revision r) (rev-of note))

241 (assert-true "refusal carries target context"

242 (string? (txn-refusal-target-context r)))

243 (assert-true "refusal carries a diff naming both values"

244 (and (string-contains? (txn-refusal-diff r) "2026-10-01")

245 (string-contains? (txn-refusal-diff r) "2027-01-01")))))))

246

247(arm "a3p2b-no-old-value"

248 (lambda ()

249 (let ((stale (rev-of note)))

250 (external-write! note (string-append (text-of note) "\n"))

251 (assert-refusal "rebase without an expected-old-value to verify"

252 (folio-update-field! coord note "t-alpha" 'due "2026-12-12" stale)

253 'rebase-needs-expected-old-value))))

254

255(arm "a3p3-spans-recomputed"

256 (lambda ()

257 (let ((stale (rev-of note)))

258 ;; Shift EVERY span: insert a paragraph before the Tasks section. A

259 ;; rebase using any span from the stale base would land in the wrong

260 ;; bytes; the fresh parse must land exactly in the task line.

261 (external-write! note (string-replace (text-of note)

262 "@section[\"Tasks\" id: \"tasks\"]{"

263

                                            "@p{An externally inserted paragraph that shifts every offset after it by a fixed amount, including multi-byte drift: ééé.}\n\n@section[\"Tasks\" id: \"tasks\"]{"))

264 (let ((r (folio-update-field! coord note "t-alpha" 'priority 'medium stale

265 expected-old-value: 'low)))

266 (assert-result "rebase across shifted offsets" r)

267 ;; 'medium appears on OTHER tasks too, so a bare contains proves

268 ;; nothing: assert it landed inside t-alpha's own argument group.

269 (assert-true "value landed inside t-alpha's line, not at a stale offset"

270 (let* ((post (text-of note))

271 (at (substring-index post "\"t-alpha\"")))

272 (and at

273 (let ((stop (if (< (+ at 200) (string-length post))

274 (+ at 200) (string-length post))))

275 (substring-index (substring post at stop)

276 "priority: 'medium")))))

277 (assert-true "the inserted paragraph is untouched"

278 (string-contains? (text-of note) "including multi-byte drift: ééé"))))))

279

280(arm "a3p5-silent-rebase-is-a-defect"

281 (lambda ()

282 ;; The green half of precondition 5 is asserted in a4 (rebased? #t with

283 ;; the base named). This arm pins the CONVERSE: a clean-match write must

284 ;; NOT claim a rebase -- the flag is evidence, not decoration.

285 (let ((r (folio-update-field! coord note "t-alpha" 'priority 'high (rev-of note))))

286 (assert-result "clean-match edit" r)

287 (assert-true "no rebase reported on a clean match" (not (txn-result-rebased? r)))

288 (assert-true "no base revision invented" (not (txn-result-rebase-base-revision r))))))

289

290;; ---------------------------------------------------------------------------

291;; a6-external-edit -- detected via revision, not excluded; and revision

292;; identifies CONTENT, not history (file-level ABA accepted by design).

293;; ---------------------------------------------------------------------------

294(arm "a6-external-edit"

295 (lambda ()

296 (let* ((before (text-of note))

297 (rev-before (rev-of note)))

298 (external-write! note (string-append before "\n"))

299 ;; Non-allowlisted field with a stale revision: refuse with context.

300 (let ((r (folio-update-field! coord note "t-alpha" 'title "Retitle attempt" rev-before)))

301 (assert-refusal "external edit detected via revision" r 'revision-mismatch)

302 (assert-equal "current revision reported" (txn-refusal-current-revision r) (rev-of note))

303 (assert-true "diff shows both revisions"

304 (string-contains? (txn-refusal-diff r) "expected-revision")))

305 ;; git-checkout-style content REVERT: identical bytes, identical

306 ;; revision, so the original expectation is valid again.

307 (external-write! note before)

308 (assert-equal "revision identifies content, not history" (rev-of note) rev-before)

309 (assert-result "transaction against reverted-identical content succeeds"

310 (folio-update-field! coord note "t-alpha" 'priority 'medium rev-before

311 expected-old-value: 'high)))))

312

313;; ---------------------------------------------------------------------------

314;; a7-structural -- amendment 1's boundary, distinguishable by message from

315;; every scalar refusal.

316;; ---------------------------------------------------------------------------

317(arm "a7-structural"

318 (lambda ()

319 (let ((stale (rev-of note)))

320 (external-write! note (string-append (text-of note) "\n"))

321 (let ((body (folio-edit-body! coord note "t-alpha" "replacement body" stale))

322 (title (folio-update-field! coord note "t-alpha" 'title "T" stale)))

323 (assert-refusal "body edit on mismatch" body 'structural-revision-mismatch)

324 (assert-true "structural refusal cites amendment 1"

325 (string-contains? (txn-refusal-message body) "amendment 1"))

326 (assert-refusal "scalar-but-not-allowlisted on mismatch" title 'revision-mismatch)

327 (assert-true "the two refusals are distinguishable"

328 (not (eq? (txn-refusal-reason body) (txn-refusal-reason title))))))

329 ;; F3b: body edits WORK on a clean match now (Q1 ruling) -- but t-alpha

330 ;; carries journal children by this point in the battery, and an

331 ;; id-declaring body refuses wholesale replacement: deleting ids blind to

332 ;; their referrers is the structural ops' job to do safely.

333 (assert-refusal "body edit on an id-declaring body refuses (F3b scope)"

334 (folio-edit-body! coord note "t-alpha" "replacement body" (rev-of note))

335 'body-declares-ids)))

336

337;; ---------------------------------------------------------------------------

338;; a-aba -- ABA on an allowlisted field, accepted explicitly: the file went

339;; A -> B -> A between the caller's read and its write.

340;; ---------------------------------------------------------------------------

341(arm "a-aba"

342 (lambda ()

343 (let* ((base (text-of note))

344 (stale (rev-of note)))

345 (external-write! note (string-replace base "priority: 'medium" "priority: 'low"))

346 (external-write! note base) ;; back to A: same bytes, same revision

347 (assert-result "ABA excursion is accepted for an allowlisted field"

348 (folio-update-field! coord note "t-alpha" 'priority 'high stale

349 expected-old-value: 'medium)))))

350

351;; ---------------------------------------------------------------------------

352;; a-namedblock -- the journal insertion point for the @end spelling.

353;; ---------------------------------------------------------------------------

354(arm "a-namedblock"

355 (lambda ()

356 (let ((r (folio-transition-status! coord note "projects/f3a-fixture" 'paused

357 (rev-of note)

358 timestamp: "2026-08-25" update-id: "u-nb"

359 update-text: "Paused."

360 expected-node-kind: 'project

361 expected-old-status: 'active)))

362 (assert-result "container transition in a named block" r)

363 (let ((post (text-of note)))

364 (assert-true "journal landed" (string-contains? post "u-nb"))

365 ;; The update must sit BEFORE @end project, i.e. inside the block.

366 (assert-true "journal is inside the named block"

367 (let ((u (substring-index post "u-nb"))

368 (e (substring-index post "@end project")))

369 (and u e (< u e))))))))

370

371;; ---------------------------------------------------------------------------

372;; a13-invalid-readonly / a13b-instrument-suspect -- the two failure kinds

373;; stay distinguishable all the way out.

374;; ---------------------------------------------------------------------------

375(arm "a13-invalid-readonly"

376 (lambda ()

377 (let ((r (folio-update-field! coord broken "t-broken" 'priority 'low (rev-of broken))))

378 (assert-refusal "invalid document is read-only" r 'document-invalid)

379 (assert-true "not retryable: the document is at fault"

380 (not (txn-refusal-retryable? r))))))

381

382(arm "a13b-instrument-suspect"

383 (lambda ()

384 ;; A coordinator whose worker runs under a memory cap far below what any

385 ;; parse needs: every verdict is about the INSTRUMENT, and the refusal

386 ;; must say so and be retryable.

387 (let* ((tiny (make-service (default-worker-argv lib-dir src-dir)

388 (make-limits 8192 30000)))

389 (tiny-coord (make-coordinator root tiny))

390 (r (folio-update-field! tiny-coord note "t-alpha" 'priority 'low (rev-of note))))

391 (assert-refusal "starved instrument refuses as suspect" r 'instrument-suspect)

392 (assert-true "retryable: the document is NOT at fault" (txn-refusal-retryable? r))

393 (assert-true "message says instrument/host, not document"

394 (string-contains? (txn-refusal-message r) "NOT the document")))))

395

396;; ---------------------------------------------------------------------------

397;; a-manifest -- an incomplete transaction manifest stops everything; its

398;; removal stands the coordinator back up (the check's own positive control).

399;; ---------------------------------------------------------------------------

400(arm "a-manifest"

401 (lambda ()

402 ;; F3b: a manifest that PARSES triggers automatic recovery (the F3b probe

403 ;; covers those branches); this arm keeps the UNPROVABLE case pinned -- a

404 ;; manifest that does not parse must refuse every mutation to a HUMAN,

405 ;; never guess, and its removal stands the coordinator back up.

406 (let ((manifest (path-join root transaction-manifest-name)))

407 (write-file-string manifest "left by a crashed cross-file transaction")

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

409 (folio-update-field! coord note "t-alpha" 'priority 'low (rev-of note))

410 #f)))

411 (assert-true "transaction refused while an unparseable manifest exists"

412 (string? raised))

413 (assert-true "the refusal names the manifest and demands a human"

414 (and (string-contains? raised "manifest")

415 (string-contains? raised "human"))))

416 (delete-file manifest)

417 (assert-result "removal stands the coordinator back up"

418 (folio-update-field! coord note "t-alpha" 'priority 'low (rev-of note)

419 expected-old-value: 'high)))))

420

421;; ---------------------------------------------------------------------------

422;; a-containment -- the held lock serializes THIS root's writers; a path

423;; outside the root must refuse loudly, and a relative path resolves against

424;; the root.

425;; ---------------------------------------------------------------------------

426(arm "a-containment"

427 (lambda ()

428 (let ((outside (path-join (path-dirname root) "f3a-escapee.sgd")))

429 (write-file-string outside "#lang folio/doc\n@note[\"topics/escapee\" title: \"E\"]\n@end note\n")

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

431 (folio-update-field! coord outside "t-alpha" 'priority 'low

432 (rev-of outside))

433 #f)))

434 (assert-true "a path outside the root raises" (string? raised))

435 (assert-true "the refusal names the containment rule"

436 (string-contains? raised "not under the coordinator's root")))

437 (delete-file outside))

438 ;; ../-laundered spelling of an outside path must refuse too.

439 (let ((laundered (string-append root "/../f3a-escapee2.sgd")))

440 (write-file-string laundered "#lang folio/doc\n@note[\"topics/e2\" title: \"E\"]\n@end note\n")

441 (let ((raised (guard (e (#t #t))

442 (folio-update-field! coord laundered "t-alpha" 'priority 'low

443 (rev-of laundered))

444 #f)))

445 (assert-true "a ../-laundered outside path raises" raised))

446 (delete-file laundered))

447 ;; A relative path is the natural slug spelling and resolves in-root.

448 ;; (t-alpha's priority is 'low by this point in the battery.)

449 (assert-result "relative path resolves against the root"

450 (folio-update-field! coord "note.sgd" "t-alpha" 'priority 'high

451 (rev-of note)

452 expected-old-value: 'low))))

453

454;; ---------------------------------------------------------------------------

455;; a-symlink-boundary -- containment is decided on the REAL path. The

456;; adversarial reviewer demonstrated a directory symlink walking the lexical

457;; check straight out of the root (finding: MEDIUM, 2026-08-25); this arm is

458;; that escape pinned shut, with the two companions that show the BOUNDARY:

459;; an ordinary in-root subdirectory still works (the stand-down control for

460;; the fix), and a LEAF file symlink is still admitted -- rename replaces the

461;; symlink in-root and the outside target is untouched.

462;; ---------------------------------------------------------------------------

463(arm "a-symlink-boundary"

464 (lambda ()

465 (let* ((outside-dir (path-join (path-dirname root) "f3a-outside"))

466 (victim (path-join outside-dir "victim.sgd")))

467 (unless (directory-exists? outside-dir) (make-directory outside-dir))

468 (write-file-bytes victim (bytes-of note))

469 ;; (a) DIRECTORY symlink: root/esc -> outside; the spelled path is

470 ;; in-root, the real write domain is not. Must refuse, and the outside

471 ;; file must not move.

472 (let ((linkdir (path-join root "esc")))

473 (make-symlink outside-dir linkdir)

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

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

476 (folio-update-field! coord (path-join root "esc/victim.sgd")

477 "t-alpha" 'priority 'low

478 (revision-of-file victim))

479 #f)))

480 (assert-true "directory-symlink path refuses" (string? raised))

481 (assert-true "refusal names the resolved containment rule"

482 (string-contains? raised "not under the coordinator's root"))

483 (assert-equal "the outside file did not move"

484 (revision-of-file victim) victim-before)))

485 ;; (b) stand-down: an ordinary in-root SUBDIRECTORY transacts fine.

486 (let ((subdir (path-join root "sub")))

487 (unless (directory-exists? subdir) (make-directory subdir))

488 (write-file-bytes (path-join subdir "subnote.sgd") (bytes-of note))

489 (assert-result "an ordinary in-root subdirectory still works"

490 (folio-update-field! coord (path-join subdir "subnote.sgd")

491 "t-alpha" 'priority 'low

492 (revision-of-file (path-join subdir "subnote.sgd"))

493 expected-old-value: 'high)))

494 ;; (c) LEAF file symlink: admitted; the publish rename replaces the

495 ;; symlink with a regular in-root file and the outside target is

496 ;; untouched.

497 (let ((leaf (path-join root "leaf.sgd"))

498 (victim-before (revision-of-file victim)))

499 (make-symlink victim leaf)

500 (assert-result "leaf-symlink transaction publishes"

501 (folio-update-field! coord leaf "t-alpha" 'priority 'low

502 (revision-of-file leaf)

503 expected-old-value: 'high))

504 (assert-equal "the symlink's outside target is untouched"

505 (revision-of-file victim) victim-before)

506 (assert-true "the in-root path is now a regular file (the symlink was replaced)"

507 (and (file-exists? leaf)

508 (not (equal? (realpath leaf) (realpath victim)))))))))

509

510;; ---------------------------------------------------------------------------

511;; a-journal-injection -- the journal body is spliced verbatim; hostile text

512;; must refuse BEFORE any staging, and the note must not move.

513;; ---------------------------------------------------------------------------

514(arm "a-journal-injection"

515 (lambda ()

516 (let ((rev (rev-of note)))

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

518 (folio-transition-status! coord note "t-journalled" 'ready rev

519 timestamp: "2026-08-25" update-id: "u-inj"

520 update-text: "x} @task[\"t-evil\" title: \"E\" status: 'ready]{y")

521 #f)))

522 (assert-true "hostile update-text raises" (string? raised))

523 (assert-true "the refusal names the injection hazard"

524 (string-contains? raised "inject")))

525 (assert-equal "the note did not move" (rev-of note) rev)

526 (assert-true "no injected node reached the file"

527 (not (string-contains? (text-of note) "t-evil"))))))

528

529;; ---------------------------------------------------------------------------

530(println "F3A_PROBE_DONE arms=~a green=~a red=~a"

531 (+ (car greens) (car reds)) (car greens) (car reds))

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