From 8b9a6e9fadfd3922c5addcbfc7b6ecea8095e127 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 8 Dec 2020 10:30:29 +0100 Subject: [PATCH 1/7] Stdlib_unix: externalise Lwt-exit --- .gitlab/ci/unittest.yml | 1 - src/bin_node/dune | 3 +- src/bin_node/tezos-node.opam | 1 + src/bin_validation/tezos-validator.opam | 1 + src/lib_client_base_unix/dune | 3 +- .../tezos-client-base-unix.opam | 1 + src/lib_protocol_updater/dune | 1 + .../tezos-protocol-updater.opam | 1 + src/lib_shell/dune | 3 +- src/lib_shell/tezos-shell.opam | 1 + src/lib_stdlib_unix/lwt_exit.ml | 501 ------------------ src/lib_stdlib_unix/lwt_exit.mli | 440 --------------- src/lib_stdlib_unix/test/.ocamlformat | 12 - src/lib_stdlib_unix/test/dune | 122 ----- .../test/test_lwt_exit_after.ml | 65 --- .../test/test_lwt_exit_clean_up.ml | 48 -- .../test/test_lwt_exit_clean_up_failure.ml | 56 -- .../test/test_lwt_exit_clean_up_timeout.ml | 57 -- .../test/test_lwt_exit_exit.ml | 40 -- .../test/test_lwt_exit_exit_escape.ml | 42 -- .../test/test_lwt_exit_main_is_clean_up.ml | 186 ------- .../test/test_lwt_exit_raise.ml | 44 -- .../test/test_lwt_exit_raise_exit.ml | 43 -- .../test/test_lwt_exit_range_of_signals.ml | 108 ---- .../test/test_lwt_exit_return.ml | 36 -- .../test/test_lwt_exit_signal.ml | 235 -------- .../test/test_lwt_exit_unregister_clean_up.ml | 51 -- ...lwt_exit_unregister_clean_up_with_after.ml | 61 --- src/proto_007_PsDELPH1/lib_delegate/dune | 3 +- .../tezos-baking-007-PsDELPH1.opam | 1 + src/proto_008_PtEdoTez/lib_delegate/dune | 3 +- .../tezos-baking-008-PtEdoTez.opam | 1 + src/proto_alpha/lib_delegate/dune | 3 +- .../lib_delegate/tezos-baking-alpha.opam | 1 + 34 files changed, 21 insertions(+), 2154 deletions(-) delete mode 100644 src/lib_stdlib_unix/lwt_exit.ml delete mode 100644 src/lib_stdlib_unix/lwt_exit.mli delete mode 100644 src/lib_stdlib_unix/test/.ocamlformat delete mode 100644 src/lib_stdlib_unix/test/dune delete mode 100644 src/lib_stdlib_unix/test/test_lwt_exit_after.ml delete mode 100644 src/lib_stdlib_unix/test/test_lwt_exit_clean_up.ml delete mode 100644 src/lib_stdlib_unix/test/test_lwt_exit_clean_up_failure.ml delete mode 100644 src/lib_stdlib_unix/test/test_lwt_exit_clean_up_timeout.ml delete mode 100644 src/lib_stdlib_unix/test/test_lwt_exit_exit.ml delete mode 100644 src/lib_stdlib_unix/test/test_lwt_exit_exit_escape.ml delete mode 100644 src/lib_stdlib_unix/test/test_lwt_exit_main_is_clean_up.ml delete mode 100644 src/lib_stdlib_unix/test/test_lwt_exit_raise.ml delete mode 100644 src/lib_stdlib_unix/test/test_lwt_exit_raise_exit.ml delete mode 100644 src/lib_stdlib_unix/test/test_lwt_exit_range_of_signals.ml delete mode 100644 src/lib_stdlib_unix/test/test_lwt_exit_return.ml delete mode 100644 src/lib_stdlib_unix/test/test_lwt_exit_signal.ml delete mode 100644 src/lib_stdlib_unix/test/test_lwt_exit_unregister_clean_up.ml delete mode 100644 src/lib_stdlib_unix/test/test_lwt_exit_unregister_clean_up_with_after.ml diff --git a/.gitlab/ci/unittest.yml b/.gitlab/ci/unittest.yml index 775663d295bf..94772d8dbbea 100644 --- a/.gitlab/ci/unittest.yml +++ b/.gitlab/ci/unittest.yml @@ -64,7 +64,6 @@ unit:alltest: - scripts/test_wrapper.sh src/lib_signer_backends signer_backends - scripts/test_wrapper.sh src/lib_signer_backends/unix signer_backends_unix - scripts/test_wrapper.sh src/lib_stdlib stdlib - - scripts/test_wrapper.sh src/lib_stdlib_unix stdlib_unix - scripts/test_wrapper.sh src/lib_storage storage - scripts/test_wrapper.sh src/proto_006_PsCARTHA/lib_client 006_PsCARTHA_lib_client - scripts/test_wrapper.sh src/proto_007_PsDELPH1/lib_client 007_PsDELPH1_lib_client diff --git a/src/bin_node/dune b/src/bin_node/dune index 0c033582e2bd..3b897f103b58 100644 --- a/src/bin_node/dune +++ b/src/bin_node/dune @@ -75,7 +75,8 @@ (tezos-mempool-008-PtEdoTez -> void_for_linking-008-PtEdoTez-mempool.empty) (-> void_for_linking-008-PtEdoTez-mempool.empty)) cmdliner - tls) + tls + lwt-exit) (flags (:standard -open Tezos_base__TzPervasives -open Tezos_base -open Tezos_stdlib_unix diff --git a/src/bin_node/tezos-node.opam b/src/bin_node/tezos-node.opam index d6630c495e43..56947a0baa4b 100644 --- a/src/bin_node/tezos-node.opam +++ b/src/bin_node/tezos-node.opam @@ -35,6 +35,7 @@ depends: [ "tezos-mempool-007-PsDELPH1" "tezos-mempool-008-PtEdoTez" "cmdliner" + "lwt-exit" "tls" { >= "0.10" < "0.11" } # remove the upper bond when the compatibility with hacl-star is restored "cstruct" ] diff --git a/src/bin_validation/tezos-validator.opam b/src/bin_validation/tezos-validator.opam index 307726d6d3aa..363eba761879 100644 --- a/src/bin_validation/tezos-validator.opam +++ b/src/bin_validation/tezos-validator.opam @@ -15,6 +15,7 @@ depends: [ "tezos-shell" "tezos-shell-context" "tezos-validation" + "lwt-exit" ] build: [ [ "dune" "build" "-p" name "-j" jobs ] diff --git a/src/lib_client_base_unix/dune b/src/lib_client_base_unix/dune index 4fb49fac0986..f74dded3eeed 100644 --- a/src/lib_client_base_unix/dune +++ b/src/lib_client_base_unix/dune @@ -11,7 +11,8 @@ tezos-mockup-commands tezos-proxy tezos-signer-backends.unix - tezos-shell-services) + tezos-shell-services + lwt-exit) (flags (:standard -open Tezos_base__TzPervasives -open Tezos_rpc_http -open Tezos_rpc_http_client_unix diff --git a/src/lib_client_base_unix/tezos-client-base-unix.opam b/src/lib_client_base_unix/tezos-client-base-unix.opam index ca2421da59e8..e3c698a0b988 100644 --- a/src/lib_client_base_unix/tezos-client-base-unix.opam +++ b/src/lib_client_base_unix/tezos-client-base-unix.opam @@ -17,6 +17,7 @@ depends: [ "tezos-mockup-registration" "tezos-mockup-commands" "tezos-proxy" + "lwt-exit" "tezos-test-services" { with-test } ] build: [ diff --git a/src/lib_protocol_updater/dune b/src/lib_protocol_updater/dune index 390484a760bb..7aa1fa3b6b25 100644 --- a/src/lib_protocol_updater/dune +++ b/src/lib_protocol_updater/dune @@ -10,6 +10,7 @@ tezos-protocol-compiler.registerer tezos-protocol-compiler.native tezos-storage + lwt-exit dynlink) (flags (:standard -open Tezos_base__TzPervasives -open Tezos_stdlib_unix diff --git a/src/lib_protocol_updater/tezos-protocol-updater.opam b/src/lib_protocol_updater/tezos-protocol-updater.opam index c3114659a4a1..d06d1f265819 100644 --- a/src/lib_protocol_updater/tezos-protocol-updater.opam +++ b/src/lib_protocol_updater/tezos-protocol-updater.opam @@ -15,6 +15,7 @@ depends: [ "tezos-shell-context" "tezos-stdlib-unix" "tezos-storage" + "lwt-exit" ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/lib_shell/dune b/src/lib_shell/dune index 774a2b4dfe19..c93f2c9fbd7e 100644 --- a/src/lib_shell/dune +++ b/src/lib_shell/dune @@ -14,7 +14,8 @@ tezos-protocol-updater tezos-requester tezos-workers - tezos-validation) + tezos-validation + lwt-exit) (flags (:standard -open Tezos_base__TzPervasives -open Tezos_base -open Tezos_storage diff --git a/src/lib_shell/tezos-shell.opam b/src/lib_shell/tezos-shell.opam index 98cbad0fdc18..3efb5e9dbe20 100644 --- a/src/lib_shell/tezos-shell.opam +++ b/src/lib_shell/tezos-shell.opam @@ -19,6 +19,7 @@ depends: [ "tezos-requester" "lwt-watcher" { = "0.1" } "lwt-canceler" { = "0.2" } + "lwt-exit" "alcotest-lwt" { with-test & >= "1.1.0" } "crowbar" { with-test } "tezos-workers" diff --git a/src/lib_stdlib_unix/lwt_exit.ml b/src/lib_stdlib_unix/lwt_exit.ml deleted file mode 100644 index 57ccc252281f..000000000000 --- a/src/lib_stdlib_unix/lwt_exit.ml +++ /dev/null @@ -1,501 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -open Lwt.Infix - -(* 1. clean-up callback registration/unregistration *) - -(* Identifiers are used for unregistering clean-up callbacks *) -type clean_up_callback_id = int - -let clean_up_callback_id_counter = ref min_int - -let new_clean_up_callback_id () = - incr clean_up_callback_id_counter ; - !clean_up_callback_id_counter - -(* clean-up callbacks are stored in a reference to a map *) -module Callbacks_map = Map.Make (Int) - -type callback = { - callback : int -> unit Lwt.t; - after : clean_up_callback_id list; - loc : string; -} - -let clean_up_callbacks : callback Callbacks_map.t ref = ref Callbacks_map.empty - -(* adding and removing clean-up callbacks affects the global reference map *) -let register_clean_up_callback ?(after = []) ~loc callback = - let id = new_clean_up_callback_id () in - let callback = {callback; after; loc} in - clean_up_callbacks := Callbacks_map.add id callback !clean_up_callbacks ; - id - -let unregister_clean_up_callback id = - clean_up_callbacks := Callbacks_map.remove id !clean_up_callbacks - -(* 2. clean-up *) - -(* cleaning-up is just calling all the clean-up callbacks, note that the - function is not exported: it cannot be called directly, it can only be - triggered as a side effect to calling [exit_and_raise] or [exit_and_wait] - - Returns a seq of clean-up promises along with their identifiers. *) -let clean_up status = - (* NOTE: [to_seq] iterates in increasing order of keys *) - let callbacks = Callbacks_map.to_seq !clean_up_callbacks in - clean_up_callbacks := Callbacks_map.empty ; - let promises : (string * unit Lwt.t) Callbacks_map.t = - Seq.fold_left - (fun promises (id, {callback; after; loc}) -> - let pre = - match after with - | [] -> - Lwt.return_unit - | _ :: _ as after -> ( - match - Callbacks_map.fold - (fun id (_, p) ps -> if List.mem id after then p :: ps else ps) - promises - [] - with - | [] -> - (* This can happen if all after-callbacks were unregistered *) - Lwt.return_unit - | [p] -> - p - | _ :: _ :: _ as ps -> - Lwt.join ps ) - in - let promise = pre >>= fun () -> callback status in - Lwt.on_failure promise (fun exc -> - Format.eprintf - "(%s) Exit: uncaught exception during clean-up (%s): %s\n%!" - Sys.executable_name - loc - (Printexc.to_string exc)) ; - Callbacks_map.add id (loc, promise) promises) - Callbacks_map.empty - callbacks - in - Seq.map snd @@ Callbacks_map.to_seq promises - -(* 3. synchronisation primitives *) - -(* [clean_up_starts] an exported promise that resolves when the clean-up starts. - [start_clean_up] a non-exported resolver for the promise. - - Note that the promise is not cancelable and we never pass an exception to the - resolver. Consequently, the promise cannot be rejected. *) -let (clean_up_starts_internal, start_clean_up) = Lwt.wait () - -(* [clean_up_starts] is exported with a delay to ensure that [wrap_and_*] - function witness the start of the cleaning up before users of the library. *) -let clean_up_starts = - Lwt.no_cancel - ( clean_up_starts_internal - >>= fun v -> Lwt.pause () >>= fun () -> Lwt.return v ) - -let clean_up_promises = - clean_up_starts_internal >>= fun status -> Lwt.return @@ clean_up status - -(* [clean_up_ends] is a promise that resolves once the clean-up is finished. *) -let clean_up_ends = - clean_up_starts_internal - >>= fun status -> - clean_up_promises - >>= fun promises -> - Lwt.join @@ List.of_seq - @@ Seq.map - (fun (_, promise) -> - Lwt.try_bind - (fun () -> promise) - (fun () -> Lwt.return_unit) - (fun _ -> Lwt.return_unit)) - promises - >>= fun () -> Lwt.return status - -(* 4. exiting *) - -(* simple exit is not exported, it is just to factor out exiting *) -let exit n = - match Lwt.state clean_up_starts_internal with - | Sleep -> - Lwt.wakeup start_clean_up n - | Return _ -> - () - | Fail _ -> - (* Remember [clean_up_starts_internal] cannot be rejected. *) - assert false - -(* [exit_and_raise] is meant to be used deep inside the program after having - witnessed, say, a fatal error. It raises an exception so that it can be used - anywhere in the program. *) -let exit_and_raise n = exit n ; raise Exit - -(* [exit_and_wait] is meant to be used near the main invocation of the program, - right inside of [Lwt_main.run] but presumably after [wrap_and_error]. *) -let exit_and_wait n = exit n ; clean_up_ends - -(* exit codes *) - -let incomplete_clean_up_mask = 128 - -let signal_exit_code = 127 - -let uncaught_exception_exit_code = 126 - -let mask_code_bc_incomplete_clean_up code = code lor incomplete_clean_up_mask - -let mask_code_if_incomplete_clean_up ~complete:all_fine code = - if all_fine then code else mask_code_bc_incomplete_clean_up code - -(* 5. signals *) - -type signal_setup = {soft : (int * string) list; hard : (int * string) list} - -(** Known signals and their names *) -let all_signal_names = - let open Sys in - [ (sigabrt, "ABRT"); - (sigalrm, "ALRM"); - (sigfpe, "FPE"); - (sighup, "HUP"); - (sigill, "ILL"); - (sigint, "INT"); - (sigkill, "KILL"); - (sigpipe, "PIPE"); - (sigquit, "QUIT"); - (sigsegv, "SEGV"); - (sigterm, "TERM"); - (sigusr1, "USR1"); - (sigusr2, "USR2"); - (sigchld, "CHLD"); - (sigcont, "CONT"); - (sigstop, "STOP"); - (sigtstp, "TSTP"); - (sigttin, "TTIN"); - (sigttou, "TTOU"); - (sigvtalrm, "VTALRM"); - (sigprof, "PROF"); - (sigbus, "BUS"); - (sigpoll, "POLL"); - (sigsys, "SYS"); - (sigtrap, "TRAP"); - (sigurg, "URG"); - (sigxcpu, "XCPU"); - (sigxfsz, "XFSZ") ] - -(** recovering the name of a signal *) -let signal_name signal = - match List.assoc_opt signal all_signal_names with - | Some name -> - name - | None -> - Format.asprintf "%d" signal - -let make_signal_setup ~soft ~hard = - try - let soft = List.map (fun signal -> (signal, signal_name signal)) soft in - let hard = List.map (fun signal -> (signal, signal_name signal)) hard in - {soft; hard} - with Not_found -> raise (Invalid_argument "Lwt_exit.make_signal_setup") - -let default_signal_setup = - make_signal_setup ~soft:[Sys.sigint; Sys.sigterm] ~hard:[] - -let sleep_span s = Lwt_unix.sleep (Ptime.Span.to_float_s s) - -let set_already_received_once double_signal_safety already_received_once name = - if Ptime.Span.(equal double_signal_safety zero) then ( - Format.eprintf - "(%s) %s: send signal again to force-quit.\n%!" - Sys.executable_name - name ; - already_received_once := true ) - else - Lwt_utils.dont_wait - (fun _exc -> assert false) - (fun () -> - (* Wait one second for safety, then set force-quitting *) - sleep_span double_signal_safety - >>= fun () -> - Format.eprintf - "(%s) %s: send signal again to force-quit.\n%!" - Sys.executable_name - name ; - already_received_once := true ; - Lwt.return_unit) - -let default_double_signal_safety = Option.get @@ Ptime.Span.of_float_s 1.0 - -(* soft handling: trigger an exit on first signal, immediately terminate - process on second signal *) -let set_soft_handler ?(double_signal_safety = default_double_signal_safety) - signal name = - let already_received_once = ref false in - Lwt_unix.on_signal signal (fun _signal -> - if !already_received_once then ( - Format.eprintf - "(%s) %s: signal received again, forcing immediate termination.\n%!" - Sys.executable_name - name ; - Stdlib.exit (mask_code_bc_incomplete_clean_up signal_exit_code) ) - else - match Lwt.state clean_up_starts_internal with - | Sleep -> - Format.eprintf - "(%s) %s: triggering shutdown.\n%!" - Sys.executable_name - name ; - exit signal_exit_code ; - set_already_received_once - double_signal_safety - already_received_once - name - | Return _ -> - Format.eprintf - "(%s) %s: already in shutdown.\n%!" - Sys.executable_name - name ; - set_already_received_once - double_signal_safety - already_received_once - name - | Fail _ -> - (* Remember [clean_up_starts_internal] cannot be rejected. *) - assert false) - -(* hard handling: immediately terminate process *) -let set_hard_handler signal name = - Lwt_unix.on_signal signal (fun _signal -> - Format.eprintf "(%s) %s: force-quiting.\n%!" Sys.executable_name name ; - Stdlib.exit (mask_code_bc_incomplete_clean_up signal_exit_code)) - -let setup_signal_handlers ?double_signal_safety signal_setup = - let soft_handler_ids = - List.fold_left - (fun acc (signal, name) -> - set_soft_handler ?double_signal_safety signal name :: acc) - [] - signal_setup.soft - in - let all_handler_ids = - List.fold_left - (fun acc (signal, name) -> set_hard_handler signal name :: acc) - soft_handler_ids - signal_setup.hard - in - all_handler_ids - -let unset_handlers = List.iter Lwt_unix.disable_signal_handler - -(* 6. internal synchronisation *) - -let wait_for_clean_up max_clean_up_time = - ( match Lwt.state clean_up_starts_internal with - | Return _ -> - () - | Fail _ -> - (* Remember [clean_up_starts_internal] cannot be rejected. *) - assert false - | Sleep -> - (* We only call this function after the clean-up has started, and we do - not export the function *) - assert false ) ; - Lwt.pause () - >>= fun () -> - ( match Lwt.state clean_up_promises with - | Return _ -> - () - | Fail _ -> - (* the promises are a promise that cannot be rejected *) - assert false - | Sleep -> - (* One tick after the clean-up has started, all the promises have been - collected. *) - assert false ) ; - ( match Lwt.state clean_up_ends with - | Fail _ -> - assert false - | Return _ -> - (* This happens when there are no callbacks registered: the clean-up is - immediate. *) - Lwt.return_unit - | Sleep -> ( - match max_clean_up_time with - | None -> - (* without timeout: just wait *) - clean_up_ends >>= fun _ -> Lwt.return_unit - | Some s -> - (* with timeout: pick first to finish *) - Lwt.choose [(clean_up_ends >>= fun _ -> Lwt.return_unit); sleep_span s] - ) ) - (* pause in case timeout and clean-up needs to deal with cancellation *) - >>= Lwt.pause - >|= fun () -> - match Lwt.state clean_up_promises with - | Lwt.Sleep -> - (* we have already asserted this earlier in the function *) - assert false - | Lwt.Fail _ -> - (* we have already asserted this earlier in the function *) - assert false - | Lwt.Return promises -> - (* check (and log) whether all clean-up is done successfully *) - Seq.fold_left - (fun all_fine (id, promise) -> - match Lwt.state promise with - | Lwt.Sleep -> - (* if a promise has not been given enough time to resolve, then it - means it was interupted by a timeout: [max_clean_up_time] *) - assert (max_clean_up_time <> None) ; - Format.eprintf - "(%s) Exit: timeout, clean-up callback not terminated (%s)\n%!" - Sys.executable_name - id ; - false - | Lwt.Fail exc -> - Format.eprintf - "(%s) Exit: clean-up callback failed (%s): %s\n%!" - Sys.executable_name - id - (Printexc.to_string exc) ; - false - | Lwt.Return () -> - all_fine) - true - promises - -(* 7. main interface: wrapping promises *) - -(* take a promise and wrap it in `Ok` but also watch for exiting and wrap that - in `Error` *) -let wrap_and_error ?(signal_setup = default_signal_setup) ?double_signal_safety - ?max_clean_up_time p = - ( match Lwt.state clean_up_starts_internal with - | Lwt.Fail _ -> - (* Remember [clean_up_starts_internal] cannot be rejected. *) - assert false - | Lwt.Return _ -> - raise (Invalid_argument "Lwt_exit.wrap") - | Lwt.Sleep -> - () ) ; - match Lwt.state p with - | Lwt.Fail _ | Lwt.Return _ -> - p >>= Lwt.return_ok - | Lwt.Sleep -> - let handler_ids = - setup_signal_handlers ?double_signal_safety signal_setup - in - Lwt.try_bind - (fun () -> - (* Watch out for both [p] and the start of clean-up *) - Lwt.choose - [p >>= Lwt.return_ok; clean_up_starts_internal >>= Lwt.return_error]) - (function - | Ok v -> - (* In this branch, the [Ok] indicates that [p] was resolved before - [clean_up_starts_internal]. As a result, - [clean_up_starts_internal] must still be pending. - - It is only possible for two promises to resolve simultaneously - if they are physically equal, if one is a proxy for the other, - or some other similar situation. Because - [clean_up_starts_internal] is not exported, this is not - possible. *) - assert (Lwt.state clean_up_starts_internal = Lwt.Sleep) ; - unset_handlers handler_ids ; - Lwt.return (Ok v) - | Error status -> - (* Conversely to the previous comment: when - [clean_up_starts_internal] resolves first, then [p] cannot have - resolved yet. *) - assert (Lwt.state clean_up_starts_internal = Lwt.Return status) ; - Lwt.cancel p ; - wait_for_clean_up max_clean_up_time - >>= fun complete -> - unset_handlers handler_ids ; - let status = mask_code_if_incomplete_clean_up ~complete status in - Lwt.return (Error status)) - (function - | Exit -> ( - (* When [Exit] bubbles from the wrapped promise, maybe it called - [exit_and_raise] *) - Lwt.pause () - >>= fun () -> - match Lwt.state clean_up_starts_internal with - | Return status -> - wait_for_clean_up max_clean_up_time - >>= fun complete -> - unset_handlers handler_ids ; - let status = - mask_code_if_incomplete_clean_up ~complete status - in - Lwt.return (Error status) - | Fail _ -> - (* Remember [clean_up_starts_internal] cannot be rejected. *) - assert false - | Sleep -> - exit uncaught_exception_exit_code ; - Format.eprintf - "(%s) Exit: exit because of uncaught exception: %s\n%!" - Sys.executable_name - (Printexc.to_string Exit) ; - wait_for_clean_up max_clean_up_time - >>= fun complete -> - unset_handlers handler_ids ; - let status = - mask_code_if_incomplete_clean_up - ~complete - uncaught_exception_exit_code - in - Lwt.return (Error status) ) - | exc -> - exit uncaught_exception_exit_code ; - Format.eprintf - "(%s) Exit: exit because of uncaught exception: %s\n%!" - Sys.executable_name - (Printexc.to_string exc) ; - wait_for_clean_up max_clean_up_time - >>= fun complete -> - unset_handlers handler_ids ; - let status = - mask_code_if_incomplete_clean_up - ~complete - uncaught_exception_exit_code - in - Lwt.return (Error status)) - -(* same but exit on error *) -let wrap_and_exit ?signal_setup ?double_signal_safety ?max_clean_up_time p = - wrap_and_error ?max_clean_up_time ?double_signal_safety ?signal_setup p - >>= function Ok v -> Lwt.return v | Error status -> Stdlib.exit status - -(* same but just return exit status *) -let wrap_and_forward ?signal_setup ?double_signal_safety ?max_clean_up_time p = - wrap_and_error ?max_clean_up_time ?double_signal_safety ?signal_setup p - >>= function Ok v -> Lwt.return v | Error status -> Lwt.return status diff --git a/src/lib_stdlib_unix/lwt_exit.mli b/src/lib_stdlib_unix/lwt_exit.mli deleted file mode 100644 index c114553cfe63..000000000000 --- a/src/lib_stdlib_unix/lwt_exit.mli +++ /dev/null @@ -1,440 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -(** {1 [Lwt_exit]} - - [Lwt_exit] provides helpers to handle: - - - OS signals, - - cleaning-up before exiting, and - - exiting. - - Specifically, this module allows users to (1) register clean-up callbacks - and (2) trigger a soft exit. When a soft exit is triggered, the clean-up - callbacks are called. The process exits once all the clean-up callbacks - calls have resolved. *) - -(** {2 State} *) - -(** A global promise that resolves when clean-up starts. Note that there is no - way to "just" start clean-up. Specifically, it is only possible to start the - clean-up as a side-effect of triggering an exit. - - It is safe to use [clean_up_starts], even in the "main" promise. See example - below in {!Misc recommendations}-{!Cleanly interrupting a main loop}. It is - safe because [Lwt_exit] always witnesses the resolution of this promise - before users of the library. -*) -val clean_up_starts : int Lwt.t - -(** A global promise that resolves when clean-up ends. *) -val clean_up_ends : int Lwt.t - -(** {2 Clean-up callbacks} *) - -(** Attaching and detaching callbacks. *) - -type clean_up_callback_id - -(** [register_clean_up_callback f] registers [f] to be called as part of the - clean-up. Typically this is used to flush outputs, rollback/commit pending - changes, gracefully close connections with peers, etc. - - The call to [f] receives an argument [n] that indicates the status the - process will exit with at the end of clean-up: [0] is for success, [127] for - interruption by signals, [126] for uncaught exceptions, other values are - available for the application's own exit codes. - - The argument [after], if passed, delays the call to this clean-up callback - until the clean-up callbacks identified by [after] have resolved. Apart - from this synchronization mechanism, all clean-up callbacks execute eagerly - and concurrently. Note that more complex synchronization is discouraged but - possible via standard Lwt techniques. - - Note that if one of the callbacks identified in [after] is unregistered - (through {!unregister_clean_up_callback}) then it is simply ignored for the - purpose of synchronization. Thus, it is important to indicate all the - "dependencies" of a clean-up callback and not rely on transitive - "dependencies". - - Once clean-up has started, this function has no effect. - - The promise returned by this callback may be canceled if it takes too long - to complete. (See {!max_clean_up_time} below.) *) -val register_clean_up_callback : - ?after:clean_up_callback_id list -> - loc:string -> - (int -> unit Lwt.t) -> - clean_up_callback_id - -(** [unregister_clean_up_callback cid] removes the callback with id [cid] from - the set of functions to call for cleaning up. - - Once clean-up has started, this function has no effect. *) -val unregister_clean_up_callback : clean_up_callback_id -> unit - -(** Example use: - - [let p = open_resource r in - let clean_p = register_clean_up_callback (fun _ -> close_resource p) in - let rec feed () = - read () >>= fun v -> - push_to_resource p >>= fun () -> - feed () - in - feed () >>= fun () -> - close_resource p >>= fun () -> - unregister_clean_up_callback clean_p; - Lwt.return ()] -*) - -(** {2 Exiting} *) - -(** [exit_and_raise n] triggers a soft exit (including clean-up) and raises - {!Stdlib.Exit}. This is intended for use deep inside the program, at a place - that wants to trigger an exit after observing, say, a fatal error. *) -val exit_and_raise : int -> 'a - -(** [exit_and_wait n] triggers a soft exit (including clean-up) and stays - pending until it is finished. This is intended to be used directly within - {!Lwt_main.run} for a clean exit. *) -val exit_and_wait : int -> int Lwt.t - -(** {2 Signal management} *) - -(** A soft signal handler is one that triggers clean-up. - - After the clean-up has started, and after a safety period has elapsed, - sending the same soft-handled signal a second time terminates the - process immediately. The safety period is set by the parameter - [double_signal_safety] of the {!wrap_and_exit}, {!wrap_and_error}, and - {!wrap_and_forward} functions (below). - - A hard signal handler is one that terminates the process immediately. - - IMPORTANT: a hard exit can leave open files in inconsistent states. *) - -type signal_setup - -(** [make_signal_setup ~soft ~hard] is a signal setup with [soft] as soft - signals and [hard] as hard signals. - - @raise {!Stdlib.Invalid_argument} if a signal is not one declared in {!Sys} - (see all [Sys.sig*] values). *) -val make_signal_setup : soft:int list -> hard:int list -> signal_setup - -(** [default_signal_setup] is - [make_signal_setup ~soft:[Sys.sigint; Sys.sigterm] ~hard:[]]. - - Note that pressing Ctrl-C sends [SIGINT] to the process whilst shutting it - down through systemd sends [SIGTERM]. This is the reasoning behind the - default: both of those signals should be handled softly in most cases. *) -val default_signal_setup : signal_setup - -(** [signal_name signal] is the name of [signal]. - E.g., [signal_name Sys.sigterm] is ["TERM"]. *) -val signal_name : int -> string - -(** {2 Main promise wrappers} *) - -(** [wrap_and_exit p] is a promise [q] that behaves as follows: - - NORMAL OPERATION: - - If [p] is fulfilled with value [v] (and [exit_and_raise] was not called) - then - - [q] also is fulfilled with [v]. The process does not exit. - - If [exit_and_raise code] is called before [p] is resolved, then - - the clean-up starts, - - [p] is canceled, - - the process terminates as soon as clean-up ends with exit code [code]. - - If [p] is rejected (and [exit_and_raise] was not called), it is equivalent - to calling [exit_and_raise 126]. I.e., - - the clean-up starts, - - the process terminates as soon as clean-up ends with exit code [126]. - - EXIT CODE: - - The exit code of the process is masked with [lor 128] (i.e., setting the 8th - bit) if the clean-up did not complete successfully (i.e., if any of the - clean-up callbacks were rejected). - - E.g., if you call [exit_and_raise 1] and one of the clean-up callback fails - (is rejected with an exception), then the exit code is [1 lor 128 = 129]. - - Note that even if one clean-up callback fails, the other clean-up callbacks - are left to execute. - - SIGNALS: - - In addition, [wrap_and_exit p] sets up the signal handlers described above - (see {!signal_setup}). - - Any hard-signal that is received triggers an immediate process termination - with exit code [127 lor 128 = 255]. - - Any soft-signal that is received triggers a call to [exit_and_raise 127] - (the consequences of which are described above). - - Note that if the same soft-signal is sent a second-time, the process - terminates immediately with code [127 lor 128 = 255]. - - To summarize, the exit code can be thought of as a 8-bit integer with the - following properties: - - the highest bit is set if the clean-up was unsuccessful/incomplete - - the second highest bit is set if the process exited because of a signal - - the third highest bit is set if the process exited because of an uncaught - exception - - all other bits can be used by the application as wanted. - - Note that if the second (signal) or third (exception) highest bits are set, - then only the highest (incomplete clean-up) may also be set. - - EXCEPTIONS: - - @raise {!Invalid_argument} if called after clean-up has already started. See - {!Misc recommendations}({!One-shot}) below for details about the - consequences of this. - - OPTIONAL PARAMETERS: - - The optional argument [max_clean_up_time] limits the time the clean-up phase - is allowed to run for. If any of the clean-up callbacks is still pending - when [max_clean_up_time] has elapsed, the process exits immediately. If the - clean-up is interrupted by this then the exit code is masked with [128] as - described above. - - By default [max_clean_up_time] is not set and no limits is set for the - completion of the clean-up callbacks. - - The optional argument [double_signal_safety] (defaults to one (1) second) - is the grace period after sending one of the softly-handled signal before - sending the same signal is handled as hard. - - This is meant to protect against double-pressing Ctrl-C in an interactive - terminal session. If you press Ctrl-c once, a soft exit is triggered, if you - press it again (accidentally) within the grace period it is ignored, if you - press it again after the grace period has elapsed it is treated as a hard - exit. - - The optional argument [signal_setup] (defaults to [default_signal_setup]) - sets up soft and hard handlers at the beginning and clears them when [q] - resolves. - - EXAMPLE: - - Intended use: - [Stdlib.exit @@ Lwt_main.run begin - Lwt_exit.wrap_and_exit (init ()) >>= fun v -> - let ccbid_v = register_clean_up_callback ~loc:__LOC__ (fun _ -> clean v) in - Lwt_exit.wrap_and_exit (main v) >>= fun r -> - let () = unregister_clean_up_callback ccbid_v in - let ccbid_r = register_clean_up_callback ~loc:__LOC__ (fun _ -> free r) in - Lwt_exit.wrap_and_exit (shutdown v) >>= fun () -> - exit_and_wait 0 (* clean exit afterwards *) - end] -*) -val wrap_and_exit : - ?signal_setup:signal_setup -> - ?double_signal_safety:Ptime.Span.t -> - ?max_clean_up_time:Ptime.Span.t -> - 'a Lwt.t -> - 'a Lwt.t - -(** [wrap_and_error p] is similar to {!wrap_and_exit} [p] but it resolves to - [Error status] instead of exiting with [status]. When it resolves with - [Error _] (i.e., if a soft-exit has been triggered), clean-up has already - ended. - - Intended use: - [Stdlib.exit @@ Lwt_main.run begin - Lwt_exit.wrap_and_error (init ()) >>= function - | Error exit_status -> - Format.eprintf "Initialisation failed\n%!"; - Lwt.return exit_status - | Ok v -> - Lwt_exit.wrap_and_error (main v) >>= function - | Error exit_status -> - Format.eprintf "Processing failed\n%!"; - Lwt.return exit_status - | Ok v -> - Lwt_exit.wrap_and_error (shutdown ()) >>= function - | Error exit_status -> - Format.eprintf "Shutdown failed\n%!"; - Lwt.return exit_status - | Ok () -> - exit_and_wait 0 >>= fun _ -> - Lwt.return 0 - end] -*) -val wrap_and_error : - ?signal_setup:signal_setup -> - ?double_signal_safety:Ptime.Span.t -> - ?max_clean_up_time:Ptime.Span.t -> - 'a Lwt.t -> - ('a, int) result Lwt.t - -(** [wrap_and_forward p] is similar to {!wrap_and_error} [p] except that it - collapses [Ok _] and [Error _]. - - Note that, in general, you can expect the status [0] to come from a - successfully resolved [p]. However, It could also be because of a soft-exit - with status [0]. As a result, you cannot be certain, based on the status - alone, whether clean-up callbacks have been called. - - Intended use: - [Stdlib.exit @@ Lwt_main.run begin - Lwt_exit.wrap_and_forward (main ()) >>= function - | 0 -> - Format.printf "I'm done, bye!\n%!"; - Lwt.return 0 - | 1 -> (* signaling *) - Format.printf "Shutdown complete\n"; - Lwt.return 1 - | 2 -> (* uncaught exception *) - Format.printf "An error occurred.\n"; - Format.printf "Please check %s\n" log_file; - Format.printf "And consider reporting the issue\n%!"; - Lwt.return 2 - | _ -> assert false - end] -*) -val wrap_and_forward : - ?signal_setup:signal_setup -> - ?double_signal_safety:Ptime.Span.t -> - ?max_clean_up_time:Ptime.Span.t -> - int Lwt.t -> - int Lwt.t - -(** {2 Misc recommendations} - - {3 One-shot} - - [Lwt_exit] is one-shot: once the clean-up has started, further uses of - [wrap_and_*] will raise {!Invalid_argument}. - - Note, for example, how in the {!wrap_and_error} example, [wrap_and_error] is - called multiple time, but on [Ok] branches where clean-up has {e not} - happened. This is ok. - - On the other hand, using [wrap_and_error] in an [Error] branch would be - unsound because clean-up has happened in these branches. - - {3 Registering callbacks} - - To the extent that it is possible, you should register your clean-up callbacks - as soon as a resource that needs clean-up is allocated. - - [let r = in - let c = register_clean_up_callback ~loc:__LOC__ (fun s -> ) in - ; - let () = unregister_clean_up_callback c in - ; - - ] - - When possible, you can even register the callback before-hand. - - [let rr = ref None in - let c = register_clean_up_callback - ~loc:__LOC__ - (fun s -> Option.iter (fun r -> ) !rr) - in - let rr := Some in - ; - let () = unregister_clean_up_callback c in - rr := None; - ; - - ] - - {3 Registering, unregistering, and loops} - - In a tight-loop, in the event loop of an actor, etc. avoid registering and - unregistering clean-up callbacks repeatedly. Instead, you should create an - intermediate layer dedicated to clean-up. E.g., - - [let module Resources = Set.Make() in - let rs = ref Resources.empty in - let c = register_clean_up_callback - ~loc:__LOC__ - (fun s -> Resources.iter - (fun r -> ; Lwt.return ()) - !rs) - in - let rec loop () = - receive () >>= function - | End -> Lwt.return () - | Input input -> - let _process = - let r = in - rs := Resources.add r !rs; - >>= fun () -> - rs := Resources.remove r !rs; - ; - Lwt.return () - in - loop () - in - loop () - ] - - Note that this is a general example and your specific use would differ. - - More importantly, note that in this specific case we do not unregister the - clean-up callback because there is no point at which we know that the resource - set is empty. It's ok because the clean-up will be a very fast no-op. Coming - up with a solution that allows unregistering of the clean-up callback is left - as an exercise to the reader. - - {3 Cleanly interrupting a main loop} - - In a program that does not normally exit, you might want to interrupt the main - loop (to avoid further processing) as soon as clean-up has started (either - because a signal was received or because a fatal exception deep within the - program was handled by calling {!exit_and_raise}). - - This is easily achieved by passing the main-loop to [wrap_and_*]. As - mentioned in the documentation of {!wrap_and_exit}, the promise passed as - argument is cancelled as soon as the clean-up starts. - - However, there may be other loops that are not syntactically available to the - main wrapper. In this case, the simple pattern below is safe and the loop, - provided it is cancelable, will stop when the clean-up starts. - - [let rec loop () = - get_task () >>= fun task -> - process task >>= fun () -> - loop () - in - Lwt.pick [loop (); Lwt_exit.clean_up_starts]] - - Arguably, for such a simple case, you can replace the pattern above by a - simple clean-up callback that cancels the loop. However, for more complex - arrangements, the [pick]-with-[clean_up_starts] pattern above can be useful. - -*) diff --git a/src/lib_stdlib_unix/test/.ocamlformat b/src/lib_stdlib_unix/test/.ocamlformat deleted file mode 100644 index 8278a132e3d6..000000000000 --- a/src/lib_stdlib_unix/test/.ocamlformat +++ /dev/null @@ -1,12 +0,0 @@ -version=0.10 -wrap-fun-args=false -let-binding-spacing=compact -field-space=loose -break-separators=after-and-docked -sequence-style=separator -doc-comments=before -margin=80 -module-item-spacing=sparse -parens-tuple=always -parens-tuple-patterns=always -break-string-literals=newlines-and-wrap diff --git a/src/lib_stdlib_unix/test/dune b/src/lib_stdlib_unix/test/dune deleted file mode 100644 index 8a4d4e07d415..000000000000 --- a/src/lib_stdlib_unix/test/dune +++ /dev/null @@ -1,122 +0,0 @@ -(executables - (names - test_lwt_exit_after - test_lwt_exit_clean_up - test_lwt_exit_clean_up_failure - test_lwt_exit_clean_up_timeout - test_lwt_exit_exit - test_lwt_exit_exit_escape - test_lwt_exit_raise - test_lwt_exit_raise_exit - test_lwt_exit_range_of_signals - test_lwt_exit_return - test_lwt_exit_signal - test_lwt_exit_unregister_clean_up - test_lwt_exit_unregister_clean_up_with_after - test_lwt_exit_main_is_clean_up - ) - (libraries tezos-stdlib-unix - tezos-stdlib - lwt.unix) - (flags (:standard -open Tezos_stdlib_unix))) - -(alias - (name buildtest) - (deps - test_lwt_exit_after.exe - test_lwt_exit_clean_up.exe - test_lwt_exit_clean_up_failure.exe - test_lwt_exit_clean_up_timeout.exe - test_lwt_exit_exit_escape.exe - test_lwt_exit_exit.exe - test_lwt_exit_raise.exe - test_lwt_exit_raise_exit.exe - test_lwt_exit_range_of_signals.exe - test_lwt_exit_return.exe - test_lwt_exit_signal.exe - test_lwt_exit_unregister_clean_up.exe - test_lwt_exit_unregister_clean_up_with_after.exe - test_lwt_exit_main_is_clean_up.exe - )) - -(rule - (alias runtest_lwt_exit_exit) - (action (run %{exe:test_lwt_exit_exit.exe}))) - -(rule - (alias runtest_lwt_exit_exit_escape) - (action (run %{exe:test_lwt_exit_exit_escape.exe}))) - -(rule - (alias runtest_lwt_exit_return) - (action (run %{exe:test_lwt_exit_return.exe}))) - -(rule - (alias runtest_lwt_exit_after) - (action (run %{exe:test_lwt_exit_after.exe}))) - -(rule - (alias runtest_lwt_exit_signal) - (action (run %{exe:test_lwt_exit_signal.exe}))) - -(rule - (alias runtest_lwt_exit_clean_up) - (action (run %{exe:test_lwt_exit_clean_up.exe}))) - -(rule - (alias runtest_test_lwt_exit_unregister_clean_up) - (action (run %{exe:test_lwt_exit_unregister_clean_up.exe}))) - -(rule - (alias runtest_test_lwt_exit_unregister_clean_up_with_after) - (action (run %{exe:test_lwt_exit_unregister_clean_up_with_after.exe}))) - -(rule - (alias runtest_test_lwt_exit_main_is_clean_up) - (action (run %{exe:test_lwt_exit_main_is_clean_up.exe}))) - -(rule - (alias runtest_test_lwt_exit_raise) - (action (run %{exe:test_lwt_exit_raise.exe}))) - -(rule - (alias runtest_test_lwt_exit_raise_exit) - (action (run %{exe:test_lwt_exit_raise_exit.exe}))) - -(rule - (alias runtest_test_lwt_exit_range_of_signals) - (action (run %{exe:test_lwt_exit_range_of_signals.exe}))) - -(rule - (alias runtest_test_lwt_exit_clean_up_failure) - (action (run %{exe:test_lwt_exit_clean_up_failure.exe}))) - -(rule - (alias runtest_test_lwt_exit_clean_up_timeout) - (action (run %{exe:test_lwt_exit_clean_up_timeout.exe}))) - -(alias - (name runtest) - (package tezos-stdlib-unix) - (deps - (alias runtest_lwt_exit_after) - (alias runtest_lwt_exit_clean_up) - (alias runtest_lwt_exit_exit) - (alias runtest_lwt_exit_exit_escape) - (alias runtest_lwt_exit_return) - (alias runtest_lwt_exit_signal) - (alias runtest_test_lwt_exit_clean_up_failure) - (alias runtest_test_lwt_exit_clean_up_timeout) - (alias runtest_test_lwt_exit_raise) - (alias runtest_test_lwt_exit_raise_exit) - (alias runtest_test_lwt_exit_range_of_signals) - (alias runtest_test_lwt_exit_unregister_clean_up) - (alias runtest_test_lwt_exit_unregister_clean_up_with_after) - (alias runtest_test_lwt_exit_main_is_clean_up) - ) -) - -(rule - (alias runtest_lint) - (deps (glob_files *.ml{,i})) - (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_stdlib_unix/test/test_lwt_exit_after.ml b/src/lib_stdlib_unix/test/test_lwt_exit_after.ml deleted file mode 100644 index 92a115abfbc6..000000000000 --- a/src/lib_stdlib_unix/test/test_lwt_exit_after.ml +++ /dev/null @@ -1,65 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -open Lwt.Infix - -let r = ref 0 - -let first = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - Lwt_unix.sleep 0.2 - >>= fun () -> - assert (!r = 0) ; - incr r ; - Lwt.return_unit) - -let second = - Lwt_exit.register_clean_up_callback ~after:[first] ~loc:__LOC__ (fun _ -> - Lwt_unix.sleep 0.1 - >>= fun () -> - assert (!r = 1) ; - incr r ; - Lwt.return_unit) - -let _third = - Lwt_exit.register_clean_up_callback ~after:[second] ~loc:__LOC__ (fun _ -> - assert (!r = 2) ; - incr r ; - Lwt.return_unit) - -let () = - match - Lwt_main.run - @@ Lwt_exit.wrap_and_error - (let (_ : unit Lwt.t) = - Lwt_unix.sleep 0.1 >>= fun () -> Lwt_exit.exit_and_raise 3 - in - fst @@ Lwt.task ()) - with - | Ok _ -> - assert false - | Error _ -> - assert (!r = 3) ; - exit 0 diff --git a/src/lib_stdlib_unix/test/test_lwt_exit_clean_up.ml b/src/lib_stdlib_unix/test/test_lwt_exit_clean_up.ml deleted file mode 100644 index 59489331790c..000000000000 --- a/src/lib_stdlib_unix/test/test_lwt_exit_clean_up.ml +++ /dev/null @@ -1,48 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -open Lwt.Infix - -let r = ref 0 - -let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun s -> - Lwt_unix.sleep 0.01 - >>= fun () -> - r := s ; - Lwt.return_unit) - -let () = - match - Lwt_main.run - @@ Lwt_exit.wrap_and_error - (Lwt_unix.sleep 0.01 >>= fun () -> Lwt_exit.exit_and_raise 10) - with - | Error 10 -> - assert (!r = 10) - | Error _ -> - assert false - | Ok _ -> - assert false diff --git a/src/lib_stdlib_unix/test/test_lwt_exit_clean_up_failure.ml b/src/lib_stdlib_unix/test/test_lwt_exit_clean_up_failure.ml deleted file mode 100644 index 07388b44d05f..000000000000 --- a/src/lib_stdlib_unix/test/test_lwt_exit_clean_up_failure.ml +++ /dev/null @@ -1,56 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -open Lwt.Infix - -let () = - let devnull = Lwt_main.run (Lwt_unix.openfile "/dev/null" [O_WRONLY] 0) in - Lwt_unix.dup2 devnull Lwt_unix.stderr - -let r = ref 0 - -let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - Lwt_unix.sleep 0.01 >>= fun () -> incr r ; Lwt.return_unit) - -let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - Lwt_unix.sleep 0.03 >>= fun () -> incr r ; Lwt.return_unit) - -let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - Lwt_unix.sleep 0.02 >>= fun () -> raise Not_found) - -let () = - match - Lwt_main.run - @@ Lwt_exit.wrap_and_error - (Lwt_unix.sleep 0.01 >>= fun () -> Lwt_exit.exit_and_raise 10) - with - | Error s -> - assert (!r = 2) ; - assert (s = 10 lor 128) - | Ok _ -> - assert false diff --git a/src/lib_stdlib_unix/test/test_lwt_exit_clean_up_timeout.ml b/src/lib_stdlib_unix/test/test_lwt_exit_clean_up_timeout.ml deleted file mode 100644 index 24558859b404..000000000000 --- a/src/lib_stdlib_unix/test/test_lwt_exit_clean_up_timeout.ml +++ /dev/null @@ -1,57 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -open Lwt.Infix - -let () = - let devnull = Lwt_main.run (Lwt_unix.openfile "/dev/null" [O_WRONLY] 0) in - Lwt_unix.dup2 devnull Lwt_unix.stderr - -let r = ref 0 - -let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - Lwt_unix.sleep 0.01 >>= fun () -> incr r ; Lwt.return_unit) - -let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - Lwt_unix.sleep 0.02 >>= fun () -> incr r ; Lwt.return_unit) - -let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - Lwt_unix.sleep 0.1 >>= fun () -> incr r ; Lwt.return_unit) - -let () = - match - Lwt_main.run - @@ Lwt_exit.wrap_and_error - ~max_clean_up_time:(Option.get @@ Ptime.Span.of_float_s 0.05) - (Lwt_unix.sleep 0.01 >>= fun () -> Lwt_exit.exit_and_raise 10) - with - | Error s -> - assert (!r = 2) ; - assert (s = 10 lor 128) - | Ok _ -> - assert false diff --git a/src/lib_stdlib_unix/test/test_lwt_exit_exit.ml b/src/lib_stdlib_unix/test/test_lwt_exit_exit.ml deleted file mode 100644 index 05c32e2cd7f0..000000000000 --- a/src/lib_stdlib_unix/test/test_lwt_exit_exit.ml +++ /dev/null @@ -1,40 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -open Lwt.Infix - -let () = - match - Lwt_main.run - @@ Lwt_exit.wrap_and_error - ( Lwt.pause () - >>= fun () -> - (try Lwt_exit.exit_and_raise 3 with Exit -> ()) ; - Tezos_stdlib.Lwt_utils.never_ending () ) - with - | Error 3 -> - () - | Error _ | Ok () -> - assert false diff --git a/src/lib_stdlib_unix/test/test_lwt_exit_exit_escape.ml b/src/lib_stdlib_unix/test/test_lwt_exit_exit_escape.ml deleted file mode 100644 index dbee594576dd..000000000000 --- a/src/lib_stdlib_unix/test/test_lwt_exit_exit_escape.ml +++ /dev/null @@ -1,42 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -open Lwt.Infix - -(** Even when not caught, a call to [exit_and_raise] should propagate the - error code correctly. *) -let () = - match - Lwt_main.run - @@ Lwt_exit.wrap_and_error - ( Lwt.pause () - >>= fun () -> - Lwt_exit.exit_and_raise 3 - >>= fun () -> Tezos_stdlib.Lwt_utils.never_ending () ) - with - | Error 3 -> - () - | Error _ | Ok () -> - assert false diff --git a/src/lib_stdlib_unix/test/test_lwt_exit_main_is_clean_up.ml b/src/lib_stdlib_unix/test/test_lwt_exit_main_is_clean_up.ml deleted file mode 100644 index 1251716fdba0..000000000000 --- a/src/lib_stdlib_unix/test/test_lwt_exit_main_is_clean_up.ml +++ /dev/null @@ -1,186 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -(** This series of tests is to check the behaviour of the library in the cases - where the "main" promise resolves "at the same time as" the start of the - clean-up. - - Because the Lwt-exit library assumes that the two promises cannot be - resolved simultaneously, this series of tests attempts to break that - assumption. *) - -open Lwt.Infix - -let devnull = Lwt_main.run (Lwt_unix.openfile "/dev/null" [O_WRONLY] 0) - -(* A signal setup with both soft and hard exits to test both behaviours *) -let signal_setup = - Lwt_exit.make_signal_setup ~soft:[Sys.sigint; Sys.sigterm] ~hard:[Sys.sigusr1] - -let child_inted p = - Lwt_unix.dup2 devnull Lwt_unix.stderr ; - let r = ref 0 in - let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - incr r ; Lwt.return ()) - in - match Lwt_main.run @@ Lwt_exit.wrap_and_error p with - | Error 127 -> - assert (!r = 1) ; - Stdlib.exit 0 - | Error _ -> - assert false - | Ok _ -> - assert false - -let child_ok p = - Lwt_unix.dup2 devnull Lwt_unix.stderr ; - let r = ref 0 in - let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - incr r ; Lwt.return ()) - in - match Lwt_main.run @@ Lwt_exit.wrap_and_error p with - | Ok 1024 -> - assert (!r = 0) ; - Stdlib.exit 0 - | Ok _ -> - assert false - | Error _ -> - assert false - -let child_already_cleaned p = - Lwt_unix.dup2 devnull Lwt_unix.stderr ; - let r = ref 0 in - let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - incr r ; Lwt.return ()) - in - match Lwt_main.run @@ Lwt_exit.wrap_and_error p with - | Error 2048 -> - Stdlib.exit 0 - | Error _ -> - assert false - | Ok _ -> - assert false - -let main pid = - let s : unit Lwt.t = - Lwt_unix.sleep 0.01 >>= fun () -> Unix.kill pid Sys.sigint ; Lwt.return () - in - Lwt_unix.waitpid [] pid - >|= fun (_, status) -> - Lwt.cancel s ; - match status with - | WEXITED 0 -> - () - | WEXITED _ -> - assert false - | WSIGNALED _ -> - assert false - | WSTOPPED _ -> - assert false - -let test_simple () = - match Lwt_unix.fork () with - | 0 -> - child_inted Lwt_exit.clean_up_starts - | pid -> - Lwt_main.run @@ main pid - -let test_map () = - match Lwt_unix.fork () with - | 0 -> - child_inted (Lwt_exit.clean_up_starts >|= function 127 -> 0 | _ -> 1) - | pid -> - Lwt_main.run @@ main pid - -let test_bind () = - match Lwt_unix.fork () with - | 0 -> - child_inted - ( Lwt_exit.clean_up_starts - >>= function 127 -> Lwt.return 0 | _ -> Lwt.return 1 ) - | pid -> - Lwt_main.run @@ main pid - -let test_pick () = - match Lwt_unix.fork () with - | 0 -> - let dummy_state = ref 1024 in - let dummy_ev_wait () = - Lwt_unix.sleep 0.001 >|= fun () -> !dummy_state + 7 - in - let dummy_ev_handling ev = dummy_state := !dummy_state + (ev / 9) in - let rec dummy_loop () = - Lwt.pick - [ (Lwt_exit.clean_up_starts >|= fun _ -> 0); - ( dummy_ev_wait () - >>= fun ev -> dummy_ev_handling ev ; dummy_loop () ) ] - in - child_inted (dummy_loop ()) - | pid -> - Lwt_main.run @@ main pid - -let test_resolve_wait_by_clean_up () = - match Lwt_unix.fork () with - | 0 -> - let (p, r) = Lwt.wait () in - let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - Lwt.wakeup r 2000 ; Lwt.return_unit) - in - child_inted p - | pid -> - Lwt_main.run @@ main pid - -let test_resolve_task_by_clean_up () = - match Lwt_unix.fork () with - | 0 -> - let (p, r) = Lwt.task () in - let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - Lwt.wakeup r 2000 ; Lwt.return_unit) - in - child_inted p - | pid -> - Lwt_main.run @@ main pid - -let test_already_resolved () = - match Lwt_unix.fork () with - | 0 -> - child_ok (Lwt.return 1024) - | pid -> - Lwt_main.run @@ main pid - -let () = - test_simple () ; - test_map () ; - test_bind () ; - test_pick () ; - test_resolve_wait_by_clean_up () ; - test_resolve_task_by_clean_up () ; - test_already_resolved () ; - Stdlib.exit 0 diff --git a/src/lib_stdlib_unix/test/test_lwt_exit_raise.ml b/src/lib_stdlib_unix/test/test_lwt_exit_raise.ml deleted file mode 100644 index 01c03cce8e97..000000000000 --- a/src/lib_stdlib_unix/test/test_lwt_exit_raise.ml +++ /dev/null @@ -1,44 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -open Lwt.Infix - -let devnull = Lwt_main.run (Lwt_unix.openfile "/dev/null" [O_WRONLY] 0) - -let () = Lwt_unix.dup2 devnull Lwt_unix.stderr - -let () = - match - Lwt_main.run - @@ Lwt_exit.wrap_and_error - ( Lwt.pause () - >>= fun () -> - raise Not_found >>= fun () -> Tezos_stdlib.Lwt_utils.never_ending () - ) - with - | Error 126 -> - () - | Error _ | Ok () -> - assert false diff --git a/src/lib_stdlib_unix/test/test_lwt_exit_raise_exit.ml b/src/lib_stdlib_unix/test/test_lwt_exit_raise_exit.ml deleted file mode 100644 index 090e433d5c56..000000000000 --- a/src/lib_stdlib_unix/test/test_lwt_exit_raise_exit.ml +++ /dev/null @@ -1,43 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -open Lwt.Infix - -let devnull = Lwt_main.run (Lwt_unix.openfile "/dev/null" [O_WRONLY] 0) - -let () = Lwt_unix.dup2 devnull Lwt_unix.stderr - -let () = - match - Lwt_main.run - @@ Lwt_exit.wrap_and_error - ( Lwt.pause () - >>= fun () -> - raise Exit >>= fun () -> Tezos_stdlib.Lwt_utils.never_ending () ) - with - | Error 126 -> - () - | Error _ | Ok () -> - assert false diff --git a/src/lib_stdlib_unix/test/test_lwt_exit_range_of_signals.ml b/src/lib_stdlib_unix/test/test_lwt_exit_range_of_signals.ml deleted file mode 100644 index 1dcfdf356834..000000000000 --- a/src/lib_stdlib_unix/test/test_lwt_exit_range_of_signals.ml +++ /dev/null @@ -1,108 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -(* The aim of this test is to check that Lwt_Exit can handle all the signals - that POSIX say are handleable. *) - -open Lwt.Infix - -let devnull = Lwt_main.run (Lwt_unix.openfile "/dev/null" [O_WRONLY] 0) - -let single_signal_setup signal = - Lwt_exit.make_signal_setup ~soft:[] ~hard:[signal] - -let rec child_loop () = Lwt_unix.sleep 0.1 >>= child_loop - -let child signal = - (* redirecting stderr to devnull to avoid polluting stderr with messages when - the child process is killed. These messages make the test look like it is - failing because they, obviously, look error-like. *) - Lwt_unix.dup2 devnull Lwt_unix.stderr ; - let signal_setup = single_signal_setup signal in - Stdlib.exit @@ Lwt_main.run - @@ Lwt_exit.wrap_and_exit ~signal_setup - @@ child_loop () - -let test_one_signal (signal, name) = - (* tests that a process that sets up a hard-handler for [signal] exits as - expected when receiving a signal. *) - match Lwt_unix.fork () with - | 0 -> - child signal - | pid -> ( - Lwt_main.run - @@ - let (_ : unit Lwt.t) = - Lwt_unix.sleep 0.01 >>= fun () -> Unix.kill pid signal ; Lwt.return () - in - Lwt_unix.waitpid [] pid - >|= fun (_, status) -> - match status with - | WEXITED s when s = 128 lor 127 -> - () - | WEXITED s -> - Format.kasprintf failwith "WEXITED(%d) on %s" s name - | WSIGNALED s -> - Format.kasprintf failwith "WSIGNALED(%d) on %s" s name - | WSTOPPED s -> - Format.kasprintf failwith "WSTOPPED(%d) on %s" s name ) - -let main () = - let open Sys in - List.iter - test_one_signal - [ (sigalrm, "ALRM"); - (sigchld, "CHLD"); - (sigabrt, "ABRT"); - (sigfpe, "FPE"); - (sighup, "HUP"); - (sigill, "ILL"); - (sigint, "INT"); - (sigpipe, "PIPE"); - (sigquit, "QUIT"); - (sigsegv, "SEGV"); - (sigterm, "TERM"); - (sigusr1, "USR1"); - (sigusr2, "USR2"); - (sigcont, "CONT"); - (sigtstp, "TSTP"); - (sigttin, "TTIN"); - (sigttou, "TTOU"); - (sigvtalrm, "VTALRM"); - (sigprof, "PROF"); - (sigbus, "BUS"); - (sigpoll, "POLL"); - (sigsys, "SYS"); - (sigtrap, "TRAP"); - (sigurg, "URG"); - (sigxcpu, "XCPU"); - (sigxfsz, "XFSZ") ] - -(** Non-catchable signals - (sigkill, "KILL"); - (sigstop, "STOP"); - *) - -let () = main () diff --git a/src/lib_stdlib_unix/test/test_lwt_exit_return.ml b/src/lib_stdlib_unix/test/test_lwt_exit_return.ml deleted file mode 100644 index 7077d655edea..000000000000 --- a/src/lib_stdlib_unix/test/test_lwt_exit_return.ml +++ /dev/null @@ -1,36 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -open Lwt.Infix - -let () = - match - Lwt_main.run - @@ Lwt_exit.wrap_and_error (Lwt.pause () >>= fun () -> Lwt.return ()) - with - | Ok () -> - () - | Error _ -> - assert false diff --git a/src/lib_stdlib_unix/test/test_lwt_exit_signal.ml b/src/lib_stdlib_unix/test/test_lwt_exit_signal.ml deleted file mode 100644 index 65f8a82b9dd1..000000000000 --- a/src/lib_stdlib_unix/test/test_lwt_exit_signal.ml +++ /dev/null @@ -1,235 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -open Lwt.Infix - -let devnull = Lwt_main.run (Lwt_unix.openfile "/dev/null" [O_WRONLY] 0) - -(* A signal setup with both soft and hard exits to test both behaviours *) -let signal_setup = - Lwt_exit.make_signal_setup ~soft:[Sys.sigint; Sys.sigterm] ~hard:[Sys.sigusr1] - -let default_double_signal_safety = Option.get @@ Ptime.Span.of_float_s 0.1 - -let short_max_clean_up_time = Option.get @@ Ptime.Span.of_float_s 0.04 - -let child_main ?double_signal_safety ?max_clean_up_time () = - let double_signal_safety = - Option.value double_signal_safety ~default:default_double_signal_safety - in - Lwt_unix.dup2 devnull Lwt_unix.stderr ; - let r = ref 10 in - let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - Lwt_unix.sleep 0.02 - >>= fun () -> - r := 11 ; - Lwt_unix.sleep 0.05 - >>= fun () -> - r := 12 ; - Lwt_unix.sleep 0.2 >>= fun () -> Lwt.return ()) - in - Stdlib.exit @@ Lwt_main.run - @@ ( Lwt_exit.wrap_and_error - ?max_clean_up_time - ~double_signal_safety - ~signal_setup - (Tezos_stdlib.Lwt_utils.never_ending ()) - >>= function - | Ok () -> - Lwt.return 3 - | Error code -> - if code = 127 then Lwt.return !r - else if code = 127 lor 128 then Lwt.return (!r lor 128) - else Lwt.return code ) - -let main () = - (* test INT *) - match Lwt_unix.fork () with - | 0 -> - child_main () - | pid -> ( - Lwt_main.run - (let s : unit Lwt.t = - Lwt_unix.sleep 0.01 - >>= fun () -> Unix.kill pid Sys.sigint ; Lwt.return () - in - Lwt_unix.waitpid [] pid - >|= fun (_, status) -> - Lwt.cancel s ; - match status with - | WEXITED 12 -> - () - | WEXITED _ -> - assert false - | WSIGNALED _ -> - assert false - | WSTOPPED _ -> - assert false) ; - (* test INT short clean-up time *) - match Lwt_unix.fork () with - | 0 -> - child_main ~max_clean_up_time:short_max_clean_up_time () - | pid -> ( - Lwt_main.run - (let s : unit Lwt.t = - Lwt_unix.sleep 0.01 - >>= fun () -> Unix.kill pid Sys.sigint ; Lwt.return () - in - Lwt_unix.waitpid [] pid - >|= fun (_, status) -> - Lwt.cancel s ; - match status with - | WEXITED s when s = 128 lor 11 -> - () - | WEXITED _ -> - assert false - | WSIGNALED _ -> - assert false - | WSTOPPED _ -> - assert false) ; - (* test INT-short-sleep-INT *) - match Lwt_unix.fork () with - | 0 -> - child_main () - | pid -> ( - Lwt_main.run - (let s : unit Lwt.t = - Lwt_unix.sleep 0.01 - >>= fun () -> - Unix.kill pid Sys.sigint ; - Lwt_unix.sleep 0.02 - >>= fun () -> Unix.kill pid Sys.sigint ; Lwt.return () - in - Lwt_unix.waitpid [] pid - >|= fun (_, status) -> - Lwt.cancel s ; - match status with - | WEXITED 12 -> - () - | WEXITED _ -> - assert false - | WSIGNALED _ -> - assert false - | WSTOPPED _ -> - assert false) ; - (* test INT-long-sleep-INT *) - match Lwt_unix.fork () with - | 0 -> - child_main () - | pid -> ( - Lwt_main.run - (let s : unit Lwt.t = - Lwt_unix.sleep 0.01 - >>= fun () -> - Unix.kill pid Sys.sigint ; - Lwt_unix.sleep 0.11 - >>= fun () -> Unix.kill pid Sys.sigint ; Lwt.return () - in - Lwt_unix.waitpid [] pid - >|= fun (_, status) -> - Lwt.cancel s ; - match status with - | WEXITED s when s = 127 lor 128 -> - () - | WEXITED _ -> - assert false - | WSIGNALED _ -> - assert false - | WSTOPPED _ -> - assert false) ; - (* test no double-signal safety *) - match Lwt_unix.fork () with - | 0 -> - child_main ~double_signal_safety:Ptime.Span.zero () - | pid -> ( - Lwt_main.run - (let s : unit Lwt.t = - Lwt_unix.sleep 0.01 - >>= fun () -> - Unix.kill pid Sys.sigint ; - Lwt_unix.sleep 0.02 - >>= fun () -> - Unix.kill pid Sys.sigint ; Lwt.return_unit - in - Lwt_unix.waitpid [] pid - >|= fun (_, status) -> - Lwt.cancel s ; - match status with - | WEXITED s when s = 127 lor 128 -> - () - | WEXITED _ -> - assert false - | WSIGNALED _ -> - assert false - | WSTOPPED _ -> - assert false) ; - (* test USR1 (hard) *) - match Lwt_unix.fork () with - | 0 -> - child_main () - | pid -> ( - Lwt_main.run - (let s : unit Lwt.t = - Lwt_unix.sleep 0.01 - >>= fun () -> - Unix.kill pid Sys.sigusr1 ; Lwt.return () - in - Lwt_unix.waitpid [] pid - >|= fun (_, status) -> - Lwt.cancel s ; - match status with - | WEXITED s when s = 127 lor 128 -> - () - | WEXITED _ -> - assert false - | WSIGNALED _ -> - assert false - | WSTOPPED _ -> - assert false) ; - (* test KILL *) - match Lwt_unix.fork () with - | 0 -> - child_main () - | pid -> - Lwt_main.run - (let s : unit Lwt.t = - Lwt_unix.sleep 0.01 - >>= fun () -> - Unix.kill pid Sys.sigkill ; Lwt.return () - in - Lwt_unix.waitpid [] pid - >|= fun (_, status) -> - Lwt.cancel s ; - match status with - | WEXITED _ -> - assert false - | WSIGNALED _ -> - () - | WSTOPPED _ -> - assert false) ; - () ) ) ) ) ) ) - -let () = main () ; Stdlib.exit 0 diff --git a/src/lib_stdlib_unix/test/test_lwt_exit_unregister_clean_up.ml b/src/lib_stdlib_unix/test/test_lwt_exit_unregister_clean_up.ml deleted file mode 100644 index e8cd245ce930..000000000000 --- a/src/lib_stdlib_unix/test/test_lwt_exit_unregister_clean_up.ml +++ /dev/null @@ -1,51 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -open Lwt.Infix - -let r = ref 0 - -let clean_up_callback_id = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun s -> - Lwt_unix.sleep 0.01 - >>= fun () -> - r := s ; - Lwt.return_unit) - -let () = - match - Lwt_main.run - @@ Lwt_exit.wrap_and_error - ( Lwt_unix.sleep 0.01 - >>= fun () -> - Lwt_exit.unregister_clean_up_callback clean_up_callback_id ; - Lwt_unix.sleep 0.01 >>= fun () -> Lwt_exit.exit_and_raise 10 ) - with - | Error 10 -> - assert (!r = 0) - | Error _ -> - assert false - | Ok _ -> - assert false diff --git a/src/lib_stdlib_unix/test/test_lwt_exit_unregister_clean_up_with_after.ml b/src/lib_stdlib_unix/test/test_lwt_exit_unregister_clean_up_with_after.ml deleted file mode 100644 index 468bf1bdfc6e..000000000000 --- a/src/lib_stdlib_unix/test/test_lwt_exit_unregister_clean_up_with_after.ml +++ /dev/null @@ -1,61 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 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. *) -(* *) -(*****************************************************************************) - -open Lwt.Infix - -let r = ref 2 - -let clean_up_callback_id = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - Lwt_unix.sleep 0.01 - >>= fun () -> - r := !r * 3 ; - Lwt.return_unit) - -let _ = - Lwt_exit.register_clean_up_callback - ~loc:__LOC__ - ~after:[clean_up_callback_id] - (fun _ -> - Lwt_unix.sleep 0.01 - >>= fun () -> - r := !r * 5 ; - Lwt.return_unit) - -let () = - match - Lwt_main.run - @@ Lwt_exit.wrap_and_error - ( Lwt_unix.sleep 0.01 - >>= fun () -> - Lwt_exit.unregister_clean_up_callback clean_up_callback_id ; - Lwt_unix.sleep 0.01 >>= fun () -> Lwt_exit.exit_and_raise 10 ) - with - | Error 10 -> - assert (!r = 10) - | Error _ -> - assert false - | Ok _ -> - assert false diff --git a/src/proto_007_PsDELPH1/lib_delegate/dune b/src/proto_007_PsDELPH1/lib_delegate/dune index c6079ae60850..0aef819b7242 100644 --- a/src/proto_007_PsDELPH1/lib_delegate/dune +++ b/src/proto_007_PsDELPH1/lib_delegate/dune @@ -14,7 +14,8 @@ tezos-storage tezos-rpc-http tezos-rpc - lwt-canceler) + lwt-canceler + lwt-exit) (library_flags (:standard -linkall)) (modules (:standard \ delegate_commands diff --git a/src/proto_007_PsDELPH1/lib_delegate/tezos-baking-007-PsDELPH1.opam b/src/proto_007_PsDELPH1/lib_delegate/tezos-baking-007-PsDELPH1.opam index 4d3214dcff44..240f006a0182 100644 --- a/src/proto_007_PsDELPH1/lib_delegate/tezos-baking-007-PsDELPH1.opam +++ b/src/proto_007_PsDELPH1/lib_delegate/tezos-baking-007-PsDELPH1.opam @@ -18,6 +18,7 @@ depends: [ "tezos-client-commands" "tezos-client-007-PsDELPH1" "lwt-canceler" { = "0.2" } + "lwt-exit" ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/proto_008_PtEdoTez/lib_delegate/dune b/src/proto_008_PtEdoTez/lib_delegate/dune index d8a8517f93e4..9aec126aa0ec 100644 --- a/src/proto_008_PtEdoTez/lib_delegate/dune +++ b/src/proto_008_PtEdoTez/lib_delegate/dune @@ -14,7 +14,8 @@ tezos-storage tezos-rpc-http tezos-rpc - lwt-canceler) + lwt-canceler + lwt-exit) (library_flags (:standard -linkall)) (modules (:standard \ delegate_commands diff --git a/src/proto_008_PtEdoTez/lib_delegate/tezos-baking-008-PtEdoTez.opam b/src/proto_008_PtEdoTez/lib_delegate/tezos-baking-008-PtEdoTez.opam index 67e51fc854ce..38e612479a9f 100644 --- a/src/proto_008_PtEdoTez/lib_delegate/tezos-baking-008-PtEdoTez.opam +++ b/src/proto_008_PtEdoTez/lib_delegate/tezos-baking-008-PtEdoTez.opam @@ -18,6 +18,7 @@ depends: [ "tezos-client-commands" "tezos-client-008-PtEdoTez" "lwt-canceler" { = "0.2" } + "lwt-exit" ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/proto_alpha/lib_delegate/dune b/src/proto_alpha/lib_delegate/dune index 24fdbfc905b9..c01d38fb22dd 100644 --- a/src/proto_alpha/lib_delegate/dune +++ b/src/proto_alpha/lib_delegate/dune @@ -14,7 +14,8 @@ tezos-storage tezos-rpc-http tezos-rpc - lwt-canceler) + lwt-canceler + lwt-exit) (library_flags (:standard -linkall)) (modules (:standard \ delegate_commands diff --git a/src/proto_alpha/lib_delegate/tezos-baking-alpha.opam b/src/proto_alpha/lib_delegate/tezos-baking-alpha.opam index 2cf6c3e6104b..abd848c8fad5 100644 --- a/src/proto_alpha/lib_delegate/tezos-baking-alpha.opam +++ b/src/proto_alpha/lib_delegate/tezos-baking-alpha.opam @@ -18,6 +18,7 @@ depends: [ "tezos-client-commands" "tezos-client-alpha" "lwt-canceler" { = "0.2" } + "lwt-exit" ] build: [ ["dune" "build" "-p" name "-j" jobs] -- GitLab From 3af8ca887dd59664a6c008f34d9dbdb77b929ada Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Tue, 22 Dec 2020 17:48:06 +0100 Subject: [PATCH 2/7] Storage: fix build for irmin 2.3.0 Co-authored-by: Craig Ferguson --- src/lib_storage/context.ml | 79 ++++++++++++++++++++---------- src/lib_storage/tezos-storage.opam | 5 +- 2 files changed, 57 insertions(+), 27 deletions(-) diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index 1ed1f1a3c351..b8a60a1c4eb9 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -106,16 +106,25 @@ end = struct Error_monad.pp_print_error err)) - let short_hash t = Irmin.Type.(short_hash string (H.to_raw_string t)) + let short_hash_string = Irmin.Type.(unstage (short_hash string)) + + let short_hash_staged = + Irmin.Type.stage + @@ fun ?seed t -> short_hash_string ?seed (H.to_raw_string t) let t : t Irmin.Type.t = Irmin.Type.map - ~cli:(pp, of_string) + ~pp + ~of_string Irmin.Type.(string_of (`Fixed H.digest_size)) - ~short_hash + ~short_hash:short_hash_staged H.of_raw_string H.to_raw_string + let short_hash = + let f = short_hash_string ?seed:None in + fun t -> f (H.to_raw_string t) + let hash_size = H.digest_size let hash = H.digesti_string @@ -131,9 +140,13 @@ module Node = struct type entry = {kind : kind; name : M.step; node : Hash.t} + let s = Irmin.Type.(string_of `Int64) + + let pre_hash_v = Irmin.Type.(unstage (pre_hash s)) + (* Irmin 1.4 uses int64 to store string lengths *) let step_t = - let pre_hash = Irmin.Type.(pre_hash (string_of `Int64)) in + let pre_hash = Irmin.Type.(stage @@ fun x -> pre_hash_v x) in Irmin.Type.like M.step_t ~pre_hash let metadata_t = @@ -177,14 +190,16 @@ module Node = struct let import t = List.map import_entry (M.list t) - let pre_hash entries = Irmin.Type.pre_hash entries_t entries + let pre_hash_entries = Irmin.Type.(unstage (pre_hash entries_t)) + + let pre_hash entries = pre_hash_entries entries end include M let pre_hash_v1 x = V1.pre_hash (V1.import x) - let t = Irmin.Type.(like t ~pre_hash:pre_hash_v1) + let t = Irmin.Type.(like t ~pre_hash:(stage @@ fun x -> pre_hash_v1 x)) end module Commit = struct @@ -192,19 +207,23 @@ module Commit = struct module V1 = Irmin.Private.Commit.V1 (M) include M - let pre_hash_v1 t = Irmin.Type.pre_hash V1.t (V1.import t) + let pre_hash_v1_t = Irmin.Type.(unstage (pre_hash V1.t)) - let t = Irmin.Type.like t ~pre_hash:pre_hash_v1 + let pre_hash_v1 t = pre_hash_v1_t (V1.import t) + + let t = Irmin.Type.(like t ~pre_hash:(stage @@ fun x -> pre_hash_v1 x)) end module Contents = struct type t = string - let pre_hash_v1 x = - let ty = Irmin.Type.(pair (string_of `Int64) unit) in - Irmin.Type.(pre_hash ty) (x, ()) + let ty = Irmin.Type.(pair (string_of `Int64) unit) + + let pre_hash_ty = Irmin.Type.(unstage (pre_hash ty)) - let t = Irmin.Type.(like ~pre_hash:pre_hash_v1 string) + let pre_hash_v1 x = pre_hash_ty (x, ()) + + let t = Irmin.Type.(like string ~pre_hash:(stage @@ fun x -> pre_hash_v1 x)) let merge = Irmin.Merge.(idempotent (Irmin.Type.option t)) end @@ -216,12 +235,19 @@ module Conf = struct end module Store = - Irmin_pack.Make_ext (Conf) (Irmin.Metadata.None) (Contents) + Irmin_pack.Make_ext + (struct + let io_version = `V1 + end) + (Conf) + (Irmin.Metadata.None) + (Contents) (Irmin.Path.String_list) (Irmin.Branch.String) (Hash) (Node) (Commit) + module P = Store.Private type index = { @@ -289,10 +315,10 @@ let unshallow context = P.Repo.batch context.index.repo (fun x y _ -> List.iter_s (fun (s, k) -> - match k with - | `Contents -> + match Store.Tree.destruct k with + | `Contents _ -> Lwt.return () - | `Node -> + | `Node _ -> Store.Tree.get_tree context.tree [s] >>= fun tree -> Store.save_tree ~clear:true context.index.repo x y tree @@ -372,12 +398,12 @@ let fold ctxt key ~init ~f = Store.Tree.list ctxt.tree (data_key key) >>= fun keys -> List.fold_left_s - (fun acc (name, kind) -> + (fun acc (name, t) -> let key = - match kind with - | `Contents -> + match Store.Tree.destruct t with + | `Contents _ -> `Key (key @ [name]) - | `Node -> + | `Node _ -> `Dir (key @ [name]) in f key acc) @@ -826,11 +852,14 @@ module Dumpable_context = struct >>= fun keys -> keys |> List.sort (fun (a, _) (b, _) -> String.compare a b) - |> List.map_s (fun (key, value_kind) -> - Store.Tree.get_tree tree [key] - >|= fun value -> - let value_hash = tree_hash value in - {key; value; value_kind; value_hash}) + |> List.map_s (fun (key, value) -> + Store.Tree.kind value [] + >|= function + | None -> + assert false (* The value must exist in the tree *) + | Some value_kind -> + let value_hash = tree_hash value in + {key; value; value_kind; value_hash}) >|= fun bindings -> Store.Tree.clear tree ; bindings module Hashtbl = Hashtbl.MakeSeeded (struct diff --git a/src/lib_storage/tezos-storage.opam b/src/lib_storage/tezos-storage.opam index b7fa94c07519..983ea05ce697 100644 --- a/src/lib_storage/tezos-storage.opam +++ b/src/lib_storage/tezos-storage.opam @@ -10,8 +10,9 @@ depends: [ "dune" { >= "2.0" } "tezos-base" "tezos-lmdb" - "irmin" { >= "2.2.0" } - "irmin-pack" + "irmin" { >= "2.3.0" } + "irmin-pack" { >= "2.3.0" } + "irmin-mem" { >= "2.3.0" } "digestif" {>= "0.7.3"} "tezos-shell-services" "tezos-stdlib-unix" -- GitLab From 3443c927aed270caf3fb92429f5af9054120d34d Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Tue, 22 Dec 2020 17:38:45 +0100 Subject: [PATCH 3/7] Storage: sync read-only instances before exists/checkout calls --- src/lib_storage/context.ml | 15 ++++++++++++--- src/lib_storage/context.mli | 4 ++++ 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index b8a60a1c4eb9..e7fe16d25605 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -254,6 +254,7 @@ type index = { path : string; repo : Store.Repo.t; patch_context : (context -> context tzresult Lwt.t) option; + readonly : bool; } and context = {index : index; parents : Store.Commit.t list; tree : Store.tree} @@ -288,11 +289,19 @@ let restore_integrity ?ppf index = "unable to fix the corrupted context: %d bad entries detected" n) +let sync index = + if index.readonly then Store.sync index.repo ; + Lwt.return () + let exists index key = + sync index + >>= fun () -> Store.Commit.of_hash index.repo (Hash.of_context_hash key) >|= function None -> false | Some _ -> true let checkout index key = + sync index + >>= fun () -> Store.Commit.of_hash index.repo (Hash.of_context_hash key) >>= function | None -> @@ -499,11 +508,11 @@ let set_predecessor_ops_metadata_hash v hash = (*-- Initialisation ----------------------------------------------------------*) -let init ?patch_context ?mapsize:_ ?readonly root = +let init ?patch_context ?mapsize:_ ?(readonly = false) root = Store.Repo.v - (Irmin_pack.config ?readonly ?index_log_size:!index_log_size root) + (Irmin_pack.config ~readonly ?index_log_size:!index_log_size root) >>= fun repo -> - let v = {path = root; repo; patch_context} in + let v = {path = root; repo; patch_context; readonly} in Lwt.return v let close index = Store.Repo.close index.repo diff --git a/src/lib_storage/context.mli b/src/lib_storage/context.mli index ef5428c93f5b..e6cfaa40994e 100644 --- a/src/lib_storage/context.mli +++ b/src/lib_storage/context.mli @@ -47,6 +47,10 @@ val init : (** Close the index. Does not fail when the context is already closed. *) val close : index -> unit Lwt.t +(** Sync the context with disk. Only useful for read-only instances. + Does not fail when the context is not in read-only mode. *) +val sync : index -> unit Lwt.t + val compute_testchain_chain_id : Block_hash.t -> Chain_id.t val compute_testchain_genesis : Block_hash.t -> Block_hash.t -- GitLab From 39ad804f960a278408dedb9acc477e67fe1c0589 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 15 Jan 2021 17:43:24 +0100 Subject: [PATCH 4/7] tests_python: increase timeout for 'many bakers' tests --- tests_python/tests_008/test_many_bakers.py | 2 +- tests_python/tests_alpha/test_many_bakers.py | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/tests_python/tests_008/test_many_bakers.py b/tests_python/tests_008/test_many_bakers.py index 61e0a0cba48c..8038c6cf8067 100644 --- a/tests_python/tests_008/test_many_bakers.py +++ b/tests_python/tests_008/test_many_bakers.py @@ -23,7 +23,7 @@ class TestManyBakers: sandbox.add_baker(i, f'bootstrap{i + 1}', proto=protocol.DAEMON) def test_wait(self): - time.sleep(5) + time.sleep(10) def test_progress(self, sandbox: Sandbox): min_level = min( diff --git a/tests_python/tests_alpha/test_many_bakers.py b/tests_python/tests_alpha/test_many_bakers.py index 61e0a0cba48c..8038c6cf8067 100644 --- a/tests_python/tests_alpha/test_many_bakers.py +++ b/tests_python/tests_alpha/test_many_bakers.py @@ -23,7 +23,7 @@ class TestManyBakers: sandbox.add_baker(i, f'bootstrap{i + 1}', proto=protocol.DAEMON) def test_wait(self): - time.sleep(5) + time.sleep(10) def test_progress(self, sandbox: Sandbox): min_level = min( -- GitLab From 13053eb61a6949d69fbf659acc983df687c4a201 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Tue, 19 Jan 2021 10:48:25 +0100 Subject: [PATCH 5/7] Dependencies: upgrade coq-of-ocaml to the version 2.3.0 --- src/tooling/tezos-tooling.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tooling/tezos-tooling.opam b/src/tooling/tezos-tooling.opam index e698884910df..f2414046691f 100644 --- a/src/tooling/tezos-tooling.opam +++ b/src/tooling/tezos-tooling.opam @@ -6,7 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "coq-of-ocaml" { = "2.2.1" } + "coq-of-ocaml" { = "2.3.0" } "dune" { >= "2.0" } "ocamlformat" { = "0.10" } "bisect_ppx" { >= "2.3" } -- GitLab From 95e05a0fc0cad54a9c5e0141dcbe8e2e565772df Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 20 Jan 2021 10:31:30 +0100 Subject: [PATCH 6/7] Protocol/coq-of-ocaml: reduce the black-list size --- src/proto_alpha/lib_protocol/coq-of-ocaml/config.json | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/coq-of-ocaml/config.json b/src/proto_alpha/lib_protocol/coq-of-ocaml/config.json index a064cb2785fe..6fa0f29dc5b6 100644 --- a/src/proto_alpha/lib_protocol/coq-of-ocaml/config.json +++ b/src/proto_alpha/lib_protocol/coq-of-ocaml/config.json @@ -17,25 +17,16 @@ "contract_hash.ml", "contract_repr.ml", "helpers_services.ml", - "lazy_storage_diff.ml", "lazy_storage_kind.ml", "level_repr.ml", "main.mli", - "michelson_v1_gas.ml", "misc.ml", "nonce_hash.ml", - "raw_context.ml", - "raw_context.mli", - "raw_level_repr.ml", "script_expr_hash.ml", - "script_interpreter.ml", "script_ir_translator.ml", "state_hash.ml", "storage_functors.ml", - "storage_functors.mli", "storage.ml", - "storage_sigs.ml", - "tez_repr.ml", "voting_period_repr.ml" ], "error_message_blacklist": [ -- GitLab From 64474f01b9e208e4b9a9d3cca7dad871aead73af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 20 Jan 2021 11:37:53 +0100 Subject: [PATCH 7/7] CI: update opam repository commit hash --- .gitlab-ci.yml | 2 +- scripts/version.sh | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 4b090ef312a8..8a74d813fc74 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -15,7 +15,7 @@ include: variables: ## Please update `scripts/version.sh` accordingly - build_deps_image_version: 4eb9728016e05758054c600ddc66c7e295c27a26 + build_deps_image_version: dd4bc58ba8b5ba8d1fe24796623f51fee6e7a5c3 build_deps_image_name: registry.gitlab.com/tezos/opam-repository public_docker_image_name: docker.io/${CI_PROJECT_PATH} GIT_STRATEGY: fetch diff --git a/scripts/version.sh b/scripts/version.sh index 1028a4a82929..4daf81c5327c 100755 --- a/scripts/version.sh +++ b/scripts/version.sh @@ -10,10 +10,10 @@ recommended_rust_version=1.44.0 ## Please update `.gitlab-ci.yml` accordingly ## full_opam_repository is a commit hash of the public OPAM repository, i.e. ## https://github.com/ocaml/opam-repository -full_opam_repository_tag=bf94421703ae6d95113e5b24890f304701e47b78 +full_opam_repository_tag=5491aa2960fd7b103b4461772b7badb475061d70 ## opam_repository is an additional, tezos-specific opam repository. -opam_repository_tag=4eb9728016e05758054c600ddc66c7e295c27a26 +opam_repository_tag=dd4bc58ba8b5ba8d1fe24796623f51fee6e7a5c3 opam_repository_url=https://gitlab.com/tezos/opam-repository.git opam_repository=$opam_repository_url\#$opam_repository_tag -- GitLab