verify_plebeia_merkle_proof.ml

open SCaml

let empty_bytes = Bytes "0x"
let is_empty_bytes b = (Bytes.length b = Nat 0)

let bytes_concat sep ss =
  match ss with
  | [] -> empty_bytes
  | s0 :: ss ->
    List.fold_left' (fun (acc, s) -> Bytes.concat (Bytes.concat acc sep) s) s0 ss

type encoded_segment = bytes
let encode_segment (seg : encoded_segment) : bytes = seg


module Hash = struct
  type prefix = bytes
  let prefix_to_bytes p : bytes = p
  type t = (prefix * bytes)

  let of_prefix p : t = (p, empty_bytes)

  let zero : t = of_prefix (Bytes "0x00000000000000000000000000000000")

  let of_bytes b : prefix = Crypto.blake2b b
  let of_list ss : prefix = of_bytes (bytes_concat empty_bytes ss)

  let to_bytes_list : t -> bytes list = function
    | (p, b) when is_empty_bytes b -> [prefix_to_bytes p]
    | (p, b)                       -> [prefix_to_bytes p; b]

  let combine_flags (p: prefix) (flags:nat) : prefix =
    p

  let to_prefix : t -> prefix = fst
  let make prefix b : t = (prefix, b)

(*  let to_string ((prefix, b): t) =*)
(*    Bytes.to_string prefix ^ "-" ^ Bytes.to_string b*)

end

type hash = Hash.t

let hash_of_bud : hash option -> hash = function
  | None -> Hash.zero
  | Some h ->
    let p = Hash.of_list (Hash.to_bytes_list h) in
    let p = Hash.combine_flags p (Nat 0b11) in
    Hash.of_prefix p
let hash_of_leaf (v: bytes) : hash =
  Hash.of_prefix (Hash.of_bytes v)

let hash_of_internal (h1: hash) (h2 : hash) =
  let p = Hash.of_list [Hash.to_prefix h1; Hash.to_prefix h2] in
  Hash.of_prefix p
let hash_of_extender (seg: encoded_segment) (h : hash) =
  Hash.make (Hash.to_prefix h) (encode_segment seg)

type node_key = nat

type node_ref =
  | Hash of hash
  | Bud of node_key option
  | Leaf of bytes
  | Internal of node_key * node_key
  | Extender of encoded_segment * node_key

type node = {root_key : node_key; elems: (node_key * node_ref) list}

type hash_cache = (node_key, hash) Map.t

let compute_hash node =
  let hashes = List.fold_left'
    (fun (cache, (node_key, node_ref)) ->
       let h =
         match node_ref with
         | Hash h -> Some h
         | Bud None ->
           Some (hash_of_bud None)
         | Bud (Some n) ->
           begin match Map.get n cache with
             | None -> None
             | Some h -> Some (hash_of_bud (Some h))
           end
         | Leaf v -> Some (hash_of_leaf v)
         | Internal (l, r) ->
           begin match Map.get l cache, Map.get r cache with
             | Some h1, Some h2 ->
               Some (hash_of_internal h1 h2)
             | _, _ -> None
           end
         | Extender (seg, n) ->
           begin match Map.get n cache with
             | None -> None
             | Some h ->
               Some (hash_of_extender seg h)
           end
       in
       match h with
       | None ->
         failwith "compute_hash"
       | Some h ->
         Map.update node_key (Some h) cache)
    Map.empty
    node.elems
  in
  Map.get node.root_key hashes

type proof = node

type storage = NoStorage

type segment_elem = L | R | Seg of encoded_segment
type segment = segment_elem list

type path = segment list


let find_child node_map segment node_key =
  let f = function
    | (None, _) -> None
    | (Some (Internal (l, _)), L) ->
      Map.get l node_map
    | (Some (Internal (_, r)), R) ->
      Map.get r node_map
    | (Some (Extender (eseg, n)), Seg s) when (eseg = s) ->
      Map.get n node_map
    | (Some _, _) -> None
  in
  let top = Map.get node_key node_map in
  List.fold_left' f top segment

let map_of_assoc (list : (node_key * node_ref) list) =
  List.fold_left' (fun (map, (key,value)) -> Map.update key (Some value) map) Map.empty list

let find path proof =
  let node_map = map_of_assoc proof.elems in
  let root = Map.get proof.root_key node_map in
  let leaf_opt =
    List.fold_left' (function
        | (None, _) -> None
        | (Some (Bud (Some n)), segment) ->
          find_child node_map segment n
        | (Some _, _) -> None)
      root
      path
  in
  match leaf_opt with
  | None -> None
  | Some (Leaf v) -> Some v
  | Some _ -> None


type param = {
  proof: proof;
  expected_root_hash : hash;
  data: (path * bytes) list;
}

let is_proof_valid expected_root_hash proof =
  match compute_hash proof with
  | Some h ->
    (expected_root_hash = h)
  | None ->
    false

let check_data proof data =
  let check proof (path, v_expected) =
    match find path proof with
    | None -> false
    | Some v -> v_expected = v
  in
  List.fold_left' (fun (acc, path) -> acc && check proof path) true data


let [@entry] verify param NoStorage =
  if is_proof_valid param.expected_root_hash param.proof = false then
    failwith "is_proof_valid"
  else if check_data param.proof param.data = false then
    failwith "check data"
  else
    ([], NoStorage)

↑上記のコンパイルエラーはStdlibのresult型を使っていたからのようだ。
ScamlではStdlibは使わず、SCaml.mliのAPIだけを使うようにすべしということで修正した。