diff --git a/lib_base/protocol.ml b/lib_base/protocol.ml index f71822c6b..91de65143 100644 --- a/lib_base/protocol.ml +++ b/lib_base/protocol.ml @@ -7,6 +7,8 @@ (* *) (**************************************************************************) +let (//) = Filename.concat + type t = { expected_env: env_version ; components: component list ; @@ -69,3 +71,104 @@ let of_bytes b = Data_encoding.Binary.of_bytes encoding b let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b let hash proto = Protocol_hash.hash_bytes [to_bytes proto] let hash_raw proto = Protocol_hash.hash_bytes [proto] + +module Meta = struct + + type t = { + hash: Protocol_hash.t option ; + expected_env_version: env_version option ; + modules: string list ; + } + + let name = "TEZOS_PROTOCOL" + + let encoding = + let open Data_encoding in + conv + (fun { hash ; expected_env_version ; modules } -> + (hash, expected_env_version, modules)) + (fun (hash, expected_env_version, modules) -> + { hash ; expected_env_version ; modules }) @@ + obj3 + (opt "hash" + ~description:"Used to force the hash of the protocol" + Protocol_hash.encoding) + (opt "expected_env_version" + env_version_encoding) + (req "modules" + ~description:"Modules comprising the protocol" + (list string)) + + let to_file ~dir:dirname ?hash ?env_version modules = + let config_file = + Data_encoding.Json.construct + encoding + { hash ; expected_env_version = env_version ; modules } in + Utils.write_file ~bin:false (dirname // name) @@ + Data_encoding_ezjsonm.to_string config_file + + let of_file ~dir:dirname = + Utils.read_file ~bin:false (dirname // name) |> + Data_encoding_ezjsonm.from_string |> function + | Error err -> Pervasives.failwith err + | Ok json -> Data_encoding.Json.destruct encoding json + +end + +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 read_dir dir = + let meta = Meta.of_file ~dir in + let components = List.map (find_component dir) meta.modules in + let expected_env = + match meta.expected_env_version with + | None -> V1 + | Some v -> v in + let protocol = { expected_env ; components } in + let hash = + match meta.hash with + | None -> hash protocol + | Some hash -> hash in + hash, protocol + +open Lwt.Infix + +let create_files dir units = + Lwt_utils.remove_dir dir >>= fun () -> + Lwt_utils.create_dir dir >>= fun () -> + Lwt_list.map_s + (fun { name ; interface ; implementation } -> + let name = String.lowercase_ascii name in + let ml = dir // (name ^ ".ml") in + let mli = dir // (name ^ ".mli") in + Lwt_utils.create_file ml implementation >>= fun () -> + match interface with + | None -> Lwt.return [ml] + | Some content -> + Lwt_utils.create_file mli content >>= fun () -> + Lwt.return [ mli ; ml ]) + units >>= fun files -> + let files = List.concat files in + Lwt.return files + +let write_dir dir ?hash (p: t) = + create_files dir p.components >>= fun _files -> + Meta.to_file + ~dir + ?hash + ~env_version:p.expected_env + (List.map (fun { name ; _ } -> String.capitalize_ascii name) p.components) ; + Lwt.return_unit + diff --git a/lib_base/protocol.mli b/lib_base/protocol.mli index 66e019277..87a1612d7 100644 --- a/lib_base/protocol.mli +++ b/lib_base/protocol.mli @@ -27,3 +27,17 @@ include S.HASHABLE with type t := t and type hash := Protocol_hash.t val of_bytes_exn: MBytes.t -> t +module Meta: sig + + type t = { + hash: Protocol_hash.t option ; + expected_env_version: env_version option ; + modules: string list ; + } + + val encoding: t Data_encoding.t + +end + +val read_dir: string -> Protocol_hash.t * t +val write_dir: string -> ?hash:Protocol_hash.t -> t -> unit Lwt.t diff --git a/lib_client_base/client_protocols.ml b/lib_client_base/client_protocols.ml index 2e8aaaeaa..be15fad6b 100644 --- a/lib_client_base/client_protocols.ml +++ b/lib_client_base/client_protocols.ml @@ -38,7 +38,7 @@ let commands () = (fun () dirname (cctxt : Client_commands.full_context) -> Lwt.catch (fun () -> - let _hash, proto = Tezos_protocol_compiler.Native.read_dir dirname in + let _hash, proto = Protocol.read_dir dirname in Client_node_rpcs.inject_protocol cctxt proto >>= function | Ok hash -> cctxt#message "Injected protocol %a successfully" Protocol_hash.pp_short hash >>= fun () -> @@ -60,7 +60,7 @@ let commands () = @@ stop) (fun () ph (cctxt : Client_commands.full_context) -> Client_node_rpcs.Protocols.contents cctxt ph >>=? fun proto -> - Updater.extract (Protocol_hash.to_short_b58check ph) ~hash:ph proto >>= fun () -> + Protocol.write_dir (Protocol_hash.to_short_b58check ph) ~hash:ph proto >>= fun () -> cctxt#message "Extracted protocol %a" Protocol_hash.pp_short ph >>= fun () -> return () ) ; diff --git a/lib_node_updater/updater.ml b/lib_node_updater/updater.ml index 6afaa7389..d04f96b68 100644 --- a/lib_node_updater/updater.ml +++ b/lib_node_updater/updater.ml @@ -44,46 +44,17 @@ let get_datadir () = let init dir = datadir := Some dir -let create_files dir units = - Lwt_utils.remove_dir dir >>= fun () -> - Lwt_utils.create_dir dir >>= fun () -> - Lwt_list.map_s - (fun { Protocol.name; interface; implementation } -> - let name = String.lowercase_ascii name in - let ml = dir // (name ^ ".ml") in - let mli = dir // (name ^ ".mli") in - Lwt_utils.create_file ml implementation >>= fun () -> - match interface with - | None -> Lwt.return [ml] - | Some content -> - Lwt_utils.create_file mli content >>= fun () -> - Lwt.return [mli;ml]) - units >>= fun files -> - let files = List.concat files in - Lwt.return files - -let extract dir ?hash (p: Protocol.t) = - create_files dir p.components >>= fun _files -> - Tezos_protocol_compiler.Native.Meta.to_file dir - ?hash - ~env_version:p.expected_env - (List.map (fun {Protocol.name} -> String.capitalize_ascii name) p.components) ; - Lwt.return_unit - let compiler_name = "tezos-protocol-compiler" let do_compile hash p = assert (p.Protocol.expected_env = V1) ; - let units = p.components in let datadir = get_datadir () in let source_dir = datadir // Protocol_hash.to_short_b58check hash // "src" in let log_file = datadir // Protocol_hash.to_short_b58check hash // "LOG" in let plugin_file = datadir // Protocol_hash.to_short_b58check hash // Format.asprintf "protocol_%a.cmxs" Protocol_hash.pp hash in - create_files source_dir units >>= fun _files -> - Tezos_protocol_compiler.Native.Meta.to_file source_dir ~hash - (List.map (fun {Protocol.name} -> String.capitalize_ascii name) units); + Protocol.write_dir source_dir ~hash p >>= fun () -> let compiler_command = (Sys.executable_name, Array.of_list [compiler_name; plugin_file; source_dir]) in diff --git a/lib_node_updater/updater.mli b/lib_node_updater/updater.mli index e7296b8eb..ba859ecd9 100644 --- a/lib_node_updater/updater.mli +++ b/lib_node_updater/updater.mli @@ -14,7 +14,6 @@ val activate: Context.t -> Protocol_hash.t -> Context.t Lwt.t val fork_test_network: Context.t -> protocol:Protocol_hash.t -> expiration:Time.t -> Context.t Lwt.t -val extract: Lwt_io.file_name -> ?hash:Protocol_hash.t -> Protocol.t -> unit Lwt.t val init: string -> unit type validation_result = { diff --git a/lib_protocol_compiler/native.ml b/lib_protocol_compiler/native.ml index 25f943899..f368ac048 100644 --- a/lib_protocol_compiler/native.ml +++ b/lib_protocol_compiler/native.ml @@ -188,64 +188,6 @@ let compile_ml ?for_pack ml = Clflags.for_package := None ; target ^ ".cmx" -module Meta = struct - - let name = "TEZOS_PROTOCOL" - - let config_file_encoding = - let open Data_encoding in - obj3 - (opt "hash" - ~description:"Used to force the hash of the protocol" - Protocol_hash.encoding) - (opt "expected_env_version" - Protocol.env_version_encoding) - (req "modules" - ~description:"Modules comprising the protocol" - (list string)) - - let to_file dirname ?hash ?env_version modules = - let config_file = - Data_encoding.Json.construct - config_file_encoding - (hash, env_version, modules) in - Utils.write_file ~bin:false (dirname // name) @@ - Data_encoding_ezjsonm.to_string config_file - - let of_file dirname = - Utils.read_file ~bin:false (dirname // name) |> - Data_encoding_ezjsonm.from_string |> function - | Error err -> Pervasives.failwith err - | Ok json -> Data_encoding.Json.destruct config_file_encoding json - -end - -let find_component dirname module_name = - let open Protocol in - 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 read_dir dirname = - let hash, expected_env, modules = Meta.of_file dirname in - let components = List.map (find_component dirname) modules in - let expected_env = match expected_env with None -> Protocol.V1 | Some v -> v in - let protocol = Protocol.{ expected_env ; components } in - let hash = - match hash with - | None -> Protocol.hash protocol - | Some hash -> hash in - hash, protocol - (** Main *) let mktemp_dir () = @@ -282,7 +224,7 @@ let main () = | Some dir -> dir in Lwt_main.run (Lwt_utils.create_dir ~perm:0o755 build_dir) ; Lwt_main.run (Lwt_utils.create_dir ~perm:0o755 (Filename.dirname output)) ; - let hash, protocol = read_dir source_dir in + let hash, protocol = Protocol.read_dir source_dir in (* Generate the 'functor' *) let functor_file = build_dir // "functor.ml" in let oc = open_out functor_file in diff --git a/lib_protocol_compiler/native.mli b/lib_protocol_compiler/native.mli index cdc22a3c1..c25825a07 100644 --- a/lib_protocol_compiler/native.mli +++ b/lib_protocol_compiler/native.mli @@ -9,17 +9,4 @@ (** Low-level part of the [Updater]. *) -module Meta : sig - val to_file: - Lwt_io.file_name -> - ?hash:Protocol_hash.t -> - ?env_version:Protocol.env_version -> - string list -> unit - val of_file: - Lwt_io.file_name -> - Protocol_hash.t option * Protocol.env_version option * string list -end - -val read_dir: Lwt_io.file_name -> Protocol_hash.t * Protocol.t - val main: unit -> unit