Alpha/daemons: some factorisation

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 () =
+  Client_baking_scheduling.wait_for_first_block
-    Lwt_stream.get block_stream >>= function
+    ~info:cctxt#message
-    | None | Some (Error _) ->
+    block_stream
-        cctxt#message "Can't fetch the current block head. Retrying soon." >>= fun () ->
+    (create cctxt ~max_past ~delay contracts block_stream)
-        (* 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 ()

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 () =
+  Client_baking_scheduling.wait_for_first_block
-    Lwt_stream.get block_stream >>= function
+    ~info:cctxt#message
-    | None | Some (Error _) ->
+    block_stream
-        cctxt#message "Can't fetch the current block head. Retrying soon." >>= fun () ->
+    (create cctxt ?max_priority delegates block_stream)
-        (* 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 ()

src/proto_alpha/lib_delegate/client_baking_scheduling.ml

@@ -0,0 +1,31 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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 ()

src/proto_alpha/lib_delegate/client_baking_scheduling.mli

@@ -0,0 +1,17 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    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