From b0fb5a5814f865cfb7b45dfcb6f36491bd4500af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 12 Jul 2021 12:13:00 +0200 Subject: [PATCH 01/10] Everywhere: avoid catch-all pattern --- src/bin_signer/main_signer.ml | 2 +- src/bin_snoop/commands.ml | 77 ++++++++++--------- src/lib_base/time.ml | 21 ++--- src/lib_clic/clic.ml | 10 +-- src/lib_client_base_unix/client_config.ml | 7 +- .../client_event_logging_commands.ml | 16 ++-- src/lib_crypto/pvss_secp256k1.ml | 2 +- src/lib_crypto/secp256k1.ml | 2 +- src/lib_crypto/secp256k1_group.ml | 9 +-- src/lib_crypto/signature.ml | 2 +- src/lib_crypto/znz.ml | 2 +- src/lib_protocol_compiler/replace.ml | 4 +- .../proxy_server_config.ml | 2 +- src/lib_sapling/core.ml | 7 +- src/lib_shell/prevalidation.ml | 8 +- .../unix/ledger.available.ml | 31 ++++---- src/lib_stdlib_unix/file_descriptor_sink.ml | 9 ++- 17 files changed, 105 insertions(+), 106 deletions(-) diff --git a/src/bin_signer/main_signer.ml b/src/bin_signer/main_signer.ml index 556d514cc2f8..c2b00cfc78a6 100644 --- a/src/bin_signer/main_signer.ml +++ b/src/bin_signer/main_signer.ml @@ -73,7 +73,7 @@ let magic_bytes_arg = let b = int_of_string s in if b < 0 || b > 255 then raise Exit else b) (String.split ',' s)) - with _ -> + with Failure _ | Exit | Invalid_argument _ -> failwith "Bad format for magic bytes, a series of numbers is expected, \ separated by commas.")) diff --git a/src/bin_snoop/commands.ml b/src/bin_snoop/commands.ml index 09d11d34ece4..61aacfe68983 100644 --- a/src/bin_snoop/commands.ml +++ b/src/bin_snoop/commands.ml @@ -28,6 +28,14 @@ open Cmdline let lift_opt f opt_arg state = match opt_arg with None -> state | Some arg -> f arg state +let parse_parameter f m = + Clic.parameter (fun (_ : unit) p -> + Lwt.return + @@ + match f p with + | Some x -> Ok x + | None -> Error (Error_monad.error_of_exn (Failure m))) + module Benchmark_cmd = struct (* ----------------------------------------------------------------------- *) (* Handling the options of the benchmarker *) @@ -142,11 +150,10 @@ module Benchmark_cmd = struct Parmeter: size in megabytes of the cache. *) let flush_cache_arg = let flush_cache_arg_param = - Clic.parameter (fun (_ : unit) parsed -> - try return (`Cache_megabytes (int_of_string parsed)) - with _ -> - Printf.eprintf "Error while parsing --flush-cache argument." ; - exit 1) + parse_parameter + (fun p -> + Option.map (fun p -> `Cache_megabytes p) (int_of_string_opt p)) + "Error while parsing --flush-cache argument." in Clic.arg ~doc:"Force flushing the cache before each measurement" @@ -176,7 +183,9 @@ module Benchmark_cmd = struct in match String.split_on_char '@' s with | ["percentile"; i] -> - let i = try int_of_string i with _ -> error () in + let i = + Option.value_f (int_of_string_opt i) ~default:error + in if i < 1 || i > 100 then error () else return (Percentile i) | _ -> error ())) in @@ -190,11 +199,9 @@ module Benchmark_cmd = struct Parameter: Id of the CPU where to preferentially pin the benchmark *) let cpu_affinity_arg = let cpu_affinity_arg_param = - Clic.parameter (fun (_ : unit) parsed -> - try return (int_of_string parsed) - with _ -> - Printf.eprintf "Error while parsing --cpu-affinity argument." ; - exit 1) + parse_parameter + int_of_string_opt + "Error while parsing --cpu-affinity argument." in Clic.arg ~doc:"Sets CPU affinity" @@ -205,11 +212,9 @@ module Benchmark_cmd = struct (* Integer argument --nsamples *) let nsamples_arg = let nsamples_arg_param = - Clic.parameter (fun (_ : unit) parsed -> - try return (int_of_string parsed) - with _ -> - Printf.eprintf "Error while parsing --nsamples argument." ; - exit 1) + parse_parameter + int_of_string_opt + "Error while parsing --nsamples argument." in Clic.arg ~doc:"Number of samples per benchmark" @@ -220,11 +225,7 @@ module Benchmark_cmd = struct (* Integer argument --seed *) let seed_arg = let seed = - Clic.parameter (fun (_ : unit) parsed -> - try return (int_of_string parsed) - with _ -> - Printf.eprintf "Error while parsing --seed argument." ; - exit 1) + parse_parameter int_of_string_opt "Error while parsing --seed argument." in Clic.arg ~doc:"RNG seed" ~long:"seed" ~placeholder:"int" seed @@ -244,7 +245,9 @@ module Benchmark_cmd = struct Parameter: Number of random stacks to generate. *) let bench_number_arg = let bench_number_param = - Clic.parameter (fun (_ : unit) parsed -> return (int_of_string parsed)) + parse_parameter + int_of_string_opt + "Error while parsing --bench-num argument." in Clic.arg ~doc:"Number of benchmarks (i.e. random stacks)" @@ -256,8 +259,9 @@ module Benchmark_cmd = struct Parameter: size of minor heap in kb. *) let minor_heap_size_arg = let minor_heap_size_param = - Clic.parameter (fun (_ : unit) parsed -> - return (`words (int_of_string parsed))) + parse_parameter + (fun s -> Option.map (fun p -> `words p) (int_of_string_opt s)) + "Error while parsing --minor-heap-size argument." in Clic.arg ~doc:"Size of minor heap in words" @@ -416,11 +420,9 @@ module Infer_cmd = struct (* Float argument --ridge-alpha *) let ridge_alpha_arg = let ridge_alpha_arg_param = - Clic.parameter (fun (_ : unit) parsed -> - try return (float_of_string parsed) - with _ -> - Printf.eprintf "Error while parsing --ridge-alpha argument." ; - exit 1) + parse_parameter + float_of_string_opt + "Error while parsing --ridge-alpha argument." in Clic.arg ~doc:"Regularization parameter for ridge regression" @@ -431,11 +433,9 @@ module Infer_cmd = struct (* Float argument --lasso-alpha *) let lasso_alpha_arg = let lasso_alpha_arg_param = - Clic.parameter (fun (_ : unit) parsed -> - try return (float_of_string parsed) - with _ -> - Printf.eprintf "Error while parsing --lasso-alpha argument." ; - exit 1) + parse_parameter + float_of_string_opt + "Error while parsing --lasso-alpha argument." in Clic.arg ~doc:"Regularization parameter for lasso regression" @@ -568,10 +568,11 @@ module Cull_outliers_cmd = struct let cull_handler () workload_data sigmas save_file () = let nsigmas = - try float_of_string sigmas - with _ -> - Printf.eprintf "Could not parse back float value for nsigmas.\n" ; - exit 1 + match float_of_string_opt sigmas with + | Some s -> s + | None -> + Printf.eprintf "Could not parse back float value for nsigmas.\n" ; + exit 1 in commandline_outcome_ref := Some (Cull_outliers {workload_data; nsigmas; save_file}) ; diff --git a/src/lib_base/time.ml b/src/lib_base/time.ml index 17cd93a597d6..433d55ab8d23 100644 --- a/src/lib_base/time.ml +++ b/src/lib_base/time.ml @@ -123,9 +123,9 @@ module Protocol = struct ~destruct:(function | "none" | "epoch" -> Ok epoch | s -> ( - match Int64.of_string s with - | t -> Ok t - | exception _ -> + match Int64.of_string_opt s with + | Some t -> Ok t + | None -> Error (Format.asprintf "failed to parse time (epoch): %S" s))) ~construct:Int64.to_string () @@ -178,11 +178,14 @@ module System = struct ~name:"timespan" ~descr:"A span of time in seconds" ~destruct:(fun s -> - match Ptime.Span.of_float_s (float_of_string s) with - | Some t -> Ok t - | None -> Error (Format.asprintf "failed to parse timespan: %S" s) - | exception _ -> - Error (Format.asprintf "failed to parse timespan: %S" s)) + match float_of_string s with + | exception Failure _ -> + Error (Format.asprintf "failed to parse timespan: %S" s) + | f -> ( + match Ptime.Span.of_float_s f with + | Some t -> Ok t + | None -> Error (Format.asprintf "failed to parse timespan: %S" s) + )) ~construct:(fun s -> string_of_float (Ptime.Span.to_float_s s)) () end @@ -278,7 +281,7 @@ module System = struct | None -> ( match of_seconds_exn (Int64.of_string s) with | t -> Ok t - | exception _ -> + | (exception Failure _) | (exception Invalid_argument _) -> Error (Format.asprintf "failed to parse time (epoch): %S" s) ))) ~construct:to_notation diff --git a/src/lib_clic/clic.ml b/src/lib_clic/clic.ml index 0cdd7a3ad0c1..8162dce537e8 100644 --- a/src/lib_clic/clic.ml +++ b/src/lib_clic/clic.ml @@ -142,11 +142,11 @@ let trim s = let print_desc ppf doc = let (short, long) = - try - let len = String.index doc '\n' in - ( String.sub doc 0 len, - Some (String.sub doc (len + 1) (String.length doc - len - 1)) ) - with _ -> (doc, None) + match String.index_opt doc '\n' with + | None -> (doc, None) + | Some len -> + ( String.sub doc 0 len, + Some (String.sub doc (len + 1) (String.length doc - len - 1)) ) in match long with | None -> Format.fprintf ppf "%s" short diff --git a/src/lib_client_base_unix/client_config.ml b/src/lib_client_base_unix/client_config.ml index c0ad5c1e0be1..a74157bf6ecc 100644 --- a/src/lib_client_base_unix/client_config.ml +++ b/src/lib_client_base_unix/client_config.ml @@ -355,10 +355,9 @@ let wait_parameter () = match wait with | "no" | "none" -> return_none | _ -> ( - try - let w = int_of_string wait in - if 0 <= w then return_some w else fail (Invalid_wait_arg wait) - with _ -> fail (Invalid_wait_arg wait))) + match int_of_string_opt wait with + | Some w when 0 <= w -> return_some w + | None | Some _ -> fail (Invalid_wait_arg wait))) let protocol_parameter () = parameter (fun _ arg -> diff --git a/src/lib_client_commands/client_event_logging_commands.ml b/src/lib_client_commands/client_event_logging_commands.ml index 2bd48e012b8b..8988a87be904 100644 --- a/src/lib_client_commands/client_event_logging_commands.ml +++ b/src/lib_client_commands/client_event_logging_commands.ml @@ -88,19 +88,15 @@ let commands () = ~doc:"Filter on event names" ~long:"names" ~placeholder:"LIST" - (parameter (fun _ s -> - try return (String.split_on_char ',' s) - with _ -> failwith "List of names cannot be parsed"))) + (parameter (fun _ s -> return (String.split_on_char ',' s)))) (arg ~doc:"Filter on event sections (use '_' for no-section)" ~long:"sections" ~placeholder:"LIST" (parameter (fun _ s -> - try - return - (String.split_on_char ',' s - |> List.map (function "_" -> None | other -> Some other)) - with _ -> failwith "List of sections cannot be parsed"))) + return + (String.split_on_char ',' s + |> List.map (function "_" -> None | other -> Some other))))) (arg ~doc:"Filter out events before DATE" ~long:"since" @@ -121,9 +117,7 @@ let commands () = @@ param ~name:"Sink-Name" ~desc:"The URI of the SINK to query" - (parameter (fun _ s -> - try return (Uri.of_string s) - with _ -> failwith "Uri cannot be parsed")) + (parameter (fun _ s -> return (Uri.of_string s))) @@ stop) (fun ( only_names, only_sections, diff --git a/src/lib_crypto/pvss_secp256k1.ml b/src/lib_crypto/pvss_secp256k1.ml index 1c87d8471d36..fe7240b4a290 100644 --- a/src/lib_crypto/pvss_secp256k1.ml +++ b/src/lib_crypto/pvss_secp256k1.ml @@ -60,7 +60,7 @@ module G : Pvss.CYCLIC_GROUP = struct let pow x n = Group.mul n x - let of_bits b = try Some (Group.of_bits_exn b) with _ -> None + let of_bits b = Option.catch (fun () -> Group.of_bits_exn b) end include Pvss.MakePvss (G) diff --git a/src/lib_crypto/secp256k1.ml b/src/lib_crypto/secp256k1.ml index 707f1b53b5f9..275230395799 100644 --- a/src/lib_crypto/secp256k1.ml +++ b/src/lib_crypto/secp256k1.ml @@ -63,7 +63,7 @@ module Public_key = struct let to_bytes pk = Bigstring.to_bytes (Key.to_bytes context pk) let of_bytes_opt s = - try Some (Key.read_pk_exn context (Bigstring.of_bytes s)) with _ -> None + Option.catch (fun () -> Key.read_pk_exn context (Bigstring.of_bytes s)) let to_string s = Bytes.to_string (to_bytes s) diff --git a/src/lib_crypto/secp256k1_group.ml b/src/lib_crypto/secp256k1_group.ml index 3c058989a422..5186eb463209 100644 --- a/src/lib_crypto/secp256k1_group.ml +++ b/src/lib_crypto/secp256k1_group.ml @@ -188,7 +188,7 @@ end = struct ~prefix:Base58.Prefix.secp256k1_scalar ~length:32 ~to_raw:to_bits - ~of_raw:(fun s -> try Some (of_bits_exn s) with _ -> None) + ~of_raw:(fun s -> Option.catch (fun () -> of_bits_exn s)) ~wrap:(fun x -> Data x) let title = "Secp256k1_group.Scalar" @@ -310,7 +310,7 @@ end = struct ~prefix:Base58.Prefix.secp256k1_element ~length:33 ~to_raw:to_bits - ~of_raw:(fun s -> try Some (of_bits_exn s) with _ -> None) + ~of_raw:(fun s -> Option.catch (fun () -> of_bits_exn s)) ~wrap:(fun x -> Data x) include Helpers.MakeB58 (struct @@ -346,12 +346,11 @@ end = struct let to_bytes pk = to_bits pk |> Bytes.of_string - let of_bytes_opt s = - try Some (Bytes.to_string s |> of_bits_exn) with _ -> None + let of_bytes_opt s = Option.catch (fun () -> Bytes.to_string s |> of_bits_exn) let to_string = to_bits - let of_string_opt s = try Some (of_bits_exn s) with _ -> None + let of_string_opt s = Option.catch (fun () -> of_bits_exn s) let size = 37 diff --git a/src/lib_crypto/signature.ml b/src/lib_crypto/signature.ml index 5f78095ec61b..acf7de0e1f8a 100644 --- a/src/lib_crypto/signature.ml +++ b/src/lib_crypto/signature.ml @@ -633,7 +633,7 @@ let pp_watermark ppf = fprintf ppf "Custom: 0x%s" - (try String.sub hexed 0 10 ^ "..." with _ -> hexed) + (try String.sub hexed 0 10 ^ "..." with Invalid_argument _ -> hexed) let sign ?watermark secret_key message = let watermark = Option.map bytes_of_watermark watermark in diff --git a/src/lib_crypto/znz.ml b/src/lib_crypto/znz.ml index 842a8d4fd929..7dddc7379ad6 100644 --- a/src/lib_crypto/znz.ml +++ b/src/lib_crypto/znz.ml @@ -119,7 +119,7 @@ module MakeZn ~prefix:B.b58_prefix ~length:32 ~to_raw:to_bits - ~of_raw:(fun s -> try Some (of_bits_exn s) with _ -> None) + ~of_raw:(fun s -> Option.catch (fun () -> of_bits_exn s)) ~wrap:(fun x -> Data x) include Helpers.MakeB58 (struct diff --git a/src/lib_protocol_compiler/replace.ml b/src/lib_protocol_compiler/replace.ml index 9eb9ce6d7b64..af77d53efa13 100644 --- a/src/lib_protocol_compiler/replace.ml +++ b/src/lib_protocol_compiler/replace.ml @@ -148,7 +148,9 @@ let main () = let template = Sys.argv.(1) in let destination = Sys.argv.(2) in let final_protocol_file = Sys.argv.(3) in - let version = try Sys.argv.(4) with _ -> guess_version () in + let version = + try Sys.argv.(4) with Invalid_argument _ -> guess_version () + in let (hash, proto, check_hash) = read_proto destination final_protocol_file in process ~template ~destination proto version hash check_hash diff --git a/src/lib_proxy_server_config/proxy_server_config.ml b/src/lib_proxy_server_config/proxy_server_config.ml index 50f03bfc7296..c4a7adbb4baf 100644 --- a/src/lib_proxy_server_config/proxy_server_config.ml +++ b/src/lib_proxy_server_config/proxy_server_config.ml @@ -87,7 +87,7 @@ let destruct_config json = | cfg -> ( match sym_block_caching_time_error cfg.sym_block_caching_time with | Some err -> Invalid err - | _ -> Valid cfg) + | None -> Valid cfg) | exception _ -> CannotDeserialize let union_right_bias (t1 : t) (t2 : t) = diff --git a/src/lib_sapling/core.ml b/src/lib_sapling/core.ml index 73c60d1a4da0..32996a6d02b9 100644 --- a/src/lib_sapling/core.ml +++ b/src/lib_sapling/core.ml @@ -71,8 +71,7 @@ module Raw = struct dk : Bytes.t; } - let of_bytes b = - try Some (R.to_zip32_expanded_spending_key b) with _ -> None + let of_bytes b = Option.catch (fun () -> R.to_zip32_expanded_spending_key b) let to_bytes = R.of_zip32_expanded_spending_key @@ -206,7 +205,7 @@ module Raw = struct let to_bytes = R.of_zip32_full_viewing_key - let of_bytes b = try Some (R.to_zip32_full_viewing_key b) with _ -> None + let of_bytes b = Option.catch (fun () -> R.to_zip32_full_viewing_key b) let of_sk (sk : Spending_key.t) = Spending_key. @@ -423,7 +422,7 @@ module Raw = struct module CV = struct type t = R.cv - let of_bytes b = try Some (R.to_cv b) with _ -> None + let of_bytes b = Option.catch (fun () -> R.to_cv b) let encoding = let open Data_encoding in diff --git a/src/lib_shell/prevalidation.ml b/src/lib_shell/prevalidation.ml index 5d724ec68849..7cf1c9e8a390 100644 --- a/src/lib_shell/prevalidation.ml +++ b/src/lib_shell/prevalidation.ml @@ -78,11 +78,9 @@ end (** Doesn't depend on heavy [Registered_protocol.T] for testability. *) let safe_binary_of_bytes (encoding : 'a Data_encoding.t) (bytes : bytes) : 'a tzresult = - try - match Data_encoding.Binary.of_bytes_opt encoding bytes with - | None -> error Parse_error - | Some protocol_data -> ok protocol_data - with _ -> error Parse_error + match Data_encoding.Binary.of_bytes_opt encoding bytes with + | None -> error Parse_error + | Some protocol_data -> ok protocol_data module Make (Proto : Tezos_protocol_environment.PROTOCOL) : T with module Proto = Proto = struct diff --git a/src/lib_signer_backends/unix/ledger.available.ml b/src/lib_signer_backends/unix/ledger.available.ml index debce953383f..d96828a06785 100644 --- a/src/lib_signer_backends/unix/ledger.available.ml +++ b/src/lib_signer_backends/unix/ledger.available.ml @@ -348,21 +348,22 @@ module Ledger_uri = struct let int32_of_path_element_exn ~allow_weak x = let failf ppf = Printf.ksprintf Stdlib.failwith ppf in let len = String.length x in - match x.[len - 1] with - | exception _ -> failf "Empty path element" - | '\'' | 'h' -> ( - let intpart = String.sub x 0 (len - 1) in - match Int32.of_string_opt intpart with - | Some i -> Bip32_path.hard i - | None -> failf "Path is not an integer: %S" intpart) - | _ when allow_weak -> ( - match Int32.of_string_opt x with - | Some i -> i - | None -> failf "Path is not a non-hardened integer: %S" x) - | _ -> - failf - "Non-hardened paths are not allowed for this derivation scheme (%S)" - x + if len = 0 then failf "Empty path element" + else + match x.[len - 1] with + | '\'' | 'h' -> ( + let intpart = String.sub x 0 (len - 1) in + match Int32.of_string_opt intpart with + | Some i -> Bip32_path.hard i + | None -> failf "Path is not an integer: %S" intpart) + | _ when allow_weak -> ( + match Int32.of_string_opt x with + | Some i -> i + | None -> failf "Path is not a non-hardened integer: %S" x) + | _ -> + failf + "Non-hardened paths are not allowed for this derivation scheme (%S)" + x let parse_animals animals = match String.split '-' animals with diff --git a/src/lib_stdlib_unix/file_descriptor_sink.ml b/src/lib_stdlib_unix/file_descriptor_sink.ml index 88ce9efb501d..bcc4d13f7e23 100644 --- a/src/lib_stdlib_unix/file_descriptor_sink.ml +++ b/src/lib_stdlib_unix/file_descriptor_sink.ml @@ -99,9 +99,12 @@ end) : Internal_event.SINK with type t = t = struct let fresh = flag "fresh" in (match Uri.get_query_param uri "chmod" with | Some n -> ( - try return (int_of_string n) - with _ -> - fail_parsing "Access-rights parameter should be an integer: %S" n) + match int_of_string_opt n with + | Some i -> return i + | None -> + fail_parsing + "Access-rights parameter should be an integer: %S" + n) | None -> return 0o600) >>=? fun rights -> match Uri.path uri with -- GitLab From d4954d85e89f5c82e5427be011076d76c3353b33 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 12 Jul 2021 13:17:27 +0200 Subject: [PATCH 02/10] Signer: less exception, more result --- src/bin_signer/main_signer.ml | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/src/bin_signer/main_signer.ml b/src/bin_signer/main_signer.ml index c2b00cfc78a6..b2a6128cc07d 100644 --- a/src/bin_signer/main_signer.ml +++ b/src/bin_signer/main_signer.ml @@ -66,17 +66,16 @@ let magic_bytes_arg = ~long:"magic-bytes" ~placeholder:"0xHH,0xHH,..." (Clic.parameter (fun _ s -> - try - return - (List.map - (fun s -> - let b = int_of_string s in - if b < 0 || b > 255 then raise Exit else b) - (String.split ',' s)) - with Failure _ | Exit | Invalid_argument _ -> - failwith - "Bad format for magic bytes, a series of numbers is expected, \ - separated by commas.")) + Lwt.return + (List.map_e + (fun s -> + match int_of_string_opt s with + | Some b when 0 <= b && b <= 255 -> Ok b + | Some _ (* out of range *) | None (* not a number *) -> + generic_error + "Bad format for magic bytes, a series of numbers is \ + expected, separated by commas.") + (String.split ',' s)))) let high_watermark_switch = Clic.switch -- GitLab From 00d0fd6eb627ad31a48b157774078bb83dbd6689 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 12 Jul 2021 14:19:10 +0200 Subject: [PATCH 03/10] Everywhere: avoid some bytes-string conversions --- src/lib_base/block_header.ml | 6 ++-- src/lib_base/p2p_addr.ml | 13 ++++----- src/lib_client_base/bip39.ml | 4 +-- .../client_helpers_commands.ml | 4 +-- src/lib_crypto/base58.ml | 2 +- src/lib_crypto/ed25519.ml | 5 ++-- src/lib_crypto/test/test_prop_hacl_hash.ml | 3 +- src/lib_crypto/timelock.ml | 6 ++-- src/lib_rpc_http/media_type.ml | 8 ++--- src/lib_sapling/core.ml | 29 ++++++++++--------- src/lib_signer_services/signer_messages.ml | 7 +++-- src/lib_store/snapshots.ml | 8 ++--- .../lib_benchmark/michelson_samplers.ml | 16 ++++------ .../lib_protocol/bootstrap_storage.ml | 4 +-- .../liquidity_baking_migration.ml | 2 +- src/proto_alpha/lib_protocol/seed_repr.ml | 2 +- 16 files changed, 55 insertions(+), 64 deletions(-) diff --git a/src/lib_base/block_header.ml b/src/lib_base/block_header.ml index f05b268a16b3..4029d4c4c140 100644 --- a/src/lib_base/block_header.ml +++ b/src/lib_base/block_header.ml @@ -139,15 +139,17 @@ let pp ppf op = let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v +let to_string v = Data_encoding.Binary.to_string_exn encoding v + let of_bytes b = Data_encoding.Binary.of_bytes_opt encoding b let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b -let to_b58check v = Base58.safe_encode (Bytes.to_string (to_bytes v)) +let to_b58check v = Base58.safe_encode (to_string v) let of_b58check b = Option.bind (Base58.safe_decode b) (fun s -> - Data_encoding.Binary.of_bytes_opt encoding (Bytes.of_string s)) + Data_encoding.Binary.of_string_opt encoding s) let hash block = Block_hash.hash_bytes [to_bytes block] diff --git a/src/lib_base/p2p_addr.ml b/src/lib_base/p2p_addr.ml index ef672eaf4897..a6d8306c6f52 100644 --- a/src/lib_base/p2p_addr.ml +++ b/src/lib_base/p2p_addr.ml @@ -45,16 +45,15 @@ let of_string_opt str = | Ok (V6 addr) -> Some addr | Error (`Msg _) -> None +let of_string_error_message = "P2p_addr.of_string" + +let of_string_exc = Failure of_string_error_message + let of_string_exn str = - match of_string_opt str with - | None -> Stdlib.failwith "P2p_addr.of_string" - | Some t -> t + of_string_opt str |> WithExceptions.Option.to_exn ~none:of_string_exc let of_string str = - try Ok (of_string_exn str) with - | Invalid_argument s -> Error s - | Failure s -> Error s - | _ -> Error "P2p_point.of_string" + of_string_opt str |> Result.of_option ~error:of_string_error_message let to_string saddr = Format.asprintf "%a" pp saddr diff --git a/src/lib_client_base/bip39.ml b/src/lib_client_base/bip39.ml index 51ced5ff8eaa..cbcc68940b48 100644 --- a/src/lib_client_base/bip39.ml +++ b/src/lib_client_base/bip39.ml @@ -83,7 +83,7 @@ let bits_of_char c = let bits_of_bytes bytes = let acc = ref [] in - String.iter bytes ~f:(fun c -> acc := List.rev_append (bits_of_char c) !acc) ; + Bytes.iter bytes ~f:(fun c -> acc := List.rev_append (bits_of_char c) !acc) ; List.rev !acc let list_sub l n = @@ -112,7 +112,7 @@ let of_entropy entropy = | Some {bytes; digest_length; _} -> let digest = Bytes.get (Hacl.Hash.SHA256.digest entropy) 0 in let digest = list_sub (bits_of_char digest) digest_length in - let entropy = bits_of_bytes (Bytes.to_string bytes) @ digest in + let entropy = bits_of_bytes bytes @ digest in List.map (pack entropy 11) ~f:int_of_bits let to_seed ?(passphrase = Bytes.empty) t = diff --git a/src/lib_client_commands/client_helpers_commands.ml b/src/lib_client_commands/client_helpers_commands.ml index 66cc5118121e..823db463d3bf 100644 --- a/src/lib_client_commands/client_helpers_commands.ml +++ b/src/lib_client_commands/client_helpers_commands.ml @@ -84,9 +84,7 @@ let commands () = ~desc:"the seed from which to compute the chain id" @@ stop) (fun () seed_str (cctxt : #Client_context.full) -> - let chain_id = - Tezos_crypto.Chain_id.hash_bytes [Bytes.of_string seed_str] - in + let chain_id = Tezos_crypto.Chain_id.hash_string [seed_str] in cctxt#message "%a" Tezos_crypto.Chain_id.pp chain_id >>= fun () -> return_unit); ] diff --git a/src/lib_crypto/base58.ml b/src/lib_crypto/base58.ml index 20d4b4d00d17..9fd2e8a873d4 100644 --- a/src/lib_crypto/base58.ml +++ b/src/lib_crypto/base58.ml @@ -48,7 +48,7 @@ module Alphabet = struct i ; Bytes.set str char (char_of_int i) done ; - {encode = alphabet; decode = Bytes.to_string str} + {encode = alphabet; decode = Bytes.unsafe_to_string str} let bitcoin = make "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" diff --git a/src/lib_crypto/ed25519.ml b/src/lib_crypto/ed25519.ml index ce0548a9ab2b..e2e3a7857fc6 100644 --- a/src/lib_crypto/ed25519.ml +++ b/src/lib_crypto/ed25519.ml @@ -172,9 +172,10 @@ module Secret_key = struct let buf = Bytes.create (sk_size + pk_size) in blit_to_bytes sk buf ; blit_to_bytes pk ~pos:sk_size buf ; - Bytes.to_string buf) + Bytes.unsafe_to_string buf) ~of_raw:(fun buf -> - let sk = Bytes.(sub (of_string buf) 0 sk_size) in + let sk = Bytes.create sk_size in + Bytes.blit_string buf 0 sk 0 sk_size ; sk_of_bytes sk) ~wrap:(fun x -> Data x) diff --git a/src/lib_crypto/test/test_prop_hacl_hash.ml b/src/lib_crypto/test/test_prop_hacl_hash.ml index 1625b837dc2d..04d6c9da828c 100644 --- a/src/lib_crypto/test/test_prop_hacl_hash.ml +++ b/src/lib_crypto/test/test_prop_hacl_hash.ml @@ -39,8 +39,7 @@ module Hash_Properties (Desc : sig end) (X : Hacl.Hash.S) = struct - let pp_bytes fmt d = - Format.fprintf fmt "\"%s\"" (String.escaped @@ Bytes.to_string d) + let pp_bytes fmt d = Format.fprintf fmt "%S" (Bytes.unsafe_to_string d) (** Verifies equivalence between the hash of [msg_s] obtained through the direct and incremental interface of [X]. diff --git a/src/lib_crypto/timelock.ml b/src/lib_crypto/timelock.ml index 997c23a2c5ec..140bfc62c444 100644 --- a/src/lib_crypto/timelock.ml +++ b/src/lib_crypto/timelock.ml @@ -44,9 +44,9 @@ let size_modulus = 2048 (* Creates a symmetric key using hash based key derivation from the time locked value*) let unlocked_value_to_symmetric_key unlocked_value = - let kdf_key = Bytes.of_string "Tezoskdftimelockv0" in - let to_hash = Bytes.of_string @@ Z.to_string unlocked_value in - let hash = Blake2B.(to_bytes @@ hash_bytes ~key:kdf_key [to_hash]) in + let kdf_key = "Tezoskdftimelockv0" in + let to_hash = Z.to_string unlocked_value in + let hash = Blake2B.(to_bytes @@ hash_string ~key:kdf_key [to_hash]) in Crypto_box.Secretbox.unsafe_of_bytes hash (* A random Z arith element of size [size] bytes *) diff --git a/src/lib_rpc_http/media_type.ml b/src/lib_rpc_http/media_type.ml index bccffc0d9d9c..a4de3213b20a 100644 --- a/src/lib_rpc_http/media_type.ml +++ b/src/lib_rpc_http/media_type.ml @@ -120,15 +120,13 @@ let bson = } let octet_stream = - let construct enc v = - Bytes.to_string @@ Data_encoding.Binary.to_bytes_exn enc v - in + let construct enc v = Data_encoding.Binary.to_string_exn enc v in { name = Cohttp.Accept.MediaType ("application", "octet-stream"); q = Some 200; pp = (fun enc ppf raw -> - match Data_encoding.Binary.of_bytes enc (Bytes.of_string raw) with + match Data_encoding.Binary.of_string enc raw with | Error re -> Format.fprintf ppf @@ -148,7 +146,7 @@ let octet_stream = Seq.return (Bytes.unsafe_of_string s, 0, String.length s)); destruct = (fun enc s -> - match Data_encoding.Binary.of_bytes enc (Bytes.of_string s) with + match Data_encoding.Binary.of_string enc s with | Error re -> Error (Format.asprintf diff --git a/src/lib_sapling/core.ml b/src/lib_sapling/core.ml index 32996a6d02b9..b13df11a0aa9 100644 --- a/src/lib_sapling/core.ml +++ b/src/lib_sapling/core.ml @@ -263,12 +263,10 @@ module Raw = struct let address_b58check_encoding = let to_raw address = - Bytes.to_string - (Data_encoding.Binary.to_bytes_exn address_encoding address) + Data_encoding.Binary.to_string_exn address_encoding address in let of_raw str = - Option.of_result - @@ Data_encoding.Binary.of_bytes address_encoding (Bytes.of_string str) + Data_encoding.Binary.of_string_opt address_encoding str in Base58.register_encoding ~prefix:Base58.Prefix.sapling_address @@ -332,18 +330,22 @@ module Raw = struct R.ka_derivepublic Viewing_key.(address.diversifier) esk (* used to derive symmetric keys from the diffie hellman. *) - let kdf_key = Bytes.of_string "KDFSaplingForTezosV1" + let kdf_key = "KDFSaplingForTezosV1" (** Derives a symmetric key to be used to create the ciphertext on the sender side. *) let symkey_sender esk pkd = - let symkey = R.of_symkey @@ R.ka_agree_sender pkd esk in - let hash = Blake2B.(to_bytes @@ hash_bytes ~key:kdf_key [symkey]) in + let symkey = + Bytes.unsafe_to_string @@ R.of_symkey @@ R.ka_agree_sender pkd esk + in + let hash = Blake2B.(to_bytes @@ hash_string ~key:kdf_key [symkey]) in Crypto_box.Secretbox.unsafe_of_bytes hash let symkey_receiver epk ivk = - let symkey = R.of_symkey @@ R.ka_agree_receiver epk ivk in - let hash = Blake2B.(to_bytes @@ hash_bytes ~key:kdf_key [symkey]) in + let symkey = + Bytes.unsafe_to_string @@ R.of_symkey @@ R.ka_agree_receiver epk ivk + in + let hash = Blake2B.(to_bytes @@ hash_string ~key:kdf_key [symkey]) in Crypto_box.Secretbox.unsafe_of_bytes hash let symkey_out ovk (cv, cm, epk) = @@ -728,16 +730,15 @@ module Raw = struct @@ conv R.of_binding_sig R.to_binding_sig (Fixed.bytes 64) (* Create sighash for binding_sig *) - let hash_transaction inputs outputs key_string = - let key = Bytes.of_string key_string in + let hash_transaction inputs outputs key = let input_bytes = - List.map (Data_encoding.Binary.to_bytes_exn input_encoding) inputs + List.map (Data_encoding.Binary.to_string_exn input_encoding) inputs in let output_bytes = - List.map (Data_encoding.Binary.to_bytes_exn output_encoding) outputs + List.map (Data_encoding.Binary.to_string_exn output_encoding) outputs in let h = - Blake2B.(to_bytes (hash_bytes ~key (input_bytes @ output_bytes))) + Blake2B.(to_bytes (hash_string ~key (input_bytes @ output_bytes))) in R.to_sighash h diff --git a/src/lib_signer_services/signer_messages.ml b/src/lib_signer_services/signer_messages.ml index 9e66acb3bd9e..ce0873e0682b 100644 --- a/src/lib_signer_services/signer_messages.ml +++ b/src/lib_signer_services/signer_messages.ml @@ -50,9 +50,12 @@ module Make_authenticated_request (T : Tag) : Authenticated_request = struct let tag = Bytes.make 1 '0' in TzEndian.set_int8 tag 0 T.tag ; Bytes.concat - (Bytes.of_string "") + Bytes.empty [ - Bytes.of_string "\x04"; tag; Signature.Public_key_hash.to_bytes pkh; data; + Bytes.unsafe_of_string "\x04"; + tag; + Signature.Public_key_hash.to_bytes pkh; + data; ] let encoding = diff --git a/src/lib_store/snapshots.ml b/src/lib_store/snapshots.ml index f3e8cd77255f..d68df8df210a 100644 --- a/src/lib_store/snapshots.ml +++ b/src/lib_store/snapshots.ml @@ -2586,11 +2586,7 @@ module Raw_importer : IMPORTER = struct let load_block_data t = let file = Naming.(snapshot_block_data_file t.snapshot_dir |> file_path) in Lwt_utils_unix.read_file file >>= fun block_data -> - match - Data_encoding.Binary.of_bytes_opt - block_data_encoding - (Bytes.of_string block_data) - with + match Data_encoding.Binary.of_string_opt block_data_encoding block_data with | Some block_data -> return block_data | None -> fail (Cannot_read {kind = `Block_data; path = file}) @@ -2872,7 +2868,7 @@ module Tar_importer : IMPORTER = struct let (_ofs, res) = Data_encoding.Binary.read_exn Protocol_levels.encoding - (Bytes.to_string bytes) + (Bytes.unsafe_to_string bytes) 0 (Bytes.length bytes) in diff --git a/src/proto_alpha/lib_benchmark/michelson_samplers.ml b/src/proto_alpha/lib_benchmark/michelson_samplers.ml index 68fa3ca72379..998d7bf3e0fd 100644 --- a/src/proto_alpha/lib_benchmark/michelson_samplers.ml +++ b/src/proto_alpha/lib_benchmark/michelson_samplers.ml @@ -604,24 +604,20 @@ module Make (P : Michelson_samplers_parameters.S) : S = struct else (* For a description of the format, see tezos-codec describe alpha.contract binary encoding *) - let bytes = - Bytes.cat - (Bytes.of_string "\001") - (Bytes.cat - (Base_samplers.uniform_bytes ~nbytes:20 rng_state) - (Bytes.of_string "\000")) + let string = + "\001" ^ Base_samplers.uniform_string ~nbytes:20 rng_state ^ "\000" in let contract = - Data_encoding.Binary.of_bytes_exn + Data_encoding.Binary.of_string_exn Alpha_context.Contract.encoding - bytes + string in let ep = Base_samplers.string ~size:{min = 1; max = 31} rng_state in (contract, ep) let chain_id rng_state = - let bytes = Base_samplers.uniform_bytes ~nbytes:4 rng_state in - Data_encoding.Binary.of_bytes_exn Chain_id.encoding bytes + let string = Base_samplers.uniform_string ~nbytes:4 rng_state in + Data_encoding.Binary.of_string_exn Chain_id.encoding string let rec value : type a. a Script_typed_ir.ty -> a sampler = let open Script_typed_ir in diff --git a/src/proto_alpha/lib_protocol/bootstrap_storage.ml b/src/proto_alpha/lib_protocol/bootstrap_storage.ml index 4f5b276198e3..a6e316842f75 100644 --- a/src/proto_alpha/lib_protocol/bootstrap_storage.ml +++ b/src/proto_alpha/lib_protocol/bootstrap_storage.ml @@ -50,9 +50,7 @@ let init_contract ~typecheck ctxt ~delegate:(Some delegate) let init ctxt ~typecheck ?ramp_up_cycles ?no_reward_cycles accounts contracts = - let nonce = - Operation_hash.hash_bytes [Bytes.of_string "Un festival de GADT."] - in + let nonce = Operation_hash.hash_string ["Un festival de GADT."] in let ctxt = Raw_context.init_origination_nonce ctxt nonce in List.fold_left_es init_account ctxt accounts >>=? fun ctxt -> List.fold_left_es (init_contract ~typecheck) ctxt contracts >>=? fun ctxt -> diff --git a/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml b/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml index 4fa1a6740a14..aec13a095f49 100644 --- a/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml +++ b/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml @@ -169,7 +169,7 @@ let check_tzBTC ~typecheck current_level ctxt f = let init ctxt ~typecheck = (* We use a custom origination nonce because it is unset when stitching from 009 *) - let nonce = Operation_hash.hash_bytes [Bytes.of_string "Drip, drip, drip."] in + let nonce = Operation_hash.hash_string ["Drip, drip, drip."] in let ctxt = Raw_context.init_origination_nonce ctxt nonce in Storage.Liquidity_baking.Escape_ema.init ctxt 0l >>=? fun ctxt -> let current_level = diff --git a/src/proto_alpha/lib_protocol/seed_repr.ml b/src/proto_alpha/lib_protocol/seed_repr.ml index 7352417b18eb..cae0b6bf2844 100644 --- a/src/proto_alpha/lib_protocol/seed_repr.ml +++ b/src/proto_alpha/lib_protocol/seed_repr.ml @@ -47,7 +47,7 @@ let seed_encoding = let open Data_encoding in conv (fun (B b) -> b) (fun b -> B b) state_hash_encoding -let empty = B (State_hash.hash_bytes [Bytes.of_string initial_seed]) +let empty = B (State_hash.hash_string [initial_seed]) let nonce (B state) nonce = B (State_hash.hash_bytes [State_hash.to_bytes state; nonce]) -- GitLab From b6632ac8fd579ecc0019137ec31ecf700dcbdb7d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 12 Jul 2021 17:22:36 +0200 Subject: [PATCH 04/10] Everywhere: use Lwt's dont_wait rather than our own --- src/bin_signer/socket_daemon.ml | 18 ++++---- src/lib_client_base/client_confirmations.ml | 16 +++---- src/lib_error_monad/monad_maker.ml | 6 ++- src/lib_error_monad/sig.ml | 4 +- src/lib_event_logging/internal_event.ml | 5 ++- src/lib_p2p/p2p_acl.ml | 4 +- src/lib_p2p/p2p_connect_handler.ml | 24 +++++----- src/lib_p2p/p2p_io_scheduler.ml | 12 ++--- src/lib_p2p/p2p_pool.ml | 4 +- .../environment_V0.ml | 2 + .../environment_V1.ml | 4 ++ .../environment_V2.ml | 4 ++ .../environment_V3.ml | 3 ++ src/lib_rpc_http/RPC_logging.ml | 2 +- src/lib_shell/distributed_db.ml | 12 ++--- src/lib_shell/p2p_reader.ml | 12 ++--- src/lib_shell/prevalidator.ml | 6 +-- src/lib_stdlib/lwt_utils.ml | 5 --- src/lib_stdlib/lwt_utils.mli | 44 ------------------- 19 files changed, 75 insertions(+), 112 deletions(-) diff --git a/src/bin_signer/socket_daemon.ml b/src/bin_signer/socket_daemon.ml index d0f38cc9de28..ff51b1dabc80 100644 --- a/src/bin_signer/socket_daemon.ml +++ b/src/bin_signer/socket_daemon.ml @@ -99,9 +99,7 @@ let run ?magic_bytes ?timeout ~check_high_watermark ~require_auth bind path >>=? fun fds -> let rec loop fd = Lwt_unix.accept fd >>= fun (cfd, _) -> - Lwt_utils.dont_wait - (fun exc -> - Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) + Lwt.dont_wait (fun () -> protect ~on_error:(function @@ -116,14 +114,14 @@ let run ?magic_bytes ?timeout ~check_high_watermark ~require_auth ~check_high_watermark ~require_auth cctxt - cfd) + cfd + >>= fun (_ : unit tzresult) -> Lwt.return_unit) (fun () -> - Lwt_utils_unix.safe_close cfd >>= function - | Error trace -> - Format.eprintf "Uncaught error: %a\n%!" pp_print_error trace ; - Lwt.return_unit - | Ok () -> Lwt.return_unit)) - >>= fun _ -> Lwt.return_unit) ; + Lwt_utils_unix.safe_close cfd + >|= Result.iter_error + (Format.eprintf "Uncaught error: %a\n%!" pp_print_error)))) + (fun exc -> + Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) ; loop fd in List.map_p loop fds >>= return diff --git a/src/lib_client_base/client_confirmations.ml b/src/lib_client_base/client_confirmations.ml index 1b2fbf0484d7..7da4d80446ac 100644 --- a/src/lib_client_base/client_confirmations.ml +++ b/src/lib_client_base/client_confirmations.ml @@ -244,20 +244,20 @@ let lookup_operation_in_previous_blocks (ctxt : #Client_context.full) ~chain let wait_for_bootstrapped ?(retry = fun f x -> f x) (ctxt : #Client_context.full) = let display = ref false in - Lwt_utils.dont_wait - (fun exc -> - let (_ : unit Lwt.t) = - ctxt#error "Uncaught exception: %s\n%!" (Printexc.to_string exc) - >>= fun () -> ctxt#error "Progress not monitored anymore\n%!" - in - ()) + Lwt.dont_wait (fun () -> ctxt#sleep 0.3 >>= fun () -> if not !display then ( ctxt#answer "Waiting for the node to be bootstrapped..." >>= fun () -> display := true ; Lwt.return_unit) - else Lwt.return_unit) ; + else Lwt.return_unit) + (fun exc -> + let (_ : unit Lwt.t) = + ctxt#error "Uncaught exception: %s\n%!" (Printexc.to_string exc) + >>= fun () -> ctxt#error "Progress not monitored anymore\n%!" + in + ()) ; retry Monitor_services.bootstrapped ctxt >>=? fun (stream, _stop) -> Lwt_stream.iter_s (fun (hash, time) -> diff --git a/src/lib_error_monad/monad_maker.ml b/src/lib_error_monad/monad_maker.ml index 4e2534f4e458..8719a3231379 100644 --- a/src/lib_error_monad/monad_maker.ml +++ b/src/lib_error_monad/monad_maker.ml @@ -143,11 +143,13 @@ module Make (Trace : Sig.TRACE) : let when_ cond f = if cond then f () else return_unit - let dont_wait exc_handler err_handler f = - Lwt_utils.dont_wait exc_handler (fun () -> + let dont_wait f err_handler exc_handler = + Lwt.dont_wait + (fun () -> f () >>= function | Ok () -> Lwt.return_unit | Error trace -> err_handler trace ; Lwt.return_unit) + exc_handler end diff --git a/src/lib_error_monad/sig.ml b/src/lib_error_monad/sig.ml index 7530d7a00020..95a3f453d48b 100644 --- a/src/lib_error_monad/sig.ml +++ b/src/lib_error_monad/sig.ml @@ -425,9 +425,9 @@ module type MONAD = sig (** Wrapper around [Lwt_utils.dont_wait] *) val dont_wait : - (exn -> unit) -> - ('trace -> unit) -> (unit -> (unit, 'trace) result Lwt.t) -> + ('trace -> unit) -> + (exn -> unit) -> unit (** A few aliases for Lwt functions *) diff --git a/src/lib_event_logging/internal_event.ml b/src/lib_event_logging/internal_event.ml index d6da76dba927..53b737584b35 100644 --- a/src/lib_event_logging/internal_event.ml +++ b/src/lib_event_logging/internal_event.ml @@ -484,9 +484,10 @@ module Simple = struct Lwt.return_unit) let emit__dont_wait__use_with_care simple_event parameters = - Lwt_utils.dont_wait - (fun exc -> raise exc) (* emit never lets exceptions escape *) + Lwt.dont_wait (fun () -> emit simple_event parameters) + (fun exc -> raise exc) + (* emit never lets exceptions escape *) let make_section names = match names with diff --git a/src/lib_p2p/p2p_acl.ml b/src/lib_p2p/p2p_acl.ml index 2dab39c33462..623d4ed14e48 100644 --- a/src/lib_p2p/p2p_acl.ml +++ b/src/lib_p2p/p2p_acl.ml @@ -95,13 +95,11 @@ let create ~peer_id_size ~ip_size ~ip_cleanup_delay = cleanup_loop () in let rec cleanup_start () = - Lwt_utils.dont_wait - (fun exc -> + Lwt.dont_wait cleanup_loop (fun exc -> Format.eprintf "Exception caught: %s\n%!" (Printexc.to_string exc) ; Format.eprintf "Resetting bloomer to an ok state\n%!" ; Bloomer.clear bloomer ; cleanup_start ()) - cleanup_loop in cleanup_start () ; { diff --git a/src/lib_p2p/p2p_connect_handler.ml b/src/lib_p2p/p2p_connect_handler.ml index 1bcf856f69f9..35f16c6872d5 100644 --- a/src/lib_p2p/p2p_connect_handler.ml +++ b/src/lib_p2p/p2p_connect_handler.ml @@ -512,23 +512,15 @@ let accept t fd point = || P2p_pool.Points.banned t.pool point then Error_monad.dont_wait - (fun exc -> - Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) + (fun () -> P2p_fd.close fd) (fun trace -> Format.eprintf "Uncaught error: %a\n%!" pp_print_error trace) - (fun () -> P2p_fd.close fd) + (fun exc -> + Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) else let canceler = Lwt_canceler.create () in P2p_point.Table.add t.incoming point canceler ; - Lwt_utils.dont_wait - (fun exc -> - P2p_point.Table.remove t.incoming point ; - P2p_pool.greylist_addr t.pool (fst point) ; - Format.eprintf - "Uncaught exception on incoming connection from %a: %s\n%!" - P2p_point.Id.pp - point - (Printexc.to_string exc)) + Lwt.dont_wait (fun () -> with_timeout ~canceler @@ -537,6 +529,14 @@ let accept t fd point = >>= fun _ -> P2p_point.Table.remove t.incoming point ; Lwt.return_unit) + (fun exc -> + P2p_point.Table.remove t.incoming point ; + P2p_pool.greylist_addr t.pool (fst point) ; + Format.eprintf + "Uncaught exception on incoming connection from %a: %s\n%!" + P2p_point.Id.pp + point + (Printexc.to_string exc)) let fail_unless_disconnected_point point_info = match P2p_point_state.get point_info with diff --git a/src/lib_p2p/p2p_io_scheduler.ml b/src/lib_p2p/p2p_io_scheduler.ml index bcf1e4ceef6c..46f5b1602c56 100644 --- a/src/lib_p2p/p2p_io_scheduler.ml +++ b/src/lib_p2p/p2p_io_scheduler.ml @@ -126,9 +126,7 @@ module Scheduler (IO : IO) = struct let waiter st conn = assert (Lwt.state conn.current_pop <> Sleep) ; conn.current_pop <- IO.pop conn.in_param ; - Lwt_utils.dont_wait - (fun exc -> - Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) + Lwt.dont_wait (fun () -> (* To ensure that there is no concurrent calls to IO.pop, we wait for the promise to be fulfilled. *) @@ -141,6 +139,8 @@ module Scheduler (IO : IO) = struct else Queue.push (conn, res) st.readys_low ; if was_empty then Lwt_condition.broadcast st.readys () ; Lwt.return_unit) + (fun exc -> + Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) (* Wait for a connection to be available, with data in one of the queues. *) @@ -531,11 +531,11 @@ let write_size bytes = let register st fd = if st.closed then ( Error_monad.dont_wait - (fun exc -> - Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) + (fun () -> P2p_fd.close fd) (fun trace -> Format.eprintf "Uncaught error: %a\n%!" pp_print_error trace) - (fun () -> P2p_fd.close fd) ; + (fun exc -> + Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) ; raise Closed) else let id = P2p_fd.id fd in diff --git a/src/lib_p2p/p2p_pool.ml b/src/lib_p2p/p2p_pool.ml index bee7c4e309f9..8f1b9024ab6a 100644 --- a/src/lib_p2p/p2p_pool.ml +++ b/src/lib_p2p/p2p_pool.ml @@ -139,9 +139,9 @@ let register_point ?trusted ?expected_peer_id pool ((addr, port) as point) = | Some point_info -> (match expected_peer_id with | Some peer_id -> - Lwt_utils.dont_wait - (fun _ -> ()) + Lwt.dont_wait (fun () -> set_expected_peer_id pool point peer_id) + (fun _ -> ()) | None -> ()) ; (match trusted with | Some true -> P2p_point_state.Info.set_trusted point_info diff --git a/src/lib_protocol_environment/environment_V0.ml b/src/lib_protocol_environment/environment_V0.ml index 7757bf0f052b..b7ad3172fef1 100644 --- a/src/lib_protocol_environment/environment_V0.ml +++ b/src/lib_protocol_environment/environment_V0.ml @@ -375,6 +375,8 @@ struct include Tezos_error_monad.Monad_ext_maker.Make (Error_core) (TzTrace) (Local_monad) + + (* Backwards compatibility additions (traversors, infix op) *) include Error_monad_traversors let ( >>|? ) = ( >|=? ) (* for backward compatibility *) diff --git a/src/lib_protocol_environment/environment_V1.ml b/src/lib_protocol_environment/environment_V1.ml index 90578f08fbf1..4f924e2fd311 100644 --- a/src/lib_protocol_environment/environment_V1.ml +++ b/src/lib_protocol_environment/environment_V1.ml @@ -562,8 +562,12 @@ struct include Tezos_error_monad.Monad_ext_maker.Make (Error_core) (TzTrace) (Local_monad) + + (* Backwards compatibility additions (traversors, dont_wait, trace) *) include Error_monad_traversors + let dont_wait ex er f = dont_wait f er ex + type 'err trace = 'err TzTrace.trace end diff --git a/src/lib_protocol_environment/environment_V2.ml b/src/lib_protocol_environment/environment_V2.ml index edcef0a39502..81c9aaabc54c 100644 --- a/src/lib_protocol_environment/environment_V2.ml +++ b/src/lib_protocol_environment/environment_V2.ml @@ -570,8 +570,12 @@ struct include Tezos_error_monad.Monad_ext_maker.Make (Error_core) (TzTrace) (Local_monad) + + (* Backwards compatibility additions (traversors, dont_wait, trace helpers) *) include Error_monad_traversors + let dont_wait ex er f = dont_wait f er ex + let make_trace_encoding e = TzTrace.encoding e let pp_trace = pp_print_error diff --git a/src/lib_protocol_environment/environment_V3.ml b/src/lib_protocol_environment/environment_V3.ml index f0d74ae5cc23..aa4e24a2db6f 100644 --- a/src/lib_protocol_environment/environment_V3.ml +++ b/src/lib_protocol_environment/environment_V3.ml @@ -607,6 +607,9 @@ struct Tezos_error_monad.Monad_ext_maker.Make (Error_core) (TzTrace) (Local_monad) + (* Backwards compatibility additions (dont_wait, trace helpers) *) + let dont_wait ex er f = dont_wait f er ex + let trace_of_error e = TzTrace.make e let make_trace_encoding e = TzTrace.encoding e diff --git a/src/lib_rpc_http/RPC_logging.ml b/src/lib_rpc_http/RPC_logging.ml index fd29ce13dbdf..3928463fbd56 100644 --- a/src/lib_rpc_http/RPC_logging.ml +++ b/src/lib_rpc_http/RPC_logging.ml @@ -58,7 +58,7 @@ let emit level message = (** Wrap an lwt computation so that it can return without waiting until the promise is resolved. *) -let wrap_lwt f a = Lwt_utils.dont_wait raise (fun () -> f a) +let wrap_lwt f a = Lwt.dont_wait (fun () -> f a) raise (** Avoid calling emit, if sinks would ignore the message anyway. *) let if_level_appropriate_or_else ~level if_so if_not fmt = diff --git a/src/lib_shell/distributed_db.ml b/src/lib_shell/distributed_db.ml index 5f5a16a3b61b..3a43969c9892 100644 --- a/src/lib_shell/distributed_db.ml +++ b/src/lib_shell/distributed_db.ml @@ -175,14 +175,14 @@ let activate P2p.send p2p conn (Get_current_branch chain_id) :: acc) in Error_monad.dont_wait - (fun exc -> - Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) + (fun () -> join_ep sends) (fun trace -> Format.eprintf "Uncaught error: %a\n%!" Error_monad.pp_print_error trace) - (fun () -> join_ep sends) ; + (fun exc -> + Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) ; Chain_id.Table.add active_chains chain_id local_db ; local_db in @@ -203,11 +203,11 @@ let deactivate chain_db = chain_db.reader_chain_db.active_connections in Error_monad.dont_wait - (fun exc -> - Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) + (fun () -> sends) (fun trace -> Format.eprintf "Uncaught error: %a\n%!" Error_monad.pp_print_error trace) - (fun () -> sends) ; + (fun exc -> + Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) ; Distributed_db_requester.Raw_operation.shutdown chain_db.reader_chain_db.operation_db >>= fun () -> diff --git a/src/lib_shell/p2p_reader.ml b/src/lib_shell/p2p_reader.ml index ff41739af96f..b1bf53608a36 100644 --- a/src/lib_shell/p2p_reader.ml +++ b/src/lib_shell/p2p_reader.ml @@ -449,17 +449,17 @@ let run ~register ~unregister p2p disk protocol_db active_chains gid conn = Chain_id.Table.iter (fun chain_id _chain_db -> Error_monad.dont_wait - (fun exc -> - Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) + (fun () -> + let meta = P2p.get_peer_metadata p2p gid in + Peer_metadata.incr meta (Sent_request Branch) ; + P2p.send p2p conn (Get_current_branch chain_id)) (fun trace -> Format.eprintf "Uncaught error: %a\n%!" Error_monad.pp_print_error trace) - (fun () -> - let meta = P2p.get_peer_metadata p2p gid in - Peer_metadata.incr meta (Sent_request Branch) ; - P2p.send p2p conn (Get_current_branch chain_id))) + (fun exc -> + Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc))) active_chains ; state.worker <- Lwt_utils.worker diff --git a/src/lib_shell/prevalidator.ml b/src/lib_shell/prevalidator.ml index a820e28cda45..75dcf3defb2e 100644 --- a/src/lib_shell/prevalidator.ml +++ b/src/lib_shell/prevalidator.ml @@ -414,13 +414,13 @@ module Make } | `None -> pv.advertisement <- `Pending mempool ; - Lwt_utils.dont_wait - (fun exc -> - Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) + Lwt.dont_wait (fun () -> Lwt_unix.sleep advertisement_delay >>= fun () -> Worker.Queue.push_request_now w Advertise ; Lwt.return_unit) + (fun exc -> + Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) let is_endorsement (op : Proto.operation_data operation) = Proto.acceptable_passes diff --git a/src/lib_stdlib/lwt_utils.ml b/src/lib_stdlib/lwt_utils.ml index 9143c9f254dd..dd1e5fe69903 100644 --- a/src/lib_stdlib/lwt_utils.ml +++ b/src/lib_stdlib/lwt_utils.ml @@ -57,11 +57,6 @@ let rec fold_left_s_n ~n f acc l = f acc x >>= fun acc -> (fold_left_s_n [@ocaml.tailcall]) f ~n:(n - 1) acc l -let dont_wait handler f = - let open Lwt in - let p = apply f () in - on_failure p handler - let rec find_map_s f = function | [] -> Lwt.return_none | x :: l -> diff --git a/src/lib_stdlib/lwt_utils.mli b/src/lib_stdlib/lwt_utils.mli index d9b9ec98ae09..bfd343030acb 100644 --- a/src/lib_stdlib/lwt_utils.mli +++ b/src/lib_stdlib/lwt_utils.mli @@ -64,49 +64,5 @@ val worker : val fold_left_s_n : n:int -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> ('a * 'b list) Lwt.t -(** [dont_wait handler f] calls [f ()] and essentially ignores the returned - promise. In particular it does not wait for the promise to resolve. - - [dont_wait] is meant as an alternative to [Lwt.async]. The former requires - an explicit, local exception handler whereas the latter uses a global - handler that is set by side-effects. - - CAVEAT! - - Note that, because of the semantics of execution in Lwt, the evaluation of - [f ()] is immediate and some progress towards the resolution of the promise - may happen immediately. Specifically, the progress towards the resolution of - the promise [p] returned by [f ()] is made until the point where it yields. - At that point, control comes back to the caller of [dont_wait] and - continues. More concretely, consider the order of the side-effects in the - following piece of code and in particular how the second side-effect in the - order of execution is within the promise created by [dont_wait]. - - [side_effect (); (* first *) - dont_wait - (fun exc -> ..) - (fun () -> - side_effect (); (* second *) - Lwt.pause () >>= fun () -> - side_effect (); (* delayed *) - ..); - side_effect (); (* third *) - ] - - If you want to delay any progress towards promise resolution being made - (e.g., if you need strong guarantees about side-effects because you are in a - critical section), then you need to add an explicit cooperation point. You - can use [Lwt.pause] at the very beginning of the promise you pass to - [dont_wait]: - [dont_wait handler (fun () -> Lwt.pause () >>= fun () -> ..)]. - - With this pattern, in the expression - [dont_wait handler (fun () -> Lwt.pause () >>= f)], the anonymous lambda - ([(fun () -> …)]) is called immediately. However, when this call is - evaluated, the call to [pause] immediately suspend progress towards the - resolution of the promise, delaying the call [f ()]. -*) -val dont_wait : (exn -> unit) -> (unit -> unit Lwt.t) -> unit - (** Lwt version of [TzList.find_map] *) val find_map_s : ('a -> 'b option Lwt.t) -> 'a list -> 'b option Lwt.t -- GitLab From 1e1b09b6a167c4f78ff1130b4efbe3e49bd64a02 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Sun, 25 Jul 2021 12:17:13 +0100 Subject: [PATCH 05/10] Lwtreslib,Error_monad: more catch helpers --- src/lib_error_monad/error_monad.ml | 17 ++-- src/lib_error_monad/error_monad.mli | 35 +++++--- src/lib_lwt_result_stdlib/bare/sigs/option.ml | 16 +++- src/lib_lwt_result_stdlib/bare/sigs/result.ml | 19 ++++- src/lib_lwt_result_stdlib/bare/sigs/unit.ml | 79 +++++++++++++++++++ .../bare/structs/option.ml | 11 +++ .../bare/structs/result.ml | 6 ++ .../bare/structs/unit.ml | 51 ++++++++++++ src/lib_lwt_result_stdlib/lwtreslib.ml | 1 + src/lib_lwt_result_stdlib/lwtreslib.mli | 2 + src/lib_lwt_result_stdlib/traced/sigs/unit.ml | 32 ++++++++ .../traced/structs/structs.ml | 1 + 12 files changed, 253 insertions(+), 17 deletions(-) create mode 100644 src/lib_lwt_result_stdlib/bare/sigs/unit.ml create mode 100644 src/lib_lwt_result_stdlib/bare/structs/unit.ml create mode 100644 src/lib_lwt_result_stdlib/traced/sigs/unit.ml diff --git a/src/lib_error_monad/error_monad.ml b/src/lib_error_monad/error_monad.ml index 9bfc1e7696de..8b9456b255ae 100644 --- a/src/lib_error_monad/error_monad.ml +++ b/src/lib_error_monad/error_monad.ml @@ -2,7 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2020 Nomadic Labs *) +(* Copyright (c) 2020-2021 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -159,12 +159,19 @@ let cancel_with_exceptions canceler = | Ok () | Error [] -> Lwt.return_unit | Error (h :: _) -> raise h -let catch ?catch_only f = - TzLwtreslib.Result.catch ?catch_only f |> Result.map_error error_of_exn +let catch ?catch_only f = TzLwtreslib.Result.catch_f ?catch_only f error_of_exn + +let catch_e ?catch_only f = + TzLwtreslib.Result.catch_f ?catch_only f error_of_exn |> Result.join let catch_f ?catch_only f exc_mapper = - TzLwtreslib.Result.catch ?catch_only f - |> Result.map_error (fun exc -> TzTrace.make (exc_mapper exc)) + TzLwtreslib.Result.catch_f ?catch_only f (fun exc -> + TzTrace.make (exc_mapper exc)) let catch_s ?catch_only f = TzLwtreslib.Result.catch_s ?catch_only f >|= Result.map_error error_of_exn + +let catch_es ?catch_only f = + TzLwtreslib.Result.catch_s ?catch_only f + >|= Result.map_error error_of_exn + >|= Result.join diff --git a/src/lib_error_monad/error_monad.mli b/src/lib_error_monad/error_monad.mli index 534d93c28c8f..e647d6f6c06e 100644 --- a/src/lib_error_monad/error_monad.mli +++ b/src/lib_error_monad/error_monad.mli @@ -2,7 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2020 Nomadic Labs *) +(* Copyright (c) 2020-2021 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -134,16 +134,26 @@ val protect : *) val catch : ?catch_only:(exn -> bool) -> (unit -> 'a) -> 'a tzresult +(** [catch_e] is like {!catch} but when [f] returns a [tzresult]. + I.e., [catch_e f] is equivalent to + [try f () with e -> Error (error_of_exn e)]. + + [catch_only] has the same use as with {!catch}. The same restriction on + catching non-deterministic runtime exceptions applies. *) +val catch_e : ?catch_only:(exn -> bool) -> (unit -> 'a tzresult) -> 'a tzresult + (** [catch_f f handler] is equivalent to [map_error (catch f) handler]. In other words, it catches exceptions in [f ()] and either returns the value in an [Ok] or passes the exception to [handler] for the [Error]. - [catch_only] has the same use as with [catch]. The same restriction on + No attempt is made to catch the exceptions raised by [handler]. + + [catch_only] has the same use as with {!catch}. The same restriction on catching non-deterministic runtime exceptions applies. *) val catch_f : ?catch_only:(exn -> bool) -> (unit -> 'a) -> (exn -> error) -> 'a tzresult -(** [catch_s] is like [catch] but when [f] returns a promise. It is equivalent +(** [catch_s] is like {!catch} but when [f] returns a promise. It is equivalent to {[ @@ -152,16 +162,21 @@ Lwt.try_bind f (fun e -> Lwt.return (Error (error_of_exn e))) ]} - If [catch_only] is set, then only exceptions [e] such that [catch_only e] is - [true] are caught. - - Whether [catch_only] is set or not, this function never catches - non-deterministic runtime exceptions of OCaml such as {!Stack_overflow} and - {!Out_of_memory}. - *) + [catch_only] has the same use as with {!catch}. The same restriction on + catching non-deterministic runtime exceptions applies. *) val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> 'a tzresult Lwt.t +(** [catch_es] is like !{catch_s} but when [f] returns a promise of a + [tzresult]. + I.e., [catch_es f] is equivalent to + [Lwt.catch f (fun e -> Lwt.return_error (error_of_exn e))]. + + [catch_only] has the same use as with {!catch}. The same restriction on + catching non-deterministic runtime exceptions applies. *) +val catch_es : + ?catch_only:(exn -> bool) -> (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t + type error += Timeout val with_timeout : diff --git a/src/lib_lwt_result_stdlib/bare/sigs/option.ml b/src/lib_lwt_result_stdlib/bare/sigs/option.ml index 454b10578f94..afaf600c0ef3 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/option.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/option.ml @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs *) +(* Copyright (c) 2020-2021 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -223,6 +223,12 @@ module type S = sig and {!Out_of_memory}. *) val catch : ?catch_only:(exn -> bool) -> (unit -> 'a) -> 'a option + (** [catch_o f] is equivalent to [join @@ catch f]. In other words, it is + [f ()] if [f] doesn't raise any exception, and it is [None] otherwise. + + [catch_only] has the same behaviour and limitations as with [catch]. *) + val catch_o : ?catch_only:(exn -> bool) -> (unit -> 'a option) -> 'a option + (** [catch_s f] is a promise that resolves to [Some x] if and when [f ()] resolves to [x]. Alternatively, it resolves to [None] if and when [f ()] is rejected. @@ -240,4 +246,12 @@ module type S = sig and {!Out_of_memory}. *) val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> 'a option Lwt.t + + (** [catch_os f] is like [catch_s f] where [f] returns a promise that resolves + to an option. [catch_os f] resolves to [None] if [f ()] resolves to + [None] or is rejected. It resolves to [Some _] if [f ()] does. + + [catch_only] has the same behaviour and limitations as with [catch]. *) + val catch_os : + ?catch_only:(exn -> bool) -> (unit -> 'a option Lwt.t) -> 'a option Lwt.t end diff --git a/src/lib_lwt_result_stdlib/bare/sigs/result.ml b/src/lib_lwt_result_stdlib/bare/sigs/result.ml index d098abca1853..ff7ca007348e 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/result.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/result.ml @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs *) +(* Copyright (c) 2020-2021 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -132,6 +132,8 @@ module type S = sig In other words, it catches exceptions in [f ()] and either returns the value in an [Ok] or passes the exception to [handler] for the [Error]. + No attempt is made to catch the exceptions raised by [handler]. + [catch_only] has the same use as with [catch]. The same restriction on catching non-deterministic runtime exceptions applies. *) val catch_f : @@ -140,6 +142,21 @@ module type S = sig (exn -> 'error) -> ('a, 'error) result + (** [catch_ef f handler] is equivalent to [join @@ map_error (catch f) handler]. + In other words, it catches exceptions in [f ()] and either returns the + value as is or passes the exception to [handler] for the [Error]. The + handler must return an error of the same type as that carried by [f ()]. + + No attempt is made to catch the exceptions raised by [handler]. + + [catch_only] has the same use as with [catch]. The same restriction on + catching non-deterministic runtime exceptions applies. *) + val catch_ef : + ?catch_only:(exn -> bool) -> + (unit -> ('a, 'error) result) -> + (exn -> 'error) -> + ('a, 'error) result + (** [catch_s] is [catch] but for Lwt promises. Specifically, [catch_s f] returns a promise that resolves to [Ok x] if and when [f ()] resolves to [x], or to [Error exc] if and when [f ()] is rejected with [exc]. diff --git a/src/lib_lwt_result_stdlib/bare/sigs/unit.ml b/src/lib_lwt_result_stdlib/bare/sigs/unit.ml new file mode 100644 index 000000000000..fce81d4aa3c3 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/sigs/unit.ml @@ -0,0 +1,79 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** A replacement for {!Stdlib.Unit} which + - is exception-safe, + - includes Lwt-, result-, and Lwt-result-aware traversors. + + See {!Lwtreslib} and {!Seq} for general description of traversors and the + meaning of [_s], [_e], and [_es] suffixes. *) +module type S = sig + type t = unit = () + + val unit : t + + val unit_s : t Lwt.t + + val unit_e : (t, 'a) result + + val unit_es : (t, 'a) result Lwt.t + + val equal : t -> t -> bool + + val compare : t -> t -> int + + val to_string : t -> string + + (** [catch f] is [f ()], but exceptions are ignored and [()] is returned if + one is raised. + + You should only use [catch] when you truly do not care about + what exception may be raised during the evaluation of [f ()]. If you need + to inspect the raised exception consider {!catch_f} and if you need to + pass it along consider {!Result.catch}. + + If [catch_only] is set, then only exceptions [e] such that [catch_only e] + is [true] are caught. + + Whether [catch_only] is set or not, this function never catches + non-deterministic runtime exceptions of OCaml such as {!Stack_overflow} + and {!Out_of_memory}. *) + val catch : ?catch_only:(exn -> bool) -> (unit -> unit) -> unit + + (** [catch_f f handler] is [f ()]. If [f ()] raises an exception then + [handler] is called. + + No attempt is made to catch the exceptions raised by [handler]. + + [catch_only] has the same behaviour and limitations as with [catch]. *) + val catch_f : + ?catch_only:(exn -> bool) -> (unit -> unit) -> (exn -> unit) -> unit + + (** [catch_s f] is [f ()]. If [f ()] is rejected or raises an exception, then + the exception is ignored and it resolves to [()]. + + [catch_only] has the same behaviour and limitations as with [catch]. *) + val catch_s : ?catch_only:(exn -> bool) -> (unit -> unit Lwt.t) -> unit Lwt.t +end diff --git a/src/lib_lwt_result_stdlib/bare/structs/option.ml b/src/lib_lwt_result_stdlib/bare/structs/option.ml index b058010935ea..b745e0f69ab3 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/option.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/option.ml @@ -160,7 +160,18 @@ let catch ?(catch_only = fun _ -> true) f = | exception ((Stack_overflow | Out_of_memory) as e) -> raise e | exception e -> if catch_only e then None else raise e +let catch_o ?(catch_only = fun _ -> true) f = + match f () with + | v -> v + | exception ((Stack_overflow | Out_of_memory) as e) -> raise e + | exception e -> if catch_only e then None else raise e + let catch_s ?(catch_only = fun _ -> true) f = Lwt.try_bind f Lwt.return_some (function | (Stack_overflow | Out_of_memory) as e -> raise e | e -> if catch_only e then Lwt.return_none else raise e) + +let catch_os ?(catch_only = fun _ -> true) f = + Lwt.catch f (function + | (Stack_overflow | Out_of_memory) as e -> raise e + | e -> if catch_only e then Lwt.return_none else raise e) diff --git a/src/lib_lwt_result_stdlib/bare/structs/result.ml b/src/lib_lwt_result_stdlib/bare/structs/result.ml index 617d161ba7af..ea6cb48d6bb4 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/result.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/result.ml @@ -122,6 +122,12 @@ let catch_f ?(catch_only = fun _ -> true) f h = | exception ((Stack_overflow | Out_of_memory) as e) -> raise e | exception e -> if catch_only e then Error (h e) else raise e +let catch_ef ?(catch_only = fun _ -> true) f h = + match f () with + | v -> v + | exception ((Stack_overflow | Out_of_memory) as e) -> raise e + | exception e -> if catch_only e then Error (h e) else raise e + let catch_s ?(catch_only = fun _ -> true) f = Lwt.try_bind f Lwt.return_ok (function | (Stack_overflow | Out_of_memory) as e -> raise e diff --git a/src/lib_lwt_result_stdlib/bare/structs/unit.ml b/src/lib_lwt_result_stdlib/bare/structs/unit.ml new file mode 100644 index 000000000000..2a2e502965e4 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/unit.ml @@ -0,0 +1,51 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include Stdlib.Unit + +let unit = () + +let unit_s = Monad.unit_s + +let unit_e = Monad.unit_e + +let unit_es = Monad.unit_es + +let catch ?(catch_only = fun _ -> true) f = + match f () with + | () -> () + | exception ((Stack_overflow | Out_of_memory) as e) -> raise e + | exception e -> if catch_only e then () else raise e + +let catch_f ?(catch_only = fun _ -> true) f h = + match f () with + | () -> () + | exception ((Stack_overflow | Out_of_memory) as e) -> raise e + | exception e -> if catch_only e then h e else raise e + +let catch_s ?(catch_only = fun _ -> true) f = + Lwt.catch f (function + | (Stack_overflow | Out_of_memory) as e -> raise e + | e -> if catch_only e then Lwt.return_unit else raise e) diff --git a/src/lib_lwt_result_stdlib/lwtreslib.ml b/src/lib_lwt_result_stdlib/lwtreslib.ml index f4b4adb82626..a9731bb7ad05 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.ml +++ b/src/lib_lwt_result_stdlib/lwtreslib.ml @@ -35,6 +35,7 @@ module Bare = struct module Seq_s = Bare_structs.Seq_s module Seq_es = Bare_structs.Seq_es module Set = Bare_structs.Set + module Unit = Bare_structs.Unit module WithExceptions = Bare_structs.WithExceptions end diff --git a/src/lib_lwt_result_stdlib/lwtreslib.mli b/src/lib_lwt_result_stdlib/lwtreslib.mli index 887d7e783e94..b246ef64df3a 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.mli +++ b/src/lib_lwt_result_stdlib/lwtreslib.mli @@ -344,5 +344,7 @@ module Traced (Trace : Traced_sigs.Trace.S) : sig module Set : Traced_sigs.Set.S with type 'error trace := 'error Trace.trace + module Unit : Traced_sigs.Unit.S + module WithExceptions : Traced_sigs.WithExceptions.S end diff --git a/src/lib_lwt_result_stdlib/traced/sigs/unit.ml b/src/lib_lwt_result_stdlib/traced/sigs/unit.ml new file mode 100644 index 000000000000..d9f0e1a415c1 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/sigs/unit.ml @@ -0,0 +1,32 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** A replacement for {!Stdlib.Unit} which + - is exception-safe, + - includes Lwt-, result-, and Lwt-result-aware traversors. + + See {!Lwtreslib} and {!Seq} for general description of traversors and the + meaning of [_s], [_e], and [_es] suffixes. *) +module type S = Bare_sigs.Unit.S diff --git a/src/lib_lwt_result_stdlib/traced/structs/structs.ml b/src/lib_lwt_result_stdlib/traced/structs/structs.ml index e54611e500f1..696ed284ab94 100644 --- a/src/lib_lwt_result_stdlib/traced/structs/structs.ml +++ b/src/lib_lwt_result_stdlib/traced/structs/structs.ml @@ -37,5 +37,6 @@ module Make (Trace : Traced_sigs.Trace.S) = struct module Seq_e = Seq_e module Seq_s = Seq_s.Make (Monad) module Seq_es = Seq_es.Make (Monad) (Seq_e) (Seq_s) + module Unit = Bare_structs.Unit module WithExceptions = Bare_structs.WithExceptions end -- GitLab From b0a40417847878720a7e2fa8f373f29e631352ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Sun, 25 Jul 2021 12:17:38 +0100 Subject: [PATCH 06/10] Everywhere: replace some Lwt.catch with calls to catch-helpers --- src/bin_signer/socket_daemon.ml | 6 +-- .../client_context_unix.ml | 12 ++--- src/lib_shell/chain_directory.ml | 4 +- src/lib_shell/p2p_reader.ml | 4 +- src/lib_store/block_repr.ml | 9 +--- src/lib_store/cemented_block_store.ml | 12 ++--- src/lib_store/floating_block_store.ml | 54 ++++++++----------- src/lib_store/legacy_store/legacy_state.ml | 4 +- src/lib_store/protocol_store.ml | 4 +- src/lib_store/snapshots.ml | 10 ++-- src/lib_store/store.ml | 3 +- src/lib_store/stored_data.ml | 4 +- 12 files changed, 41 insertions(+), 85 deletions(-) diff --git a/src/bin_signer/socket_daemon.ml b/src/bin_signer/socket_daemon.ml index ff51b1dabc80..f2257bd4eb80 100644 --- a/src/bin_signer/socket_daemon.ml +++ b/src/bin_signer/socket_daemon.ml @@ -101,11 +101,7 @@ let run ?magic_bytes ?timeout ~check_high_watermark ~require_auth Lwt_unix.accept fd >>= fun (cfd, _) -> Lwt.dont_wait (fun () -> - protect - ~on_error:(function - | Exn End_of_file :: _ -> return_unit - | errs -> Lwt.return_error errs) - (fun () -> + Unit.catch_s (fun () -> Lwt.finalize (fun () -> handle_client_loop diff --git a/src/lib_client_base_unix/client_context_unix.ml b/src/lib_client_base_unix/client_context_unix.ml index fd8d7d57449d..4485afc54681 100644 --- a/src/lib_client_base_unix/client_context_unix.ml +++ b/src/lib_client_base_unix/client_context_unix.ml @@ -68,12 +68,10 @@ class unix_wallet ~base_dir ~password_filename : Client_context.wallet = in lock () >>= fun (fd, sh) -> (* catch might be useless if f always uses the error monad *) - Lwt.catch f (function e -> - Lwt.return - (unlock fd ; - raise e)) + Lwt.finalize f (fun () -> + unlock fd ; + Lwt.return_unit) >>= fun res -> - Lwt.return (unlock fd) >>= fun () -> Lwt_unix.disable_signal_handler sh ; Lwt.return res @@ -98,13 +96,11 @@ class unix_wallet ~base_dir ~password_filename : Client_context.wallet = method write : type a. string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t = fun alias_name list encoding -> - Lwt.catch - (fun () -> + Error_monad.catch_es (fun () -> Lwt_utils_unix.create_dir base_dir >>= 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) - (fun exn -> Lwt.return (error_exn exn)) |> generic_trace "could not write the %s alias file." alias_name end diff --git a/src/lib_shell/chain_directory.ml b/src/lib_shell/chain_directory.ml index da0b08736ecb..dbe6da6b7501 100644 --- a/src/lib_shell/chain_directory.ml +++ b/src/lib_shell/chain_directory.ml @@ -39,9 +39,7 @@ let get_chain_id store = | `Hash chain_id -> Lwt.return chain_id let get_chain_id_opt store chain = - Lwt.catch - (fun () -> get_chain_id store chain >>= Lwt.return_some) - (fun _exn -> Lwt.return_none) + Option.catch_s (fun () -> get_chain_id store chain) let get_chain_store_exn store chain = get_chain_id store chain >>= fun chain_id -> diff --git a/src/lib_shell/p2p_reader.ml b/src/lib_shell/p2p_reader.ml index b1bf53608a36..2a203dce34f4 100644 --- a/src/lib_shell/p2p_reader.ml +++ b/src/lib_shell/p2p_reader.ml @@ -119,8 +119,7 @@ let read_block_header db h = Lwt.return_some (chain_id, Store.Block.header block) let read_predecessor_header {disk; _} h offset = - Lwt.catch - (fun () -> + Option.catch_os (fun () -> let offset = Int32.to_int offset in Store.all_chain_stores disk >>= fun chain_stores -> Lwt_utils.find_map_s @@ -129,7 +128,6 @@ let read_predecessor_header {disk; _} h offset = | None -> Lwt.return_none | Some block -> Lwt.return_some (Store.Block.header block)) chain_stores) - (fun _ -> Lwt.return_none) let find_pending_block_header {peer_active_chains; _} h = Chain_id.Table.to_seq_values peer_active_chains diff --git a/src/lib_store/block_repr.ml b/src/lib_store/block_repr.ml index 21599c909ca9..9bdffe0eee96 100644 --- a/src/lib_store/block_repr.ml +++ b/src/lib_store/block_repr.ml @@ -256,10 +256,7 @@ let read_next_block_exn fd = Lwt.return (Data_encoding.Binary.of_bytes_exn encoding block_bytes, 4 + block_length) -let read_next_block fd = - Lwt.catch - (fun () -> read_next_block_exn fd >>= fun b -> Lwt.return_some b) - (fun _exn -> Lwt.return_none) +let read_next_block fd = Option.catch_s (fun () -> read_next_block_exn fd) let pread_block_exn fd ~file_offset = (* Read length *) @@ -280,6 +277,4 @@ let pread_block_exn fd ~file_offset = (Data_encoding.Binary.of_bytes_exn encoding block_bytes, 4 + block_length) let pread_block fd ~file_offset = - Lwt.catch - (fun () -> pread_block_exn fd ~file_offset >>= fun b -> Lwt.return_some b) - (fun _exn -> Lwt.return_none) + Option.catch_s (fun () -> pread_block_exn fd ~file_offset) diff --git a/src/lib_store/cemented_block_store.ml b/src/lib_store/cemented_block_store.ml index 3ae734e47afa..113564a5ef70 100644 --- a/src/lib_store/cemented_block_store.ml +++ b/src/lib_store/cemented_block_store.ml @@ -555,9 +555,7 @@ let trigger_full_gc cemented_store cemented_blocks_files offset = file |> file_path) in - Lwt.catch - (fun () -> Lwt_unix.unlink metadata_file_path) - (fun _exn -> Lwt.return_unit)) + Unit.catch_s (fun () -> Lwt_unix.unlink metadata_file_path)) files_to_remove let trigger_rolling_gc cemented_store cemented_blocks_files offset = @@ -589,13 +587,9 @@ let trigger_rolling_gc cemented_store cemented_blocks_files offset = file |> file_path) in - Lwt.catch - (fun () -> Lwt_unix.unlink metadata_file_path) - (fun _exn -> Lwt.return_unit) + Unit.catch_s (fun () -> Lwt_unix.unlink metadata_file_path) >>= fun () -> - Lwt.catch - (fun () -> Lwt_unix.unlink (Naming.file_path file)) - (fun _exn -> Lwt.return_unit)) + Unit.catch_s (fun () -> Lwt_unix.unlink (Naming.file_path file))) files_to_remove let trigger_gc cemented_store = diff --git a/src/lib_store/floating_block_store.ml b/src/lib_store/floating_block_store.ml index 36220a64f920..14619613feab 100644 --- a/src/lib_store/floating_block_store.ml +++ b/src/lib_store/floating_block_store.ml @@ -67,8 +67,7 @@ let find_predecessors floating_store hash = let read_block_and_predecessors floating_store hash = Lwt_idle_waiter.task floating_store.scheduler (fun () -> - Lwt.catch - (fun () -> + Option.catch_os (fun () -> let {offset; predecessors} = Floating_block_index.find floating_store.floating_block_index hash in @@ -77,8 +76,7 @@ let read_block_and_predecessors floating_store hash = | Some (block, _) -> Lwt.return_some (block, predecessors) | None -> (* May be the case when a stored block is corrupted *) - Lwt.return_none) - (fun _exn -> Lwt.return_none)) + Lwt.return_none)) let read_block floating_store hash = read_block_and_predecessors floating_store hash >>= function @@ -318,14 +316,12 @@ let full_integrity_check chain_dir kind = (function _exn -> Lwt.return_false) let delete_files floating_store = - Lwt.catch - (fun () -> + Unit.catch_s (fun () -> close floating_store >>= fun () -> let floating_store_dir_path = Naming.dir_path floating_store.floating_blocks_dir in Lwt_utils_unix.remove_dir floating_store_dir_path) - (fun _ignore -> (* ignore errors *) Lwt.return_unit) let swap ~src ~dst = close src >>= fun () -> @@ -358,32 +354,24 @@ let fix_integrity chain_dir kind = (fun () -> Lwt.catch (fun () -> - Lwt.catch - (fun () -> - (* This [iter_s] stops reading whenever a block - cannot be read. *) - iter_s - (fun block -> - find_predecessors - inconsistent_floating_store - (Block_repr.hash block) - >>= function - | Some preds -> - (* TODO: should we retrieve info ? e.g. highest_level, highest_fitness ? *) - append_block fresh_floating_store preds block - >>= return - | None -> Lwt.fail Exit) - inconsistent_floating_store) - (function Exit -> return_unit | exn -> Lwt.fail exn) - >>=? fun () -> - swap - ~src:fresh_floating_store - ~dst:inconsistent_floating_store - >>= fun () -> return_unit) - (fun exn -> - (* Restoring integrity failed: delete the fresh_floating_store files *) - close inconsistent_floating_store >>= fun () -> - close fresh_floating_store >>= fun () -> Lwt.fail exn)) + (* This [iter_s] stops reading whenever a block + cannot be read. *) + iter_s + (fun block -> + find_predecessors + inconsistent_floating_store + (Block_repr.hash block) + >>= function + | Some preds -> + (* TODO: should we retrieve info ? e.g. highest_level, highest_fitness ? *) + append_block fresh_floating_store preds block + >>= return + | None -> Lwt.fail Exit) + inconsistent_floating_store) + (function Exit -> return_unit | exn -> Lwt.fail exn) + >>=? fun () -> + swap ~src:fresh_floating_store ~dst:inconsistent_floating_store + >>= fun () -> return_unit) (fun () -> close inconsistent_floating_store >>= fun () -> close fresh_floating_store >>= fun () -> diff --git a/src/lib_store/legacy_store/legacy_state.ml b/src/lib_store/legacy_store/legacy_state.ml index 26ee0c723ce9..b3136a5c2ff9 100644 --- a/src/lib_store/legacy_store/legacy_state.ml +++ b/src/lib_store/legacy_store/legacy_state.ml @@ -262,15 +262,13 @@ let predecessor_n_raw store block_hash distance = loop block_hash distance let predecessor_n block_store block_hash distance = - Lwt.catch - (fun () -> + Option.catch_os (fun () -> predecessor_n_raw block_store block_hash distance >>= function | None -> Lwt.return_none | Some predecessor -> ( Header.known (block_store, predecessor) >>= function | false -> Lwt.return_none | true -> Lwt.return_some predecessor)) - (fun _exn -> Lwt.return_none) type t = global_state diff --git a/src/lib_store/protocol_store.ml b/src/lib_store/protocol_store.ml index 75ba30b5e12c..6ede5319ef27 100644 --- a/src/lib_store/protocol_store.ml +++ b/src/lib_store/protocol_store.ml @@ -53,15 +53,13 @@ let store store protocol_hash protocol = raw_store store protocol_hash (Protocol.to_bytes protocol) let read store protocol_hash = - Lwt.catch - (fun () -> + Option.catch_os (fun () -> let protocol_file = Naming.protocol_file store.protocol_store_dir protocol_hash in Lwt_utils_unix.read_file (Naming.file_path protocol_file) >>= fun content -> Lwt.return (Protocol.of_bytes (Bytes.unsafe_of_string content))) - (fun _ -> Lwt.return_none) let init store_dir = let protocol_store_dir = Naming.protocol_store_dir store_dir in diff --git a/src/lib_store/snapshots.ml b/src/lib_store/snapshots.ml index d68df8df210a..88b9bffeec5a 100644 --- a/src/lib_store/snapshots.ml +++ b/src/lib_store/snapshots.ml @@ -726,11 +726,9 @@ let ensure_valid_export_path = function let clean_all paths = Lwt_list.iter_s (fun path -> - Lwt.catch - (fun () -> + Unit.catch_s (fun () -> if Sys.is_directory path then Lwt_utils_unix.remove_dir path - else Lwt_unix.unlink path) - (fun _ -> Lwt.return_unit)) + else Lwt_unix.unlink path)) paths (* This module allows to create a tar archive by adding files to it, @@ -1014,7 +1012,8 @@ end = struct Lwt_unix.close fd >>= fun () -> Lwt.return_unit let rec readdir dir_handler = - Lwt.catch + Option.catch_os + ~catch_only:(function End_of_file -> true | _ -> false) (fun () -> Lwt_unix.readdir dir_handler >>= function | filename @@ -1022,7 +1021,6 @@ end = struct || filename = Filename.parent_dir_name -> readdir dir_handler | any -> Lwt.return_some any) - (function End_of_file -> Lwt.return_none | e -> Lwt.fail e) let enumerate path = let rec aux prefix dir_handler acc = diff --git a/src/lib_store/store.ml b/src/lib_store/store.ml index 2b263033b0dc..3786e0be7f6e 100644 --- a/src/lib_store/store.ml +++ b/src/lib_store/store.ml @@ -172,8 +172,7 @@ let try_lock_for_write lockfile = Lwt_unix.lockf lockfile Unix.F_TLOCK 0 >>= fun () -> Lwt.return_true) (fun _ -> Lwt.return_false) -let may_unlock lockfile = - Lwt.catch (fun () -> unlock lockfile) (fun _ -> Lwt.return_unit) +let may_unlock lockfile = Unit.catch_s (fun () -> unlock lockfile) module Block = struct type nonrec block = block diff --git a/src/lib_store/stored_data.ml b/src/lib_store/stored_data.ml index 4714f7b447cd..4fe881a29a66 100644 --- a/src/lib_store/stored_data.ml +++ b/src/lib_store/stored_data.ml @@ -35,14 +35,12 @@ type _ t = -> 'a t let read_json_file file = - Lwt.catch - (fun () -> + Option.catch_os (fun () -> Lwt_utils_unix.Json.read_file (Naming.encoded_file_path file) >>= function | Ok json -> let encoding = Naming.file_encoding file in Lwt.return_some (Data_encoding.Json.destruct encoding json) | _ -> Lwt.return_none) - (fun _ -> Lwt.return_none) let read_file file = Lwt.try_bind -- GitLab From e5d6b101b92940be922e8e4288d6be23813863ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Thu, 29 Jul 2021 07:46:44 +0100 Subject: [PATCH 07/10] Everywhere: synchronise dune lang version in all dune files --- dune-project | 2 +- dune-workspace | 2 +- src/lib_base/test_helpers/dune-project | 2 +- src/lib_crypto/test/lib_alcotest_glue/unix/dune-project | 2 +- src/lib_crypto/test/lib_alcotest_glue/virtual/dune-project | 2 +- src/lib_event_logging/test_helpers/dune-project | 2 +- src/proto_000_Ps9mPmXa/lib_client/dune-project | 2 +- src/proto_001_PtCJ7pwo/lib_client/dune-project | 2 +- src/proto_001_PtCJ7pwo/lib_client_commands/dune-project | 2 +- src/proto_002_PsYLVpVv/lib_client/dune-project | 2 +- src/proto_002_PsYLVpVv/lib_client_commands/dune-project | 2 +- src/proto_003_PsddFKi3/lib_client/dune-project | 2 +- src/proto_003_PsddFKi3/lib_client_commands/dune-project | 2 +- src/proto_004_Pt24m4xi/lib_client/dune-project | 2 +- src/proto_004_Pt24m4xi/lib_client_commands/dune-project | 2 +- src/proto_005_PsBabyM1/lib_client/dune-project | 2 +- src/proto_005_PsBabyM1/lib_client_commands/dune-project | 2 +- src/proto_006_PsCARTHA/lib_client/dune-project | 2 +- src/proto_006_PsCARTHA/lib_client_commands/dune-project | 2 +- src/proto_006_PsCARTHA/lib_parameters/dune-project | 2 +- src/proto_007_PsDELPH1/lib_client/dune-project | 2 +- src/proto_007_PsDELPH1/lib_client_commands/dune-project | 2 +- src/proto_007_PsDELPH1/lib_plugin/dune-project | 2 +- tezt/lib/dune-project | 2 +- tezt/lib_tezos/dune-project | 2 +- 25 files changed, 25 insertions(+), 25 deletions(-) diff --git a/dune-project b/dune-project index 2f6b7f75e141..23655ad5ba99 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) ; dune-project files are automatically generated by dune but they are kept diff --git a/dune-workspace b/dune-workspace index de4fc2092005..45acd3f08847 100644 --- a/dune-workspace +++ b/dune-workspace @@ -1 +1 @@ -(lang dune 1.0) +(lang dune 2.7) diff --git a/src/lib_base/test_helpers/dune-project b/src/lib_base/test_helpers/dune-project index bb24e8d2d212..5e2cc229ce12 100644 --- a/src/lib_base/test_helpers/dune-project +++ b/src/lib_base/test_helpers/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-base-test-helpers) diff --git a/src/lib_crypto/test/lib_alcotest_glue/unix/dune-project b/src/lib_crypto/test/lib_alcotest_glue/unix/dune-project index 4f46cb755478..659e86e9d558 100644 --- a/src/lib_crypto/test/lib_alcotest_glue/unix/dune-project +++ b/src/lib_crypto/test/lib_alcotest_glue/unix/dune-project @@ -1,2 +1,2 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) diff --git a/src/lib_crypto/test/lib_alcotest_glue/virtual/dune-project b/src/lib_crypto/test/lib_alcotest_glue/virtual/dune-project index 4f46cb755478..659e86e9d558 100644 --- a/src/lib_crypto/test/lib_alcotest_glue/virtual/dune-project +++ b/src/lib_crypto/test/lib_alcotest_glue/virtual/dune-project @@ -1,2 +1,2 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) diff --git a/src/lib_event_logging/test_helpers/dune-project b/src/lib_event_logging/test_helpers/dune-project index 901049d21842..edfc69146a54 100644 --- a/src/lib_event_logging/test_helpers/dune-project +++ b/src/lib_event_logging/test_helpers/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-event-logging-test-helpers) diff --git a/src/proto_000_Ps9mPmXa/lib_client/dune-project b/src/proto_000_Ps9mPmXa/lib_client/dune-project index 762545eb084c..a2e2a19d806d 100644 --- a/src/proto_000_Ps9mPmXa/lib_client/dune-project +++ b/src/proto_000_Ps9mPmXa/lib_client/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-client-000-Ps9mPmXa) diff --git a/src/proto_001_PtCJ7pwo/lib_client/dune-project b/src/proto_001_PtCJ7pwo/lib_client/dune-project index 804c408fd22e..aab46ceca17c 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/dune-project +++ b/src/proto_001_PtCJ7pwo/lib_client/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-client-001-PtCJ7pwo) diff --git a/src/proto_001_PtCJ7pwo/lib_client_commands/dune-project b/src/proto_001_PtCJ7pwo/lib_client_commands/dune-project index d32ad71b0760..8a4201969975 100644 --- a/src/proto_001_PtCJ7pwo/lib_client_commands/dune-project +++ b/src/proto_001_PtCJ7pwo/lib_client_commands/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-client-001-PtCJ7pwo-commands) diff --git a/src/proto_002_PsYLVpVv/lib_client/dune-project b/src/proto_002_PsYLVpVv/lib_client/dune-project index b8828e827918..708213521711 100644 --- a/src/proto_002_PsYLVpVv/lib_client/dune-project +++ b/src/proto_002_PsYLVpVv/lib_client/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-client-002-PsYLVpVv) diff --git a/src/proto_002_PsYLVpVv/lib_client_commands/dune-project b/src/proto_002_PsYLVpVv/lib_client_commands/dune-project index e0f0618a34bf..6582e019f33f 100644 --- a/src/proto_002_PsYLVpVv/lib_client_commands/dune-project +++ b/src/proto_002_PsYLVpVv/lib_client_commands/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-client-002-PsYLVpVv-commands) diff --git a/src/proto_003_PsddFKi3/lib_client/dune-project b/src/proto_003_PsddFKi3/lib_client/dune-project index f811a0cd203a..9e6f4c92473b 100644 --- a/src/proto_003_PsddFKi3/lib_client/dune-project +++ b/src/proto_003_PsddFKi3/lib_client/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-client-003-PsddFKi3) diff --git a/src/proto_003_PsddFKi3/lib_client_commands/dune-project b/src/proto_003_PsddFKi3/lib_client_commands/dune-project index e837143cb482..05fa64e18bc8 100644 --- a/src/proto_003_PsddFKi3/lib_client_commands/dune-project +++ b/src/proto_003_PsddFKi3/lib_client_commands/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-client-003-PsddFKi3-commands) diff --git a/src/proto_004_Pt24m4xi/lib_client/dune-project b/src/proto_004_Pt24m4xi/lib_client/dune-project index 68cdb1accbf1..dbad904e5ee2 100644 --- a/src/proto_004_Pt24m4xi/lib_client/dune-project +++ b/src/proto_004_Pt24m4xi/lib_client/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-client-004-Pt24m4xi) diff --git a/src/proto_004_Pt24m4xi/lib_client_commands/dune-project b/src/proto_004_Pt24m4xi/lib_client_commands/dune-project index d5396a17afec..8777203df2ab 100644 --- a/src/proto_004_Pt24m4xi/lib_client_commands/dune-project +++ b/src/proto_004_Pt24m4xi/lib_client_commands/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-client-004-Pt24m4xi-commands) diff --git a/src/proto_005_PsBabyM1/lib_client/dune-project b/src/proto_005_PsBabyM1/lib_client/dune-project index 7b42adb05372..137a5c8ed6b8 100644 --- a/src/proto_005_PsBabyM1/lib_client/dune-project +++ b/src/proto_005_PsBabyM1/lib_client/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-client-005-PsBabyM1) diff --git a/src/proto_005_PsBabyM1/lib_client_commands/dune-project b/src/proto_005_PsBabyM1/lib_client_commands/dune-project index 4bb8a82bbb46..92509c3982b1 100644 --- a/src/proto_005_PsBabyM1/lib_client_commands/dune-project +++ b/src/proto_005_PsBabyM1/lib_client_commands/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-client-005-PsBabyM1-commands) diff --git a/src/proto_006_PsCARTHA/lib_client/dune-project b/src/proto_006_PsCARTHA/lib_client/dune-project index a6f0cee76b10..d18e3c9ee15d 100644 --- a/src/proto_006_PsCARTHA/lib_client/dune-project +++ b/src/proto_006_PsCARTHA/lib_client/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-client-006-PsCARTHA) diff --git a/src/proto_006_PsCARTHA/lib_client_commands/dune-project b/src/proto_006_PsCARTHA/lib_client_commands/dune-project index f7d6bd723656..7cad433d3f44 100644 --- a/src/proto_006_PsCARTHA/lib_client_commands/dune-project +++ b/src/proto_006_PsCARTHA/lib_client_commands/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-client-006-PsCARTHA-commands) diff --git a/src/proto_006_PsCARTHA/lib_parameters/dune-project b/src/proto_006_PsCARTHA/lib_parameters/dune-project index 596a5f0a873b..fb0ed5020f23 100644 --- a/src/proto_006_PsCARTHA/lib_parameters/dune-project +++ b/src/proto_006_PsCARTHA/lib_parameters/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-protocol-006-PsCARTHA-parameters) diff --git a/src/proto_007_PsDELPH1/lib_client/dune-project b/src/proto_007_PsDELPH1/lib_client/dune-project index 890514c6faa1..90c61de348f1 100644 --- a/src/proto_007_PsDELPH1/lib_client/dune-project +++ b/src/proto_007_PsDELPH1/lib_client/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-client-alpha) diff --git a/src/proto_007_PsDELPH1/lib_client_commands/dune-project b/src/proto_007_PsDELPH1/lib_client_commands/dune-project index 2cbeb8024d79..7cc9e6db1fec 100644 --- a/src/proto_007_PsDELPH1/lib_client_commands/dune-project +++ b/src/proto_007_PsDELPH1/lib_client_commands/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-client-alpha-commands) diff --git a/src/proto_007_PsDELPH1/lib_plugin/dune-project b/src/proto_007_PsDELPH1/lib_plugin/dune-project index 7c81cbf84b34..5c9063fdca1c 100644 --- a/src/proto_007_PsDELPH1/lib_plugin/dune-project +++ b/src/proto_007_PsDELPH1/lib_plugin/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezos-filters-007-PsDELPH1) diff --git a/tezt/lib/dune-project b/tezt/lib/dune-project index b27188914912..508555585c78 100644 --- a/tezt/lib/dune-project +++ b/tezt/lib/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezt) diff --git a/tezt/lib_tezos/dune-project b/tezt/lib_tezos/dune-project index 6c30a733ceed..24ba40f10529 100644 --- a/tezt/lib_tezos/dune-project +++ b/tezt/lib_tezos/dune-project @@ -1,3 +1,3 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (name tezt-tezos) -- GitLab From 50e68fab650b37664384cbd1d3fc84e1c66447a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 6 Aug 2021 10:33:16 +0100 Subject: [PATCH 08/10] Clic: error and exception management improvemens --- src/lib_clic/clic.ml | 68 ++++++++++++++++---------------------------- 1 file changed, 25 insertions(+), 43 deletions(-) diff --git a/src/lib_clic/clic.ml b/src/lib_clic/clic.ml index 8162dce537e8..fb74fa7fa16e 100644 --- a/src/lib_clic/clic.ml +++ b/src/lib_clic/clic.ml @@ -762,21 +762,19 @@ let parse_arg : >|=? fun x -> Some x | Some (_ :: _) -> fail (Multiple_occurrences ("--" ^ long, command))) | DefArg {label = {long; short = _}; kind = {converter; _}; default; _} -> ( - converter ctx default >>= fun default -> - (match default with - | Ok x -> return x + converter ctx default >>= function | Error _ -> invalid_arg (Format.sprintf "Value provided as default for '%s' could not be parsed by \ converter function." - long)) - >>=? fun default -> - match TzString.Map.find_opt long args_dict with - | None | Some [] -> return default - | Some [s] -> - trace (Bad_option_argument (long, command)) (converter ctx s) - | Some (_ :: _) -> fail (Multiple_occurrences (long, command))) + long) + | Ok default -> ( + match TzString.Map.find_opt long args_dict with + | None | Some [] -> return default + | Some [s] -> + trace (Bad_option_argument (long, command)) (converter ctx s) + | Some (_ :: _) -> fail (Multiple_occurrences (long, command)))) | Switch {label = {long; short = _}; _} -> ( match TzString.Map.find_opt long args_dict with | None | Some [] -> return_false @@ -869,10 +867,9 @@ let make_args_dict_consume ?command spec args = | (1, []) when completing -> return (acc, []) | (1, []) -> fail (Option_expected_argument (arg, None)) | (_, _) -> - raise - (Failure - "cli_entries: Arguments with arity not equal to 1 or 0 \ - not supported") + Stdlib.failwith + "cli_entries: Arguments with arity not equal to 1 or 0 not \ + supported" else fail (Unknown_option (arg, None)) else return (acc, args) in @@ -904,10 +901,9 @@ let make_args_dict_filter ?command spec args = tl' | (1, []) -> fail (Option_expected_argument (arg, command)) | (_, _) -> - raise - (Failure - "cli_entries: Arguments with arity not equal to 1 or 0 not \ - supported") + Stdlib.failwith + "cli_entries: Arguments with arity not equal to 1 or 0 not \ + supported" else make_args_dict arities (dict, arg :: other_args) tl in make_args_dict @@ -1395,8 +1391,9 @@ let string ~name ~desc next = next let string_contains ~needle ~haystack = - try Some (Re.Str.search_forward (Re.Str.regexp_string needle) haystack 0) - with Not_found -> None + Option.catch + ~catch_only:(function Not_found -> true | _ -> false) + (fun () -> Re.Str.search_forward (Re.Str.regexp_string needle) haystack 0) let rec search_params_prefix : type a arg. string -> (a, arg) params -> bool = fun prefix -> function @@ -1439,11 +1436,7 @@ let exec (type ctx) let rec do_seq i acc = function | [] -> return (List.rev acc) | p :: rest -> - Lwt.catch - (fun () -> converter ctx p) - (function - | Failure msg -> Error_monad.failwith "%s" msg - | exn -> fail (Exn exn)) + Error_monad.catch_es (fun () -> converter ctx p) |> trace (Bad_argument (i, p)) >>=? fun v -> do_seq (succ i) (v :: acc) rest in @@ -1465,28 +1458,18 @@ let exec (type ctx) if matched then return (List.rev acc, unmatched_rest) else (* if suffix is not match, try to continue with the sequence *) - Lwt.catch - (fun () -> + Error_monad.catch_es (fun () -> converter ctx p >>=? fun v -> do_seq (succ i) (v :: acc) rest) - (function - | err -> ( - match err with - | Failure msg -> Error_monad.failwith "%s" msg - | exn -> fail (Exn exn))) in do_seq i [] seq >>=? fun (parsed, rest) -> exec (succ i) ctx next (cb parsed) rest | (Prefix (n, next), p :: rest) when n = p -> exec (succ i) ctx next cb rest | (Param (_, _, {converter; _}, next), p :: rest) -> - Lwt.catch - (fun () -> converter ctx p) - (function - | Failure msg -> Error_monad.failwith "%s" msg - | exn -> fail (Exn exn)) + Error_monad.catch_es (fun () -> converter ctx p) |> trace (Bad_argument (i, p)) >>=? fun v -> exec (succ i) ctx next (cb v) rest - | _ -> raise (Failure "cli_entries internal error: exec no case matched") + | _ -> Stdlib.failwith "cli_entries internal error: exec no case matched" in let ctx = conv ctx in parse_args ~command options_spec args_dict ctx >>=? fun parsed_options -> @@ -1565,7 +1548,7 @@ let insert_in_dispatch_tree : type ctx. ctx tree -> ctx command -> ctx tree = let autocomplete = conv_autocomplete autocomplete in if not (has_options cmd) then TParam {tree = insert_tree TEmpty next; stop = Some cmd; autocomplete} - else raise (Failure "Command cannot have both prefix and options") + else Stdlib.failwith "Command cannot have both prefix and options" | (TStop cmd, Prefix (n, next)) -> TPrefix {stop = Some cmd; prefix = [(n, insert_tree TEmpty next)]} | (TStop cmd, NonTerminalSeq (name, desc, {autocomplete; _}, suffix, next)) @@ -1594,10 +1577,9 @@ let insert_in_dispatch_tree : type ctx. ctx tree -> ctx command -> ctx tree = n <> t.name || desc <> t.desc || t.suffix <> suffix (* we should match the parameter too but this would require a bit of refactoring*) then - raise - (Failure - "Command cannot have different non_terminal_seq_level at the \ - same position") + Stdlib.failwith + "Command cannot have different non_terminal_seq_level at the same \ + position" else let params = suffix_to_params suffix next in TNonTerminalSeq {t with tree = insert_tree t.tree params} -- GitLab From 5b50a92d264cf83bdf695900300f40c68d3a927c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 11 Aug 2021 17:40:19 +0100 Subject: [PATCH 09/10] Error-monad: avoid double registery of Canceled --- src/lib_error_monad/error_monad.ml | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/src/lib_error_monad/error_monad.ml b/src/lib_error_monad/error_monad.ml index 8b9456b255ae..0251997ab4b9 100644 --- a/src/lib_error_monad/error_monad.ml +++ b/src/lib_error_monad/error_monad.ml @@ -75,16 +75,6 @@ let pp_exn ppf exn = pp ppf (Exn exn) type error += Canceled -let () = - register_error_kind - `Temporary - ~id:"utils.Canceled" - ~title:"Canceled" - ~description:"Canceled" - Data_encoding.unit - (function Canceled -> Some () | _ -> None) - (fun () -> Canceled) - let () = register_error_kind `Temporary -- GitLab From fdb51cdd8cbc262417fa5af3d8c74bb8e37c956d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 17 Aug 2021 10:06:51 +0100 Subject: [PATCH 10/10] Clic: minor error message improvements --- src/lib_clic/clic.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/lib_clic/clic.ml b/src/lib_clic/clic.ml index fb74fa7fa16e..1040ec1faced 100644 --- a/src/lib_clic/clic.ml +++ b/src/lib_clic/clic.ml @@ -868,8 +868,8 @@ let make_args_dict_consume ?command spec args = | (1, []) -> fail (Option_expected_argument (arg, None)) | (_, _) -> Stdlib.failwith - "cli_entries: Arguments with arity not equal to 1 or 0 not \ - supported" + "cli_entries: Arguments with arity not equal to 1 or 0 \ + unsupported" else fail (Unknown_option (arg, None)) else return (acc, args) in @@ -902,8 +902,8 @@ let make_args_dict_filter ?command spec args = | (1, []) -> fail (Option_expected_argument (arg, command)) | (_, _) -> Stdlib.failwith - "cli_entries: Arguments with arity not equal to 1 or 0 not \ - supported" + "cli_entries: Arguments with arity not equal to 1 or 0 \ + unsupported" else make_args_dict arities (dict, arg :: other_args) tl in make_args_dict -- GitLab