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

@@ -104,48 +104,48 @@ let unlink_object obj =
 
 (** TEZOS_PROTOCOL files *)
 
-module Meta = struct
+module Protocol = struct
-
+  type component = {
-  let hash_wrapper =
+    name: string;
-    let open Config_file in
+    interface: string option;
-    { to_raw = (fun h -> Raw.String (Protocol_hash.to_b48check h));
+    implementation: string;
-      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 =
+  let component_encoding =
-    [Protocol_hash.t] Config_file.cp_custom_type hash_wrapper
+    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))
 
-  let to_file file hash modules =
+  type t = component list
-    let group = new Config_file.group in
+  let encoding = Data_encoding.list component_encoding
-    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 to_bytes v = Data_encoding.Binary.to_bytes encoding v
-    let group = new Config_file.group in
+  let of_bytes b = Data_encoding.Binary.of_bytes encoding b
-    let hash =
+  let hash proto = Protocol_hash.hash_bytes [to_bytes proto]
-      new protocol_hash_cp ~group ["hash"]
+end
-        (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)
 
+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 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))

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 -> ?hash:Protocol_hash.t -> string list -> unit
-  val to_file: string -> Protocol_hash.t -> string list -> unit
+  val of_file: string -> Protocol_hash.t option * string list
-  val of_file: string -> Protocol_hash.t * string list
-
 end
 
 val main: unit -> unit

src/node/db/store.ml

@@ -508,30 +508,10 @@ end
 
 (*-- Typed operation store under "protocols/" -------------------------------*)
 
-type component = {
+type protocol = Tezos_compiler.Protocol.t
-  name : string ;
+let protocol_encoding = Tezos_compiler.Protocol.encoding
-  interface : string option ;
-  implementation : string ;
-}
 
-let component_encoding =
+module Raw_protocol_value = Tezos_compiler.Protocol
-  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
@@ -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

src/node/db/store.mli

@@ -113,14 +113,7 @@ type block = {
 val shell_block_encoding: shell_block Data_encoding.t
 val block_encoding: block Data_encoding.t
 
-(** Protocol *)
+type protocol = Tezos_compiler.Protocol.t
-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} ********************************************)
@@ -194,14 +187,14 @@ module Operation : sig
 end
 
 module Protocol : sig
-  val of_bytes: MBytes.t -> protocol option
+  val of_bytes: MBytes.t -> Tezos_compiler.Protocol.t option
-  val to_bytes: protocol -> MBytes.t
+  val to_bytes: Tezos_compiler.Protocol.t -> MBytes.t
-  val hash: protocol -> Protocol_hash.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

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

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

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
 

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,

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 ;