From 55c009442276087749ef1372c93b950e51238562 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 20 Apr 2021 14:07:13 +0200 Subject: [PATCH 1/2] Stdlib/lwt_utils_unix: replace some tzresults with excs --- src/bin_node/node_config_file.ml | 2 + src/bin_node/node_data_version.ml | 2 + src/bin_node/node_identity_file.ml | 2 + src/bin_node/node_shared_arg.ml | 3 +- src/bin_signer/socket_daemon.ml | 1 + src/lib_base/unix/protocol_files.ml | 2 + src/lib_base/unix/socket.ml | 9 ++- src/lib_client_base_unix/client_config.ml | 7 ++- .../client_context_unix.ml | 4 +- .../test/test_mockup_wallet.ml | 1 + src/lib_error_monad/error_monad.ml | 3 + src/lib_error_monad/error_monad.mli | 2 + src/lib_mockup/local_services.ml | 2 + src/lib_mockup/mockup_wallet.ml | 1 + src/lib_mockup/persistence.ml | 3 + src/lib_p2p/p2p_discovery.ml | 3 + src/lib_p2p/p2p_fd.ml | 2 +- src/lib_p2p/p2p_peer_state.ml | 2 + src/lib_p2p/p2p_welcome.ml | 1 + src/lib_p2p/test/p2p_test_utils.ml | 1 + src/lib_p2p/test/test_p2p_io_scheduler.ml | 1 + src/lib_shell/bench/bench_tool.ml | 1 + src/lib_stdlib_unix/file_event_sink.ml | 10 ++-- src/lib_stdlib_unix/internal_event_unix.ml | 1 + src/lib_stdlib_unix/lwt_utils_unix.ml | 58 +++++++++---------- src/lib_stdlib_unix/lwt_utils_unix.mli | 8 +-- .../legacy_store/legacy_store_builder.ml | 2 + src/lib_store/snapshots.ml | 2 + .../lib_client/client_proto_main.ml | 1 + .../client_proto_context_commands.ml | 5 +- .../client_proto_context_commands.ml | 5 +- .../client_sapling_commands.ml | 1 + .../lib_delegate/client_baking_forge.ml | 1 + .../client_proto_context_commands.ml | 5 +- .../client_sapling_commands.ml | 1 + .../lib_delegate/client_baking_forge.ml | 1 + .../client_proto_context_commands.ml | 5 +- .../client_sapling_commands.ml | 1 + .../lib_delegate/client_baking_forge.ml | 1 + .../lib_client/client_proto_main.ml | 2 + .../lib_client/client_proto_main.ml | 2 + 41 files changed, 112 insertions(+), 55 deletions(-) diff --git a/src/bin_node/node_config_file.ml b/src/bin_node/node_config_file.ml index 87a0da367279..1583f8522226 100644 --- a/src/bin_node/node_config_file.ml +++ b/src/bin_node/node_config_file.ml @@ -1161,6 +1161,7 @@ let string_of_json_encoding_error exn = let read fp = if Sys.file_exists fp then Lwt_utils_unix.Json.read_file fp + >|= tzresult_of_exn_result >>=? fun json -> try return (Data_encoding.Json.destruct encoding json) with | Json_encoding.Cannot_destruct (path, exn) -> @@ -1181,6 +1182,7 @@ let write fp cfg = Node_data_version.ensure_data_dir (Filename.dirname fp) >>=? fun () -> Lwt_utils_unix.Json.write_file fp (Data_encoding.Json.construct encoding cfg) + >|= tzresult_of_exn_result let to_string cfg = Data_encoding.Json.to_string (Data_encoding.Json.construct encoding cfg) diff --git a/src/bin_node/node_data_version.ml b/src/bin_node/node_data_version.ml index ee5708964b50..122bce13c001 100644 --- a/src/bin_node/node_data_version.ml +++ b/src/bin_node/node_data_version.ml @@ -251,10 +251,12 @@ let write_version_file data_dir = Lwt_utils_unix.Json.write_file version_file (Data_encoding.Json.construct version_encoding data_version) + >|= tzresult_of_exn_result |> trace (Could_not_write_version_file version_file) let read_version_file version_file = Lwt_utils_unix.Json.read_file version_file + >|= tzresult_of_exn_result |> trace (Could_not_read_data_dir_version version_file) >>=? fun json -> try return (Data_encoding.Json.destruct version_encoding json) diff --git a/src/bin_node/node_identity_file.ml b/src/bin_node/node_identity_file.ml index 6e8003f5ed16..9abc7505f461 100644 --- a/src/bin_node/node_identity_file.ml +++ b/src/bin_node/node_identity_file.ml @@ -138,6 +138,7 @@ let read ?expected_pow filename = fail (No_identity_file filename) | true -> ( Lwt_utils_unix.Json.read_file filename + >|= tzresult_of_exn_result >>=? fun json -> let id = Data_encoding.Json.destruct P2p_identity.encoding json in let pkh = Crypto_box.hash id.public_key in @@ -191,6 +192,7 @@ let write file identity = Lwt_utils_unix.Json.write_file file (Data_encoding.Json.construct P2p_identity.encoding identity) + >|= tzresult_of_exn_result let generate_with_animation ppf target = let duration = 1200 / Animation.number_of_frames in diff --git a/src/bin_node/node_shared_arg.ml b/src/bin_node/node_shared_arg.ml index e85a66d2f6c2..4c2706b8d8b3 100644 --- a/src/bin_node/node_shared_arg.ml +++ b/src/bin_node/node_shared_arg.ml @@ -137,7 +137,8 @@ let load_net_config = function fail (Network_http_error (resp.status, body_str)) ) >>=? decode_net_config (Uri.to_string uri) | Filename filename -> - Lwt_utils_unix.Json.read_file filename >>=? decode_net_config filename + Lwt_utils_unix.Json.read_file filename + >|= tzresult_of_exn_result >>=? decode_net_config filename let wrap data_dir config_file network connections max_download_speed max_upload_speed binary_chunks_size peer_table_size listen_addr diff --git a/src/bin_signer/socket_daemon.ml b/src/bin_signer/socket_daemon.ml index b04534d4c6fc..2fc1d6185ac7 100644 --- a/src/bin_signer/socket_daemon.ml +++ b/src/bin_signer/socket_daemon.ml @@ -125,6 +125,7 @@ let run ?magic_bytes ?timeout ~check_high_watermark ~require_auth cfd) (fun () -> Lwt_utils_unix.safe_close cfd + >|= tzresult_of_exn_result >>= function | Error trace -> Format.eprintf diff --git a/src/lib_base/unix/protocol_files.ml b/src/lib_base/unix/protocol_files.ml index 5d469cf9195a..faebbe13c97f 100644 --- a/src/lib_base/unix/protocol_files.ml +++ b/src/lib_base/unix/protocol_files.ml @@ -12,9 +12,11 @@ let to_file ~dir:dirname ?hash ?env_version modules = {hash; expected_env_version = env_version; modules} in Lwt_utils_unix.Json.write_file (dirname // name) config_file + >|= tzresult_of_exn_result let of_file ~dir:dirname = Lwt_utils_unix.Json.read_file (dirname // name) + >|= tzresult_of_exn_result >>=? fun json -> return (Data_encoding.Json.destruct Meta.encoding json) let find_component dirname module_name = diff --git a/src/lib_base/unix/socket.ml b/src/lib_base/unix/socket.ml index 28c772a3722f..efeacada1845 100644 --- a/src/lib_base/unix/socket.ml +++ b/src/lib_base/unix/socket.ml @@ -81,9 +81,14 @@ let with_connection ?timeout addr f = protect (fun () -> f conn - >>=? fun a -> Lwt_utils_unix.safe_close conn >>=? fun () -> return a) + >>=? fun a -> + Lwt_utils_unix.safe_close conn + >|= tzresult_of_exn_result + >>=? fun () -> return a) ~on_error:(fun e -> - Lwt_utils_unix.safe_close conn >>=? fun () -> Lwt.return (Error e)) + Lwt_utils_unix.safe_close conn + >|= tzresult_of_exn_result + >>=? fun () -> Lwt.return (Error e)) let bind ?(backlog = 10) = function | Unix path -> diff --git a/src/lib_client_base_unix/client_config.ml b/src/lib_client_base_unix/client_config.ml index 481c1a744800..15a32f49c944 100644 --- a/src/lib_client_base_unix/client_config.ml +++ b/src/lib_client_base_unix/client_config.ml @@ -276,12 +276,15 @@ module Cfg_file = struct let from_json json = Data_encoding.Json.destruct encoding json let read fp = - Lwt_utils_unix.Json.read_file fp >>=? fun json -> return (from_json json) + Lwt_utils_unix.Json.read_file fp + >|= tzresult_of_exn_result + >>=? fun json -> return (from_json json) let write out cfg = Lwt_utils_unix.Json.write_file out (Data_encoding.Json.construct encoding cfg) + >|= tzresult_of_exn_result end let default_cli_args = @@ -516,6 +519,7 @@ let client_mode_arg () = let read_config_file config_file = Lwt_utils_unix.Json.read_file config_file + >|= tzresult_of_exn_result >>= function | Error errs -> failwith @@ -652,6 +656,7 @@ let config_init_mockup cctxt protocol_hash_opt bootstrap_accounts_file protocol_constants in Lwt_utils_unix.Json.write_file protocol_constants_file string_to_write + >|= tzresult_of_exn_result >>=? fun () -> cctxt#message "Written default --%s file: %s" diff --git a/src/lib_client_base_unix/client_context_unix.ml b/src/lib_client_base_unix/client_context_unix.ml index 9bc579fad580..070d58c8c364 100644 --- a/src/lib_client_base_unix/client_context_unix.ml +++ b/src/lib_client_base_unix/client_context_unix.ml @@ -85,6 +85,7 @@ class unix_wallet ~base_dir ~password_filename : Client_context.wallet = if not (Sys.file_exists filename) then return default else Lwt_utils_unix.Json.read_file filename + >|= tzresult_of_exn_result |> generic_trace "could not read the %s alias file" alias_name >>=? fun json -> match Data_encoding.Json.destruct encoding json with @@ -106,7 +107,8 @@ class unix_wallet ~base_dir ~password_filename : Client_context.wallet = >>= fun () -> let filename = self#filename alias_name in let json = Data_encoding.Json.construct encoding list in - Lwt_utils_unix.Json.write_file filename json) + Lwt_utils_unix.Json.write_file filename json + >|= tzresult_of_exn_result) (fun exn -> Lwt.return (error_exn exn)) |> generic_trace "could not write the %s alias file." alias_name end diff --git a/src/lib_client_base_unix/test/test_mockup_wallet.ml b/src/lib_client_base_unix/test/test_mockup_wallet.ml index f55c4d765e88..9e0fec366ce7 100644 --- a/src/lib_client_base_unix/test/test_mockup_wallet.ml +++ b/src/lib_client_base_unix/test/test_mockup_wallet.ml @@ -162,6 +162,7 @@ let test_with_valid_bootstrap_accounts_file_populates = Lwt_utils_unix.Json.write_file bootstrap_accounts_file_path bootstrap_accounts + >|= tzresult_of_exn_result >>=? fun () -> populate io_wallet (Some bootstrap_accounts_file_path) >>=? fun () -> diff --git a/src/lib_error_monad/error_monad.ml b/src/lib_error_monad/error_monad.ml index fc4f6fc10f08..dc7f4b73a79b 100644 --- a/src/lib_error_monad/error_monad.ml +++ b/src/lib_error_monad/error_monad.ml @@ -55,6 +55,9 @@ let () = None) (fun msg -> Exn (Failure msg)) +let tzresult_of_exn_result r = + Result.map_error (fun exc -> TzTrace.make @@ Exn exc) r + let generic_error fmt = Format.kasprintf (fun s -> error (Exn (Failure s))) fmt let failwith fmt = Format.kasprintf (fun s -> fail (Exn (Failure s))) fmt diff --git a/src/lib_error_monad/error_monad.mli b/src/lib_error_monad/error_monad.mli index b1c0cddc8c25..1577052f064b 100644 --- a/src/lib_error_monad/error_monad.mli +++ b/src/lib_error_monad/error_monad.mli @@ -78,6 +78,8 @@ val failure : ('a, Format.formatter, unit, error) format4 -> 'a (** Wrapped OCaml/Lwt exception *) type error += Exn of exn +val tzresult_of_exn_result : ('a, exn) result -> 'a tzresult + type error += Canceled (** [protect] is a wrapper around [Lwt.catch] where the error handler operates diff --git a/src/lib_mockup/local_services.ml b/src/lib_mockup/local_services.ml index e4711bb071a4..13224c4edf46 100644 --- a/src/lib_mockup/local_services.ml +++ b/src/lib_mockup/local_services.ml @@ -241,6 +241,7 @@ module Make (E : MENV) = struct let unsafe_read () = Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file file + >|= tzresult_of_exn_result >>=? fun json -> return @@ Data_encoding.Json.destruct ops_encoding json let read () = @@ -256,6 +257,7 @@ module Make (E : MENV) = struct >>=? fun ops -> let json = Data_encoding.Json.construct ops_encoding ops in Tezos_stdlib_unix.Lwt_utils_unix.Json.write_file file json + >|= tzresult_of_exn_result let append = write ~mode:Append end diff --git a/src/lib_mockup/mockup_wallet.ml b/src/lib_mockup/mockup_wallet.ml index 909212a42e2a..d3d5ce9011ec 100644 --- a/src/lib_mockup/mockup_wallet.ml +++ b/src/lib_mockup/mockup_wallet.ml @@ -85,6 +85,7 @@ let populate (cctxt : #Tezos_client_base.Client_context.io_wallet) default_bootstrap_accounts | Some accounts_file -> ( Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file accounts_file + >|= tzresult_of_exn_result >>=? fun json -> match Data_encoding.Json.destruct bootstrap_secrets_encoding json with | accounts -> diff --git a/src/lib_mockup/persistence.ml b/src/lib_mockup/persistence.ml index 485aa9f6423b..3b38b37b72e8 100644 --- a/src/lib_mockup/persistence.ml +++ b/src/lib_mockup/persistence.ml @@ -169,6 +169,7 @@ module Internal = struct failwith "get_mockup_context_from_disk: file %s not found" file else Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file file + >|= tzresult_of_exn_result >>=? fun context_json -> match Persistent_mockup_environment.of_json context_json with | persisted_mockup -> @@ -203,6 +204,7 @@ module Internal = struct Persistent_mockup_environment.( to_json {protocol_hash; chain_id; rpc_context}) |> Tezos_stdlib_unix.Lwt_utils_unix.Json.write_file context_file + >|= tzresult_of_exn_result type base_dir_class = | Base_dir_does_not_exist @@ -288,6 +290,7 @@ module Internal = struct Persistent_mockup_environment.( to_json {protocol_hash; chain_id; rpc_context}) |> Tezos_stdlib_unix.Lwt_utils_unix.Json.write_file context_file + >|= tzresult_of_exn_result >>=? fun () -> if asynchronous then (* Setup a local persistent mempool *) diff --git a/src/lib_p2p/p2p_discovery.ml b/src/lib_p2p/p2p_discovery.ml index e7f049ba8f51..7188e346839f 100644 --- a/src/lib_p2p/p2p_discovery.ml +++ b/src/lib_p2p/p2p_discovery.ml @@ -59,6 +59,7 @@ module Answer = struct Lwt_unix.set_close_on_exec socket ; Lwt_canceler.on_cancel st.canceler (fun () -> Lwt_utils_unix.safe_close socket + >|= tzresult_of_exn_result >>= function | Error trace -> Format.eprintf "Uncaught error: %a\n%!" pp_print_error trace ; @@ -176,6 +177,7 @@ module Sender = struct let socket = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in Lwt_canceler.on_cancel st.canceler (fun () -> Lwt_utils_unix.safe_close socket + >|= tzresult_of_exn_result >>= function | Error trace -> Format.eprintf "Uncaught error: %a\n%!" pp_print_error trace ; @@ -192,6 +194,7 @@ module Sender = struct Lwt_unix.sendto socket msg 0 Message.length [] addr >>= fun _len -> Lwt_utils_unix.safe_close socket + >|= tzresult_of_exn_result >>= function | Error trace -> Format.eprintf "Uncaught error: %a\n%!" pp_print_error trace ; diff --git a/src/lib_p2p/p2p_fd.ml b/src/lib_p2p/p2p_fd.ml index 111f13ead5d1..f71ca10160db 100644 --- a/src/lib_p2p/p2p_fd.ml +++ b/src/lib_p2p/p2p_fd.ml @@ -68,7 +68,7 @@ let socket proto kind arg = let close t = Events.(emit close_fd) (t.id, t.nread, t.nwrit) - >>= fun () -> Lwt_utils_unix.safe_close t.fd + >>= fun () -> Lwt_utils_unix.safe_close t.fd >|= tzresult_of_exn_result let read t buf pos len = Events.(emit try_read) (t.id, len) diff --git a/src/lib_p2p/p2p_peer_state.ml b/src/lib_p2p/p2p_peer_state.ml index eae4949e0c8d..8287b5f91a50 100644 --- a/src/lib_p2p/p2p_peer_state.ml +++ b/src/lib_p2p/p2p_peer_state.ml @@ -194,6 +194,7 @@ module Info = struct let enc = Data_encoding.list (encoding peer_metadata_encoding) in if path <> "/dev/null" && Sys.file_exists path then Lwt_utils_unix.Json.read_file path + >|= tzresult_of_exn_result >>=? fun json -> return (Data_encoding.Json.destruct enc json) else return_nil @@ -205,6 +206,7 @@ module Info = struct let tempfile = path ^ ".tmp" in Lwt_utils_unix.Json.write_file tempfile @@ Json.construct (list (encoding peer_metadata_encoding)) peers + >|= tzresult_of_exn_result >>=? fun () -> protect (fun () -> Lwt_unix.rename tempfile path >>= fun () -> return_unit) diff --git a/src/lib_p2p/p2p_welcome.ml b/src/lib_p2p/p2p_welcome.ml index da011dbe2618..9940174c54b9 100644 --- a/src/lib_p2p/p2p_welcome.ml +++ b/src/lib_p2p/p2p_welcome.ml @@ -122,6 +122,7 @@ let create ?addr ~backlog connect_handler port = let canceler = Lwt_canceler.create () in Lwt_canceler.on_cancel canceler (fun () -> Lwt_utils_unix.safe_close socket + >|= tzresult_of_exn_result >>= function | Error trace -> Format.eprintf "Uncaught error: %a\n%!" pp_print_error trace ; diff --git a/src/lib_p2p/test/p2p_test_utils.ml b/src/lib_p2p/test/p2p_test_utils.ml index 677f1f1a88c0..c54ec29af268 100644 --- a/src/lib_p2p/test/p2p_test_utils.ml +++ b/src/lib_p2p/test/p2p_test_utils.ml @@ -175,6 +175,7 @@ let run_nodes client server = >>=? fun server_node -> Process.detach ~prefix:"client: " (fun channel -> Lwt_utils_unix.safe_close main_socket + >|= tzresult_of_exn_result >>= (function | Error trace -> Format.eprintf "Uncaught error: %a\n%!" pp_print_error trace ; diff --git a/src/lib_p2p/test/test_p2p_io_scheduler.ml b/src/lib_p2p/test/test_p2p_io_scheduler.ml index e3b95d321437..21714bdd0c19 100644 --- a/src/lib_p2p/test/test_p2p_io_scheduler.ml +++ b/src/lib_p2p/test/test_p2p_io_scheduler.ml @@ -193,6 +193,7 @@ let run ?display_client_stat ?max_download_speed ?max_upload_speed let prefix = Printf.sprintf "client(%d): " n in Process.detach ~prefix (fun _ -> Lwt_utils_unix.safe_close main_socket + >|= tzresult_of_exn_result >>= (function | Error trace -> Format.eprintf "Uncaught error: %a\n%!" pp_print_error trace ; diff --git a/src/lib_shell/bench/bench_tool.ml b/src/lib_shell/bench/bench_tool.ml index db50219751ce..d6383c3e19fe 100644 --- a/src/lib_shell/bench/bench_tool.ml +++ b/src/lib_shell/bench/bench_tool.ml @@ -69,6 +69,7 @@ let parse_param_file name = failwith "Parameters : Inexistent JSON file" else Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file name + >|= tzresult_of_exn_result >>=? fun json -> match Data_encoding.Json.destruct Parameters.encoding json with | exception exn -> diff --git a/src/lib_stdlib_unix/file_event_sink.ml b/src/lib_stdlib_unix/file_event_sink.ml index 4142ae9e8760..19fdeb214114 100644 --- a/src/lib_stdlib_unix/file_event_sink.ml +++ b/src/lib_stdlib_unix/file_event_sink.ml @@ -289,14 +289,13 @@ module Sink_implementation : Internal_event.SINK with type t = t = struct >>= function | Ok () -> return_unit - | Error el -> + | Error exc -> failwith - "ERROR while Handling %a,@ cannot write JSON to %s:@ %a\n%!" + "ERROR while Handling %a,@ cannot write JSON to %s:@ %s\n%!" pp () file_path - Error_monad.pp_print_error - el) + (Printexc.to_string exc)) (function | e -> failwith @@ -572,7 +571,8 @@ module Query = struct >>=? fun user_return -> return (fst previous, user_return) with e -> return_with_error previous (`Parsing_event (`Encoding (path, e))) ) - | Error el -> + | Error exc -> + let el = TzTrace.make @@ Exn exc in return_with_error previous (`Parsing_event (`Json (path, el))) in fold_event_kind_directory diff --git a/src/lib_stdlib_unix/internal_event_unix.ml b/src/lib_stdlib_unix/internal_event_unix.ml index 5a4b947b828f..d1fa6cf9acdd 100644 --- a/src/lib_stdlib_unix/internal_event_unix.ml +++ b/src/lib_stdlib_unix/internal_event_unix.ml @@ -45,6 +45,7 @@ module Configuration = struct let of_file path = Lwt_utils_unix.Json.read_file path + >|= Error_monad.tzresult_of_exn_result >>=? fun json -> protect (fun () -> return (Data_encoding.Json.destruct encoding json)) diff --git a/src/lib_stdlib_unix/lwt_utils_unix.ml b/src/lib_stdlib_unix/lwt_utils_unix.ml index 248a83673079..05617959293e 100644 --- a/src/lib_stdlib_unix/lwt_utils_unix.ml +++ b/src/lib_stdlib_unix/lwt_utils_unix.ml @@ -24,9 +24,10 @@ (* *) (*****************************************************************************) -open Error_monad +open Lwt.Infix let () = + let open Error_monad in register_error_kind `Temporary ~id:"unix_error" @@ -175,10 +176,7 @@ let rec create_dir ?(perm = 0o755) dir = | _ -> Stdlib.failwith "Not a directory" ) -let safe_close fd = - Lwt.catch - (fun () -> Lwt_unix.close fd >>= fun () -> return_unit) - (fun exc -> fail (Exn exc)) +let safe_close fd = Lwt_result.catch (Lwt_unix.close fd) let create_file ?(close_on_exec = true) ?(perm = 0o644) name content = let flags = @@ -193,16 +191,16 @@ let create_file ?(close_on_exec = true) ?(perm = 0o644) name content = (fun v -> safe_close fd >>= function - | Error trace -> - Format.eprintf "Uncaught error: %a\n%!" pp_print_error trace ; + | Error exc -> + Format.eprintf "Uncaught error: %s\n%!" (Printexc.to_string exc) ; Lwt.return v | Ok () -> Lwt.return v) (fun exc -> safe_close fd >>= function - | Error trace -> - Format.eprintf "Uncaught error: %a\n%!" pp_print_error trace ; + | Error exc -> + Format.eprintf "Uncaught error: %s\n%!" (Printexc.to_string exc) ; raise exc | Ok () -> raise exc) @@ -296,17 +294,16 @@ module Json = struct let write_file file json = let json = to_root json in - protect (fun () -> - Lwt_io.with_file ~mode:Output file (fun chan -> - let str = Data_encoding.Json.to_string ~minify:false json in - Lwt_io.write chan str >|= ok)) + Lwt_result.catch + (Lwt_io.with_file ~mode:Output file (fun chan -> + let str = Data_encoding.Json.to_string ~minify:false json in + Lwt_io.write chan str)) let read_file file = - protect (fun () -> - Lwt_io.with_file ~mode:Input file (fun chan -> - Lwt_io.read chan - >>= fun str -> - return (Ezjsonm.from_string str :> Data_encoding.json))) + Lwt_result.catch + (Lwt_io.with_file ~mode:Input file (fun chan -> + Lwt_io.read chan + >|= fun str -> (Ezjsonm.from_string str :> Data_encoding.json))) end let with_tempdir name f = @@ -336,6 +333,8 @@ type 'action io_error = { arg : string; } +let ( >>=? ) = Lwt_result.bind + let with_open_file ~flags ?(perm = 0o640) filename task = Lwt.catch (fun () -> @@ -345,19 +344,16 @@ let with_open_file ~flags ?(perm = 0o640) filename task = Lwt.return (Error {action = `Open; unix_code; caller; arg}) | exn -> raise exn) - >>= function - | Error _ as x -> - Lwt.return x - | Ok fd -> - task fd - >>= fun res -> - Lwt.catch - (fun () -> Lwt_unix.close fd >>= fun () -> return res) - (function - | Unix.Unix_error (unix_code, caller, arg) -> - Lwt.return (Error {action = `Close; unix_code; caller; arg}) - | exn -> - raise exn) + >>=? fun fd -> + task fd + >>= fun res -> + Lwt.catch + (fun () -> Lwt_unix.close fd >|= fun () -> Ok res) + (function + | Unix.Unix_error (unix_code, caller, arg) -> + Lwt.return (Error {action = `Close; unix_code; caller; arg}) + | exn -> + raise exn) let with_open_out ?(overwrite = true) file task = let flags = diff --git a/src/lib_stdlib_unix/lwt_utils_unix.mli b/src/lib_stdlib_unix/lwt_utils_unix.mli index 1ce14d6fb2bc..0c505d2a2356 100644 --- a/src/lib_stdlib_unix/lwt_utils_unix.mli +++ b/src/lib_stdlib_unix/lwt_utils_unix.mli @@ -24,8 +24,6 @@ (* *) (*****************************************************************************) -open Error_monad - (** [default_net_timeout] is the default timeout used by functions in this library which admit a timeout value, i.e. [read_bytes_with_timeout], [Socket.connect], [Socket.recv]. *) @@ -99,7 +97,7 @@ val create_file : val with_tempdir : string -> (string -> 'a Lwt.t) -> 'a Lwt.t -val safe_close : Lwt_unix.file_descr -> unit tzresult Lwt.t +val safe_close : Lwt_unix.file_descr -> (unit, exn) result Lwt.t val getaddrinfo : passive:bool -> @@ -113,10 +111,10 @@ val getpass : unit -> string module Json : sig (** Loads a JSON file in memory *) - val read_file : string -> Data_encoding.json tzresult Lwt.t + val read_file : string -> (Data_encoding.json, exn) result Lwt.t (** (Over)write a JSON file from in memory data *) - val write_file : string -> Data_encoding.json -> unit tzresult Lwt.t + val write_file : string -> Data_encoding.json -> (unit, exn) result Lwt.t end val retry : diff --git a/src/lib_store/legacy_store/legacy_store_builder.ml b/src/lib_store/legacy_store/legacy_store_builder.ml index 97bfeeee6efa..70c11f0bf711 100644 --- a/src/lib_store/legacy_store/legacy_store_builder.ml +++ b/src/lib_store/legacy_store/legacy_store_builder.ml @@ -122,6 +122,7 @@ let generate identity_file pow = Lwt_utils_unix.Json.write_file identity_file (Data_encoding.Json.construct P2p_identity.encoding id) + >|= tzresult_of_exn_result >>=? fun () -> return_unit let dump_config data_dir = @@ -135,6 +136,7 @@ let dump_config data_dir = Lwt_utils_unix.Json.write_file version_file (Data_encoding.Json.construct version_encoding data_version) + >|= tzresult_of_exn_result in write_version_file data_dir >>=? fun () -> diff --git a/src/lib_store/snapshots.ml b/src/lib_store/snapshots.ml index a991894cd1a6..c486cd0db330 100644 --- a/src/lib_store/snapshots.ml +++ b/src/lib_store/snapshots.ml @@ -2482,6 +2482,7 @@ module Raw_loader : LOADER = struct Data_encoding.Json.destruct metadata_encoding json in Lwt_utils_unix.Json.read_file metadata_file + >|= tzresult_of_exn_result >>=? fun json -> return (read_config json) let close _ = Lwt.return_unit @@ -2630,6 +2631,7 @@ module Raw_importer : IMPORTER = struct Data_encoding.Json.destruct metadata_encoding json in Lwt_utils_unix.Json.read_file metadata_file + >|= tzresult_of_exn_result >>=? fun json -> return (read_config json) let load_block_data t = diff --git a/src/proto_000_Ps9mPmXa/lib_client/client_proto_main.ml b/src/proto_000_Ps9mPmXa/lib_client/client_proto_main.ml index e3fe4cf71a83..4029b5ed2f9d 100644 --- a/src/proto_000_Ps9mPmXa/lib_client/client_proto_main.ml +++ b/src/proto_000_Ps9mPmXa/lib_client/client_proto_main.ml @@ -136,6 +136,7 @@ let commands () = (cctxt : Client_context.full) -> let fitness = fitness_from_int64 fitness in Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file param_json_file + >|= tzresult_of_exn_result >>=? fun json -> let protocol_parameters = Data_encoding.Binary.to_bytes_exn Data_encoding.json json diff --git a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml index a6323f059444..e693bf5c67e4 100644 --- a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml @@ -69,9 +69,10 @@ let json_file_or_text_parameter = | ["text"; text] -> return (Ezjsonm.from_string text) | ["file"; path] -> - Lwt_utils_unix.Json.read_file path + Lwt_utils_unix.Json.read_file path >|= tzresult_of_exn_result | _ -> ( - if Sys.file_exists p then Lwt_utils_unix.Json.read_file p + if Sys.file_exists p then + Lwt_utils_unix.Json.read_file p >|= tzresult_of_exn_result else try return (Ezjsonm.from_string p) with Ezjsonm.Parse_error _ -> diff --git a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml index cdafa53cb67b..af1d807b28b8 100644 --- a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml @@ -69,9 +69,10 @@ let json_file_or_text_parameter = | ["text"; text] -> return (Ezjsonm.from_string text) | ["file"; path] -> - Lwt_utils_unix.Json.read_file path + Lwt_utils_unix.Json.read_file path >|= tzresult_of_exn_result | _ -> ( - if Sys.file_exists p then Lwt_utils_unix.Json.read_file p + if Sys.file_exists p then + Lwt_utils_unix.Json.read_file p >|= tzresult_of_exn_result else try return (Ezjsonm.from_string p) with Ezjsonm.Parse_error _ -> diff --git a/src/proto_008_PtEdo2Zk/lib_client_sapling/client_sapling_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_sapling/client_sapling_commands.ml index 0e87dd733e6d..026ee8a7b67d 100644 --- a/src/proto_008_PtEdo2Zk/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_sapling/client_sapling_commands.ml @@ -499,6 +499,7 @@ let submit_shielded_cmd = let open Context in ( if use_json_format then Lwt_utils_unix.Json.read_file filename + >|= tzresult_of_exn_result >>=? fun json -> return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json else diff --git a/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_forge.ml b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_forge.ml index c5c40f9ae693..b5f0b25f1550 100644 --- a/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_forge.ml +++ b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_forge.ml @@ -496,6 +496,7 @@ let unopt_operations cctxt chain mempool = function return ops | Some file -> Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file file + >|= tzresult_of_exn_result >>=? fun json -> let mpool = Data_encoding.Json.destruct diff --git a/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml b/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml index e1fb772e0676..09eef38a7b5f 100644 --- a/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml @@ -69,9 +69,10 @@ let json_file_or_text_parameter = | ["text"; text] -> return (Ezjsonm.from_string text) | ["file"; path] -> - Lwt_utils_unix.Json.read_file path + Lwt_utils_unix.Json.read_file path >|= tzresult_of_exn_result | _ -> ( - if Sys.file_exists p then Lwt_utils_unix.Json.read_file p + if Sys.file_exists p then + Lwt_utils_unix.Json.read_file p >|= tzresult_of_exn_result else try return (Ezjsonm.from_string p) with Ezjsonm.Parse_error _ -> diff --git a/src/proto_009_PsFLoren/lib_client_sapling/client_sapling_commands.ml b/src/proto_009_PsFLoren/lib_client_sapling/client_sapling_commands.ml index ca3b8647d059..680f73e494d7 100644 --- a/src/proto_009_PsFLoren/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_009_PsFLoren/lib_client_sapling/client_sapling_commands.ml @@ -499,6 +499,7 @@ let submit_shielded_cmd = let open Context in ( if use_json_format then Lwt_utils_unix.Json.read_file filename + >|= tzresult_of_exn_result >>=? fun json -> return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json else diff --git a/src/proto_009_PsFLoren/lib_delegate/client_baking_forge.ml b/src/proto_009_PsFLoren/lib_delegate/client_baking_forge.ml index 7bc030f5df4a..97316e470cfe 100644 --- a/src/proto_009_PsFLoren/lib_delegate/client_baking_forge.ml +++ b/src/proto_009_PsFLoren/lib_delegate/client_baking_forge.ml @@ -494,6 +494,7 @@ let unopt_operations cctxt chain mempool = function return ops | Some file -> Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file file + >|= tzresult_of_exn_result >>=? fun json -> let mpool = Data_encoding.Json.destruct diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index e1fb772e0676..09eef38a7b5f 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -69,9 +69,10 @@ let json_file_or_text_parameter = | ["text"; text] -> return (Ezjsonm.from_string text) | ["file"; path] -> - Lwt_utils_unix.Json.read_file path + Lwt_utils_unix.Json.read_file path >|= tzresult_of_exn_result | _ -> ( - if Sys.file_exists p then Lwt_utils_unix.Json.read_file p + if Sys.file_exists p then + Lwt_utils_unix.Json.read_file p >|= tzresult_of_exn_result else try return (Ezjsonm.from_string p) with Ezjsonm.Parse_error _ -> diff --git a/src/proto_alpha/lib_client_sapling/client_sapling_commands.ml b/src/proto_alpha/lib_client_sapling/client_sapling_commands.ml index ca3b8647d059..680f73e494d7 100644 --- a/src/proto_alpha/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_alpha/lib_client_sapling/client_sapling_commands.ml @@ -499,6 +499,7 @@ let submit_shielded_cmd = let open Context in ( if use_json_format then Lwt_utils_unix.Json.read_file filename + >|= tzresult_of_exn_result >>=? fun json -> return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json else diff --git a/src/proto_alpha/lib_delegate/client_baking_forge.ml b/src/proto_alpha/lib_delegate/client_baking_forge.ml index b0ccfc7cfa52..514d5751c850 100644 --- a/src/proto_alpha/lib_delegate/client_baking_forge.ml +++ b/src/proto_alpha/lib_delegate/client_baking_forge.ml @@ -500,6 +500,7 @@ let unopt_operations cctxt chain mempool = function return ops | Some file -> Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file file + >|= tzresult_of_exn_result >>=? fun json -> let mpool = Data_encoding.Json.destruct diff --git a/src/proto_genesis/lib_client/client_proto_main.ml b/src/proto_genesis/lib_client/client_proto_main.ml index 6bc3af382dc1..9667581780dd 100644 --- a/src/proto_genesis/lib_client/client_proto_main.ml +++ b/src/proto_genesis/lib_client/client_proto_main.ml @@ -145,6 +145,7 @@ let commands () = (cctxt : Client_context.full) -> let fitness = fitness_from_int64 fitness in Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file param_json_file + >|= tzresult_of_exn_result >>=? fun json -> let protocol_parameters = Data_encoding.Binary.to_bytes_exn Data_encoding.json json @@ -182,6 +183,7 @@ let commands () = (fun (timestamp, delay) hash fitness sk param_json_file cctxt -> let fitness = fitness_from_int64 fitness in Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file param_json_file + >|= tzresult_of_exn_result >>=? fun json -> let protocol_parameters = Data_encoding.Binary.to_bytes_exn Data_encoding.json json diff --git a/src/proto_genesis_carthagenet/lib_client/client_proto_main.ml b/src/proto_genesis_carthagenet/lib_client/client_proto_main.ml index e49bc5205298..2d4a14b03baf 100644 --- a/src/proto_genesis_carthagenet/lib_client/client_proto_main.ml +++ b/src/proto_genesis_carthagenet/lib_client/client_proto_main.ml @@ -149,6 +149,7 @@ let commands () = (cctxt : Client_context.full) -> let fitness = fitness_from_int64 fitness in Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file param_json_file + >|= tzresult_of_exn_result >>=? fun json -> let protocol_parameters = Data_encoding.Binary.to_bytes_exn Data_encoding.json json @@ -186,6 +187,7 @@ let commands () = (fun (timestamp, delay) hash fitness sk param_json_file cctxt -> let fitness = fitness_from_int64 fitness in Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file param_json_file + >|= tzresult_of_exn_result >>=? fun json -> let protocol_parameters = Data_encoding.Binary.to_bytes_exn Data_encoding.json json -- GitLab From eae56fbc77cb95bf8712e13d2e6e9bf8846c7fb1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 20 Apr 2021 14:46:53 +0200 Subject: [PATCH 2/2] Stdlib/lwt_lock: replace tzresult with exn-results --- src/bin_node/node_reconstruct_command.ml | 1 + src/bin_node/node_replay_command.ml | 2 + src/bin_node/node_run_command.ml | 2 + src/bin_node/node_snapshot_command.ml | 1 + src/bin_node/node_upgrade_command.ml | 7 +-- src/bin_signer/main_signer.ml | 3 +- src/lib_stdlib_unix/lwt_lock_file.ml | 52 +++++++++---------- src/lib_stdlib_unix/lwt_lock_file.mli | 9 ++-- .../lib_delegate/delegate_commands.ml | 3 +- .../lib_delegate/delegate_commands.ml | 3 +- .../lib_delegate/delegate_commands.ml | 3 +- 11 files changed, 49 insertions(+), 37 deletions(-) diff --git a/src/bin_node/node_reconstruct_command.ml b/src/bin_node/node_reconstruct_command.ml index c386250d13f8..4ffac3422fe4 100644 --- a/src/bin_node/node_reconstruct_command.ml +++ b/src/bin_node/node_reconstruct_command.ml @@ -71,6 +71,7 @@ module Term = struct return_some ("sandbox_parameter", json) ) ) >>=? fun sandbox_parameters -> Lwt_lock_file.is_locked (Node_data_version.lock_file data_dir) + >|= tzresult_of_exn_result >>=? fun is_locked -> fail_when is_locked Locked_directory >>=? fun () -> diff --git a/src/bin_node/node_replay_command.ml b/src/bin_node/node_replay_command.ml index 667a90f9ed9e..0804ce85829a 100644 --- a/src/bin_node/node_replay_command.ml +++ b/src/bin_node/node_replay_command.ml @@ -362,6 +362,7 @@ let run ?verbosity ~singleprocess (config : Node_config_file.t) block = Node_data_version.ensure_data_dir config.data_dir >>=? fun () -> Lwt_lock_file.is_locked (Node_data_version.lock_file config.data_dir) + >|= tzresult_of_exn_result >>=? (function | true -> failwith "Data directory is locked by another process" @@ -371,6 +372,7 @@ let run ?verbosity ~singleprocess (config : Node_config_file.t) block = Lwt_lock_file.create ~unlink_on_exit:true (Node_data_version.lock_file config.data_dir) + >|= tzresult_of_exn_result >>=? fun () -> (* Main loop *) let log_cfg = diff --git a/src/bin_node/node_run_command.ml b/src/bin_node/node_run_command.ml index e7f98d462642..27aea72637d0 100644 --- a/src/bin_node/node_run_command.ml +++ b/src/bin_node/node_run_command.ml @@ -402,6 +402,7 @@ let run ?verbosity ?sandbox ?target ~singleprocess ~force_history_mode_switch Lwt_lock_file.create ~unlink_on_exit:true (Node_data_version.lock_file config.data_dir) + >|= tzresult_of_exn_result >>=? fun () -> (* Main loop *) let log_cfg = @@ -508,6 +509,7 @@ let process sandbox verbosity target singleprocess force_history_mode_switch value was expected.") ) >>=? fun target -> Lwt_lock_file.is_locked (Node_data_version.lock_file config.data_dir) + >|= tzresult_of_exn_result >>=? function | false -> Lwt.catch diff --git a/src/bin_node/node_snapshot_command.ml b/src/bin_node/node_snapshot_command.ml index b765d2437b37..678c808b3963 100644 --- a/src/bin_node/node_snapshot_command.ml +++ b/src/bin_node/node_snapshot_command.ml @@ -208,6 +208,7 @@ module Term = struct Lwt_lock_file.create ~unlink_on_exit:true (Node_data_version.lock_file data_dir) + >|= tzresult_of_exn_result >>=? fun () -> ( match (node_config.blockchain_network.genesis_parameters, sandbox_file) diff --git a/src/bin_node/node_upgrade_command.ml b/src/bin_node/node_upgrade_command.ml index dc71e6a29f00..6e391ab9796a 100644 --- a/src/bin_node/node_upgrade_command.ml +++ b/src/bin_node/node_upgrade_command.ml @@ -57,9 +57,10 @@ module Term = struct trace (failure "Fail to lock the data directory. Is a `tezos-node` running?") - @@ Lwt_lock_file.create - ~unlink_on_exit:true - (Node_data_version.lock_file data_dir) + @@ ( Lwt_lock_file.create + ~unlink_on_exit:true + (Node_data_version.lock_file data_dir) + >|= tzresult_of_exn_result ) >>=? fun () -> Node_data_version.upgrade_data_dir ~data_dir diff --git a/src/bin_signer/main_signer.ml b/src/bin_signer/main_signer.ml index 9c3853d05aec..e7115e264a6d 100644 --- a/src/bin_signer/main_signer.ml +++ b/src/bin_signer/main_signer.ml @@ -114,7 +114,8 @@ let may_setup_pidfile = function return_unit | Some pidfile -> trace (failure "Failed to create the pidfile: %s" pidfile) - @@ Lwt_lock_file.create ~unlink_on_exit:true pidfile + @@ ( Lwt_lock_file.create ~unlink_on_exit:true pidfile + >|= tzresult_of_exn_result ) let commands base_dir require_auth : Client_context.full command list = Tezos_signer_backends_unix.Ledger.commands () diff --git a/src/lib_stdlib_unix/lwt_lock_file.ml b/src/lib_stdlib_unix/lwt_lock_file.ml index 47ec04e3218a..7ef2240c980d 100644 --- a/src/lib_stdlib_unix/lwt_lock_file.ml +++ b/src/lib_stdlib_unix/lwt_lock_file.ml @@ -24,34 +24,34 @@ (* *) (*****************************************************************************) -open Error_monad +open Lwt.Infix let create ?(close_on_exec = true) ?(unlink_on_exit = false) fn = - protect (fun () -> - let flags = - let open Unix in - let flags = [O_TRUNC; O_CREAT; O_WRONLY] in - if close_on_exec then O_CLOEXEC :: flags else flags - in - Lwt_unix.openfile fn flags 0o644 - >>= fun fd -> - Lwt_unix.lockf fd Unix.F_TLOCK 0 - >>= fun () -> - if unlink_on_exit then Lwt_main.at_exit (fun () -> Lwt_unix.unlink fn) ; - let pid_str = string_of_int @@ Unix.getpid () in - Lwt_unix.write_string fd pid_str 0 (String.length pid_str) - >>= fun _ -> return_unit) + Lwt_result.catch + (let flags = + let open Unix in + let flags = [O_TRUNC; O_CREAT; O_WRONLY] in + if close_on_exec then O_CLOEXEC :: flags else flags + in + Lwt_unix.openfile fn flags 0o644 + >>= fun fd -> + Lwt_unix.lockf fd Unix.F_TLOCK 0 + >>= fun () -> + if unlink_on_exit then Lwt_main.at_exit (fun () -> Lwt_unix.unlink fn) ; + let pid_str = string_of_int @@ Unix.getpid () in + Lwt_unix.write_string fd pid_str 0 (String.length pid_str) + >>= fun _ -> Lwt.return_unit) let is_locked fn = - if not @@ Sys.file_exists fn then return_false + if not @@ Sys.file_exists fn then Lwt.return_ok false else - protect (fun () -> - Lwt_unix.openfile fn Unix.[O_RDONLY; O_CLOEXEC] 0o644 - >>= fun fd -> - Lwt.finalize - (fun () -> - Lwt.try_bind - (fun () -> Lwt_unix.(lockf fd F_TEST 0)) - (fun () -> return_false) - (fun _ -> return_true)) - (fun () -> Lwt_unix.close fd)) + Lwt_result.catch + ( Lwt_unix.openfile fn Unix.[O_RDONLY; O_CLOEXEC] 0o644 + >>= fun fd -> + Lwt.finalize + (fun () -> + Lwt.try_bind + (fun () -> Lwt_unix.(lockf fd F_TEST 0)) + (fun () -> Lwt.return_false) + (fun _ -> Lwt.return_true)) + (fun () -> Lwt_unix.close fd) ) diff --git a/src/lib_stdlib_unix/lwt_lock_file.mli b/src/lib_stdlib_unix/lwt_lock_file.mli index a3b8f30391d4..e8f8cc164887 100644 --- a/src/lib_stdlib_unix/lwt_lock_file.mli +++ b/src/lib_stdlib_unix/lwt_lock_file.mli @@ -23,9 +23,10 @@ (* *) (*****************************************************************************) -open Error_monad - val create : - ?close_on_exec:bool -> ?unlink_on_exit:bool -> string -> unit tzresult Lwt.t + ?close_on_exec:bool -> + ?unlink_on_exit:bool -> + string -> + (unit, exn) result Lwt.t -val is_locked : string -> bool tzresult Lwt.t +val is_locked : string -> (bool, exn) result Lwt.t diff --git a/src/proto_008_PtEdo2Zk/lib_delegate/delegate_commands.ml b/src/proto_008_PtEdo2Zk/lib_delegate/delegate_commands.ml index f7bcf06e678c..27819f04b371 100644 --- a/src/proto_008_PtEdo2Zk/lib_delegate/delegate_commands.ml +++ b/src/proto_008_PtEdo2Zk/lib_delegate/delegate_commands.ml @@ -68,7 +68,8 @@ let may_lock_pidfile = function return_unit | Some pidfile -> trace (failure "Failed to create the pidfile: %s" pidfile) - @@ Lwt_lock_file.create ~unlink_on_exit:true pidfile + @@ ( Lwt_lock_file.create ~unlink_on_exit:true pidfile + >|= tzresult_of_exn_result ) let block_param t = Clic.param diff --git a/src/proto_009_PsFLoren/lib_delegate/delegate_commands.ml b/src/proto_009_PsFLoren/lib_delegate/delegate_commands.ml index f7bcf06e678c..27819f04b371 100644 --- a/src/proto_009_PsFLoren/lib_delegate/delegate_commands.ml +++ b/src/proto_009_PsFLoren/lib_delegate/delegate_commands.ml @@ -68,7 +68,8 @@ let may_lock_pidfile = function return_unit | Some pidfile -> trace (failure "Failed to create the pidfile: %s" pidfile) - @@ Lwt_lock_file.create ~unlink_on_exit:true pidfile + @@ ( Lwt_lock_file.create ~unlink_on_exit:true pidfile + >|= tzresult_of_exn_result ) let block_param t = Clic.param diff --git a/src/proto_alpha/lib_delegate/delegate_commands.ml b/src/proto_alpha/lib_delegate/delegate_commands.ml index f7bcf06e678c..27819f04b371 100644 --- a/src/proto_alpha/lib_delegate/delegate_commands.ml +++ b/src/proto_alpha/lib_delegate/delegate_commands.ml @@ -68,7 +68,8 @@ let may_lock_pidfile = function return_unit | Some pidfile -> trace (failure "Failed to create the pidfile: %s" pidfile) - @@ Lwt_lock_file.create ~unlink_on_exit:true pidfile + @@ ( Lwt_lock_file.create ~unlink_on_exit:true pidfile + >|= tzresult_of_exn_result ) let block_param t = Clic.param -- GitLab