From 07ba685b8d4328db694e992466c4d29d0c5d3b01 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Fri, 23 Sep 2016 15:06:17 +0200 Subject: [PATCH 01/10] Base48: encode the "data" before its "hash" --- src/client/embedded/bootstrap/client_proto_main.ml | 2 +- src/client/embedded/demo/client_proto_main.ml | 2 +- src/node/shell/node.ml | 2 +- src/node_main.ml | 6 +++--- src/proto/bootstrap/TEZOS_PROTOCOL | 4 +++- src/proto/demo/TEZOS_PROTOCOL | 2 +- src/utils/base48.ml | 8 ++++---- test/test_context.ml | 4 ++-- test/test_state.ml | 4 ++-- test/test_store.ml | 4 ++-- 10 files changed, 20 insertions(+), 18 deletions(-) diff --git a/src/client/embedded/bootstrap/client_proto_main.ml b/src/client/embedded/bootstrap/client_proto_main.ml index bc4d0155e..18122b9f7 100644 --- a/src/client/embedded/bootstrap/client_proto_main.ml +++ b/src/client/embedded/bootstrap/client_proto_main.ml @@ -9,7 +9,7 @@ let protocol = Protocol_hash.of_b48check - "TnrnfGHMCPAcxtMAHXdpfebbnn2XvPAxq7DHbpeJbKTkJQPgcgRGr" + "4prgmSgbaeMKbgLtLjpsHaDD9QvG2dbC2bLq2XBmyxd2RJgLFpcAg" let () = Client_version.register protocol @@ diff --git a/src/client/embedded/demo/client_proto_main.ml b/src/client/embedded/demo/client_proto_main.ml index af367ffc1..355588a37 100644 --- a/src/client/embedded/demo/client_proto_main.ml +++ b/src/client/embedded/demo/client_proto_main.ml @@ -9,7 +9,7 @@ let protocol = Protocol_hash.of_b48check - "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + "2gagXCT66nmJ2mKh3a6Aeysy9CHaHsAJyDEGSyFNeFAxGCJehsKpK" let demo () = let block = Client_config.block () in diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index 22534aca5..0ee7704bb 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -330,7 +330,7 @@ module RPC = struct let prevalidation_hash = Block_hash.of_b48check - "Et22nEeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + "eeeeeeeeeeeeeegqJHARhSaNXggmMs8K3tvsgn4rBprkvpFAMVD5d" let get_net node = function | `Head _ | `Prevalidation -> node.global_validator, node.global_net diff --git a/src/node_main.ml b/src/node_main.ml index 8c52837d4..949071c9c 100644 --- a/src/node_main.ml +++ b/src/node_main.ml @@ -12,15 +12,15 @@ open Logging.Node.Main let genesis_block = Block_hash.of_b48check - "qBeeesNtMrdyRDj6hSK2PxEN9R67brGSm64EFRjJSBTTqLcQCRHNR" + "eeHfgnr9QeDNvcMgSfATNeDeec4KG4CkHHkNNJt5B9xdVmsxhsHNR" let genesis_protocol = Protocol_hash.of_b48check - "TnrnfGHMCPAcxtMAHXdpfebbnn2XvPAxq7DHbpeJbKTkJQPgcgRGr" + "4prgmSgbaeMKbgLtLjpsHaDD9QvG2dbC2bLq2XBmyxd2RJgLFpcAg" let test_protocol = Some (Protocol_hash.of_b48check - "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee") + "2gagXCT66nmJ2mKh3a6Aeysy9CHaHsAJyDEGSyFNeFAxGCJehsKpK") let genesis_time = Time.of_notation_exn "2016-08-01T00:00:00Z" diff --git a/src/proto/bootstrap/TEZOS_PROTOCOL b/src/proto/bootstrap/TEZOS_PROTOCOL index 50b9fca67..86d10d8c3 100644 --- a/src/proto/bootstrap/TEZOS_PROTOCOL +++ b/src/proto/bootstrap/TEZOS_PROTOCOL @@ -1,8 +1,10 @@ { - "hash": "TnrnfGHMCPAcxtMAHXdpfebbnn2XvPAxq7DHbpeJbKTkJQPgcgRGr", + "hash": "4prgmSgbaeMKbgLtLjpsHaDD9QvG2dbC2bLq2XBmyxd2RJgLFpcAg", "modules": [ + "Misc", "Tezos_hash", + "Qty_repr", "Tez_repr", "Period_repr", diff --git a/src/proto/demo/TEZOS_PROTOCOL b/src/proto/demo/TEZOS_PROTOCOL index ab9f2dec6..08eb00275 100644 --- a/src/proto/demo/TEZOS_PROTOCOL +++ b/src/proto/demo/TEZOS_PROTOCOL @@ -1,4 +1,4 @@ { - "hash": "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee", + "hash": "2gagXCT66nmJ2mKh3a6Aeysy9CHaHsAJyDEGSyFNeFAxGCJehsKpK", "modules": ["Error", "Services", "Main"] } diff --git a/src/utils/base48.ml b/src/utils/base48.ml index 6c9d9471e..619603217 100644 --- a/src/utils/base48.ml +++ b/src/utils/base48.ml @@ -15,7 +15,7 @@ let decode_alphabet alphabet = Bytes.to_string str let default_alphabet = - "eXMNE9qvHPQDdcFx5J86rT7VRm2atAypGhgLfbS3CKjnksB4" + "eE2NXaQvHPqDdTJxfF36jb7VRmp9tAyMgG4L5cS8CKrnksBh" let default_decode_alphabet = decode_alphabet default_alphabet @@ -85,13 +85,13 @@ let sha256 s = computed_hash let safe_encode ?alphabet s = - raw_encode ?alphabet (String.sub (sha256 (sha256 s)) 0 4 ^ s) + raw_encode ?alphabet (s ^ String.sub (sha256 (sha256 s)) 0 4) let safe_decode ?alphabet s = let s = raw_decode ?alphabet s in let len = String.length s in - let msg_hash = String.sub s 0 4 in - let msg = String.sub s 4 (len-4) in + let msg = String.sub s 0 (len-4) + and msg_hash = String.sub s (len-4) 4 in if msg_hash <> String.sub (sha256 (sha256 msg)) 0 4 then invalid_arg "safe_decode" ; msg diff --git a/test/test_context.ml b/test/test_context.ml index c3f7efd5c..81c838fc7 100644 --- a/test/test_context.ml +++ b/test/test_context.ml @@ -18,11 +18,11 @@ let (//) = Filename.concat let genesis_block = Block_hash.of_b48check - "Et22nEeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + "eeeeeeeeeeeeeegqJHARhSaNXggmMs8K3tvsgn4rBprkvpFAMVD5d" let genesis_protocol = Protocol_hash.of_b48check - "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + "2gagXCT66nmJ2mKh3a6Aeysy9CHaHsAJyDEGSyFNeFAxGCJehsKpK" let genesis_time = Time.of_seconds 0L diff --git a/test/test_state.ml b/test/test_state.ml index 8d0dabf19..75497e440 100644 --- a/test/test_state.ml +++ b/test/test_state.ml @@ -16,11 +16,11 @@ let (//) = Filename.concat let genesis_block = Block_hash.of_b48check - "Et22nEeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + "eeeeeeeeeeeeeegqJHARhSaNXggmMs8K3tvsgn4rBprkvpFAMVD5d" let genesis_protocol = Protocol_hash.of_b48check - "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + "2gagXCT66nmJ2mKh3a6Aeysy9CHaHsAJyDEGSyFNeFAxGCJehsKpK" let genesis_time = Time.of_seconds 0L diff --git a/test/test_store.ml b/test/test_store.ml index 94685add2..26602189f 100644 --- a/test/test_store.ml +++ b/test/test_store.ml @@ -18,11 +18,11 @@ let (//) = Filename.concat let genesis_block = Block_hash.of_b48check - "Et22nEeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + "eeeeeeeeeeeeeegqJHARhSaNXggmMs8K3tvsgn4rBprkvpFAMVD5d" let genesis_protocol = Protocol_hash.of_b48check - "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" + "2gagXCT66nmJ2mKh3a6Aeysy9CHaHsAJyDEGSyFNeFAxGCJehsKpK" let genesis_time = Time.of_seconds 0L From 1ce2643dc7b4098d3b1db852740236d9645b6cf1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Thu, 6 Oct 2016 18:30:04 +0200 Subject: [PATCH 02/10] Shell: add Base48.decode_partial --- src/Makefile | 6 ++-- src/node/db/store.ml | 43 +++++++++++++++++++++++++ src/proto/environment/base48.mli | 7 ++++- src/proto/environment/hash.mli | 2 ++ src/utils/base48.ml | 54 +++++++++++++++++++++++--------- src/utils/base48.mli | 10 +++++- src/utils/ed25519.ml | 6 ++-- src/utils/hash.ml | 28 ++++++++++++----- src/utils/hash.mli | 2 ++ src/utils/utils.ml | 8 +++++ src/utils/utils.mli | 2 ++ test/lib/assert.ml | 12 +++++++ test/lib/assert.mli | 16 +++++++--- test/test_store.ml | 20 ++++++++++++ 14 files changed, 181 insertions(+), 35 deletions(-) diff --git a/src/Makefile b/src/Makefile index 195086693..c381fdc1c 100644 --- a/src/Makefile +++ b/src/Makefile @@ -102,9 +102,9 @@ clean:: UTILS_LIB_INTFS := \ utils/mBytes.mli \ + utils/utils.mli \ utils/base48.mli \ utils/hex_encode.mli \ - utils/utils.mli \ utils/cli_entries.mli \ utils/compare.mli \ utils/data_encoding.mli \ @@ -118,9 +118,9 @@ UTILS_LIB_INTFS := \ UTILS_LIB_IMPLS := \ utils/mBytes.ml \ - utils/base48.ml \ - utils/hex_encode.ml \ utils/utils.ml \ + utils/hex_encode.ml \ + utils/base48.ml \ utils/cli_entries.ml \ utils/compare.ml \ utils/data_encoding.ml \ diff --git a/src/node/db/store.ml b/src/node/db/store.ml index 3673ecb6f..23744650f 100644 --- a/src/node/db/store.ml +++ b/src/node/db/store.ml @@ -50,6 +50,10 @@ module FS = struct let file = file_of_key root key in Lwt.return (Sys.file_exists file && not (Sys.is_directory file)) + let exists root key = + let file = file_of_key root key in + Sys.file_exists file + let get root key = mem root key >>= function | true -> @@ -222,6 +226,37 @@ module Make (K : KEY) (V : Persist.VALUE) = struct let keys _t = undefined_key_fn end +module MakeResolver (P: sig val prefix: string list end) (H: HASH) = struct + let plen = List.length P.prefix + let build path = + H.to_raw @@ H.of_path @@ + Utils.remove_elem_from_list plen path + let resolve t p = + let rec loop prefix = function + | [] -> Lwt.return [build prefix] + | "" :: ds -> + FS.list t [ prefix] >>= fun prefixes -> + Lwt_list.map_p (fun prefix -> loop prefix ds) prefixes + >|= List.flatten + | [d] -> + FS.list t [prefix] >>= fun prefixes -> + Lwt_list.filter_map_p (fun prefix -> + match remove_prefix d (List.hd (List.rev prefix)) with + | None -> Lwt.return_none + | Some _ -> Lwt.return (Some (build prefix)) + ) prefixes + | d :: ds -> + if FS.exists t prefix then + loop (prefix @ [d]) ds + else + Lwt.return_nil in + loop P.prefix (H.prefix_path p) + let register t = + match H.kind with + | None -> () + | Some kind -> Base48.register_resolver kind (resolve t) +end + module Data_store : IMPERATIVE_STORE with type t = FS.t = Make (Raw_key) (Raw_value) @@ -307,6 +342,9 @@ module Block_errors_key = struct end module Block_errors = Make (Block_errors_key) (Errors_value) +module Block_resolver = + MakeResolver(struct let prefix = ["blocks"] end)(Block_hash) + module Block = struct type t = FS.t type key = Block_hash.t @@ -458,6 +496,9 @@ module Operation_errors_key = struct end module Operation_errors = Make (Operation_errors_key) (Errors_value) +module Operation_resolver = + MakeResolver(struct let prefix = ["operations"] end)(Operation_hash) + module Operation = struct type t = FS.t type key = Operation_hash.t @@ -715,6 +756,8 @@ let net_destroy ~root { net_genesis } = let init root = raw_init ~root:(Filename.concat root "global") () >>= fun t -> + Block_resolver.register t ; + Operation_resolver.register t ; Lwt.return { block = Persist.share t ; blockchain = Persist.share t ; diff --git a/src/proto/environment/base48.mli b/src/proto/environment/base48.mli index 81eaf1df1..b2398c7a2 100644 --- a/src/proto/environment/base48.mli +++ b/src/proto/environment/base48.mli @@ -4,11 +4,16 @@ type data = .. val decode: ?alphabet:string -> string -> data val encode: ?alphabet:string -> data -> string +type kind + val register: prefix:string -> read:(data -> string option) -> build:(string -> data) -> - unit + kind + +val register_resolver: + kind -> (string -> string list Lwt.t) -> unit module Prefix : sig val protocol_prefix: string diff --git a/src/proto/environment/hash.mli b/src/proto/environment/hash.mli index f7deb5da7..785ef3165 100644 --- a/src/proto/environment/hash.mli +++ b/src/proto/environment/hash.mli @@ -29,11 +29,13 @@ module type HASH = sig val write: MBytes.t -> int -> t -> unit val to_path: t -> string list val of_path: string list -> t + val prefix_path: string -> string list val path_len: int val encoding: t Data_encoding.t val pp: Format.formatter -> t -> unit val pp_short: Format.formatter -> t -> unit type Base48.data += Hash of t + val kind: Base48.kind option end (** {2 Building Hashes} *******************************************************) diff --git a/src/utils/base48.ml b/src/utils/base48.ml index 619603217..080951c68 100644 --- a/src/utils/base48.ml +++ b/src/utils/base48.ml @@ -7,6 +7,10 @@ (* *) (**************************************************************************) +open Utils + +let (>>=) = Lwt.bind + let decode_alphabet alphabet = let str = Bytes.make 256 '\255' in for i = 0 to String.length alphabet - 1 do @@ -98,20 +102,14 @@ let safe_decode ?alphabet s = type data = .. -type kinds = +type kind = Kind : { prefix: string; read: data -> string option ; - build: string -> data } -> kinds + build: string -> data ; + mutable resolver: string -> string list Lwt.t ; + } -> kind -let kinds = ref ([] : kinds list) - -let remove_prefix ~prefix s = - let x = String.length prefix in - let n = String.length s in - if n >= x && String.sub s 0 x = prefix then - Some (String.sub s x (n - x)) - else - None +let kinds = ref ([] : kind list) exception Unknown_prefix @@ -137,14 +135,21 @@ let encode ?alphabet s = try find s !kinds with Not_found -> raise Unknown_prefix +let default_resolver _ = Lwt.return_nil + let register ~prefix ~read ~build = match List.find (fun (Kind {prefix=s}) -> remove_prefix s prefix <> None || remove_prefix prefix s <> None) !kinds with | exception Not_found -> - kinds := Kind { prefix ; read ; build } :: !kinds + let kind = + Kind { prefix ; read ; build ; resolver = default_resolver } in + kinds := kind :: !kinds ; + kind | Kind { prefix = s } -> Format.kasprintf Pervasives.failwith - "Base49.register: Conflicting prefixes: %S and %S." prefix s ; + "Base48.register: Conflicting prefixes: %S and %S." prefix s + +let register_resolver (Kind k) resolver = k.resolver <- resolver module Prefix = struct let block_hash = "\000" @@ -154,5 +159,26 @@ module Prefix = struct let public_key = "\004" let secret_key = "\005" let signature = "\006" - let protocol_prefix = "\255" + let protocol_prefix = "\015" end + +let decode_partial ?alphabet request = + let n = String.length request in + let s = raw_decode request ?alphabet in + let partial = String.sub s 0 (n/2) in + let rec find s = function + | [] -> Lwt.return_nil + | Kind { prefix ; build ; resolver } :: kinds -> + match remove_prefix ~prefix s with + | None -> find s kinds + | Some msg -> + resolver msg >>= fun msgs -> + let candidates = List.map build msgs in + Lwt.return @@ + List.filter + (fun data -> + match Utils.remove_prefix ~prefix:request (encode data) with + | None -> false + | Some _ -> true) + candidates in + find partial !kinds diff --git a/src/utils/base48.mli b/src/utils/base48.mli index 613516aa6..8877fe83b 100644 --- a/src/utils/base48.mli +++ b/src/utils/base48.mli @@ -1,3 +1,4 @@ + (**************************************************************************) (* *) (* Copyright (c) 2014 - 2016. *) @@ -15,11 +16,18 @@ type data = .. val decode: ?alphabet:string -> string -> data val encode: ?alphabet:string -> data -> string +val decode_partial: ?alphabet:string -> string -> data list Lwt.t + +type kind + val register: prefix:string -> read:(data -> string option) -> build:(string -> data) -> - unit + kind + +val register_resolver: + kind -> (string -> string list Lwt.t) -> unit module Prefix : sig val block_hash: string diff --git a/src/utils/ed25519.ml b/src/utils/ed25519.ml index 64fda8a56..2b04095ed 100644 --- a/src/utils/ed25519.ml +++ b/src/utils/ed25519.ml @@ -55,19 +55,19 @@ type Base48.data += | Secret_key of secret_key | Signature of signature -let () = +let _ = Base48.register ~prefix:Base48.Prefix.public_key ~read:(function Public_key x -> Some (Bytes.to_string (Sodium.Sign.Bytes.of_public_key x)) | _ -> None) ~build:(fun x -> Public_key (Sodium.Sign.Bytes.to_public_key (Bytes.of_string x))) -let () = +let _ = Base48.register ~prefix:Base48.Prefix.secret_key ~read:(function Secret_key x -> Some (Bytes.to_string (Sodium.Sign.Bytes.of_secret_key x)) | _ -> None) ~build:(fun x -> Secret_key (Sodium.Sign.Bytes.to_secret_key (Bytes.of_string x))) -let () = +let _ = Base48.register ~prefix:Base48.Prefix.signature ~read:(function Signature x -> Some (MBytes.to_string x) | _ -> None) diff --git a/src/utils/hash.ml b/src/utils/hash.ml index 4cfd75db3..d31e677b8 100644 --- a/src/utils/hash.ml +++ b/src/utils/hash.ml @@ -36,11 +36,13 @@ module type HASH = sig val write: MBytes.t -> int -> t -> unit val to_path: t -> string list val of_path: string list -> t + val prefix_path: string -> string list val path_len: int val encoding: t Data_encoding.t val pp: Format.formatter -> t -> unit val pp_short: Format.formatter -> t -> unit type Base48.data += Hash of t + val kind: Base48.kind option end module type Name = sig @@ -72,14 +74,14 @@ module Make_SHA256 (K : Name) = struct type Base48.data += Hash of t - let () = - match K.prefix with - | Some prefix -> - Base48.register - ~prefix - ~read:(function Hash x -> Some x | _ -> None) - ~build:(fun x -> Hash x) - | None -> () + let kind = + Utils.map_option + K.prefix + ~f:(fun prefix -> + Base48.register + ~prefix + ~read:(function Hash x -> Some x | _ -> None) + ~build:(fun x -> Hash x)) let of_b48check s = match Base48.decode s with @@ -151,6 +153,16 @@ module Make_SHA256 (K : Name) = struct let path = String.concat "" path in of_hex path + let prefix_path p = + let p = to_hex p in + 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 "" + and p5 = if len > 8 then String.sub p 8 (len - 8) else "" in + [ p1 ; p2 ; p3 ; p4 ; p5 ] + (* Serializers *) let encoding = diff --git a/src/utils/hash.mli b/src/utils/hash.mli index 7ca62e7a5..08eba0e71 100644 --- a/src/utils/hash.mli +++ b/src/utils/hash.mli @@ -38,11 +38,13 @@ module type HASH = sig val write: MBytes.t -> int -> t -> unit val to_path: t -> string list val of_path: string list -> t + val prefix_path: string -> string list val path_len: int val encoding: t Data_encoding.t val pp: Format.formatter -> t -> unit val pp_short: Format.formatter -> t -> unit type Base48.data += Hash of t + val kind: Base48.kind option end (** {2 Building Hashes} *******************************************************) diff --git a/src/utils/utils.ml b/src/utils/utils.ml index 60988ac6e..d4ed38aeb 100644 --- a/src/utils/utils.ml +++ b/src/utils/utils.ml @@ -122,6 +122,14 @@ let rec remove_elem_from_list nb = function | l when nb <= 0 -> l | _ :: tl -> remove_elem_from_list (nb - 1) tl +let remove_prefix ~prefix s = + let x = String.length prefix in + let n = String.length s in + if n >= x && String.sub s 0 x = prefix then + Some (String.sub s x (n - x)) + else + None + let finalize f g = try let res = f () in g (); res with exn -> g (); raise exn let read_file ?(bin=false) fn = diff --git a/src/utils/utils.mli b/src/utils/utils.mli index 7cff8939d..3d87afcad 100644 --- a/src/utils/utils.mli +++ b/src/utils/utils.mli @@ -36,6 +36,8 @@ val display_paragraph: Format.formatter -> string -> unit (** [remove nb list] remove the first [nb] elements from the list [list]. *) val remove_elem_from_list: int -> 'a list -> 'a list +val remove_prefix: prefix:string -> string -> string option + val filter_map: ('a -> 'b option) -> 'a list -> 'b list val finalize: (unit -> 'a) -> (unit -> unit) -> 'a diff --git a/test/lib/assert.ml b/test/lib/assert.ml index 14aa3fbd7..a86434461 100644 --- a/test/lib/assert.ml +++ b/test/lib/assert.ml @@ -7,6 +7,7 @@ (* *) (**************************************************************************) +open Hash open Kaputt.Abbreviations include Kaputt.Assertion @@ -21,6 +22,17 @@ let equal_persist_list ?msg l1 l2 = Printf.sprintf "[%s]" res in Assert.make_equal_list ?msg (=) pr_persist l1 l2 +let equal_block_hash_list ?msg l1 l2 = + let msg = format_msg msg in + let pr_block_hash = Block_hash.to_short_b48check in + Assert.make_equal_list ?msg Block_hash.equal pr_block_hash l1 l2 + +let equal_base48_list ?msg l1 l2 = + let msg = format_msg msg in + let pr_base48 = Base48.encode in + (* TODO do not use polymorphic equality ! *) + Assert.make_equal_list ?msg (=) pr_base48 l1 l2 + let equal_string_option ?msg o1 o2 = let msg = format_msg msg in let prn = function diff --git a/test/lib/assert.mli b/test/lib/assert.mli index 08dbdff69..de31ce4d7 100644 --- a/test/lib/assert.mli +++ b/test/lib/assert.mli @@ -7,7 +7,7 @@ (* *) (**************************************************************************) - +open Hash include (module type of struct include Kaputt.Assertion end) val fail_msg : ('a, Format.formatter, unit, 'b) format4 -> 'a @@ -17,6 +17,12 @@ val fail : string -> string -> ('a, Format.formatter, unit, 'b) format4 -> 'a val equal_persist_list : ?msg:string -> Persist.key list -> Persist.key list -> unit +val equal_block_hash_list : + ?msg:string -> Block_hash.t list -> Block_hash.t list -> unit + +val equal_base48_list : + ?msg:string -> Base48.data list -> Base48.data list -> unit + val equal_string_option : ?msg:string -> string option -> string option -> unit val equal_error_monad : @@ -26,14 +32,14 @@ val equal_block_map : ?msg:string -> eq:('a -> 'a -> bool) -> 'a -> 'a -> unit val equal_operation : ?msg:string -> - (Hash.Operation_hash.t * State.Operation.operation) option -> - (Hash.Operation_hash.t * State.Operation.operation) option -> + (Operation_hash.t * State.Operation.operation) option -> + (Operation_hash.t * State.Operation.operation) option -> unit val equal_block : ?msg:string -> - (Hash.Block_hash.t * Store.block) option -> - (Hash.Block_hash.t * Store.block) option -> + (Block_hash.t * Store.block) option -> + (Block_hash.t * Store.block) option -> unit val equal_result : diff --git a/test/test_store.ml b/test/test_store.ml index 26602189f..02977949d 100644 --- a/test/test_store.ml +++ b/test/test_store.ml @@ -88,6 +88,11 @@ let b2 = lolblock "Tacatlopo" let bh2 = Store.Block.hash b2.data let b3 = lolblock ~operations:[oph1;oph2] "Persil" let bh3 = Store.Block.hash b3.data +let bh3' = + let raw = Bytes.of_string @@ Block_hash.to_raw bh3 in + Bytes.set raw 31 '\000' ; + Bytes.set raw 30 '\000' ; + Block_hash.of_raw @@ Bytes.to_string raw let check_block s h b = Block.full_get s h >>= function @@ -110,6 +115,20 @@ let test_block (s: Store.store) = check_block s bh2 b2 >>= fun () -> check_block s bh3 b3) +let test_expand (s: Store.store) = + Persist.use s.block (fun s -> + Block.full_set s bh1 b1 >>= fun () -> + Block.full_set s bh2 b2 >>= fun () -> + Block.full_set s bh3 b3 >>= fun () -> + Block.full_set s bh3' b3 >>= fun () -> + Base48.decode_partial (Block_hash.to_short_b48check bh1) >>= fun res -> + Assert.equal_base48_list ~msg:__LOC__ res [Block_hash.Hash bh1] ; + Base48.decode_partial (Block_hash.to_short_b48check bh2) >>= fun res -> + Assert.equal_base48_list ~msg:__LOC__ res [Block_hash.Hash bh2] ; + Base48.decode_partial (Block_hash.to_short_b48check bh3) >>= fun res -> + Assert.equal_base48_list ~msg:__LOC__ res [Block_hash.Hash bh3] ; + Lwt.return_unit) + (** Generic store *) @@ -235,6 +254,7 @@ let test_hashmap (s: Store.store) = let tests : (string * (store -> unit Lwt.t)) list = [ "init", test_init ; + "expand", test_expand ; "operation", test_operation ; "block", test_block ; "generic", test_generic ; From 3f864ae113dfda1fb53b69e1282e7625406ec74d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Thu, 13 Oct 2016 17:05:53 +0200 Subject: [PATCH 03/10] Shell: display 12 characters for short Base48. A full block/operation identifier is around 53 characters. --- src/utils/hash.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/utils/hash.ml b/src/utils/hash.ml index d31e677b8..5126cf506 100644 --- a/src/utils/hash.ml +++ b/src/utils/hash.ml @@ -89,7 +89,7 @@ module Make_SHA256 (K : Name) = struct | _ -> Format.kasprintf failwith "Unexpected hash (%s)" K.name let to_b48check s = Base48.encode (Hash s) - let to_short_b48check s = String.sub (to_b48check s) 0 8 + let to_short_b48check s = String.sub (to_b48check s) 0 12 let compare = String.compare let equal : t -> t -> bool = (=) From 69261aa54286a8c9144437044a9fc9395f9af251 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Sun, 16 Oct 2016 21:57:56 +0200 Subject: [PATCH 04/10] Client: add command "complete". --- src/Makefile | 2 ++ src/client/client_helpers.ml | 35 ++++++++++++++++++++++++++++ src/client/client_helpers.mli | 10 ++++++++ src/client/client_node_rpcs.ml | 2 ++ src/client/client_node_rpcs.mli | 2 ++ src/client_main.ml | 1 + src/node/shell/node_rpc.ml | 5 ++++ src/node/shell/node_rpc_services.ml | 13 +++++++++++ src/node/shell/node_rpc_services.mli | 2 ++ 9 files changed, 72 insertions(+) create mode 100644 src/client/client_helpers.ml create mode 100644 src/client/client_helpers.mli diff --git a/src/Makefile b/src/Makefile index c381fdc1c..748caf687 100644 --- a/src/Makefile +++ b/src/Makefile @@ -345,6 +345,7 @@ CLIENT_LIB_INTFS := \ client/client_version.mli \ client/client_node_rpcs.mli \ client/client_generic_rpcs.mli \ + client/client_helpers.mli \ client/client_aliases.mli \ client/client_keys.mli \ client/client_protocols.mli \ @@ -354,6 +355,7 @@ CLIENT_LIB_IMPLS := \ client/client_config.ml \ client/client_node_rpcs.ml \ client/client_generic_rpcs.ml \ + client/client_helpers.ml \ client/client_aliases.ml \ client/client_keys.ml \ client/client_protocols.ml \ diff --git a/src/client/client_helpers.ml b/src/client/client_helpers.ml new file mode 100644 index 000000000..e5fa85b8d --- /dev/null +++ b/src/client/client_helpers.ml @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let () = + let open Cli_entries in + register_group "helpers" "Various helpers" + +let unique = ref false +let unique_arg = + "-unique", + Arg.Set unique, + "Fail when there is more than one possible completion." + +let commands () = Cli_entries.[ + command + ~desc: "Lookup for the possible completion of a \ + given prefix of Base48Check-encoded hash. This actually \ + works only for blocks and operations." + ~args: [unique_arg] + (prefixes [ "complete" ] @@ string "prefix" "the prefix of the Base48Check-encoded hash to be completed" @@ stop) + (fun prefix () -> + Client_node_rpcs.complete prefix >>= fun completions -> + match completions with + | [] -> Pervasives.exit 3 + | _ :: _ :: _ when !unique -> Pervasives.exit 3 + | completions -> + List.iter print_endline completions ; + Lwt.return_unit) +] diff --git a/src/client/client_helpers.mli b/src/client/client_helpers.mli new file mode 100644 index 000000000..2ae45c301 --- /dev/null +++ b/src/client/client_helpers.mli @@ -0,0 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val commands: unit -> Cli_entries.command list diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index 889bc8f31..f897ebfd4 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -150,6 +150,8 @@ let inject_operation ?(wait = true) ?force operation = call_service0 Services.inject_operation (operation, wait, force) let inject_protocol ?(wait = true) ?force protocol = call_service0 Services.inject_protocol (protocol, wait, force) +let complete prefix = + call_service1 Services.complete prefix () let describe ?recurse path = let prefix, arg = RPC.forge_request Services.describe () recurse in get_json (prefix @ path) arg >>= diff --git a/src/client/client_node_rpcs.mli b/src/client/client_node_rpcs.mli index 1a1e9605f..3fe7e5fd6 100644 --- a/src/client/client_node_rpcs.mli +++ b/src/client/client_node_rpcs.mli @@ -104,6 +104,8 @@ module Protocols : sig (Protocol_hash.t * Store.protocol option) list Lwt.t end +val complete: string -> string list Lwt.t + val describe: ?recurse:bool -> string list -> RPC.Description.directory_descr Lwt.t (** Low-level *) diff --git a/src/client_main.ml b/src/client_main.ml index 416f10abd..e57cdd9cf 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -31,6 +31,7 @@ let main () = Client_generic_rpcs.commands @ Client_keys.commands () @ Client_protocols.commands () @ + Client_helpers.commands () @ Client_version.commands_for_version version in Client_config.parse_args ~version (Cli_entries.usage commands) diff --git a/src/node/shell/node_rpc.ml b/src/node/shell/node_rpc.ml index a938ec44c..87ed0191a 100644 --- a/src/node/shell/node_rpc.ml +++ b/src/node/shell/node_rpc.ml @@ -434,6 +434,11 @@ let build_rpc_directory node = let implementation () = RPC.Answer.return Data_encoding.Json.(schema (Error_monad.error_encoding ())) in RPC.register0 dir RPC.Error.service implementation in + let dir = + RPC.register1 dir Services.complete + (fun s () -> + Base48.decode_partial s >>= fun l -> + RPC.Answer.return (List.map Base48.encode l)) in let dir = RPC.register_describe_directory_service dir Services.describe in dir diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index b4d3332e4..c85c28283 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -583,6 +583,19 @@ let inject_protocol = (obj1 (req "injectedProtocol" Protocol_hash.encoding))) RPC.Path.(root / "inject_protocol") +let complete = + let prefix_arg = + let destruct s = Ok s + and construct s = s in + RPC.Arg.make ~name:"prefix" ~destruct ~construct () in + RPC.service + ~description: "Try to complete a prefix of a Base48Check-encoded data. \ + This RPC is actually able to complete hashes of \ + black and hashes of operations." + ~input: empty + ~output: (list string) + RPC.Path.(root / "complete" /: prefix_arg ) + let describe = RPC.Description.service ~description: "RPCs documentation and input/output schema" diff --git a/src/node/shell/node_rpc_services.mli b/src/node/shell/node_rpc_services.mli index 055de2ec6..ca0edb4e2 100644 --- a/src/node/shell/node_rpc_services.mli +++ b/src/node/shell/node_rpc_services.mli @@ -132,5 +132,7 @@ val inject_protocol: (unit, unit, (Store.protocol * bool * bool option), Protocol_hash.t tzresult) RPC.service +val complete: (unit, unit * string, unit, string list) RPC.service + val describe: (unit, unit, bool option, RPC.Description.directory_descr) RPC.service From b82ad19806d8ffd87e1d6895753651dd8e987bc1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 14 Nov 2016 15:54:21 +0100 Subject: [PATCH 05/10] Shell: Consistently use `Ed25519.Public_key_hash` --- src/client/client_keys.mli | 3 ++- .../bootstrap/client_proto_contracts.ml | 2 +- src/proto/bootstrap/asset_repr.ml | 6 ++--- src/proto/bootstrap/asset_repr.mli | 2 +- src/proto/bootstrap/bootstrap_storage.ml | 4 +-- src/proto/bootstrap/bootstrap_storage.mli | 2 +- src/proto/bootstrap/contract_repr.ml | 26 +++++++++---------- src/proto/bootstrap/contract_repr.mli | 14 +++++----- src/proto/bootstrap/contract_storage.mli | 14 +++++----- src/proto/bootstrap/nonce_storage.ml | 2 +- src/proto/bootstrap/nonce_storage.mli | 6 ++--- src/proto/bootstrap/operation_repr.ml | 16 ++++++------ src/proto/bootstrap/operation_repr.mli | 8 +++--- src/proto/bootstrap/reward_storage.mli | 4 +-- src/proto/bootstrap/roll_storage.mli | 6 ++--- src/proto/bootstrap/services.ml | 22 ++++++++-------- src/proto/bootstrap/storage.ml | 18 ++++++------- src/proto/bootstrap/storage.mli | 18 ++++++------- src/proto/bootstrap/tezos_context.ml | 2 +- src/proto/bootstrap/tezos_context.mli | 2 +- src/proto/bootstrap/vote_storage.mli | 6 ++--- src/proto/environment/ed25519.mli | 16 +----------- src/utils/ed25519.mli | 18 ++----------- 23 files changed, 94 insertions(+), 123 deletions(-) diff --git a/src/client/client_keys.mli b/src/client/client_keys.mli index e88391533..989458f21 100644 --- a/src/client/client_keys.mli +++ b/src/client/client_keys.mli @@ -8,7 +8,8 @@ (**************************************************************************) -module Public_key_hash : Client_aliases.Alias with type t = Ed25519.public_key_hash +module Public_key_hash : + Client_aliases.Alias with type t = Ed25519.Public_key_hash.t module Public_key : Client_aliases.Alias with type t = Ed25519.public_key module Secret_key : Client_aliases.Alias with type t = Ed25519.secret_key diff --git a/src/client/embedded/bootstrap/client_proto_contracts.ml b/src/client/embedded/bootstrap/client_proto_contracts.ml index 05aa8b817..2ad6b6fb1 100644 --- a/src/client/embedded/bootstrap/client_proto_contracts.ml +++ b/src/client/embedded/bootstrap/client_proto_contracts.ml @@ -101,7 +101,7 @@ let get_delegate block source = let may_check_key sourcePubKey sourcePubKeyHash = match sourcePubKey with | Some sourcePubKey -> - if not (Ed25519.equal_hash (Ed25519.hash sourcePubKey) sourcePubKeyHash) + if not (Ed25519.Public_key_hash.equal (Ed25519.hash sourcePubKey) sourcePubKeyHash) then failwith "Invalid public key in `client_proto_endorsement`" else diff --git a/src/proto/bootstrap/asset_repr.ml b/src/proto/bootstrap/asset_repr.ml index 8148a11d9..ac288a660 100644 --- a/src/proto/bootstrap/asset_repr.ml +++ b/src/proto/bootstrap/asset_repr.ml @@ -22,10 +22,10 @@ let encoding = module Map = struct module Raw = Map.Make(struct - type t = asset * Ed25519.public_key_hash + type t = asset * Ed25519.Public_key_hash.t let compare (a1, pk1) (a2, pk2) = if Compare.Int32.(a1 = a2) then - Ed25519.compare_hash pk1 pk2 + Ed25519.Public_key_hash.compare pk1 pk2 else Compare.Int32.compare a1 a2 end) @@ -54,7 +54,7 @@ let encoding = (Json.wrap_error of_tuple_list_exn) (list (tup2 - (tup2 encoding Ed25519.public_key_hash_encoding) + (tup2 encoding Ed25519.Public_key_hash.encoding) Tez_repr.encoding))) end diff --git a/src/proto/bootstrap/asset_repr.mli b/src/proto/bootstrap/asset_repr.mli index b0f8fb033..6bdd30efc 100644 --- a/src/proto/bootstrap/asset_repr.mli +++ b/src/proto/bootstrap/asset_repr.mli @@ -17,6 +17,6 @@ module Map : sig type t val empty: t val add: - t -> asset -> Ed25519.public_key_hash -> Tez_repr.tez -> t tzresult + t -> asset -> Ed25519.Public_key_hash.t -> Tez_repr.tez -> t tzresult val encoding: t Data_encoding.t end diff --git a/src/proto/bootstrap/bootstrap_storage.ml b/src/proto/bootstrap/bootstrap_storage.ml index d73438a58..9555ae33d 100644 --- a/src/proto/bootstrap/bootstrap_storage.ml +++ b/src/proto/bootstrap/bootstrap_storage.ml @@ -8,7 +8,7 @@ (**************************************************************************) type account = { - public_key_hash : Ed25519.public_key_hash ; + public_key_hash : Ed25519.Public_key_hash.t ; public_key : Ed25519.public_key ; secret_key : Ed25519.secret_key ; } @@ -94,7 +94,7 @@ let account_encoding = (fun (public_key_hash, public_key, secret_key) -> { public_key_hash ; public_key ; secret_key }) (obj3 - (req "publicKeyHash" Ed25519.public_key_hash_encoding) + (req "publicKeyHash" Ed25519.Public_key_hash.encoding) (req "publicKey" Ed25519.public_key_encoding) (req "secretKey" Ed25519.secret_key_encoding)) diff --git a/src/proto/bootstrap/bootstrap_storage.mli b/src/proto/bootstrap/bootstrap_storage.mli index 40eedc5d8..f578bb61e 100644 --- a/src/proto/bootstrap/bootstrap_storage.mli +++ b/src/proto/bootstrap/bootstrap_storage.mli @@ -8,7 +8,7 @@ (**************************************************************************) type account = { - public_key_hash : Ed25519.public_key_hash ; + public_key_hash : Ed25519.Public_key_hash.t ; public_key : Ed25519.public_key ; secret_key : Ed25519.secret_key ; } diff --git a/src/proto/bootstrap/contract_repr.ml b/src/proto/bootstrap/contract_repr.ml index cf0ab4db9..136fc03ea 100644 --- a/src/proto/bootstrap/contract_repr.ml +++ b/src/proto/bootstrap/contract_repr.ml @@ -10,15 +10,15 @@ open Tezos_hash type descr = { - manager: Ed25519.public_key_hash ; - delegate: Ed25519.public_key_hash option ; + manager: Ed25519.Public_key_hash.t ; + delegate: Ed25519.Public_key_hash.t option ; spendable: bool ; delegatable: bool ; script: Script_repr.t ; } type t = - | Default of Ed25519.public_key_hash + | Default of Ed25519.Public_key_hash.t | Hash of Contract_hash.t type contract = t @@ -29,12 +29,10 @@ let to_b48check = function | Hash h -> Contract_hash.to_b48check h let of_b48check s = - try - match Base48.decode s with - | Ed25519.Public_key_hash.Hash h -> ok (Default h) - | Contract_hash.Hash h -> ok (Hash h) - | _ -> error (Invalid_contract_notation s) - with _ -> error (Invalid_contract_notation s) + match Base48.decode s with + | Some (Ed25519.Public_key_hash.Hash h) -> ok (Default h) + | Some (Contract_hash.Hash h) -> ok (Hash h) + | _ -> error (Invalid_contract_notation s) let encoding = let open Data_encoding in @@ -50,7 +48,7 @@ let encoding = splitted ~binary: (union ~tag_size:`Uint8 [ - case ~tag:0 Ed25519.public_key_hash_encoding + case ~tag:0 Ed25519.Public_key_hash.encoding (function Default k -> Some k | _ -> None) (fun k -> Default k) ; case ~tag:1 Contract_hash.encoding @@ -96,8 +94,8 @@ let descr_encoding = (fun (manager, delegate, spendable, delegatable, script) -> { manager; delegate; spendable; delegatable; script }) (obj5 - (req "manager" Ed25519.public_key_hash_encoding) - (opt "delegate" Ed25519.public_key_hash_encoding) + (req "manager" Ed25519.Public_key_hash.encoding) + (opt "delegate" Ed25519.Public_key_hash.encoding) (dft "spendable" bool false) (dft "delegatable" bool false) (req "script" Script_repr.encoding)) @@ -105,7 +103,7 @@ let descr_encoding = let generic_contract ~manager ~delegate ~spendable ~delegatable ~script = match delegate, spendable, delegatable, script with | Some delegate, true, false, Script_repr.No_script - when Ed25519.equal_hash manager delegate -> + when Ed25519.Public_key_hash.equal manager delegate -> default_contract manager | _ -> let data = @@ -130,7 +128,7 @@ let arg = let compare l1 l2 = match l1, l2 with | Default pkh1, Default pkh2 -> - Ed25519.compare_hash pkh1 pkh2 + Ed25519.Public_key_hash.compare pkh1 pkh2 | Hash h1, Hash h2 -> Contract_hash.compare h1 h2 | Default _, Hash _ -> -1 diff --git a/src/proto/bootstrap/contract_repr.mli b/src/proto/bootstrap/contract_repr.mli index 86047b798..2422f268e 100644 --- a/src/proto/bootstrap/contract_repr.mli +++ b/src/proto/bootstrap/contract_repr.mli @@ -10,13 +10,13 @@ open Tezos_hash type t = private - | Default of Ed25519.public_key_hash + | Default of Ed25519.Public_key_hash.t | Hash of Contract_hash.t type contract = t type descr = { - manager: Ed25519.public_key_hash ; - delegate: Ed25519.public_key_hash option ; + manager: Ed25519.Public_key_hash.t ; + delegate: Ed25519.Public_key_hash.t option ; spendable: bool ; delegatable: bool ; script: Script_repr.t ; @@ -24,13 +24,13 @@ type descr = { include Compare.S with type t := contract -val default_contract : Ed25519.public_key_hash -> contract +val default_contract : Ed25519.Public_key_hash.t -> contract -val is_default : contract -> Ed25519.public_key_hash option +val is_default : contract -> Ed25519.Public_key_hash.t option val generic_contract : - manager:Ed25519.public_key_hash -> - delegate:Ed25519.public_key_hash option -> + manager:Ed25519.Public_key_hash.t -> + delegate:Ed25519.Public_key_hash.t option -> spendable:bool -> delegatable:bool -> script:Script_repr.t -> diff --git a/src/proto/bootstrap/contract_storage.mli b/src/proto/bootstrap/contract_storage.mli index b62812b91..589fb2b03 100644 --- a/src/proto/bootstrap/contract_storage.mli +++ b/src/proto/bootstrap/contract_storage.mli @@ -33,9 +33,9 @@ val is_delegatable : Storage.t -> Contract_repr.t -> bool tzresult Lwt.t val is_spendable : Storage.t -> Contract_repr.t -> bool tzresult Lwt.t val get_descr: Storage.t -> Contract_repr.t -> Contract_repr.descr tzresult Lwt.t -val get_manager: Storage.t -> Contract_repr.t -> Ed25519.public_key_hash tzresult Lwt.t -val get_delegate: Storage.t -> Contract_repr.t -> Ed25519.public_key_hash tzresult Lwt.t -val get_delegate_opt: Storage.t -> Contract_repr.t -> Ed25519.public_key_hash option tzresult Lwt.t +val get_manager: Storage.t -> Contract_repr.t -> Ed25519.Public_key_hash.t tzresult Lwt.t +val get_delegate: Storage.t -> Contract_repr.t -> Ed25519.Public_key_hash.t tzresult Lwt.t +val get_delegate_opt: Storage.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option tzresult Lwt.t val get_balance: Storage.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t val get_assets: Storage.t -> Contract_repr.t -> Asset_repr.Map.t tzresult Lwt.t val get_counter: Storage.t -> Contract_repr.t -> int32 tzresult Lwt.t @@ -49,7 +49,7 @@ val update_script_storage: Storage.t -> Contract_repr.t -> Script_repr.expr -> Storage.t tzresult Lwt.t (** fails if the contract is not delegatable *) -val set_delegate : Storage.t -> Contract_repr.t -> Ed25519.public_key_hash option -> Storage.t tzresult Lwt.t +val set_delegate : Storage.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option -> Storage.t tzresult Lwt.t val credit : Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t @@ -60,14 +60,14 @@ val spend : Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt val unconditional_spend : Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t val issue : - Storage.t -> Contract_repr.t -> Asset_repr.t -> Ed25519.public_key_hash -> Tez_repr.t -> Storage.t tzresult Lwt.t + Storage.t -> Contract_repr.t -> Asset_repr.t -> Ed25519.Public_key_hash.t -> Tez_repr.t -> Storage.t tzresult Lwt.t val originate : Storage.t -> balance:Tez_repr.t -> - manager:Ed25519.public_key_hash -> + manager:Ed25519.Public_key_hash.t -> script:Script_repr.t -> - delegate:Ed25519.public_key_hash option -> + delegate:Ed25519.Public_key_hash.t option -> spendable:bool -> delegatable:bool -> (Storage.t * Contract_repr.t) tzresult Lwt.t diff --git a/src/proto/bootstrap/nonce_storage.ml b/src/proto/bootstrap/nonce_storage.ml index df2b2d3ba..b1acbd0e8 100644 --- a/src/proto/bootstrap/nonce_storage.ml +++ b/src/proto/bootstrap/nonce_storage.ml @@ -55,7 +55,7 @@ let reveal c level nonce = type status = Storage.Seed.nonce_status = | Unrevealed of { nonce_hash: Tezos_hash.Nonce_hash.t ; - delegate_to_reward: Ed25519.public_key_hash ; + delegate_to_reward: Ed25519.Public_key_hash.t ; reward_amount: Tez_repr.t ; } | Revealed of nonce diff --git a/src/proto/bootstrap/nonce_storage.mli b/src/proto/bootstrap/nonce_storage.mli index 1f996ad54..2c0ab5a53 100644 --- a/src/proto/bootstrap/nonce_storage.mli +++ b/src/proto/bootstrap/nonce_storage.mli @@ -21,17 +21,17 @@ val encoding: nonce Data_encoding.t val record_hash: Storage.t -> - Ed25519.public_key_hash -> Tez_repr.t -> + Ed25519.Public_key_hash.t -> Tez_repr.t -> Nonce_hash.t -> Storage.t tzresult Lwt.t val reveal: Storage.t -> Level_repr.t -> nonce -> - (Storage.t * Ed25519.public_key_hash * Tez_repr.t) tzresult Lwt.t + (Storage.t * Ed25519.Public_key_hash.t * Tez_repr.t) tzresult Lwt.t type status = | Unrevealed of { nonce_hash: Tezos_hash.Nonce_hash.t ; - delegate_to_reward: Ed25519.public_key_hash ; + delegate_to_reward: Ed25519.Public_key_hash.t ; reward_amount: Tez_repr.t ; } | Revealed of nonce diff --git a/src/proto/bootstrap/operation_repr.ml b/src/proto/bootstrap/operation_repr.ml index 9b0559940..9fead8956 100644 --- a/src/proto/bootstrap/operation_repr.ml +++ b/src/proto/bootstrap/operation_repr.ml @@ -46,18 +46,18 @@ and manager_operation = destination: Contract_repr.contract ; } | Origination of { - manager: Ed25519.public_key_hash ; - delegate: Ed25519.public_key_hash option ; + manager: Ed25519.Public_key_hash.t ; + delegate: Ed25519.Public_key_hash.t option ; script: Script_repr.t ; spendable: bool ; delegatable: bool ; credit: Tez_repr.tez ; } | Issuance of { - asset: Asset_repr.asset * Ed25519.public_key_hash ; + asset: Asset_repr.asset * Ed25519.Public_key_hash.t ; amount: Tez_repr.tez ; } - | Delegation of Ed25519.public_key_hash option + | Delegation of Ed25519.Public_key_hash.t option and delegate_operation = | Endorsement of { @@ -99,11 +99,11 @@ module Encoding = struct let origination_encoding = (obj7 (req "kind" (constant "origination")) - (req "managerPubkey" Ed25519.public_key_hash_encoding) + (req "managerPubkey" Ed25519.Public_key_hash.encoding) (req "balance" Tez_repr.encoding) (opt "spendable" bool) (opt "delegatable" bool) - (opt "delegate" Ed25519.public_key_hash_encoding) + (opt "delegate" Ed25519.Public_key_hash.encoding) (req "script" Script_repr.encoding)) let origination_case tag = @@ -125,7 +125,7 @@ module Encoding = struct let issuance_encoding = (obj3 (req "kind" (constant "issuance")) - (req "asset" (tup2 Asset_repr.encoding Ed25519.public_key_hash_encoding)) + (req "asset" (tup2 Asset_repr.encoding Ed25519.Public_key_hash.encoding)) (req "quantity" Tez_repr.encoding)) let issuance_case tag = @@ -138,7 +138,7 @@ module Encoding = struct let delegation_encoding = (obj2 (req "kind" (constant "delegation")) - (opt "delegate" Ed25519.public_key_hash_encoding)) + (opt "delegate" Ed25519.Public_key_hash.encoding)) let delegation_case tag = case ~tag delegation_encoding diff --git a/src/proto/bootstrap/operation_repr.mli b/src/proto/bootstrap/operation_repr.mli index 7d6abc0a7..089325228 100644 --- a/src/proto/bootstrap/operation_repr.mli +++ b/src/proto/bootstrap/operation_repr.mli @@ -46,18 +46,18 @@ and manager_operation = destination: Contract_repr.contract ; } | Origination of { - manager: Ed25519.public_key_hash ; - delegate: Ed25519.public_key_hash option ; + manager: Ed25519.Public_key_hash.t ; + delegate: Ed25519.Public_key_hash.t option ; script: Script_repr.t ; spendable: bool ; delegatable: bool ; credit: Tez_repr.tez ; } | Issuance of { - asset: Asset_repr.t * Ed25519.public_key_hash ; + asset: Asset_repr.t * Ed25519.Public_key_hash.t ; amount: Tez_repr.tez ; } - | Delegation of Ed25519.public_key_hash option + | Delegation of Ed25519.Public_key_hash.t option and delegate_operation = | Endorsement of { diff --git a/src/proto/bootstrap/reward_storage.mli b/src/proto/bootstrap/reward_storage.mli index 8ba49d14a..f337ec1da 100644 --- a/src/proto/bootstrap/reward_storage.mli +++ b/src/proto/bootstrap/reward_storage.mli @@ -8,10 +8,10 @@ (**************************************************************************) val record: - Storage.t -> Ed25519.public_key_hash -> Cycle_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t + Storage.t -> Ed25519.Public_key_hash.t -> Cycle_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t val discard: - Storage.t -> Ed25519.public_key_hash -> Cycle_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t + Storage.t -> Ed25519.Public_key_hash.t -> Cycle_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t val pay_due_rewards: Storage.t -> Storage.t tzresult Lwt.t diff --git a/src/proto/bootstrap/roll_storage.mli b/src/proto/bootstrap/roll_storage.mli index 5141c9b79..066d55117 100644 --- a/src/proto/bootstrap/roll_storage.mli +++ b/src/proto/bootstrap/roll_storage.mli @@ -36,11 +36,11 @@ val clear_cycle : val mining_rights_owner : Storage.t -> Level_repr.t -> priority:int32 -> - Ed25519.public_key_hash tzresult Lwt.t + Ed25519.Public_key_hash.t tzresult Lwt.t val endorsement_rights_owner : Storage.t -> Level_repr.t -> slot:int -> - Ed25519.public_key_hash tzresult Lwt.t + Ed25519.Public_key_hash.t tzresult Lwt.t module Contract : sig @@ -60,4 +60,4 @@ end (**/**) val get_contract_delegate: - Storage.t -> Contract_repr.t -> Ed25519.public_key_hash option tzresult Lwt.t + Storage.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option tzresult Lwt.t diff --git a/src/proto/bootstrap/services.ml b/src/proto/bootstrap/services.ml index 721d099c9..7054f08d8 100644 --- a/src/proto/bootstrap/services.ml +++ b/src/proto/bootstrap/services.ml @@ -191,7 +191,7 @@ module Context = struct let pk_encoding = (obj2 - (req "hash" Ed25519.public_key_hash_encoding) + (req "hash" Ed25519.Public_key_hash.encoding) (req "public_key" Ed25519.public_key_encoding)) let list custom_root = @@ -225,14 +225,14 @@ module Context = struct RPC.service ~description: "Access the manager of a contract." ~input: empty - ~output: (wrap_tzerror Ed25519.public_key_hash_encoding) + ~output: (wrap_tzerror Ed25519.Public_key_hash.encoding) RPC.Path.(custom_root / "context" / "contracts" /: Contract.arg / "manager") let delegate custom_root = RPC.service ~description: "Access the delegate of a contract, if any." ~input: empty - ~output: (wrap_tzerror (option Ed25519.public_key_hash_encoding)) + ~output: (wrap_tzerror (option Ed25519.Public_key_hash.encoding)) RPC.Path.(custom_root / "context" / "contracts" /: Contract.arg / "delegate") let counter custom_root = @@ -292,12 +292,12 @@ module Context = struct (fun (manager,balance,spendable,delegate,script,assets,counter) -> {manager;balance;spendable;delegate;script;assets;counter}) @@ obj7 - (req "manager" Ed25519.public_key_hash_encoding) + (req "manager" Ed25519.Public_key_hash.encoding) (req "balance" Tez.encoding) (req "spendable" bool) (req "delegate" @@ obj2 (req "setable" bool) - (opt "value" Ed25519.public_key_hash_encoding)) + (opt "value" Ed25519.Public_key_hash.encoding)) (dft "script" Script.encoding No_script) (req "assets" Asset.Map.encoding) (req "counter" int32)) @@ -404,7 +404,7 @@ module Helpers = struct (req "mining_rights" (list (obj2 - (req "delegate" Ed25519.public_key_hash_encoding) + (req "delegate" Ed25519.Public_key_hash.encoding) (req "timestamp" Timestamp.encoding))))) RPC.Path.(custom_root / "helpers" / "rights" / "mining") @@ -418,7 +418,7 @@ module Helpers = struct obj2 (req "level" Raw_level.encoding) (req "delegates" - (list Ed25519.public_key_hash_encoding))) + (list Ed25519.Public_key_hash.encoding))) RPC.Path.(custom_root / "helpers" / "rights" / "mining" / "level" /: Raw_level.arg ) @@ -447,7 +447,7 @@ module Helpers = struct ~input: empty ~output: (wrap_tzerror @@ obj1 (req "delegates" - (list Ed25519.public_key_hash_encoding))) + (list Ed25519.Public_key_hash.encoding))) RPC.Path.(custom_root / "helpers" / "rights" / "mining" / "delegate" ) @@ -460,7 +460,7 @@ module Helpers = struct obj2 (req "level" Raw_level.encoding) (req "delegates" - (list Ed25519.public_key_hash_encoding))) + (list Ed25519.Public_key_hash.encoding))) RPC.Path.(custom_root / "helpers" / "rights" / "endorsement") let endorsement_rights_for_level custom_root = @@ -472,7 +472,7 @@ module Helpers = struct obj2 (req "level" Raw_level.encoding) (req "delegates" - (list Ed25519.public_key_hash_encoding))) + (list Ed25519.Public_key_hash.encoding))) RPC.Path.(custom_root / "helpers" / "rights" / "endorsement" / "level" /: Raw_level.arg ) @@ -501,7 +501,7 @@ module Helpers = struct ~input: empty ~output: (wrap_tzerror @@ obj1 (req "delegates" - (list Ed25519.public_key_hash_encoding))) + (list Ed25519.Public_key_hash.encoding))) RPC.Path.(custom_root / "helpers" / "rights" / "endorsement" / "delegate" ) diff --git a/src/proto/bootstrap/storage.ml b/src/proto/bootstrap/storage.ml index 9dfed0a9a..74183b50a 100644 --- a/src/proto/bootstrap/storage.ml +++ b/src/proto/bootstrap/storage.ml @@ -197,10 +197,10 @@ module Roll = struct module Owner_for_cycle = Make_indexed_data_storage(struct type key = Cycle_repr.t * Roll_repr.t - type value = Ed25519.public_key_hash + type value = Ed25519.Public_key_hash.t let name = "roll owner for current cycle" let key = Key.Cycle.roll_owner - let encoding = Ed25519.public_key_hash_encoding + let encoding = Ed25519.Public_key_hash.encoding end) module Contract_roll_list = @@ -266,10 +266,10 @@ module Contract = struct module Manager = Make_indexed_data_storage(struct type key = Contract_repr.t - type value = Ed25519.public_key_hash + type value = Ed25519.Public_key_hash.t let name = "contract manager" let key = Key.Contract.manager - let encoding = Ed25519.public_key_hash_encoding + let encoding = Ed25519.Public_key_hash.encoding end) module Spendable = @@ -293,10 +293,10 @@ module Contract = struct module Delegate = Make_indexed_data_storage(struct type key = Contract_repr.t - type value = Ed25519.public_key_hash + type value = Ed25519.Public_key_hash.t let name = "contract delegate" let key = Key.Contract.delegate - let encoding = Ed25519.public_key_hash_encoding + let encoding = Ed25519.Public_key_hash.encoding end) module Counter = @@ -376,7 +376,7 @@ module Vote = struct module Proposals = Make_data_set_storage (struct - type value = Protocol_hash.t * Ed25519.public_key_hash + type value = Protocol_hash.t * Ed25519.Public_key_hash.t let name = "proposals" let encoding = Data_encoding.tup2 @@ -413,7 +413,7 @@ module Seed = struct type nonce_status = | Unrevealed of { nonce_hash: Tezos_hash.Nonce_hash.t ; - delegate_to_reward: Ed25519.public_key_hash ; + delegate_to_reward: Ed25519.Public_key_hash.t ; reward_amount: Tez_repr.t ; } | Revealed of Seed_repr.nonce @@ -482,7 +482,7 @@ module Rewards = struct module Amount = Raw_make_iterable_data_storage(struct - type t = Ed25519.public_key_hash * Cycle_repr.t + type t = Ed25519.Public_key_hash.t * Cycle_repr.t let prefix = Key.rewards let length = Ed25519.Public_key_hash.path_len + 1 let to_path (pkh, c) = diff --git a/src/proto/bootstrap/storage.mli b/src/proto/bootstrap/storage.mli index a49173e4a..6c20b856e 100644 --- a/src/proto/bootstrap/storage.mli +++ b/src/proto/bootstrap/storage.mli @@ -109,7 +109,7 @@ module Roll : sig module Owner_for_cycle : Indexed_data_storage with type key = Cycle_repr.t * Roll_repr.t - and type value = Ed25519.public_key_hash + and type value = Ed25519.Public_key_hash.t and type context := t end @@ -144,13 +144,13 @@ module Contract : sig (** The manager of a contract *) module Manager : Indexed_data_storage with type key = Contract_repr.t - and type value = Ed25519.public_key_hash + and type value = Ed25519.Public_key_hash.t and type context := t (** The delegate of a contract, if any. *) module Delegate : Indexed_data_storage with type key = Contract_repr.t - and type value = Ed25519.public_key_hash + and type value = Ed25519.Public_key_hash.t and type context := t module Spendable : Indexed_data_storage @@ -201,16 +201,16 @@ module Vote : sig and type context := t module Listings : Iterable_data_storage - with type key = Ed25519.public_key_hash + with type key = Ed25519.Public_key_hash.t and type value = int32 (* number of rolls for the key. *) and type context := t module Proposals : Data_set_storage - with type value = Protocol_hash.t * Ed25519.public_key_hash + with type value = Protocol_hash.t * Ed25519.Public_key_hash.t and type context := t module Ballots : Iterable_data_storage - with type key = Ed25519.public_key_hash + with type key = Ed25519.Public_key_hash.t and type value = Vote_repr.ballot and type context := t @@ -220,7 +220,7 @@ end (** Keys *) module Public_key : Iterable_data_storage - with type key = Ed25519.public_key_hash + with type key = Ed25519.Public_key_hash.t and type value = Ed25519.public_key and type context := t @@ -234,7 +234,7 @@ module Seed : sig type nonce_status = | Unrevealed of { nonce_hash: Tezos_hash.Nonce_hash.t ; - delegate_to_reward: Ed25519.public_key_hash ; + delegate_to_reward: Ed25519.Public_key_hash.t ; reward_amount: Tez_repr.t ; } | Revealed of Seed_repr.nonce @@ -266,7 +266,7 @@ module Rewards : sig and type context := t module Amount : Iterable_data_storage - with type key = Ed25519.public_key_hash * Cycle_repr.t + with type key = Ed25519.Public_key_hash.t * Cycle_repr.t and type value = Tez_repr.t and type context := t diff --git a/src/proto/bootstrap/tezos_context.ml b/src/proto/bootstrap/tezos_context.ml index d387a0819..d1c9287fd 100644 --- a/src/proto/bootstrap/tezos_context.ml +++ b/src/proto/bootstrap/tezos_context.ml @@ -39,7 +39,7 @@ module Script_int = Script_int_repr module Script = Script_repr type public_key = Ed25519.public_key -type public_key_hash = Ed25519.public_key_hash +type public_key_hash = Ed25519.Public_key_hash.t type secret_key = Ed25519.secret_key type signature = Ed25519.signature diff --git a/src/proto/bootstrap/tezos_context.mli b/src/proto/bootstrap/tezos_context.mli index 15a935db7..2da485bf6 100644 --- a/src/proto/bootstrap/tezos_context.mli +++ b/src/proto/bootstrap/tezos_context.mli @@ -26,7 +26,7 @@ module Nonce_hash_set = Tezos_hash.Nonce_hash_set module Nonce_hash_map = Tezos_hash.Nonce_hash_map type public_key = Ed25519.public_key -type public_key_hash = Ed25519.public_key_hash +type public_key_hash = Ed25519.Public_key_hash.t type secret_key = Ed25519.secret_key type signature = Ed25519.signature diff --git a/src/proto/bootstrap/vote_storage.mli b/src/proto/bootstrap/vote_storage.mli index 010a822fd..c94386dfe 100644 --- a/src/proto/bootstrap/vote_storage.mli +++ b/src/proto/bootstrap/vote_storage.mli @@ -8,7 +8,7 @@ (**************************************************************************) val record_proposal: - Storage.t -> Protocol_hash.t -> Ed25519.public_key_hash -> + Storage.t -> Protocol_hash.t -> Ed25519.Public_key_hash.t -> Storage.t tzresult Lwt.t val get_proposals: @@ -23,7 +23,7 @@ type ballots = { } val record_ballot: - Storage.t -> Ed25519.public_key_hash -> Vote_repr.ballot -> + Storage.t -> Ed25519.Public_key_hash.t -> Vote_repr.ballot -> Storage.t tzresult Lwt.t val get_ballots: Storage.t -> ballots tzresult Lwt.t val clear_ballots: Storage.t -> Storage.t Lwt.t @@ -33,7 +33,7 @@ val clear_listings: Storage.t -> Storage.t tzresult Lwt.t val listing_size: Storage.t -> int32 tzresult Lwt.t val in_listings: - Storage.t -> Ed25519.public_key_hash -> bool Lwt.t + Storage.t -> Ed25519.Public_key_hash.t -> bool Lwt.t val get_current_quorum: Storage.t -> int32 tzresult Lwt.t val set_current_quorum: Storage.t -> int32 -> Storage.t tzresult Lwt.t diff --git a/src/proto/environment/ed25519.mli b/src/proto/environment/ed25519.mli index 3dc1fa5d0..588d318e2 100644 --- a/src/proto/environment/ed25519.mli +++ b/src/proto/environment/ed25519.mli @@ -22,25 +22,11 @@ val check_signature : public_key -> signature -> MBytes.t -> bool module Public_key_hash : Hash.HASH -(** A Sha256 hash of an Ed25519 public key for use as an ID *) -type public_key_hash = Public_key_hash.t - (** Hashes an Ed25519 public key *) -val hash : public_key -> public_key_hash - -(** For using IDs as keys in the database *) -val hash_path : public_key_hash -> string list - -(** ID comparison *) -val equal_hash : public_key_hash -> public_key_hash -> bool - -(** ID comparison *) -val compare_hash : public_key_hash -> public_key_hash -> int +val hash : public_key -> Public_key_hash.t (** {2 Serializers} **********************************************************) -val public_key_hash_encoding : public_key_hash Data_encoding.t - val public_key_encoding : public_key Data_encoding.t val secret_key_encoding : secret_key Data_encoding.t diff --git a/src/utils/ed25519.mli b/src/utils/ed25519.mli index 4e4b7d560..5a9c367b5 100644 --- a/src/utils/ed25519.mli +++ b/src/utils/ed25519.mli @@ -33,25 +33,11 @@ val check_signature : public_key -> signature -> MBytes.t -> bool module Public_key_hash : Hash.HASH -(** A Sha256 hash of an Ed25519 public key for use as an ID *) -type public_key_hash = Public_key_hash.t - (** Hashes an Ed25519 public key *) -val hash : public_key -> public_key_hash - -(** For using IDs as keys in the database *) -val hash_path : public_key_hash -> string list - -(** ID comparison *) -val equal_hash : public_key_hash -> public_key_hash -> bool - -(** ID comparison *) -val compare_hash : public_key_hash -> public_key_hash -> int +val hash : public_key -> Public_key_hash.t (** {2 Serializers} **********************************************************) -val public_key_hash_encoding : public_key_hash Data_encoding.t - val public_key_encoding : public_key Data_encoding.t val secret_key_encoding : secret_key Data_encoding.t @@ -60,4 +46,4 @@ val signature_encoding : signature Data_encoding.t (** {2 Key pairs generation} *************************************************) -val generate_key : unit -> public_key_hash * public_key * secret_key +val generate_key : unit -> Public_key_hash.t * public_key * secret_key From 9062c405adc5ea311c6f2984adfed439fa5ef0f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 14 Nov 2016 17:33:32 +0100 Subject: [PATCH 06/10] Proto: minor fix in `Storage.Key` --- src/proto/bootstrap/storage.ml | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/proto/bootstrap/storage.ml b/src/proto/bootstrap/storage.ml index 74183b50a..88f7b1097 100644 --- a/src/proto/bootstrap/storage.ml +++ b/src/proto/bootstrap/storage.ml @@ -60,6 +60,8 @@ module Key = struct let next_cycle_to_be_rewarded = store_root ["next_cycle_to_be_rewarded"] let rewards = store_root ["rewards"] + let public_keys = ["public_keys" ; "ed25519"] + module Roll = struct let store_root l = store_root ("rolls" :: l) let next = store_root [ "next" ] @@ -88,13 +90,14 @@ module Key = struct module Contract = struct let store_root l = store_root ("contracts" :: l) let set = store_root ["set"] + let pubkey_contract l = store_root ("pubkey" :: l) + let generic_contract l = store_root ("generic" :: l) let contract_store c l = - store_root @@ match c with | Contract_repr.Default k -> - "pubkey" :: Ed25519.hash_path k @ l + pubkey_contract @@ Ed25519.Public_key_hash.to_path k @ l | Contract_repr.Hash h -> - "generic" :: Contract_hash.to_path h @ l + generic_contract @@ Contract_hash.to_path h @ l let roll_list c = contract_store c ["roll_list"] let change c = contract_store c ["change"] let balance c = contract_store c ["balance"] @@ -401,7 +404,7 @@ module Public_key = Make_iterable_data_storage (Ed25519.Public_key_hash) (struct type value = Ed25519.public_key - let key = ["public_keys"] + let key = Key.public_keys let name = "public keys" let encoding = Ed25519.public_key_encoding end) From 1805a1d8167450dda41212f645f853edc960490f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 14 Nov 2016 15:55:24 +0100 Subject: [PATCH 07/10] Shell: inline `Ed25519` into `Environment` This interface is not used in the shell, only in the protocol. It is just a (documented) wrapper over a fragment of sodium. --- src/Makefile | 4 +- src/client/client_keys.ml | 2 + src/client/client_keys.mli | 1 + .../bootstrap/client_proto_context.ml | 1 + .../bootstrap/client_proto_contracts.ml | 2 + .../bootstrap/client_proto_programs.ml | 1 + .../mining/client_mining_endorsement.ml | 2 + .../bootstrap/mining/client_mining_forge.ml | 1 + .../mining/client_mining_operations.ml | 2 + src/node/updater/environment.ml | 116 ++++++++++++++- src/utils/ed25519.ml | 134 ------------------ src/utils/ed25519.mli | 49 ------- test/test_basic.ml | 2 +- 13 files changed, 129 insertions(+), 188 deletions(-) delete mode 100644 src/utils/ed25519.ml delete mode 100644 src/utils/ed25519.mli diff --git a/src/Makefile b/src/Makefile index 748caf687..78b6630db 100644 --- a/src/Makefile +++ b/src/Makefile @@ -110,7 +110,6 @@ UTILS_LIB_INTFS := \ utils/data_encoding.mli \ utils/time.mli \ utils/hash.mli \ - utils/ed25519.mli \ utils/error_monad.mli \ utils/logging.mli \ utils/lwt_utils.mli \ @@ -126,7 +125,6 @@ UTILS_LIB_IMPLS := \ utils/data_encoding.ml \ utils/time.ml \ utils/hash.ml \ - utils/ed25519.ml \ utils/error_monad_sig.ml \ utils/error_monad.ml \ utils/logging.ml \ @@ -318,7 +316,7 @@ proto/embedded_proto_%.cmxa: \ CLIENT_PROTO_INCLUDES := \ utils node/updater node/db node/net node/shell client \ - $(shell ocamlfind query lwt ocplib-json-typed) + $(shell ocamlfind query lwt ocplib-json-typed sodium) proto/client_embedded_proto_%.cmxa: \ ${TZCOMPILER} \ diff --git a/src/client/client_keys.ml b/src/client/client_keys.ml index 535f50b89..158434405 100644 --- a/src/client/client_keys.ml +++ b/src/client/client_keys.ml @@ -7,6 +7,8 @@ (* *) (**************************************************************************) +module Ed25519 = Environment.Ed25519 + module Public_key_hash = Client_aliases.Alias (struct type t = Ed25519.Public_key_hash.t let encoding = Ed25519.Public_key_hash.encoding diff --git a/src/client/client_keys.mli b/src/client/client_keys.mli index 989458f21..757df170c 100644 --- a/src/client/client_keys.mli +++ b/src/client/client_keys.mli @@ -7,6 +7,7 @@ (* *) (**************************************************************************) +module Ed25519 = Environment.Ed25519 module Public_key_hash : Client_aliases.Alias with type t = Ed25519.Public_key_hash.t diff --git a/src/client/embedded/bootstrap/client_proto_context.ml b/src/client/embedded/bootstrap/client_proto_context.ml index 893fd2534..ecffdecfb 100644 --- a/src/client/embedded/bootstrap/client_proto_context.ml +++ b/src/client/embedded/bootstrap/client_proto_context.ml @@ -11,6 +11,7 @@ open Client_proto_args open Client_proto_contracts open Client_proto_programs open Client_keys +module Ed25519 = Environment.Ed25519 let handle_error f () = f () >>= Client_proto_rpcs.handle_error diff --git a/src/client/embedded/bootstrap/client_proto_contracts.ml b/src/client/embedded/bootstrap/client_proto_contracts.ml index 2ad6b6fb1..9a921f594 100644 --- a/src/client/embedded/bootstrap/client_proto_contracts.ml +++ b/src/client/embedded/bootstrap/client_proto_contracts.ml @@ -7,6 +7,8 @@ (* *) (**************************************************************************) +module Ed25519 = Environment.Ed25519 + module RawContractAlias = Client_aliases.Alias (struct type t = Contract.t let encoding = Contract.encoding diff --git a/src/client/embedded/bootstrap/client_proto_programs.ml b/src/client/embedded/bootstrap/client_proto_programs.ml index 341cb5b8c..1ff02fa84 100644 --- a/src/client/embedded/bootstrap/client_proto_programs.ml +++ b/src/client/embedded/bootstrap/client_proto_programs.ml @@ -7,6 +7,7 @@ (* *) (**************************************************************************) +module Ed25519 = Environment.Ed25519 open Client_proto_args let report_parse_error _prefix exn _lexbuf = diff --git a/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml b/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml index b6478a31d..ca31a6219 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml @@ -10,6 +10,8 @@ open Logging.Client.Endorsement open Cli_entries +module Ed25519 = Environment.Ed25519 + module State : sig val get_endorsement: diff --git a/src/client/embedded/bootstrap/mining/client_mining_forge.ml b/src/client/embedded/bootstrap/mining/client_mining_forge.ml index 15f73d4c4..fb7a274dd 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_forge.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_forge.ml @@ -8,6 +8,7 @@ (**************************************************************************) open Logging.Client.Mining +module Ed25519 = Environment.Ed25519 let generate_proof_of_work_nonce () = Sodium.Random.Bigbytes.generate Constants.proof_of_work_nonce_size diff --git a/src/client/embedded/bootstrap/mining/client_mining_operations.ml b/src/client/embedded/bootstrap/mining/client_mining_operations.ml index 6df2bde39..bd95edab5 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_operations.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_operations.ml @@ -7,6 +7,8 @@ (* *) (**************************************************************************) +module Ed25519 = Environment.Ed25519 + open Logging.Client.Mining open Operation diff --git a/src/node/updater/environment.ml b/src/node/updater/environment.ml index 351a7bec3..a1bc9d8ab 100644 --- a/src/node/updater/environment.ml +++ b/src/node/updater/environment.ml @@ -31,7 +31,121 @@ module Data_encoding = Data_encoding module Time = Time module Base48 = Base48 module Hash = Hash -module Ed25519 = Ed25519 +module Ed25519 = struct + + type secret_key = Sodium.Sign.secret_key + type public_key = Sodium.Sign.public_key + type signature = MBytes.t + + let sign key msg = + Sodium.Sign.Bigbytes.(of_signature @@ sign_detached key msg) + + let check_signature public_key signature msg = + try + Sodium.Sign.Bigbytes.(verify public_key (to_signature signature) msg) ; + true + with _ -> false + + let append_signature key msg = + MBytes.concat msg (sign key msg) + + module Public_key_hash = Hash.Make_SHA256(Base48)(struct + let name = "Ed25519.Public_key_hash" + let title = "An Ed25519 public key ID" + let b48check_prefix = Base48.Prefix.ed25519_public_key_hash + end) + + let hash v = + Public_key_hash.hash_bytes + [ Sodium.Sign.Bigbytes.of_public_key v ] + + let generate_key () = + let secret, pub = Sodium.Sign.random_keypair () in + (hash pub, pub, secret) + + type Base48.data += + | Public_key of public_key + | Secret_key of secret_key + | Signature of signature + + let b48check_public_key_encoding = + Base48.register_encoding + ~prefix: Base48.Prefix.ed25519_public_key + ~to_raw:(fun x -> Bytes.to_string (Sodium.Sign.Bytes.of_public_key x)) + ~of_raw:(fun x -> Sodium.Sign.Bytes.to_public_key (Bytes.of_string x)) + ~wrap:(fun x -> Public_key x) + + let b48check_secret_key_encoding = + Base48.register_encoding + ~prefix: Base48.Prefix.ed25519_secret_key + ~to_raw:(fun x -> Bytes.to_string (Sodium.Sign.Bytes.of_secret_key x)) + ~of_raw:(fun x -> Sodium.Sign.Bytes.to_secret_key (Bytes.of_string x)) + ~wrap:(fun x -> Secret_key x) + + let b48check_signature_encoding = + Base48.register_encoding + ~prefix: Base48.Prefix.ed25519_signature + ~to_raw:MBytes.to_string + ~of_raw:MBytes.of_string + ~wrap:(fun x -> Signature x) + + let public_key_encoding = + let open Data_encoding in + splitted + ~json: + (describe + ~title: "An Ed25519 public key (Base48Check encoded)" @@ + conv + (fun s -> Base48.simple_encode b48check_public_key_encoding s) + (fun s -> + match Base48.simple_decode b48check_public_key_encoding s with + | Some x -> x + | None -> Data_encoding.Json.cannot_destruct + "Ed25519 public key: unexpected prefix.") + string) + ~binary: + (conv + Sodium.Sign.Bigbytes.of_public_key + Sodium.Sign.Bigbytes.to_public_key + bytes) + + let secret_key_encoding = + let open Data_encoding in + splitted + ~json: + (describe + ~title: "An Ed25519 secret key (Base48Check encoded)" @@ + conv + (fun s -> Base48.simple_encode b48check_secret_key_encoding s) + (fun s -> + match Base48.simple_decode b48check_secret_key_encoding s with + | Some x -> x + | None -> Data_encoding.Json.cannot_destruct + "Ed25519 secret key: unexpected prefix.") + string) + ~binary: + (conv + Sodium.Sign.Bigbytes.of_secret_key + Sodium.Sign.Bigbytes.to_secret_key + bytes) + + let signature_encoding = + let open Data_encoding in + splitted + ~json: + (describe + ~title: "An Ed25519 signature (Base48Check encoded)" @@ + conv + (fun s -> Base48.simple_encode b48check_signature_encoding s) + (fun s -> + match Base48.simple_decode b48check_signature_encoding s with + | Some x -> x + | None -> Data_encoding.Json.cannot_destruct + "Ed25519 signature: unexpected prefix.") + string) + ~binary: (Fixed.bytes 64) + +end module Persist = Persist module Context = Context module RPC = RPC diff --git a/src/utils/ed25519.ml b/src/utils/ed25519.ml deleted file mode 100644 index 2b04095ed..000000000 --- a/src/utils/ed25519.ml +++ /dev/null @@ -1,134 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2016. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -(* Tezos - Ed25519 cryptography (simple interface to Sodium) *) - -(*-- Signature ---------------------------------------------------------------*) - -type secret_key = Sodium.Sign.secret_key -type public_key = Sodium.Sign.public_key -type signature = MBytes.t - -let sign key msg = - Sodium.Sign.Bigbytes.(of_signature @@ sign_detached key msg) - -let check_signature public_key signature msg = - try Sodium.Sign.Bigbytes.(verify public_key (to_signature signature) msg) ; true - with _ -> false - -let append_signature key msg = - MBytes.concat msg (sign key msg) - -(*-- Hashed public keys for user ID ------------------------------------------*) - -module Public_key_hash = Hash.Make_SHA256(struct - let name = "Ed25519.Public_key_hash" - let title = "An Ed25519 public key ID" - let prefix = Some Base48.Prefix.public_key_hash - end) - -type public_key_hash = Public_key_hash.t - -let hash v = - Public_key_hash.hash_bytes - [ Sodium.Sign.Bigbytes.of_public_key v ] - -let hash_path = Public_key_hash.to_path -let hash_hex = Public_key_hash.to_hex -let equal_hash = Public_key_hash.equal -let compare_hash = Public_key_hash.compare - -let generate_key () = - let secret, pub = Sodium.Sign.random_keypair () in - (hash pub, pub, secret) - -(*-- JSON Serializers --------------------------------------------------------*) - -type Base48.data += - | Public_key of public_key - | Secret_key of secret_key - | Signature of signature - -let _ = - Base48.register - ~prefix:Base48.Prefix.public_key - ~read:(function Public_key x -> Some (Bytes.to_string (Sodium.Sign.Bytes.of_public_key x)) | _ -> None) - ~build:(fun x -> Public_key (Sodium.Sign.Bytes.to_public_key (Bytes.of_string x))) - -let _ = - Base48.register - ~prefix:Base48.Prefix.secret_key - ~read:(function Secret_key x -> Some (Bytes.to_string (Sodium.Sign.Bytes.of_secret_key x)) | _ -> None) - ~build:(fun x -> Secret_key (Sodium.Sign.Bytes.to_secret_key (Bytes.of_string x))) - -let _ = - Base48.register - ~prefix:Base48.Prefix.signature - ~read:(function Signature x -> Some (MBytes.to_string x) | _ -> None) - ~build:(fun x -> Signature (MBytes.of_string x)) - -let public_key_hash_encoding = - Public_key_hash.encoding - -let public_key_encoding = - let open Data_encoding in - splitted - ~json: - (describe - ~title: "An Ed25519 public key (Base48Check encoded)" @@ - conv - (fun s -> Base48.encode (Public_key s)) - (fun s -> - match Base48.decode s with - | Public_key x -> x - | _ -> Data_encoding.Json.cannot_destruct - "Ed25519 public key: unexpected prefix.") - string) - ~binary: - (conv - Sodium.Sign.Bigbytes.of_public_key - Sodium.Sign.Bigbytes.to_public_key - bytes) - -let secret_key_encoding = - let open Data_encoding in - splitted - ~json: - (describe - ~title: "An Ed25519 secret key (Base48Check encoded)" @@ - conv - (fun s -> Base48.encode (Secret_key s)) - (fun s -> - match Base48.decode s with - | Secret_key x -> x - | _ -> Data_encoding.Json.cannot_destruct - "Ed25519 secret key: unexpected prefix.") - string) - ~binary: - (conv - Sodium.Sign.Bigbytes.of_secret_key - Sodium.Sign.Bigbytes.to_secret_key - bytes) - -let signature_encoding = - let open Data_encoding in - splitted - ~json: - (describe - ~title: "An Ed25519 signature (Base48Check encoded)" @@ - conv - (fun s -> Base48.encode (Signature s)) - (fun s -> - match Base48.decode s with - | Signature x -> x - | _ -> - Data_encoding.Json.cannot_destruct - "Ed25519 signature: unexpected prefix.") - string) - ~binary: (Fixed.bytes 64) diff --git a/src/utils/ed25519.mli b/src/utils/ed25519.mli deleted file mode 100644 index 5a9c367b5..000000000 --- a/src/utils/ed25519.mli +++ /dev/null @@ -1,49 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2016. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -(** Tezos - Ed25519 cryptography *) - - -(** {2 Signature} ************************************************************) - -(** An Ed25519 public key *) -type public_key = Sodium.Sign.public_key - -(** An Ed25519 secret key *) -type secret_key = Sodium.Sign.secret_key - -(** The result of signing a sequence of bytes with a secret key *) -type signature - -(** Signs a sequence of bytes with a secret key *) -val sign : secret_key -> MBytes.t -> signature - -val append_signature : secret_key -> MBytes.t -> MBytes.t - -(** Checks a signature *) -val check_signature : public_key -> signature -> MBytes.t -> bool - -(** {2 Hashed public keys for user ID} ***************************************) - -module Public_key_hash : Hash.HASH - -(** Hashes an Ed25519 public key *) -val hash : public_key -> Public_key_hash.t - -(** {2 Serializers} **********************************************************) - -val public_key_encoding : public_key Data_encoding.t - -val secret_key_encoding : secret_key Data_encoding.t - -val signature_encoding : signature Data_encoding.t - -(** {2 Key pairs generation} *************************************************) - -val generate_key : unit -> Public_key_hash.t * public_key * secret_key diff --git a/test/test_basic.ml b/test/test_basic.ml index e55e99508..d3c80d69e 100644 --- a/test/test_basic.ml +++ b/test/test_basic.ml @@ -78,7 +78,7 @@ let bootstrap_accounts () = let create_account name = let secret_key, public_key = Sodium.Sign.random_keypair () in - let public_key_hash = Ed25519.hash public_key in + let public_key_hash = Environment.Ed25519.hash public_key in let contract = Contract.default_contract public_key_hash in Lwt.return { name ; contract ; public_key_hash ; public_key ; secret_key } From b16a644e554786462ab791c8aa65f632ba43acfc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 14 Nov 2016 16:26:34 +0100 Subject: [PATCH 08/10] Proto: Completion of Base48-encoded public keys and contracts This required some modifications in the Base48 module, in order not to share the 'resolver' between distinct version of the economical protocol. --- src/Makefile | 9 +- src/compiler/embedded_cmis.mli | 1 + src/compiler/tezos_compiler.ml | 35 +++-- src/node/db/context.ml | 6 + src/node/db/ir_funview.ml | 6 + src/node/db/ir_funview.mli | 1 + src/node/db/persist.ml | 42 +++++- src/node/db/persist.mli | 15 +- src/node/db/store.ml | 60 ++++---- src/node/db/store.mli | 1 + src/node/shell/node.ml | 14 ++ src/node/shell/node.mli | 6 + src/node/shell/node_rpc.ml | 7 +- src/node/shell/node_rpc_services.ml | 17 ++- src/node/shell/node_rpc_services.mli | 2 + src/node/updater/environment.ml | 12 +- src/node/updater/environment_gen.ml | 2 + src/node/updater/protocol.mli | 2 + src/node/updater/updater.ml | 2 + src/node/updater/updater.mli | 2 + src/proto/bootstrap/.merlin | 2 +- src/proto/bootstrap/storage.ml | 14 ++ src/proto/bootstrap/storage_functors.ml | 31 +++- src/proto/bootstrap/storage_functors.mli | 2 + src/proto/bootstrap/storage_helpers.mli | 7 + src/proto/bootstrap/tezos_hash.ml | 30 ++-- src/proto/demo/.merlin | 3 +- src/proto/environment/base48.mli | 38 +++-- src/proto/environment/hash.mli | 46 +++++- src/proto/environment/persist.mli | 13 +- src/utils/base48.ml | 179 +++++++++++++++-------- src/utils/base48.mli | 152 +++++++++++++++---- src/utils/hash.ml | 105 ++++++++----- src/utils/hash.mli | 43 +++++- src/utils/utils.ml | 4 + src/utils/utils.mli | 1 + test/lib/assert.ml | 6 +- test/lib/assert.mli | 4 +- test/test_store.ml | 12 +- 39 files changed, 677 insertions(+), 257 deletions(-) diff --git a/src/Makefile b/src/Makefile index 78b6630db..182a89f9c 100644 --- a/src/Makefile +++ b/src/Makefile @@ -12,7 +12,8 @@ all: ${TZCOMPILER} ${TZNODE} ${TZCLIENT} ## Protocol environment ############################################################################ -PROTOCOL_ENV_INTFS := $(addprefix proto/environment/, \ +PROTOCOL_ENV_INTFS := \ +$(addprefix proto/environment/, \ pervasives.mli \ compare.mli \ \ @@ -30,7 +31,7 @@ PROTOCOL_ENV_INTFS := $(addprefix proto/environment/, \ uri.mli \ data_encoding.mli \ time.mli \ - base48.mli \ + ../../utils/base48.mli \ hash.mli \ ed25519.mli \ persist.mli \ @@ -42,7 +43,8 @@ PROTOCOL_ENV_INTFS := $(addprefix proto/environment/, \ ) \ utils/logging.mli \ utils/error_monad_sig.ml \ -utils/error_monad.mli +utils/error_monad.mli \ + .INTERMEDIATE: node/updater/environment_gen .SECONDARY: node/updater/proto_environment.mli @@ -75,6 +77,7 @@ EMBEDDED_PROTOCOL_LIB_CMIS := \ tmp/camlinternalFormatBasics.cmi \ utils/error_monad.cmi \ proto/environment/error_monad.mli \ + proto/environment/base48.mli \ proto/environment/logging.mli \ node/updater/proto_environment.cmi \ node/updater/register.cmi diff --git a/src/compiler/embedded_cmis.mli b/src/compiler/embedded_cmis.mli index 288657844..8b4cc4a0e 100644 --- a/src/compiler/embedded_cmis.mli +++ b/src/compiler/embedded_cmis.mli @@ -11,5 +11,6 @@ val camlinternalFormatBasics_cmi: string val error_monad_cmi: string val error_monad_mli: string val logging_mli: string +val base48_mli: string val proto_environment_cmi: string val register_cmi: string diff --git a/src/compiler/tezos_compiler.ml b/src/compiler/tezos_compiler.ml index 8211165ae..66eba9ed7 100644 --- a/src/compiler/tezos_compiler.ml +++ b/src/compiler/tezos_compiler.ml @@ -258,7 +258,8 @@ let link_shared ?(static=false) output objects = let create_register_file client file hash packname modules = let unit = List.hd (List.rev modules) in - let error_monad = packname ^ ".Local_error_monad.Error_monad" in + let error_monad = packname ^ ".Local_modules.Error_monad" in + let base48 = packname ^ ".Local_modules.Base48" in create_file file (Printf.sprintf "module Packed_protocol = struct\n\ @@ -269,6 +270,7 @@ let create_register_file client file hash packname modules = \ let error_encoding = %s.error_encoding ()\n\ \ let classify_errors = %s.classify_errors\n\ \ let pp = %s.pp\n\ + \ let complete_b48prefix = %s.complete \ end\n\ \ %s\n\ " @@ -279,6 +281,7 @@ let create_register_file client file hash packname modules = error_monad error_monad error_monad + base48 (if client then "include Register.Make(Packed_protocol)" else @@ -397,38 +400,44 @@ let main () = (* Compile the /ad-hoc/ Error_monad. *) List.iter (dump_cmi sigs_dir) tezos_protocol_env ; at_exit (fun () -> List.iter (unlink_cmi sigs_dir) tezos_protocol_env ) ; - let error_monad_unit = "local_error_monad" in - let error_monad_ml = build_dir // error_monad_unit ^ ".ml" in - create_file error_monad_ml @@ Printf.sprintf {| + let local_modules_unit = "local_modules" in + let local_modules_ml = build_dir // local_modules_unit ^ ".ml" in + create_file local_modules_ml @@ Printf.sprintf {| module Error_monad = struct type error_category = [ `Branch | `Temporary | `Permanent ] include Error_monad.Make() end module Logging = Logging.Make(struct let name = %S end) + module Base48 = struct + include Base48 + include Make(struct type context = Context.t end) + end |} logname ; - let error_monad_mli = build_dir // error_monad_unit ^ ".mli" in - create_file error_monad_mli @@ Printf.sprintf {| + let local_modules_mli = build_dir // local_modules_unit ^ ".mli" in + create_file local_modules_mli @@ Printf.sprintf {| module Error_monad : sig %s end module Logging : sig %s end + module Base48 : sig %s end |} Embedded_cmis.error_monad_mli - Embedded_cmis.logging_mli ; + Embedded_cmis.logging_mli + Embedded_cmis.base48_mli ; if not keep_object then at_exit (fun () -> - safe_unlink error_monad_mli ; - safe_unlink error_monad_ml) ; - let error_monad_object = + safe_unlink local_modules_mli ; + safe_unlink local_modules_ml) ; + let local_modules_object = compile_units ~ctxt ~for_pack:packname ~keep_object - ~build_dir ~source_dir:build_dir [error_monad_unit] + ~build_dir ~source_dir:build_dir [local_modules_unit] in Compenv.implicit_modules := !Compenv.implicit_modules @ - [ "Local_error_monad"; "Error_monad" ; "Hash" ; "Logging" ]; + [ "Local_modules"; "Error_monad" ; "Hash" ; "Logging" ]; (* Compile the protocol *) let objects = @@ -437,7 +446,7 @@ let main () = ~update_needed ~keep_object ~for_pack:packname ~build_dir ~source_dir units in pack_objects ~ctxt ~keep_object - packed_objects (error_monad_object @ objects) ; + packed_objects (local_modules_object @ objects) ; (* Compiler the 'registering module' *) List.iter (dump_cmi sigs_dir) register_env; diff --git a/src/node/db/context.ml b/src/node/db/context.ml index 6f16c2b2d..982623809 100644 --- a/src/node/db/context.ml +++ b/src/node/db/context.ml @@ -30,6 +30,7 @@ module rec S : sig val update_path: t -> IrminPath.t -> v -> unit Lwt.t val mem: v -> IrminPath.t -> bool Lwt.t + val dir_mem: v -> IrminPath.t -> bool Lwt.t val get: v -> IrminPath.t -> MBytes.t option Lwt.t val set: v -> IrminPath.t -> MBytes.t-> v Lwt.t val del: v -> IrminPath.t -> v Lwt.t @@ -187,6 +188,11 @@ let mem (module View : VIEW) key = GitStore.FunView.mem View.v (data_key key) >>= fun v -> Lwt.return v +let dir_mem (module View : VIEW) key = + let module GitStore = View.Store in + GitStore.FunView.dir_mem View.v (data_key key) >>= fun v -> + Lwt.return v + let raw_get (module View : VIEW) key = let module GitStore = View.Store in GitStore.FunView.get View.v key >>= function diff --git a/src/node/db/ir_funview.ml b/src/node/db/ir_funview.ml index acaf941b3..7b08ebee8 100644 --- a/src/node/db/ir_funview.ml +++ b/src/node/db/ir_funview.ml @@ -466,6 +466,11 @@ module Make (S: Irmin.S) = struct | None -> Lwt.return false | _ -> Lwt.return true + let dir_mem t k = + sub t k >>= function + | Some _ -> Lwt.return true + | None -> Lwt.return false + let list_aux t path = sub t path >>= function | None -> Lwt.return [] @@ -662,6 +667,7 @@ end module type S = sig include Irmin.RO + val dir_mem: t -> key -> bool Lwt.t val update: t -> key -> value -> t Lwt.t val remove: t -> key -> t Lwt.t val list: t -> key -> key list Lwt.t diff --git a/src/node/db/ir_funview.mli b/src/node/db/ir_funview.mli index bdf1671cb..b72dca5c2 100644 --- a/src/node/db/ir_funview.mli +++ b/src/node/db/ir_funview.mli @@ -9,6 +9,7 @@ module type S = sig include Irmin.RO + val dir_mem: t -> key -> bool Lwt.t val update: t -> key -> value -> t Lwt.t val remove: t -> key -> t Lwt.t val list: t -> key -> key list Lwt.t diff --git a/src/node/db/persist.ml b/src/node/db/persist.ml index b0ae55440..56cb57bcd 100644 --- a/src/node/db/persist.ml +++ b/src/node/db/persist.ml @@ -19,13 +19,13 @@ type value = MBytes.t module type STORE = sig type t val mem: t -> key -> bool Lwt.t + val dir_mem: t -> key -> bool Lwt.t val get: t -> key -> value option Lwt.t val set: t -> key -> value -> t Lwt.t val del: t -> key -> t Lwt.t val list: t -> key list -> key list Lwt.t val remove_rec: t -> key -> t Lwt.t - - val keys : t -> key list Lwt.t + val keys: t -> key list Lwt.t end module type BYTES_STORE = sig @@ -37,8 +37,7 @@ module type BYTES_STORE = sig val del: t -> key -> t Lwt.t val list: t -> key list -> key list Lwt.t val remove_rec: t -> key -> t Lwt.t - - val keys : t -> key list Lwt.t + val keys: t -> key list Lwt.t end module type TYPED_STORE = sig @@ -49,7 +48,6 @@ module type TYPED_STORE = sig val get: t -> key -> value option Lwt.t val set: t -> key -> value -> t Lwt.t val del: t -> key -> t Lwt.t - val keys: t -> key list Lwt.t end @@ -583,3 +581,37 @@ module MakeBufferedPersistentTypedMap (Map : Map.S with type key = K.t) = MakeBufferedPersistentMap(S)(K)(TypedValue(T))(Map) + +module MakeHashResolver + (Store : sig + type t + val dir_mem: t -> string list -> bool Lwt.t + val list: t -> string list list -> string list list Lwt.t + val prefix: string list + end) + (H: HASH) = struct + let plen = List.length Store.prefix + let build path = + H.of_path @@ + Utils.remove_elem_from_list plen path + let resolve t p = + let rec loop prefix = function + | [] -> + Lwt.return [build prefix] + | "" :: ds -> + Store.list t [ prefix] >>= fun prefixes -> + Lwt_list.map_p (fun prefix -> loop prefix ds) prefixes + >|= List.flatten + | [d] -> + Store.list t [prefix] >>= fun prefixes -> + Lwt_list.filter_map_p (fun prefix -> + match remove_prefix d (List.hd (List.rev prefix)) with + | None -> Lwt.return_none + | Some _ -> Lwt.return (Some (build prefix)) + ) prefixes + | d :: ds -> + Store.dir_mem t (prefix @ [d]) >>= function + | true -> loop (prefix @ [d]) ds + | false -> Lwt.return_nil in + loop Store.prefix (H.prefix_path p) +end diff --git a/src/node/db/persist.mli b/src/node/db/persist.mli index ede8de0e4..9b87058cc 100644 --- a/src/node/db/persist.mli +++ b/src/node/db/persist.mli @@ -22,13 +22,13 @@ type value = MBytes.t module type STORE = sig type t val mem: t -> key -> bool Lwt.t + val dir_mem: t -> key -> bool Lwt.t val get: t -> key -> value option Lwt.t val set: t -> key -> value -> t Lwt.t val del: t -> key -> t Lwt.t val list: t -> key list -> key list Lwt.t val remove_rec: t -> key -> t Lwt.t - - val keys : t -> key list Lwt.t + val keys: t -> key list Lwt.t end (** Projection of OCaml keys of some abstract type to concrete storage @@ -258,3 +258,14 @@ module MakeBufferedPersistentTypedMap and type key := K.t and type value := T.value and module Map := Map + +module MakeHashResolver + (Store : sig + type t + val dir_mem: t -> string list -> bool Lwt.t + val list: t -> string list list -> string list list Lwt.t + val prefix: string list + end) + (H: HASH) : sig + val resolve : Store.t -> string -> H.t list Lwt.t +end diff --git a/src/node/db/store.ml b/src/node/db/store.ml index 23744650f..92a342922 100644 --- a/src/node/db/store.ml +++ b/src/node/db/store.ml @@ -50,6 +50,10 @@ module FS = struct let file = file_of_key root key in Lwt.return (Sys.file_exists file && not (Sys.is_directory file)) + let dir_mem root key = + let file = file_of_key root key in + Lwt.return (Sys.file_exists file && Sys.is_directory file) + let exists root key = let file = file_of_key root key in Sys.file_exists file @@ -139,6 +143,7 @@ end module type IMPERATIVE_STORE = sig type t val mem: t -> key -> bool Lwt.t + val dir_mem: t -> key -> bool Lwt.t val get: t -> key -> value option Lwt.t val get_exn: t -> key -> value Lwt.t val set: t -> key -> value -> unit Lwt.t @@ -210,6 +215,7 @@ module Make (K : KEY) (V : Persist.VALUE) = struct type key = K.t type value = V.t let mem t k = FS.mem t (K.to_path k) + let dir_mem t k = FS.dir_mem t (K.to_path k) let get t k = FS.get t (K.to_path k) >|= function | None -> None @@ -226,37 +232,6 @@ module Make (K : KEY) (V : Persist.VALUE) = struct let keys _t = undefined_key_fn end -module MakeResolver (P: sig val prefix: string list end) (H: HASH) = struct - let plen = List.length P.prefix - let build path = - H.to_raw @@ H.of_path @@ - Utils.remove_elem_from_list plen path - let resolve t p = - let rec loop prefix = function - | [] -> Lwt.return [build prefix] - | "" :: ds -> - FS.list t [ prefix] >>= fun prefixes -> - Lwt_list.map_p (fun prefix -> loop prefix ds) prefixes - >|= List.flatten - | [d] -> - FS.list t [prefix] >>= fun prefixes -> - Lwt_list.filter_map_p (fun prefix -> - match remove_prefix d (List.hd (List.rev prefix)) with - | None -> Lwt.return_none - | Some _ -> Lwt.return (Some (build prefix)) - ) prefixes - | d :: ds -> - if FS.exists t prefix then - loop (prefix @ [d]) ds - else - Lwt.return_nil in - loop P.prefix (H.prefix_path p) - let register t = - match H.kind with - | None -> () - | Some kind -> Base48.register_resolver kind (resolve t) -end - module Data_store : IMPERATIVE_STORE with type t = FS.t = Make (Raw_key) (Raw_value) @@ -343,7 +318,12 @@ end module Block_errors = Make (Block_errors_key) (Errors_value) module Block_resolver = - MakeResolver(struct let prefix = ["blocks"] end)(Block_hash) + Persist.MakeHashResolver + (struct + include FS + let prefix = ["blocks"] + end) + (Block_hash) module Block = struct type t = FS.t @@ -497,7 +477,13 @@ end module Operation_errors = Make (Operation_errors_key) (Errors_value) module Operation_resolver = - MakeResolver(struct let prefix = ["operations"] end)(Operation_hash) + Persist.MakeHashResolver + (struct + include FS + let mem t k = Lwt.return (exists t k) + let prefix = ["operations"] + end) + (Operation_hash) module Operation = struct type t = FS.t @@ -756,8 +742,12 @@ let net_destroy ~root { net_genesis } = let init root = raw_init ~root:(Filename.concat root "global") () >>= fun t -> - Block_resolver.register t ; - Operation_resolver.register t ; + Base48.register_resolver + Block_hash.b48check_encoding + (fun s -> Block_resolver.resolve t s); + Base48.register_resolver + Operation_hash.b48check_encoding + (fun s -> Operation_resolver.resolve t s); Lwt.return { block = Persist.share t ; blockchain = Persist.share t ; diff --git a/src/node/db/store.mli b/src/node/db/store.mli index 6a311bf43..43f2a6e61 100644 --- a/src/node/db/store.mli +++ b/src/node/db/store.mli @@ -27,6 +27,7 @@ end module type IMPERATIVE_STORE = sig type t val mem: t -> key -> bool Lwt.t + val dir_mem: t -> key -> bool Lwt.t val get: t -> key -> value option Lwt.t val get_exn: t -> key -> value Lwt.t val set: t -> key -> value -> unit Lwt.t diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index 0ee7704bb..38b69c9f2 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -498,6 +498,20 @@ module RPC = struct Proto.fitness ctxt >>= fun fitness -> return (fitness, r) + let complete node ?block str = + match block with + | None -> + Base48.complete str + | Some block -> + get_context node block >>= function + | None -> Lwt.fail Not_found + | Some ctxt -> + Context.get_protocol ctxt >>= fun protocol_hash -> + let (module Proto) = Updater.get_exn protocol_hash in + Base48.complete str >>= fun l1 -> + Proto.complete_b48prefix ctxt str >>= fun l2 -> + Lwt.return (l1 @ l2) + let context_dir node block = get_context node block >>= function | None -> Lwt.return None diff --git a/src/node/shell/node.mli b/src/node/shell/node.mli index c771de089..997b71ca9 100644 --- a/src/node/shell/node.mli +++ b/src/node/shell/node.mli @@ -72,6 +72,12 @@ module RPC : sig val validate: t -> State.net_id -> Block_hash.t -> unit tzresult Lwt.t + val context_dir: + t -> block -> 'a RPC.directory option Lwt.t + + val complete: + t -> ?block:block -> string -> string list Lwt.t + end val shutdown: t -> unit Lwt.t diff --git a/src/node/shell/node_rpc.ml b/src/node/shell/node_rpc.ml index 87ed0191a..354187527 100644 --- a/src/node/shell/node_rpc.ml +++ b/src/node/shell/node_rpc.ml @@ -437,8 +437,11 @@ let build_rpc_directory node = let dir = RPC.register1 dir Services.complete (fun s () -> - Base48.decode_partial s >>= fun l -> - RPC.Answer.return (List.map Base48.encode l)) in + Node.RPC.complete node s >>= RPC.Answer.return) in + let dir = + RPC.register2 dir Services.Blocks.complete + (fun block s () -> + Node.RPC.complete node ~block s >>= RPC.Answer.return) in let dir = RPC.register_describe_directory_service dir Services.describe in dir diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index c85c28283..c1046755a 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -255,6 +255,19 @@ module Blocks = struct ~output: (RPC.Error.wrap preapply_result_encoding) RPC.Path.(block_path / "preapply") + let complete = + let prefix_arg = + let destruct s = Ok s + and construct s = s in + RPC.Arg.make ~name:"prefix" ~destruct ~construct () in + RPC.service + ~description: "Try to complete a prefix of a Base48Check-encoded data. \ + This RPC is actually able to complete hashes of \ + block, operations, public_keys and contracts." + ~input: empty + ~output: (list string) + RPC.Path.(block_path / "complete" /: prefix_arg ) + type list_param = { operations: bool option ; length: int option ; @@ -329,6 +342,8 @@ module Blocks = struct ~output: (obj1 (req "blocks" (list (list block_info_encoding)))) RPC.Path.(root / "blocks") + + end module Operations = struct @@ -591,7 +606,7 @@ let complete = RPC.service ~description: "Try to complete a prefix of a Base48Check-encoded data. \ This RPC is actually able to complete hashes of \ - black and hashes of operations." + block and hashes of operations." ~input: empty ~output: (list string) RPC.Path.(root / "complete" /: prefix_arg ) diff --git a/src/node/shell/node_rpc_services.mli b/src/node/shell/node_rpc_services.mli index ca0edb4e2..bc2e5e86b 100644 --- a/src/node/shell/node_rpc_services.mli +++ b/src/node/shell/node_rpc_services.mli @@ -80,6 +80,8 @@ module Blocks : sig val preapply: (unit, unit * block, preapply_param, preapply_result tzresult) RPC.service + val complete: (unit, (unit * block) * string, unit, string list) RPC.service + val proto_path: (unit, unit * block) RPC.Path.path end diff --git a/src/node/updater/environment.ml b/src/node/updater/environment.ml index a1bc9d8ab..23ca178ab 100644 --- a/src/node/updater/environment.ml +++ b/src/node/updater/environment.ml @@ -72,21 +72,25 @@ module Ed25519 = struct Base48.register_encoding ~prefix: Base48.Prefix.ed25519_public_key ~to_raw:(fun x -> Bytes.to_string (Sodium.Sign.Bytes.of_public_key x)) - ~of_raw:(fun x -> Sodium.Sign.Bytes.to_public_key (Bytes.of_string x)) + ~of_raw:(fun x -> + try Some (Sodium.Sign.Bytes.to_public_key (Bytes.of_string x)) + with _ -> None) ~wrap:(fun x -> Public_key x) let b48check_secret_key_encoding = Base48.register_encoding ~prefix: Base48.Prefix.ed25519_secret_key ~to_raw:(fun x -> Bytes.to_string (Sodium.Sign.Bytes.of_secret_key x)) - ~of_raw:(fun x -> Sodium.Sign.Bytes.to_secret_key (Bytes.of_string x)) + ~of_raw:(fun x -> + try Some (Sodium.Sign.Bytes.to_secret_key (Bytes.of_string x)) + with _ -> None) ~wrap:(fun x -> Secret_key x) let b48check_signature_encoding = Base48.register_encoding ~prefix: Base48.Prefix.ed25519_signature ~to_raw:MBytes.to_string - ~of_raw:MBytes.of_string + ~of_raw:(fun s -> Some (MBytes.of_string s)) ~wrap:(fun x -> Signature x) let public_key_encoding = @@ -164,4 +168,6 @@ module type PACKED_PROTOCOL = sig val error_encoding : error Data_encoding.t val classify_errors : error list -> [ `Branch | `Temporary | `Permanent ] val pp : Format.formatter -> error -> unit + val complete_b48prefix : + ?alphabet:string -> Context.t -> string -> string list Lwt.t end diff --git a/src/node/updater/environment_gen.ml b/src/node/updater/environment_gen.ml index d40b093cd..7f578346b 100644 --- a/src/node/updater/environment_gen.ml +++ b/src/node/updater/environment_gen.ml @@ -48,6 +48,8 @@ module type PACKED_PROTOCOL = sig val error_encoding : error Data_encoding.t val classify_errors : error list -> [ `Branch | `Temporary | `Permanent ] val pp : Format.formatter -> error -> unit + val complete_b48prefix : + ?alphabet:string -> Context.t -> string -> string list Lwt.t end val __cast: (module PACKED_PROTOCOL) -> (module Protocol.PACKED_PROTOCOL) |} diff --git a/src/node/updater/protocol.mli b/src/node/updater/protocol.mli index 88867d1f8..3d3ea57a3 100644 --- a/src/node/updater/protocol.mli +++ b/src/node/updater/protocol.mli @@ -135,4 +135,6 @@ module type PACKED_PROTOCOL = sig val error_encoding : error Data_encoding.t val classify_errors : error list -> [ `Branch | `Temporary | `Permanent ] val pp : Format.formatter -> error -> unit + val complete_b48prefix : + ?alphabet:string -> Context.t -> string -> string list Lwt.t end diff --git a/src/node/updater/updater.ml b/src/node/updater/updater.ml index e9b0af49c..3ca23c774 100644 --- a/src/node/updater/updater.ml +++ b/src/node/updater/updater.ml @@ -16,6 +16,8 @@ module type REGISTRED_PROTOCOL = sig val hash: Protocol_hash.t include Protocol.PROTOCOL with type error := error and type 'a tzresult := 'a tzresult + val complete_b48prefix : + ?alphabet:string -> Context.t -> string -> string list Lwt.t end type net_id = Store.net_id = Net of Block_hash.t diff --git a/src/node/updater/updater.mli b/src/node/updater/updater.mli index 09bd44185..aaad9c544 100644 --- a/src/node/updater/updater.mli +++ b/src/node/updater/updater.mli @@ -68,6 +68,8 @@ module type REGISTRED_PROTOCOL = sig (* exception Ecoproto_error of error list *) include Protocol.PROTOCOL with type error := error and type 'a tzresult := 'a tzresult + val complete_b48prefix : + ?alphabet:string -> Context.t -> string -> string list Lwt.t end type component = Tezos_compiler.Protocol.component = { diff --git a/src/proto/bootstrap/.merlin b/src/proto/bootstrap/.merlin index 46edbf5ec..1d807e77f 100644 --- a/src/proto/bootstrap/.merlin +++ b/src/proto/bootstrap/.merlin @@ -3,7 +3,7 @@ B _tzbuild FLG -nopervasives FLG -open Proto_environment FLG -open Hash -FLG -open Local_error_monad +FLG -open Local_modules FLG -open Error_monad FLG -open Logging FLG -w -40 diff --git a/src/proto/bootstrap/storage.ml b/src/proto/bootstrap/storage.ml index 88f7b1097..2a23756f8 100644 --- a/src/proto/bootstrap/storage.ml +++ b/src/proto/bootstrap/storage.ml @@ -88,6 +88,7 @@ module Key = struct end module Contract = struct + let store_root l = store_root ("contracts" :: l) let set = store_root ["set"] let pubkey_contract l = store_root ("pubkey" :: l) @@ -238,6 +239,7 @@ module Contract = struct let encoding = Data_encoding.int32 end) + (** FIXME REMOVE : use 'list' *) module Set = Make_data_set_storage(struct type value = Contract_repr.t @@ -518,3 +520,15 @@ let fork_test_network (c, constants) = Updater.fork_test_network c >>= fun c -> Lwt.return (c, constants) let set_test_protocol (c, constants) h = Updater.set_test_protocol c h >>= fun c -> Lwt.return (c, constants) + + +(** Resolver *) + +let () = + Storage_functors.register_resolvers + (module Contract_hash) + [ Key.Contract.generic_contract [] ] ; + Storage_functors.register_resolvers + (module Ed25519.Public_key_hash) + [ Key.Contract.pubkey_contract [] ; + Key.public_keys ] diff --git a/src/proto/bootstrap/storage_functors.ml b/src/proto/bootstrap/storage_functors.ml index 1bbf874d7..d95851b64 100644 --- a/src/proto/bootstrap/storage_functors.ml +++ b/src/proto/bootstrap/storage_functors.ml @@ -202,10 +202,9 @@ end module Make_data_set_storage (P : Single_data_description) = struct module Key = struct - include Hash.Make_SHA256(struct + include Hash.Make_minimal_SHA256(struct let name = P.name let title = ("A " ^ P.name ^ "key") - let prefix = None end) let prefix = P.key let length = path_len @@ -352,3 +351,31 @@ module Make_iterable_data_storage (H: HASH) (P: Single_data_description) = let prefix = P.key let length = path_len end)(P) + +let register_resolvers (module H : Hash.HASH) prefixes = + + let module Set = Hash_set(H) in + + let resolvers = + List.map + (fun prefix -> + let module R = Persist.MakeHashResolver(struct + include Context + let prefix = prefix + end)(H) in + R.resolve) + prefixes in + + let resolve c m = + match resolvers with + | [resolve] -> resolve c m + | resolvers -> + Lwt_list.map_p (fun resolve -> resolve c m) resolvers >|= fun hs -> + List.fold_left + (fun acc hs -> List.fold_left (fun acc h -> Set.add h acc) acc hs) + Set.empty hs |> + Set.elements in + + Base48.register_resolver H.b48check_encoding resolve + + diff --git a/src/proto/bootstrap/storage_functors.mli b/src/proto/bootstrap/storage_functors.mli index 52341b87d..53593b868 100644 --- a/src/proto/bootstrap/storage_functors.mli +++ b/src/proto/bootstrap/storage_functors.mli @@ -98,3 +98,5 @@ module Raw_make_iterable_data_storage (K: Persist.KEY) (P: Data_description) : and type value = P.value and type context := context +val register_resolvers: (module Hash.HASH) -> string list list -> unit + diff --git a/src/proto/bootstrap/storage_helpers.mli b/src/proto/bootstrap/storage_helpers.mli index c836faf2f..67e74fbdb 100644 --- a/src/proto/bootstrap/storage_helpers.mli +++ b/src/proto/bootstrap/storage_helpers.mli @@ -227,3 +227,10 @@ module Make_data_set_storage (P : Single_data_description) : module Make_iterable_data_storage (H : HASH) (P: Single_data_description) : Iterable_data_storage with type key = H.t and type value = P.value + +module Make_hash_resolver + (K: sig val prefix: string list end) + (H: Hash.HASH) : sig + val register : Store.t -> unit +end + diff --git a/src/proto/bootstrap/tezos_hash.ml b/src/proto/bootstrap/tezos_hash.ml index 1f53b4496..0cf2b3b96 100644 --- a/src/proto/bootstrap/tezos_hash.ml +++ b/src/proto/bootstrap/tezos_hash.ml @@ -8,42 +8,44 @@ (**************************************************************************) module Prefix = struct - let random_state_hash = Base48.Prefix.protocol_prefix ^ "\001" - let nonce_hash = Base48.Prefix.protocol_prefix ^ "\002" - let script_expr_hash = Base48.Prefix.protocol_prefix ^ "\003" - let proposition_hash = Base48.Prefix.protocol_prefix ^ "\004" - let contract_hash = Base48.Prefix.protocol_prefix ^ "\005" + let make x = + assert (Compare.String.(Base48.Prefix.protocol_prefix = "\015")) ; + String.make 1 (char_of_int ((x lsl 4) lor 15)) + let public_key_hash = make 0 + let contract_hash = make 1 + let nonce_hash = make 2 + let script_expr_hash = make 3 + let random_state_hash = make 15 (* never used... *) end -module State_hash = Hash.Make_SHA256(struct +module State_hash = Hash.Make_SHA256(Base48)(struct let name = "random" let title = "A random generation state" - let prefix = Some Prefix.random_state_hash + let b48check_prefix = Prefix.random_state_hash end) module State_hash_set = Hash_set(State_hash) module State_hash_map = Hash_map(State_hash) -module Nonce_hash = Hash.Make_SHA256(struct +module Nonce_hash = Hash.Make_SHA256(Base48)(struct let name = "cycle_nonce" let title = "A nonce hash" - let prefix = Some Prefix.nonce_hash + let b48check_prefix = Prefix.nonce_hash end) module Nonce_hash_set = Hash_set(Nonce_hash) module Nonce_hash_map = Hash_map(Nonce_hash) -module Script_expr_hash = Hash.Make_SHA256(struct +module Script_expr_hash = Hash.Make_SHA256(Base48)(struct let name = "script_expr" let title = "A script expression ID" - let prefix = Some Prefix.script_expr_hash + let b48check_prefix = Prefix.script_expr_hash end) module Script_expr_hash_set = Hash_set(Script_expr_hash) module Script_expr_hash_map = Hash_map(Script_expr_hash) -module Contract_hash = Hash.Make_SHA256(struct +module Contract_hash = Hash.Make_SHA256(Base48)(struct let name = "Contract_hash" let title = "A contract ID" - let prefix = Some Prefix.contract_hash + let b48check_prefix = Prefix.contract_hash end) module Contract_hash_set = Hash_set(Contract_hash) module Contract_hash_map = Hash_map(Contract_hash) - diff --git a/src/proto/demo/.merlin b/src/proto/demo/.merlin index 28fcf44c1..1d807e77f 100644 --- a/src/proto/demo/.merlin +++ b/src/proto/demo/.merlin @@ -3,6 +3,7 @@ B _tzbuild FLG -nopervasives FLG -open Proto_environment FLG -open Hash -FLG -open Local_error_monad +FLG -open Local_modules FLG -open Error_monad +FLG -open Logging FLG -w -40 diff --git a/src/proto/environment/base48.mli b/src/proto/environment/base48.mli index b2398c7a2..dd000467b 100644 --- a/src/proto/environment/base48.mli +++ b/src/proto/environment/base48.mli @@ -1,20 +1,26 @@ -type data = .. - -val decode: ?alphabet:string -> string -> data -val encode: ?alphabet:string -> data -> string - -type kind - -val register: - prefix:string -> - read:(data -> string option) -> - build:(string -> data) -> - kind - -val register_resolver: - kind -> (string -> string list Lwt.t) -> unit - module Prefix : sig val protocol_prefix: string end + +type 'a encoding = 'a Base48.encoding + +val simple_decode: ?alphabet:string -> 'a encoding -> string -> 'a option +val simple_encode: ?alphabet:string -> 'a encoding -> 'a -> string + +type data = Base48.data = .. + +val register_encoding: + prefix: string -> + to_raw: ('a -> string) -> + of_raw: (string -> 'a option) -> + wrap: ('a -> data) -> + 'a encoding + +val decode: ?alphabet:string -> string -> data option + +val register_resolver: + 'a encoding -> (Context.t -> string -> 'a list Lwt.t) -> unit + +val complete: + ?alphabet:string -> Context.t -> string -> string list Lwt.t diff --git a/src/proto/environment/hash.mli b/src/proto/environment/hash.mli index 785ef3165..eb3ef4b53 100644 --- a/src/proto/environment/hash.mli +++ b/src/proto/environment/hash.mli @@ -1,5 +1,5 @@ -(** Tezos - Manipulation and creation of hashes *) +(** Tezos - Manipulation and creation of hashes *) (** {2 Hash Types} ************************************************************) @@ -8,9 +8,14 @@ various kinds of hashes in the system at typing time. Each type is equipped with functions to use it as is of as keys in the database or in memory sets and maps. *) -module type HASH = sig + +module type MINIMAL_HASH = sig + type t + val name: string + val title: string + val hash_bytes: MBytes.t list -> t val hash_string: string list -> t val size: int (* in bytes *) @@ -20,9 +25,6 @@ module type HASH = sig val to_raw: t -> string val of_hex: string -> t val to_hex: t -> string - val of_b48check: string -> t - val to_b48check: t -> string - val to_short_b48check: t -> string val to_bytes: t -> MBytes.t val of_bytes: MBytes.t -> t val read: MBytes.t -> int -> t @@ -31,11 +33,22 @@ module type HASH = sig val of_path: string list -> t val prefix_path: string -> string list val path_len: int + +end + +module type HASH = sig + + include MINIMAL_HASH + + val of_b48check: string -> t + val to_b48check: t -> string + val to_short_b48check: t -> string val encoding: t Data_encoding.t val pp: Format.formatter -> t -> unit val pp_short: Format.formatter -> t -> unit type Base48.data += Hash of t - val kind: Base48.kind option + val b48check_encoding: t Base48.encoding + end (** {2 Building Hashes} *******************************************************) @@ -43,14 +56,30 @@ end (** The parameters for creating a new Hash type using {!Make_SHA256}. Both {!name} and {!title} are only informative, used in error messages and serializers. *) + module type Name = sig val name : string val title : string - val prefix : string option +end + +module type PrefixedName = sig + include Name + val b48check_prefix : string end (** Builds a new Hash type using Sha256. *) -module Make_SHA256 (Name:Name) : HASH + +module Make_minimal_SHA256 (Name : Name) : MINIMAL_HASH +module Make_SHA256 + (Register : sig + val register_encoding: + prefix: string -> + to_raw: ('a -> string) -> + of_raw: (string -> 'a option) -> + wrap: ('a -> Base48.data) -> + 'a Base48.encoding + end) + (Name : PrefixedName) : HASH (** Builds a Set of values of some Hash type. *) module Hash_set (Hash : HASH) : sig @@ -80,3 +109,4 @@ module Operation_hash_map : module type of Hash_map (Operation_hash) module Protocol_hash : HASH module Protocol_hash_set : Set.S with type elt = Protocol_hash.t module Protocol_hash_map : module type of Hash_map (Protocol_hash) + diff --git a/src/proto/environment/persist.mli b/src/proto/environment/persist.mli index e7fc1d792..da710368a 100644 --- a/src/proto/environment/persist.mli +++ b/src/proto/environment/persist.mli @@ -13,12 +13,12 @@ type value = MBytes.t module type STORE = sig type t val mem: t -> key -> bool Lwt.t + val dir_mem: t -> key -> bool Lwt.t val get: t -> key -> value option Lwt.t val set: t -> key -> value -> t Lwt.t val del: t -> key -> t Lwt.t val list: t -> key list -> key list Lwt.t val remove_rec: t -> key -> t Lwt.t - val keys: t -> key list Lwt.t end @@ -196,3 +196,14 @@ module MakeBufferedPersistentTypedMap and type key := K.t and type value := T.value and module Map := Map + +module MakeHashResolver + (Store : sig + type t + val dir_mem: t -> key -> bool Lwt.t + val list: t -> key list -> key list Lwt.t + val prefix: string list + end) + (H: Hash.HASH) : sig + val resolve : Store.t -> string -> H.t list Lwt.t +end diff --git a/src/utils/base48.ml b/src/utils/base48.ml index 080951c68..b5ab98861 100644 --- a/src/utils/base48.ml +++ b/src/utils/base48.ml @@ -10,6 +10,7 @@ open Utils let (>>=) = Lwt.bind +let (>|=) = Lwt.(>|=) let decode_alphabet alphabet = let str = Bytes.make 256 '\255' in @@ -102,83 +103,131 @@ let safe_decode ?alphabet s = type data = .. -type kind = - Kind : { prefix: string; - read: data -> string option ; - build: string -> data ; - mutable resolver: string -> string list Lwt.t ; - } -> kind +type 'a encoding = { + prefix: string; + to_raw: 'a -> string ; + of_raw: string -> 'a option ; + wrap: 'a -> data ; +} -let kinds = ref ([] : kind list) +let simple_decode ?alphabet { prefix ; of_raw } s = + safe_decode ?alphabet s |> + remove_prefix ~prefix |> + Utils.apply_option ~f:of_raw -exception Unknown_prefix +let simple_encode ?alphabet { prefix ; to_raw } d = + safe_encode ?alphabet (prefix ^ to_raw d) -let decode ?alphabet s = - let rec find s = function - | [] -> raise Unknown_prefix - | Kind { prefix ; build } :: kinds -> - match remove_prefix ~prefix s with - | None -> find s kinds - | Some msg -> build msg in - let s = safe_decode ?alphabet s in - find s !kinds +type registred_encoding = Encoding : 'a encoding -> registred_encoding -exception Unregistred_kind +module MakeEncodings(E: sig + val encodings: registred_encoding list + end) = struct -let encode ?alphabet s = - let rec find s = function - | [] -> raise Unregistred_kind - | Kind { prefix ; read } :: kinds -> - match read s with - | None -> find s kinds - | Some msg -> safe_encode ?alphabet (prefix ^ msg) in - try find s !kinds - with Not_found -> raise Unknown_prefix + let encodings = ref E.encodings -let default_resolver _ = Lwt.return_nil + let ambiguous_prefix prefix encodings = + List.exists (fun (Encoding { prefix = s }) -> + remove_prefix s prefix <> None || + remove_prefix prefix s <> None) + encodings -let register ~prefix ~read ~build = - match List.find (fun (Kind {prefix=s}) -> remove_prefix s prefix <> None || remove_prefix prefix s <> None) !kinds with - | exception Not_found -> - let kind = - Kind { prefix ; read ; build ; resolver = default_resolver } in - kinds := kind :: !kinds ; - kind - | Kind { prefix = s } -> - Format.kasprintf - Pervasives.failwith - "Base48.register: Conflicting prefixes: %S and %S." prefix s + let register_encoding ~prefix ~to_raw ~of_raw ~wrap = + if ambiguous_prefix prefix !encodings then + Format.ksprintf invalid_arg + "Base48.register_encoding: duplicate prefix: %S" prefix ; + let encoding = { prefix ; to_raw ; of_raw ; wrap } in + encodings := Encoding encoding :: !encodings ; + encoding -let register_resolver (Kind k) resolver = k.resolver <- resolver + let decode ?alphabet s = + let rec find s = function + | [] -> None + | Encoding { prefix ; of_raw ; wrap } :: encodings -> + match remove_prefix ~prefix s with + | None -> find s encodings + | Some msg -> of_raw msg |> Utils.map_option ~f:wrap in + let s = safe_decode ?alphabet s in + find s !encodings + +end + +type 'a resolver = + Resolver : { + encoding: 'h encoding ; + resolver: 'a -> string -> 'h list Lwt.t ; + } -> 'a resolver + +module MakeResolvers(R: sig + type context + val encodings: registred_encoding list ref + end) = struct + + let resolvers = ref [] + + let register_resolver + (type a) + (encoding : a encoding) + (resolver : R.context -> string -> a list Lwt.t) = + try + resolvers := Resolver { encoding ; resolver } :: !resolvers + with Not_found -> + invalid_arg "Base48.register_resolver: unregistred encodings" + + type context = R.context + + let complete ?alphabet context request = + (* One may extract from the prefix of a Base48-encoded value, a + prefix of the original encoded value. Given that `48 = 3 * 2^4`, + every "digits" in the Base48-prefix (i.e. a "bytes" in its ascii + representation), provides for sure 4 bits of the original data. + Hence, when we decode a prefix of a Base48-encoded value of + length `n`, the `n/2` first bytes of the decoded value are (for + sure) a prefix of the original value. *) + let n = String.length request in + let s = raw_decode request ?alphabet in + let partial = String.sub s 0 (n / 2) in + let rec find s = function + | [] -> Lwt.return_nil + | Resolver { encoding ; resolver } :: resolvers -> + match remove_prefix ~prefix:encoding.prefix s with + | None -> find s resolvers + | Some msg -> + resolver context msg >|= fun msgs -> + filter_map + (fun msg -> + let res = simple_encode encoding ?alphabet msg in + Utils.remove_prefix ~prefix:request res |> + Utils.map_option ~f:(fun _ -> res)) + msgs in + find partial !resolvers + +end + +include MakeEncodings(struct let encodings = [] end) +include MakeResolvers(struct + type context = unit + let encodings = encodings + end) + +let register_resolver enc f = register_resolver enc (fun () s -> f s) +let complete ?alphabet s = complete ?alphabet () s + +module Make(C: sig type context end) = struct + include MakeEncodings(struct let encodings = !encodings end) + include MakeResolvers(struct + type context = C.context + let encodings = encodings + end) +end module Prefix = struct let block_hash = "\000" let operation_hash = "\001" let protocol_hash = "\002" - let public_key_hash = "\003" - let public_key = "\004" - let secret_key = "\005" - let signature = "\006" + let ed25519_public_key_hash = "\003" + let ed25519_public_key = "\012" + let ed25519_secret_key = "\013" + let ed25519_signature = "\014" let protocol_prefix = "\015" end - -let decode_partial ?alphabet request = - let n = String.length request in - let s = raw_decode request ?alphabet in - let partial = String.sub s 0 (n/2) in - let rec find s = function - | [] -> Lwt.return_nil - | Kind { prefix ; build ; resolver } :: kinds -> - match remove_prefix ~prefix s with - | None -> find s kinds - | Some msg -> - resolver msg >>= fun msgs -> - let candidates = List.map build msgs in - Lwt.return @@ - List.filter - (fun data -> - match Utils.remove_prefix ~prefix:request (encode data) with - | None -> false - | Some _ -> true) - candidates in - find partial !kinds diff --git a/src/utils/base48.mli b/src/utils/base48.mli index 8877fe83b..26a1f7922 100644 --- a/src/utils/base48.mli +++ b/src/utils/base48.mli @@ -1,4 +1,3 @@ - (**************************************************************************) (* *) (* Copyright (c) 2014 - 2016. *) @@ -8,34 +7,131 @@ (* *) (**************************************************************************) +(** {1 Prefixed Base48Check encodings} *) + +(** Like Bitcoin's Base58Check, all the data encoded in Tezos are + prefixed with a constant which depends on the kind of encoded + data. + + The [Prefix] exports all the prefix used by the Tezos Shell. Each + version of the economical protocol might complete this list. + + Unlike Bitcoin's Base58Check, the prefix in the unencoded-data + is visible in the encoded data. + +*) +module Prefix : sig + + val block_hash: string + (** Prefix for block hashes: "\000". + (in Base48: "e" "f" or "g") *) + + val operation_hash: string + (** Prefix for operation hashes: "\001". + (in Base48: "E" "F" or "G") *) + + val protocol_hash: string + (** Prefix for protocol-version hashes: "\002". + (in Base48: "2" "3" or "4") *) + + val ed25519_public_key_hash: string + (** Prefix for Ed25519 public key hashes: "\003". *) + + val ed25519_public_key: string + (** Prefix for Ed25519 public key: "\012". *) + + val ed25519_secret_key: string + (** Prefix for Ed25519 secret key: "\013". *) + + val ed25519_signature: string + (** Prefix for Ed25519 signature key: "\014". *) + + val protocol_prefix: string + (** Prefix for all the encodings defined by economical protocol: + "\015". *) + +end + +(** An extensible sum-type for decoded data: one case per known + "prefix". See for instance [Hash.Block_hash.Hash] or + [Environment.Ed25519.Public_key_hash]. *) +type data = .. + +(** Abstract representation of registred encodings. The type paramater + is the type of the encoded data, for instance [Hash.Block_hash.t]. *) +type 'a encoding = private { + prefix: string; + to_raw: 'a -> string ; + of_raw: string -> 'a option ; + wrap: 'a -> data ; +} + +(** Register a new encoding. The function might raise `Invalid_arg` if + the provided [prefix] overlap with a previously registred + prefix. The [to_raw] and [of_raw] are the ad-hoc + serialisation/deserialisation for the data. The [wrap] should wrap + the deserialised value into the extensible sum-type [data] (see + the generic function [decode]). *) +val register_encoding: + prefix: string -> + to_raw: ('a -> string) -> + of_raw: (string -> 'a option) -> + wrap: ('a -> data) -> + 'a encoding + +(** Encoder for a given kind of data. *) +val simple_encode: ?alphabet:string -> 'a encoding -> 'a -> string + +(** Decoder for a given kind of data. It returns [None] when + the decoded data does not start with the expected prefix. *) +val simple_decode: ?alphabet:string -> 'a encoding -> string -> 'a option + +(** Generic decoder. It returns [None] when the decoded data does + not start with a registred prefix. *) +val decode: ?alphabet:string -> string -> data option + +(** {2 Completion of partial Base48Check value} *) + +(** Register a (global) resolver for a previsously + registred kind af data. *) +val register_resolver: 'a encoding -> (string -> 'a list Lwt.t) -> unit + +(** Try to complete a prefix of a Base48Check encoded data, by using + the previously registered resolver associated to this kind of + data. Note that a prefix of [n] characters of a Base48-encoded + value provides at least [n/2] bytes of a prefix of the original value. *) +val complete: ?alphabet:string -> string -> string list Lwt.t + +(** {1 Low-level: distinct registering function for economical protocol} *) + +(** See [src/proto/environment/base48.mli]} for an inlined + documentation. *) +module Make(C: sig type context end) : sig + + val register_encoding: + prefix: string -> + to_raw: ('a -> string) -> + of_raw: (string -> 'a option) -> + wrap: ('a -> data) -> + 'a encoding + + val decode: ?alphabet:string -> string -> data option + + val register_resolver: + 'a encoding -> (C.context -> string -> 'a list Lwt.t) -> unit + + val complete: + ?alphabet:string -> C.context -> string -> string list Lwt.t + +end + +(** {2 Low-level Base48Check encodings} *) + +(** Base48Check-encoding/decoding functions (with error detections). *) val safe_encode: ?alphabet:string -> string -> string val safe_decode: ?alphabet:string -> string -> string -type data = .. +(** Base48-encoding/decoding functions (without error detections). *) +val raw_encode: ?alphabet:string -> string -> string +val raw_decode: ?alphabet:string -> string -> string -val decode: ?alphabet:string -> string -> data -val encode: ?alphabet:string -> data -> string - -val decode_partial: ?alphabet:string -> string -> data list Lwt.t - -type kind - -val register: - prefix:string -> - read:(data -> string option) -> - build:(string -> data) -> - kind - -val register_resolver: - kind -> (string -> string list Lwt.t) -> unit - -module Prefix : sig - val block_hash: string - val operation_hash: string - val protocol_hash: string - val public_key_hash: string - val public_key: string - val secret_key: string - val signature: string - val protocol_prefix: string -end diff --git a/src/utils/hash.ml b/src/utils/hash.ml index 5126cf506..567ae16c9 100644 --- a/src/utils/hash.ml +++ b/src/utils/hash.ml @@ -15,9 +15,13 @@ open Utils (*-- Signatures -------------------------------------------------------------*) -module type HASH = sig +module type MINIMAL_HASH = sig + type t + val name: string + val title: string + val hash_bytes: MBytes.t list -> t val hash_string: string list -> t val size: int (* in bytes *) @@ -27,9 +31,6 @@ module type HASH = sig val to_raw: t -> string val of_hex: string -> t val to_hex: t -> string - val of_b48check: string -> t - val to_b48check: t -> string - val to_short_b48check: t -> string val to_bytes: t -> MBytes.t val of_bytes: MBytes.t -> t val read: MBytes.t -> int -> t @@ -38,25 +39,42 @@ module type HASH = sig val of_path: string list -> t val prefix_path: string -> string list val path_len: int + +end + +module type HASH = sig + + include MINIMAL_HASH + + val of_b48check: string -> t + val to_b48check: t -> string + val to_short_b48check: t -> string val encoding: t Data_encoding.t val pp: Format.formatter -> t -> unit val pp_short: Format.formatter -> t -> unit type Base48.data += Hash of t - val kind: Base48.kind option + val b48check_encoding: t Base48.encoding + end module type Name = sig - val name : string - val title : string - val prefix : string option + val name: string + val title: string +end + +module type PrefixedName = sig + include Name + val b48check_prefix: string end (*-- Type specific Hash builder ---------------------------------------------*) -module Make_SHA256 (K : Name) = struct +module Make_minimal_SHA256 (K : Name) = struct type t = string + include K + let size = 32 (* SHA256 *) let of_raw s = @@ -72,25 +90,6 @@ module Make_SHA256 (K : Name) = struct let of_hex s = of_raw (Hex_encode.hex_decode s) let to_hex s = Hex_encode.hex_encode s - type Base48.data += Hash of t - - let kind = - Utils.map_option - K.prefix - ~f:(fun prefix -> - Base48.register - ~prefix - ~read:(function Hash x -> Some x | _ -> None) - ~build:(fun x -> Hash x)) - - let of_b48check s = - match Base48.decode s with - | Hash x -> x - | _ -> Format.kasprintf failwith "Unexpected hash (%s)" K.name - let to_b48check s = Base48.encode (Hash s) - - let to_short_b48check s = String.sub (to_b48check s) 0 12 - let compare = String.compare let equal : t -> t -> bool = (=) @@ -143,12 +142,12 @@ module Make_SHA256 (K : Name) = struct let equal = equal end) - let path_len = 5 + let path_len = 6 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 ; - String.sub key 8 (size * 2 - 8) ] + String.sub key 8 2 ; String.sub key 10 (size * 2 - 10) ] let of_path path = let path = String.concat "" path in of_hex path @@ -160,11 +159,41 @@ module Make_SHA256 (K : Name) = struct 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 "" - and p5 = if len > 8 then String.sub p 8 (len - 8) else "" in - [ p1 ; p2 ; p3 ; p4 ; p5 ] + 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 ] + +end + +module Make_SHA256 (R : sig + val register_encoding: + prefix: string -> + to_raw: ('a -> string) -> + of_raw: (string -> 'a option) -> + wrap: ('a -> Base48.data) -> + 'a Base48.encoding + end) (K : PrefixedName) = struct + + include Make_minimal_SHA256(K) (* Serializers *) + type Base48.data += Hash of t + + let b48check_encoding = + R.register_encoding + ~prefix: K.b48check_prefix + ~wrap: (fun x -> Hash x) + ~of_raw:(fun s -> Some s) ~to_raw + + let of_b48check s = + match Base48.simple_decode b48check_encoding s with + | Some x -> x + | None -> Format.kasprintf failwith "Unexpected hash (%s)" K.name + let to_b48check s = Base48.simple_encode b48check_encoding s + + let to_short_b48check s = String.sub (to_b48check s) 0 12 + let encoding = let open Data_encoding in splitted @@ -219,10 +248,10 @@ module Hash_table (Hash : HASH) (*-- Pre-instanciated hashes ------------------------------------------------*) module Block_hash = - Make_SHA256 (struct + Make_SHA256 (Base48) (struct let name = "Block_hash" let title = "A Tezos block ID" - let prefix = Some Base48.Prefix.block_hash + let b48check_prefix = Base48.Prefix.block_hash end) module Block_hash_set = Hash_set (Block_hash) @@ -230,10 +259,10 @@ module Block_hash_map = Hash_map (Block_hash) module Block_hash_table = Hash_table (Block_hash) module Operation_hash = - Make_SHA256 (struct + Make_SHA256 (Base48) (struct let name = "Operation_hash" let title = "A Tezos operation ID" - let prefix = Some Base48.Prefix.operation_hash + let b48check_prefix = Base48.Prefix.operation_hash end) module Operation_hash_set = Hash_set (Operation_hash) @@ -241,10 +270,10 @@ module Operation_hash_map = Hash_map (Operation_hash) module Operation_hash_table = Hash_table (Operation_hash) module Protocol_hash = - Make_SHA256 (struct + Make_SHA256 (Base48) (struct let name = "Protocol_hash" let title = "A Tezos protocol ID" - let prefix = Some Base48.Prefix.protocol_hash + let b48check_prefix = Base48.Prefix.protocol_hash end) module Protocol_hash_set = Hash_set (Protocol_hash) diff --git a/src/utils/hash.mli b/src/utils/hash.mli index 08eba0e71..220a00431 100644 --- a/src/utils/hash.mli +++ b/src/utils/hash.mli @@ -17,9 +17,14 @@ various kinds of hashes in the system at typing time. Each type is equipped with functions to use it as is of as keys in the database or in memory sets and maps. *) -module type HASH = sig + +module type MINIMAL_HASH = sig + type t + val name: string + val title: string + val hash_bytes: MBytes.t list -> t val hash_string: string list -> t val size: int (* in bytes *) @@ -29,9 +34,6 @@ module type HASH = sig val to_raw: t -> string val of_hex: string -> t val to_hex: t -> string - val of_b48check: string -> t - val to_b48check: t -> string - val to_short_b48check: t -> string val to_bytes: t -> MBytes.t val of_bytes: MBytes.t -> t val read: MBytes.t -> int -> t @@ -40,11 +42,22 @@ module type HASH = sig val of_path: string list -> t val prefix_path: string -> string list val path_len: int + +end + +module type HASH = sig + + include MINIMAL_HASH + + val of_b48check: string -> t + val to_b48check: t -> string + val to_short_b48check: t -> string val encoding: t Data_encoding.t val pp: Format.formatter -> t -> unit val pp_short: Format.formatter -> t -> unit type Base48.data += Hash of t - val kind: Base48.kind option + val b48check_encoding: t Base48.encoding + end (** {2 Building Hashes} *******************************************************) @@ -52,14 +65,29 @@ end (** The parameters for creating a new Hash type using {!Make_SHA256}. Both {!name} and {!title} are only informative, used in error messages and serializers. *) + module type Name = sig val name : string val title : string - val prefix : string option +end + +module type PrefixedName = sig + include Name + val b48check_prefix : string end (** Builds a new Hash type using Sha256. *) -module Make_SHA256 (Name:Name) : HASH +module Make_minimal_SHA256 (Name : Name) : MINIMAL_HASH +module Make_SHA256 + (Register : sig + val register_encoding: + prefix: string -> + to_raw: ('a -> string) -> + of_raw: (string -> 'a option) -> + wrap: ('a -> Base48.data) -> + 'a Base48.encoding + end) + (Name : PrefixedName) : HASH (** Builds a Set of values of some Hash type. *) module Hash_set (Hash : HASH) : sig @@ -103,3 +131,4 @@ module Protocol_hash : HASH module Protocol_hash_set : module type of Hash_set (Protocol_hash) module Protocol_hash_map : module type of Hash_map (Protocol_hash) module Protocol_hash_table : module type of Hash_table (Protocol_hash) + diff --git a/src/utils/utils.ml b/src/utils/utils.ml index d4ed38aeb..963b066fb 100644 --- a/src/utils/utils.ml +++ b/src/utils/utils.ml @@ -96,6 +96,10 @@ let map_option ~f = function | None -> None | Some x -> Some (f x) +let apply_option ~f = function + | None -> None + | Some x -> f x + let iter_option ~f = function | None -> () | Some x -> f x diff --git a/src/utils/utils.mli b/src/utils/utils.mli index 3d87afcad..0105ffaa9 100644 --- a/src/utils/utils.mli +++ b/src/utils/utils.mli @@ -27,6 +27,7 @@ val split_path: string -> string list val split: char -> ?limit: int -> string -> string list val map_option: f:('a -> 'b) -> 'a option -> 'b option +val apply_option: f:('a -> 'b option) -> 'a option -> 'b option val iter_option: f:('a -> unit) -> 'a option -> unit val unopt: 'a -> 'a option -> 'a val unopt_list: 'a option list -> 'a list diff --git a/test/lib/assert.ml b/test/lib/assert.ml index a86434461..8201fdf82 100644 --- a/test/lib/assert.ml +++ b/test/lib/assert.ml @@ -27,11 +27,9 @@ let equal_block_hash_list ?msg l1 l2 = let pr_block_hash = Block_hash.to_short_b48check in Assert.make_equal_list ?msg Block_hash.equal pr_block_hash l1 l2 -let equal_base48_list ?msg l1 l2 = +let equal_string_list ?msg l1 l2 = let msg = format_msg msg in - let pr_base48 = Base48.encode in - (* TODO do not use polymorphic equality ! *) - Assert.make_equal_list ?msg (=) pr_base48 l1 l2 + Assert.make_equal_list ?msg (=) (fun x -> x) l1 l2 let equal_string_option ?msg o1 o2 = let msg = format_msg msg in diff --git a/test/lib/assert.mli b/test/lib/assert.mli index de31ce4d7..28ee6a19f 100644 --- a/test/lib/assert.mli +++ b/test/lib/assert.mli @@ -20,8 +20,8 @@ val equal_persist_list : val equal_block_hash_list : ?msg:string -> Block_hash.t list -> Block_hash.t list -> unit -val equal_base48_list : - ?msg:string -> Base48.data list -> Base48.data list -> unit +val equal_string_list : + ?msg:string -> string list -> string list -> unit val equal_string_option : ?msg:string -> string option -> string option -> unit diff --git a/test/test_store.ml b/test/test_store.ml index 02977949d..f824fbe8c 100644 --- a/test/test_store.ml +++ b/test/test_store.ml @@ -121,12 +121,12 @@ let test_expand (s: Store.store) = Block.full_set s bh2 b2 >>= fun () -> Block.full_set s bh3 b3 >>= fun () -> Block.full_set s bh3' b3 >>= fun () -> - Base48.decode_partial (Block_hash.to_short_b48check bh1) >>= fun res -> - Assert.equal_base48_list ~msg:__LOC__ res [Block_hash.Hash bh1] ; - Base48.decode_partial (Block_hash.to_short_b48check bh2) >>= fun res -> - Assert.equal_base48_list ~msg:__LOC__ res [Block_hash.Hash bh2] ; - Base48.decode_partial (Block_hash.to_short_b48check bh3) >>= fun res -> - Assert.equal_base48_list ~msg:__LOC__ res [Block_hash.Hash bh3] ; + Base48.complete (Block_hash.to_short_b48check bh1) >>= fun res -> + Assert.equal_string_list ~msg:__LOC__ res [Block_hash.to_b48check bh1] ; + Base48.complete (Block_hash.to_short_b48check bh2) >>= fun res -> + Assert.equal_string_list ~msg:__LOC__ res [Block_hash.to_b48check bh2] ; + Base48.complete (Block_hash.to_short_b48check bh3) >>= fun res -> + Assert.equal_string_list ~msg:__LOC__ res [Block_hash.to_b48check bh3] ; Lwt.return_unit) From d61220f4f9bd2a3bffca3c18b25a530080f2b6e5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 14 Nov 2016 17:28:37 +0100 Subject: [PATCH 09/10] Compiler: use explicit functor in `Environment` Previously, the functor applications were hidden in a module generated by `tezos-protocol-compiler`. --- src/Makefile | 14 ++-- src/compiler/embedded_cmis.mli | 4 -- src/compiler/tezos_compiler.ml | 66 +++++++---------- src/node/updater/environment.ml | 94 ++++++++++++++----------- src/node/updater/environment_gen.ml | 10 ++- src/node/updater/proto_environment.ml | 10 ++- src/node/updater/register.ml | 3 +- src/node/updater/register.mli | 2 +- src/proto/bootstrap/.merlin | 4 +- src/proto/bootstrap/storage_functors.ml | 2 +- src/proto/demo/.merlin | 4 +- src/proto/environment/base48.mli | 10 +-- src/proto/environment/context.mli | 6 ++ 13 files changed, 113 insertions(+), 116 deletions(-) diff --git a/src/Makefile b/src/Makefile index 182a89f9c..91a81d37b 100644 --- a/src/Makefile +++ b/src/Makefile @@ -30,8 +30,10 @@ $(addprefix proto/environment/, \ \ uri.mli \ data_encoding.mli \ + error_monad.mli \ + logging.mli \ time.mli \ - ../../utils/base48.mli \ + base48.mli \ hash.mli \ ed25519.mli \ persist.mli \ @@ -40,11 +42,7 @@ $(addprefix proto/environment/, \ \ fitness.mli \ updater.mli \ -) \ -utils/logging.mli \ -utils/error_monad_sig.ml \ -utils/error_monad.mli \ - +) .INTERMEDIATE: node/updater/environment_gen .SECONDARY: node/updater/proto_environment.mli @@ -75,10 +73,6 @@ clean:: EMBEDDED_PROTOCOL_LIB_CMIS := \ tmp/camlinternalFormatBasics.cmi \ - utils/error_monad.cmi \ - proto/environment/error_monad.mli \ - proto/environment/base48.mli \ - proto/environment/logging.mli \ node/updater/proto_environment.cmi \ node/updater/register.cmi diff --git a/src/compiler/embedded_cmis.mli b/src/compiler/embedded_cmis.mli index 8b4cc4a0e..cf01202eb 100644 --- a/src/compiler/embedded_cmis.mli +++ b/src/compiler/embedded_cmis.mli @@ -8,9 +8,5 @@ (**************************************************************************) val camlinternalFormatBasics_cmi: string -val error_monad_cmi: string -val error_monad_mli: string -val logging_mli: string -val base48_mli: string val proto_environment_cmi: string val register_cmi: string diff --git a/src/compiler/tezos_compiler.ml b/src/compiler/tezos_compiler.ml index 66eba9ed7..6f868a5cc 100644 --- a/src/compiler/tezos_compiler.ml +++ b/src/compiler/tezos_compiler.ml @@ -258,12 +258,14 @@ let link_shared ?(static=false) output objects = let create_register_file client file hash packname modules = let unit = List.hd (List.rev modules) in - let error_monad = packname ^ ".Local_modules.Error_monad" in - let base48 = packname ^ ".Local_modules.Base48" in + let environment_module = packname ^ ".Local_environment.Environment" in + let error_monad_module = environment_module ^ ".Error_monad" in + let context_module = environment_module ^ ".Context" in + let hash_module = environment_module ^ ".Hash" in create_file file (Printf.sprintf "module Packed_protocol = struct\n\ - \ let hash = (Hash.Protocol_hash.of_b48check %S)\n\ + \ let hash = (%s.Protocol_hash.of_b48check %S)\n\ \ type error = %s.error = ..\n\ \ type 'a tzresult = 'a %s.tzresult\n\ \ include %s.%s\n\ @@ -274,18 +276,20 @@ let create_register_file client file hash packname modules = \ end\n\ \ %s\n\ " + hash_module (Protocol_hash.to_b48check hash) - error_monad - error_monad + error_monad_module + error_monad_module packname (String.capitalize_ascii unit) - error_monad - error_monad - error_monad - base48 + error_monad_module + error_monad_module + error_monad_module + context_module (if client then "include Register.Make(Packed_protocol)" else - "let () = Register.register (module Packed_protocol : PACKED_PROTOCOL)")) + Printf.sprintf + "let () = Register.register (%s.__cast (module Packed_protocol : %s.PACKED_PROTOCOL))" environment_module environment_module)) let mktemp_dir () = Filename.get_temp_dir_name () // @@ -394,50 +398,30 @@ let main () = if keep_object then create_file (build_dir // ".tezos_compiler") (md5 ^ "\n"); - Compenv.implicit_modules := - if client then [ "Environment" ] else [ "Proto_environment" ] ; - (* Compile the /ad-hoc/ Error_monad. *) List.iter (dump_cmi sigs_dir) tezos_protocol_env ; at_exit (fun () -> List.iter (unlink_cmi sigs_dir) tezos_protocol_env ) ; - let local_modules_unit = "local_modules" in - let local_modules_ml = build_dir // local_modules_unit ^ ".ml" in - create_file local_modules_ml @@ Printf.sprintf {| - module Error_monad = struct - type error_category = [ `Branch | `Temporary | `Permanent ] - include Error_monad.Make() - end - module Logging = Logging.Make(struct let name = %S end) - module Base48 = struct - include Base48 - include Make(struct type context = Context.t end) - end + let local_environment_unit = "local_environment" in + let local_environment_ml = build_dir // local_environment_unit ^ ".ml" in + create_file local_environment_ml @@ Printf.sprintf {| + module Environment = %s.Make(struct let name = %S end)() |} + (if client then "Environment" else "Proto_environment") logname ; - let local_modules_mli = build_dir // local_modules_unit ^ ".mli" in - create_file local_modules_mli @@ Printf.sprintf {| - module Error_monad : sig %s end - module Logging : sig %s end - module Base48 : sig %s end - |} - Embedded_cmis.error_monad_mli - Embedded_cmis.logging_mli - Embedded_cmis.base48_mli ; if not keep_object then at_exit (fun () -> - safe_unlink local_modules_mli ; - safe_unlink local_modules_ml) ; - let local_modules_object = + safe_unlink local_environment_ml) ; + let local_environment_object = compile_units ~ctxt ~for_pack:packname ~keep_object - ~build_dir ~source_dir:build_dir [local_modules_unit] + ~build_dir ~source_dir:build_dir [local_environment_unit] in Compenv.implicit_modules := - !Compenv.implicit_modules @ - [ "Local_modules"; "Error_monad" ; "Hash" ; "Logging" ]; + [ "Local_environment"; "Environment" ; + "Error_monad" ; "Hash" ; "Logging" ]; (* Compile the protocol *) let objects = @@ -446,7 +430,7 @@ let main () = ~update_needed ~keep_object ~for_pack:packname ~build_dir ~source_dir units in pack_objects ~ctxt ~keep_object - packed_objects (local_modules_object @ objects) ; + packed_objects (local_environment_object @ objects) ; (* Compiler the 'registering module' *) List.iter (dump_cmi sigs_dir) register_env; diff --git a/src/node/updater/environment.ml b/src/node/updater/environment.ml index 23ca178ab..015008fb9 100644 --- a/src/node/updater/environment.ml +++ b/src/node/updater/environment.ml @@ -7,30 +7,6 @@ (* *) (**************************************************************************) -include Pervasives -module Pervasives = Pervasives -module Compare = Compare -module Array = Array -module List = List -module Bytes = Bytes -module String = String -module Set = Set -module Map = Map -module Int32 = Int32 -module Int64 = Int64 -module Nativeint = Nativeint -module Buffer = Buffer -module Format = Format -module Hex_encode = Hex_encode -module Lwt_sequence = Lwt_sequence -module Lwt = Lwt -module Lwt_list = Lwt_list -module MBytes = MBytes -module Uri = Uri -module Data_encoding = Data_encoding -module Time = Time -module Base48 = Base48 -module Hash = Hash module Ed25519 = struct type secret_key = Sodium.Sign.secret_key @@ -150,24 +126,60 @@ module Ed25519 = struct ~binary: (Fixed.bytes 64) end -module Persist = Persist -module Context = Context -module RPC = RPC -module Fitness = Fitness -module Updater = Updater -(* Internal usage *) +module Make(Param : sig val name: string end)() = struct -module Error_monad_sig = Error_monad_sig -module Error_monad = Error_monad -module Logging = Logging + include Pervasives + module Pervasives = Pervasives + module Compare = Compare + module Array = Array + module List = List + module Bytes = Bytes + module String = String + module Set = Set + module Map = Map + module Int32 = Int32 + module Int64 = Int64 + module Nativeint = Nativeint + module Buffer = Buffer + module Format = Format + module Hex_encode = Hex_encode + module Lwt_sequence = Lwt_sequence + module Lwt = Lwt + module Lwt_list = Lwt_list + module MBytes = MBytes + module Uri = Uri + module Data_encoding = Data_encoding + module Time = Time + module Ed25519 = Ed25519 + module Hash = Hash + module Persist = Persist + module RPC = RPC + module Fitness = Fitness + module Updater = Updater + module Error_monad = struct + type error_category = [ `Branch | `Temporary | `Permanent ] + include Error_monad.Make() + end + module Logging = Logging.Make(Param) + module Base48 = struct + include Base48 + include Make(struct type context = Context.t end) + end + module Context = struct + include Context + let register_resolver = Base48.register_resolver + let complete = Base48.complete + end + + module type PACKED_PROTOCOL = sig + val hash : Protocol_hash.t + include Updater.PROTOCOL + val error_encoding : error Data_encoding.t + val classify_errors : error list -> [ `Branch | `Temporary | `Permanent ] + val pp : Format.formatter -> error -> unit + val complete_b48prefix : + ?alphabet:string -> Context.t -> string -> string list Lwt.t + end -module type PACKED_PROTOCOL = sig - val hash : Protocol_hash.t - include Updater.PROTOCOL - val error_encoding : error Data_encoding.t - val classify_errors : error list -> [ `Branch | `Temporary | `Permanent ] - val pp : Format.formatter -> error -> unit - val complete_b48prefix : - ?alphabet:string -> Context.t -> string -> string list Lwt.t end diff --git a/src/node/updater/environment_gen.ml b/src/node/updater/environment_gen.ml index 7f578346b..99fab1063 100644 --- a/src/node/updater/environment_gen.ml +++ b/src/node/updater/environment_gen.ml @@ -21,6 +21,11 @@ let dump_file oc file = let included = ["Pervasives"] +let () = + Printf.fprintf mli + "module Make(Param : sig val name: string end)() : sig\n" + + let () = for i = 2 to Array.length Sys.argv - 1 do let file = Sys.argv.(i) in @@ -36,10 +41,12 @@ let () = dump_file mli file; Printf.fprintf mli "end\n"; if unit = "Result" then begin - Printf.fprintf mli "type ('a, 'b) result = ('a, 'b) Result.result = Ok of 'a | Error of 'b\n"; + Printf.fprintf mli + "type ('a, 'b) result = ('a, 'b) Result.result = Ok of 'a | Error of 'b\n"; end; done + let () = Printf.fprintf mli {| module type PACKED_PROTOCOL = sig @@ -55,4 +62,5 @@ val __cast: (module PACKED_PROTOCOL) -> (module Protocol.PACKED_PROTOCOL) |} let () = + Printf.fprintf mli "end\n" ; close_out mli diff --git a/src/node/updater/proto_environment.ml b/src/node/updater/proto_environment.ml index 05e795ef3..fc22e9a60 100644 --- a/src/node/updater/proto_environment.ml +++ b/src/node/updater/proto_environment.ml @@ -7,7 +7,11 @@ (* *) (**************************************************************************) -include Environment +module Make(Param : sig val name: string end)() = struct -let __cast (type error) (module X : PACKED_PROTOCOL) = - (module X : Protocol.PACKED_PROTOCOL) + include Environment.Make(Param)() + + let __cast (type error) (module X : PACKED_PROTOCOL) = + (module X : Protocol.PACKED_PROTOCOL) + +end diff --git a/src/node/updater/register.ml b/src/node/updater/register.ml index 9e1ee9242..dc13192be 100644 --- a/src/node/updater/register.ml +++ b/src/node/updater/register.ml @@ -29,8 +29,7 @@ module Make(Proto : Protocol.PACKED_PROTOCOL) = struct (function ecoerrors -> Ecoproto_error ecoerrors) end -let register proto = - let module Proto = (val Proto_environment.__cast proto) in +let register (module Proto : Protocol.PACKED_PROTOCOL) = let module V = struct include Proto include Make(Proto) diff --git a/src/node/updater/register.mli b/src/node/updater/register.mli index 4da480158..c24a4c108 100644 --- a/src/node/updater/register.mli +++ b/src/node/updater/register.mli @@ -12,4 +12,4 @@ module Make(Proto : Protocol.PACKED_PROTOCOL) : sig val wrap_error: 'a Proto.tzresult -> 'a tzresult end -val register: (module Proto_environment.PACKED_PROTOCOL) -> unit +val register: (module Protocol.PACKED_PROTOCOL) -> unit diff --git a/src/proto/bootstrap/.merlin b/src/proto/bootstrap/.merlin index 1d807e77f..bee23c94c 100644 --- a/src/proto/bootstrap/.merlin +++ b/src/proto/bootstrap/.merlin @@ -1,9 +1,9 @@ B ../../node/updater/ B _tzbuild FLG -nopervasives -FLG -open Proto_environment +FLG -open Local_environment +FLG -open Environment FLG -open Hash -FLG -open Local_modules FLG -open Error_monad FLG -open Logging FLG -w -40 diff --git a/src/proto/bootstrap/storage_functors.ml b/src/proto/bootstrap/storage_functors.ml index d95851b64..7c95b0327 100644 --- a/src/proto/bootstrap/storage_functors.ml +++ b/src/proto/bootstrap/storage_functors.ml @@ -376,6 +376,6 @@ let register_resolvers (module H : Hash.HASH) prefixes = Set.empty hs |> Set.elements in - Base48.register_resolver H.b48check_encoding resolve + Context.register_resolver H.b48check_encoding resolve diff --git a/src/proto/demo/.merlin b/src/proto/demo/.merlin index 1d807e77f..bee23c94c 100644 --- a/src/proto/demo/.merlin +++ b/src/proto/demo/.merlin @@ -1,9 +1,9 @@ B ../../node/updater/ B _tzbuild FLG -nopervasives -FLG -open Proto_environment +FLG -open Local_environment +FLG -open Environment FLG -open Hash -FLG -open Local_modules FLG -open Error_monad FLG -open Logging FLG -w -40 diff --git a/src/proto/environment/base48.mli b/src/proto/environment/base48.mli index dd000467b..ba3cc3733 100644 --- a/src/proto/environment/base48.mli +++ b/src/proto/environment/base48.mli @@ -3,12 +3,12 @@ module Prefix : sig val protocol_prefix: string end -type 'a encoding = 'a Base48.encoding +type 'a encoding val simple_decode: ?alphabet:string -> 'a encoding -> string -> 'a option val simple_encode: ?alphabet:string -> 'a encoding -> 'a -> string -type data = Base48.data = .. +type data = .. val register_encoding: prefix: string -> @@ -18,9 +18,3 @@ val register_encoding: 'a encoding val decode: ?alphabet:string -> string -> data option - -val register_resolver: - 'a encoding -> (Context.t -> string -> 'a list Lwt.t) -> unit - -val complete: - ?alphabet:string -> Context.t -> string -> string list Lwt.t diff --git a/src/proto/environment/context.mli b/src/proto/environment/context.mli index 3bf8d08d5..a2e895dcf 100644 --- a/src/proto/environment/context.mli +++ b/src/proto/environment/context.mli @@ -7,3 +7,9 @@ include Persist.STORE val get_genesis_time: t -> Time.t Lwt.t val get_genesis_block: t -> Block_hash.t Lwt.t + +val register_resolver: + 'a Base48.encoding -> (t -> string -> 'a list Lwt.t) -> unit + +val complete: + ?alphabet:string -> t -> string -> string list Lwt.t From 719b54ac1db36f7b079190ed0f52a4c27ee38c1c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Tue, 15 Nov 2016 14:44:16 +0100 Subject: [PATCH 10/10] Client: use contextual completion --- src/client/client_helpers.ml | 7 +++++-- src/client/client_node_rpcs.ml | 10 ++++++++-- src/client/client_node_rpcs.mli | 2 +- 3 files changed, 14 insertions(+), 5 deletions(-) diff --git a/src/client/client_helpers.ml b/src/client/client_helpers.ml index e5fa85b8d..4555be6ee 100644 --- a/src/client/client_helpers.ml +++ b/src/client/client_helpers.ml @@ -7,6 +7,8 @@ (* *) (**************************************************************************) +open Client_config + let () = let open Cli_entries in register_group "helpers" "Various helpers" @@ -21,11 +23,12 @@ let commands () = Cli_entries.[ command ~desc: "Lookup for the possible completion of a \ given prefix of Base48Check-encoded hash. This actually \ - works only for blocks and operations." + works only for blocks, operations, public key and contract \ + identifiers." ~args: [unique_arg] (prefixes [ "complete" ] @@ string "prefix" "the prefix of the Base48Check-encoded hash to be completed" @@ stop) (fun prefix () -> - Client_node_rpcs.complete prefix >>= fun completions -> + Client_node_rpcs.complete ~block:(block ()) prefix >>= fun completions -> match completions with | [] -> Pervasives.exit 3 | _ :: _ :: _ when !unique -> Pervasives.exit 3 diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index f897ebfd4..247195539 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -150,8 +150,12 @@ let inject_operation ?(wait = true) ?force operation = call_service0 Services.inject_operation (operation, wait, force) let inject_protocol ?(wait = true) ?force protocol = call_service0 Services.inject_protocol (protocol, wait, force) -let complete prefix = - call_service1 Services.complete prefix () +let complete ?block prefix = + match block with + | None -> + call_service1 Services.complete prefix () + | Some block -> + call_service2 Services.Blocks.complete block prefix () let describe ?recurse path = let prefix, arg = RPC.forge_request Services.describe () recurse in get_json (prefix @ path) arg >>= @@ -198,6 +202,8 @@ module Blocks = struct call_service1 Services.Blocks.pending_operations block () let info ?(operations = false) h = call_service1 Services.Blocks.info h operations + let complete block prefix = + call_service2 Services.Blocks.complete block prefix () let list ?operations ?length ?heads ?delay ?min_date ?min_heads () = call_service0 Services.Blocks.list { operations; length ; heads ; monitor = Some false ; delay ; diff --git a/src/client/client_node_rpcs.mli b/src/client/client_node_rpcs.mli index 3fe7e5fd6..8944348fe 100644 --- a/src/client/client_node_rpcs.mli +++ b/src/client/client_node_rpcs.mli @@ -104,7 +104,7 @@ module Protocols : sig (Protocol_hash.t * Store.protocol option) list Lwt.t end -val complete: string -> string list Lwt.t +val complete: ?block:Blocks.block -> string -> string list Lwt.t val describe: ?recurse:bool -> string list -> RPC.Description.directory_descr Lwt.t