Alpha/Baker: add a max_waiting_time parameter in the command

src/proto_alpha/lib_client/client_proto_args.ml

@@ -30,6 +30,7 @@ open Clic
 type error += Bad_tez_arg of string * string (* Arg_name * value *)
 type error += Bad_max_priority of string
 type error += Bad_fee_threshold of string
+type error += Bad_max_waiting_time of string
 type error += Bad_endorsement_delay of string
 type error += Bad_preserved_levels of string
 
@@ -68,6 +69,16 @@ let () =
     Data_encoding.(obj1 (req "parameter" string))
     (function Bad_fee_threshold parameter -> Some parameter | _ -> None)
     (fun parameter -> Bad_fee_threshold parameter) ;
+  register_error_kind
+    `Permanent
+    ~id:"badMaxWaitingTimeArg"
+    ~title:"Bad -max-waiting-time arg"
+    ~description:("invalid duration in -max-waiting-time")
+    ~pp:(fun ppf literal ->
+        Format.fprintf ppf "Bad argument value for -max-waiting-time. Expected an integer, but given '%s'" literal)
+    Data_encoding.(obj1 (req "parameter" string))
+    (function Bad_max_waiting_time parameter -> Some parameter | _ -> None)
+    (fun parameter -> Bad_max_waiting_time parameter) ;
   register_error_kind
     `Permanent
     ~id:"badEndorsementDelayArg"
@@ -232,6 +243,21 @@ let fee_threshold_arg =
          | Some t -> return t
          | None -> fail (Bad_fee_threshold s)))
 
+let max_waiting_time_arg =
+  default_arg
+    ~long:"max-waiting-time"
+    ~placeholder:"seconds"
+    ~doc:"Specify how long the baker is allowed to wait late \
+          endorsements (if necessary) after its delegate's injection \
+          date."
+    ~default:"25"
+    (parameter (fun _ s ->
+         try
+           let i = int_of_string s in
+           fail_when (i < 0) (Bad_max_waiting_time s) >>=? fun () ->
+           return (int_of_string s)
+         with _ -> fail (Bad_max_waiting_time s)))
+
 let endorsement_delay_arg =
   default_arg
     ~long:"endorsement-delay"

src/proto_alpha/lib_client/client_proto_args.mli

@@ -40,6 +40,7 @@ val delegatable_switch: (bool, Proto_alpha.full) Clic.arg
 val spendable_switch: (bool, Proto_alpha.full) Clic.arg
 val max_priority_arg: (int option, Proto_alpha.full) Clic.arg
 val fee_threshold_arg: (Tez.tez option, Proto_alpha.full) Clic.arg
+val max_waiting_time_arg: (int, Proto_alpha.full) Clic.arg
 val force_switch: (bool, Proto_alpha.full) Clic.arg
 val minimal_timestamp_switch: (bool, Proto_alpha.full) Clic.arg
 val endorsement_delay_arg: (int, Proto_alpha.full) Clic.arg

src/proto_alpha/lib_delegate/client_baking_forge.ml

@@ -50,17 +50,20 @@ type state = {
   constants: Constants.t tzlazy ;
   (* Minimum operation fee required to include in a block *)
   fee_threshold : Tez.t ;
+  (* Maximum waiting time allowed for late endorsements *)
+  max_waiting_time : int ;
   (* truly mutable *)
   mutable best_slot: (Time.t * (Client_baking_blocks.block_info * int * public_key_hash)) option ;
 }
 
-let create_state ?(fee_threshold = Tez.zero) genesis context_path index delegates constants =
+let create_state ?(fee_threshold = Tez.zero) ~max_waiting_time genesis context_path index delegates constants =
   { genesis ;
     context_path ;
     index ;
     delegates ;
     constants ;
     fee_threshold ;
+    max_waiting_time ;
     best_slot = None ;
   }
 
@@ -594,6 +597,7 @@ let forge_block
           constants = tzlazy (fun () -> Alpha_services.Constants.all cctxt (`Main, `Head 0)) ;
           delegates = [] ;
           best_slot = None ;
+          max_waiting_time = 0 ;
           fee_threshold = Tez.zero ;
         } in
         filter_and_apply_operations ~timestamp ~protocol_data state bi operations
@@ -645,7 +649,7 @@ let shell_prevalidation
 
 (** [fetch_operations] retrieve the operations present in the
     mempool. If no endorsements are present in the initial set, it
-    waits until half of its injection range time has passed. *)
+    waits until [state.max_waiting_time] seconds after its injection range start date. *)
 let fetch_operations
     (cctxt : #Proto_alpha.full)
     ~chain
@@ -675,21 +679,8 @@ let fetch_operations
       if contains_head_endorsements !operations then
         return (Some !operations)
       else
-        (* Retrieve time left *)
-        tzforce state.constants >>=? fun Constants.{ parametric = { time_between_blocks ; _ } } ->
-        let rec loop prio = function
-          | [] -> Period.one_minute
-          | [ last ] -> last
-          | first :: durations ->
-              if prio = 0 then first
-              else loop (prio - 1) durations
-        in
-        (* The "safe" allocated time for injection stops when the next
-           baker's time begins. *)
-        let allocated_time = loop (priority + 1) time_between_blocks in
         (* Wait 1/3 of the allocated time *)
-        let timespan = Int64.div (Period.to_seconds allocated_time) 3L in
-        let limit_date = Time.add timestamp timespan in
+        let limit_date = Time.add timestamp (Int64.of_int state.max_waiting_time) in
         lwt_log_notice Tag.DSL.(fun f ->
             f "No endorsements present in the mempool. Waiting until %a (%a) for new operations."
             -% t event "waiting_operations"
@@ -996,6 +987,7 @@ let create
     (cctxt : #Proto_alpha.full)
     ?fee_threshold
     ?max_priority
+    ~max_waiting_time
     ~context_path
     delegates
     block_stream =
@@ -1003,7 +995,7 @@ let create
     let constants =
       tzlazy (fun () -> Alpha_services.Constants.all cctxt (`Main, `Hash (bi.Client_baking_blocks.hash, 0))) in
     Client_baking_simulator.load_context ~context_path >>= fun index ->
-    let state = create_state genesis_hash context_path index delegates constants ?fee_threshold in
+    let state = create_state ?fee_threshold  ~max_waiting_time genesis_hash  context_path index delegates constants in
     return state
   in
 

src/proto_alpha/lib_delegate/client_baking_forge.mli

@@ -105,6 +105,7 @@ val create:
   #Proto_alpha.full ->
   ?fee_threshold:Tez.t ->
   ?max_priority: int ->
+  max_waiting_time: int ->
   context_path: string ->
   public_key_hash list ->
   Client_baking_blocks.block_info tzresult Lwt_stream.t ->

src/proto_alpha/lib_delegate/client_daemon.ml

@@ -44,13 +44,20 @@ end
 
 module Baker = struct
 
-  let run (cctxt : #Proto_alpha.full) ?fee_threshold ?max_priority ?min_date ~context_path delegates =
+  let run
+      (cctxt : #Proto_alpha.full)
+      ?fee_threshold
+      ?max_priority
+      ?min_date
+      ~context_path
+      ~max_waiting_time
+      delegates =
     await_bootstrapped_node cctxt >>=? fun _ ->
     Client_baking_blocks.monitor_heads
       ~next_protocols:(Some [Proto_alpha.hash])
       cctxt `Main >>=? fun block_stream ->
     Client_baking_forge.create cctxt
-      ?fee_threshold ?max_priority ~context_path delegates block_stream >>=? fun () ->
+      ?fee_threshold ?max_priority ~max_waiting_time ~context_path delegates block_stream >>=? fun () ->
     ignore min_date;
     return_unit
 

src/proto_alpha/lib_delegate/client_daemon.mli

@@ -41,6 +41,7 @@ module Baker : sig
     ?max_priority: int ->
     ?min_date: Time.t ->
     context_path: string ->
+    max_waiting_time: int ->
     public_key_hash list -> unit tzresult Lwt.t
 end
 

src/proto_alpha/lib_delegate/delegate_commands.ml

@@ -93,19 +93,20 @@ let baker_commands () =
   in
   [
     command ~group ~desc: "Launch the baker daemon."
-      (args2 max_priority_arg fee_threshold_arg)
+      (args3 max_priority_arg fee_threshold_arg max_waiting_time_arg)
       (prefixes [ "run" ; "with" ; "local" ; "node" ]
        @@ param
          ~name:"context_path"
          ~desc:"Path to the node data directory (e.g. $HOME/.tezos-node)"
          directory_parameter
        @@ seq_of_param Client_keys.Public_key_hash.alias_param)
-      (fun (max_priority, fee_threshold) node_path delegates cctxt ->
+      (fun (max_priority, fee_threshold, max_waiting_time) node_path delegates cctxt ->
          Tezos_signer_backends.Encrypted.decrypt_list
            cctxt (List.map fst delegates) >>=? fun () ->
          Client_daemon.Baker.run cctxt
            ?fee_threshold
            ?max_priority
+           ~max_waiting_time
            ~min_date:((Time.add (Time.now ()) (Int64.neg 1800L)))
            ~context_path:(Filename.concat node_path "context")
            (List.map snd delegates)