rpc: add failed jobs to progress

Signed-off-by: Ali Caglayan <alizter@gmail.com>

CHANGES.md

@@ -3,6 +3,9 @@ Unreleased
 
 - No longer emit linkopts(javascript) in META files (#8168, @hhugo)
 
+- The `progress` RPC procedure now has an extra field for the `In_progress`
+  constructor for the number of failed jobs. (#8212, @Alizter)
+
 3.10.0 (2023-07-31)
 -------------------
 

otherlibs/dune-rpc-lwt/examples/rpc_client/rpc_client.ml

@@ -34,9 +34,10 @@ let () =
            | Some Success -> "Success"
            | Some Failed -> "Failed"
            | Some Interrupted -> "Interrupted"
-           | Some (In_progress { complete; remaining }) ->
-             Printf.sprintf "In_progress { complete = %d;  remaining = %d }"
-               complete remaining
+           | Some (In_progress { complete; remaining; failed }) ->
+             Printf.sprintf
+               "In_progress { complete = %d;  remaining = %d;  failed = %d }"
+               complete remaining failed
            | Some Waiting -> "Waiting"
          in
          print_endline (Printf.sprintf "Got progress_event: %s" message);

otherlibs/dune-rpc/dune_rpc.mli

@@ -175,6 +175,7 @@ module V1 : sig
       | In_progress of
           { complete : int
           ; remaining : int
+          ; failed : int
           }
       | Failed
       | Interrupted

otherlibs/dune-rpc/private/exported_types.ml

@@ -325,6 +325,7 @@ module Progress = struct
     | In_progress of
         { complete : int
         ; remaining : int
+        ; failed : int
         }
     | Failed
     | Interrupted
@@ -337,9 +338,11 @@ module Progress = struct
     let in_progress =
       let complete = field "complete" (required int) in
       let remaining = field "remaining" (required int) in
+      let failed = field "failed" (required int) in
       constr "in_progress"
-        (record (both complete remaining))
-        (fun (complete, remaining) -> In_progress { complete; remaining })
+        (record (three complete remaining failed))
+        (fun (complete, remaining, failed) ->
+          In_progress { complete; remaining; failed })
     in
     let interrupted = constr "interrupted" unit (fun () -> Interrupted) in
     let success = constr "success" unit (fun () -> Success) in
@@ -349,8 +352,8 @@ module Progress = struct
     in
     let serialize = function
       | Waiting -> case () waiting
-      | In_progress { complete; remaining } ->
-        case (complete, remaining) in_progress
+      | In_progress { complete; remaining; failed } ->
+        case (complete, remaining, failed) in_progress
       | Failed -> case () failed
       | Interrupted -> case () interrupted
       | Success -> case () success

otherlibs/dune-rpc/private/exported_types.mli

@@ -132,6 +132,7 @@ module Progress : sig
     | In_progress of
         { complete : int
         ; remaining : int
+        ; failed : int
         }
     | Failed
     | Interrupted

otherlibs/dune-rpc/private/procedures.ml

@@ -118,12 +118,72 @@ module Poll = struct
   let name t = t.name
 
   module Progress = struct
+    module V1 = struct
+      type t =
+        | Waiting
+        | In_progress of
+            { complete : int
+            ; remaining : int
+            }
+        | Failed
+        | Interrupted
+        | Success
+
+      let sexp =
+        let open Conv in
+        let waiting = constr "waiting" unit (fun () -> Waiting) in
+        let failed = constr "failed" unit (fun () -> Failed) in
+        let in_progress =
+          let complete = field "complete" (required int) in
+          let remaining = field "remaining" (required int) in
+          constr "in_progress"
+            (record (both complete remaining))
+            (fun (complete, remaining) -> In_progress { complete; remaining })
+        in
+        let interrupted = constr "interrupted" unit (fun () -> Interrupted) in
+        let success = constr "success" unit (fun () -> Success) in
+        let constrs =
+          List.map ~f:econstr [ waiting; failed; interrupted; success ]
+          @ [ econstr in_progress ]
+        in
+        let serialize = function
+          | Waiting -> case () waiting
+          | In_progress { complete; remaining } ->
+            case (complete, remaining) in_progress
+          | Failed -> case () failed
+          | Interrupted -> case () interrupted
+          | Success -> case () success
+        in
+        sum constrs serialize
+
+      let to_progress : t -> Progress.t = function
+        | Waiting -> Waiting
+        | In_progress { complete; remaining } ->
+          In_progress { complete; remaining; failed = 0 }
+        | Failed -> Failed
+        | Interrupted -> Interrupted
+        | Success -> Success
+
+      let of_progress : Progress.t -> t = function
+        | Waiting -> Waiting
+        | In_progress { complete; remaining; failed = _ } ->
+          In_progress { complete; remaining }
+        | Failed -> Failed
+        | Interrupted -> Interrupted
+        | Success -> Success
+    end
+
     let name = "progress"
 
     let v1 =
-      Decl.Request.make_current_gen ~req:Id.sexp
+      Decl.Request.make_gen ~version:1 ~req:Id.sexp ~resp:(Conv.option V1.sexp)
+        ~upgrade_req:Fun.id ~downgrade_req:Fun.id
+        ~upgrade_resp:(Option.map ~f:V1.to_progress)
+        ~downgrade_resp:(Option.map ~f:V1.of_progress)
+
+    let v2 =
+      Decl.Request.make_current_gen ~version:2 ~req:Id.sexp
         ~resp:(Conv.option Progress.sexp)
-        ~version:1
   end
 
   module Diagnostic = struct
@@ -146,7 +206,7 @@ module Poll = struct
 
   let progress =
     let open Progress in
-    make name [ v1 ]
+    make name [ v1; v2 ]
 
   let diagnostic =
     let open Diagnostic in

src/dune_rpc_impl/server.ml

@@ -303,10 +303,12 @@ let handler (t : _ t Fdecl.t) action_runner_server handle :
       | Build_succeeded__now_waiting_for_changes -> Success
       | Build_failed__now_waiting_for_changes -> Failed
       | Building now ->
-        let remaining =
-          now.number_of_rules_discovered - now.number_of_rules_executed
-        in
-        In_progress { complete = now.number_of_rules_executed; remaining }
+        In_progress
+          { complete = now.number_of_rules_executed
+          ; remaining =
+              now.number_of_rules_discovered - now.number_of_rules_executed
+          ; failed = now.number_of_rules_failed
+          }
     in
     Handler.implement_long_poll rpc Procedures.Poll.progress Build_system.state
       ~equal:Build_system.State.equal ~diff