2016-09-08 21:13:10 +04:00
|
|
|
(**************************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* Copyright (c) 2014 - 2016. *)
|
|
|
|
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
|
|
|
(* *)
|
|
|
|
(* All rights reserved. No warranty, explicit or implicit, provided. *)
|
|
|
|
(* *)
|
|
|
|
(**************************************************************************)
|
|
|
|
|
|
|
|
let (//) = Filename.concat
|
|
|
|
let (>>=) = Lwt.bind
|
|
|
|
let (>|=) = Lwt.(>|=)
|
|
|
|
|
2017-04-05 12:22:41 +04:00
|
|
|
open Error_monad
|
2016-09-08 21:13:10 +04:00
|
|
|
|
2016-11-25 22:46:50 +04:00
|
|
|
let () =
|
|
|
|
let expected_primitive = "blake2b"
|
|
|
|
and primitive = Sodium.Generichash.primitive in
|
|
|
|
if primitive <> expected_primitive then begin
|
|
|
|
Printf.eprintf
|
|
|
|
"FATAL ERROR: \
|
|
|
|
invalid value for Sodium.Generichash.primitive: %S (expected %S)@."
|
|
|
|
primitive expected_primitive ;
|
|
|
|
exit 1
|
|
|
|
end
|
|
|
|
|
2016-09-08 21:13:10 +04:00
|
|
|
(*-- Signatures -------------------------------------------------------------*)
|
|
|
|
|
2016-11-14 19:26:34 +04:00
|
|
|
module type MINIMAL_HASH = sig
|
|
|
|
|
2016-09-08 21:13:10 +04:00
|
|
|
type t
|
|
|
|
|
2016-11-14 19:26:34 +04:00
|
|
|
val name: string
|
|
|
|
val title: string
|
|
|
|
|
2016-09-08 21:13:10 +04:00
|
|
|
val hash_bytes: MBytes.t list -> t
|
|
|
|
val hash_string: string list -> t
|
|
|
|
val size: int (* in bytes *)
|
|
|
|
val compare: t -> t -> int
|
|
|
|
val equal: t -> t -> bool
|
2017-02-24 20:17:53 +04:00
|
|
|
|
2016-09-08 21:13:10 +04:00
|
|
|
val to_hex: t -> string
|
2017-02-24 20:17:53 +04:00
|
|
|
val of_hex: string -> t option
|
|
|
|
val of_hex_exn: string -> t
|
|
|
|
|
2016-11-25 22:46:50 +04:00
|
|
|
val to_string: t -> string
|
2017-02-24 20:17:53 +04:00
|
|
|
val of_string: string -> t option
|
|
|
|
val of_string_exn: string -> t
|
|
|
|
|
2016-09-08 21:13:10 +04:00
|
|
|
val to_bytes: t -> MBytes.t
|
2017-02-24 20:17:53 +04:00
|
|
|
val of_bytes: MBytes.t -> t option
|
|
|
|
val of_bytes_exn: MBytes.t -> t
|
|
|
|
|
2016-09-08 21:13:10 +04:00
|
|
|
val read: MBytes.t -> int -> t
|
|
|
|
val write: MBytes.t -> int -> t -> unit
|
2017-02-24 20:17:53 +04:00
|
|
|
|
2016-09-08 21:13:10 +04:00
|
|
|
val to_path: t -> string list
|
2017-02-24 20:17:53 +04:00
|
|
|
val of_path: string list -> t option
|
|
|
|
val of_path_exn: string list -> t
|
|
|
|
|
2016-10-06 20:30:04 +04:00
|
|
|
val prefix_path: string -> string list
|
2017-02-24 20:17:53 +04:00
|
|
|
val path_length: int
|
2016-11-14 19:26:34 +04:00
|
|
|
|
|
|
|
end
|
|
|
|
|
2017-02-24 20:17:53 +04:00
|
|
|
module type INTERNAL_MINIMAL_HASH = sig
|
|
|
|
include MINIMAL_HASH
|
|
|
|
module Table : Hashtbl.S with type key = t
|
|
|
|
end
|
|
|
|
|
2016-11-14 19:26:34 +04:00
|
|
|
module type HASH = sig
|
|
|
|
|
|
|
|
include MINIMAL_HASH
|
|
|
|
|
2017-04-05 11:54:21 +04:00
|
|
|
val of_b58check_exn: string -> t
|
|
|
|
val of_b58check_opt: string -> t option
|
2017-02-19 21:22:32 +04:00
|
|
|
val to_b58check: t -> string
|
|
|
|
val to_short_b58check: t -> string
|
2016-09-08 21:13:10 +04:00
|
|
|
val encoding: t Data_encoding.t
|
|
|
|
val pp: Format.formatter -> t -> unit
|
|
|
|
val pp_short: Format.formatter -> t -> unit
|
2017-02-19 21:22:32 +04:00
|
|
|
type Base58.data += Hash of t
|
|
|
|
val b58check_encoding: t Base58.encoding
|
2016-11-14 19:26:34 +04:00
|
|
|
|
2017-02-24 20:17:53 +04:00
|
|
|
module Set : sig
|
|
|
|
include Set.S with type elt = t
|
|
|
|
val encoding: t Data_encoding.t
|
|
|
|
end
|
|
|
|
|
|
|
|
module Map : sig
|
|
|
|
include Map.S with type key = t
|
|
|
|
val encoding: 'a Data_encoding.t -> 'a t Data_encoding.t
|
|
|
|
end
|
|
|
|
|
|
|
|
end
|
|
|
|
|
|
|
|
module type INTERNAL_HASH = sig
|
|
|
|
include HASH
|
2017-04-05 11:54:21 +04:00
|
|
|
val of_b58check: string -> t tzresult
|
2017-04-05 12:22:41 +04:00
|
|
|
val param:
|
|
|
|
?name:string ->
|
|
|
|
?desc:string ->
|
|
|
|
('a, 'arg, 'ret) Cli_entries.params ->
|
|
|
|
(t -> 'a, 'arg, 'ret) Cli_entries.params
|
2017-09-29 20:43:13 +04:00
|
|
|
val random_set_elt: Set.t -> t
|
2017-02-24 20:17:53 +04:00
|
|
|
module Table : Hashtbl.S with type key = t
|
2016-09-08 21:13:10 +04:00
|
|
|
end
|
|
|
|
|
2017-03-16 20:17:06 +04:00
|
|
|
module type INTERNAL_MERKLE_TREE = sig
|
|
|
|
type elt
|
|
|
|
include INTERNAL_HASH
|
|
|
|
val compute: elt list -> t
|
|
|
|
val empty: t
|
|
|
|
type path =
|
|
|
|
| Left of path * t
|
|
|
|
| Right of t * path
|
|
|
|
| Op
|
|
|
|
val compute_path: elt list -> int -> path
|
|
|
|
val check_path: path -> elt -> t * int
|
|
|
|
val path_encoding: path Data_encoding.t
|
|
|
|
end
|
|
|
|
|
|
|
|
module type MERKLE_TREE = sig
|
|
|
|
type elt
|
|
|
|
include HASH
|
|
|
|
val compute: elt list -> t
|
|
|
|
val empty: t
|
|
|
|
type path =
|
|
|
|
| Left of path * t
|
|
|
|
| Right of t * path
|
|
|
|
| Op
|
|
|
|
val compute_path: elt list -> int -> path
|
|
|
|
val check_path: path -> elt -> t * int
|
|
|
|
val path_encoding: path Data_encoding.t
|
|
|
|
end
|
|
|
|
|
2016-09-08 21:13:10 +04:00
|
|
|
module type Name = sig
|
2016-11-14 19:26:34 +04:00
|
|
|
val name: string
|
|
|
|
val title: string
|
2016-11-25 22:46:50 +04:00
|
|
|
val size: int option
|
2016-11-14 19:26:34 +04:00
|
|
|
end
|
|
|
|
|
|
|
|
module type PrefixedName = sig
|
|
|
|
include Name
|
2017-02-19 21:22:32 +04:00
|
|
|
val b58check_prefix: string
|
2016-09-08 21:13:10 +04:00
|
|
|
end
|
|
|
|
|
|
|
|
(*-- Type specific Hash builder ---------------------------------------------*)
|
|
|
|
|
2016-11-25 22:46:50 +04:00
|
|
|
module Make_minimal_Blake2B (K : Name) = struct
|
2016-09-08 21:13:10 +04:00
|
|
|
|
2016-11-25 22:46:50 +04:00
|
|
|
type t = Sodium.Generichash.hash
|
2016-09-08 21:13:10 +04:00
|
|
|
|
2016-11-14 19:26:34 +04:00
|
|
|
include K
|
|
|
|
|
2016-11-25 22:46:50 +04:00
|
|
|
let size =
|
|
|
|
match K.size with
|
|
|
|
| None -> 32
|
|
|
|
| Some x -> x
|
2016-09-08 21:13:10 +04:00
|
|
|
|
2016-11-25 22:46:50 +04:00
|
|
|
let of_string s =
|
2017-02-24 20:17:53 +04:00
|
|
|
if String.length s <> size then
|
|
|
|
None
|
|
|
|
else
|
|
|
|
Some (Sodium.Generichash.Bytes.to_hash (Bytes.of_string s))
|
|
|
|
let of_string_exn s =
|
|
|
|
match of_string s with
|
|
|
|
| None ->
|
|
|
|
let msg =
|
|
|
|
Printf.sprintf "%s.of_string: wrong string size (%d)"
|
|
|
|
K.name (String.length s) in
|
|
|
|
raise (Invalid_argument msg)
|
|
|
|
| Some h -> h
|
2016-11-25 22:46:50 +04:00
|
|
|
let to_string s = Bytes.to_string (Sodium.Generichash.Bytes.of_hash s)
|
2016-09-08 21:13:10 +04:00
|
|
|
|
2016-11-25 22:46:50 +04:00
|
|
|
let of_hex s = of_string (Hex_encode.hex_decode s)
|
2017-02-24 20:17:53 +04:00
|
|
|
let of_hex_exn s = of_string_exn (Hex_encode.hex_decode s)
|
2016-11-25 22:46:50 +04:00
|
|
|
let to_hex s = Hex_encode.hex_encode (to_string s)
|
2016-09-08 21:13:10 +04:00
|
|
|
|
2016-11-25 22:46:50 +04:00
|
|
|
let compare = Sodium.Generichash.compare
|
|
|
|
let equal x y = compare x y = 0
|
2016-09-08 21:13:10 +04:00
|
|
|
|
|
|
|
let of_bytes b =
|
2017-02-24 20:17:53 +04:00
|
|
|
if MBytes.length b <> size then
|
|
|
|
None
|
|
|
|
else
|
|
|
|
Some (Sodium.Generichash.Bigbytes.to_hash b)
|
|
|
|
let of_bytes_exn b =
|
|
|
|
match of_bytes b with
|
|
|
|
| None ->
|
|
|
|
let msg =
|
|
|
|
Printf.sprintf "%s.of_bytes: wrong string size (%d)"
|
|
|
|
K.name (MBytes.length b) in
|
|
|
|
raise (Invalid_argument msg)
|
|
|
|
| Some h -> h
|
2016-11-25 22:46:50 +04:00
|
|
|
let to_bytes = Sodium.Generichash.Bigbytes.of_hash
|
2016-09-08 21:13:10 +04:00
|
|
|
|
2017-02-24 20:17:53 +04:00
|
|
|
let read src off = of_bytes_exn @@ MBytes.sub src off size
|
2016-11-25 22:46:50 +04:00
|
|
|
let write dst off h = MBytes.blit (to_bytes h) 0 dst off size
|
2016-09-08 21:13:10 +04:00
|
|
|
|
|
|
|
let hash_bytes l =
|
2016-11-25 22:46:50 +04:00
|
|
|
let open Sodium.Generichash in
|
|
|
|
let state = init ~size () in
|
|
|
|
List.iter (Bigbytes.update state) l ;
|
|
|
|
final state
|
2016-09-08 21:13:10 +04:00
|
|
|
|
|
|
|
let hash_string l =
|
2016-11-25 22:46:50 +04:00
|
|
|
let open Sodium.Generichash in
|
|
|
|
let state = init ~size () in
|
|
|
|
List.iter
|
|
|
|
(fun s -> Bytes.update state (BytesLabels.unsafe_of_string s))
|
|
|
|
l ;
|
|
|
|
final state
|
2016-09-08 21:13:10 +04:00
|
|
|
|
|
|
|
let fold_read f buf off len init =
|
|
|
|
let last = off + len * size in
|
|
|
|
if last > MBytes.length buf then
|
|
|
|
invalid_arg "Hash.read_set: invalid size.";
|
|
|
|
let rec loop acc off =
|
|
|
|
if off >= last then
|
|
|
|
acc
|
|
|
|
else
|
|
|
|
let hash = read buf off in
|
|
|
|
loop (f hash acc) (off + size)
|
|
|
|
in
|
|
|
|
loop init off
|
|
|
|
|
2017-02-24 20:17:53 +04:00
|
|
|
let path_length = 6
|
2016-09-08 21:13:10 +04:00
|
|
|
let to_path key =
|
|
|
|
let key = to_hex key in
|
|
|
|
[ String.sub key 0 2 ; String.sub key 2 2 ;
|
|
|
|
String.sub key 4 2 ; String.sub key 6 2 ;
|
2016-11-14 19:26:34 +04:00
|
|
|
String.sub key 8 2 ; String.sub key 10 (size * 2 - 10) ]
|
2016-09-08 21:13:10 +04:00
|
|
|
let of_path path =
|
|
|
|
let path = String.concat "" path in
|
|
|
|
of_hex path
|
2017-02-24 20:17:53 +04:00
|
|
|
let of_path_exn path =
|
|
|
|
let path = String.concat "" path in
|
|
|
|
of_hex_exn path
|
2016-09-08 21:13:10 +04:00
|
|
|
|
2016-10-06 20:30:04 +04:00
|
|
|
let prefix_path p =
|
2016-11-25 22:46:50 +04:00
|
|
|
let p = Hex_encode.hex_encode p in
|
2016-10-06 20:30:04 +04:00
|
|
|
let len = String.length p in
|
|
|
|
let p1 = if len >= 2 then String.sub p 0 2 else ""
|
|
|
|
and p2 = if len >= 4 then String.sub p 2 2 else ""
|
|
|
|
and p3 = if len >= 6 then String.sub p 4 2 else ""
|
|
|
|
and p4 = if len >= 8 then String.sub p 6 2 else ""
|
2016-11-14 19:26:34 +04:00
|
|
|
and p5 = if len >= 10 then String.sub p 8 2 else ""
|
|
|
|
and p6 = if len > 10 then String.sub p 10 (len - 10) else "" in
|
|
|
|
[ p1 ; p2 ; p3 ; p4 ; p5 ; p6 ]
|
|
|
|
|
2017-02-24 20:17:53 +04:00
|
|
|
module Table = struct
|
|
|
|
include Hashtbl.Make(struct
|
2017-11-13 19:34:00 +04:00
|
|
|
type nonrec t = t
|
|
|
|
let hash s =
|
|
|
|
Int64.to_int
|
|
|
|
(EndianString.BigEndian.get_int64
|
|
|
|
(Bytes.unsafe_to_string (Sodium.Generichash.Bytes.of_hash s))
|
|
|
|
0)
|
|
|
|
let equal = equal
|
|
|
|
end)
|
2017-02-24 20:17:53 +04:00
|
|
|
end
|
|
|
|
|
2016-11-14 19:26:34 +04:00
|
|
|
end
|
|
|
|
|
2016-11-25 22:46:50 +04:00
|
|
|
module Make_Blake2B (R : sig
|
2016-11-14 19:26:34 +04:00
|
|
|
val register_encoding:
|
|
|
|
prefix: string ->
|
2017-02-19 21:22:32 +04:00
|
|
|
length:int ->
|
2016-11-14 19:26:34 +04:00
|
|
|
to_raw: ('a -> string) ->
|
|
|
|
of_raw: (string -> 'a option) ->
|
2017-02-19 21:22:32 +04:00
|
|
|
wrap: ('a -> Base58.data) ->
|
|
|
|
'a Base58.encoding
|
2016-11-14 19:26:34 +04:00
|
|
|
end) (K : PrefixedName) = struct
|
|
|
|
|
2016-11-25 22:46:50 +04:00
|
|
|
include Make_minimal_Blake2B(K)
|
2016-10-06 20:30:04 +04:00
|
|
|
|
2016-09-08 21:13:10 +04:00
|
|
|
(* Serializers *)
|
|
|
|
|
2017-02-19 21:22:32 +04:00
|
|
|
type Base58.data += Hash of t
|
2016-11-14 19:26:34 +04:00
|
|
|
|
2017-02-19 21:22:32 +04:00
|
|
|
let b58check_encoding =
|
2016-11-14 19:26:34 +04:00
|
|
|
R.register_encoding
|
2017-02-19 21:22:32 +04:00
|
|
|
~prefix: K.b58check_prefix
|
|
|
|
~length:size
|
2016-11-25 22:46:50 +04:00
|
|
|
~wrap: (fun s -> Hash s)
|
2017-02-24 20:17:53 +04:00
|
|
|
~of_raw:(fun h -> of_string h) ~to_raw:to_string
|
2016-11-14 19:26:34 +04:00
|
|
|
|
2017-04-05 11:54:21 +04:00
|
|
|
let of_b58check_opt s =
|
|
|
|
Base58.simple_decode b58check_encoding s
|
|
|
|
let of_b58check_exn s =
|
2017-02-19 21:22:32 +04:00
|
|
|
match Base58.simple_decode b58check_encoding s with
|
2016-11-14 19:26:34 +04:00
|
|
|
| Some x -> x
|
2017-04-05 11:54:21 +04:00
|
|
|
| None -> Format.kasprintf Pervasives.failwith "Unexpected hash (%s)" K.name
|
|
|
|
let of_b58check s =
|
|
|
|
match Base58.simple_decode b58check_encoding s with
|
|
|
|
| Some x -> Ok x
|
|
|
|
| None -> generic_error "Unexpected hash (%s)" K.name
|
2017-02-19 21:22:32 +04:00
|
|
|
let to_b58check s = Base58.simple_encode b58check_encoding s
|
2016-11-14 19:26:34 +04:00
|
|
|
|
2017-02-19 21:22:32 +04:00
|
|
|
let to_short_b58check s =
|
|
|
|
String.sub (to_b58check s) 0 (10 + 2 * String.length K.b58check_prefix)
|
2016-11-14 19:26:34 +04:00
|
|
|
|
2016-09-08 21:13:10 +04:00
|
|
|
let encoding =
|
|
|
|
let open Data_encoding in
|
|
|
|
splitted
|
|
|
|
~binary:
|
2017-02-24 20:17:53 +04:00
|
|
|
(conv to_bytes of_bytes_exn (Fixed.bytes size))
|
2016-09-08 21:13:10 +04:00
|
|
|
~json:
|
2017-11-08 20:52:21 +04:00
|
|
|
(describe ~title: (K.title ^ " (Base58Check-encoded Blake2B hash)") @@
|
2017-04-05 11:54:21 +04:00
|
|
|
conv to_b58check (Data_encoding.Json.wrap_error of_b58check_exn) string)
|
2016-09-08 21:13:10 +04:00
|
|
|
|
|
|
|
let param ?(name=K.name) ?(desc=K.title) t =
|
2017-09-27 11:55:20 +04:00
|
|
|
Cli_entries.param
|
|
|
|
~name
|
|
|
|
~desc (Cli_entries.parameter (fun _ str -> Lwt.return (of_b58check str))) t
|
2016-09-08 21:13:10 +04:00
|
|
|
|
|
|
|
let pp ppf t =
|
2017-02-19 21:22:32 +04:00
|
|
|
Format.pp_print_string ppf (to_b58check t)
|
2016-09-08 21:13:10 +04:00
|
|
|
|
|
|
|
let pp_short ppf t =
|
2017-02-19 21:22:32 +04:00
|
|
|
Format.pp_print_string ppf (to_short_b58check t)
|
2016-09-08 21:13:10 +04:00
|
|
|
|
2017-02-24 20:17:53 +04:00
|
|
|
module Set = struct
|
|
|
|
include Set.Make(struct type nonrec t = t let compare = compare end)
|
2017-09-29 20:43:13 +04:00
|
|
|
exception Found of elt
|
|
|
|
let random_elt s =
|
|
|
|
let n = Random.int (cardinal s) in
|
|
|
|
try
|
|
|
|
ignore
|
|
|
|
(fold (fun x i -> if i = n then raise (Found x) ; i+1) s 0 : int) ;
|
|
|
|
assert false
|
|
|
|
with Found x -> x
|
2017-02-24 20:17:53 +04:00
|
|
|
let encoding =
|
|
|
|
Data_encoding.conv
|
|
|
|
elements
|
|
|
|
(fun l -> List.fold_left (fun m x -> add x m) empty l)
|
|
|
|
Data_encoding.(list encoding)
|
|
|
|
end
|
|
|
|
|
2017-09-29 20:43:13 +04:00
|
|
|
let random_set_elt = Set.random_elt
|
|
|
|
|
2017-02-24 20:17:53 +04:00
|
|
|
module Map = struct
|
|
|
|
include Map.Make(struct type nonrec t = t let compare = compare end)
|
|
|
|
let encoding arg_encoding =
|
|
|
|
Data_encoding.conv
|
|
|
|
bindings
|
|
|
|
(fun l -> List.fold_left (fun m (k,v) -> add k v m) empty l)
|
|
|
|
Data_encoding.(list (tup2 encoding arg_encoding))
|
|
|
|
end
|
|
|
|
|
2016-09-08 21:13:10 +04:00
|
|
|
end
|
|
|
|
|
2017-03-16 20:17:06 +04:00
|
|
|
module Generic_Merkle_tree (H : sig
|
|
|
|
type t
|
|
|
|
type elt
|
|
|
|
val encoding : t Data_encoding.t
|
|
|
|
val empty : t
|
|
|
|
val leaf : elt -> t
|
|
|
|
val node : t -> t -> t
|
|
|
|
end) = struct
|
|
|
|
|
|
|
|
let rec step a n =
|
|
|
|
let m = (n+1) / 2 in
|
|
|
|
for i = 0 to m - 1 do
|
|
|
|
a.(i) <- H.node a.(2*i) a.(2*i+1)
|
|
|
|
done ;
|
|
|
|
a.(m) <- H.node a.(n) a.(n) ;
|
|
|
|
if m = 1 then
|
|
|
|
a.(0)
|
|
|
|
else if m mod 2 = 0 then
|
|
|
|
step a m
|
|
|
|
else begin
|
|
|
|
a.(m+1) <- a.(m) ;
|
|
|
|
step a (m+1)
|
|
|
|
end
|
|
|
|
|
|
|
|
let empty = H.empty
|
|
|
|
|
|
|
|
let compute xs =
|
|
|
|
match xs with
|
|
|
|
| [] -> H.empty
|
|
|
|
| [x] -> H.leaf x
|
|
|
|
| _ :: _ :: _ ->
|
|
|
|
let last = Utils.list_last_exn xs in
|
|
|
|
let n = List.length xs in
|
|
|
|
let a = Array.make (n+1) (H.leaf last) in
|
|
|
|
List.iteri (fun i x -> a.(i) <- H.leaf x) xs ;
|
|
|
|
step a n
|
|
|
|
|
|
|
|
type path =
|
|
|
|
| Left of path * H.t
|
|
|
|
| Right of H.t * path
|
|
|
|
| Op
|
|
|
|
|
|
|
|
let rec step_path a n p j =
|
|
|
|
let m = (n+1) / 2 in
|
|
|
|
let p = if j mod 2 = 0 then Left (p, a.(j+1)) else Right (a.(j-1), p) in
|
|
|
|
for i = 0 to m - 1 do
|
|
|
|
a.(i) <- H.node a.(2*i) a.(2*i+1)
|
|
|
|
done ;
|
|
|
|
a.(m) <- H.node a.(n) a.(n) ;
|
|
|
|
if m = 1 then
|
|
|
|
p
|
|
|
|
else if m mod 2 = 0 then
|
|
|
|
step_path a m p (j/2)
|
|
|
|
else begin
|
|
|
|
a.(m+1) <- a.(m) ;
|
|
|
|
step_path a (m+1) p (j/2)
|
|
|
|
end
|
|
|
|
|
|
|
|
let compute_path xs i =
|
|
|
|
match xs with
|
|
|
|
| [] -> invalid_arg "compute_path"
|
|
|
|
| [_] -> Op
|
|
|
|
| _ :: _ :: _ ->
|
|
|
|
let last = Utils.list_last_exn xs in
|
|
|
|
let n = List.length xs in
|
|
|
|
if i < 0 || n <= i then invalid_arg "compute_path" ;
|
|
|
|
let a = Array.make (n+1) (H.leaf last) in
|
|
|
|
List.iteri (fun i x -> a.(i) <- H.leaf x) xs ;
|
|
|
|
step_path a n Op i
|
|
|
|
|
|
|
|
let rec check_path p h =
|
|
|
|
match p with
|
|
|
|
| Op ->
|
|
|
|
H.leaf h, 1, 0
|
|
|
|
| Left (p, r) ->
|
|
|
|
let l, s, pos = check_path p h in
|
|
|
|
H.node l r, s * 2, pos
|
|
|
|
| Right (l, p) ->
|
|
|
|
let r, s, pos = check_path p h in
|
|
|
|
H.node l r, s * 2, pos + s
|
|
|
|
|
|
|
|
let check_path p h =
|
|
|
|
let h, _, pos = check_path p h in
|
|
|
|
h, pos
|
|
|
|
|
|
|
|
let path_encoding =
|
|
|
|
let open Data_encoding in
|
|
|
|
mu "path"
|
|
|
|
(fun path_encoding ->
|
|
|
|
union [
|
|
|
|
case ~tag:240
|
|
|
|
(obj2
|
|
|
|
(req "path" path_encoding)
|
|
|
|
(req "right" H.encoding))
|
|
|
|
(function Left (p, r) -> Some (p, r) | _ -> None)
|
|
|
|
(fun (p, r) -> Left (p, r)) ;
|
|
|
|
case ~tag:15
|
|
|
|
(obj2
|
|
|
|
(req "left" H.encoding)
|
|
|
|
(req "path" path_encoding))
|
|
|
|
(function Right (r, p) -> Some (r, p) | _ -> None)
|
|
|
|
(fun (r, p) -> Right (r, p)) ;
|
|
|
|
case ~tag:0
|
|
|
|
unit
|
|
|
|
(function Op -> Some () | _ -> None)
|
|
|
|
(fun () -> Op)
|
|
|
|
])
|
2016-09-08 21:13:10 +04:00
|
|
|
|
|
|
|
end
|
|
|
|
|
2017-03-16 20:17:06 +04:00
|
|
|
module Make_merkle_tree
|
|
|
|
(R : sig
|
|
|
|
val register_encoding:
|
|
|
|
prefix: string ->
|
|
|
|
length:int ->
|
|
|
|
to_raw: ('a -> string) ->
|
|
|
|
of_raw: (string -> 'a option) ->
|
|
|
|
wrap: ('a -> Base58.data) ->
|
|
|
|
'a Base58.encoding
|
|
|
|
end)
|
|
|
|
(K : PrefixedName)
|
|
|
|
(Contents: sig
|
|
|
|
type t
|
|
|
|
val to_bytes: t -> MBytes.t
|
|
|
|
end) = struct
|
|
|
|
|
|
|
|
include Make_Blake2B (R) (K)
|
|
|
|
|
|
|
|
type elt = Contents.t
|
|
|
|
|
|
|
|
let empty = hash_bytes []
|
|
|
|
|
|
|
|
include Generic_Merkle_tree(struct
|
|
|
|
type nonrec t = t
|
|
|
|
type nonrec elt = elt
|
|
|
|
let encoding = encoding
|
|
|
|
let empty = empty
|
|
|
|
let leaf x = hash_bytes [Contents.to_bytes x]
|
|
|
|
let node x y = hash_bytes [to_bytes x; to_bytes y]
|
|
|
|
end)
|
2016-09-08 21:13:10 +04:00
|
|
|
|
2017-03-16 20:17:06 +04:00
|
|
|
end
|
2016-09-08 21:13:10 +04:00
|
|
|
|
|
|
|
(*-- Pre-instanciated hashes ------------------------------------------------*)
|
|
|
|
|
|
|
|
module Block_hash =
|
2017-02-19 21:22:32 +04:00
|
|
|
Make_Blake2B (Base58) (struct
|
2016-09-08 21:13:10 +04:00
|
|
|
let name = "Block_hash"
|
|
|
|
let title = "A Tezos block ID"
|
2017-02-19 21:22:32 +04:00
|
|
|
let b58check_prefix = Base58.Prefix.block_hash
|
2016-11-25 22:46:50 +04:00
|
|
|
let size = None
|
2016-09-08 21:13:10 +04:00
|
|
|
end)
|
|
|
|
|
|
|
|
module Operation_hash =
|
2017-02-19 21:22:32 +04:00
|
|
|
Make_Blake2B (Base58) (struct
|
2016-09-08 21:13:10 +04:00
|
|
|
let name = "Operation_hash"
|
|
|
|
let title = "A Tezos operation ID"
|
2017-02-19 21:22:32 +04:00
|
|
|
let b58check_prefix = Base58.Prefix.operation_hash
|
2016-11-25 22:46:50 +04:00
|
|
|
let size = None
|
2017-03-16 20:17:06 +04:00
|
|
|
end)
|
|
|
|
|
|
|
|
module Operation_list_hash =
|
|
|
|
Make_merkle_tree (Base58) (struct
|
|
|
|
let name = "Operation_list_hash"
|
|
|
|
let title = "A list of operations"
|
|
|
|
let b58check_prefix = Base58.Prefix.operation_list_hash
|
|
|
|
let size = None
|
|
|
|
end) (Operation_hash)
|
|
|
|
|
|
|
|
module Operation_list_list_hash =
|
|
|
|
Make_merkle_tree (Base58) (struct
|
|
|
|
let name = "Operation_list_list_hash"
|
|
|
|
let title = "A list of list of operations"
|
|
|
|
let b58check_prefix = Base58.Prefix.operation_list_list_hash
|
|
|
|
let size = None
|
|
|
|
end) (Operation_list_hash)
|
2016-09-08 21:13:10 +04:00
|
|
|
|
|
|
|
module Protocol_hash =
|
2017-02-19 21:22:32 +04:00
|
|
|
Make_Blake2B (Base58) (struct
|
2016-09-08 21:13:10 +04:00
|
|
|
let name = "Protocol_hash"
|
|
|
|
let title = "A Tezos protocol ID"
|
2017-02-19 21:22:32 +04:00
|
|
|
let b58check_prefix = Base58.Prefix.protocol_hash
|
2016-11-25 22:46:50 +04:00
|
|
|
let size = None
|
2016-09-08 21:13:10 +04:00
|
|
|
end)
|
|
|
|
|
2016-11-25 22:46:50 +04:00
|
|
|
module Generic_hash =
|
|
|
|
Make_minimal_Blake2B (struct
|
|
|
|
let name = "Generic_hash"
|
|
|
|
let title = ""
|
|
|
|
let size = None
|
|
|
|
end)
|
|
|
|
|
2017-03-31 15:04:05 +04:00
|
|
|
module Net_id = struct
|
|
|
|
|
|
|
|
type t = string
|
|
|
|
|
|
|
|
let name = "Net_id"
|
|
|
|
let title = "Network identifier"
|
|
|
|
|
|
|
|
let size = 4
|
|
|
|
|
2017-09-22 00:24:10 +04:00
|
|
|
let extract bh =
|
2017-03-31 15:04:05 +04:00
|
|
|
MBytes.substring (Block_hash.to_bytes bh) 0 4
|
|
|
|
|
2017-09-22 00:24:10 +04:00
|
|
|
let hash_bytes l = extract (Block_hash.hash_bytes l)
|
|
|
|
let hash_string l = extract (Block_hash.hash_string l)
|
|
|
|
|
|
|
|
let of_block_hash bh = hash_bytes [Block_hash.to_bytes bh]
|
2017-03-31 15:04:05 +04:00
|
|
|
|
|
|
|
type Base58.data += Hash of t
|
|
|
|
|
|
|
|
let of_string s =
|
|
|
|
if String.length s <> size then None else Some s
|
|
|
|
let of_string_exn s =
|
|
|
|
match of_string s with
|
|
|
|
| None ->
|
|
|
|
let msg =
|
|
|
|
Printf.sprintf "%s.of_string: wrong string size (%d)"
|
|
|
|
name (String.length s) in
|
|
|
|
raise (Invalid_argument msg)
|
|
|
|
| Some h -> h
|
|
|
|
let to_string s = s
|
|
|
|
|
|
|
|
let of_hex s = of_string (Hex_encode.hex_decode s)
|
|
|
|
let of_hex_exn s = of_string_exn (Hex_encode.hex_decode s)
|
|
|
|
let to_hex s = Hex_encode.hex_encode (to_string s)
|
|
|
|
|
|
|
|
let compare = String.compare
|
|
|
|
let equal = String.equal
|
|
|
|
|
|
|
|
let of_bytes b =
|
|
|
|
if MBytes.length b <> size then
|
|
|
|
None
|
|
|
|
else
|
|
|
|
Some (MBytes.to_string b)
|
|
|
|
let of_bytes_exn b =
|
|
|
|
match of_bytes b with
|
|
|
|
| None ->
|
|
|
|
let msg =
|
|
|
|
Printf.sprintf "%s.of_bytes: wrong string size (%d)"
|
|
|
|
name (MBytes.length b) in
|
|
|
|
raise (Invalid_argument msg)
|
|
|
|
| Some h -> h
|
|
|
|
let to_bytes = MBytes.of_string
|
|
|
|
|
|
|
|
let read src off = of_bytes_exn @@ MBytes.sub src off size
|
|
|
|
let write dst off h = MBytes.blit (to_bytes h) 0 dst off size
|
|
|
|
|
|
|
|
let b58check_encoding =
|
|
|
|
Base58.register_encoding
|
|
|
|
~prefix: Base58.Prefix.net_id
|
|
|
|
~length: size
|
|
|
|
~wrap: (fun s -> Hash s)
|
|
|
|
~of_raw:of_string ~to_raw: (fun h -> h)
|
|
|
|
|
2017-04-05 11:54:21 +04:00
|
|
|
let of_b58check_opt s =
|
|
|
|
Base58.simple_decode b58check_encoding s
|
|
|
|
let of_b58check_exn s =
|
2017-03-31 15:04:05 +04:00
|
|
|
match Base58.simple_decode b58check_encoding s with
|
|
|
|
| Some x -> x
|
2017-04-05 11:54:21 +04:00
|
|
|
| None -> Format.kasprintf Pervasives.failwith "Unexpected hash (%s)" name
|
|
|
|
let of_b58check s =
|
|
|
|
match Base58.simple_decode b58check_encoding s with
|
|
|
|
| Some x -> Ok x
|
|
|
|
| None -> generic_error "Unexpected hash (%s)" name
|
2017-03-31 15:04:05 +04:00
|
|
|
let to_b58check s = Base58.simple_encode b58check_encoding s
|
|
|
|
let to_short_b58check = to_b58check
|
|
|
|
|
|
|
|
let encoding =
|
|
|
|
let open Data_encoding in
|
|
|
|
splitted
|
|
|
|
~binary: (Fixed.string size)
|
|
|
|
~json:
|
2017-11-08 20:52:21 +04:00
|
|
|
(describe ~title: (title ^ " (Base58Check-encoded Blake2B hash)") @@
|
2017-04-05 11:54:21 +04:00
|
|
|
conv to_b58check (Data_encoding.Json.wrap_error of_b58check_exn) string)
|
2017-03-31 15:04:05 +04:00
|
|
|
|
|
|
|
let param ?(name=name) ?(desc=title) t =
|
2017-09-27 11:55:20 +04:00
|
|
|
Cli_entries.(param ~name ~desc (parameter (fun _ str -> Lwt.return (of_b58check str))) t)
|
2017-03-31 15:04:05 +04:00
|
|
|
|
|
|
|
let pp ppf t =
|
|
|
|
Format.pp_print_string ppf (to_b58check t)
|
|
|
|
|
|
|
|
let pp_short ppf t =
|
|
|
|
Format.pp_print_string ppf (to_short_b58check t)
|
|
|
|
|
|
|
|
module Set = struct
|
|
|
|
include Set.Make(struct type nonrec t = t let compare = compare end)
|
2017-09-29 20:43:13 +04:00
|
|
|
exception Found of elt
|
|
|
|
let random_elt s =
|
|
|
|
let n = Random.int (cardinal s) in
|
|
|
|
try
|
|
|
|
ignore
|
|
|
|
(fold (fun x i -> if i = n then raise (Found x) ; i+1) s 0 : int) ;
|
|
|
|
assert false
|
|
|
|
with Found x -> x
|
2017-03-31 15:04:05 +04:00
|
|
|
let encoding =
|
|
|
|
Data_encoding.conv
|
|
|
|
elements
|
|
|
|
(fun l -> List.fold_left (fun m x -> add x m) empty l)
|
|
|
|
Data_encoding.(list encoding)
|
|
|
|
end
|
2017-09-29 20:43:13 +04:00
|
|
|
let random_set_elt = Set.random_elt
|
2017-03-31 15:04:05 +04:00
|
|
|
|
|
|
|
module Map = struct
|
|
|
|
include Map.Make(struct type nonrec t = t let compare = compare end)
|
|
|
|
let encoding arg_encoding =
|
|
|
|
Data_encoding.conv
|
|
|
|
bindings
|
|
|
|
(fun l -> List.fold_left (fun m (k,v) -> add k v m) empty l)
|
|
|
|
Data_encoding.(list (tup2 encoding arg_encoding))
|
|
|
|
end
|
|
|
|
|
|
|
|
let fold_read f buf off len init =
|
|
|
|
let last = off + len * size in
|
|
|
|
if last > MBytes.length buf then
|
|
|
|
invalid_arg "Hash.read_set: invalid size.";
|
|
|
|
let rec loop acc off =
|
|
|
|
if off >= last then
|
|
|
|
acc
|
|
|
|
else
|
|
|
|
let hash = read buf off in
|
|
|
|
loop (f hash acc) (off + size)
|
|
|
|
in
|
|
|
|
loop init off
|
|
|
|
|
|
|
|
let path_length = 1
|
|
|
|
let to_path key = [to_hex key]
|
|
|
|
let of_path path =
|
|
|
|
let path = String.concat "" path in
|
|
|
|
of_hex path
|
|
|
|
let of_path_exn path =
|
|
|
|
let path = String.concat "" path in
|
|
|
|
of_hex_exn path
|
|
|
|
|
|
|
|
let prefix_path p =
|
|
|
|
let p = Hex_encode.hex_encode p in
|
|
|
|
[ p ]
|
|
|
|
|
|
|
|
module Table = struct
|
|
|
|
include Hashtbl.Make(struct
|
2017-11-13 19:34:00 +04:00
|
|
|
type nonrec t = t
|
|
|
|
let hash = Hashtbl.hash
|
|
|
|
let equal = equal
|
|
|
|
end)
|
2017-03-31 15:04:05 +04:00
|
|
|
end
|
|
|
|
|
|
|
|
end
|
|
|
|
|
2017-02-19 21:22:32 +04:00
|
|
|
let () =
|
|
|
|
Base58.check_encoded_prefix Block_hash.b58check_encoding "B" 51 ;
|
|
|
|
Base58.check_encoded_prefix Operation_hash.b58check_encoding "o" 51 ;
|
2017-03-16 20:17:06 +04:00
|
|
|
Base58.check_encoded_prefix Operation_list_hash.b58check_encoding "Lo" 52 ;
|
|
|
|
Base58.check_encoded_prefix Operation_list_list_hash.b58check_encoding "LLo" 53 ;
|
2017-03-31 15:04:05 +04:00
|
|
|
Base58.check_encoded_prefix Protocol_hash.b58check_encoding "P" 51 ;
|
|
|
|
Base58.check_encoded_prefix Net_id.b58check_encoding "Net" 15
|