From d11e44dead53f9924fa9fb3fd591ca79ecdc382c Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Fri, 21 Oct 2016 14:01:01 +0200 Subject: [PATCH 1/8] hex_decode: better error reporting --- src/utils/hex_encode.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/utils/hex_encode.ml b/src/utils/hex_encode.ml index 65cf85f7f..3dc05256e 100644 --- a/src/utils/hex_encode.ml +++ b/src/utils/hex_encode.ml @@ -24,13 +24,14 @@ let hex_encode = gen_encode String.length (fun s i -> int_of_char s.[i]) (* From OCaml's stdlib. See [Digest.from_hex]. *) let gen_decode create set h = let n = String.length h in - if n mod 2 <> 0 then invalid_arg "hex_decode" ; + if n mod 2 <> 0 then invalid_arg ("hex_decode: " ^ h); let digit c = match c with | '0'..'9' -> int_of_char c - int_of_char '0' | 'A'..'F' -> int_of_char c - int_of_char 'A' + 10 | 'a'..'f' -> int_of_char c - int_of_char 'a' + 10 - | _c -> invalid_arg "hex_decode" in + | _c -> invalid_arg ("hex_decode: " ^ h) + in let byte i = digit h.[i] lsl 4 + digit h.[i+1] in let result = create (n / 2) in for i = 0 to n/2 - 1 do From 488373551b42cd05b05959ca1568127d15b95e3e Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Fri, 21 Oct 2016 14:01:20 +0200 Subject: [PATCH 2/8] add protocol store + rpcs --- src/client/client_node_rpcs.ml | 2 + src/client/client_node_rpcs.mli | 2 + src/node/db/context.ml | 2 +- src/node/db/db_proxy.ml | 41 +++++++++ src/node/db/db_proxy.mli | 12 +++ src/node/db/persist.ml | 14 +++ src/node/db/persist.mli | 9 ++ src/node/db/store.ml | 123 +++++++++++++++++++++++++++ src/node/db/store.mli | 34 ++++++++ src/node/shell/messages.ml | 16 ++-- src/node/shell/messages.mli | 5 +- src/node/shell/node.ml | 59 +++++++++---- src/node/shell/node.mli | 9 ++ src/node/shell/node_rpc.ml | 47 ++++++++++ src/node/shell/node_rpc_services.ml | 103 ++++++++++++++++++++++ src/node/shell/node_rpc_services.mli | 17 ++++ src/node/shell/state.ml | 82 +++++++++++++++++- src/node/shell/state.mli | 73 ++++++++++++++++ src/node/updater/updater.ml | 2 +- src/proto/environment/persist.mli | 6 ++ 20 files changed, 629 insertions(+), 29 deletions(-) diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index a0b7a567e..8197325af 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -148,6 +148,8 @@ let inject_block ?(wait = true) ?force block = call_service0 Services.inject_block (block, wait, force) 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 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 2f9ec342b..3fa2349cc 100644 --- a/src/client/client_node_rpcs.mli +++ b/src/client/client_node_rpcs.mli @@ -25,6 +25,8 @@ val inject_block: Block_hash.t tzresult Lwt.t val inject_operation: ?wait:bool -> ?force:bool -> MBytes.t -> Operation_hash.t tzresult Lwt.t +val inject_protocol: + ?wait:bool -> ?force:bool -> Store.protocol -> Protocol_hash.t tzresult Lwt.t module Blocks : sig diff --git a/src/node/db/context.ml b/src/node/db/context.ml index a18795f2c..6f16c2b2d 100644 --- a/src/node/db/context.ml +++ b/src/node/db/context.ml @@ -216,7 +216,7 @@ let remove_rec (module View : VIEW) key = GitStore.FunView.remove_rec View.v (data_key key) >>= fun v -> Lwt.return (pack (module GitStore) View.s v) - +let keys (module View : VIEW) = Store.undefined_key_fn (*-- Initialisation ----------------------------------------------------------*) diff --git a/src/node/db/db_proxy.ml b/src/node/db/db_proxy.ml index 2777256e6..6e4f89bec 100644 --- a/src/node/db/db_proxy.ml +++ b/src/node/db/db_proxy.ml @@ -23,6 +23,8 @@ module type DISTRIBUTED_DB = sig val update: t -> key -> value -> bool Lwt.t val remove: t -> key -> bool Lwt.t val shutdown: t -> unit Lwt.t + + val keys: t -> key list Lwt.t end type operation_state = { @@ -106,3 +108,42 @@ module Block = Persist.MakeImperativeProxy (Store.Faked_functional_block) (Block_hash_table) (Block_scheduler) + +type protocol_state = { + request_protocols: Protocol_hash.t list -> unit ; +} + +module Protocol_scheduler = struct + let name = "protocol_scheduler" + type rdata = Store.net_id + type data = float ref + type state = protocol_state + let init_request _ _ = Lwt.return (ref 0.0) + let request net ~get:_ ~set:_ pendings = + let current_time = Unix.gettimeofday () in + let time = current_time -. (3. +. Random.float 8.) in + let protocols = + List.fold_left + (fun acc (hash, last_request, Store.Net net_id) -> + if !last_request < time then begin + last_request := current_time ; + let prev = + try Block_hash_map.find net_id acc + with Not_found -> [] in + Block_hash_map.add net_id (hash :: prev) acc + end else + acc) + Block_hash_map.empty + pendings in + if Block_hash_map.is_empty protocols then + 0. + else begin + Block_hash_map.iter (fun _net_id -> net.request_protocols) protocols ; + 1. +. Random.float 4. + end +end + +module Protocol = + Persist.MakeImperativeProxy + (Store.Faked_functional_protocol) + (Protocol_hash_table) (Protocol_scheduler) diff --git a/src/node/db/db_proxy.mli b/src/node/db/db_proxy.mli index 9370a1754..b69483202 100644 --- a/src/node/db/db_proxy.mli +++ b/src/node/db/db_proxy.mli @@ -23,6 +23,8 @@ module type DISTRIBUTED_DB = sig val update: t -> key -> value -> bool Lwt.t val remove: t -> key -> bool Lwt.t val shutdown: t -> unit Lwt.t + + val keys: t -> key list Lwt.t end type operation_state = { @@ -44,3 +46,13 @@ module Block : and type key := Store.Block.key and type value := Store.Block.value and type state := block_state + + +type protocol_state = { + request_protocols: Protocol_hash.t list -> unit ; +} +module Protocol : + DISTRIBUTED_DB with type store := Store.Protocol.t + and type key := Store.Protocol.key + and type value := Store.Protocol.value + and type state := protocol_state diff --git a/src/node/db/persist.ml b/src/node/db/persist.ml index 43811d6ab..b0ae55440 100644 --- a/src/node/db/persist.ml +++ b/src/node/db/persist.ml @@ -24,6 +24,8 @@ module type 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 module type BYTES_STORE = sig @@ -35,6 +37,8 @@ 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 module type TYPED_STORE = sig @@ -45,6 +49,8 @@ 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 module type KEY = sig @@ -146,6 +152,7 @@ module MakeBytesStore let remove_rec s k = S.remove_rec s (to_path k) + let keys s = S.keys s >|= List.map of_path end module MakeTypedStore @@ -167,6 +174,7 @@ module MakeTypedStore let raw_get = S.get + let keys = S.keys end module RawKey = struct @@ -369,6 +377,8 @@ module type IMPERATIVE_PROXY = sig val fetch: t -> rdata -> Store.key -> Store.value Lwt.t val pending: t -> Store.key -> bool val shutdown: t -> unit Lwt.t + + val keys: t -> Store.key list Lwt.t end module type IMPERATIVE_PROXY_SCHEDULER = sig @@ -457,6 +467,8 @@ module MakeImperativeProxy let known { store } hash = use store (fun store -> Store.mem store hash) + let keys { store } = use store Store.keys + let read { store } hash = use store (fun store -> Store.get store hash) @@ -528,6 +540,8 @@ module MakeImperativeProxy let shutdown { cancel ; worker } = cancel () >>= fun () -> worker + let keys { store } = + use store (fun store -> Store.keys store) end (*-- Predefined Instances ----------------------------------------------------*) diff --git a/src/node/db/persist.mli b/src/node/db/persist.mli index 69380e0a6..ede8de0e4 100644 --- a/src/node/db/persist.mli +++ b/src/node/db/persist.mli @@ -27,6 +27,8 @@ module type 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 (** Projection of OCaml keys of some abstract type to concrete storage @@ -55,6 +57,8 @@ 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 module MakeBytesStore (S : STORE) (K : KEY) : @@ -82,6 +86,8 @@ 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 (** Not always relevant, BEWARE! *) end (** Gives a typed view of a store (values of a given type stored under @@ -91,6 +97,7 @@ end module MakeTypedStore (S : STORE) (K : KEY) (C : VALUE) : TYPED_STORE with type t = S.t and type key = K.t and type value = C.t + (** {2 Persistent Sets} ******************************************************) (** Signature of a set as returned by {!MakePersistentSet} *) @@ -194,6 +201,8 @@ module type IMPERATIVE_PROXY = sig val fetch: t -> rdata -> Store.key -> Store.value Lwt.t val pending: t -> Store.key -> bool val shutdown: t -> unit Lwt.t + + val keys: t -> Store.key list Lwt.t end module type IMPERATIVE_PROXY_SCHEDULER = sig diff --git a/src/node/db/store.ml b/src/node/db/store.ml index 4ffc3abd1..2447b001a 100644 --- a/src/node/db/store.ml +++ b/src/node/db/store.ml @@ -92,11 +92,13 @@ type generic_store = FS.t type block_store = FS.t type blockchain_store = FS.t type operation_store = FS.t +type protocol_store = FS.t type store = { block: block_store Persist.shared_ref ; blockchain: blockchain_store Persist.shared_ref ; operation: operation_store Persist.shared_ref ; + protocol: protocol_store Persist.shared_ref ; global_store: generic_store Persist.shared_ref ; net_init: ?expiration:Time.t -> genesis -> net_store Lwt.t ; net_read: net_id -> net_store tzresult Lwt.t ; @@ -126,6 +128,8 @@ module type TYPED_IMPERATIVE_STORE = sig val get_exn: t -> key -> value Lwt.t val set: t -> key -> value -> unit Lwt.t val del: t -> key -> unit Lwt.t + + val keys: t -> key list Lwt.t end module type IMPERATIVE_STORE = sig @@ -146,6 +150,14 @@ module type KEY = sig val to_path: t -> string list end +module type HASHKEY = sig + type t + val to_path: t -> string list + val of_path: string list -> t + val prefix : string list + val length : int +end + module Raw_key = struct type t = string list let to_path x = x @@ -187,6 +199,7 @@ module Errors_value = struct let of_bytes b = Data_encoding.(Binary.of_bytes (list (error_encoding ()))) b end +let undefined_key_fn = Lwt.fail_invalid_arg "function keys cannot be implemented in this module" module Make (K : KEY) (V : Persist.VALUE) = struct type t = FS.t @@ -205,6 +218,8 @@ module Make (K : KEY) (V : Persist.VALUE) = struct let del t k = FS.del t (K.to_path k) let list t ks = FS.list t (List.map K.to_path ks) let remove_rec t k = FS.remove_rec t (K.to_path k) + + let keys _t = undefined_key_fn end module Data_store : IMPERATIVE_STORE with type t = FS.t = @@ -212,6 +227,7 @@ module Data_store : IMPERATIVE_STORE with type t = FS.t = include Data_store + (*-- Typed block store under "blocks/" ---------------------------------------*) type shell_block = { @@ -350,6 +366,7 @@ module Block = struct let raw_get t k = Raw_block.get t k + let keys _t = undefined_key_fn (** We never list keys here *) end module Blockchain_succ_key = struct @@ -484,9 +501,111 @@ module Operation = struct let to_bytes = Raw_operation_value.to_bytes let hash op = Operation_hash.hash_bytes [to_bytes op] let raw_get t k = Raw_operation_data.get t k + + let keys _t = undefined_key_fn (** We never list keys here *) end +(*-- Typed operation store under "protocols/" -------------------------------*) + +type component = { + name : string ; + interface : string option ; + implementation : string ; +} + +let component_encoding = + let open Data_encoding in + conv + (fun { name ; interface; implementation } -> (name, interface, implementation)) + (fun (name, interface, implementation) -> { name ; interface ; implementation }) + (obj3 + (req "name" string) + (opt "interface" string) + (req "implementation" string)) + +type protocol = component list +let protocol_encoding = Data_encoding.list component_encoding + +module Raw_protocol_value = struct + type t = protocol + let to_bytes v = Data_encoding.Binary.to_bytes protocol_encoding v + let of_bytes b = Data_encoding.Binary.of_bytes protocol_encoding b +end + +module Raw_protocol_key = struct + type t = Protocol_hash.t + let to_path p = "protocols" :: Protocol_hash.to_path p @ [ "contents" ] +end + +module Protocol_data = Make (Raw_protocol_key) (Raw_protocol_value) +module Raw_protocol_data = Make (Raw_protocol_key) (Raw_value) + +module Protocol_time_key = struct + type t = Protocol_hash.t + let to_path p = "protocols" :: Protocol_hash.to_path p @ [ "discovery_time" ] +end +module Protocol_time = Make (Protocol_time_key) (Time_value) + +module Protocol_errors_key = struct + type t = Protocol_hash.t + let to_path p = "protocols" :: Protocol_hash.to_path p @ [ "errors" ] +end +module Protocol_errors = Make (Protocol_errors_key) (Errors_value) + +module Protocol = struct + type t = FS.t + type key = Protocol_hash.t + type value = protocol tzresult Time.timed_data + let mem = Protocol_data.mem + let get s k = + Protocol_time.get s k >>= function + | None -> Lwt.return_none + | Some time -> + Protocol_errors.get s k >>= function + | Some exns -> Lwt.return (Some { Time.data = Error exns ; time }) + | None -> + Protocol_data.get s k >>= function + | None -> Lwt.return_none + | Some bytes -> Lwt.return (Some { Time.data = Ok bytes ; time }) + let get_exn s k = + get s k >>= function + | None -> Lwt.fail Not_found + | Some x -> Lwt.return x + let set s k { Time.data ; time } = + Protocol_time.set s k time >>= fun () -> + match data with + | Ok bytes -> + Protocol_data.set s k bytes >>= fun () -> + Protocol_errors.del s k + | Error exns -> + Protocol_errors.set s k exns >>= fun () -> + Protocol_data.del s k + let del s k = + Protocol_time.del s k >>= fun () -> + Protocol_data.del s k >>= fun () -> + Protocol_errors.del s k + let of_bytes = Raw_protocol_value.of_bytes + let to_bytes = Raw_protocol_value.to_bytes + let hash proto = Protocol_hash.hash_bytes [to_bytes proto] + let compare p1 p2 = + Protocol_hash.(compare (hash_bytes [to_bytes p1]) (hash_bytes [to_bytes p2])) + let equal b1 b2 = compare b1 b2 = 0 + let raw_get t k = Raw_protocol_data.get t k + + let fold s x ~f = + let rec dig i root acc = + if i <= 0 then + f (Protocol_hash.of_path @@ List.tl root) acc + else + FS.list s [root] >>= fun roots -> + Lwt_list.fold_right_s (dig (i - 1)) roots acc + in + dig Protocol_hash.path_len ["protocols"] x + + let keys s = fold s [] ~f:(fun k a -> Lwt.return @@ k :: a) +end + (*- Genesis and initialization -----------------------------------------------*) let genesis_encoding = @@ -620,6 +739,7 @@ let init root = { block = Persist.share t ; blockchain = Persist.share t ; operation = Persist.share t ; + protocol = Persist.share t ; global_store = Persist.share t ; net_init = net_init ~root ; net_read = net_read ~root ; @@ -638,6 +758,7 @@ end module Faked_functional_operation = Faked_functional_typed_store (Operation) module Faked_functional_block = Faked_functional_typed_store (Block) +module Faked_functional_protocol = Faked_functional_typed_store (Protocol) module Faked_functional_store : Persist.STORE with type t = t = struct @@ -645,4 +766,6 @@ module Faked_functional_store : Persist.STORE with type t = t let set s k v = Data_store.set s k v >>= fun () -> Lwt.return s let del s k = Data_store.del s k >>= fun () -> Lwt.return s let remove_rec s k = Data_store.remove_rec s k >>= fun () -> Lwt.return s + + let keys _s = invalid_arg "function keys not implementable here" (** We never use list here. *) end diff --git a/src/node/db/store.mli b/src/node/db/store.mli index a91909889..8bbc1ebf7 100644 --- a/src/node/db/store.mli +++ b/src/node/db/store.mli @@ -21,6 +21,7 @@ module type TYPED_IMPERATIVE_STORE = sig val get_exn: t -> key -> value Lwt.t val set: t -> key -> value -> unit Lwt.t val del: t -> key -> unit Lwt.t + val keys: t -> key list Lwt.t end module type IMPERATIVE_STORE = sig @@ -39,11 +40,13 @@ type generic_store type block_store type blockchain_store type operation_store +type protocol_store type store = private { block: block_store Persist.shared_ref ; blockchain: blockchain_store Persist.shared_ref ; operation: operation_store Persist.shared_ref ; + protocol: protocol_store Persist.shared_ref ; global_store: generic_store Persist.shared_ref ; net_init: ?expiration:Time.t -> genesis -> net_store Lwt.t ; net_read: net_id -> net_store tzresult Lwt.t ; @@ -70,6 +73,9 @@ val pp_net_id: Format.formatter -> net_id -> unit (** Open or initialize a store at a given path. *) val init: string -> store Lwt.t +(** Lwt exn returned when function keys is not implemented *) +val undefined_key_fn : 'a Lwt.t + (** {2 Generic interface} ****************************************************) (** The generic primitives do work on the direct root, but in a @@ -107,6 +113,16 @@ type block = { val shell_block_encoding: shell_block Data_encoding.t val block_encoding: block Data_encoding.t +(** Protocol *) +type component = { + name : string ; + interface : string option ; + implementation : string ; +} + +type protocol = component list +val protocol_encoding : protocol Data_encoding.t + (** {2 Block and operations store} ********************************************) module Block : sig @@ -177,6 +193,19 @@ module Operation : sig end +module Protocol : sig + val of_bytes: MBytes.t -> protocol option + val to_bytes: protocol -> MBytes.t + val hash: protocol -> Protocol_hash.t + + include TYPED_IMPERATIVE_STORE + with type t = protocol_store + and type key = Protocol_hash.t + and type value = protocol tzresult Time.timed_data + + val raw_get: t -> Protocol_hash.t -> MBytes.t option Lwt.t +end + (**/**) (* For testing only *) (* module LwtUnixStore : sig *) @@ -198,4 +227,9 @@ module Faked_functional_block : and type value = Block.value and type key = Block.key +module Faked_functional_protocol : + Persist.TYPED_STORE with type t = Protocol.t + and type value = Protocol.value + and type key = Protocol.key + module Faked_functional_store : Persist.STORE with type t = t diff --git a/src/node/shell/messages.ml b/src/node/shell/messages.ml index eba85a1a0..22e32f68c 100644 --- a/src/node/shell/messages.ml +++ b/src/node/shell/messages.ml @@ -25,8 +25,8 @@ type message = | Get_operations of Operation_hash.t list | Operation of MBytes.t - | Current_protocol of net_id - | Protocol_inventory of Protocol_hash.t + | Get_protocols of Protocol_hash.t list + | Protocol of MBytes.t let to_frame msg = @@ -54,10 +54,10 @@ let to_frame msg = | Operation b -> [ S 2703 ; B b ] - | Current_protocol (Net net_id) -> - [ S 2800 ; bh net_id ] - | Protocol_inventory p -> - [ S 2801 ; ph p ] + | Get_protocols protos -> + [ S 2800 ; F (List.map ph protos) ] + | Protocol p -> + [ S 2801 ; B p ] let from_frame msg = @@ -82,9 +82,9 @@ let from_frame msg = Some (Get_operations (List.map oph ops)) | [ S 2703 ; B contents ] -> Some (Operation contents) - | [ S 2800 ; B netid ] -> Some (Current_protocol (net netid)) + | [ S 2800 ; F protos ] -> Some (Get_protocols (List.map ph protos)) - | [ S 2801 ; p ] -> Some (Protocol_inventory (ph p)) + | [ S 2801 ; B contents ] -> Some (Protocol contents) | _ -> None diff --git a/src/node/shell/messages.mli b/src/node/shell/messages.mli index 0f8c1601a..2c3df42cc 100644 --- a/src/node/shell/messages.mli +++ b/src/node/shell/messages.mli @@ -22,8 +22,9 @@ type message = | Get_operations of Operation_hash.t list | Operation of MBytes.t - | Current_protocol of Store.net_id - | Protocol_inventory of Protocol_hash.t + | Get_protocols of Protocol_hash.t list + | Protocol of MBytes.t + (** Converts a high level message to a network frame *) val to_frame: message -> Netbits.frame diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index f14d5e1b7..67291fac5 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -24,6 +24,13 @@ let inject_operation validator ?force bytes = let hash = Operation_hash.hash_bytes [bytes] in Lwt.return (hash, t) +let inject_protocol state ?force:_ proto = + (* TODO: Validate the protocol *) + let proto_bytes = Store.Protocol.to_bytes proto in + let hash = Protocol_hash.hash_bytes [proto_bytes] in + let t = State.Protocol.store state proto_bytes >>|? ignore in + Lwt.return (hash, t) + let process_operation state validator bytes = State.Operation.store state bytes >>= function | Error _ | Ok None -> Lwt.return_unit @@ -38,6 +45,13 @@ let process_operation state validator bytes = Prevalidator.register_operation prevalidator hash ; Lwt.return_unit +let process_protocol state _validator bytes = + State.Protocol.store state bytes >>= function + | Error _ | Ok None -> Lwt.return_unit + | Ok (Some (hash, _proto)) -> + (* TODO: Store only pending protocols... *) + lwt_log_info "process Protocol %a" Protocol_hash.pp_short hash + let process_block state validator bytes = State.Block.store state bytes >>= function | Error _ | Ok None -> Lwt.return_unit @@ -144,23 +158,20 @@ let process state validator msg = process_operation state validator content >>= fun () -> Lwt.return_nil - | Current_protocol net_id -> - lwt_log_info "process Current_protocol" >>= fun () -> - if not (State.Net.is_active state net_id) then - Lwt.return_nil - else begin - match State.Net.get state net_id with - | Error _ -> Lwt.return_nil - | Ok net -> - State.Net.Blockchain.head net >>= fun head -> - Lwt.return [Protocol_inventory head.protocol_hash] - end + | Get_protocols protos -> + lwt_log_info "process Get_protocols" >>= fun () -> + Lwt_list.map_p (State.Protocol.raw_read state) protos >>= fun protos -> + let cons_protocol acc = function + | Some proto -> Protocol proto :: acc + | None -> acc in + Lwt.return (List.fold_left cons_protocol [] protos) - | Protocol_inventory _ -> - lwt_log_info "process Protocol_inventory" >>= fun () -> - (* TODO... *) + | Protocol content -> + lwt_log_info "process Protocol" >>= fun () -> + process_protocol state validator content >>= fun () -> Lwt.return_nil + type t = { state: State.t ; validator: Validator.worker ; @@ -170,6 +181,8 @@ type t = { ?force:bool -> MBytes.t -> (Block_hash.t * unit tzresult Lwt.t) Lwt.t ; inject_operation: ?force:bool -> MBytes.t -> (Operation_hash.t * unit tzresult Lwt.t) Lwt.t ; + inject_protocol: + ?force:bool -> Store.protocol -> (Protocol_hash.t * unit tzresult Lwt.t) Lwt.t ; shutdown: unit -> unit Lwt.t ; } @@ -184,6 +197,11 @@ let request_blocks net _net_id blocks = For now simply broadcast the request to all our neighbours. *) P2p.broadcast (Messages.(to_frame (Get_blocks blocks))) net +let request_protocols net protocols = + (* TODO improve the lookup strategy. + For now simply broadcast the request to all our neighbours. *) + P2p.broadcast (Messages.(to_frame (Get_protocols protocols))) net + let init_p2p net_params = match net_params with | None -> @@ -200,8 +218,9 @@ let create lwt_log_info "reading state..." >>= fun () -> let request_operations = request_operations p2p in let request_blocks = request_blocks p2p in + let request_protocols = request_protocols p2p in State.read - ~request_operations ~request_blocks + ~request_operations ~request_blocks ~request_protocols ~store_root ~context_root ~ttl:(48 * 3600) (* 2 days *) ?patch_context () >>= fun state -> let validator = Validator.create_worker p2p state in @@ -264,6 +283,7 @@ let create global_validator ; inject_block = inject_block state validator ; inject_operation = inject_operation validator ; + inject_protocol = inject_protocol state ; shutdown ; } @@ -310,6 +330,7 @@ module RPC = struct let inject_block node = node.inject_block let inject_operation node = node.inject_operation + let inject_protocol node = node.inject_protocol let raw_block_info node hash = State.Valid_block.read_exn node.state hash >|= convert @@ -449,6 +470,11 @@ module RPC = struct State.Net.Mempool.for_block net b >|= fun ops -> Updater.empty_result, ops + let protocols { state } = State.Protocol.keys state + + let protocol_content node hash = + State.Protocol.read node.state hash + let preapply node block ~timestamp ~sort ops = begin match block with @@ -539,6 +565,9 @@ module RPC = struct let operation_watcher node = State.Operation.create_watcher node.state + let protocol_watcher node = + State.Protocol.create_watcher node.state + let validate node net_id block = Validator.get node.validator net_id >>=? fun net_v -> Validator.fetch_block net_v block >>=? fun _ -> diff --git a/src/node/shell/node.mli b/src/node/shell/node.mli index f1ffe52c6..d5368fa7c 100644 --- a/src/node/shell/node.mli +++ b/src/node/shell/node.mli @@ -29,6 +29,8 @@ module RPC : sig t -> ?force:bool -> MBytes.t -> (Block_hash.t * unit tzresult Lwt.t) Lwt.t val inject_operation: t -> ?force:bool -> MBytes.t -> (Operation_hash.t * unit tzresult Lwt.t) Lwt.t + val inject_protocol: + t -> ?force:bool -> Store.protocol -> (Protocol_hash.t * unit tzresult Lwt.t) Lwt.t val raw_block_info: t -> Block_hash.t -> block_info Lwt.t @@ -54,6 +56,13 @@ module RPC : sig val pending_operations: t -> block -> (error Updater.preapply_result * Operation_hash_set.t) Lwt.t + val protocols: + t -> Protocol_hash.t list Lwt.t + val protocol_content: + t -> Protocol_hash.t -> Store.protocol tzresult Time.timed_data option Lwt.t + val protocol_watcher: + t -> (Protocol_hash.t * Store.protocol) Lwt_stream.t * (unit -> unit) + val context_dir: t -> block -> 'a RPC.directory option Lwt.t diff --git a/src/node/shell/node_rpc.ml b/src/node/shell/node_rpc.ml index 9a58865f0..a938ec44c 100644 --- a/src/node/shell/node_rpc.ml +++ b/src/node/shell/node_rpc.ml @@ -332,6 +332,42 @@ let get_operations node hash () = | Some bytes -> RPC.Answer.return bytes | None -> raise Not_found +let list_protocols node {Services.Protocols.monitor; contents} = + let monitor = match monitor with None -> false | Some x -> x in + let include_contents = match contents with None -> false | Some x -> x in + Node.RPC.protocols node >>= fun protocols -> + Lwt_list.map_p + (fun hash -> + if include_contents then + Node.RPC.protocol_content node hash >>= function + | None | Some { Time.data = Error _ } -> Lwt.return (hash, None) + | Some { Time.data = Ok bytes }-> + Lwt.return (hash, Some bytes) + else + Lwt.return (hash, None)) + protocols >>= fun protocols -> + if not monitor then + RPC.Answer.return protocols + else + let stream, shutdown = Node.RPC.protocol_watcher node in + let first_request = ref true in + let next () = + if not !first_request then + Lwt_stream.get stream >>= function + | None -> Lwt.return_none + | Some (h, op) when include_contents -> Lwt.return (Some [h, Some op]) + | Some (h, _) -> Lwt.return (Some [h, None]) + else begin + first_request := false ; + Lwt.return (Some protocols) + end in + RPC.Answer.return_stream { next ; shutdown } + +let get_protocols node hash () = + Node.RPC.protocol_content node hash >>= function + | Some bytes -> RPC.Answer.return bytes + | None -> raise Not_found + let build_rpc_directory node = let dir = RPC.empty in let dir = RPC.register0 dir Services.Blocks.list (list_blocks node) in @@ -351,6 +387,10 @@ let build_rpc_directory node = RPC.register0 dir Services.Operations.list (list_operations node) in let dir = RPC.register1 dir Services.Operations.bytes (get_operations node) in + let dir = + RPC.register0 dir Services.Protocols.list (list_protocols node) in + let dir = + RPC.register1 dir Services.Protocols.bytes (get_protocols node) in let dir = let implementation (net_id, pred, time, fitness, operations, header) = Node.RPC.block_info node (`Head 0) >>= fun bi -> @@ -383,6 +423,13 @@ let build_rpc_directory node = (if blocking then wait else return ()) >>=? fun () -> return hash end >>= RPC.Answer.return in RPC.register0 dir Services.inject_operation implementation in + let dir = + let implementation (proto, blocking, force) = + Node.RPC.inject_protocol ?force node proto >>= fun (hash, wait) -> + begin + (if blocking then wait else return ()) >>=? fun () -> return hash + end >>= RPC.Answer.return in + RPC.register0 dir Services.inject_protocol implementation in let dir = let implementation () = RPC.Answer.return Data_encoding.Json.(schema (Error_monad.error_encoding ())) in diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index 75d8bea6e..4b85cd97e 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -383,6 +383,56 @@ module Operations = struct end +module Protocols = struct + let protocols_arg = + let name = "protocol_id" in + let descr = + "A protocol identifier in hexadecimal." in + let construct = Protocol_hash.to_b48check in + let destruct h = + try Ok (Protocol_hash.of_b48check h) + with _ -> Error "Can't parse hash" in + RPC.Arg.make ~name ~descr ~construct ~destruct () + + let bytes = + RPC.service + ~input: empty + ~output: + (obj1 (req "data" + (describe ~title: "Tezos protocol" + (Time.timed_encoding @@ + RPC.Error.wrap @@ + Store.protocol_encoding)))) + RPC.Path.(root / "protocols" /: protocols_arg) + + type list_param = { + contents: bool option ; + monitor: bool option ; + } + + let list_param_encoding = + conv + (fun {contents; monitor} -> (contents, monitor)) + (fun (contents, monitor) -> {contents; monitor}) + (obj2 + (opt "contents" bool) + (opt "monitor" bool)) + + let list = + RPC.service + ~input: list_param_encoding + ~output: + (obj1 + (req "protocols" + (list + (obj2 + (req "hash" Protocol_hash.encoding) + (opt "contents" + (dynamic_size Store.protocol_encoding))) + ))) + RPC.Path.(root / "protocols") +end + let forge_block = RPC.service ~description: "Forge a block header" @@ -480,6 +530,59 @@ let inject_operation = (obj1 (req "injectedOperation" Operation_hash.encoding))) RPC.Path.(root / "inject_operation") +let inject_protocol = + let proto = + (list + (obj3 + (req "name" + (describe ~title:"OCaml module name" + string)) + (opt "interface" + (describe + ~description:"Content of the .mli file" + string)) + (req "implementation" + (describe + ~description:"Content of the .ml file" + string)))) + in + let proto_of_rpc = + List.map (fun (name, interface, implementation) -> + { Store.name; interface; implementation }) + in + let rpc_of_proto = + List.map (fun { Store.name; interface; implementation } -> + (name, interface, implementation)) + in + RPC.service + ~description: + "Inject a protocol in node. Returns the ID of the protocol." + ~input: + (conv + (fun (proto, blocking, force) -> (rpc_of_proto proto, Some blocking, force)) + (fun (proto, blocking, force) -> (proto_of_rpc proto, unopt true blocking, force)) + (obj3 + (req "protocol" + (describe ~title: "Tezos protocol" + proto)) + (opt "blocking" + (describe + ~description: + "Should the RPC wait for the protocol to be \ + validated before to answer. (default: true)" + bool)) + (opt "force" + (describe + ~description: + "Should we inject protocol that is invalid. (default: false)" + bool)))) + ~output: + (RPC.Error.wrap @@ + describe + ~title: "Hash of the injected protocol" @@ + (obj1 (req "injectedProtocol" Protocol_hash.encoding))) + RPC.Path.(root / "inject_protocol") + 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 6aa778939..055de2ec6 100644 --- a/src/node/shell/node_rpc_services.mli +++ b/src/node/shell/node_rpc_services.mli @@ -97,6 +97,19 @@ module Operations : sig list_param, (Operation_hash.t * Store.operation option) list) RPC.service end +module Protocols : sig + val bytes: + (unit, unit * Protocol_hash.t, unit, + Store.protocol tzresult Time.timed_data) RPC.service + type list_param = { + contents: bool option ; + monitor: bool option ; + } + val list: + (unit, unit, + list_param, (Protocol_hash.t * Store.protocol option) list) RPC.service +end + val forge_block: (unit, unit, Updater.net_id option * Block_hash.t option * Time.t option * @@ -115,5 +128,9 @@ val inject_operation: (unit, unit, (MBytes.t * bool * bool option), Operation_hash.t tzresult) RPC.service +val inject_protocol: + (unit, unit, + (Store.protocol * bool * bool option), Protocol_hash.t tzresult) RPC.service + val describe: (unit, unit, bool option, RPC.Description.directory_descr) RPC.service diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml index b4433eb6e..3fb1853dd 100644 --- a/src/node/shell/state.ml +++ b/src/node/shell/state.ml @@ -82,6 +82,9 @@ type t = { operation_db: Db_proxy.Operation.t ; operation_watchers: (Operation_hash.t * Store.operation) Watcher.t list ref ; + protocol_db: Db_proxy.Protocol.t ; + protocol_watchers: + (Protocol_hash.t * Store.protocol) Watcher.t list ref ; valid_block_state: valid_block_state Persist.shared_ref ; } @@ -154,6 +157,15 @@ module InvalidOperations = Persist.MakeBufferedPersistentSet (Store.Faked_functional_store) (InvalidOperations_key) (Operation_hash_set) +module InvalidProtocols_key = struct + include Protocol_hash + let prefix = ["state"; "invalid_protocols"] + let length = path_len +end +module InvalidProtocols = + Persist.MakeBufferedPersistentSet + (Store.Faked_functional_store) (InvalidProtocols_key) (Protocol_hash_set) + module InvalidBlocks_key = struct include Block_hash let prefix = ["state"; "invalid_blocks"] @@ -236,6 +248,66 @@ module Operation = struct end +module Protocol = struct + type key = Store.Protocol.key + + type component = Store.component = { + name: string; + interface: string option; + implementation: string + } + + type t = Store.protocol + + type protocol = t + exception Invalid of key * error list + let of_bytes = Store.Protocol.of_bytes + let to_bytes = Store.Protocol.to_bytes + let known t k = Db_proxy.Protocol.known t.protocol_db k + let read t k = Db_proxy.Protocol.read t.protocol_db k + let read_exn t k = + Db_proxy.Protocol.read t.protocol_db k >>= function + | None -> Lwt.fail Not_found + | Some { data = Error e } -> Lwt.fail (Invalid (k, e)) + | Some { data = Ok data ; time } -> Lwt.return { Time.data ; time } + let hash = Store.Protocol.hash + let raw_read t k = + Persist.use t.store.Store.protocol + (fun store -> Store.Protocol.raw_get store k) + let prefetch t net_id ks = + List.iter (Db_proxy.Protocol.prefetch t.protocol_db net_id) ks + let fetch t net_id k = Db_proxy.Protocol.fetch t.protocol_db net_id k + let store t bytes = + match of_bytes bytes with + | None -> fail Cannot_parse + | Some proto -> + let h = hash proto in + Db_proxy.Protocol.store t.protocol_db h (Time.make_timed (Ok proto)) + >>= function + | true -> + Watcher.notify !(t.protocol_watchers) (h, proto) ; + return (Some (h, proto)) + | false -> + return None + let mark_invalid t k e = + Db_proxy.Protocol.update t.protocol_db k (Time.make_timed (Error e)) + >>= function + | true -> + Persist.update t.store.global_store (fun store -> + InvalidProtocols.set store k >>= fun store -> + Lwt.return (Some store)) >>= fun _ -> + Lwt.return true + | false -> Lwt.return false + + let invalid state = + Persist.use state.store.global_store InvalidProtocols.read + + let create_watcher t = Watcher.create_stream t.protocol_watchers () + + let keys { protocol_db } = Db_proxy.Protocol.keys protocol_db + +end + let iter_predecessors (type t) (compare: t -> t -> int) @@ -458,7 +530,7 @@ module Valid_block = struct hash: Block_hash.t ; pred: Block_hash.t ; timestamp: Time.t ; - fitness: Protocol.fitness ; + fitness: Fitness.fitness ; operations: Operation_hash.t list ; discovery_time: Time.t ; protocol_hash: Protocol_hash.t ; @@ -785,6 +857,8 @@ module Valid_block = struct | Error exns -> locked_store_invalid vstate hash exns >>= fun _changed -> Lwt.return vstate + + let keys _ = Store.undefined_key_fn end let iter_predecessors = @@ -1216,12 +1290,14 @@ let () = (** Whole protocol state : read and store. *) let read - ~request_operations ~request_blocks + ~request_operations ~request_blocks ~request_protocols ~store_root ~context_root ~ttl ?patch_context () = Store.init store_root >>= fun store -> lwt_log_info "Initialising the distributed database..." >>= fun () -> let operation_db = Db_proxy.Operation.create { request_operations } store.operation in + let protocol_db = + Db_proxy.Protocol.create { request_protocols } store.protocol in let block_db = Db_proxy.Block.create { request_blocks } store.block in Valid_block.create @@ -1233,6 +1309,8 @@ let read nets = Block_hash_table.create 7 ; operation_db ; operation_watchers = ref [] ; + protocol_db ; + protocol_watchers = ref [] ; block_db ; block_watchers = ref [] ; valid_block_state ; } diff --git a/src/node/shell/state.mli b/src/node/shell/state.mli index e5084f6b9..7ea0dfdda 100644 --- a/src/node/shell/state.mli +++ b/src/node/shell/state.mli @@ -39,6 +39,7 @@ type error += val read: request_operations: (net_id -> Operation_hash.t list -> unit) -> request_blocks: (net_id -> Block_hash.t list -> unit) -> + request_protocols: (Protocol_hash.t list -> unit) -> store_root:string -> context_root:string -> ttl:int -> @@ -342,6 +343,78 @@ module Valid_block : sig end +(** {2 Protocol database} ****************************************************) + +(** The local and distributed database of protocols. *) +module Protocol : sig + + type key = Protocol_hash.t + + type component = Store.component = { + name : string ; + interface : string option ; + implementation : string ; + } + + type t = Store.protocol + + type protocol = t + + (** Is a protocol stored in the local database ? *) + val known: state -> key -> bool Lwt.t + + (** Read a protocol in the local database. This returns [None] + when the protocol does not exist in the local database; this returns + [Some (Error _)] when [mark_invalid] was used. This also returns + the time when the protocol was stored on the local database. *) + val read: + state -> key -> protocol tzresult Time.timed_data option Lwt.t + + (** Read a protocol in the local database. This throws [Not_found] + when the protocol does not exist in the local database or when + [mark_invalid] was used. *) + val read_exn: + state -> key -> protocol Time.timed_data Lwt.t + exception Invalid of key * error list + + (** Read an operation in the local database (without parsing). *) + val raw_read: state -> key -> MBytes.t option Lwt.t + + (** Read a protocol from the distributed database. This may block + while the block is fetched from the P2P network. *) + val fetch: + state -> Store.net_id -> key -> protocol tzresult Time.timed_data Lwt.t + + (** Request protocols on the P2P network without waiting for answers. *) + val prefetch: state -> Store.net_id -> key list -> unit + + (** Add a protocol to the local database. This returns [Ok None] + if the protocol was already stored in the database, or returns + the parsed operation if not. It may also fails when the shell + part of the operation cannot be parsed or when the operation + does not belong to an active "network". For a given sequence of + bytes, it is guaranted that at most one call to [store] returns + [Some _]. *) + val store: + state -> MBytes.t -> (Protocol_hash.t * protocol) option tzresult Lwt.t + + (** Mark a protocol as invalid in the local database. This returns + [false] if the protocol was previously stored in the local + database. The protocol is not removed from the local database, + but its content is replaced by a list of errors. *) + val mark_invalid: state -> key -> error list -> bool Lwt.t + + (** Returns the list known-invalid procols. *) + val invalid: state -> Protocol_hash_set.t Lwt.t + + (** Create a stream of all the newly locally-stored protocols. + The returned function allows to terminate the stream. *) + val create_watcher: + state -> (key * protocol) Lwt_stream.t * (unit -> unit) + + val keys: state -> key list Lwt.t +end + (** {2 Network} ****************************************************************) (** Data specific to a given network. *) diff --git a/src/node/updater/updater.ml b/src/node/updater/updater.ml index c7a7e2167..32a5971fd 100644 --- a/src/node/updater/updater.ml +++ b/src/node/updater/updater.ml @@ -131,7 +131,7 @@ let get_basedir () = let init dir = basedir := Some dir -type component = { +type component = Store.component = { name : string ; interface : string option ; implementation : string ; diff --git a/src/proto/environment/persist.mli b/src/proto/environment/persist.mli index 25657f2c8..e7fc1d792 100644 --- a/src/proto/environment/persist.mli +++ b/src/proto/environment/persist.mli @@ -18,6 +18,8 @@ module type 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 (** Projection of OCaml keys of some abstract type to concrete storage @@ -57,6 +59,8 @@ 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 module MakeBytesStore (S : STORE) (K : KEY) : @@ -73,6 +77,8 @@ 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 (** Gives a typed view of a store (values of a given type stored under From ec79241adb2ff8e6f617c0ff0d95b7f827747dd6 Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Mon, 24 Oct 2016 14:10:17 +0200 Subject: [PATCH 3/8] reject invalid protocols --- src/node/shell/node.ml | 11 ++++++++--- src/node/updater/updater.mli | 2 +- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index 67291fac5..49872995c 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -25,11 +25,16 @@ let inject_operation validator ?force bytes = Lwt.return (hash, t) let inject_protocol state ?force:_ proto = - (* TODO: Validate the protocol *) let proto_bytes = Store.Protocol.to_bytes proto in let hash = Protocol_hash.hash_bytes [proto_bytes] in - let t = State.Protocol.store state proto_bytes >>|? ignore in - Lwt.return (hash, t) + let validation = Updater.compile hash proto >>= function + | false -> Lwt.fail_with (Format.asprintf "Invalid protocol %a: compilation failed" Protocol_hash.pp_short hash) + | true -> + State.Protocol.store state proto_bytes >>= function + | Ok None -> Lwt.fail_with "Previously registred protocol" + | t -> t >|? ignore |> Lwt.return + in + Lwt.return (hash, validation) let process_operation state validator bytes = State.Operation.store state bytes >>= function diff --git a/src/node/updater/updater.mli b/src/node/updater/updater.mli index 05f90454e..e82447228 100644 --- a/src/node/updater/updater.mli +++ b/src/node/updater/updater.mli @@ -70,7 +70,7 @@ module type REGISTRED_PROTOCOL = sig and type 'a tzresult := 'a tzresult end -type component = { +type component = Store.component = { name : string ; interface : string option ; implementation : string ; From f3b7299662c10e0a4ed9f542de438289d39e74b9 Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Mon, 24 Oct 2016 15:39:53 +0200 Subject: [PATCH 4/8] tezos-compiler: better arguments, add doc --- src/Makefile | 4 ++-- src/compiler/tezos_compiler.ml | 23 ++++++++++------------- 2 files changed, 12 insertions(+), 15 deletions(-) diff --git a/src/Makefile b/src/Makefile index 5425b524f..b9254edb7 100644 --- a/src/Makefile +++ b/src/Makefile @@ -315,7 +315,7 @@ proto/embedded_proto_%.cmxa: \ proto/%/TEZOS_PROTOCOL \ $$(wildcard proto/%/*.ml) \ $$(wildcard proto/%/*.mli) - @${TZCOMPILER} --build-dir proto/$*/_tzbuild $@ proto/$*/ + @${TZCOMPILER} -static -build-dir proto/$*/_tzbuild $@ proto/$*/ CLIENT_PROTO_INCLUDES := \ utils node/updater node/db node/net node/shell client \ @@ -328,7 +328,7 @@ proto/client_embedded_proto_%.cmxa: \ proto/%/TEZOS_PROTOCOL \ $$(wildcard proto/%/*.ml) \ $$(wildcard proto/%/*.mli) - @./${TZCOMPILER} --client --build-dir client/embedded/$*/_tzbuild \ + @./${TZCOMPILER} -static -client -build-dir client/embedded/$*/_tzbuild \ $(addprefix -I , ${CLIENT_PROTO_INCLUDES}) \ $@ proto/$* diff --git a/src/compiler/tezos_compiler.ml b/src/compiler/tezos_compiler.ml index 5ea8eb1ff..4b533f6e0 100644 --- a/src/compiler/tezos_compiler.ml +++ b/src/compiler/tezos_compiler.ml @@ -36,11 +36,6 @@ module Backend = struct end let backend = (module Backend : Backend_intf.S) -let usage () = - Printf.eprintf - "Usage: %s output.cmxs source_dir [--in-place]\n%!" - Sys.argv.(0) - let warnings = "+a-4-6-7-9-29-40..42-44-45-48" let warn_error = "-a" @@ -215,11 +210,11 @@ let pack_objects ?(ctxt = "") ?(keep_object = false) output objects = if not keep_object then at_exit (fun () -> unlink_object output) ; Warnings.check_fatal () -let link_shared output objects = +let link_shared ?(static=false) output objects = Printf.printf "LINK %s\n%!" (Filename.basename output); Compenv.(readenv Format.err_formatter Before_link); Compmisc.init_path true; - if Filename.check_suffix output ".cmxa" then + if static then Asmlibrarian.create_archive objects output else Asmlink.link_shared Format.err_formatter objects output; @@ -283,12 +278,14 @@ let main () = and client = ref false and build_dir = ref None and include_dirs = ref [] in + let static = ref false in let args_spec = [ - "--client", Arg.Set client, "TODO" ; - "-I", Arg.String (fun s -> include_dirs := s :: !include_dirs), "TODO" ; - "--build-dir", Arg.String (fun s -> build_dir := Some s), "TODO"] in - let usage_msg = "TODO" in - Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) "TODO" ; + "-static", Arg.Set static, " Build a library (.cmxa)"; + "-client", Arg.Set client, " Preserve type equality with concrete node environment (used to embed protocol into the client)" ; + "-I", Arg.String (fun s -> include_dirs := s :: !include_dirs), "path Path for concrete node signatures (used to embed protocol into the client)" ; + "-build-dir", Arg.String (fun s -> build_dir := Some s), "path Reuse build dir (incremental compilation)"] in + let usage_msg = Printf.sprintf "Usage: %s \nOptions are:" Sys.argv.(0) in + Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) usage_msg ; let client = !client and include_dirs = !include_dirs in let output, source_dir = @@ -439,4 +436,4 @@ let main () = (* Create the final [cmxs] *) Clflags.link_everything := true ; - link_shared output [packed_objects; register_object] + link_shared ~static:!static output [packed_objects; register_object] From 4fa77b12785e591a6f463af40d5f6f3adb653968 Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Mon, 24 Oct 2016 19:12:57 +0200 Subject: [PATCH 5/8] + Utils.{finalize,read_file,write_file} --- src/utils/utils.ml | 20 ++++++++++++++++++++ src/utils/utils.mli | 3 +++ 2 files changed, 23 insertions(+) diff --git a/src/utils/utils.ml b/src/utils/utils.ml index ef2fe1f48..60988ac6e 100644 --- a/src/utils/utils.ml +++ b/src/utils/utils.ml @@ -121,3 +121,23 @@ let rec remove_elem_from_list nb = function | [] -> [] | l when nb <= 0 -> l | _ :: tl -> remove_elem_from_list (nb - 1) tl + +let finalize f g = try let res = f () in g (); res with exn -> g (); raise exn + +let read_file ?(bin=false) fn = + let ic = (if bin then open_in_bin else open_in) fn in + finalize (fun () -> + let len = in_channel_length ic in + let buf = Bytes.create len in + let nb_read = input ic buf 0 len in + if nb_read <> len then failwith (Printf.sprintf "read_file: read %d, expected %d" nb_read len) + else Bytes.unsafe_to_string buf) + (fun () -> close_in ic) + +let write_file ?(bin=false) fn contents = + let oc = (if bin then open_out_bin else open_out) fn in + finalize (fun () -> + let contents = Bytes.unsafe_of_string contents in + output oc contents 0 @@ Bytes.length contents + ) + (fun () -> close_out oc) diff --git a/src/utils/utils.mli b/src/utils/utils.mli index a027b783f..7cff8939d 100644 --- a/src/utils/utils.mli +++ b/src/utils/utils.mli @@ -38,3 +38,6 @@ val remove_elem_from_list: int -> 'a list -> 'a list val filter_map: ('a -> 'b option) -> 'a list -> 'b list +val finalize: (unit -> 'a) -> (unit -> unit) -> 'a +val read_file: ?bin:bool -> string -> string +val write_file: ?bin:bool -> string -> string -> unit From ccf6ed4a9d775caaae14a64b96a540085e29574e Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Mon, 24 Oct 2016 19:14:56 +0200 Subject: [PATCH 6/8] TEZOS_PROTOCOL: use json syntax --- src/proto/bootstrap/TEZOS_PROTOCOL | 99 +++++++++++++++--------------- src/proto/demo/TEZOS_PROTOCOL | 10 ++- 2 files changed, 53 insertions(+), 56 deletions(-) diff --git a/src/proto/bootstrap/TEZOS_PROTOCOL b/src/proto/bootstrap/TEZOS_PROTOCOL index 00f61d8d1..50b9fca67 100644 --- a/src/proto/bootstrap/TEZOS_PROTOCOL +++ b/src/proto/bootstrap/TEZOS_PROTOCOL @@ -1,57 +1,56 @@ -hash = "TnrnfGHMCPAcxtMAHXdpfebbnn2XvPAxq7DHbpeJbKTkJQPgcgRGr" -modules = [ +{ + "hash": "TnrnfGHMCPAcxtMAHXdpfebbnn2XvPAxq7DHbpeJbKTkJQPgcgRGr", + "modules": [ + "Misc", + "Tezos_hash", + "Qty_repr", + "Tez_repr", + "Period_repr", + "Time_repr", + "Constants_repr", + "Fitness_repr", + "Raw_level_repr", + "Voting_period_repr", + "Cycle_repr", + "Level_repr", + "Seed_repr", + "Script_int_repr", + "Script_repr", + "Contract_repr", + "Roll_repr", + "Asset_repr", + "Vote_repr", + "Operation_repr", + "Block_repr", - Misc ; - Tezos_hash ; + "Storage_sigs", + "Storage_functors", + "Storage", - Qty_repr ; - Tez_repr ; - Period_repr ; - Time_repr ; - Constants_repr ; - Fitness_repr ; - Raw_level_repr ; - Voting_period_repr ; - Cycle_repr ; - Level_repr ; - Seed_repr ; - Script_int_repr ; - Script_repr ; - Contract_repr ; - Roll_repr ; - Asset_repr ; - Vote_repr ; - Operation_repr ; - Block_repr ; + "Level_storage", + "Nonce_storage", + "Seed_storage", + "Roll_storage", + "Contract_storage", + "Reward_storage", + "Bootstrap_storage", + "Fitness_storage", + "Vote_storage", + "Init_storage", - Storage_sigs ; - Storage_functors ; - Storage ; + "Tezos_context", - Level_storage ; - Nonce_storage ; - Seed_storage ; - Roll_storage ; - Contract_storage ; - Reward_storage ; - Bootstrap_storage ; - Fitness_storage ; - Vote_storage ; - Init_storage ; + "Script_typed_ir", + "Script_ir_translator", + "Script_interpreter", - Tezos_context ; + "Mining", + "Amendment", + "Apply", - Script_typed_ir ; - Script_ir_translator ; - Script_interpreter ; + "Services", + "Services_registration", - Mining ; - Amendment ; - Apply ; - - Services ; - Services_registration ; - - Main ; - -] + "Main" + ] +} diff --git a/src/proto/demo/TEZOS_PROTOCOL b/src/proto/demo/TEZOS_PROTOCOL index 49898d3d5..ab9f2dec6 100644 --- a/src/proto/demo/TEZOS_PROTOCOL +++ b/src/proto/demo/TEZOS_PROTOCOL @@ -1,6 +1,4 @@ -hash = "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee" -modules = [ - Error ; - Services ; - Main ; -] +{ + "hash": "JF7Fxgeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee", + "modules": ["Error", "Services", "Main"] +} From 0af5f6e7c3ae42327f819b222afc818b8c62ea77 Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Mon, 24 Oct 2016 19:15:35 +0200 Subject: [PATCH 7/8] tezos_compiler: changes * Read TEZOS_PROTOCOL in json format * Define Protocol module here * Fix dependent modules to use Protocol defined here * Compute hash of protocol if absent in TEZOS_PROTOCOL --- src/compiler/tezos_compiler.ml | 91 ++++++++++++++++------------- src/compiler/tezos_compiler.mli | 20 +++++-- src/node/db/store.ml | 30 ++-------- src/node/db/store.mli | 19 ++---- src/node/shell/node_rpc_services.ml | 4 +- src/node/shell/state.ml | 2 +- src/node/shell/state.mli | 4 +- src/node/updater/updater.ml | 4 +- src/node/updater/updater.mli | 2 +- 9 files changed, 87 insertions(+), 89 deletions(-) diff --git a/src/compiler/tezos_compiler.ml b/src/compiler/tezos_compiler.ml index 4b533f6e0..cb8b99d01 100644 --- a/src/compiler/tezos_compiler.ml +++ b/src/compiler/tezos_compiler.ml @@ -104,48 +104,48 @@ let unlink_object obj = (** TEZOS_PROTOCOL files *) +module Protocol = struct + type component = { + name: string; + interface: string option; + implementation: string; + } + + let component_encoding = + let open Data_encoding in + conv + (fun { name ; interface; implementation } -> (name, interface, implementation)) + (fun (name, interface, implementation) -> { name ; interface ; implementation }) + (obj3 + (req "name" string) + (opt "interface" string) + (req "implementation" string)) + + type t = component list + let encoding = Data_encoding.list component_encoding + + let to_bytes v = Data_encoding.Binary.to_bytes encoding v + let of_bytes b = Data_encoding.Binary.of_bytes encoding b + let hash proto = Protocol_hash.hash_bytes [to_bytes proto] +end + module Meta = struct + let config_file_encoding = + let open Data_encoding in + obj2 + (opt "hash" ~description:"Used to force the hash of the protocol" Protocol_hash.encoding) + (req "modules" ~description:"Modules comprising the protocol" (list string)) - let hash_wrapper = - let open Config_file in - { to_raw = (fun h -> Raw.String (Protocol_hash.to_b48check h)); - of_raw = (function - | Raw.String h -> begin try - Protocol_hash.of_b48check h - with _ -> - let error oc = Printf.fprintf oc "Invalid Base48Check-encoded SHA256 key %S" h in - raise (Wrong_type error) - end - | _ -> - let error oc = - Printf.fprintf oc "Unexcepted value: should be a Base48Check-encoded SHA256 key." in - raise (Wrong_type error)); - } - - class protocol_hash_cp = - [Protocol_hash.t] Config_file.cp_custom_type hash_wrapper - - let to_file file hash modules = - let group = new Config_file.group in - let _ = new protocol_hash_cp ~group ["hash"] hash "" in - let _ = - new Config_file.list_cp Config_file.string_wrappers ~group - ["modules"] modules "" in - group#write file - - let of_file file = - let group = new Config_file.group in - let hash = - new protocol_hash_cp ~group ["hash"] - (Protocol_hash.of_b48check - "TnrnfGHMCPAcxtMAHXdpfebbnn2XvPAxq7DHbpeJbKTkJQPgcgRGr") - "" in - let modules = - new Config_file.list_cp Config_file.string_wrappers ~group - ["modules"] [] "" in - group#read file; - (hash#get, modules#get) + let to_file fn ?hash modules = + let open Data_encoding.Json in + let config_file = construct config_file_encoding (hash, modules) in + Utils.write_file ~bin:false fn @@ to_string config_file + let of_file fn = + let open Data_encoding.Json in + Utils.read_file ~bin:false fn |> from_string |> function + | Error err -> Pervasives.failwith err + | Ok json -> destruct config_file_encoding json end (** Semi-generic compilation functions *) @@ -269,6 +269,15 @@ let mktemp_dir () = Filename.get_temp_dir_name () // Printf.sprintf "tezos-protocol-build-%06X" (Random.int 0xFFFFFF) +let create_component dirname name = + let name_lowercase = String.uncapitalize_ascii name in + let implementation = dirname // name_lowercase ^ ".ml" in + let interface = implementation ^ "i" in + match Sys.file_exists implementation, Sys.file_exists interface with + | false, _ -> Pervasives.failwith ("No such file " ^ implementation) + | true, false -> { Protocol.name; interface = None; implementation } + | _ -> { name; interface = Some interface; implementation } + let main () = Random.self_init () ; @@ -310,6 +319,10 @@ let main () = if not keep_object then Unix.rmdir build_dir ) ; let hash, units = Meta.of_file (source_dir // "TEZOS_PROTOCOL") in + let hash = match hash with + | Some hash -> hash + | None -> Protocol.hash @@ List.map (create_component source_dir) units + in let packname = if keep_object then String.capitalize_ascii (Filename.(basename @@ chop_extension output)) diff --git a/src/compiler/tezos_compiler.mli b/src/compiler/tezos_compiler.mli index e2548ac2f..1dd2703aa 100644 --- a/src/compiler/tezos_compiler.mli +++ b/src/compiler/tezos_compiler.mli @@ -9,11 +9,23 @@ (** Low-level part of the [Updater]. *) +module Protocol : sig + type component = { + name : string; + interface : string option; + implementation : string; + } + val component_encoding : component Data_encoding.encoding + type t = component list + val encoding : component list Data_encoding.encoding + val to_bytes : component list -> MBytes.t + val of_bytes : MBytes.t -> component list option + val hash : component list -> Hash.Protocol_hash.t +end + module Meta : sig - - val to_file: string -> Protocol_hash.t -> string list -> unit - val of_file: string -> Protocol_hash.t * string list - + val to_file: string -> ?hash:Protocol_hash.t -> string list -> unit + val of_file: string -> Protocol_hash.t option * string list end val main: unit -> unit diff --git a/src/node/db/store.ml b/src/node/db/store.ml index 2447b001a..3673ecb6f 100644 --- a/src/node/db/store.ml +++ b/src/node/db/store.ml @@ -508,30 +508,10 @@ end (*-- Typed operation store under "protocols/" -------------------------------*) -type component = { - name : string ; - interface : string option ; - implementation : string ; -} +type protocol = Tezos_compiler.Protocol.t +let protocol_encoding = Tezos_compiler.Protocol.encoding -let component_encoding = - let open Data_encoding in - conv - (fun { name ; interface; implementation } -> (name, interface, implementation)) - (fun (name, interface, implementation) -> { name ; interface ; implementation }) - (obj3 - (req "name" string) - (opt "interface" string) - (req "implementation" string)) - -type protocol = component list -let protocol_encoding = Data_encoding.list component_encoding - -module Raw_protocol_value = struct - type t = protocol - let to_bytes v = Data_encoding.Binary.to_bytes protocol_encoding v - let of_bytes b = Data_encoding.Binary.of_bytes protocol_encoding b -end +module Raw_protocol_value = Tezos_compiler.Protocol module Raw_protocol_key = struct type t = Protocol_hash.t @@ -556,7 +536,7 @@ module Protocol_errors = Make (Protocol_errors_key) (Errors_value) module Protocol = struct type t = FS.t type key = Protocol_hash.t - type value = protocol tzresult Time.timed_data + type value = Tezos_compiler.Protocol.t tzresult Time.timed_data let mem = Protocol_data.mem let get s k = Protocol_time.get s k >>= function @@ -587,7 +567,7 @@ module Protocol = struct Protocol_errors.del s k let of_bytes = Raw_protocol_value.of_bytes let to_bytes = Raw_protocol_value.to_bytes - let hash proto = Protocol_hash.hash_bytes [to_bytes proto] + let hash = Raw_protocol_value.hash let compare p1 p2 = Protocol_hash.(compare (hash_bytes [to_bytes p1]) (hash_bytes [to_bytes p2])) let equal b1 b2 = compare b1 b2 = 0 diff --git a/src/node/db/store.mli b/src/node/db/store.mli index 8bbc1ebf7..6a311bf43 100644 --- a/src/node/db/store.mli +++ b/src/node/db/store.mli @@ -113,15 +113,8 @@ type block = { val shell_block_encoding: shell_block Data_encoding.t val block_encoding: block Data_encoding.t -(** Protocol *) -type component = { - name : string ; - interface : string option ; - implementation : string ; -} - -type protocol = component list -val protocol_encoding : protocol Data_encoding.t +type protocol = Tezos_compiler.Protocol.t +val protocol_encoding: protocol Data_encoding.t (** {2 Block and operations store} ********************************************) @@ -194,14 +187,14 @@ module Operation : sig end module Protocol : sig - val of_bytes: MBytes.t -> protocol option - val to_bytes: protocol -> MBytes.t - val hash: protocol -> Protocol_hash.t + val of_bytes: MBytes.t -> Tezos_compiler.Protocol.t option + val to_bytes: Tezos_compiler.Protocol.t -> MBytes.t + val hash: Tezos_compiler.Protocol.t -> Protocol_hash.t include TYPED_IMPERATIVE_STORE with type t = protocol_store and type key = Protocol_hash.t - and type value = protocol tzresult Time.timed_data + and type value = Tezos_compiler.Protocol.t tzresult Time.timed_data val raw_get: t -> Protocol_hash.t -> MBytes.t option Lwt.t end diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index 4b85cd97e..b4d3332e4 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -548,10 +548,10 @@ let inject_protocol = in let proto_of_rpc = List.map (fun (name, interface, implementation) -> - { Store.name; interface; implementation }) + { Tezos_compiler.Protocol.name; interface; implementation }) in let rpc_of_proto = - List.map (fun { Store.name; interface; implementation } -> + List.map (fun { Tezos_compiler.Protocol.name; interface; implementation } -> (name, interface, implementation)) in RPC.service diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml index 3fb1853dd..2a11aa2a2 100644 --- a/src/node/shell/state.ml +++ b/src/node/shell/state.ml @@ -251,7 +251,7 @@ end module Protocol = struct type key = Store.Protocol.key - type component = Store.component = { + type component = Tezos_compiler.Protocol.component = { name: string; interface: string option; implementation: string diff --git a/src/node/shell/state.mli b/src/node/shell/state.mli index 7ea0dfdda..39b282737 100644 --- a/src/node/shell/state.mli +++ b/src/node/shell/state.mli @@ -350,13 +350,13 @@ module Protocol : sig type key = Protocol_hash.t - type component = Store.component = { + type component = Tezos_compiler.Protocol.component = { name : string ; interface : string option ; implementation : string ; } - type t = Store.protocol + type t = Tezos_compiler.Protocol.t type protocol = t diff --git a/src/node/updater/updater.ml b/src/node/updater/updater.ml index 32a5971fd..865323b54 100644 --- a/src/node/updater/updater.ml +++ b/src/node/updater/updater.ml @@ -131,7 +131,7 @@ let get_basedir () = let init dir = basedir := Some dir -type component = Store.component = { +type component = Tezos_compiler.Protocol.component = { name : string ; interface : string option ; implementation : string ; @@ -164,7 +164,7 @@ let do_compile hash units = create_files source_dir units >>= fun _files -> Tezos_compiler.Meta.to_file (source_dir // "TEZOS") - hash + ~hash (List.map (fun {name} -> String.capitalize_ascii name) units); let compiler_command = (Sys.executable_name, diff --git a/src/node/updater/updater.mli b/src/node/updater/updater.mli index e82447228..1afa0ae4b 100644 --- a/src/node/updater/updater.mli +++ b/src/node/updater/updater.mli @@ -70,7 +70,7 @@ module type REGISTRED_PROTOCOL = sig and type 'a tzresult := 'a tzresult end -type component = Store.component = { +type component = Tezos_compiler.Protocol.component = { name : string ; interface : string option ; implementation : string ; From 7a1712756f6c91c4f27de1b30d7e1eeb435ed2b0 Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Tue, 25 Oct 2016 19:00:03 +0200 Subject: [PATCH 8/8] add protocol client commands --- src/Makefile | 4 +- src/client/client_node_rpcs.ml | 7 ++++ src/client/client_node_rpcs.mli | 11 +++++- src/client/client_protocols.ml | 52 ++++++++++++++++++++++++++ src/client/client_protocols.mli | 2 + src/client_main.ml | 1 + src/compiler/tezos_compiler.ml | 66 +++++++++++++++++++-------------- src/compiler/tezos_compiler.mli | 22 ++++++----- src/node/updater/updater.ml | 27 ++++++++------ src/node/updater/updater.mli | 1 + 10 files changed, 143 insertions(+), 50 deletions(-) create mode 100644 src/client/client_protocols.ml create mode 100644 src/client/client_protocols.mli diff --git a/src/Makefile b/src/Makefile index b9254edb7..2f7e838d7 100644 --- a/src/Makefile +++ b/src/Makefile @@ -348,6 +348,7 @@ CLIENT_LIB_INTFS := \ client/client_generic_rpcs.mli \ client/client_aliases.mli \ client/client_keys.mli \ + client/client_protocols.mli \ CLIENT_LIB_IMPLS := \ client/client_version.ml \ @@ -356,6 +357,7 @@ CLIENT_LIB_IMPLS := \ client/client_generic_rpcs.ml \ client/client_aliases.ml \ client/client_keys.ml \ + client/client_protocols.ml \ CLIENT_IMPLS := \ client_main.ml @@ -378,7 +380,7 @@ CLIENT_OBJS := \ ${CLIENT_LIB_INTFS:.mli=.cmi} ${CLIENT_LIB_INTFS:.mli=.mli.deps} \ ${TZCLIENT} ${CLIENT_OBJS}: PACKAGES=${CLIENT_PACKAGES} -${CLIENT_OBJS}: SOURCE_DIRECTORIES=client client/embedded utils node/net node/shell node/updater node/db +${CLIENT_OBJS}: SOURCE_DIRECTORIES=client client/embedded utils node/net node/shell node/updater node/db compiler ${CLIENT_OBJS}: TARGET="(client.cmxa)" ${CLIENT_OBJS}: OPENED_MODULES=Error_monad Hash Utils diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index 8197325af..889bc8f31 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -211,3 +211,10 @@ module Operations = struct call_streamed_service0 Services.Operations.list { monitor = Some true ; contents } end + +module Protocols = struct + let bytes hash = + call_service1 Services.Protocols.bytes hash () + let list ?contents () = + call_service0 Services.Protocols.list { contents; monitor = Some false } +end diff --git a/src/client/client_node_rpcs.mli b/src/client/client_node_rpcs.mli index 3fa2349cc..1a1e9605f 100644 --- a/src/client/client_node_rpcs.mli +++ b/src/client/client_node_rpcs.mli @@ -26,7 +26,7 @@ val inject_block: val inject_operation: ?wait:bool -> ?force:bool -> MBytes.t -> Operation_hash.t tzresult Lwt.t val inject_protocol: - ?wait:bool -> ?force:bool -> Store.protocol -> Protocol_hash.t tzresult Lwt.t + ?wait:bool -> ?force:bool -> Tezos_compiler.Protocol.t -> Protocol_hash.t tzresult Lwt.t module Blocks : sig @@ -95,6 +95,15 @@ module Operations : sig (Operation_hash.t * Store.operation option) list Lwt_stream.t Lwt.t end +module Protocols : sig + val bytes: + Protocol_hash.t -> Store.protocol tzresult Time.timed_data Lwt.t + + val list: + ?contents:bool -> unit -> + (Protocol_hash.t * Store.protocol option) list Lwt.t +end + val describe: ?recurse:bool -> string list -> RPC.Description.directory_descr Lwt.t (** Low-level *) diff --git a/src/client/client_protocols.ml b/src/client/client_protocols.ml new file mode 100644 index 000000000..b8a1213ff --- /dev/null +++ b/src/client/client_protocols.ml @@ -0,0 +1,52 @@ +let commands () = + let open Cli_entries in + let check_dir dn = + if Sys.is_directory dn then Lwt.return dn else Lwt.fail_invalid_arg "not a directory" + in + let check_hash ph = Lwt.wrap1 Protocol_hash.of_b48check ph in + register_group "protocols" "Commands for managing protocols" ; + [ + command + ~group: "protocols" + ~desc: "list known protocols" + (prefixes [ "list" ; "protocols" ] stop) + (fun () -> + Client_node_rpcs.Protocols.list ~contents:false () >|= fun protos -> + List.iter (fun (ph, _p) -> message "%a" Protocol_hash.pp ph) protos + ); + command + ~group: "protocols" + ~desc: "inject a new protocol to the shell database" + (prefixes [ "inject" ; "protocol" ] + @@ param ~name:"directory containing a protocol" ~desc:"" check_dir + @@ stop) + (fun dirname () -> + Lwt.catch + (fun () -> + let proto = Tezos_compiler.Protocol.of_dir dirname in + Client_node_rpcs.inject_protocol proto >>= function + | Ok hash -> + message "Injected protocol %a successfully" Protocol_hash.pp_short hash; + Lwt.return (); + | Error err -> + error "Error while injecting protocol from %s: %a" + dirname Error_monad.pp_print_error err) + (fun exn -> + error "Error while injecting protocol from %s: %a" + dirname Error_monad.pp_print_error [Error_monad.Exn exn]) + ); + command + ~group: "protocols" + ~desc: "dump a protocol from the shell database" + (prefixes [ "dump" ; "protocol" ] + @@ param ~name:"protocol hash" ~desc:"" check_hash + @@ stop) + (fun ph () -> + Client_node_rpcs.Protocols.bytes ph >>= fun { data } -> match data with + | Ok proto -> + Updater.extract "" ph proto >|= fun () -> + message "Extracted protocol %a" Protocol_hash.pp_short ph + | Error err -> + error "Error while dumping protocol %a: %a" + Protocol_hash.pp_short ph Error_monad.pp_print_error err); + ] diff --git a/src/client/client_protocols.mli b/src/client/client_protocols.mli new file mode 100644 index 000000000..1b6371300 --- /dev/null +++ b/src/client/client_protocols.mli @@ -0,0 +1,2 @@ + +val commands: unit -> Cli_entries.command list diff --git a/src/client_main.ml b/src/client_main.ml index b907ce0e3..416f10abd 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -30,6 +30,7 @@ let main () = let commands = Client_generic_rpcs.commands @ Client_keys.commands () @ + Client_protocols.commands () @ Client_version.commands_for_version version in Client_config.parse_args ~version (Cli_entries.usage commands) diff --git a/src/compiler/tezos_compiler.ml b/src/compiler/tezos_compiler.ml index cb8b99d01..8211165ae 100644 --- a/src/compiler/tezos_compiler.ml +++ b/src/compiler/tezos_compiler.ml @@ -104,6 +104,26 @@ let unlink_object obj = (** TEZOS_PROTOCOL files *) +module Meta = struct + let name = "TEZOS_PROTOCOL" + let config_file_encoding = + let open Data_encoding in + obj2 + (opt "hash" ~description:"Used to force the hash of the protocol" Protocol_hash.encoding) + (req "modules" ~description:"Modules comprising the protocol" (list string)) + + let to_file dirname ?hash modules = + let open Data_encoding.Json in + let config_file = construct config_file_encoding (hash, modules) in + Utils.write_file ~bin:false (dirname // name) @@ to_string config_file + + let of_file dirname = + let open Data_encoding.Json in + Utils.read_file ~bin:false (dirname // name) |> from_string |> function + | Error err -> Pervasives.failwith err + | Ok json -> destruct config_file_encoding json +end + module Protocol = struct type component = { name: string; @@ -127,25 +147,24 @@ module Protocol = struct let to_bytes v = Data_encoding.Binary.to_bytes encoding v let of_bytes b = Data_encoding.Binary.of_bytes encoding b let hash proto = Protocol_hash.hash_bytes [to_bytes proto] -end -module Meta = struct - let config_file_encoding = - let open Data_encoding in - obj2 - (opt "hash" ~description:"Used to force the hash of the protocol" Protocol_hash.encoding) - (req "modules" ~description:"Modules comprising the protocol" (list string)) + let find_component dirname module_name = + let name_lowercase = String.uncapitalize_ascii module_name in + let implementation = dirname // name_lowercase ^ ".ml" in + let interface = implementation ^ "i" in + match Sys.file_exists implementation, Sys.file_exists interface with + | false, _ -> Pervasives.failwith @@ "Not such file: " ^ implementation + | true, false -> + let implementation = Utils.read_file ~bin:false implementation in + { name = module_name; interface = None; implementation } + | _ -> + let interface = Utils.read_file ~bin:false interface in + let implementation = Utils.read_file ~bin:false implementation in + { name = module_name; interface = Some interface; implementation } - let to_file fn ?hash modules = - let open Data_encoding.Json in - let config_file = construct config_file_encoding (hash, modules) in - Utils.write_file ~bin:false fn @@ to_string config_file - - let of_file fn = - let open Data_encoding.Json in - Utils.read_file ~bin:false fn |> from_string |> function - | Error err -> Pervasives.failwith err - | Ok json -> destruct config_file_encoding json + let of_dir dirname = + let _hash, modules = Meta.of_file dirname in + List.map (find_component dirname) modules end (** Semi-generic compilation functions *) @@ -269,15 +288,6 @@ let mktemp_dir () = Filename.get_temp_dir_name () // Printf.sprintf "tezos-protocol-build-%06X" (Random.int 0xFFFFFF) -let create_component dirname name = - let name_lowercase = String.uncapitalize_ascii name in - let implementation = dirname // name_lowercase ^ ".ml" in - let interface = implementation ^ "i" in - match Sys.file_exists implementation, Sys.file_exists interface with - | false, _ -> Pervasives.failwith ("No such file " ^ implementation) - | true, false -> { Protocol.name; interface = None; implementation } - | _ -> { name; interface = Some interface; implementation } - let main () = Random.self_init () ; @@ -318,10 +328,10 @@ let main () = Unix.rmdir sigs_dir ; if not keep_object then Unix.rmdir build_dir ) ; - let hash, units = Meta.of_file (source_dir // "TEZOS_PROTOCOL") in + let hash, units = Meta.of_file source_dir in let hash = match hash with | Some hash -> hash - | None -> Protocol.hash @@ List.map (create_component source_dir) units + | None -> Protocol.hash @@ List.map (Protocol.find_component source_dir) units in let packname = if keep_object then diff --git a/src/compiler/tezos_compiler.mli b/src/compiler/tezos_compiler.mli index 1dd2703aa..7b783c7da 100644 --- a/src/compiler/tezos_compiler.mli +++ b/src/compiler/tezos_compiler.mli @@ -9,23 +9,27 @@ (** Low-level part of the [Updater]. *) +module Meta : sig + val to_file: Lwt_io.file_name -> ?hash:Protocol_hash.t -> string list -> unit + val of_file: Lwt_io.file_name -> Protocol_hash.t option * string list +end + module Protocol : sig type component = { name : string; interface : string option; implementation : string; } + val find_component : Lwt_io.file_name -> string -> component val component_encoding : component Data_encoding.encoding - type t = component list - val encoding : component list Data_encoding.encoding - val to_bytes : component list -> MBytes.t - val of_bytes : MBytes.t -> component list option - val hash : component list -> Hash.Protocol_hash.t -end -module Meta : sig - val to_file: string -> ?hash:Protocol_hash.t -> string list -> unit - val of_file: string -> Protocol_hash.t option * string list + type t = component list + val encoding : t Data_encoding.encoding + val to_bytes : t -> MBytes.t + val of_bytes : MBytes.t -> t option + val hash : t -> Hash.Protocol_hash.t + + val of_dir : Lwt_io.file_name -> t end val main: unit -> unit diff --git a/src/node/updater/updater.ml b/src/node/updater/updater.ml index 865323b54..e9b0af49c 100644 --- a/src/node/updater/updater.ml +++ b/src/node/updater/updater.ml @@ -141,11 +141,12 @@ let create_files dir units = Utils.remove_dir dir >>= fun () -> Utils.create_dir dir >>= fun () -> Lwt_list.map_s - (fun unit -> - let ml = dir // (unit.name ^ ".ml") in - let mli = dir // (unit.name ^ ".mli") in - Utils.create_file ml unit.implementation >>= fun () -> - match unit.interface with + (fun { name; interface; implementation } -> + let name = String.lowercase_ascii name in + let ml = dir // (name ^ ".ml") in + let mli = dir // (name ^ ".mli") in + Utils.create_file ml implementation >>= fun () -> + match interface with | None -> Lwt.return [ml] | Some content -> Utils.create_file mli content >>= fun () -> @@ -154,17 +155,21 @@ let create_files dir units = let files = List.concat files in Lwt.return files +let extract dirname hash units = + let source_dir = dirname // Protocol_hash.to_short_b48check hash // "src" in + create_files source_dir units >|= fun _files -> + Tezos_compiler.Meta.to_file source_dir ~hash + (List.map (fun {name} -> String.capitalize_ascii name) units) + let do_compile hash units = let basedir = get_basedir () in let source_dir = basedir // Protocol_hash.to_short_b48check hash // "src" in let log_file = basedir // Protocol_hash.to_short_b48check hash // "LOG" in - let plugin_file = - basedir // Protocol_hash.to_b48check hash - // Format.asprintf "protocol_%a.cmxs" Protocol_hash.pp hash in + let plugin_file = basedir // Protocol_hash.to_short_b48check hash // + Format.asprintf "protocol_%a.cmxs" Protocol_hash.pp hash + in create_files source_dir units >>= fun _files -> - Tezos_compiler.Meta.to_file - (source_dir // "TEZOS") - ~hash + Tezos_compiler.Meta.to_file source_dir ~hash (List.map (fun {name} -> String.capitalize_ascii name) units); let compiler_command = (Sys.executable_name, diff --git a/src/node/updater/updater.mli b/src/node/updater/updater.mli index 1afa0ae4b..09bd44185 100644 --- a/src/node/updater/updater.mli +++ b/src/node/updater/updater.mli @@ -76,6 +76,7 @@ type component = Tezos_compiler.Protocol.component = { implementation : string ; } +val extract: Lwt_io.file_name -> Protocol_hash.t -> component list -> unit Lwt.t val compile: Protocol_hash.t -> component list -> bool Lwt.t val activate: Context.t -> Protocol_hash.t -> Context.t Lwt.t