My own corner of monopam
Harden SCITT receipt verification and refactor Receipt.decode
- Use Eqaf.equal for hash comparisons in verify_inclusion and
check_receipt_leaf to prevent timing side-channels
- Catch Eio.Io exceptions from Atp.Cid.of_raw_bytes during MST
proof decode/verify (malformed CIDs in untrusted receipts)
- Reject non-bytes entries in proof path strictly instead of
silently dropping them via List.filter_map
- Extract CBOR map helpers (cbor_map_find, cbor_map_require,
cbor_bytes_list, decode_proof_map) and flatten Receipt.decode
with let* to reduce nesting depth
- Add eqaf dependency
+159
-143
+1
ocaml-scitt/dune-project
+1
ocaml-scitt/dune-project
+1
ocaml-scitt/lib/dune
+1
ocaml-scitt/lib/dune
+156
-143
ocaml-scitt/lib/scitt.ml
+156
-143
ocaml-scitt/lib/scitt.ml
···
140
140
let rec step fn sn r = function
141
141
| [] ->
142
142
(* Step 5 *)
143
-
sn = 0 && r = proof.root
143
+
sn = 0 && Eqaf.equal r proof.root
144
144
| _ :: _ when sn = 0 ->
145
145
(* 4a: more path entries than expected *)
146
146
false
···
431
431
let receipt_vds_label = 395
432
432
let receipt_proof_label = 396
433
433
434
+
(* -- Receipt proof CBOR helpers -- *)
435
+
436
+
(** Look up a text-keyed field in a CBOR map. *)
437
+
let cbor_map_find k pairs =
438
+
List.find_opt (fun (label, _) -> Cbort.Cbor.to_text label = Some k) pairs
439
+
|> Option.map snd
440
+
441
+
let cbor_map_require name f pairs =
442
+
match Option.bind (cbor_map_find name pairs) f with
443
+
| Some v -> Ok v
444
+
| None ->
445
+
Error (Invalid_receipt (Fmt.str "proof missing required field: %s" name))
446
+
447
+
let cbor_map_require_int name pairs =
448
+
match
449
+
Option.bind (cbor_map_find name pairs) (fun v ->
450
+
Option.map Z.to_int (Cbort.Cbor.to_int v))
451
+
with
452
+
| Some v -> Ok v
453
+
| None ->
454
+
Error (Invalid_receipt (Fmt.str "proof missing required int: %s" name))
455
+
456
+
(** Parse a CBOR array as a strict list of byte strings. *)
457
+
let cbor_bytes_list items =
458
+
let rec go acc = function
459
+
| [] -> Ok (List.rev acc)
460
+
| item :: rest -> (
461
+
match Cbort.Cbor.to_bytes item with
462
+
| Some b -> go (b :: acc) rest
463
+
| None -> Error (Invalid_receipt "proof path contains non-bytes entry"))
464
+
in
465
+
go [] items
466
+
467
+
let cbor_map_require_timestamp pairs =
468
+
match Option.bind (cbor_map_find "ts" pairs) Cbort.Cbor.to_text with
469
+
| Some s -> (
470
+
match Ptime.of_rfc3339 s with
471
+
| Ok (t, _, _) -> Ok t
472
+
| Error _ -> Error (Invalid_receipt (Fmt.str "malformed timestamp: %s" s))
473
+
)
474
+
| None -> Error (Invalid_receipt "proof missing required field: ts")
475
+
476
+
(** Decode the inclusion proof from a CBOR map (unprotected header label 396).
477
+
*)
478
+
let decode_proof_map pairs =
479
+
let ( let* ) = Result.bind in
480
+
let* leaf_index = cbor_map_require_int "index" pairs in
481
+
let* tree_size = cbor_map_require_int "size" pairs in
482
+
let* root = cbor_map_require "root" Cbort.Cbor.to_bytes pairs in
483
+
let* leaf_hash = cbor_map_require "leaf" Cbort.Cbor.to_bytes pairs in
484
+
let* path =
485
+
match Option.bind (cbor_map_find "path" pairs) Cbort.Cbor.to_array with
486
+
| Some items -> cbor_bytes_list items
487
+
| None -> Ok []
488
+
in
489
+
let* timestamp = cbor_map_require_timestamp pairs in
490
+
Ok ({ leaf_index; tree_size; root; path; leaf_hash }, timestamp)
491
+
434
492
module Receipt = struct
435
493
type t = {
436
494
proof : inclusion_proof;
···
448
506
let encode t = Cose.Sign1.encode t.cose
449
507
450
508
let decode s =
451
-
match Cose.Sign1.decode s with
452
-
| Error e -> Error (Cose_error e)
453
-
| Ok cose -> (
454
-
let protected = Cose.Sign1.protected_header cose in
455
-
let algorithm_id =
456
-
match Cose.Header.find receipt_vds_label protected with
457
-
| Some cbor -> (
458
-
match Option.map Z.to_int (Cbort.Cbor.to_int cbor) with
459
-
| Some id -> Ok id
460
-
| None -> Error (Invalid_receipt "vds header is not an integer"))
461
-
| None ->
462
-
Error
463
-
(Invalid_receipt "receipt missing vds (395) in protected header")
464
-
in
465
-
match algorithm_id with
466
-
| Error _ as e -> e
467
-
| Ok algorithm_id -> (
468
-
let service_id = Cose.Header.key_id protected in
469
-
(* vdp (396) is in the UNPROTECTED header *)
470
-
let unprotected = Cose.Sign1.unprotected_header cose in
471
-
match Cose.Header.find receipt_proof_label unprotected with
472
-
| None -> Error (Invalid_receipt "no inclusion proof in receipt")
473
-
| Some proof_cbor -> (
474
-
match Cbort.Cbor.to_map proof_cbor with
475
-
| None -> Error (Invalid_receipt "proof is not a CBOR map")
476
-
| Some pairs ->
477
-
let find k =
478
-
List.find_opt
479
-
(fun (label, _) -> Cbort.Cbor.to_text label = Some k)
480
-
pairs
481
-
|> Option.map snd
482
-
in
483
-
let require name f =
484
-
match Option.bind (find name) f with
485
-
| Some v -> Ok v
486
-
| None ->
487
-
Error
488
-
(Invalid_receipt
489
-
(Fmt.str "proof missing required field: %s" name))
490
-
in
491
-
let require_int name =
492
-
match
493
-
Option.bind (find name) (fun v ->
494
-
Option.map Z.to_int (Cbort.Cbor.to_int v))
495
-
with
496
-
| Some v -> Ok v
497
-
| None ->
498
-
Error
499
-
(Invalid_receipt
500
-
(Fmt.str "proof missing required int: %s" name))
501
-
in
502
-
Result.bind (require_int "index") @@ fun leaf_index ->
503
-
Result.bind (require_int "size") @@ fun tree_size ->
504
-
Result.bind (require "root" Cbort.Cbor.to_bytes)
505
-
@@ fun root ->
506
-
Result.bind (require "leaf" Cbort.Cbor.to_bytes)
507
-
@@ fun leaf_hash ->
508
-
let path =
509
-
match Option.bind (find "path") Cbort.Cbor.to_array with
510
-
| Some items -> List.filter_map Cbort.Cbor.to_bytes items
511
-
| None -> []
512
-
in
513
-
let timestamp =
514
-
match Option.bind (find "ts") Cbort.Cbor.to_text with
515
-
| Some s -> (
516
-
match Ptime.of_rfc3339 s with
517
-
| Ok (t, _, _) -> Ok t
518
-
| Error _ ->
519
-
Error
520
-
(Invalid_receipt
521
-
(Fmt.str "malformed timestamp: %s" s)))
522
-
| None ->
523
-
Error
524
-
(Invalid_receipt "proof missing required field: ts")
525
-
in
526
-
Result.bind timestamp @@ fun timestamp ->
527
-
Ok
528
-
{
529
-
proof = { leaf_index; tree_size; root; path; leaf_hash };
530
-
algorithm_id;
531
-
service_id;
532
-
timestamp;
533
-
cose;
534
-
})))
509
+
let ( let* ) = Result.bind in
510
+
let* cose =
511
+
Cose.Sign1.decode s |> Result.map_error (fun e -> Cose_error e)
512
+
in
513
+
let protected = Cose.Sign1.protected_header cose in
514
+
let* algorithm_id =
515
+
match Cose.Header.find receipt_vds_label protected with
516
+
| Some cbor -> (
517
+
match Option.map Z.to_int (Cbort.Cbor.to_int cbor) with
518
+
| Some id -> Ok id
519
+
| None -> Error (Invalid_receipt "vds header is not an integer"))
520
+
| None ->
521
+
Error
522
+
(Invalid_receipt "receipt missing vds (395) in protected header")
523
+
in
524
+
let service_id = Cose.Header.key_id protected in
525
+
let unprotected = Cose.Sign1.unprotected_header cose in
526
+
let* proof_cbor =
527
+
match Cose.Header.find receipt_proof_label unprotected with
528
+
| Some c -> Ok c
529
+
| None -> Error (Invalid_receipt "no inclusion proof in receipt")
530
+
in
531
+
let* pairs =
532
+
match Cbort.Cbor.to_map proof_cbor with
533
+
| Some p -> Ok p
534
+
| None -> Error (Invalid_receipt "proof is not a CBOR map")
535
+
in
536
+
let* proof, timestamp = decode_proof_map pairs in
537
+
Ok { proof; algorithm_id; service_id; timestamp; cose }
535
538
end
536
539
537
540
(* -- Transparent Statement -- *)
···
557
560
internal nodes) prevents leaf/node confusion. See also Crosby & Wallach,
558
561
"Efficient Data Structures for Tamper-Evident Logging" (2009), Theorem 1:
559
562
finding a valid alternative inclusion proof requires a hash collision. *)
563
+
564
+
(** Decode and verify an MST (AT Proto) Irmin proof from the receipt's
565
+
unprotected [vdp] path. The path must contain exactly one entry: a CBOR
566
+
array [[repo_key, irmin_proof_cbor]].
567
+
568
+
Checks: 1. The Irmin proof's root CID matches [~root] (the
569
+
TS-authenticated root). 2. [Irmin.Proof.Mst.verify] succeeds (proof tree
570
+
hashes are consistent). 3. The key exists in the proven tree.
571
+
572
+
The found value is NOT compared to the signed statement — the MST stores
573
+
DAG-CBOR wrapped AT Proto records, not raw COSE bytes. The binding between
574
+
the statement and the tree is via the TS signature over (root, leaf_hash),
575
+
verified by the caller. *)
576
+
let verify_mst_proof ~hash:_ ~root path =
577
+
match path with
578
+
| [ vdp_data ] -> (
579
+
match Cbort.decode_string Cbort.any vdp_data with
580
+
| Error _ -> Error (Proof_error "MST vdp: invalid CBOR")
581
+
| Ok vdp_cbor -> (
582
+
match Cbort.Cbor.to_array vdp_cbor with
583
+
| Some [ key_cbor; proof_cbor ] -> (
584
+
let repo_key =
585
+
Option.value ~default:"" (Cbort.Cbor.to_text key_cbor)
586
+
in
587
+
let irmin_proof_bytes =
588
+
Option.value ~default:"" (Cbort.Cbor.to_bytes proof_cbor)
589
+
in
590
+
match
591
+
Irmin.Proof.decode_cbor ~decode_hash:Atp.Cid.of_raw_bytes
592
+
~decode_contents:Fun.id irmin_proof_bytes
593
+
with
594
+
| exception Eio.Io _ ->
595
+
Error (Proof_error "MST proof decode: malformed CID")
596
+
| Error (`Msg msg) ->
597
+
Error (Proof_error ("MST proof decode: " ^ msg))
598
+
| Ok irmin_proof -> (
599
+
let irmin_root_cid =
600
+
match Irmin.Proof.before irmin_proof with
601
+
| `Node h -> h
602
+
| `Contents h -> h
603
+
in
604
+
let irmin_root = Atp.Cid.to_raw_bytes irmin_root_cid in
605
+
if not (Eqaf.equal irmin_root root) then
606
+
Error
607
+
(Proof_error
608
+
"MST proof root does not match authenticated root")
609
+
else
610
+
match
611
+
Irmin.Proof.Mst.verify irmin_proof (fun tree ->
612
+
let v =
613
+
Irmin.Proof.Mst.Tree.find tree [ repo_key ]
614
+
in
615
+
(tree, v))
616
+
with
617
+
| exception Eio.Io _ ->
618
+
Error (Proof_error "MST proof verify: malformed CID")
619
+
| Ok (_, Some _) -> Ok Merkle_proof
620
+
| Ok (_, None) ->
621
+
Error (Proof_error "MST proof: key not in tree")
622
+
| Error (`Proof_mismatch msg) ->
623
+
Error (Proof_error ("MST proof mismatch: " ^ msg))))
624
+
| _ -> Error (Proof_error "MST vdp must be [repo_key, proof_cbor]"))
625
+
)
626
+
| _ -> Error (Proof_error "MST receipt must have exactly one proof entry")
627
+
560
628
let check_receipt_leaf ~expected_leaf receipt_payload r =
561
629
match Cbort.decode_string Cbort.any receipt_payload with
562
630
| Error _ -> Error (Invalid_receipt "bad receipt payload CBOR")
···
572
640
| _, _, None ->
573
641
Error (Invalid_receipt "receipt payload missing tree size")
574
642
| Some signed_leaf, Some signed_root, Some signed_size -> (
575
-
if signed_leaf <> expected_leaf then
643
+
if not (Eqaf.equal signed_leaf expected_leaf) then
576
644
Error (Proof_error "receipt leaf does not match statement")
577
645
else
578
646
(* Build the proof using authenticated leaf, root, and size
···
595
663
r.Receipt.algorithm_id))
596
664
| Some vds_info ->
597
665
let hash = vds_info.hash in
598
-
(* Dispatch proof verification by registered proof format *)
599
666
if vds_info.proof_format = Prefixed then
600
-
(* MST (ATProto): path[0] is CBOR [repo_key, irmin_proof].
601
-
Verify offline via Irmin.Proof.Mst.verify. *)
602
-
match proof.path with
603
-
| [ vdp_data ] -> (
604
-
match Cbort.decode_string Cbort.any vdp_data with
605
-
| Error _ -> Error (Proof_error "MST vdp: invalid CBOR")
606
-
| Ok vdp_cbor -> (
607
-
match Cbort.Cbor.to_array vdp_cbor with
608
-
| Some [ key_cbor; proof_cbor ] -> (
609
-
let repo_key =
610
-
Option.value ~default:""
611
-
(Cbort.Cbor.to_text key_cbor)
612
-
in
613
-
let irmin_proof_bytes =
614
-
Option.value ~default:""
615
-
(Cbort.Cbor.to_bytes proof_cbor)
616
-
in
617
-
match
618
-
Irmin.Proof.decode_cbor
619
-
~decode_hash:Atp.Cid.of_raw_bytes
620
-
~decode_contents:Fun.id irmin_proof_bytes
621
-
with
622
-
| Error (`Msg msg) ->
623
-
Error
624
-
(Proof_error ("MST proof decode: " ^ msg))
625
-
| Ok irmin_proof -> (
626
-
match
627
-
Irmin.Proof.Mst.verify irmin_proof
628
-
(fun tree ->
629
-
let v =
630
-
Irmin.Proof.Mst.Tree.find tree
631
-
[ repo_key ]
632
-
in
633
-
(tree, v))
634
-
with
635
-
| Ok (_, Some _) -> Ok Merkle_proof
636
-
| Ok (_, None) ->
637
-
Error
638
-
(Proof_error
639
-
"MST proof: key not in tree")
640
-
| Error (`Proof_mismatch msg) ->
641
-
Error
642
-
(Proof_error
643
-
("MST proof mismatch: " ^ msg))))
644
-
| _ ->
645
-
Error
646
-
(Proof_error
647
-
"MST vdp must be [repo_key, proof_cbor]")))
648
-
| _ ->
649
-
Error
650
-
(Proof_error
651
-
"MST receipt must have exactly one proof entry")
652
-
else if
653
-
(* RFC 9162: binary Merkle tree *)
654
-
verify_inclusion ~hash proof
655
-
then Ok Merkle_proof
667
+
verify_mst_proof ~hash ~root:proof.root proof.path
668
+
else if verify_inclusion ~hash proof then Ok Merkle_proof
656
669
else Error (Proof_error "merkle inclusion proof failed")))
657
670
658
671
(** Fold over receipts, verifying each and tracking the weakest proof level.