packages/sigil-cli/test/test-registry-bridge.sgl

1;;; Tests for the verified toolchain index behind `sigil cli upgrade`/`use`

2;;; ((sigil cli manager registry)).

3;;;

4;;; Two kinds of evidence:

5;;;

6;;; * REAL BYTES. test/fixtures/registry-toolchain/ holds registry.json and

7;;; the toolchain index as served by the staging registry (signed with

8;;; the `minisign` program, fixture root DC8855833C274BE8), and

9;;; production's registry.json (the real root, C45E1150D2D3F55A). They

10;;; prove the in-process verifier accepts what minisign produced.

11;;;

12;;; * THROWAWAY KEYS. Every attack case needs a document signed by the

13;;; wrong key, or with the wrong binding, which no real key holder will

14;;; produce. `sign` below writes minisign signatures with Ed25519 keys

15;;; derived from fixed seeds, so no key file exists anywhere. The

16;;; happy-path case over those keys is the control that the signer

17;;; itself is right: without it, every refusal below could be the signer

18;;; failing rather than the check firing.

19;;;

20;;; Each attack case asserts the outcome TAG ('refused, never 'unreachable)

21;;; and a message fragment that only the intended check produces.

22

23(import (sigil test)

24 (sigil core)

25 (sigil io)

26 (sigil fs)

27 (sigil path)

28 (sigil string)

29 (sigil process)

30 (sigil crypto)

31 (sigil crypto minisign)

32 (sigil cli manager registry))

33

34;; ============================================================

35;; Fixtures

36;; ============================================================

37

38(define fixture-dir "test/fixtures/registry-toolchain")

39(define (fixture . parts) (read-file-bytes (apply path-join fixture-dir parts)))

40

41(define fixture-root "RWToSyc8g1WI3P0eYKcMcKGJCkje2w1LLPKLrnbJKu1UMXY0y9/QGsHO")

42(define production-root "RWRa9dPSUBFexBbLdzZIfuAmuCYL736UeHC7IbdAOIYpgGIyDmWRaQHY")

43

44;; ============================================================

45;; A minisign signer over seed-derived keys (tests only)

46;; ============================================================

47

48(define (bv-append . parts)

49 (let* ((total (apply + (map bytevector-length parts)))

50 (out (make-bytevector total 0)))

51 (let loop ((parts parts) (at 0))

52 (if (null? parts)

53 out

54 (begin

55 (bytevector-copy! out at (car parts))

56 (loop (cdr parts) (+ at (bytevector-length (car parts)))))))))

57

58;; A key is (seed key-id-bytes public-key-bytes).

59(define (make-key n)

60 (let ((seed (make-bytevector 32 n)))

61 (list seed (make-bytevector 8 (+ n 100)) (ed25519-public-key seed))))

62

63(define (key-public k)

64 (base64-encode (bv-append (bytevector 69 100) (cadr k) (caddr k))))

65

66(define (key-id k)

67 (minisign-public-key-id (minisign-parse-public-key (key-public k))))

68

69;; A `.minisig` over BYTES with trusted comment COMMENT, prehashed ("ED").

70(define (sign k bytes comment)

71 (let* ((sig (ed25519-sign (car k) (blake2b-512 bytes)))

72 (global (ed25519-sign (car k) (bv-append sig (string->utf8 comment)))))

73 (string->utf8

74 (string-append "untrusted comment: test signature\n"

75 (base64-encode (bv-append (bytevector 69 68) (cadr k) sig)) "\n"

76 "trusted comment: " comment "\n"

77 (base64-encode global) "\n"))))

78

79(define (comment path seq)

80 (string-append "registry=pkg.usesigil.org path=" path

81 " seq=" (number->string seq) " ts=2026-09-24T00:00:00Z"))

82

83(define root (make-key 1))

84(define toolchain (make-key 2))

85(define index-key (make-key 3))

86(define stranger (make-key 4))

87(define revoked (make-key 5))

88(define retired (make-key 6))

89

90(define (key-json k roles status . extra)

91 (string-append "{\"id\":\"" (key-id k) "\",\"algorithm\":\"minisign-ed25519\","

92 "\"roles\":[" (string-join (map (lambda (r) (string-append "\"" r "\"")) roles) ",")

93 "],\"public-key\":\"" (key-public k) "\",\"status\":\"" status "\""

94 (apply string-append extra) "}"))

95

96(define standard-keys

97 (list (key-json root '("root") "active")

98 (key-json toolchain '("toolchain") "active")

99 (key-json index-key '("index") "active")))

100

101(define (registry-bytes seq keys)

102 (string->utf8

103 (string-append "{\"schema\":1,\"protocol\":1,\"registry\":\"pkg.usesigil.org\","

104 "\"seq\":" (number->string seq) ",\"updated\":\"2026-09-24T00:00:00Z\","

105 "\"keys\":[" (string-join keys ",") "],\"log\":null,\"reproducibility\":null}")))

106

107(define (index-bytes seq . opts)

108 (let ((schema (if (pair? opts) (car opts) 1)))

109 (string->utf8

110 (string-append

111 "{\"schema\":" (number->string schema) ",\"name\":\"sigil\",\"latest\":\"0.22.7\","

112 "\"seq\":" (number->string seq) ",\"updated\":\"2026-09-24T00:00:00Z\","

113 "\"versions\":{\"0.22.7\":{\"published\":\"2026-09-24T00:00:00Z\",\"seq\":"

114 (number->string seq) ",\"platforms\":{\"linux-amd64-static\":{\"artifact\":"

115 "\"sigil-linux-amd64-static\",\"size\":3,\"source\":\"sha256:"

116 "039058c6f2c0cb492c533b0a4d14ef77cc0f78abccced5287d84a1a2011cfb81\"}}}}}"))))

117

118;; A registry: an alist from path to fetch outcome, served by `fetcher`.

119(define (serve reg reg-sig idx idx-sig)

120 (list (cons "/v1/meta/registry.json" (cons 'ok reg))

121 (cons "/v1/meta/registry.json.minisig" (cons 'ok reg-sig))

122 (cons "/v1/toolchain/index.json" (cons 'ok idx))

123 (cons "/v1/toolchain/index.json.minisig" (cons 'ok idx-sig))))

124

125(define (fetcher site)

126 (lambda (path)

127 (let ((entry (assoc path site)))

128 (if entry (cdr entry) (cons 'missing (string-append path " 404"))))))

129

130(define (with-path site path outcome)

131 (cons (cons path outcome) (filter (lambda (e) (not (string=? (car e) path))) site)))

132

133(define good-reg (registry-bytes 10 standard-keys))

134(define good-reg-sig (sign root good-reg (comment "/v1/meta/registry.json" 10)))

135(define good-idx (index-bytes 700))

136(define good-idx-sig (sign toolchain good-idx (comment "/v1/toolchain/index.json" 700)))

137(define good-site (serve good-reg good-reg-sig good-idx good-idx-sig))

138

139;; Rollback memory is keyed by the root key that verified registry.json.

140(define scope (key-id root))

141

142;; Every (root-id path seq) the loader asked to record, newest first.

143(define recorded (list))

144(define (record! root-id path seq) (set! recorded (cons (list root-id path seq) recorded)))

145

146(define (load-site site . opts)

147 (let ((seen (if (pair? opts) (car opts) '())))

148 (load-verified-toolchain-index (fetcher site) (list (key-public root)) seen record!)))

149

150(define (flip bytes at)

151 (let ((copy (bytevector-copy bytes)))

152 (bytevector-u8-set! copy at (modulo (+ 1 (bytevector-u8-ref copy at)) 256))

153 copy))

154

155(define (assert-refused result fragment)

156 (assert-equal 'refused (car result))

157 (unless (string-contains? (cdr result) fragment)

158 (error (string-append "refusal message should mention: " fragment

159 " -- got: " (if (string? (cdr result)) (cdr result) "?")))))

160

161;; ============================================================

162;; Real bytes, signed by the minisign program

163;; ============================================================

164

165(test-group "real registry documents"

166 (test "staging registry.json verifies under the fixture root"

167 (let ((r (verify-registry-metadata (fixture "staging" "registry.json")

168 (fixture "staging" "registry.json.minisig")

169 (list fixture-root) 0)))

170 (assert-equal 'ok (car r))

171 (assert-equal 122 (caddr (cdr r)))))

172

173 (test "staging toolchain index verifies under staging's toolchain key"

174 (let* ((meta (verify-registry-metadata (fixture "staging" "registry.json")

175 (fixture "staging" "registry.json.minisig")

176 (list fixture-root) 0))

177 (r (verify-toolchain-index (fixture "staging" "toolchain-index.json")

178 (fixture "staging" "toolchain-index.json.minisig")

179 (cadr (cdr meta)) 0)))

180 (assert-equal 'ok (car r))

181 (assert-equal "0.22.4" (toolchain-latest (cadr r)))

182 (assert-equal 631 (caddr r))))

183

184 (test "production registry.json verifies under the production root"

185 (let ((r (verify-registry-metadata (fixture "production" "registry.json")

186 (fixture "production" "registry.json.minisig")

187 (list production-root) 0)))

188 (assert-equal 'ok (car r))

189 (assert-equal 1 (caddr (cdr r)))))

190

191 (test "a build that trusts only the production root refuses staging"

192 (assert-refused (verify-registry-metadata (fixture "staging" "registry.json")

193 (fixture "staging" "registry.json.minisig")

194 (list production-root) 0)

195 "not signed by a root key this build trusts"))

196

197 (test "by default even this dev build trusts only the real root for upgrades"

198 (assert-refused (verify-registry-metadata (fixture "staging" "registry.json")

199 (fixture "staging" "registry.json.minisig")

200 (toolchain-trust-anchors-for #f) 0)

201 "not signed by a root key this build trusts"))

202

203 (test "with the test-root switch, this dev build accepts staging (the fixture root is compiled in)"

204 (assert-equal 'ok (car (verify-registry-metadata

205 (fixture "staging" "registry.json")

206 (fixture "staging" "registry.json.minisig")

207 (toolchain-trust-anchors-for #t) 0)))))

208

209(test-group "version keys (contract §1.6)"

210 (test "release versions are valid"

211 (assert-true (valid-version-key? "0.22.7"))

212 (assert-true (valid-version-key? "10.0.0")))

213 (test "anything else is not"

214 (for-each (lambda (v) (assert-false (valid-version-key? v)))

215 (list "../bin" "0.22" "0.22.7.1" "v0.22.7" "0.22.07" "0.22.7-rc1" "" "0..7" "a.b.c"))))

216

217;; ============================================================

218;; The chain, over throwaway keys

219;; ============================================================

220

221(test-group "the chain accepts a correctly signed registry"

222 (test "control: the test signer's documents verify end to end"

223 (let ((r (load-site good-site)))

224 (assert-equal 'ok (car r))

225 (assert-equal "0.22.7" (toolchain-latest (cadr r)))

226 (assert-equal 10 (caddr r))

227 (assert-equal 700 (cadddr r))))

228

229 (test "seq equal to the highest seen is accepted"

230 (let ((seen (record-seen-seq

231 (record-seen-seq '() scope "/v1/meta/registry.json" 10)

232 scope "/v1/toolchain/index.json" 700)))

233 (assert-equal 'ok (car (load-site good-site seen))))))

234

235(test-group "tampering is refused, never treated as an outage"

236 (test "a tampered toolchain index"

237 (assert-refused (load-site (with-path good-site "/v1/toolchain/index.json"

238 (cons 'ok (flip good-idx 40))))

239 "not signed by any toolchain key"))

240

241 (test "a tampered registry.json"

242 (assert-refused (load-site (with-path good-site "/v1/meta/registry.json"

243 (cons 'ok (flip good-reg 30))))

244 "not signed by a root key"))

245

246 (test "an index signed by a key registry.json does not list"

247 (assert-refused (load-site (with-path good-site "/v1/toolchain/index.json.minisig"

248 (cons 'ok (sign stranger good-idx

249 (comment "/v1/toolchain/index.json" 700)))))

250 "not signed by any toolchain key"))

251

252 (test "registry.json signed by the toolchain key (only the root may sign it)"

253 (assert-refused (load-site (with-path good-site "/v1/meta/registry.json.minisig"

254 (cons 'ok (sign toolchain good-reg

255 (comment "/v1/meta/registry.json" 10)))))

256 "not signed by a root key"))

257

258 (test "an index signed by the root key (root is not a toolchain key)"

259 (assert-refused (load-site (with-path good-site "/v1/toolchain/index.json.minisig"

260 (cons 'ok (sign root good-idx

261 (comment "/v1/toolchain/index.json" 700)))))

262 "not signed by any toolchain key"))

263

264 (test "an index signed by the index-role key"

265 (assert-refused (load-site (with-path good-site "/v1/toolchain/index.json.minisig"

266 (cons 'ok (sign index-key good-idx

267 (comment "/v1/toolchain/index.json" 700)))))

268 "not signed by any toolchain key"))

269

270 (test "a signature bound to another path (cross-path replay)"

271 (assert-refused (load-site (with-path good-site "/v1/toolchain/index.json.minisig"

272 (cons 'ok (sign toolchain good-idx

273 (comment "/v1/meta/registry.json" 700)))))

274 "is bound to path"))

275

276 (test "a signature bound to another registry"

277 (assert-refused (load-site (with-path good-site "/v1/toolchain/index.json.minisig"

278 (cons 'ok (sign toolchain good-idx

279

                                                     "registry=evil.example path=/v1/toolchain/index.json seq=700 ts=2026-09-24T00:00:00Z"))))

280 "is bound to registry"))

281

282 (test "a signature without ts="

283 (assert-refused (load-site (with-path good-site "/v1/toolchain/index.json.minisig"

284 (cons 'ok (sign toolchain good-idx

285

                                                     "registry=pkg.usesigil.org path=/v1/toolchain/index.json seq=700"))))

286 "has no ts="))

287

288 (test "a signature with a repeated field"

289 (assert-refused (load-site (with-path good-site "/v1/toolchain/index.json.minisig"

290 (cons 'ok (sign toolchain good-idx

291 (string-append (comment "/v1/toolchain/index.json" 700)

292 " path=/v1/toolchain/index.json")))))

293 "repeats a trusted-comment field"))

294

295 (test "a signed seq that differs from the document's seq"

296 (assert-refused (load-site (with-path good-site "/v1/toolchain/index.json.minisig"

297 (cons 'ok (sign toolchain good-idx

298 (comment "/v1/toolchain/index.json" 701)))))

299 "but its signature says seq"))

300

301 (test "seq=0 is not a valid seq"

302 (let* ((idx (index-bytes 0)))

303 (assert-refused (load-site (serve good-reg good-reg-sig idx

304 (sign toolchain idx (comment "/v1/toolchain/index.json" 0))))

305 "has no valid seq="))))

306

307;; An index made of RAW json text, correctly signed, for the structure checks.

308(define (signed-index-site json)

309 (let ((idx (string->utf8 json)))

310 (serve good-reg good-reg-sig idx

311 (sign toolchain idx (comment "/v1/toolchain/index.json" 700)))))

312

313(define (index-json latest version source)

314 (string-append

315 "{\"schema\":1,\"name\":\"sigil\",\"latest\":\"" latest "\",\"seq\":700,"

316 "\"updated\":\"2026-09-24T00:00:00Z\",\"versions\":{\"" version "\":{"

317 "\"published\":\"2026-09-24T00:00:00Z\",\"seq\":700,\"platforms\":{"

318 "\"linux-amd64\":{\"artifact\":\"sigil-linux-amd64\",\"size\":3,\"source\":\""

319 source "\"}}}}}"))

320

321(define good-source

322 "sha256:ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad")

323

324(define (index-sig-with text)

325 (with-path good-site "/v1/toolchain/index.json.minisig"

326 (cons 'ok (sign toolchain good-idx text))))

327

328(test-group "bindings are exact matches"

329 (test "a path with a suffix"

330 (assert-refused (load-site (index-sig-with

331

                                 "registry=pkg.usesigil.org path=/v1/toolchain/index.json.evil seq=700 ts=2026-09-24T00:00:00Z"))

332 "is bound to path"))

333

334 (test "a registry with a suffix"

335 (assert-refused (load-site (index-sig-with

336

                                 "registry=pkg.usesigil.org.evil path=/v1/toolchain/index.json seq=700 ts=2026-09-24T00:00:00Z"))

337 "is bound to registry"))

338

339 (test "an empty ts="

340 (assert-refused (load-site (index-sig-with

341 "registry=pkg.usesigil.org path=/v1/toolchain/index.json seq=700 ts="))

342 "has no ts="))

343

344 (test "a seq with a sign"

345 (assert-refused (load-site (index-sig-with

346

                                 "registry=pkg.usesigil.org path=/v1/toolchain/index.json seq=+700 ts=2026-09-24T00:00:00Z"))

347 "has no valid seq="))

348

349 (test "a seq with trailing junk"

350 (assert-refused (load-site (index-sig-with

351

                                 "registry=pkg.usesigil.org path=/v1/toolchain/index.json seq=700a ts=2026-09-24T00:00:00Z"))

352 "has no valid seq=")))

353

354(test-group "structure of signed documents"

355 (test "control: a hand-written index with the same shape verifies"

356 (assert-equal 'ok (car (load-site (signed-index-site (index-json "0.22.7" "0.22.7" good-source))))))

357

358 (test "a version key that is not X.Y.Z (it would become a directory name)"

359 (assert-refused (load-site (signed-index-site (index-json "../bin" "../bin" good-source)))

360 "invalid version key"))

361

362 (test "latest that is not one of the versions"

363 (assert-refused (load-site (signed-index-site (index-json "0.22.8" "0.22.7" good-source)))

364 "latest is not one of its versions"))

365

366 (test "a platform whose source is not a CAS ref"

367 (assert-refused (load-site (signed-index-site (index-json "0.22.7" "0.22.7" "sha256:XYZ")))

368 "has an invalid source"))

369

370 (test "registry.json naming another registry"

371 (let ((reg (string->utf8 (string-replace (utf8->string good-reg)

372 "\"registry\":\"pkg.usesigil.org\""

373 "\"registry\":\"evil.example\""))))

374 (assert-refused (load-site (serve reg (sign root reg (comment "/v1/meta/registry.json" 10))

375 good-idx good-idx-sig))

376 "names a registry other than"))))

377

378;; The eleven platform keys the release emitter publishes (0.22.6). Windows

379;; is the one whose artifact file name differs from its key.

380(define release-platforms

381 (list "android-arm64" "freebsd-amd64" "linux-amd64" "linux-amd64-static" "linux-arm64"

382 "macos-amd64" "macos-arm64" "netbsd-amd64" "openbsd-amd64" "openbsd-arm64"

383 "windows-amd64"))

384

385(define (artifact-name key)

386 (if (string=? key "windows-amd64") "sigil-windows-amd64.exe" (string-append "sigil-" key)))

387

388(define all-platforms-json

389 (string-append

390 "{\"schema\":1,\"name\":\"sigil\",\"latest\":\"0.22.6\",\"seq\":700,"

391 "\"updated\":\"2026-09-24T00:00:00Z\",\"versions\":{\"0.22.6\":{"

392 "\"published\":\"2026-09-24T00:00:00Z\",\"seq\":700,\"platforms\":{"

393 (string-join

394 (map (lambda (key)

395 (string-append "\"" key "\":{\"artifact\":\"" (artifact-name key)

396 "\",\"size\":3,\"source\":\"" good-source "\"}"))

397 release-platforms)

398 ",")

399 "}}}}"))

400

401(test-group "platforms are looked up by key, never by artifact file name"

402 (test "an index with all eleven release platforms verifies"

403 (let ((r (load-site (signed-index-site all-platforms-json))))

404 (assert-equal 'ok (car r))

405 (assert-equal (length release-platforms)

406 (length (toolchain-entry-platforms

407 (toolchain-version-entry (cadr r) "0.22.6"))))))

408

409 (test "windows-amd64 is found by its key, although its artifact is sigil-windows-amd64.exe"

410 (let* ((r (load-site (signed-index-site all-platforms-json)))

411 (entry (toolchain-version-entry (cadr r) "0.22.6"))

412 (windows (toolchain-entry-platform entry "windows-amd64")))

413 (assert-true windows)

414 (assert-equal good-source (platform-source windows))

415 (assert-false (toolchain-entry-platform entry "sigil-windows-amd64.exe"))

416 (assert-false (toolchain-entry-platform entry "windows-amd64.exe"))))

417

418 (test "every release platform key resolves"

419 (let* ((r (load-site (signed-index-site all-platforms-json)))

420 (entry (toolchain-version-entry (cadr r) "0.22.6")))

421 (for-each (lambda (key) (assert-true (toolchain-entry-platform entry key)))

422 release-platforms))))

423

424(test-group "signature fetches"

425 (test "registry.json served without its signature is refused"

426 (assert-refused (load-site (with-path good-site "/v1/meta/registry.json.minisig"

427 (cons 'missing "404")))

428 "without its signature"))

429

430 (test "a signature that fails with a server error is an outage, not a refusal"

431 (assert-equal 'unreachable

432 (car (load-site (with-path good-site "/v1/toolchain/index.json.minisig"

433 (cons 'unreachable "HTTP 503")))))))

434

435(test-group "rollback"

436 (test "a toolchain index older than one already seen"

437 (assert-refused (load-site good-site (record-seen-seq '() scope "/v1/toolchain/index.json" 701))

438 "went backwards"))

439

440 (test "a registry.json older than one already seen"

441 (assert-refused (load-site good-site (record-seen-seq '() scope "/v1/meta/registry.json" 11))

442 "went backwards"))

443

444 (test "seqs seen under another root do not apply"

445 (assert-equal 'ok (car (load-site good-site

446 (record-seen-seq '() (key-id stranger)

447 "/v1/toolchain/index.json" 9999)))))

448

449 (test "both verified seqs are recorded, under the verifying root"

450 (set! recorded (list))

451 (load-site good-site)

452 (assert-true (and (member (list scope "/v1/meta/registry.json" 10) recorded) #t))

453 (assert-true (and (member (list scope "/v1/toolchain/index.json" 700) recorded) #t)))

454

455 (test "a verified registry.json is recorded even when the index is then missing"

456 (set! recorded (list))

457 (let ((r (load-site (with-path good-site "/v1/toolchain/index.json" (cons 'missing "404")))))

458 (assert-equal 'unreachable (car r))

459 (assert-true (and (member (list scope "/v1/meta/registry.json" 10) recorded) #t))))

460

461 (test "nothing is recorded for a registry.json that fails verification"

462 (set! recorded (list))

463 (load-site (with-path good-site "/v1/meta/registry.json" (cons 'ok (flip good-reg 30))))

464 (assert-equal '() recorded)))

465

466(test-group "key status in registry.json"

467 (test "an index signed by a revoked toolchain key is refused as hostile"

468 (let* ((reg (registry-bytes 10 (list (key-json root '("root") "active")

469 (key-json revoked '("toolchain") "revoked"))))

470 (site (serve reg (sign root reg (comment "/v1/meta/registry.json" 10))

471 good-idx (sign revoked good-idx (comment "/v1/toolchain/index.json" 700)))))

472 (assert-refused (load-site site) "revoked key")))

473

474 (test "a retired key still verifies documents below its status-seq"

475 (let* ((reg (registry-bytes 10 (list (key-json root '("root") "active")

476 (key-json retired '("toolchain") "retired"

477 ",\"status-seq\":701"))))

478 (site (serve reg (sign root reg (comment "/v1/meta/registry.json" 10))

479 good-idx (sign retired good-idx (comment "/v1/toolchain/index.json" 700)))))

480 (assert-equal 'ok (car (load-site site)))))

481

482 (test "a retired key does not verify documents at or after its status-seq"

483 (let* ((reg (registry-bytes 10 (list (key-json root '("root") "active")

484 (key-json retired '("toolchain") "retired"

485 ",\"status-seq\":700"))))

486 (site (serve reg (sign root reg (comment "/v1/meta/registry.json" 10))

487 good-idx (sign retired good-idx (comment "/v1/toolchain/index.json" 700)))))

488 (assert-refused (load-site site) "not signed by any toolchain key")))

489

490 (test "a key whose id does not match its public key"

491 (let* ((bad (string-append "{\"id\":\"0000000000000000\",\"algorithm\":\"minisign-ed25519\","

492 "\"roles\":[\"toolchain\"],\"public-key\":\"" (key-public toolchain)

493 "\",\"status\":\"active\"}"))

494 (reg (registry-bytes 10 (list (key-json root '("root") "active") bad)))

495 (site (serve reg (sign root reg (comment "/v1/meta/registry.json" 10))

496 good-idx good-idx-sig)))

497 (assert-refused (load-site site) "whose public-key has id"))))

498

499(test-group "documents this client does not understand"

500 (test "an unsupported toolchain index schema"

501 (let ((idx (index-bytes 700 2)))

502 (assert-refused (load-site (serve good-reg good-reg-sig idx

503 (sign toolchain idx (comment "/v1/toolchain/index.json" 700))))

504 "unsupported schema"))))

505

506;; ============================================================

507;; What falls back to Codeberg, and what does not

508;; ============================================================

509

510(test-group "the registry did not serve it: unreachable, so the caller may fall back"

511 (test "registry.json cannot be fetched"

512 (let ((r (load-site (with-path good-site "/v1/meta/registry.json"

513 (cons 'unreachable "could not connect")))))

514 (assert-equal 'unreachable (car r))))

515

516 (test "no toolchain index yet (HTTP 404, production before the ceremony)"

517 (let ((r (load-site (with-path good-site "/v1/toolchain/index.json"

518 (cons 'missing "404")))))

519 (assert-equal 'unreachable (car r))))

520

521 (test "a server error on the toolchain index"

522 (let ((r (load-site (with-path good-site "/v1/toolchain/index.json"

523 (cons 'unreachable "HTTP 503")))))

524 (assert-equal 'unreachable (car r)))))

525

526(test-group "the registry served something wrong: refused, no fallback"

527 (test "a served document whose signature is 404"

528 (assert-refused (load-site (with-path good-site "/v1/toolchain/index.json.minisig"

529 (cons 'missing "404")))

530 "without its signature"))

531

532 (test "a signature file that is not minisign"

533 (assert-refused (load-site (with-path good-site "/v1/meta/registry.json.minisig"

534 (cons 'ok (string->utf8 "not a signature\n"))))

535 "not a valid minisign signature file")))

536

537(test-group "a verified index that lacks what was asked for is not a refusal"

538 (test "a version the index does not carry"

539 (let ((r (load-site good-site)))

540 (assert-equal 'ok (car r))

541 (assert-false (toolchain-version-entry (cadr r) "0.21.0"))

542 (assert-true (toolchain-version-entry (cadr r) "0.22.7"))))

543

544 (test "a platform the release does not carry"

545 (let* ((r (load-site good-site))

546 (entry (toolchain-version-entry (cadr r) "0.22.7")))

547 (assert-false (toolchain-entry-platform entry "macos-arm64"))

548 (assert-true (toolchain-entry-platform entry "linux-amd64-static")))))

549

550;; ============================================================

551;; The downloaded binary

552;; ============================================================

553

554;; A fresh directory per run: mktemp, not a fixed name, so two runs never share it.

555(define scratch

556 (string-trim (process-output->string "mktemp" "-d" "-t" "sigil-registry-bridge.XXXXXX")))

557

558(define abc-source "sha256:ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad")

559

560(define (artifact-with bytes)

561 (make-directory-recursive* scratch)

562 (let ((p (path-join scratch "artifact")))

563 (write-file-bytes p bytes)

564 p))

565

566(define (make-directory-recursive* dir)

567 (unless (file-exists? dir) (make-directory dir)))

568

569(test-group "the binary must match the index's hash and size"

570 (test "control: the right bytes pass"

571 (assert-equal 'ok (car (verify-artifact-file (artifact-with (string->utf8 "abc"))

572 abc-source 3))))

573

574 (test "one changed byte is a hash mismatch"

575 (assert-refused (verify-artifact-file (artifact-with (string->utf8 "abd")) abc-source 3)

576 "has sha256"))

577

578 (test "a wrong length is refused"

579 (assert-refused (verify-artifact-file (artifact-with (string->utf8 "abcd")) abc-source 3)

580 "bytes; the index says 3")))

581

582;; ============================================================

583;; Rollback state on disk

584;; ============================================================

585

586(test-group "seen-seq state"

587 (test "round-trips through the file and never lowers"

588 (make-directory-recursive* scratch)

589 (let ((file (path-join scratch "registry-seen-seq")))

590 (record-seen-seq! file scope "/v1/toolchain/index.json" 700)

591 (record-seen-seq! file scope "/v1/toolchain/index.json" 5)

592 (let ((back (read-seen-seqs file)))

593 (assert-equal 700 (seen-seq back scope "/v1/toolchain/index.json"))

594 (assert-equal 0 (seen-seq back scope "/v1/meta/registry.json")))))

595

596 (test "a damaged line is ignored, the rest is kept"

597 (let ((file (path-join scratch "registry-seen-seq-damaged")))

598 (write-file-string file (string-append "garbage\n" scope " /v1/meta/registry.json 12\n"

599 scope " /v1/toolchain/index.json x\n"))

600 (let ((back (read-seen-seqs file)))

601 (assert-equal 12 (seen-seq back scope "/v1/meta/registry.json"))

602 (assert-equal 0 (seen-seq back scope "/v1/toolchain/index.json"))))))

603

604;; An entry must name its own platform's artifact. The download is checked

605;; against the hash in the same entry, so a signed index that maps one

606;; platform to another platform's file would pass that check and install the

607;; wrong binary; only the name can catch it.

608(define (index-with-artifact key artifact)

609 (string-append

610 "{\"schema\":1,\"name\":\"sigil\",\"latest\":\"0.22.6\",\"seq\":700,"

611 "\"updated\":\"2026-09-24T00:00:00Z\",\"versions\":{\"0.22.6\":{"

612 "\"published\":\"2026-09-24T00:00:00Z\",\"seq\":700,\"platforms\":{"

613 (string-join

614 (map (lambda (k)

615 (string-append "\"" k "\":{\"artifact\":\""

616 (if (string=? k key) artifact (artifact-name k))

617 "\",\"size\":3,\"source\":\"" good-source "\"}"))

618 release-platforms)

619 ",")

620 "}}}}"))

621

622(test-group "a platform entry must name its own artifact"

623 (test "control: every entry naming its own artifact verifies"

624 (assert-equal 'ok (car (load-site (signed-index-site

625 (index-with-artifact "macos-arm64" "sigil-macos-arm64"))))))

626

627 (test "macos-arm64 naming the windows binary is refused"

628 (assert-refused (load-site (signed-index-site

629 (index-with-artifact "macos-arm64" "sigil-windows-amd64.exe")))

630 "it must name sigil-macos-arm64"))

631

632 (test "windows-amd64 without .exe is refused"

633 (assert-refused (load-site (signed-index-site

634 (index-with-artifact "windows-amd64" "sigil-windows-amd64")))

635 "it must name sigil-windows-amd64.exe"))

636

637 (test "linux-amd64 naming the static build is refused"

638 (assert-refused (load-site (signed-index-site

639 (index-with-artifact "linux-amd64" "sigil-linux-amd64-static")))

640 "it must name sigil-linux-amd64")))