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.
This commit is contained in:
Grégoire Henry
parent
1805a1d816
commit
b16a644e55
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -19,12 +19,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
|
||||
|
||||
@ -37,7 +37,6 @@ 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
|
||||
end
|
||||
|
||||
@ -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
|
||||
|
||||
@ -22,12 +22,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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ;
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 )
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 = {
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ]
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
type registred_encoding = Encoding : 'a encoding -> registred_encoding
|
||||
|
||||
module MakeEncodings(E: sig
|
||||
val encodings: registred_encoding list
|
||||
end) = struct
|
||||
|
||||
let encodings = ref E.encodings
|
||||
|
||||
let ambiguous_prefix prefix encodings =
|
||||
List.exists (fun (Encoding { prefix = s }) ->
|
||||
remove_prefix s prefix <> None ||
|
||||
remove_prefix prefix s <> None)
|
||||
encodings
|
||||
|
||||
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 decode ?alphabet s =
|
||||
let rec find s = function
|
||||
| [] -> raise Unknown_prefix
|
||||
| Kind { prefix ; build } :: kinds ->
|
||||
| [] -> None
|
||||
| Encoding { prefix ; of_raw ; wrap } :: encodings ->
|
||||
match remove_prefix ~prefix s with
|
||||
| None -> find s kinds
|
||||
| Some msg -> build msg in
|
||||
| None -> find s encodings
|
||||
| Some msg -> of_raw msg |> Utils.map_option ~f:wrap in
|
||||
let s = safe_decode ?alphabet s in
|
||||
find s !kinds
|
||||
find s !encodings
|
||||
|
||||
exception Unregistred_kind
|
||||
|
||||
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 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 ->
|
||||
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_resolver (Kind k) resolver = k.resolver <- resolver
|
||||
|
||||
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 protocol_prefix = "\015"
|
||||
end
|
||||
|
||||
let decode_partial ?alphabet request =
|
||||
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
|
||||
| Kind { prefix ; build ; resolver } :: kinds ->
|
||||
match remove_prefix ~prefix s with
|
||||
| None -> find s kinds
|
||||
| Resolver { encoding ; resolver } :: resolvers ->
|
||||
match remove_prefix ~prefix:encoding.prefix s with
|
||||
| None -> find s resolvers
|
||||
| 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
|
||||
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 ed25519_public_key_hash = "\003"
|
||||
let ed25519_public_key = "\012"
|
||||
let ed25519_secret_key = "\013"
|
||||
let ed25519_signature = "\014"
|
||||
let protocol_prefix = "\015"
|
||||
end
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
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)
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user