packages/slate-cli/test/test-logging-contract.sgl

1;;; The `--log` / `--log-level` CLI contract, and the stream-child gate.

2;;;

3;;; THE LOAD-BEARING TEST IN THIS FILE is "stream child argv carries the

4;;; logging flags AND still strips back to the _stream arity". It exists

5;;; because the failure it guards is SILENT and lands on the exact path this

6;;; whole feature was built for:

7;;;

8;;; `main.sgl` builds the child's argv EXPLICITLY at the spawn — the child

9;;; inherits nothing from the parent's command line. If the flags are not

10;;; forwarded, the child configures itself silent (no flags means logging

11;;; off, by design) and everything it would say disappears. Nothing errors.

12;;; The parent's log looks healthy. The one path we are instrumenting for

13;;; goes dark.

14;;;

15;;; SCOPE, STATED HONESTLY: today that is TWO log lines (the stream child's

16;;; start and exit, in main.sgl). (slate-cli enclave-stream) — the module

17;;; whose process death IS the remote session's death — has NOT been

18;;; instrumented yet; it currently contains no log calls and does not

19;;; import (sigil log). An earlier version of this comment said forwarding

20;;; protects "every log line in enclave-stream", which was a claim about

21;;; work not yet done. The gate is here first ON PURPOSE: the forwarding is

22;;; the precondition for that instrumentation being worth anything, and a

23;;; gate written after the code it guards is a gate written too late.

24;;;

25;;; And the mirror failure: `run-node!` dispatches `_stream` only when

26;;; `(= (length (cdr args)) 3)`. Forwarding the flags without stripping

27;;; them first breaks that check, and every remote terminal with it.

28;;;

29;;; Those two halves are load-bearing on each other, so the test asserts

30;;; them together: forward the flags, then run the child's own parse over

31;;; the result and assert the arity the dispatcher will count.

32;;;

33;;; SABOTAGE (how to show these gates can go red — do this before trusting

34;;; a green, per procedures/worker-instructions):

35;;; 1. In `stream-child-argv`, drop the `--log-level` clause.

36;;; -> "stream child argv carries the logging flags..." fails on the

37;;; `--log-level` assertion.

38;;; 2. In `stream-child-argv`, append the flags BEFORE the three

39;;; positional arguments instead of after, and simultaneously make

40;;; `extract-log-opts` return `args` unchanged.

41;;; -> the same test fails on the arity assertion (5, not 3).

42;;; 3. In `extract-log-opts`, accept the `=` spelling instead of refusing.

43;;; -> "the = spelling is refused..." fails.

44;;; 4. In `validate-value`, drop the level check.

45;;; -> "an unknown level is refused..." fails.

46;;; Each sabotage must be reverted after the red is recorded.

48(import (sigil test)

49 (sigil core)

50 (sigil string)

51 (sigil fs)

52 (slate-cli logging))

54;; Locate main.sgl for the structural arm at the end of this file. `sigil

55;; test` may be invoked from the workspace root or from the package, so try

56;; both; returns #f if neither exists and the arm then FAILS rather than

57;; skipping. A gate that quietly skips is not a gate.

58(define (main-source-path)

59 (let loop ((candidates

60 (list "packages/slate-cli/src/slate-cli/main.sgl"

61 "src/slate-cli/main.sgl"

62 "../src/slate-cli/main.sgl")))

63 (cond

64 ((null? candidates) #f)

65 ((file-exists? (car candidates)) (car candidates))

66 (else (loop (cdr candidates))))))

68;; Count non-overlapping occurrences of `needle` in `haystack`. Defined

69;; before the test group that uses it, not after: `test-group` runs at load.

70(define (count-occurrences haystack needle)

71 (let ((step (string-length needle)))

72 (let loop ((from 0) (n 0))

73 (let ((hit (string-find haystack needle from)))

74 (if hit (loop (+ hit step) (+ n 1)) n)))))

76(test-group "slate-cli logging CLI contract"

78 ;; ---------------------------------------------------------------

79 ;; Parsing

80 ;; ---------------------------------------------------------------

82 (test "flags are extracted and removed from the argument list"

83 (let ((r (extract-log-opts

84 (list "node" "run" "--log" "/var/log/slate.log"

85 "--log-level" "debug"))))

86 (assert-true (log-opts-ok? r))

87 (assert-equal "/var/log/slate.log" (log-opts-file r))

88 (assert-equal "debug" (log-opts-level r))

89 (assert-equal (list "node" "run") (log-opts-rest r))))

91 (test "flags are accepted before the subcommand as well as after"

92 (let ((r (extract-log-opts

93 (list "--log" "/tmp/s.log" "node" "run"))))

94 (assert-true (log-opts-ok? r))

95 (assert-equal "/tmp/s.log" (log-opts-file r))

96 (assert-equal (list "node" "run") (log-opts-rest r))))

98 ;; The additive-only guarantee: an invocation with no logging flags must

99 ;; come back through the parser completely untouched, because every

100 ;; existing subcommand parses whatever this returns.

101 (test "an invocation with no logging flags is passed through unchanged"

102 (let* ((args (list "serve" "--app-dir" "/build/web" "--port" "32650"))

103 (r (extract-log-opts args)))

104 (assert-true (log-opts-ok? r))

105 (assert-false (log-opts-file r))

106 (assert-false (log-opts-level r))

107 (assert-equal args (log-opts-rest r))))

108

109 (test "order within the list does not matter and both flags are optional"

110 (let ((only-level (extract-log-opts (list "serve" "--log-level" "trace"))))

111 (assert-true (log-opts-ok? only-level))

112 (assert-false (log-opts-file only-level))

113 (assert-equal "trace" (log-opts-level only-level))

114 (assert-equal (list "serve") (log-opts-rest only-level))))

115

116 ;; ---------------------------------------------------------------

117 ;; Refusals

118 ;; ---------------------------------------------------------------

119

120 ;; The `=` spelling must be REFUSED WITH THE CORRECTION, not accepted.

121 ;; (sigil log)'s own `log-configure-from-args!` matches its flags with

122 ;; `equal?` and never splits on `=`, so anything that accepts the spelling

123 ;; upstream hands the user a flag that is silently ignored downstream --

124 ;; a diagnostic that lies about being on. Refusing keeps slate identical

125 ;; to folio, whose test asserts the same pair of properties.

126 (test "the = spelling is refused, and the message gives the correct spelling"

127 (let ((r (extract-log-opts (list "node" "run" "--log-level=trace"))))

128 (assert-false (log-opts-ok? r))

129 (assert-true (string-contains? (log-opts-message r) "--log-level trace")))

130 (let ((r (extract-log-opts (list "node" "run" "--log=/tmp/x.log"))))

131 (assert-false (log-opts-ok? r))

132 (assert-true (string-contains? (log-opts-message r) "--log /tmp/x.log"))))

133

134 ;; Scoped refusal: the `=` rule applies to OUR two flags only. Everything

135 ;; else keeps whatever behaviour it has today, so this stays additive.

136 (test "an = form on a flag we do not own is left alone for the existing parsers"

137 (let ((r (extract-log-opts (list "serve" "--app-upstream=https://x"))))

138 (assert-true (log-opts-ok? r))

139 (assert-equal (list "serve" "--app-upstream=https://x")

140 (log-opts-rest r))))

141

142 (test "a flag with no value is refused rather than silently ignored"

143 (let ((r (extract-log-opts (list "node" "run" "--log"))))

144 (assert-false (log-opts-ok? r))

145 (assert-true (string-contains? (log-opts-message r) "requires a value"))))

146

147 ;; folio measured this one: `folio --log --web` was blessed as "--log with

148 ;; the value --web", after which a second parser started an HTTP server

149 ;; nobody asked for and the logger wrote to a file named `--web`.

150 (test "a value that looks like an option is a forgotten argument, not a value"

151 (let ((r (extract-log-opts (list "serve" "--log" "--port"))))

152 (assert-false (log-opts-ok? r))

153 (assert-true (string-contains? (log-opts-message r) "--port"))))

154

155 ;; `log-configure!` maps an unknown level through `level-name->number` and

156 ;; only assigns `(when n ...)`, so without this check `--log-level tarce`

157 ;; would quietly give the operator `info`.

158 (test "an unknown level is refused, and the message names the valid ones"

159 (let ((r (extract-log-opts (list "node" "run" "--log-level" "tarce"))))

160 (assert-false (log-opts-ok? r))

161 (assert-true (string-contains? (log-opts-message r) "trace"))

162 (assert-true (string-contains? (log-opts-message r) "fatal"))))

163

164 (test "every level (sigil log) understands is accepted"

165 (for-each

166 (lambda (level)

167 (let ((r (extract-log-opts (list "serve" "--log-level" level))))

168 (assert-true (log-opts-ok? r))

169 (assert-equal level (log-opts-level r))))

170 log-levels))

171

172 ;; ---------------------------------------------------------------

173 ;; Child log paths

174 ;; ---------------------------------------------------------------

175

176 ;; Per-pid child files are not a naming preference. sigil has no O_APPEND,

177 ;; so appending is emulated as read-truncate-rewrite, which two processes

178 ;; cannot do to one file without the kernel zero-filling the gap -- and NUL

179 ;; bytes make `grep` report zero matches for lines `tail` shows plainly.

180 (test "a stream child derives its own per-pid log file from the parent's"

181 (assert-equal "/var/log/slate-node-stream-4242.log"

182 (stream-child-log-path "/var/log/slate-node.log" 4242))

183 ;; Two children never collide, which is the entire point.

184 (assert-false (string=? (stream-child-log-path "/var/log/n.log" 1)

185 (stream-child-log-path "/var/log/n.log" 2))))

186

187 (test "the stream-child invocation is recognised before dispatch"

188 (assert-true (stream-child-invocation? (list "node" "_stream" "u" "c" "t")))

189 (assert-false (stream-child-invocation? (list "node" "run")))

190 (assert-false (stream-child-invocation? (list "serve")))

191 (assert-false (stream-child-invocation? '())))

192

193 ;; ---------------------------------------------------------------

194 ;; THE GATE

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

196

197 (test "stream child argv carries the logging flags AND still strips back to the _stream arity"

198 (let ((argv (stream-child-argv "/usr/bin/slate" "wss://relay/stream"

199 "alice" "tkt-opaque"

200 "/var/log/slate-node.log" "debug")))

201 ;; Half one: the child is actually TOLD to log. Without this the whole

202 ;; enclave-stream instrumentation is silent and nothing complains.

203 (assert-true (member "--log" argv))

204 (assert-true (member "/var/log/slate-node.log" argv))

205 (assert-true (member "--log-level" argv))

206 (assert-true (member "debug" argv))

207

208 ;; Half two: what the child's own `main` will see is `(cdr argv)`, and

209 ;; after its own parse `run-node!` must still count exactly three

210 ;; positional arguments after `_stream`, or the dispatch arm does not

211 ;; fire and every remote terminal breaks.

212 (let* ((child-args (cdr argv))

213 (parsed (extract-log-opts child-args))

214 (rest (log-opts-rest parsed)))

215 (assert-true (log-opts-ok? parsed))

216 (assert-equal "/var/log/slate-node.log" (log-opts-file parsed))

217 (assert-equal "debug" (log-opts-level parsed))

218 (assert-equal "node" (car rest))

219 (assert-equal "_stream" (cadr rest))

220 ;; `run-node!` checks `(= (length (cdr args)) 3)` where args is

221 ;; `(cdr rest)`. This is that number.

222 (assert-equal 3 (length (cddr rest)))

223 ;; And the three are the real ones, in order.

224 (assert-equal (list "wss://relay/stream" "alice" "tkt-opaque")

225 (cddr rest)))))

226

227 ;; The unlogged case must be byte-identical to what the spawn site built

228 ;; before this change, or "additive only" is not true.

229 (test "with no parent logging the child argv is exactly the original six"

230 (assert-equal

231 (list "/usr/bin/slate" "node" "_stream" "wss://relay/stream" "alice" "tkt")

232 (stream-child-argv "/usr/bin/slate" "wss://relay/stream" "alice" "tkt"

233 #f #f)))

234

235 ;; A parent logging to STDERR ONLY must leave its children silent, and this

236 ;; is a deadlock guard rather than a preference. `process-spawn` gives the

237 ;; child a stderr PIPE, and nothing in slate-cli ever reads it; a child

238 ;; logging into it would block forever once ~64 KiB accumulated, taking the

239 ;; terminal session with it. Give the node `--log` and the children get

240 ;; their own files instead.

241 (test "a parent logging to stderr only leaves the child silent"

242 (let ((argv (stream-child-argv "/usr/bin/slate" "u" "c" "t" #f "trace")))

243 (assert-false (member "--log" argv))

244 (assert-false (member "--log-level" argv))

245 (assert-equal

246 (list "/usr/bin/slate" "node" "_stream" "u" "c" "t")

247 argv)))

248

249 ;; ---------------------------------------------------------------

250 ;; THE STRUCTURAL ARM — the seam cannot be bypassed

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

252 ;;

253 ;; Every test above proves `stream-child-argv` behaves. None of them

254 ;; proves `main.sgl` still CALLS it. Someone inlining the spawn again --

255 ;; which is exactly how it was written before this change -- would leave

256 ;; the whole suite green while the child silently lost its flags.

257 ;;

258 ;; WHAT THIS ARM IS AND IS NOT. It is a SMOKE CHECK over source text: it

259 ;; catches the regression that actually happened once (a hand-rolled

260 ;; `_stream` spawn) and the careless reintroduction of it. It is NOT proof

261 ;; that the seam cannot be bypassed -- a reviewer rightly pointed out that

262 ;; a line break, different spacing, or a second spawn site added alongside

263 ;; the constructor would all slip past. Claiming otherwise would make this

264 ;; the kind of gate that is trusted more than it has earned.

265 ;;

266 ;; The counting assertion below is the part with real teeth: exactly ONE

267 ;; `process-spawn` call in the file, so a second spawn site fails here

268 ;; whatever it looks like.

269 (test "the stream child spawn goes through the tested argv constructor"

270 (let ((path (main-source-path)))

271 (if (not path)

272 ;; Fail, do not skip, and do not fall through into a type error on

273 ;; `(read-file-string #f)`: an arm that cannot find its subject has

274 ;; checked nothing, and reporting that as green is how a gate comes

275 ;; to be quiet rather than correct. `assert-true` records the

276 ;; failure without aborting, so the `if` is what keeps us out of

277 ;; the read.

278 (assert-true path)

279 (let ((src (read-file-string path)))

280 ;; The spawn is reached through the tested constructor, exactly

281 ;; once. Note the form: it is `(apply process-spawn ...)` because

282 ;; the argv is variable-length. Counting `"(process-spawn"` here

283 ;; would be a gate that can never pass -- that exact mistake was

284 ;; made writing this test and caught by running the count against

285 ;; the real file before trusting it.

286 (assert-equal 1 (count-occurrences src "(apply process-spawn"))

287 (assert-true (string-contains? src "(stream-child-argv"))

288 ;; And there is NO direct-call spawn anywhere in the file, which

289 ;; is the form a hand-rolled second site would take.

290 (assert-equal 0 (count-occurrences src "(process-spawn "))

291 ;; The pre-change shape, kept as a named tripwire.

292 ;;

293 ;; MEASURED to discriminate, both directions, against the real

294 ;; pre-change source (`git show HEAD:...main.sgl`):

295 ;; pre-change: (apply process-spawn = 0, (process-spawn = 1,

296 ;; "process-spawn exe \"node\"" present

297 ;; current: (apply process-spawn = 1, (process-spawn = 0,

298 ;; tripwire absent

299 ;; So reverting the spawn site to how it was written before this

300 ;; change fails all three assertions rather than none.

301 (assert-false (string-contains? src "process-spawn exe \"node\"")))))))