Source file node_hash.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019,2020 DaiLambda, Inc. <contact@dailambda.jp>            *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Node_type
open Hash

let (^^) nh1 nh2 =
  let s1 = to_strings nh1 in
  let s2 = to_strings nh2 in
  let l2 = match nh2 with _, s -> String.length s in
  (* This defines hard_limit_max_hash_postfix_bytes *)
  assert (0 <= l2 && l2 <= Limit.max_hash_postfix_bytes);
  let c = Char.chr l2 in
  s1 @ s2 @ [ String.make 1 c ]

let of_bud h = function
  | None -> h.Hasher.zero
  | Some hash -> h.compute ~flags:0b11 @@ to_strings hash

let of_internal h l r = h.Hasher.compute ~flags:0b00 (l ^^ r)

let of_leaf h v = h.Hasher.compute ~flags:0b10 [Value.to_string v]

let of_extender seg hp = (hp, Segment.Serialization.encode seg )

let compute hash_conf g n : (Node_type.t * Hash.t) =
  let hash n = match n with
    | Disk _ -> assert false
    | Hash nh -> nh
    | View v ->
        match hash_of_view v with
        | None -> assert false
        | Some nh -> nh
  in
  let n =
    Traverse.Map.map
      ~enter: (fun n ->
          match g n with
          | `Hashed (_nh, n) -> `Return n
          | `Not_Hashed v -> `Continue v)
      ~leave: (fun ~org v ->
          View (
            (* Index : use the original
               Hash : compute from the hashes of the subnodes
            *)
            match org, v with
            | Leaf (_, i, _), Leaf (v, _, _) -> _Leaf (v, i, Hashed (of_leaf hash_conf v))
            | Bud (_, i, _), Bud (None, _, _) -> _Bud (None, i, Hashed (of_bud hash_conf None))
            | Bud (_, i, _), Bud (Some n, _, _) -> _Bud (Some n, i, Hashed (of_bud hash_conf (Some (hash n))))
            | Internal (_, _, i, _), Internal (nl, nr, _, _) -> _Internal (nl, nr, i, Hashed (of_internal hash_conf (hash nl) (hash nr)))
            | Extender (_, _, i, _), Extender (seg, n, _, _) ->
                let hp, postfix = hash n in
                assert (postfix = "");
                _Extender (seg, n, i, Hashed hp)
            | _ -> assert false))
      n
  in
  n, hash n

let compute_without_context hash_conf n =
  let f n = match n with
    | Disk _ ->  raise Not_found
    | Hash nh -> `Hashed (nh, n)
    | View v ->
        match hash_of_view v with
        | None -> `Not_Hashed v
        | Some nh -> `Hashed (nh, n)
  in
  try Some (compute hash_conf f n) with Not_found -> None