feat: retry failed tests n times (#43)

* feat: retry failed tests x times

* chore: use stream to submit tests to a pool of workers

* feat: print retries to console

* feat: add configuration option for retry count

* docs: add documentation for the retry configuration option

lib/OSnap.ml

@@ -20,9 +20,9 @@ let setup ~sw ~env ~noCreate ~noOnly ~noSkip ~config_path =
   let*? all_tests = Config.Test.init config in
   let*? only_tests, tests =
     all_tests
-    |> ResultList.map_p_until_first_error (fun test ->
+    |> ResultList.traverse (fun test ->
       test.sizes
-      |> ResultList.map_p_until_first_error (fun size ->
+      |> ResultList.traverse (fun size ->
         let { name = _size_name; width; height } = size in
         let filename = Test.get_filename test.name width height in
         let current_image_path = Eio.Path.(snapshot_dir / filename) in
@@ -70,39 +70,62 @@ let setup ~sw ~env ~noCreate ~noOnly ~noSkip ~config_path =
 let teardown t = Browser.Launcher.shutdown t.browser
 
 let run ~env t =
-  let ( let*? ) = Result.bind in
+  Eio.Switch.run
+  @@ fun sw ->
   let open Config.Types in
   let { tests_to_run; config; start_time; browser } = t in
-  let parallelism = Domain.recommended_domain_count () * 3 in
-  let pool =
+  Test.Printer.Progress.set_total (List.length tests_to_run);
+  let domain_count = Domain.recommended_domain_count () in
+  let parallelism = domain_count * 3 in
+  let test_stream = Eio.Stream.create 0 in
+  let browser_pool =
     Eio.Pool.create
-      ~validate:(fun target -> Result.is_ok target)
       parallelism
       (fun () -> Browser.Target.make browser)
+      ~validate:(fun target -> Result.is_ok target)
+  in
+  for _ = 1 to parallelism do
+    Eio.Fiber.fork_daemon ~sw (fun () ->
+      let rec aux () =
+        let request, reply = Eio.Stream.take test_stream in
+        let test_result =
+          Eio.Pool.use browser_pool (fun target ->
+            Test.run ~env config (Result.get_ok target) request)
+        in
+        Eio.Promise.resolve reply test_result;
+        aux ()
+      in
+      aux ())
+  done;
+  let rec run_test test =
+    let reply, resolve_reply = Eio.Promise.create () in
+    Eio.Stream.add test_stream (test, resolve_reply);
+    let response = Eio.Promise.await reply in
+    match response with
+    | Ok ({ result = Some (`Retry _); _ } as test) -> run_test test
+    | r -> r
   in
-  Test.Printer.Progress.set_total (List.length tests_to_run);
   let*? test_results =
     tests_to_run
-    |> ResultList.map_p_until_first_error (fun test ->
-      Eio.Pool.use pool (fun target ->
-        let test, { name = size_name; width; height }, exists = test in
-        let test =
-          Test.Types.
-            { exists
-            ; size_name
-            ; width
-            ; height
-            ; skip = test.OSnap_Config.Types.skip
-            ; url = test.OSnap_Config.Types.url
-            ; name = test.OSnap_Config.Types.name
-            ; actions = test.OSnap_Config.Types.actions
-            ; ignore_regions = test.OSnap_Config.Types.ignore
-            ; threshold = test.OSnap_Config.Types.threshold
-            ; warnings = []
-            ; result = None
-            }
-        in
-        Test.run ~env config (Result.get_ok target) test))
+    |> ResultList.traverse
+       @@ fun target ->
+       let test, { name = size_name; width; height }, exists = target in
+       run_test
+         Test.Types.
+           { exists
+           ; size_name
+           ; width
+           ; height
+           ; skip = test.OSnap_Config.Types.skip
+           ; url = test.OSnap_Config.Types.url
+           ; name = test.OSnap_Config.Types.name
+           ; actions = test.OSnap_Config.Types.actions
+           ; ignore_regions = test.OSnap_Config.Types.ignore
+           ; threshold = test.OSnap_Config.Types.threshold
+           ; retry = test.OSnap_Config.Types.retry
+           ; warnings = []
+           ; result = None
+           }
   in
   let end_time = Unix.gettimeofday () in
   let seconds = end_time -. start_time in

lib/OSnap_Config/OSnap_Config_Global.ml

@@ -22,6 +22,11 @@ module YAML = struct
       |> OSnap_Config_Utils.YAML.get_int_option ~path "threshold"
       |> Result.map (Option.value ~default:0)
     in
+    let* retry =
+      yaml
+      |> OSnap_Config_Utils.YAML.get_int_option ~path "retry"
+      |> Result.map (Option.value ~default:1)
+    in
     let* ignore_patterns =
       yaml
       |> OSnap_Config_Utils.YAML.get_string_list_option ~path "ignorePatterns"
@@ -135,6 +140,7 @@ module YAML = struct
       Result.ok
         { root_path
         ; threshold
+        ; retry
         ; test_pattern
         ; ignore_patterns
         ; base_url
@@ -186,6 +192,17 @@ module JSON = struct
       | Yojson.Basic.Util.Type_error (message, _) ->
         Result.error (`OSnap_Config_Parse_Error (message, path))
     in
+    let* retry =
+      try
+        json
+        |> Yojson.Basic.Util.member "retry"
+        |> Yojson.Basic.Util.to_int_option
+        |> Option.value ~default:1
+        |> Result.ok
+      with
+      | Yojson.Basic.Util.Type_error (message, _) ->
+        Result.error (`OSnap_Config_Parse_Error (message, path))
+    in
     let* default_sizes =
       try
         json
@@ -308,6 +325,7 @@ module JSON = struct
       Result.ok
         { root_path
         ; threshold
+        ; retry
         ; test_pattern
         ; ignore_patterns
         ; base_url

lib/OSnap_Config/OSnap_Config_Test.ml

@@ -138,6 +138,17 @@ module JSON = struct
       | Yojson.Basic.Util.Type_error (message, _) ->
         Result.error (`OSnap_Config_Parse_Error (message, path))
     in
+    let* retry =
+      try
+        test
+        |> Yojson.Basic.Util.member "retry"
+        |> Yojson.Basic.Util.to_int_option
+        |> Option.value ~default:global_config.retry
+        |> Result.ok
+      with
+      | Yojson.Basic.Util.Type_error (message, _) ->
+        Result.error (`OSnap_Config_Parse_Error (message, path))
+    in
     let* url =
       try
         test |> Yojson.Basic.Util.member "url" |> Yojson.Basic.Util.to_string |> Result.ok
@@ -176,7 +187,7 @@ module JSON = struct
       | _ -> Result.ok []
     in
     let* () = Common.collect_duplicates sizes in
-    Result.ok { only; skip; threshold; name; url; sizes; actions; ignore }
+    Result.ok { only; skip; threshold; retry; name; url; sizes; actions; ignore }
   ;;
 
   let parse global_config path =
@@ -226,6 +237,11 @@ module YAML = struct
       |> OSnap_Config_Utils.YAML.get_int_option ~path "threshold"
       |> Result.map (Option.value ~default:global_config.threshold)
     in
+    let* retry =
+      test
+      |> OSnap_Config_Utils.YAML.get_int_option ~path "retry"
+      |> Result.map (Option.value ~default:global_config.retry)
+    in
     let* sizes =
       test
       |> OSnap_Config_Utils.YAML.get_list_option
@@ -255,7 +271,7 @@ module YAML = struct
       |> Result.map (Option.value ~default:[])
     in
     let* () = Common.collect_duplicates sizes in
-    Result.ok { only; skip; threshold; name; url; sizes; actions; ignore }
+    Result.ok { only; skip; threshold; retry; name; url; sizes; actions; ignore }
   ;;
 
   let parse global_config path =

lib/OSnap_Config/OSnap_Config_Types.ml

@@ -25,6 +25,7 @@ type test =
   { only : bool
   ; skip : bool
   ; threshold : int
+  ; retry : int
   ; name : string
   ; url : string
   ; sizes : size list
@@ -35,6 +36,7 @@ type test =
 type global =
   { root_path : Eio.Fs.dir_ty Eio.Path.t
   ; threshold : int
+  ; retry : int
   ; ignore_patterns : string list
   ; test_pattern : string
   ; base_url : string

lib/OSnap_Test/OSnap_Test.ml

@@ -124,7 +124,7 @@ let get_ignore_regions ~document target size_name regions =
     | Error (`OSnap_Selector_Not_Found _s) -> None
     | Error (`OSnap_Selector_Not_Visible _s) -> None
     | Error (`OSnap_CDP_Protocol_Error _ as e) -> Some (Result.error e))
-  |> ResultList.map_p_until_first_error Fun.id
+  |> ResultList.traverse Fun.id
   |> Result.map List.flatten
 ;;
 
@@ -216,15 +216,31 @@ let run ~env (global_config : Config.Types.global) target test =
             let*? () = save_screenshot screenshot ~path:updated_snapshot in
             Result.ok (`Failed `Layout)
           | Error (Pixel (diffCount, diffPercentage)) ->
-            Printer.diff_message
-              ~print_head:true
-              ~name:test.name
-              ~width:test.width
-              ~height:test.height
-              ~diffCount
-              ~diffPercentage;
-            let*? () = save_screenshot screenshot ~path:updated_snapshot in
-            Result.ok (`Failed (`Pixel (diffCount, diffPercentage)))
+            (match test.result with
+             | None ->
+               Printer.retry_message
+                 ~count:1
+                 ~name:test.name
+                 ~width:test.width
+                 ~height:test.height;
+               Result.ok (`Retry 1)
+             | Some (`Retry i) when i < test.retry ->
+               Printer.retry_message
+                 ~count:(succ i)
+                 ~name:test.name
+                 ~width:test.width
+                 ~height:test.height;
+               Result.ok (`Retry (succ i))
+             | _ ->
+               Printer.diff_message
+                 ~print_head:true
+                 ~name:test.name
+                 ~width:test.width
+                 ~height:test.height
+                 ~diffCount
+                 ~diffPercentage;
+               let*? () = save_screenshot screenshot ~path:updated_snapshot in
+               Result.ok (`Failed (`Pixel (diffCount, diffPercentage))))
     in
     { test with result = Some result } |> Result.ok)
 ;;

lib/OSnap_Test/OSnap_Test_Printer.ml

@@ -22,6 +22,14 @@ module Progress = struct
       (Printf.sprintf "%*i / %i " progress.total_length progress.current progress.total)
   ;;
 
+  let none () =
+    Fmt.str_like
+      Fmt.stdout
+      "%a"
+      (styled `Faint string)
+      (Printf.sprintf "%*s / %i " progress.total_length "-" progress.total)
+  ;;
+
   let set_total i =
     Mutex.lock progress_mutex;
     progress.total <- i;
@@ -52,11 +60,22 @@ let skipped_message ~name ~width ~height =
   Fmt.pr
     "%s %a %s @."
     (Progress.get_and_incr ())
-    (styled `Bold (styled `Yellow string))
+    (styled `Bold (styled `Magenta string))
     "SKIP"
     (test_name ~name ~width ~height)
 ;;
 
+let retry_message ~count ~name ~width ~height =
+  Fmt.pr
+    "%s %a %s %a @."
+    (Progress.none ())
+    (styled `Bold (styled `Yellow string))
+    "RETRY"
+    (test_name ~name ~width ~height)
+    (styled `Bold (styled `Yellow string))
+    (Printf.sprintf "(%i)" count)
+;;
+
 let success_message ~name ~width ~height =
   Fmt.pr
     "%s %a  %s @."

lib/OSnap_Test/OSnap_Test_Types.ml

@@ -7,6 +7,7 @@ type t =
   ; actions : OSnap_Config.Types.action list
   ; ignore_regions : OSnap_Config.Types.ignoreType list
   ; threshold : int
+  ; retry : int
   ; exists : bool
   ; skip : bool
   ; warnings : string list
@@ -15,6 +16,7 @@ type t =
       | `Failed of [ `Io | `Layout | `Pixel of int * float ]
       | `Passed
       | `Skipped
+      | `Retry of int
       ]
         option
   }

lib/OSnap_Utils/OSnap_Utils.ml

@@ -87,7 +87,7 @@ module List = struct
 end
 
 module ResultList = struct
-  let map_p_until_first_error (type err) (fn : 'a -> ('b, err) result) list =
+  let traverse (type err) (fn : 'a -> ('b, err) result) list =
     let exception FoundError of err in
     try
       list

website/docs/Setup/configuration.md

@@ -76,6 +76,17 @@ The number of pixels allowed to be different, before the test will be marked as
 
 ---
 
+### Retry
+
+- **Key**: `retry`
+- **Required**: `false`
+- **Type**: `int`
+- **Default**: `1`
+
+The number of times a failed test should be retried before it is reported as failed.
+
+---
+
 ### Parallelism (DEPRECATED)
 
 - **Key**: `parallelism`

website/docs/Tests/configuration.md

@@ -69,6 +69,17 @@ The number of pixels allowed to be different, before the test will be marked as
 
 ---
 
+### Retry
+
+- **Key**: `retry`
+- **Required**: `false`
+- **Type**: `int`
+- **Default**: _Whatever is specified in the [global retry](../Setup/configuration#retry)_
+
+The number of times a failed test should be retried before it is reported as failed.
+
+---
+
 ### Ignore Regions
 
 - **Key**: `ignore`