From ac20391c62574ab93e5c165c234d6cb2c2bdb828 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Thu, 14 Jun 2018 14:24:33 +0800 Subject: [PATCH] Alpha/daemons: some factorisation --- .../lib_delegate/client_baking_endorsement.ml | 22 +++---------- .../lib_delegate/client_baking_forge.ml | 23 +++----------- .../lib_delegate/client_baking_scheduling.ml | 31 +++++++++++++++++++ .../lib_delegate/client_baking_scheduling.mli | 17 ++++++++++ 4 files changed, 58 insertions(+), 35 deletions(-) create mode 100644 src/proto_alpha/lib_delegate/client_baking_scheduling.ml create mode 100644 src/proto_alpha/lib_delegate/client_baking_scheduling.mli diff --git a/src/proto_alpha/lib_delegate/client_baking_endorsement.ml b/src/proto_alpha/lib_delegate/client_baking_endorsement.ml index 815c6dc33..69f1f7755 100644 --- a/src/proto_alpha/lib_delegate/client_baking_endorsement.ml +++ b/src/proto_alpha/lib_delegate/client_baking_endorsement.ml @@ -206,12 +206,6 @@ let endorse_for cctxt = function ignore errored; (* TODO: log *) return still_waiting -let compute_timeout time = - let delay = Time.diff time (Time.now ()) in - if delay < 0L then - None - else - Some (Lwt_unix.sleep (Int64.to_float delay)) let allowed_to_endorse cctxt state (block: Client_baking_blocks.block_info) delegate time = Client_keys.Public_key_hash.name cctxt delegate >>=? fun name -> @@ -227,7 +221,7 @@ let allowed_to_endorse cctxt state (block: Client_baking_blocks.block_info) dele lwt_debug "Level %a (or higher) previously endorsed: do not endorse." Raw_level.pp level >>= return | false -> - match compute_timeout time with + match Client_baking_scheduling.sleep_until time with | None -> lwt_debug "Endorsment opportunity is passed." >>= fun () -> return () @@ -336,13 +330,7 @@ let create ~delay contracts (block_stream: Client_baking_blocks.block_info tzresult Lwt_stream.t) = - let rec wait_for_first_block () = - Lwt_stream.get block_stream >>= function - | None | Some (Error _) -> - cctxt#message "Can't fetch the current block head. Retrying soon." >>= fun () -> - (* NOTE: this is not a tight loop because of Lwt_stream.get *) - wait_for_first_block () - | Some (Ok bi) -> - create cctxt ~max_past ~delay contracts block_stream bi - in - wait_for_first_block () + Client_baking_scheduling.wait_for_first_block + ~info:cctxt#message + block_stream + (create cctxt ~max_past ~delay contracts block_stream) diff --git a/src/proto_alpha/lib_delegate/client_baking_forge.ml b/src/proto_alpha/lib_delegate/client_baking_forge.ml index 2a0bd0ca2..61081015c 100644 --- a/src/proto_alpha/lib_delegate/client_baking_forge.ml +++ b/src/proto_alpha/lib_delegate/client_baking_forge.ml @@ -387,20 +387,13 @@ let drop_old_slots ~before state = (fun (t, _slot) -> Time.compare before t <= 0) state.future_slots -let compute_timeout time = - let delay = Time.diff time (Time.now ()) in - if delay < 0L then - None - else - Some (Lwt_unix.sleep (Int64.to_float delay)) - let compute_timeout { future_slots } = match future_slots with | [] -> (* No slots, just wait for new blocks which will give more info *) Lwt_utils.never_ending | (timestamp, _) :: _ -> - match compute_timeout timestamp with + match Client_baking_scheduling.sleep_until timestamp with | None -> Lwt_utils.never_ending | Some timeout -> timeout @@ -712,13 +705,7 @@ let create ?max_priority (delegates: public_key_hash list) (block_stream: Client_baking_blocks.block_info tzresult Lwt_stream.t) = - let rec wait_for_first_block () = - Lwt_stream.get block_stream >>= function - | None | Some (Error _) -> - cctxt#message "Can't fetch the current block head. Retrying soon." >>= fun () -> - (* NOTE: this is not a tight loop because of Lwt_stream.get *) - wait_for_first_block () - | Some (Ok bi) -> - create cctxt ?max_priority delegates block_stream bi - in - wait_for_first_block () + Client_baking_scheduling.wait_for_first_block + ~info:cctxt#message + block_stream + (create cctxt ?max_priority delegates block_stream) diff --git a/src/proto_alpha/lib_delegate/client_baking_scheduling.ml b/src/proto_alpha/lib_delegate/client_baking_scheduling.ml new file mode 100644 index 000000000..bef74c213 --- /dev/null +++ b/src/proto_alpha/lib_delegate/client_baking_scheduling.ml @@ -0,0 +1,31 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +let sleep_until time = + let delay = Time.diff time (Time.now ()) in + if delay < 0L then + None + else + Some (Lwt_unix.sleep (Int64.to_float delay)) + +let wait_for_first_block + ?(info = fun (_: (unit Lwt.t, unit) Client_context.lwt_format) -> Lwt.return_unit) + (block_stream: Client_baking_blocks.block_info tzresult Lwt_stream.t) + k = + let rec wait_for_first_block () = + Lwt_stream.get block_stream >>= function + | None | Some (Error _) -> + info "Can't fetch the current block head. Retrying soon." >>= fun () -> + (* NOTE: this is not a tight loop because of Lwt_stream.get *) + wait_for_first_block () + | Some (Ok bi) -> + k bi + in + wait_for_first_block () diff --git a/src/proto_alpha/lib_delegate/client_baking_scheduling.mli b/src/proto_alpha/lib_delegate/client_baking_scheduling.mli new file mode 100644 index 000000000..0a079ec36 --- /dev/null +++ b/src/proto_alpha/lib_delegate/client_baking_scheduling.mli @@ -0,0 +1,17 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +val sleep_until: Time.t -> unit Lwt.t option + +val wait_for_first_block: + ?info:((unit Lwt.t, unit) Client_context.lwt_format -> unit Lwt.t) -> + Client_baking_blocks.block_info tzresult Lwt_stream.t -> + (Client_baking_blocks.block_info -> 'a Lwt.t) -> + 'a Lwt.t