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] 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 ;