test/uut/forgery-arms.sgl

1;;; Log-forgery tests for (sigil log)'s TEXT formatter.

2;;;

3;;; The text format is the DEFAULT, and before this suite existed a

4;;; string field value was written raw and unquoted after `key=`. Any

5;;; attacker-controlled string could therefore append convincing

6;;; `key=value` pairs — or, with a newline, a whole extra log line — to

7;;; a log entry written about it.

8;;;

9;;; The real attack, and the reason these arms exist: the Slate node's

10;;; anti-DNS-rebinding path answers 421 and logs the request's `Host`

11;;; header. A hostile Host could make a REFUSED request read as ALLOWED

12;;; in the node's own audit line.

13;;;

14;;; EVERY ARM HERE ASSERTS WHAT THE LINE *PARSES AS*, not what it

15;;; contains. A `string-contains?` arm passes this defect forever: the

16;;; forged text is present in both the broken and the fixed rendering,

17;;; only its parse differs.

19(import (sigil test)

20 (sigil log)

21 (sigil io)

22 (sigil string))

24;; ============================================================

25;; A minimal logfmt reader

26;; ============================================================

27;;

28;; Deliberately written the way a log CONSUMER would write one, with no

29;; knowledge of the logger's internals: a key is a run of characters up

30;; to `=`; a value is either a `"`-quoted, backslash-escaped string or a

31;; bare run up to the next space. A bare token containing no `=` (the

32;; prose message) is not a field and is skipped.

34;; Any of these ends a bare token: a log line is one line, and a field

35;; value that is not quoted cannot contain whitespace.

36(define (logfmt-space? c)

37 (or (char=? c #\space) (char=? c #\newline)

38 (char=? c #\return) (char=? c #\tab)))

40(define (parse-logfmt s)

41 (let ((n (string-length s)))

42 (let loop ((i 0) (acc '()))

43 (cond

44 ((>= i n) (reverse acc))

45 ((logfmt-space? (string-ref s i)) (loop (+ i 1) acc))

46 (else

47 (let key-loop ((j i))

48 (cond

49 ((>= j n) (reverse acc))

50 ((logfmt-space? (string-ref s j)) (loop (+ j 1) acc))

51 ((char=? (string-ref s j) #\=)

52 (let ((key (substring s i j)))

53 (if (and (< (+ j 1) n) (char=? (string-ref s (+ j 1)) #\"))

54 (let val-loop ((k (+ j 2)) (out '()))

55 (cond

56 ((>= k n)

57 (loop k (cons (cons key (list->string (reverse out))) acc)))

58 ((char=? (string-ref s k) #\\)

59 (if (< (+ k 1) n)

60 (let ((e (string-ref s (+ k 1))))

61 (if (char=? e #\x)

62 ;; \xHH; — R7RS hex escape, TERMINATED.

63 ;; Reading it properly is what lets an arm

64 ;; tell an escaped control character from

65 ;; the literal letters "xHH".

66 (let hex-loop ((h (+ k 2)) (digits '()))

67 (cond

68 ((>= h n)

69 (val-loop h (cons #\? out)))

70 ((char=? (string-ref s h) #\;)

71 (val-loop

72 (+ h 1)

73 (cons (integer->char

74 (string->number

75 (list->string (reverse digits))

76 16))

77 out)))

78 (else

79 (hex-loop (+ h 1)

80 (cons (string-ref s h) digits)))))

81 (val-loop (+ k 2)

82 (cons (cond ((char=? e #\n) #\newline)

83 ((char=? e #\r) #\return)

84 ((char=? e #\t) #\tab)

85 (else e))

86 out))))

87 (val-loop (+ k 1) out)))

88 ((char=? (string-ref s k) #\")

89 (loop (+ k 1) (cons (cons key (list->string (reverse out))) acc)))

90 (else (val-loop (+ k 1) (cons (string-ref s k) out)))))

91 (let bare-loop ((k (+ j 1)))

92 (if (or (>= k n) (logfmt-space? (string-ref s k)))

93 (loop k (cons (cons key (substring s (+ j 1) k)) acc))

94 (bare-loop (+ k 1)))))))

95 (else (key-loop (+ j 1))))))))))

97;; Capture one text-format log line and return it verbatim.

98(define (capture thunk)

99 (let ((port (open-output-string)))

100 (log-configure! level: 'info format: 'text target: port)

101 (thunk)

102 (get-output-string port)))

103

104;; Parse the fields of a captured line.

105(define (fields-of line)

106 (let ((i (string-find line "] ")))

107 (if i

108 (parse-logfmt (substring line (+ i 2) (string-length line)))

109 '())))

110

111(define (field line key)

112 (let ((hit (assoc key (fields-of line))))

113 (and (pair? hit) (cdr hit))))

114

115(define (count-char s ch)

116 (let ((n (string-length s)))

117 (let loop ((i 0) (c 0))

118 (if (>= i n)

119 c

120 (loop (+ i 1) (if (char=? (string-ref s i) ch) (+ c 1) c))))))

121

122;; ============================================================

123;; The reader itself must be able to fail

124;; ============================================================

125;;

126;; parse-logfmt is the instrument every arm below depends on. If it

127;; silently returned '() for everything, every "no forged field"

128;; assertion would pass for free. These are its positive controls.

129

130(test-group "logfmt reader (instrument controls)"

131 (test "reads bare fields"

132 (let ((f (parse-logfmt "a=1 b=two")))

133 (assert-equal "1" (cdr (assoc "a" f)))

134 (assert-equal "two" (cdr (assoc "b" f)))

135 (assert-equal 2 (length f))))

136

137 (test "reads quoted fields and unescapes them"

138 (let ((f (parse-logfmt "a=\"x y\" b=\"say \\\"hi\\\"\" c=\"one\\ntwo\"")))

139 (assert-equal "x y" (cdr (assoc "a" f)))

140 (assert-equal "say \"hi\"" (cdr (assoc "b" f)))

141 (assert-equal "one\ntwo" (cdr (assoc "c" f)))))

142

143 (test "skips a prose token that is not a field"

144 (let ((f (parse-logfmt "refused host=example port=443")))

145 (assert-false (assoc "refused" f))

146 (assert-equal 2 (length f))))

147

148 (test "DOES see fields hidden in a raw value — the defect, stated"

149 ;; This is what the pre-fix formatter produced. The reader must be

150 ;; able to see the forgery, or it could not detect its absence.

151 (let ((f (parse-logfmt "host-header=evil.example status=200")))

152 (assert-equal "200" (cdr (assoc "status" f))))))

153

154;; ============================================================

155;; Field forgery — the real attack

156;; ============================================================

157

158(test-group "text format: a field value cannot forge fields"

159 (test "the Slate 421 Host-header attack produces ONE field"

160 ;; The shape from packages/slate-cli: a 421 refusal logging the

161 ;; request's Host header, with a Host chosen to make the refusal

162 ;; read as an allow.

163 (let* ((hostile "evil.example status=200 reason=host-allowed")

164 (line (capture (lambda () (log-warn "refused" host-header: hostile)))))

165 (assert-false (field line "status"))

166 (assert-false (field line "reason"))

167 (assert-equal hostile (field line "host-header"))

168 (assert-equal 1 (length (fields-of line)))))

169

170 (test "a value crafted to inject allowed=true does not produce an allowed field"

171 (let* ((hostile "attacker.example allowed=true")

172 (line (capture (lambda () (log-warn "refused" host-header: hostile)))))

173 (assert-false (field line "allowed"))

174 (assert-equal hostile (field line "host-header"))))

175

176 (test "a value cannot forge a field alongside real ones"

177 (let* ((hostile "h status=200")

178 (line (capture (lambda ()

179 (log-warn "refused" host-header: hostile status: 421)))))

180 ;; The genuine status: field must survive and must be the 421 one.

181 (assert-equal "421" (field line "status"))

182 (assert-equal hostile (field line "host-header"))

183 (assert-equal 2 (length (fields-of line)))))

184

185 (test "a value containing a newline cannot forge a whole log line"

186 (let* ((hostile "h\n2026-01-01T00:00:00Z [INFO] request allowed=true")

187 (line (capture (lambda () (log-warn "refused" host-header: hostile)))))

188 ;; One log event is exactly one line: a single trailing newline.

189 (assert-equal 1 (count-char line #\newline))

190 (assert-false (field line "allowed"))

191 (assert-equal hostile (field line "host-header"))))

192

193 (test "a value containing a carriage return cannot split the line"

194 (let* ((hostile "h\r[INFO] allowed=true")

195 (line (capture (lambda () (log-warn "refused" host-header: hostile)))))

196 (assert-equal 0 (count-char line #\return))

197 (assert-false (field line "allowed"))

198 (assert-equal hostile (field line "host-header"))))

199

200 (test "a value containing quotes round-trips and forges nothing"

201 (let* ((hostile "he said \"a=b\" loudly")

202 (line (capture (lambda () (log-warn "refused" host-header: hostile)))))

203 (assert-false (field line "b\""))

204 (assert-equal hostile (field line "host-header"))

205 (assert-equal 1 (length (fields-of line)))))

206

207 (test "a value ending in a backslash does not swallow the closing quote"

208 (let* ((hostile "trailing\\")

209 (line (capture (lambda ()

210 (log-warn "refused" host-header: hostile ok: 1)))))

211 (assert-equal hostile (field line "host-header"))

212 (assert-equal "1" (field line "ok"))))

213

214 (test "a value containing a tab cannot start a new field"

215 (let* ((hostile "h\tallowed=true")

216 (line (capture (lambda () (log-warn "refused" host-header: hostile)))))

217 (assert-false (field line "allowed"))

218 (assert-equal hostile (field line "host-header"))))

219

220 (test "a compound value carrying a hostile string forges nothing"

221 (let ((line (capture (lambda ()

222 (log-warn "refused"

223 detail: (list 1 "x allowed=true" 2))))))

224 (assert-false (field line "allowed"))

225 (assert-equal 1 (length (fields-of line)))))

226

227 (test "an empty value is a present, empty field — not a missing one"

228 (let ((line (capture (lambda () (log-warn "refused" host-header: "" ok: 1)))))

229 (assert-equal "" (field line "host-header"))

230 (assert-equal "1" (field line "ok"))

231 (assert-equal 2 (length (fields-of line))))))

232

233;; ============================================================

234;; The message is prose, and its ONE guarantee

235;; ============================================================

236

237(test-group "text format: message stays on one line"

238 (test "a newline in the message does not become a second line"

239 (let ((line (capture (lambda ()

240 (log-warn "a\n2026-01-01T00:00:00Z [INFO] b" ok: 1)))))

241 (assert-equal 1 (count-char line #\newline))

242 (assert-equal "1" (field line "ok"))))

243

244 (test "ordinary message prose is untouched"

245 (let ((line (capture (lambda () (log-warn "Slow query on /api/v1" ms: 12)))))

246 (assert-true (string-contains? line "Slow query on /api/v1"))

247 (assert-equal "12" (field line "ms")))))

248

249;; ============================================================

250;; Well-formed values must NOT have started being quoted

251;; ============================================================

252;;

253;; Quoting is conditional. If these arms go red, every existing log line

254;; in the estate changed shape and every human reading one has to relearn

255;; the format — which is the cost this design exists to avoid.

256

257(test-group "text format: ordinary values render unquoted, as before"

258 (test "integers"

259 (let ((line (capture (lambda () (log-info "started" port: 8080)))))

260 (assert-true (string-contains? line "port=8080"))

261 (assert-false (string-contains? line "port=\"8080\""))))

262

263 (test "a path"

264 (let ((line (capture (lambda () (log-info "req" path: "/api/v1/things")))))

265 (assert-true (string-contains? line "path=/api/v1/things"))))

266

267 (test "a plain string"

268 (let ((line (capture (lambda () (log-info "req" user: "alice")))))

269 (assert-true (string-contains? line "user=alice"))))

270

271 (test "symbols, booleans and reals"

272 (let ((line (capture (lambda () (log-info "s" v: 'a-symbol flag: #t n: 3.5)))))

273 (assert-true (string-contains? line "v=a-symbol"))

274 (assert-true (string-contains? line "flag=#t"))

275 (assert-true (string-contains? line "n=3.5"))))

276

277 (test "a realistic well-formed Host header is not quoted"

278 (let ((line (capture (lambda () (log-info "req" host-header: "slate.local:8443")))))

279 (assert-true (string-contains? line "host-header=slate.local:8443"))

280 (assert-equal "slate.local:8443" (field line "host-header")))))

281

282;; ============================================================

283;; JSON output was already safe and must stay that way

284;; ============================================================

285

286(test-group "json format is unaffected"

287 (test "a hostile value stays one JSON string"

288 (let* ((hostile "evil.example status=200 reason=host-allowed")

289 (port (open-output-string)))

290 (log-configure! level: 'info format: 'json target: port)

291 (log-warn "refused" host-header: hostile)

292 (let ((out (get-output-string port)))

293 (assert-true (string-contains? out "\"host-header\""))

294 (assert-false (string-contains? out "\"status\"")))

295 (log-configure! format: 'text))))

296

297

298;; ============================================================

299;; KEYS — found by adversarial review, 2026-08-25

300;; ============================================================

301;;

302;; The first version of this fix quoted values and left keys alone, on

303;; the argument that "a key is always a keyword literal written by the

304;; programmer, never a runtime value". THAT ARGUMENT WAS WRONG AND WAS

305;; NEVER PROBED. `string->keyword` accepts any string and is used with

306;; runtime data across the ecosystem, and `(apply log-warn msg kwargs)`

307;; is the natural way to log a dict of attributes. A crafted key forged

308;; both a field and an entire second log line against the "fixed" code.

309

310(test-group "text format: a KEY cannot forge fields or lines"

311 (test "a crafted key cannot inject a second field"

312 (let* ((line (capture

313 (lambda ()

314 (apply log-warn "refused"

315 (list (string->keyword "host status=200 reason=host-allowed")

316 "evil.example")))))

317 (f (fields-of line)))

318 (assert-false (assoc "status" f))

319 (assert-false (assoc "reason" f))

320 (assert-equal 1 (length f))))

321

322 (test "a crafted key cannot forge a whole log line"

323 (let ((line (capture

324 (lambda ()

325 (apply log-warn "refused"

326 (list (string->keyword

327 "h\n2026-01-01T00:00:00Z [INFO] request allowed=true from")

328 "evil.example"))))))

329 (assert-equal 1 (count-char line #\newline))

330 (assert-false (field line "allowed"))))

331

332 (test "a crafted key cannot smuggle a quote"

333 (let ((line (capture

334 (lambda ()

335 (apply log-info "m"

336 (list (string->keyword "a\"b") "v"))))))

337 (assert-false (string-contains? line "a\"b"))

338 (assert-equal "v" (field line "a_b"))))

339

340 (test "an ordinary keyword key is untouched"

341 (let ((line (capture (lambda () (log-info "m" host-header: "x")))))

342 (assert-true (string-contains? line "host-header=x")))))

343

344;; ============================================================

345;; Separators a NON-ASCII log reader honours

346;; ============================================================

347;;

348;; Python's str.splitlines() splits on U+0085, U+2028 and U+2029, and

349;; str.split() additionally on U+00A0 and U+3000. Left raw, those forge

350;; an event for a Python consumer while looking innocent in a terminal.

351

352(test-group "text format: unicode separators do not split a line"

353 (test "U+2028 in a value is escaped"

354 (let* ((hostile (string-append "h" (string (integer->char 8232)) "allowed=true"))

355 (line (capture (lambda () (log-warn "refused" host-header: hostile)))))

356 (assert-false (string-contains? line (string (integer->char 8232))))

357 (assert-equal hostile (field line "host-header"))))

358

359 (test "U+0085 in a MESSAGE is escaped"

360 (let ((line (capture

361 (lambda ()

362 (log-warn (string-append "a" (string (integer->char 133))

363 "2026-01-01T00:00:00Z [INFO] allowed=true")

364 ok: 1)))))

365 (assert-false (string-contains? line (string (integer->char 133))))

366 (assert-equal "1" (field line "ok"))))

367

368 (test "U+2029 in a MESSAGE is escaped"

369 (let ((line (capture

370 (lambda ()

371 (log-warn (string-append "a" (string (integer->char 8233)) "b") ok: 1)))))

372 (assert-false (string-contains? line (string (integer->char 8233))))))

373

374 (test "U+00A0 in a value forces quoting"

375 (let* ((v (string-append "a" (string (integer->char 160)) "b"))

376 (line (capture (lambda () (log-info "m" k: v)))))

377 (assert-equal v (field line "k"))

378 (assert-true (string-contains? line "k=\""))))

379

380 (test "ordinary non-ASCII text is NOT byte-escaped"

381 ;; `write` renders "café au lait" as "caf\xC3\xA9 au lait". A log a

382 ;; human has to read must not do that.

383 (let ((line (capture (lambda () (log-info "m" city: "café au lait")))))

384 (assert-true (string-contains? line "café au lait"))

385 (assert-equal "café au lait" (field line "city")))))

386

387;; ============================================================

388;; MESSAGE escaping — the generic control-char rule

389;; ============================================================

390;;

391;; Deleting the generic `(or (< k 32) (= k 127))` branch left every arm

392;; green, because only newline, CR and tab were ever exercised.

393

394(test-group "text format: message control characters"

395 (test "an ESC in a message does not reach the terminal raw"

396 (let ((line (capture (lambda () (log-info (string (integer->char 27)) ok: 1)))))

397 (assert-false (string-contains? line (string (integer->char 27))))

398 (assert-equal "1" (field line "ok"))))

399

400 (test "a NUL in a message is escaped"

401 (let ((line (capture (lambda () (log-info (string (integer->char 0)) ok: 1)))))

402 (assert-false (string-contains? line (string (integer->char 0))))))

403

404 (test "a DEL in a message is escaped"

405 (let ((line (capture (lambda () (log-info (string (integer->char 127)) ok: 1)))))

406 (assert-false (string-contains? line (string (integer->char 127))))))

407

408 (test "a non-string message still produces a log line"

409 ;; It used to produce NOTHING: string-append raised, the fallback

410 ;; raised the same way, and the entire event vanished silently.

411 (let ((line (capture (lambda () (log-info 'a-symbol ok: 1)))))

412 (assert-true (string-contains? line "a-symbol"))

413 (assert-equal "1" (field line "ok")))))

414

415;; ============================================================

416;; Rendering assertions that the parse-level arms cannot make

417;; ============================================================

418;;

419;; The empty-value arm above asserts a PARSE, and `host-header= ok=1`

420;; parses identically to `host-header="" ok=1` — so it could not go red

421;; when the empty-value rule was deleted. These assert the bytes.

422

423(test-group "text format: exact rendering"

424 (test "an empty value renders as two quotes, not as nothing"

425 (let ((line (capture (lambda () (log-info "m" k: "" ok: 1)))))

426 (assert-true (string-contains? line "k=\"\" ok=1"))))

427

428 (test "a value needing quotes renders with them"

429 (let ((line (capture (lambda () (log-info "m" k: "a b")))))

430 (assert-true (string-contains? line "k=\"a b\""))))

431

432 (test "a value not needing quotes renders without them"

433 (let ((line (capture (lambda () (log-info "m" k: "ab")))))

434 (assert-true (string-contains? line "k=ab"))

435 (assert-false (string-contains? line "k=\"ab\""))))

436

437 (test "a control character is escaped in the terminated R7RS form"

438 (let ((line (capture (lambda () (log-info "m" k: (string (integer->char 7)))))))

439 (assert-true (string-contains? line "\\x7;")))))

440

441(run-tests)