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