Alpha/endorser: one upcoming endorsment per key

src/proto_alpha/lib_delegate/client_baking_endorsement.ml

@@ -141,17 +141,19 @@ let forge_endorsement (cctxt : #Proto_alpha.full)
 type state = {
   delegates: public_key_hash list ;
   delay: int64 ;
-  mutable to_endorse : endorsement option
+  (* invariant: only one slot per delegate *)
+  mutable to_endorse : endorsement list ;
 }
 and endorsement = {
   time: Time.t ;
+  timeout: unit Lwt.t ;
   delegate: public_key_hash ;
   block: Client_baking_blocks.block_info ;
-  slots: int list;
+  slots: int list ;
 }
 
 let create_state delegates delay =
-  { delegates ; delay ; to_endorse=None }
+  { delegates ; delay ; to_endorse=[] }
 
 let get_delegates cctxt state =
   match state.delegates with
@@ -161,9 +163,7 @@ let get_delegates cctxt state =
   | _ :: _ as delegates ->
       return delegates
 
-let endorse_for cctxt = function
-    None -> return ()
-  | Some {delegate; block ; slots} ->
+let endorse_for_delegate cctxt { delegate ; block ; slots ; } =
   let hash = block.hash in
   let b = `Hash (hash, 0) in
   let level = block.level.level in
@@ -189,6 +189,23 @@ let endorse_for cctxt = function
     Operation_hash.pp_short oph >>= fun () ->
   return ()
 
+let endorse_for cctxt = function
+  | [] -> return []
+  | endorsments ->
+      let done_waiting, still_waiting, errored =
+        List.fold_left
+          (fun (r, s, f) ({ timeout } as endorsment) -> match Lwt.state timeout with
+             | Lwt.Return () -> (endorsment :: r, s, f)
+             | Lwt.Sleep -> (r, endorsment :: s, f)
+             | Lwt.Fail _ -> (r, s, endorsment :: f)
+          )
+          ([], [], [])
+          endorsments
+      in
+      iter_p (endorse_for_delegate cctxt) done_waiting >>=? fun () ->
+      ignore errored; (* TODO: log *)
+      return still_waiting
+
 let allowed_to_endorse cctxt state (block: Client_baking_blocks.block_info) delegate time =
   Client_keys.Public_key_hash.name cctxt delegate >>=? fun name ->
   lwt_log_info "Checking if allowed to endorse block %a for %s"
@@ -203,14 +220,23 @@ 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 ->
-      let neu = {time ; delegate ; block; slots} in
-      match state.to_endorse with
+      let timeout =
+        let delay = (Time.diff time (Time.now ())) in
+        if delay <= 0L then
+          Lwt.return_unit
+        else
+          Lwt_unix.sleep (Int64.to_float delay)
+      in
+      let neu = { time ; timeout ; delegate ; block; slots } in
+      match List.find_opt (fun { delegate = d } -> delegate = d) state.to_endorse with
       | None ->
-          state.to_endorse <- Some neu;
+          state.to_endorse <- neu :: state.to_endorse;
           return ()
       | Some old ->
           if Fitness.compare old.block.fitness neu.block.fitness < 0 then begin
-            state.to_endorse <- Some neu;
+            let without_old =
+              List.filter (fun to_end -> to_end <> old) state.to_endorse in
+            state.to_endorse <- neu :: without_old;
             return ()
           end else
             lwt_debug "Block %a is not the fittest: do not endorse."
@@ -235,13 +261,10 @@ let prepare_endorsement (cctxt : #Proto_alpha.full) ~(max_past:int64) state bi
 
 let compute_timeout state =
   match state.to_endorse with
-  | None -> Lwt_utils.never_ending
-  | Some {time} ->
-      let delay = (Time.diff time (Time.now ())) in
-      if delay <= 0L then
-        Lwt.return_unit
-      else
-        Lwt_unix.sleep (Int64.to_float delay)
+  | [] -> Lwt_utils.never_ending
+  | to_ends ->
+      Lwt.choose (List.map (fun to_end -> to_end.timeout) to_ends)
+
 
 let check_error f =
   f >>= function
@@ -283,9 +306,14 @@ let create
           last_get_block := None;
           check_error (prepare_endorsement cctxt ~max_past state bi)
       | `Timeout ->
-          check_error (endorse_for cctxt state.to_endorse) >>= fun () ->
-          state.to_endorse <- None ;
+          begin
+            endorse_for cctxt state.to_endorse >>= function
+            | Ok still_waiting ->
+                state.to_endorse <- still_waiting ;
                 Lwt.return_unit
+            | Error errs ->
+                lwt_log_error "Error while endorsing:@\n%a" pp_print_error errs
+          end
     end >>= fun () ->
     worker_loop () in