From 484b5b5b0847769b46ebf4e3d40037a60bbb8984 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Thu, 8 Feb 2018 10:51:01 +0100 Subject: [PATCH] Client refactor: move `stdlib_lwt` out of `base` --- src/bin_node/jbuild | 2 + src/lib_base/jbuild | 6 +- src/lib_base/protocol.ml | 76 ------------------ src/lib_base/protocol.mli | 3 - src/lib_base/tezos-base.opam | 3 +- src/lib_base/tzPervasives.ml | 1 - src/lib_client_base/client_protocols.ml | 4 +- src/lib_client_base/jbuild | 2 + src/lib_p2p/jbuild | 6 +- src/lib_p2p/test/jbuild | 2 + src/lib_protocol_compiler/compiler.ml | 7 +- src/lib_protocol_compiler/jbuild | 10 ++- .../main_embedded_packer.ml | 7 +- src/lib_protocol_updater/jbuild | 2 + src/lib_protocol_updater/updater.ml | 25 +++--- src/lib_stdlib_lwt/jbuild | 8 +- src/lib_stdlib_lwt/lwt_utils_unix.ml | 77 +++++++++++++++++++ src/lib_stdlib_lwt/lwt_utils_unix.mli | 8 ++ 18 files changed, 139 insertions(+), 110 deletions(-) diff --git a/src/bin_node/jbuild b/src/bin_node/jbuild index 82db599a5..49d2398b7 100644 --- a/src/bin_node/jbuild +++ b/src/bin_node/jbuild @@ -4,6 +4,7 @@ ((name main) (public_name tezos-node) (libraries (tezos-base + tezos-stdlib-lwt tezos-shell-services tezos-rpc-http tezos-p2p @@ -17,6 +18,7 @@ (flags (:standard -w -9+27-30-32-40@8 -safe-string -open Tezos_base__TzPervasives + -open Tezos_stdlib_lwt -open Tezos_shell_services -open Tezos_rpc_http -open Tezos_p2p diff --git a/src/lib_base/jbuild b/src/lib_base/jbuild index 1bed273d1..a5af7d07f 100644 --- a/src/lib_base/jbuild +++ b/src/lib_base/jbuild @@ -5,7 +5,6 @@ (public_name tezos-base) (flags (:standard -w -30 -open Tezos_stdlib - -open Tezos_stdlib_lwt -open Tezos_crypto -open Tezos_data_encoding -open Tezos_error_monad @@ -13,7 +12,6 @@ -open Tezos_micheline -safe-string)) (libraries (tezos-stdlib - tezos-stdlib-lwt tezos-crypto tezos-data-encoding tezos-error-monad @@ -21,7 +19,9 @@ tezos-micheline calendar ezjsonm - mtime.clock.os)))) + lwt.unix + mtime.clock.os + ipaddr.unix)))) (alias ((name runtest_indent) diff --git a/src/lib_base/protocol.ml b/src/lib_base/protocol.ml index c4a84321b..884c6ca58 100644 --- a/src/lib_base/protocol.ml +++ b/src/lib_base/protocol.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -let (//) = Filename.concat - type t = { expected_env: env_version ; components: component list ; @@ -102,8 +100,6 @@ module Meta = struct modules: string list ; } - let name = "TEZOS_PROTOCOL" - let encoding = let open Data_encoding in conv @@ -121,76 +117,4 @@ module Meta = struct ~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.Json.to_string config_file - - let of_file ~dir:dirname = - Utils.read_file ~bin:false (dirname // name) |> - Data_encoding.Json.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_unix.remove_dir dir >>= fun () -> - Lwt_utils_unix.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_unix.create_file ml implementation >>= fun () -> - match interface with - | None -> Lwt.return [ml] - | Some content -> - Lwt_utils_unix.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/src/lib_base/protocol.mli b/src/lib_base/protocol.mli index 52ecdb4cb..516a6adb9 100644 --- a/src/lib_base/protocol.mli +++ b/src/lib_base/protocol.mli @@ -40,6 +40,3 @@ module Meta: sig 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/src/lib_base/tezos-base.opam b/src/lib_base/tezos-base.opam index ec1e989e6..8419b799a 100644 --- a/src/lib_base/tezos-base.opam +++ b/src/lib_base/tezos-base.opam @@ -16,8 +16,9 @@ depends: [ "tezos-error-monad" "tezos-micheline" "tezos-rpc" - "ezjsonm" { >= "0.5.0" } "calendar" + "ezjsonm" { >= "0.5.0" } + "ipaddr" "mtime" { >= "1.0.0" } ] build: [ diff --git a/src/lib_base/tzPervasives.ml b/src/lib_base/tzPervasives.ml index 2e54eb13e..33849e003 100644 --- a/src/lib_base/tzPervasives.ml +++ b/src/lib_base/tzPervasives.ml @@ -8,7 +8,6 @@ (**************************************************************************) include Tezos_stdlib -include Tezos_stdlib_lwt include Tezos_data_encoding include Tezos_error_monad include Tezos_rpc diff --git a/src/lib_client_base/client_protocols.ml b/src/lib_client_base/client_protocols.ml index 2ac6108c2..2dd13142e 100644 --- a/src/lib_client_base/client_protocols.ml +++ b/src/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 = Protocol.read_dir dirname in + Lwt_utils_unix.Protocol.read_dir dirname >>=? fun (_hash, proto) -> 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 -> - Protocol.write_dir (Protocol_hash.to_short_b58check ph) ~hash:ph proto >>= fun () -> + Lwt_utils_unix.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/src/lib_client_base/jbuild b/src/lib_client_base/jbuild index 442c0d625..67789c50d 100644 --- a/src/lib_client_base/jbuild +++ b/src/lib_client_base/jbuild @@ -4,12 +4,14 @@ ((name tezos_client_base) (public_name tezos-client-base) (libraries (tezos-base + tezos-stdlib-lwt tezos-shell-services tezos-rpc-http)) (library_flags (:standard -linkall)) (flags (:standard -w -9+27-30-32-40@8 -safe-string -open Tezos_base__TzPervasives + -open Tezos_stdlib_lwt -open Tezos_rpc_http -open Tezos_shell_services)))) diff --git a/src/lib_p2p/jbuild b/src/lib_p2p/jbuild index b74f888fd..8ed098575 100644 --- a/src/lib_p2p/jbuild +++ b/src/lib_p2p/jbuild @@ -3,10 +3,12 @@ (library ((name tezos_p2p) (public_name tezos-p2p) - (libraries (tezos-base)) + (libraries (tezos-base + tezos-stdlib-lwt)) (flags (:standard -w -9+27-30-32-40@8 -safe-string - -open Tezos_base__TzPervasives)))) + -open Tezos_base__TzPervasives + -open Tezos_stdlib_lwt)))) (alias ((name runtest_indent) diff --git a/src/lib_p2p/test/jbuild b/src/lib_p2p/test/jbuild index a5be3f790..a65a95ab6 100644 --- a/src/lib_p2p/test/jbuild +++ b/src/lib_p2p/test/jbuild @@ -5,12 +5,14 @@ test_p2p_pool test_p2p_io_scheduler)) (libraries (tezos-base + tezos-stdlib-lwt tezos-p2p tezos-test-helpers)) (flags (:standard -w -9-32 -linkall -safe-string -open Tezos_base__TzPervasives + -open Tezos_stdlib_lwt -open Tezos_test_helpers -open Tezos_p2p)))) diff --git a/src/lib_protocol_compiler/compiler.ml b/src/lib_protocol_compiler/compiler.ml index a847aea00..baf76e776 100644 --- a/src/lib_protocol_compiler/compiler.ml +++ b/src/lib_protocol_compiler/compiler.ml @@ -177,7 +177,12 @@ let main { compile_ml ; pack_objects ; link_shared } = at_exit (fun () -> Lwt_main.run (Lwt_utils_unix.remove_dir dir)) ; dir | Some dir -> dir in - let hash, protocol = Protocol.read_dir source_dir in + let hash, protocol = + match Lwt_main.run (Lwt_utils_unix.Protocol.read_dir source_dir) with + | Ok v -> v + | Error err -> + Format.kasprintf Pervasives.failwith + "Failed to read TEZOS_PROTOCOL: %a" pp_print_error err in Lwt_main.run (Lwt_utils_unix.create_dir ~perm:0o755 build_dir) ; Lwt_main.run (Lwt_utils_unix.create_dir ~perm:0o755 (Filename.dirname output)) ; (* Generate the 'functor' *) diff --git a/src/lib_protocol_compiler/jbuild b/src/lib_protocol_compiler/jbuild index 2eb4dbbc4..0983ec233 100644 --- a/src/lib_protocol_compiler/jbuild +++ b/src/lib_protocol_compiler/jbuild @@ -25,6 +25,7 @@ (public_name tezos-protocol-compiler) (libraries (tezos-base tezos-protocol-environment-sigs + tezos-stdlib-lwt compiler-libs lwt.unix ocplib-endian @@ -32,7 +33,8 @@ unix)) (flags (:standard -w -9+27-30-32-40@8 -safe-string - -open Tezos_base__TzPervasives)) + -open Tezos_base__TzPervasives + -open Tezos_stdlib_lwt)) (modules (Embedded_cmis Packer Compiler)))) (library @@ -79,9 +81,11 @@ ((name main_embedded_packer) (public_name tezos-embedded-protocol-packer) (modes (native)) - (libraries (tezos-base)) + (libraries (tezos-base + tezos-stdlib-lwt)) (flags (:standard -linkall - -open Tezos_base__TzPervasives)) + -open Tezos_base__TzPervasives + -open Tezos_stdlib_lwt)) (modules (Main_embedded_packer)))) (install diff --git a/src/lib_protocol_compiler/main_embedded_packer.ml b/src/lib_protocol_compiler/main_embedded_packer.ml index 28407f7aa..5c798b38f 100644 --- a/src/lib_protocol_compiler/main_embedded_packer.ml +++ b/src/lib_protocol_compiler/main_embedded_packer.ml @@ -10,7 +10,12 @@ let srcdir = Sys.argv.(1) let version = Sys.argv.(2) -let hash, sources = Protocol.read_dir srcdir +let hash, sources = + match Lwt_main.run (Lwt_utils_unix.Protocol.read_dir srcdir) with + | Ok v -> v + | Error err -> + Format.kasprintf Pervasives.failwith + "Failed to read TEZOS_PROTOCOL: %a" pp_print_error err let () = Format.printf {| diff --git a/src/lib_protocol_updater/jbuild b/src/lib_protocol_updater/jbuild index fe674ebe9..04d728614 100644 --- a/src/lib_protocol_updater/jbuild +++ b/src/lib_protocol_updater/jbuild @@ -4,6 +4,7 @@ ((name tezos_protocol_updater) (public_name tezos-protocol-updater) (libraries (tezos-base + tezos-stdlib-lwt tezos-micheline tezos-protocol-compiler.registerer tezos-protocol-compiler.native @@ -12,6 +13,7 @@ (flags (:standard -w -9+27-30-32-40@8 -safe-string -open Tezos_base__TzPervasives + -open Tezos_stdlib_lwt -open Tezos_micheline -open Tezos_storage)))) diff --git a/src/lib_protocol_updater/updater.ml b/src/lib_protocol_updater/updater.ml index 3794b7e4a..256fb1134 100644 --- a/src/lib_protocol_updater/updater.ml +++ b/src/lib_protocol_updater/updater.ml @@ -60,23 +60,26 @@ module Raw = struct let plugin_file = datadir // Protocol_hash.to_short_b58check hash // Format.asprintf "protocol_%a.cmxs" Protocol_hash.pp hash in - Protocol.write_dir source_dir ~hash p >>= fun () -> - let compiler_command = - (Sys.executable_name, - Array.of_list [compiler_name; "-register"; plugin_file; source_dir]) in - let fd = Unix.(openfile log_file [O_WRONLY; O_CREAT; O_TRUNC] 0o644) in - let pi = + begin + Lwt_utils_unix.Protocol.write_dir source_dir ~hash p >>=? fun () -> + let compiler_command = + (Sys.executable_name, + Array.of_list [compiler_name; "-register"; plugin_file; source_dir]) in + let fd = Unix.(openfile log_file [O_WRONLY; O_CREAT; O_TRUNC] 0o644) in Lwt_process.exec ~stdin:`Close ~stdout:(`FD_copy fd) ~stderr:(`FD_move fd) - compiler_command in - pi >>= function - | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> + compiler_command >>= return + end >>= function + | Error err -> + log_error "Error %a" pp_print_error err ; + Lwt.return false + | Ok (Unix.WSIGNALED _ | Unix.WSTOPPED _) -> log_error "INTERRUPTED COMPILATION (%s)" log_file; Lwt.return false - | Unix.WEXITED x when x <> 0 -> + | Ok (Unix.WEXITED x) when x <> 0 -> log_error "COMPILATION ERROR (%s)" log_file; Lwt.return false - | Unix.WEXITED _ -> + | Ok (Unix.WEXITED _) -> try Dynlink.loadfile_private plugin_file; Lwt.return true with Dynlink.Error err -> log_error "Can't load plugin: %s (%s)" diff --git a/src/lib_stdlib_lwt/jbuild b/src/lib_stdlib_lwt/jbuild index 13c45fecb..6ff6b933e 100644 --- a/src/lib_stdlib_lwt/jbuild +++ b/src/lib_stdlib_lwt/jbuild @@ -4,13 +4,9 @@ ((name tezos_stdlib_lwt) (public_name tezos-stdlib-lwt) (flags (:standard -w -9-30 - -open Tezos_stdlib - -open Tezos_data_encoding - -open Tezos_error_monad + -open Tezos_base__TzPervasives -safe-string)) - (libraries (tezos-stdlib - tezos-data-encoding - tezos-error-monad + (libraries (tezos-base lwt.unix ipaddr.unix str)))) diff --git a/src/lib_stdlib_lwt/lwt_utils_unix.ml b/src/lib_stdlib_lwt/lwt_utils_unix.ml index 43cff41c5..fb5a33a64 100644 --- a/src/lib_stdlib_lwt/lwt_utils_unix.ml +++ b/src/lib_stdlib_lwt/lwt_utils_unix.ml @@ -145,3 +145,80 @@ module Json = struct end end + +module Protocol = struct + + let name = "TEZOS_PROTOCOL" + + open Protocol + + let (//) = Filename.concat + + let to_file ~dir:dirname ?hash ?env_version modules = + let config_file = + Data_encoding.Json.construct + Meta.encoding + { hash ; expected_env_version = env_version ; modules } in + Json.write_file (dirname // name) config_file + + let of_file ~dir:dirname = + Json.read_file (dirname // name) >>=? fun json -> + return (Data_encoding.Json.destruct Meta.encoding json) + + 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 = + of_file ~dir >>=? fun meta -> + 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 + return (hash, protocol) + + open Lwt.Infix + + let create_files dir units = + remove_dir dir >>= fun () -> + 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 + create_file ml implementation >>= fun () -> + match interface with + | None -> Lwt.return [ml] + | Some content -> + 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 -> + to_file + ~dir + ?hash + ~env_version:p.expected_env + (List.map (fun { name ; _ } -> String.capitalize_ascii name) p.components) + +end diff --git a/src/lib_stdlib_lwt/lwt_utils_unix.mli b/src/lib_stdlib_lwt/lwt_utils_unix.mli index 93235339d..e6cf428e7 100644 --- a/src/lib_stdlib_lwt/lwt_utils_unix.mli +++ b/src/lib_stdlib_lwt/lwt_utils_unix.mli @@ -40,3 +40,11 @@ module Json : sig val write_file : string -> Data_encoding.json -> unit tzresult Lwt.t end + +module Protocol : sig + + val read_dir: string -> (Protocol_hash.t * Protocol.t) tzresult Lwt.t + + val write_dir: string -> ?hash:Protocol_hash.t -> Protocol.t -> unit tzresult Lwt.t + +end