Shell: add Base48.decode_partial

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 \

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 ;

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

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} *******************************************************)

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 kinds = ref ([] : kind 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
 
 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

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

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)

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 () =
+  let kind =
-    match K.prefix with
+    Utils.map_option
-    | Some prefix ->
+      K.prefix
+      ~f:(fun prefix ->
            Base48.register
              ~prefix
              ~read:(function Hash x -> Some x | _ -> None)
-          ~build:(fun x -> Hash x)
+             ~build:(fun x -> Hash x))
-    | None -> ()
 
   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 =

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} *******************************************************)

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 =

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

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

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 ->
+  (Operation_hash.t * State.Operation.operation) option ->
-  (Hash.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 ->
+  (Block_hash.t * Store.block) option ->
-  (Hash.Block_hash.t * Store.block) option ->
+  (Block_hash.t * Store.block) option ->
   unit
 
 val equal_result :

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 ;