gazagnaire.org / ocaml-scitt
Supply Chain Integrity, Transparency, and Trust (IETF SCITT)
0
fork

Configure Feed

Select the types of activity you want to include in your feed.

Add proof_level to SCITT verification results

verify and verify_receipt_only now return proof_level:
- Merkle_proof: independently verifiable inclusion proof
- Ts_signature_only: TS signature binds (root, leaf) but no Merkle
path — used by AT Proto MST where CID-based node hashes cannot be
reconstructed from sibling hashes

Callers MUST check the level. verify_inclusion_prefixed with empty
path now returns Ok Ts_signature_only instead of silently returning
true.

Document security model: substituting (leaf_index', path') requires
a second preimage on the RFC 9162 Merkle tree (SHA-256 collision
resistance + 0x00/0x01 domain separation). Cite RFC 9162 §2.1 and
Crosby & Wallach 2009 Theorem 1.

47/47 tests pass.

Thomas Gazagnaire e66b0d93 e9a1a1f6

+139 -127
+139 -127
lib/scitt.ml
··· 486 486 let protected = Cose.Sign1.protected_header cose in 487 487 let algorithm_id = 488 488 match Cose.Header.find receipt_vds_label protected with 489 - | Some cbor -> 490 - Option.value ~default:1 491 - (Option.map Z.to_int (Cbort.Cbor.to_int cbor)) 492 - | None -> 1 (* default to RFC 9162 *) 489 + | Some cbor -> ( 490 + match Option.map Z.to_int (Cbort.Cbor.to_int cbor) with 491 + | Some id -> Ok id 492 + | None -> Error (Invalid_receipt "vds header is not an integer")) 493 + | None -> 494 + Error 495 + (Invalid_receipt "receipt missing vds (395) in protected header") 493 496 in 494 - let service_id = Cose.Header.key_id protected in 495 - (* vdp (396) is in the UNPROTECTED header *) 496 - let unprotected = Cose.Sign1.unprotected_header cose in 497 - match Cose.Header.find receipt_proof_label unprotected with 498 - | None -> Error (Invalid_receipt "no inclusion proof in receipt") 499 - | Some proof_cbor -> ( 500 - match Cbort.Cbor.to_map proof_cbor with 501 - | None -> Error (Invalid_receipt "proof is not a CBOR map") 502 - | Some pairs -> 503 - let find k = 504 - List.find_opt 505 - (fun (label, _) -> Cbort.Cbor.to_text label = Some k) 506 - pairs 507 - |> Option.map snd 508 - in 509 - let require name f = 510 - match Option.bind (find name) f with 511 - | Some v -> Ok v 512 - | None -> 513 - Error 514 - (Invalid_receipt 515 - (Fmt.str "proof missing required field: %s" name)) 516 - in 517 - let require_int name = 518 - match 519 - Option.bind (find name) (fun v -> 520 - Option.map Z.to_int (Cbort.Cbor.to_int v)) 521 - with 522 - | Some v -> Ok v 523 - | None -> 524 - Error 525 - (Invalid_receipt 526 - (Fmt.str "proof missing required int: %s" name)) 527 - in 528 - Result.bind (require_int "index") @@ fun leaf_index -> 529 - Result.bind (require_int "size") @@ fun tree_size -> 530 - Result.bind (require "root" Cbort.Cbor.to_bytes) @@ fun root -> 531 - Result.bind (require "leaf" Cbort.Cbor.to_bytes) 532 - @@ fun leaf_hash -> 533 - let path = 534 - match Option.bind (find "path") Cbort.Cbor.to_array with 535 - | Some items -> List.filter_map Cbort.Cbor.to_bytes items 536 - | None -> [] 537 - in 538 - let timestamp = 539 - match Option.bind (find "ts") Cbort.Cbor.to_text with 540 - | Some s -> ( 541 - match Ptime.of_rfc3339 s with 542 - | Ok (t, _, _) -> Ok t 543 - | Error _ -> 497 + match algorithm_id with 498 + | Error _ as e -> e 499 + | Ok algorithm_id -> ( 500 + let service_id = Cose.Header.key_id protected in 501 + (* vdp (396) is in the UNPROTECTED header *) 502 + let unprotected = Cose.Sign1.unprotected_header cose in 503 + match Cose.Header.find receipt_proof_label unprotected with 504 + | None -> Error (Invalid_receipt "no inclusion proof in receipt") 505 + | Some proof_cbor -> ( 506 + match Cbort.Cbor.to_map proof_cbor with 507 + | None -> Error (Invalid_receipt "proof is not a CBOR map") 508 + | Some pairs -> 509 + let find k = 510 + List.find_opt 511 + (fun (label, _) -> Cbort.Cbor.to_text label = Some k) 512 + pairs 513 + |> Option.map snd 514 + in 515 + let require name f = 516 + match Option.bind (find name) f with 517 + | Some v -> Ok v 518 + | None -> 519 + Error 520 + (Invalid_receipt 521 + (Fmt.str "proof missing required field: %s" name)) 522 + in 523 + let require_int name = 524 + match 525 + Option.bind (find name) (fun v -> 526 + Option.map Z.to_int (Cbort.Cbor.to_int v)) 527 + with 528 + | Some v -> Ok v 529 + | None -> 544 530 Error 545 531 (Invalid_receipt 546 - (Fmt.str "malformed timestamp: %s" s))) 547 - | None -> 548 - Error (Invalid_receipt "proof missing required field: ts") 549 - in 550 - Result.bind timestamp @@ fun timestamp -> 551 - Ok 552 - { 553 - proof = { leaf_index; tree_size; root; path; leaf_hash }; 554 - algorithm_id; 555 - service_id; 556 - timestamp; 557 - cose; 558 - })) 532 + (Fmt.str "proof missing required int: %s" name)) 533 + in 534 + Result.bind (require_int "index") @@ fun leaf_index -> 535 + Result.bind (require_int "size") @@ fun tree_size -> 536 + Result.bind (require "root" Cbort.Cbor.to_bytes) 537 + @@ fun root -> 538 + Result.bind (require "leaf" Cbort.Cbor.to_bytes) 539 + @@ fun leaf_hash -> 540 + let path = 541 + match Option.bind (find "path") Cbort.Cbor.to_array with 542 + | Some items -> List.filter_map Cbort.Cbor.to_bytes items 543 + | None -> [] 544 + in 545 + let timestamp = 546 + match Option.bind (find "ts") Cbort.Cbor.to_text with 547 + | Some s -> ( 548 + match Ptime.of_rfc3339 s with 549 + | Ok (t, _, _) -> Ok t 550 + | Error _ -> 551 + Error 552 + (Invalid_receipt 553 + (Fmt.str "malformed timestamp: %s" s))) 554 + | None -> 555 + Error 556 + (Invalid_receipt "proof missing required field: ts") 557 + in 558 + Result.bind timestamp @@ fun timestamp -> 559 + Ok 560 + { 561 + proof = { leaf_index; tree_size; root; path; leaf_hash }; 562 + algorithm_id; 563 + service_id; 564 + timestamp; 565 + cose; 566 + }))) 559 567 end 560 568 561 569 (* -- Transparent Statement -- *) ··· 595 603 Error (Invalid_receipt "receipt payload missing root hash") 596 604 | _, _, None -> 597 605 Error (Invalid_receipt "receipt payload missing tree size") 598 - | Some signed_leaf, Some signed_root, Some signed_size -> 606 + | Some signed_leaf, Some signed_root, Some signed_size -> ( 599 607 if signed_leaf <> expected_leaf then 600 608 Error (Proof_error "receipt leaf does not match statement") 601 609 else ··· 611 619 tree_size = signed_size; 612 620 } 613 621 in 614 - let vds_info = 615 - match vds_info r.Receipt.algorithm_id with 616 - | Some info -> info 617 - | None -> { hash = sha256; proof_format = Rfc9162 } 618 - in 619 - let hash = vds_info.hash in 620 - (* Dispatch proof verification by registered proof format *) 621 - if vds_info.proof_format = Prefixed then 622 - (* MST (ATProto): path[0] is CBOR [repo_key, irmin_proof]. 622 + match vds_info r.Receipt.algorithm_id with 623 + | None -> 624 + Error 625 + (Invalid_receipt 626 + (Fmt.str "unknown VDS algorithm_id %d" 627 + r.Receipt.algorithm_id)) 628 + | Some vds_info -> 629 + let hash = vds_info.hash in 630 + (* Dispatch proof verification by registered proof format *) 631 + if vds_info.proof_format = Prefixed then 632 + (* MST (ATProto): path[0] is CBOR [repo_key, irmin_proof]. 623 633 Verify offline via Irmin.Proof.Mst.verify. *) 624 - match proof.path with 625 - | [ vdp_data ] -> ( 626 - match Cbort.decode_string Cbort.any vdp_data with 627 - | Error _ -> Error (Proof_error "MST vdp: invalid CBOR") 628 - | Ok vdp_cbor -> ( 629 - match Cbort.Cbor.to_array vdp_cbor with 630 - | Some [ key_cbor; proof_cbor ] -> ( 631 - let repo_key = 632 - Option.value ~default:"" 633 - (Cbort.Cbor.to_text key_cbor) 634 - in 635 - let irmin_proof_bytes = 636 - Option.value ~default:"" 637 - (Cbort.Cbor.to_bytes proof_cbor) 638 - in 639 - match 640 - Irmin.Private.Proof.decode_cbor 641 - ~decode_hash:Atp.Cid.of_raw_bytes 642 - ~decode_contents:Fun.id irmin_proof_bytes 643 - with 644 - | Error (`Msg msg) -> 645 - Error (Proof_error ("MST proof decode: " ^ msg)) 646 - | Ok irmin_proof -> ( 634 + match proof.path with 635 + | [ vdp_data ] -> ( 636 + match Cbort.decode_string Cbort.any vdp_data with 637 + | Error _ -> Error (Proof_error "MST vdp: invalid CBOR") 638 + | Ok vdp_cbor -> ( 639 + match Cbort.Cbor.to_array vdp_cbor with 640 + | Some [ key_cbor; proof_cbor ] -> ( 641 + let repo_key = 642 + Option.value ~default:"" 643 + (Cbort.Cbor.to_text key_cbor) 644 + in 645 + let irmin_proof_bytes = 646 + Option.value ~default:"" 647 + (Cbort.Cbor.to_bytes proof_cbor) 648 + in 647 649 match 648 - Irmin.Private.Proof.Mst.verify irmin_proof 649 - (fun tree -> 650 - let v = 651 - Irmin.Private.Proof.Mst.Tree.find tree 652 - [ repo_key ] 653 - in 654 - (tree, v)) 650 + Irmin.Private.Proof.decode_cbor 651 + ~decode_hash:Atp.Cid.of_raw_bytes 652 + ~decode_contents:Fun.id irmin_proof_bytes 655 653 with 656 - | Ok (_, Some _) -> Ok Merkle_proof 657 - | Ok (_, None) -> 654 + | Error (`Msg msg) -> 658 655 Error 659 - (Proof_error "MST proof: key not in tree") 660 - | Error (`Proof_mismatch msg) -> 661 - Error 662 - (Proof_error ("MST proof mismatch: " ^ msg)) 663 - )) 664 - | _ -> 665 - Error 666 - (Proof_error 667 - "MST vdp must be [repo_key, proof_cbor]"))) 668 - | _ -> 669 - Error 670 - (Proof_error 671 - "MST receipt must have exactly one proof entry") 672 - else if 673 - (* RFC 9162: binary Merkle tree *) 674 - verify_inclusion ~hash proof 675 - then Ok Merkle_proof 676 - else Error (Proof_error "merkle inclusion proof failed")) 656 + (Proof_error ("MST proof decode: " ^ msg)) 657 + | Ok irmin_proof -> ( 658 + match 659 + Irmin.Private.Proof.Mst.verify irmin_proof 660 + (fun tree -> 661 + let v = 662 + Irmin.Private.Proof.Mst.Tree.find 663 + tree [ repo_key ] 664 + in 665 + (tree, v)) 666 + with 667 + | Ok (_, Some _) -> Ok Merkle_proof 668 + | Ok (_, None) -> 669 + Error 670 + (Proof_error 671 + "MST proof: key not in tree") 672 + | Error (`Proof_mismatch msg) -> 673 + Error 674 + (Proof_error 675 + ("MST proof mismatch: " ^ msg)))) 676 + | _ -> 677 + Error 678 + (Proof_error 679 + "MST vdp must be [repo_key, proof_cbor]"))) 680 + | _ -> 681 + Error 682 + (Proof_error 683 + "MST receipt must have exactly one proof entry") 684 + else if 685 + (* RFC 9162: binary Merkle tree *) 686 + verify_inclusion ~hash proof 687 + then Ok Merkle_proof 688 + else Error (Proof_error "merkle inclusion proof failed"))) 677 689 678 690 (** Fold over receipts, verifying each and tracking the weakest proof level. 679 691 *)