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

1;;; Test suite for the node's operation logging (t-b24590).

2;;;

3;;; WHY THIS FILE EXISTS. The instrumentation shipped with three one-off

4;;; manual measurements — a rotation arm, a concurrency demonstration, and a

5;;; deadlock-guard probe — all of which lived in /tmp and none of which would

6;;; ever run again. An adversarial review's sharpest finding was not a bug in

7;;; the code but that nothing in the repository could go red tomorrow.

8;;;

9;;; Two of those manual checks also could not fail for the property they

10;;; claimed. The concurrency demonstration's evidence was "the end lines land

11;;; in the opposite order to the begin lines", which is a property of the

12;;; WORKLOAD (two operations of different durations), not of the product:

13;;; replacing `next-op-id!` with `(define (next-op-id!) 1)` — the exact defect

14;;; correlation ids exist to prevent — leaves that evidence completely

15;;; unchanged. What actually pins it is asserting the LABELS: two distinct

16;;; ids, each appearing exactly twice, never reused across two begins. That is

17;;; what `interleaved concurrent operations` below does.

18;;;

19;;; Every arm here was checked against a deliberately broken product before

20;;; being trusted; the specific breakage each one catches is named in its own

21;;; comment. An arm that cannot fail is decoration, and this file exists

22;;; because three pieces of decoration were shipped.

24(import (sigil test)

25 (sigil core)

26 (sigil string)

27 (sigil io)

28 (sigil fs)

29 (sigil path)

30 (sigil json)

31 (sigil math)

32 (sigil log)

33 (sigil time)

34 (sigil async)

35 (sigil channels)

36 (sigil process)

37 (sigil system grant)

38 (slate-cli wire)

39 (slate-cli dispatch)

40 (slate-cli config)

41 (slate-cli logging)

42 (slate-cli listen))

44;; ---------------------------------------------------------------

45;; Fixtures. Every arm captures into its OWN string port, so one arm

46;; cannot read another's lines and no arm depends on ordering.

47;; ---------------------------------------------------------------

48(define ROOT (make-temp-directory))

49(define ORIGIN "https://useslate.org")

51(define GRANTS (make-grants principal: (string-append "web:" ORIGIN)))

52(grant-add! GRANTS (string-append "fs:rw:" ROOT))

53(grant-add! GRANTS "exec:full")

55(define DAEMON

56 #{ config: (make-config machine-name: "testhost" state-dir: "/tmp")

57 instance: "test-instance" })

59(define LISTING (path-join ROOT "listing"))

60(ensure-directory LISTING)

61(write-file-string (path-join LISTING "a.txt") "ay")

63;; Run `thunk` with logging captured at `level`, and return everything

64;; emitted. Restores the logger to silent afterwards so a failing arm cannot

65;; leave the rest of the suite logging to stderr.

66(define (capture-at level thunk)

67 (let ((sink (open-output-string)))

68 (log-configure! target: sink level: level format: 'text)

69 (thunk)

70 (let ((out (get-output-string sink)))

71 (log-configure! level: 6)

72 out)))

74(define (capture-json-at level thunk)

75 (let ((sink (open-output-string)))

76 (log-configure! target: sink level: level format: 'json)

77 (thunk)

78 (let ((out (get-output-string sink)))

79 (log-configure! level: 6 format: 'text)

80 out)))

82(define (req id verb args)

83 (dispatch-req DAEMON ORIGIN GRANTS

84 (decode-control (json-encode #{ t: "req" id: id verb: verb args: args }))))

86(define (count-substring haystack needle)

87 (let loop ((from 0) (n 0))

88 (let ((hit (string-find (substring haystack from (string-length haystack)) needle)))

89 (if (not hit)

90 n

91 (loop (+ from hit (string-length needle)) (+ n 1))))))

93(define (contains? haystack needle) (if (string-find haystack needle) #t #f))

95;; ===============================================================

96;; 1. Durations

97;; ===============================================================

98(test-group "operation logging - durations"

100 ;; THE ARM THAT LICENSES `op-elapsed-ms` BEING GUARDED.

101 ;;

102 ;; That function returns -1 rather than raising, because a raise from a log

103 ;; field inside `do-open`'s guard escapes and can kill the node. The

104 ;; objection to guarding it was that a guard would hide a real defect behind

105 ;; a placeholder with every test still green — which is exactly what

106 ;; happened once already, when it called `round` without importing

107 ;; (sigil math).

108 ;;

109 ;; So the sentinel is -1, which no real duration can be, and this arm is

110 ;; what converts that sentinel back into a red. Break the function any way

111 ;; at all — unbound variable, wrong arity, bad arithmetic — and the guard

112 ;; yields -1 and this assertion fails.

113 (test "op-elapsed-ms measures a real interval, and is never the -1 sentinel"

114 (let* ((t0 (op-clock))

115 (spin (let loop ((i 0) (acc 0))

116 (if (< i 200000) (loop (+ i 1) (+ acc i)) acc)))

117 (ms (op-elapsed-ms t0)))

118 (assert-true (number? ms))

119 (assert-true (> ms 0)) ; -1 sentinel, or a dead clock, fails here

120 (assert-true (< ms 60000)) ; and an absurd value fails here

121 (assert-true (> spin 0)))) ; the spin really ran

122

123 (test "every completed dispatch carries a duration-ms field"

124 (let ((out (capture-at 'debug

125 (lambda ()

126 (req 1 "fs/stat" #{ path: (path-join LISTING "a.txt") })))))

127 (assert-true (contains? out "node/rpc-end"))

128 (assert-true (contains? out "duration-ms="))

129 (assert-true (not (contains? out "duration-ms=-1"))))))

130

131;; ===============================================================

132;; 2. Correlation ids

133;; ===============================================================

134(test-group "operation logging - correlation ids"

135

136 (test "ids are unique and monotonic across calls"

137 (let ((a (next-op-id!)) (b (next-op-id!)) (c (next-op-id!)))

138 (assert-true (< a b))

139 (assert-true (< b c))))

140

141 ;; The pid prefix is what keeps an id unique across the node's per-ticket

142 ;; stream children and across a restart. A bare counter restarts at 0 in

143 ;; every process — the defect `hub-next-chan!`'s comment records about the

144 ;; sid counter it replaced. Deleting the prefix makes this arm red.

145 (test "an op label is qualified by pid, so it survives restarts and children"

146 (let ((label (op-label 42))

147 (pid (number->string (process-id))))

148 (assert-true (contains? label pid))

149 (assert-true (contains? label "42"))

150 (assert-true (contains? label "."))))

151

152 (test "one request's begin and end lines share one id"

153 (let* ((out (capture-at 'debug

154 (lambda () (req 7 "fs/stat" #{ path: (path-join LISTING "a.txt") }))))

155 (label (let* ((at (string-find out "op="))

156 (rest (substring out (+ at 3) (string-length out)))

157 (sp (string-find rest " ")))

158 (substring rest 0 sp))))

159 ;; Exactly two lines, both carrying the same label.

160 (assert-equal 2 (count-substring out (string-append "op=" label)))

161 (assert-true (contains? out "node/rpc-begin"))

162 (assert-true (contains? out "node/rpc-end"))))

163

164 ;; THE ARM THE MANUAL DEMONSTRATION SHOULD HAVE BEEN.

165 ;;

166 ;; Two operations genuinely in flight together, asserted on the LABELS

167 ;; rather than on the order the lines happen to land in. Ordering is a

168 ;; property of the workload; label distinctness is a property of the

169 ;; product. `(define (next-op-id!) 1)` leaves the ordering evidence intact

170 ;; and makes this arm red, which is the whole point.

171 (test "interleaved concurrent operations stay separable by id"

172 (let ((sink (open-output-string)))

173 (log-configure! target: sink level: 'debug format: 'text)

174 (with-async

175 (let ((done (make-channel 2)))

176 (go (begin (req 201 "proc/run"

177 #{ argv: (list->array (list "sh" "-c" "sleep 0.25")) })

178 (channel-send done 'a)))

179 (go (begin (req 202 "proc/run"

180 #{ argv: (list->array (list "sh" "-c" "sleep 0.05")) })

181 (channel-send done 'b)))

182 (channel-receive done)

183 (channel-receive done)))

184 (let ((out (get-output-string sink)))

185 (log-configure! level: 6)

186 ;; Both operations ran and both completed.

187 (assert-equal 2 (count-substring out "node/rpc-begin"))

188 (assert-equal 2 (count-substring out "node/rpc-end"))

189 ;; Each request id appears exactly twice — once per line.

190 (assert-equal 2 (count-substring out "req-id=201"))

191 (assert-equal 2 (count-substring out "req-id=202"))

192 ;; THE LOAD-BEARING ASSERTION. Pull the label off each of the two

193 ;; begin lines; they must DIFFER. A constant id passes every

194 ;; assertion above and fails this one.

195 (let* ((b1 (string-find out "node/rpc-begin"))

196 (rest1 (substring out b1 (string-length out)))

197 (b2rel (string-find (substring rest1 10 (string-length rest1))

198 "node/rpc-begin"))

199 (label-after

200 (lambda (s)

201 (let* ((at (string-find s "op="))

202 (r (substring s (+ at 3) (string-length s))))

203 (substring r 0 (string-find r " ")))))

204 (l1 (label-after rest1))

205 (l2 (label-after (substring rest1 (+ 10 b2rel) (string-length rest1)))))

206 (assert-true (not (string=? l1 l2))))))))

207

208;; ===============================================================

209;; 3. Refusals are loud and distinguishable

210;; ===============================================================

211(test-group "operation logging - refusals"

212

213 (test "an unrecognised verb logs at warn and names itself"

214 (let ((out (capture-at 'debug (lambda () (req 3 "fs/teleport" #{ path: "/x" })))))

215 (assert-true (contains? out "[WARN]"))

216 (assert-true (contains? out "node/rpc-refused"))

217 (assert-true (contains? out "code=unknown-verb"))))

218

219 (test "a grant refusal logs at warn"

220 (let ((out (capture-at 'debug (lambda () (req 4 "fs/read-file" #{ path: "/etc/shadow" })))))

221 (assert-true (contains? out "[WARN]"))

222 (assert-true (contains? out "grant-denied"))))

223

224 ;; A request with NO id at all must be distinguishable from one carrying

225 ;; literal `false`. `#f` is a boolean, so ordering the boolean test before

226 ;; the `#f` test collapses the two — which is how it was first written.

227 (test "a request with no id logs <missing>, not a bare false"

228 (let ((out (capture-at 'debug

229 (lambda ()

230 (dispatch-req DAEMON ORIGIN GRANTS

231 (decode-control (json-encode #{ t: "req" verb: "fs/stat" })))))))

232 (assert-true (contains? out "node/rpc-invalid-id"))

233 (assert-true (contains? out "raw-id=<missing>"))))

234

235 ;; Every refusal at warn-or-above is what makes `grep -c '[WARN]'` a

236 ;; first-pass health check. The control matters: a SUCCESSFUL operation must

237 ;; produce no warn line, or the check is worthless.

238 (test "a successful operation produces no warn line"

239 (let ((out (capture-at 'debug

240 (lambda () (req 5 "fs/read-dir" #{ path: LISTING })))))

241 (assert-true (contains? out "node/rpc-end"))

242 (assert-true (not (contains? out "[WARN]"))))))

243

244;; ===============================================================

245;; 4. JSON output

246;; ===============================================================

247(test-group "operation logging - json"

248

249 ;; The event name must survive as the `message` field. A caller kwarg named

250 ;; `message:` silently overwrites it, because the JSON formatter appends

251 ;; caller fields after the base ones and the last key wins — which shipped

252 ;; once and made `grep '"message":"node/rpc-refused"'` return nothing while

253 ;; the lines were all present. Re-introducing `message:` at that call site

254 ;; makes this arm red.

255 (test "the event name survives as \"message\" on a refusal line"

256 (let ((out (capture-json-at 'debug

257 (lambda () (req 6 "fs/teleport" #{ path: "/x" })))))

258 (assert-true (contains? out "\"message\":\"node/rpc-refused\""))

259 (assert-true (contains? out "\"level\":\"warn\""))

260 (assert-true (contains? out "\"detail\":"))))

261

262 (test "structured fields are json keys, not interpolated prose"

263 (let ((out (capture-json-at 'debug

264 (lambda () (req 8 "fs/stat" #{ path: (path-join LISTING "a.txt") })))))

265 (assert-true (contains? out "\"op\":"))

266 (assert-true (contains? out "\"req-id\":8"))

267 (assert-true (contains? out "\"duration-ms\":"))

268 (assert-true (contains? out "\"verb\":\"fs/stat\"")))))

269

270;; ===============================================================

271;; 5. Lazy macros

272;; ===============================================================

273(test-group "operation logging - laziness"

274

275 ;; Zero OUTPUT does not prove zero EVALUATION — `do-log` gates on the level

276 ;; too, so a non-lazy call would also emit nothing while still evaluating

277 ;; every argument. Only a side effect in an argument slot can tell them

278 ;; apart, and the second arm is the positive control that stops the first

279 ;; from passing vacuously.

280 (test "an inactive level evaluates no argument expressions"

281 (let ((calls (vector 0)))

282 (log-configure! level: 'info target: (open-output-string) format: 'text)

283 (log-debug* "test/lazy" v: (begin (vector-set! calls 0 (+ 1 (vector-ref calls 0))) 1))

284 (assert-equal 0 (vector-ref calls 0))

285 (log-configure! level: 'debug)

286 (log-debug* "test/lazy" v: (begin (vector-set! calls 0 (+ 1 (vector-ref calls 0))) 1))

287 (assert-equal 1 (vector-ref calls 0))

288 (log-configure! level: 6))))

289

290;; ===============================================================

291;; 6. The stream-child deadlock guard

292;; ===============================================================

293;; THE ONE PIECE OF THIS WORK THAT PREVENTS A HANG RATHER THAN IMPROVING A

294;; DIAGNOSTIC, AND IT HAD NO TEST AT ALL.

295;;

296;; `process-spawn` gives a child pipes for stdout and stderr and nothing in

297;; this codebase ever reads them, so a child logging to stderr wedges at

298;; ~64 KiB in `anon_pipe_write` for as long as the parent lives, taking the

299;; user's terminal with it. `stream-child-argv` withholds `--log-level` unless

300;; a file is present — but that guards ARGV, and `SIGIL_LOG_LEVEL` crosses the

301;; spawn untouched, so the guard has to sit in `configure-logging!` where both

302;; routes converge.

303;;

304;; BOTH arms are required. A guard that silences everything passes the first

305;; and is a regression; the second is what catches it.

306(test-group "operation logging - stream child is silent without a file"

307

308 ;; THE FIXTURE HAS TO CARRY A LEVEL, AND THE FIRST VERSION OF IT DID NOT.

309 ;;

310 ;; This arm was written as `(extract-log-opts (list "node" "_stream"))` — no

311 ;; flags at all — asserting silence. It passed. It also passed with the

312 ;; guard clause DELETED, which a sabotage leg proved: with no level from any

313 ;; source the input falls through to `(else (log-configure! level:

314 ;; log-level-silent))`, which silences it anyway. **The arm asserted a

315 ;; property the guard was not responsible for, so it could not fail.**

316 ;;

317 ;; The guard only does work when something is trying to set a level: a

318 ;; `--log-level` with no `--log`, or `SIGIL_LOG_LEVEL`. Those are precisely

319 ;; the two dangerous inputs, and the original fixture used neither. Varying

320 ;; the guard's code could never reveal that, because the inputs were chosen

321 ;; by the same person who chose the guard.

322 ;;

323 ;; So the fixture now carries `--log-level debug` and no `--log`. Delete or

324 ;; reorder the clause and this falls through to `(level ...)`, which

325 ;; configures debug against a stderr target — the deadlock — and the arm

326 ;; goes red.

327 ;;

328 ;; Asserted with `log-level-active?`, not `current-log-level`: at the silent

329 ;; level the latter does `(list-ref *level-names* 6)` and RAISES, which

330 ;; would make this an error rather than a verdict. FATAL is the strongest

331 ;; form of the question that matters — would anything be emitted at all.

332 (test "a stream child given a LEVEL but no file is silenced, up to fatal"

333 (let ((opts (extract-log-opts (list "node" "_stream" "--log-level" "debug"))))

334 (configure-logging! opts 'stream-child)

335 (assert-true (not (log-level-active? 'fatal)))

336 (assert-true (not (log-level-active? 'error)))

337 (assert-true (not (log-level-active? 'debug)))))

338

339 ;; The production route is the ENVIRONMENT, not argv: `stream-child-argv`

340 ;; already withholds `--log-level` unless a file is present, whereas

341 ;; `SIGIL_LOG_LEVEL` crosses the spawn untouched. That route cannot be set

342 ;; up in-process — sigil exposes `getenv` and no `setenv` — so this arm is

343 ;; live only when the SUITE ITSELF is run with the variable set:

344 ;;

345 ;; SIGIL_LOG_LEVEL=debug sigil test --sgl <this file>

346 ;;

347 ;; It reports which case it took rather than passing silently either way,

348 ;; so a green here is not mistaken for coverage that did not run.

349 (test "the env-var route cannot reach around the stream-child guard"

350 (let ((opts (extract-log-opts (list "node" "_stream"))))

351 (configure-logging! opts 'stream-child)

352 (if (getenv "SIGIL_LOG_LEVEL")

353 (begin

354 (display " [env leg LIVE: SIGIL_LOG_LEVEL is set]\n")

355 (assert-true (not (log-level-active? 'fatal))))

356 (begin

357 (display " [env leg SKIPPED: SIGIL_LOG_LEVEL unset — run the suite with it set]\n")

358 (assert-true #t)))))

359

360 (test "a stream child WITH a log file still logs"

361 (let* ((dir (make-temp-directory))

362 (target (path-join dir "child.log"))

363 (opts (extract-log-opts (list "node" "_stream" "--log" target

364 "--log-level" "debug"))))

365 (configure-logging! opts 'stream-child)

366 (log-debug* "test/child-line" note: "must-appear")

367 ;; The child rewrites the path to its own per-pid file.

368 (let ((actual (stream-child-log-path target (process-id))))

369 (assert-true (file-exists? actual))

370 (assert-true (contains? (read-file-string actual) "must-appear")))

371 (log-configure! level: 6))))

372

373;; ===============================================================

374;; 7. Bounding an attacker-controlled field value

375;; ===============================================================

376;; `log-bounded-token` caps the Host header before it reaches the 421 audit

377;; line. It used to substitute `_` for space/`=`/newline as well; sigil-log

378;; 0.17.0 quotes and escapes, which defeats injection LOSSLESSLY, so the

379;; substitution was removed as redundant-and-harmful (it destroyed forensic

380;; detail and suppressed the quoting signal). What quoting does NOT do is

381;; bound length, and the Host header is attacker-controlled pre-auth.

382(test-group "operation logging - attacker-controlled field bound"

383

384 (test "a short value passes through UNCHANGED, escaping left to the logger"

385 ;; The control. If this ever mangles, the lossless-forensics property

386 ;; that justified dropping the substitution is gone.

387 (let ((hostile "x status=200 reason=host-allowed"))

388 (assert-equal hostile (log-bounded-token hostile))))

389

390 (test "a long value is capped AND says that it was"

391 (let* ((long (make-string 400 #\A))

392 (out (log-bounded-token long)))

393 (assert-true (< (string-length out) 200))

394 ;; The marker is the point: without it a value that was exactly 128

395 ;; characters and one cut down from 400 render identically.

396 (assert-true (contains? out "<truncated>"))))

397

398 (test "a non-string degrades rather than raising"

399 ;; It runs on a failing path; a field helper that raises destroys the

400 ;; diagnostic it was building.

401 (assert-equal "<non-string>" (log-bounded-token 42))))