test/f3a-sab-driver.sgl

1;;; f3a-sab-driver.sgl -- independent mini-arms for sabotage-f3a.sh (and two

2;;; gate arms). Unlike f3a-txn-probe.sgl's sequential battery, every arm here

3;;; builds its own fresh fixture root, so a sabotage leg can run exactly the

4;;; arms its prediction names, in any order, with no state chained between

5;;; them.

6;;;

7;;; Select arms with F3A_SAB_ARMS=name,name (default: all). Fixture source

8;;; dir arrives as F3A_FIXTURES. Markers: SAB_ARM_<name>_<GREEN|RED>, then

9;;; SAB_DRIVER_DONE arms=N green=N red=N; non-zero exit when any red.

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

11 (folio doc revision) (folio doc bounded) (folio doc service)

12 (folio doc coordinator) (folio doc transaction))

13

14(define fixtures (or (getenv "F3A_FIXTURES")

15 (begin (display "SAB_DRIVER SETUP-FAILED: F3A_FIXTURES not set\n") (exit 3))))

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

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

18(define only (let ((s (getenv "F3A_SAB_ARMS")))

19 (and s (string-split s ","))))

20

21(define greens (list 0))

22(define reds (list 0))

23

24(define (fresh-root)

25 (let ((dir (make-temp-directory)))

26 (unless dir (error "could not create a temp fixture root"))

27 (for-each

28 (lambda (name)

29 (write-file-bytes (path-join dir name)

30 (read-file-bytes (path-join fixtures name))))

31 '("note.sgd" "broken.sgd"))

32 dir))

33

34(define (coordinator-for root)

35 (make-coordinator root (make-service (default-worker-argv lib-dir src-dir)

36 default-limits)))

37

38(define (arm name thunk)

39 (when (or (not only) (member name only))

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

41 (println "SAB_ARM_~a_RED: ~a" name

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

43 (thunk)

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

45 (println "SAB_ARM_~a_GREEN" name))))

46

47(define (assert-true label v)

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

49(define (assert-result label r)

50 (when (txn-refusal? r)

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

52 (assert-true label (txn-result? r)))

53(define (assert-refusal label r reason)

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

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

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

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

58

59;; --- sab-uncontended: the stand-down control, arm form ---------------------

60(arm "sab-uncontended"

61 (lambda ()

62 (let* ((root (fresh-root))

63 (note (path-join root "note.sgd"))

64 (coord (coordinator-for root))

65 (pre (read-file-string note))

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

67 (revision-of-file note)

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

69 (assert-result "uncontended edit succeeds" r)

70 (let ((post (read-file-string note)))

71 (assert-true "the task line moved" (string-contains? post "priority: 'low"))

72 (assert-true "the prose duplicate did not"

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

74

75;; --- sab-revcheck: a stale write is refused --------------------------------

76(arm "sab-revcheck"

77 (lambda ()

78 (let* ((root (fresh-root))

79 (note (path-join root "note.sgd"))

80 (coord (coordinator-for root))

81 (stale (revision-of-file note)))

82 (write-file-string note (string-append (read-file-string note) "\n"))

83 (let ((r (folio-update-field! coord note "t-alpha" 'title "stale write" stale)))

84 (assert-refusal "stale title edit refused" r 'revision-mismatch)

85 (assert-true "note does not contain the stale write"

86 (not (string-contains? (read-file-string note) "stale write")))))))

87

88;; --- sab-precond2: a same-field conflict is refused ------------------------

89(arm "sab-precond2"

90 (lambda ()

91 (let* ((root (fresh-root))

92 (note (path-join root "note.sgd"))

93 (coord (coordinator-for root))

94 (stale (revision-of-file note)))

95 (write-file-string note (string-replace (read-file-string note)

96 "due: \"2026-08-30\"" "due: \"2027-06-06\""))

97 (let ((r (folio-update-field! coord note "t-alpha" 'due "2026-12-24" stale

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

99 (assert-refusal "conflicting rebase refused" r 'rebase-value-changed)

100 (assert-true "the concurrent value survives"

101 (string-contains? (read-file-string note) "due: \"2027-06-06\""))))))

102

103;; --- sab-span: the edit lands at the RECORDED span, not first matching text

104(arm "sab-span"

105 (lambda ()

106 (let* ((root (fresh-root))

107 (note (path-join root "note.sgd"))

108 (coord (coordinator-for root))

109 (r (folio-update-field! coord note "t-alpha" 'due "2026-12-31"

110 (revision-of-file note)

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

112 (assert-result "due edit" r)

113 (let ((post (read-file-string note)))

114 (assert-true "prose duplicate of the old value untouched"

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

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

117 (string-contains? post "due: \"2026-12-31\""))))))

118

119;; --- sab-postcheck-defends: a staged result that fails its reparse must NOT

120;; publish. GREEN requires a refusal AND untouched bytes -- so this arm is

121;; run by the sabotage legs that plant a serializer defect (S4a: refusal

122;; observed = the postcheck fired; S4b adds a verdict-ignoring plant and the

123;; publish of a corrupt note reddens it). WITHOUT any plant this arm expects

124;; the edit to SUCCEED, so it stays green in the gate too.

125(arm "sab-postcheck-defends"

126 (lambda ()

127 (let* ((root (fresh-root))

128 (note (path-join root "note.sgd"))

129 (coord (coordinator-for root))

130 (pre-rev (revision-of-file note))

131 (r (folio-update-field! coord note "t-alpha" 'due "2026-11-30" pre-rev

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

133 (cond

134 ((txn-result? r)

135 ;; No plant: the edit published and the file must still parse -- run

136 ;; one more transaction against it as the parse witness.

137 (assert-result "published file still transacts"

138 (folio-update-field! coord note "t-alpha" 'priority 'low

139 (revision-of-file note)

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

141 (else

142 ;; A plant is live: the ONLY acceptable refusal is the postcheck, and

143 ;; the file must be byte-identical.

144 (assert-refusal "refusal is the postcheck's" r 'postcheck-failed)

145 (assert-true "nothing was published"

146 (equal? (revision-of-file note) pre-rev)))))))

147

148;; --- sab-journal: a status transition lands its @update --------------------

149(arm "sab-journal"

150 (lambda ()

151 (let* ((root (fresh-root))

152 (note (path-join root "note.sgd"))

153 (coord (coordinator-for root))

154 (r (folio-transition-status! coord note "t-alpha" 'done

155 (revision-of-file note)

156 timestamp: "2026-08-25" update-id: "u-sab"

157 update-text: "Journalled."

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

159 (assert-result "journalled transition publishes" r)

160 (let ((post (read-file-string note)))

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

162 (assert-true "journal landed" (string-contains? post "u-sab"))))))

163

164;; --- sab-rebase-report: a rebase says so -----------------------------------

165(arm "sab-rebase-report"

166 (lambda ()

167 (let* ((root (fresh-root))

168 (note (path-join root "note.sgd"))

169 (coord (coordinator-for root))

170 (stale (revision-of-file note)))

171 ;; Unrelated external edit moves the revision.

172 (write-file-string note (string-append (read-file-string note) "\n"))

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

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

175 (assert-result "allowlisted rebase succeeds" r)

176 (assert-true "PRECONDITION 5: rebased? is #t" (txn-result-rebased? r))

177 (assert-true "the stale base is named"

178 (equal? (txn-result-rebase-base-revision r) stale))))))

179

180;; --- sab-coord-init: a coordinator can be built (exclusion probe passes) ---

181(arm "sab-coord-init"

182 (lambda ()

183 (let ((coord (coordinator-for (fresh-root))))

184 (assert-true "probe passed" (coordinator-probed? coord)))))

185

186(println "SAB_DRIVER_DONE arms=~a green=~a red=~a"

187 (+ (car greens) (car reds)) (car greens) (car reds))

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