add protocol client commands

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
 

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

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

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

src/client/client_protocols.mli

@@ -0,0 +1,2 @@
+
+val commands: unit -> Cli_entries.command list

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)

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 find_component dirname module_name =
-  let config_file_encoding =
+    let name_lowercase = String.uncapitalize_ascii module_name in
-    let open Data_encoding in
+    let implementation = dirname // name_lowercase ^ ".ml" in
-    obj2
+    let interface = implementation ^ "i" in
-      (opt "hash" ~description:"Used to force the hash of the protocol" Protocol_hash.encoding)
+    match Sys.file_exists implementation, Sys.file_exists interface with
-      (req "modules" ~description:"Modules comprising the protocol" (list string))
+    | 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 of_dir dirname =
-    let open Data_encoding.Json in
+    let _hash, modules = Meta.of_file dirname in
-    let config_file = construct config_file_encoding (hash, modules) in
+    List.map (find_component dirname) modules
-    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,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

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
+  type t = component list
-  val to_file: string -> ?hash:Protocol_hash.t -> string list -> unit
+  val encoding : t Data_encoding.encoding
-  val of_file: string -> Protocol_hash.t option * string list
+  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

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 ->
+    (fun { name; interface; implementation } ->
-       let ml = dir // (unit.name ^ ".ml") in
+       let name = String.lowercase_ascii name in
-       let mli = dir // (unit.name ^ ".mli") in
+       let ml = dir // (name ^ ".ml") in
-       Utils.create_file ml unit.implementation >>= fun () ->
+       let mli = dir // (name ^ ".mli") in
-       match unit.interface with
+       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 =
+  let plugin_file = basedir // Protocol_hash.to_short_b48check hash //
-    basedir // Protocol_hash.to_b48check hash
+                    Format.asprintf "protocol_%a.cmxs" Protocol_hash.pp hash
-            // Format.asprintf "protocol_%a.cmxs" Protocol_hash.pp hash in
+  in
   create_files source_dir units >>= fun _files ->
-  Tezos_compiler.Meta.to_file
+  Tezos_compiler.Meta.to_file source_dir ~hash
-    (source_dir // "TEZOS")
-    ~hash
     (List.map (fun {name} -> String.capitalize_ascii name) units);
   let compiler_command =
     (Sys.executable_name,

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