diff --git a/bin/Main.ml b/bin/Main.ml index 7bad68c..bd671a7 100644 --- a/bin/Main.ml +++ b/bin/Main.ml @@ -1,6 +1,5 @@ open Cmdliner;; -Printexc.record_backtrace true;; Fmt.set_style_renderer Fmt.stdout `Ansi_tty let print_error msg = @@ -11,61 +10,60 @@ let print_error msg = let handle_response response = match response with | Ok () -> 0 - | Error OSnap_Response.Test_Failure -> 1 - | Error (OSnap_Response.Config_Duplicate_Tests tests) -> + | Error `OSnap_Test_Failure -> 1 + | Error (`OSnap_Config_Duplicate_Tests tests) -> print_error "Found some tests with duplicate names. Every test has to have a unique name."; print_error "Please rename the following tests: \n"; tests |> List.iter (print_error "%s"); 1 - | Error OSnap_Response.Config_Global_Not_Found -> + | Error `OSnap_Config_Global_Not_Found -> print_error "Unable to find a global config file."; print_error "Please create a \"osnap.config.json\" at the root of your project or specifiy the \ location using the --config option."; 1 - | Error (OSnap_Response.Config_Global_Invalid s) -> + | Error (`OSnap_Config_Global_Invalid s) -> print_error "Your global config file is invalid."; print_error "%s" s; 1 - | Error (OSnap_Response.Config_Unsupported_Format path) -> + | Error (`OSnap_Config_Unsupported_Format path) -> print_error "Your config file has an unknown format."; - print_error "Tried to parse %S." path; + print_error "Tried to parse %s." path; print_error "Known formats are json and yaml"; 1 - | Error OSnap_Response.CDP_Connection_Failed -> + | Error `OSnap_CDP_Connection_Failed -> print_error "Could not connect to Chrome."; 1 - | Error (OSnap_Response.Config_Parse_Error (msg, path)) -> + | Error (`OSnap_Config_Parse_Error (msg, path)) -> print_error "Your config is in an invalid format"; - (match path with - | Some path -> print_error "Tried to parse %S" path - | None -> ()); + print_error "Tried to parse %s" path; print_error "%s" msg; 1 - | Error (OSnap_Response.Config_Invalid (s, path)) -> + | Error (`OSnap_Config_Invalid (s, path)) -> print_error "Found some tests with an invalid format."; - (match path with - | Some path -> print_error "Tried to parse %S" path - | None -> ()); + print_error "Tried to parse %s" path; print_error "%s" s; 1 - | Error (OSnap_Response.Config_Duplicate_Size_Names sizes) -> + | Error (`OSnap_Config_Undefined_Function s) -> + print_error "Tried to call non existant function %s" s; + 1 + | Error (`OSnap_Config_Duplicate_Size_Names sizes) -> print_error "Found some sizes with duplicate names. Every size has to have a unique name \ inside it's list."; print_error "Please rename the following sizes: \n"; sizes |> List.iter (print_error "%s"); 1 - | Error (OSnap_Response.CDP_Protocol_Error e) -> + | Error (`OSnap_CDP_Protocol_Error e) -> print_error "CDP failed to run some commands. Message was: \n"; print_error "%s" e; 1 - | Error (OSnap_Response.Invalid_Run msg) -> + | Error (`OSnap_Invalid_Run msg) -> print_error "%s" msg; 1 - | Error (OSnap_Response.FS_Error _) -> 1 - | Error (OSnap_Response.Unknown_Error exn) -> + | Error (`OSnap_FS_Error _) -> 1 + | Error (`OSnap_Unknown_Error exn) -> print_error "An unexpected error occured: \n"; print_error "%s" (Printexc.to_string exn); 1 @@ -124,7 +122,7 @@ let default_cmd = (function | exn -> let () = OSnap.teardown t in - Lwt_result.fail (OSnap_Response.Unknown_Error exn)) + Lwt_result.fail (`OSnap_Unknown_Error exn)) in Lwt_main.run run |> handle_response in diff --git a/bin/dune b/bin/dune index 29f6af4..e7e79b8 100644 --- a/bin/dune +++ b/bin/dune @@ -4,4 +4,4 @@ (public_name osnap) (package osnap) (ocamlopt_flags -O3) - (libraries OSnap OSnap_Response cmdliner lwt lwt.unix fmt)) + (libraries OSnap cmdliner lwt lwt.unix fmt)) diff --git a/lib/OSnap.ml b/lib/OSnap.ml index 8ae762b..0cb17b5 100644 --- a/lib/OSnap.ml +++ b/lib/OSnap.ml @@ -1,34 +1,12 @@ module Config = OSnap_Config module Browser = OSnap_Browser module Printer = OSnap_Printer -module Utils = OSnap_Utils +open OSnap_Utils -module Lwt_list = struct - include Lwt_list - - let map_p_until_exception fn list = - let open! Lwt.Syntax in - let rec loop acc list = - match list with - | [] -> Lwt_result.return acc - | list -> - let* resolved, pending = Lwt.nchoose_split list in - let success, error = - resolved - |> List.partition_map (function - | Ok v -> Either.left v - | Error e -> Either.right e) - in - (match error with - | [] -> loop (success @ acc) pending - | hd :: _tl -> - pending |> List.iter Lwt.cancel; - Lwt_result.fail hd) - in - let promises = list |> List.map (Lwt.apply fn) in - loop [] promises - ;; -end +let print_error msg = + let printer = Fmt.pr "%a @." (Fmt.styled `Red Fmt.string) in + Printf.ksprintf printer msg +;; type t = { config : Config.Types.global @@ -38,16 +16,6 @@ type t = ; browser : Browser.t } -let init_folder_structure config = - let dirs = OSnap_Paths.get config in - if not (Sys.file_exists dirs.base) - then FileUtil.mkdir ~parent:true ~mode:(`Octal 0o755) dirs.base; - FileUtil.rm ~recurse:true [ dirs.updated ]; - FileUtil.mkdir ~parent:true ~mode:(`Octal 0o755) dirs.updated; - FileUtil.rm ~recurse:true [ dirs.diff ]; - FileUtil.mkdir ~parent:true ~mode:(`Octal 0o755) dirs.diff -;; - let setup ~noCreate ~noOnly ~noSkip ~parallelism ~config_path = let open Config.Types in let open Lwt_result.Syntax in @@ -58,7 +26,7 @@ let setup ~noCreate ~noOnly ~noSkip ~parallelism ~config_path = | Some parallelism -> { config with parallelism } | None -> config in - let () = init_folder_structure config in + let () = OSnap_Paths.init_folder_structure config in let snapshot_dir = OSnap_Paths.get_base_images_dir config in let* tests = Config.Test.init config |> Lwt_result.lift in let* all_tests = @@ -73,10 +41,10 @@ let setup ~noCreate ~noOnly ~noSkip ~parallelism ~config_path = if noCreate && not exists then Lwt_result.fail - (OSnap_Response.Invalid_Run - (Printf.sprintf - "Flag --no-create is set. Cannot create new images for %s." - test.name)) + (`OSnap_Invalid_Run + (Printf.sprintf + "Flag --no-create is set. Cannot create new images for %s." + test.name)) else Lwt_result.return (test, size, exists))) |> Lwt_result.map List.flatten in @@ -85,15 +53,15 @@ let setup ~noCreate ~noOnly ~noSkip ~parallelism ~config_path = if noOnly && List.length only_tests > 0 then Lwt_result.fail - (OSnap_Response.Invalid_Run - (only_tests - |> List.map (fun ((test : Config.Types.test), _, _) -> test.name) - |> List.sort_uniq String.compare - |> String.concat ",\n" - |> Printf.sprintf - "Flag --no-only is set, but the following tests still have only set to \ - true:\n\ - %s")) + (`OSnap_Invalid_Run + (only_tests + |> List.map (fun ((test : Config.Types.test), _, _) -> test.name) + |> List.sort_uniq String.compare + |> String.concat ",\n" + |> Printf.sprintf + "Flag --no-only is set, but the following tests still have only set to \ + true:\n\ + %s")) else if List.length only_tests > 0 then Lwt_result.return only_tests else Lwt_result.return all_tests @@ -105,15 +73,15 @@ let setup ~noCreate ~noOnly ~noSkip ~parallelism ~config_path = if noSkip && List.length skipped_tests > 0 then Lwt_result.fail - (OSnap_Response.Invalid_Run - (skipped_tests - |> List.map (fun ((test : Config.Types.test), _, _) -> test.name) - |> List.sort_uniq String.compare - |> String.concat ",\n" - |> Printf.sprintf - "Flag --no-skip is set, but the following tests still have \"skip\" set \ - to true:\n\ - %s")) + (`OSnap_Invalid_Run + (skipped_tests + |> List.map (fun ((test : Config.Types.test), _, _) -> test.name) + |> List.sort_uniq String.compare + |> String.concat ",\n" + |> Printf.sprintf + "Flag --no-skip is set, but the following tests still have \"skip\" set \ + to true:\n\ + %s")) else if List.length skipped_tests > 0 then ( skipped_tests @@ -185,14 +153,14 @@ let run t = ~seconds; match failed_tests with | [] -> Lwt_result.return () - | _ -> Lwt_result.fail OSnap_Response.Test_Failure + | _ -> Lwt_result.fail `OSnap_Test_Failure ;; let cleanup ~config_path = let ( let* ) = Result.bind in print_newline (); let* config = Config.Global.init ~config_path in - let () = init_folder_structure config in + let () = OSnap_Paths.init_folder_structure config in let snapshot_dir = OSnap_Paths.get_base_images_dir config in let* tests = Config.Test.init config in let test_file_paths = @@ -204,12 +172,16 @@ let cleanup ~config_path = let filename = OSnap_Test.get_filename test.name width height in let current_image_path = snapshot_dir ^ filename in let exists = Sys.file_exists current_image_path in - if exists then Some current_image_path else None)) + if exists then Some filename else None)) |> List.flatten in let files_to_delete = - FileUtil.ls snapshot_dir - |> List.find_all (fun file -> not (List.mem file test_file_paths)) + Sys.readdir snapshot_dir + |> Array.to_list + |> List.filter_map (fun file -> + if List.mem file test_file_paths + then Some (Filename.concat snapshot_dir file) + else None) in let num_files_to_delete = List.length files_to_delete in let open Fmt in @@ -221,7 +193,7 @@ let cleanup ~config_path = (Printf.sprintf "Deleting %i files...\n" num_files_to_delete); files_to_delete |> List.iter (fun file -> - FileUtil.rm [ file ]; + Sys.remove file; Fmt.pr "%a @." (styled `Faint string) (Printf.sprintf "Deleted %s" file)); Fmt.pr "\n%a @." (styled `Bold (styled `Green string)) "Done!") else diff --git a/lib/OSnap.mli b/lib/OSnap.mli index 6ac662f..bd2ff34 100644 --- a/lib/OSnap.mli +++ b/lib/OSnap.mli @@ -1,6 +1,16 @@ -module Utils = OSnap_Utils +module Config = OSnap_Config +module Browser = OSnap_Browser +module Printer = OSnap_Printer -type t +val print_error : ('a, unit, string, unit) format4 -> 'a + +type t = + { config : Config.Types.global + ; all_tests : (Config.Types.test * Config.Types.size * bool) list + ; tests_to_run : (Config.Types.test * Config.Types.size * bool) list + ; start_time : float + ; browser : Browser.t + } val setup : noCreate:bool @@ -8,9 +18,43 @@ val setup -> noSkip:bool -> parallelism:int option -> config_path:string - -> (t, OSnap_Response.t) Lwt_result.t + -> ( t + , [> `OSnap_CDP_Connection_Failed + | `OSnap_CDP_Protocol_Error of string + | `OSnap_Config_Duplicate_Size_Names of string list + | `OSnap_Config_Duplicate_Tests of string list + | `OSnap_Config_Global_Invalid of string + | `OSnap_Config_Global_Not_Found + | `OSnap_Config_Invalid of string * string + | `OSnap_Config_Parse_Error of string * string + | `OSnap_Config_Unsupported_Format of string + | `OSnap_Invalid_Run of string + ] ) + Lwt_result.t val teardown : t -> unit -val cleanup : config_path:string -> (unit, OSnap_Response.t) Result.t -val run : t -> (unit, OSnap_Response.t) Lwt_result.t + +val run + : t + -> ( unit + , [> `OSnap_CDP_Protocol_Error of string + | `OSnap_Config_Undefined_Function of string + | `OSnap_FS_Error of string + | `OSnap_Test_Failure + ] ) + Lwt_result.t + +val cleanup + : config_path:string + -> ( unit + , [> `OSnap_Config_Duplicate_Size_Names of string list + | `OSnap_Config_Duplicate_Tests of string list + | `OSnap_Config_Global_Invalid of string + | `OSnap_Config_Global_Not_Found + | `OSnap_Config_Invalid of string * string + | `OSnap_Config_Parse_Error of string * string + | `OSnap_Config_Unsupported_Format of string + ] ) + result + val download_chromium : unit -> (unit, unit) Lwt_result.t diff --git a/lib/OSnap_Browser/OSnap_Browser.mli b/lib/OSnap_Browser/OSnap_Browser.mli index 2d6cff9..66bc553 100644 --- a/lib/OSnap_Browser/OSnap_Browser.mli +++ b/lib/OSnap_Browser/OSnap_Browser.mli @@ -1,95 +1,6 @@ -type t +module Actions = OSnap_Browser_Actions +module Launcher = OSnap_Browser_Launcher +module Target = OSnap_Browser_Target +module Download = OSnap_Browser_Download -module Launcher : sig - val make : unit -> (t, OSnap_Response.t) Lwt_result.t - val shutdown : t -> unit -end - -module Target : sig - type target = - { targetId : Cdp.Types.Target.TargetID.t - ; sessionId : Cdp.Types.Target.SessionID.t - } - - val make : t -> (target, OSnap_Response.t) Lwt_result.t -end - -module Actions : sig - val get_document - : Target.target - -> (Cdp.Commands.DOM.GetDocument.Response.result, OSnap_Response.t) Lwt_result.t - - val get_quads - : document:Cdp.Commands.DOM.GetDocument.Response.result - -> selector:string - -> Target.target - -> ((float * float) * (float * float), OSnap_Response.t) Lwt_result.t - - val get_quads_all - : document:Cdp.Commands.DOM.GetDocument.Response.result - -> selector:string - -> Target.target - -> (((float * float) * (float * float)) list, OSnap_Response.t) Lwt_result.t - - val scroll - : document:Cdp.Commands.DOM.GetDocument.Response.result - -> selector:string option - -> px:int option - -> Target.target - -> (unit, OSnap_Response.t) Lwt_result.t - - val mousemove - : document:Cdp.Commands.DOM.GetDocument.Response.result - -> to_:[ `Selector of string | `Coordinates of Cdp.Types.number * Cdp.Types.number ] - -> Target.target - -> (unit, OSnap_Response.t) Lwt_result.t - - val click - : document:Cdp.Commands.DOM.GetDocument.Response.result - -> selector:string - -> Target.target - -> (unit, OSnap_Response.t) Lwt_result.t - - val type_text - : document:Cdp.Commands.DOM.GetDocument.Response.result - -> selector:string - -> text:string - -> Target.target - -> (unit, OSnap_Response.t) Lwt_result.t - - val wait_for - : ?timeout:float - -> ?look_behind:bool - -> event:string - -> Target.target - -> [> `Data of string | `Timeout ] Lwt.t - - val wait_for_network_idle - : Target.target - -> loaderId:Cdp.Types.Network.LoaderId.t - -> unit Lwt.t - - val go_to : url:string -> Target.target -> (string, OSnap_Response.t) Lwt_result.t - - val get_content_size - : Target.target - -> (Cdp.Types.number * Cdp.Types.number, OSnap_Response.t) Lwt_result.t - - val set_size - : width:Cdp.Types.number - -> height:Cdp.Types.number - -> Target.target - -> (unit, OSnap_Response.t) Lwt_result.t - - val screenshot - : ?full_size:bool - -> Target.target - -> (string, OSnap_Response.t) Lwt_result.t - - val clear_cookies : Target.target -> (unit, OSnap_Response.t) Lwt_result.t -end - -module Download : sig - val get_uri : string -> OSnap_Utils.platform -> Uri.t - val download : unit -> (unit, unit) Lwt_result.t -end +type t = OSnap_Browser_Types.t diff --git a/lib/OSnap_Browser/OSnap_Browser_Actions.ml b/lib/OSnap_Browser/OSnap_Browser_Actions.ml index 51b3324..f4c0739 100644 --- a/lib/OSnap_Browser/OSnap_Browser_Actions.ml +++ b/lib/OSnap_Browser/OSnap_Browser_Actions.ml @@ -29,8 +29,8 @@ let get_document target = let error = response.Response.error |> Option.map (fun (error : Response.error) -> - OSnap_Response.CDP_Protocol_Error error.message) - |> Option.value ~default:(OSnap_Response.CDP_Protocol_Error "") + `OSnap_CDP_Protocol_Error error.message) + |> Option.value ~default:(`OSnap_CDP_Protocol_Error "") in Option.to_result response.Response.result ~none:error) ;; @@ -50,11 +50,10 @@ let select_element_all ~document ~selector ~sessionId = match response.Response.error, response.Response.result with | _, Some { nodeIds = [] } -> Result.error - (OSnap_Response.CDP_Protocol_Error - (Printf.sprintf "No node with the selector %S could not be found." selector)) - | None, None -> Result.error (OSnap_Response.CDP_Protocol_Error "") - | Some { message; _ }, None -> - Result.error (OSnap_Response.CDP_Protocol_Error message) + (`OSnap_CDP_Protocol_Error + (Printf.sprintf "No node with the selector %S could not be found." selector)) + | None, None -> Result.error (`OSnap_CDP_Protocol_Error "") + | Some { message; _ }, None -> Result.error (`OSnap_CDP_Protocol_Error message) | Some _, Some result | None, Some result -> Result.ok result) ;; @@ -73,11 +72,10 @@ let select_element ~document ~selector ~sessionId = match response.Response.error, response.Response.result with | _, (Some { nodeId = `Int 0 } | Some { nodeId = `Float 0. }) -> Result.error - (OSnap_Response.CDP_Protocol_Error - (Printf.sprintf "A node with the selector %S could not be found." selector)) - | None, None -> Result.error (OSnap_Response.CDP_Protocol_Error "") - | Some { message; _ }, None -> - Result.error (OSnap_Response.CDP_Protocol_Error message) + (`OSnap_CDP_Protocol_Error + (Printf.sprintf "A node with the selector %S could not be found." selector)) + | None, None -> Result.error (`OSnap_CDP_Protocol_Error "") + | Some { message; _ }, None -> Result.error (`OSnap_CDP_Protocol_Error message) | Some _, Some result | None, Some result -> Result.ok result) ;; @@ -107,15 +105,15 @@ let go_to ~url target = let error = response.Response.error |> Option.map (fun (error : Response.error) -> - OSnap_Response.CDP_Protocol_Error error.message) - |> Option.value ~default:(OSnap_Response.CDP_Protocol_Error "") + `OSnap_CDP_Protocol_Error error.message) + |> Option.value ~default:(`OSnap_CDP_Protocol_Error "") in Option.to_result response.Response.result ~none:error) in match result.errorText, result.loaderId with - | Some error, _ -> OSnap_Response.CDP_Protocol_Error error |> Lwt_result.fail + | Some error, _ -> `OSnap_CDP_Protocol_Error error |> Lwt_result.fail | None, None -> - Lwt_result.fail (OSnap_Response.CDP_Protocol_Error "CDP responded with no loader id") + Lwt_result.fail (`OSnap_CDP_Protocol_Error "CDP responded with no loader id") | None, Some loaderId -> loaderId |> Lwt_result.return ;; @@ -132,8 +130,8 @@ let type_text ~document ~selector ~text target = let error = response.Response.error |> Option.map (fun (error : Response.error) -> - OSnap_Response.CDP_Protocol_Error error.message) - |> Option.value ~default:(OSnap_Response.CDP_Protocol_Error "") + `OSnap_CDP_Protocol_Error error.message) + |> Option.value ~default:(`OSnap_CDP_Protocol_Error "") in Option.to_result response.Response.result ~none:error) |> Lwt_result.map ignore @@ -232,8 +230,8 @@ let get_quads ~document ~selector target = let error = response.Response.error |> Option.map (fun (error : Response.error) -> - OSnap_Response.CDP_Protocol_Error error.message) - |> Option.value ~default:(OSnap_Response.CDP_Protocol_Error "") + `OSnap_CDP_Protocol_Error error.message) + |> Option.value ~default:(`OSnap_CDP_Protocol_Error "") in Option.to_result response.Response.result ~none:error) in @@ -244,7 +242,7 @@ let get_quads ~document ~selector target = match result.quads with | (x1 :: y1 :: x2 :: _y2 :: _x3 :: y2 :: _x4 :: _y4 :: _) :: _ -> Lwt_result.return ((to_float x1, to_float y1), (to_float x2, to_float y2)) - | _ -> Lwt_result.fail (OSnap_Response.CDP_Protocol_Error "no content quads returned") + | _ -> Lwt_result.fail (`OSnap_CDP_Protocol_Error "no content quads returned") ;; let mousemove ~document ~to_ target = @@ -333,7 +331,7 @@ let scroll ~document ~selector ~px target = |> Lwt.map (fun response -> match response.Response.error with | None -> Result.ok () - | Some { message; _ } -> Result.error (OSnap_Response.CDP_Protocol_Error message)) + | Some { message; _ } -> Result.error (`OSnap_CDP_Protocol_Error message)) | Some px, None -> let expression = Printf.sprintf @@ -356,7 +354,7 @@ let scroll ~document ~selector ~px target = | None -> let timeout = float_of_int (px / 200) in Lwt_unix.sleep timeout |> Lwt_result.ok - | Some { message; _ } -> Lwt_result.fail (OSnap_Response.CDP_Protocol_Error message)) + | Some { message; _ } -> Lwt_result.fail (`OSnap_CDP_Protocol_Error message)) ;; let get_content_size target = @@ -371,8 +369,8 @@ let get_content_size target = let error = response.Response.error |> Option.map (fun (error : Response.error) -> - OSnap_Response.CDP_Protocol_Error error.message) - |> Option.value ~default:(OSnap_Response.CDP_Protocol_Error "") + `OSnap_CDP_Protocol_Error error.message) + |> Option.value ~default:(`OSnap_CDP_Protocol_Error "") in Option.to_result response.Response.result ~none:error) in @@ -393,8 +391,8 @@ let set_size ~width ~height target = let error = response.Response.error |> Option.map (fun (error : Response.error) -> - OSnap_Response.CDP_Protocol_Error error.message) - |> Option.value ~default:(OSnap_Response.CDP_Protocol_Error "") + `OSnap_CDP_Protocol_Error error.message) + |> Option.value ~default:(`OSnap_CDP_Protocol_Error "") in Option.to_result response.Response.result ~none:error) in @@ -422,8 +420,8 @@ let screenshot ?(full_size = false) target = let error = response.Response.error |> Option.map (fun (error : Response.error) -> - OSnap_Response.CDP_Protocol_Error error.message) - |> Option.value ~default:(OSnap_Response.CDP_Protocol_Error "") + `OSnap_CDP_Protocol_Error error.message) + |> Option.value ~default:(`OSnap_CDP_Protocol_Error "") in Option.to_result response.Response.result ~none:error) in @@ -442,8 +440,8 @@ let clear_cookies target = let error = response.Response.error |> Option.map (fun (error : Response.error) -> - OSnap_Response.CDP_Protocol_Error error.message) - |> Option.value ~default:(OSnap_Response.CDP_Protocol_Error "") + `OSnap_CDP_Protocol_Error error.message) + |> Option.value ~default:(`OSnap_CDP_Protocol_Error "") in Option.to_result response.Response.result ~none:error) in diff --git a/lib/OSnap_Browser/OSnap_Browser_Actions.mli b/lib/OSnap_Browser/OSnap_Browser_Actions.mli new file mode 100644 index 0000000..13ff6d7 --- /dev/null +++ b/lib/OSnap_Browser/OSnap_Browser_Actions.mli @@ -0,0 +1,70 @@ +val get_document + : OSnap_Browser_Target.target + -> ( Cdp.Commands.DOM.GetDocument.Response.result + , [> `OSnap_CDP_Protocol_Error of string ] ) + result + Lwt.t + +val wait_for_network_idle : OSnap_Browser_Target.target -> loaderId:string -> unit Lwt.t + +val go_to + : url:string + -> OSnap_Browser_Target.target + -> (string, [> `OSnap_CDP_Protocol_Error of string ]) Lwt_result.t + +val type_text + : document:Cdp.Commands.DOM.GetDocument.Response.result + -> selector:string + -> text:string + -> OSnap_Browser_Target.target + -> (unit, [> `OSnap_CDP_Protocol_Error of string ]) Lwt_result.t + +val get_quads_all + : document:Cdp.Commands.DOM.GetDocument.Response.result + -> selector:string + -> OSnap_Browser_Target.target + -> ( ((float * float) * (float * float)) list + , [> `OSnap_CDP_Protocol_Error of string ] ) + Lwt_result.t + +val get_quads + : document:Cdp.Commands.DOM.GetDocument.Response.result + -> selector:string + -> OSnap_Browser_Target.target + -> ( (float * float) * (float * float) + , [> `OSnap_CDP_Protocol_Error of string ] ) + Lwt_result.t + +val mousemove + : document:Cdp.Commands.DOM.GetDocument.Response.result + -> to_:[< `Coordinates of Cdp.Types.number * Cdp.Types.number | `Selector of string ] + -> OSnap_Browser_Target.target + -> (unit, [> `OSnap_CDP_Protocol_Error of string ]) Lwt_result.t + +val click + : document:Cdp.Commands.DOM.GetDocument.Response.result + -> selector:string + -> OSnap_Browser_Target.target + -> (unit, [> `OSnap_CDP_Protocol_Error of string ]) Lwt_result.t + +val scroll + : document:Cdp.Commands.DOM.GetDocument.Response.result + -> selector:string option + -> px:int option + -> OSnap_Browser_Target.target + -> (unit, [> `OSnap_CDP_Protocol_Error of string ]) Lwt_result.t + +val set_size + : width:Cdp.Types.number + -> height:Cdp.Types.number + -> OSnap_Browser_Target.target + -> (unit, [> `OSnap_CDP_Protocol_Error of string ]) Lwt_result.t + +val screenshot + : ?full_size:bool + -> OSnap_Browser_Target.target + -> (string, [> `OSnap_CDP_Protocol_Error of string ]) Lwt_result.t + +val clear_cookies + : OSnap_Browser_Target.target + -> (unit, [> `OSnap_CDP_Protocol_Error of string ]) Lwt_result.t diff --git a/lib/OSnap_Browser/OSnap_Browser_Download.mli b/lib/OSnap_Browser/OSnap_Browser_Download.mli new file mode 100644 index 0000000..feef35d --- /dev/null +++ b/lib/OSnap_Browser/OSnap_Browser_Download.mli @@ -0,0 +1 @@ +val download : unit -> (unit, unit) Lwt_result.t diff --git a/lib/OSnap_Browser/OSnap_Browser_Launcher.ml b/lib/OSnap_Browser/OSnap_Browser_Launcher.ml index bd57790..6de5ada 100644 --- a/lib/OSnap_Browser/OSnap_Browser_Launcher.ml +++ b/lib/OSnap_Browser/OSnap_Browser_Launcher.ml @@ -58,7 +58,7 @@ let make () = when line |> OSnap_Utils.contains_substring ~search:"Cannot start http server" -> proc#terminate; - Lwt_result.fail OSnap_Response.CDP_Connection_Failed + Lwt_result.fail `OSnap_CDP_Connection_Failed | line when line |> OSnap_Utils.contains_substring ~search:"DevTools listening on" -> let offset = String.length "DevTools listening on " in @@ -66,7 +66,7 @@ let make () = let socket = String.sub line offset (len - offset) in socket |> Lwt_result.return | _ -> get_ws_url proc) - | Lwt_process.Exited _ -> Lwt_result.fail OSnap_Response.CDP_Connection_Failed + | Lwt_process.Exited _ -> Lwt_result.fail `OSnap_CDP_Connection_Failed in let* url = get_ws_url process in let _ = Websocket.connect url in @@ -79,8 +79,8 @@ let make () = let error = response.Response.error |> Option.map (fun (error : Response.error) -> - OSnap_Response.CDP_Protocol_Error error.message) - |> Option.value ~default:OSnap_Response.CDP_Connection_Failed + `OSnap_CDP_Protocol_Error error.message) + |> Option.value ~default:`OSnap_CDP_Connection_Failed in Option.to_result response.Response.result ~none:error) in diff --git a/lib/OSnap_Browser/OSnap_Browser_Launcher.mli b/lib/OSnap_Browser/OSnap_Browser_Launcher.mli new file mode 100644 index 0000000..8d5c793 --- /dev/null +++ b/lib/OSnap_Browser/OSnap_Browser_Launcher.mli @@ -0,0 +1,7 @@ +val make + : unit + -> ( OSnap_Browser_Types.t + , [> `OSnap_CDP_Connection_Failed | `OSnap_CDP_Protocol_Error of string ] ) + Lwt_result.t + +val shutdown : OSnap_Browser_Types.t -> unit diff --git a/lib/OSnap_Browser/OSnap_Browser_Target.ml b/lib/OSnap_Browser/OSnap_Browser_Target.ml index e5dccf3..a9bd2da 100644 --- a/lib/OSnap_Browser/OSnap_Browser_Target.ml +++ b/lib/OSnap_Browser/OSnap_Browser_Target.ml @@ -19,8 +19,8 @@ let enable_events t = let error = response.Response.error |> Option.map (fun (error : Response.error) -> - OSnap_Response.CDP_Protocol_Error error.message) - |> Option.value ~default:(OSnap_Response.CDP_Protocol_Error "") + `OSnap_CDP_Protocol_Error error.message) + |> Option.value ~default:(`OSnap_CDP_Protocol_Error "") in Option.to_result response.Response.result ~none:error) in @@ -33,8 +33,8 @@ let enable_events t = let error = response.Response.error |> Option.map (fun (error : Response.error) -> - OSnap_Response.CDP_Protocol_Error error.message) - |> Option.value ~default:(OSnap_Response.CDP_Protocol_Error "") + `OSnap_CDP_Protocol_Error error.message) + |> Option.value ~default:(`OSnap_CDP_Protocol_Error "") in Option.to_result response.Response.result ~none:error) in @@ -47,8 +47,8 @@ let enable_events t = let error = response.Response.error |> Option.map (fun (error : Response.error) -> - OSnap_Response.CDP_Protocol_Error error.message) - |> Option.value ~default:(OSnap_Response.CDP_Protocol_Error "") + `OSnap_CDP_Protocol_Error error.message) + |> Option.value ~default:(`OSnap_CDP_Protocol_Error "") in Option.to_result response.Response.result ~none:error) in @@ -73,8 +73,8 @@ let make browser = let error = response.Response.error |> Option.map (fun (error : Response.error) -> - OSnap_Response.CDP_Protocol_Error error.message) - |> Option.value ~default:(OSnap_Response.CDP_Protocol_Error "") + `OSnap_CDP_Protocol_Error error.message) + |> Option.value ~default:(`OSnap_CDP_Protocol_Error "") in Option.to_result response.Response.result ~none:error) in @@ -87,8 +87,8 @@ let make browser = let error = response.Response.error |> Option.map (fun (error : Response.error) -> - OSnap_Response.CDP_Protocol_Error error.message) - |> Option.value ~default:(OSnap_Response.CDP_Protocol_Error "") + `OSnap_CDP_Protocol_Error error.message) + |> Option.value ~default:(`OSnap_CDP_Protocol_Error "") in Option.to_result response.Response.result ~none:error) in diff --git a/lib/OSnap_Browser/OSnap_Browser_Target.mli b/lib/OSnap_Browser/OSnap_Browser_Target.mli new file mode 100644 index 0000000..53c6070 --- /dev/null +++ b/lib/OSnap_Browser/OSnap_Browser_Target.mli @@ -0,0 +1,8 @@ +type target = + { targetId : Cdp.Types.Target.TargetID.t + ; sessionId : Cdp.Types.Target.SessionID.t + } + +val make + : OSnap_Browser_Types.t + -> (target, [> `OSnap_CDP_Protocol_Error of string ]) Lwt_result.t diff --git a/lib/OSnap_Browser/dune b/lib/OSnap_Browser/dune index 2fa7d96..6407b55 100644 --- a/lib/OSnap_Browser/dune +++ b/lib/OSnap_Browser/dune @@ -1,7 +1,6 @@ (library (name OSnap_Browser) (libraries - OSnap_Response OSnap_Utils OSnap_Websocket bigstringaf diff --git a/lib/OSnap_Config/OSnap_Config_Global.ml b/lib/OSnap_Config/OSnap_Config_Global.ml index a3b6bab..dcf96fe 100644 --- a/lib/OSnap_Config/OSnap_Config_Global.ml +++ b/lib/OSnap_Config/OSnap_Config_Global.ml @@ -9,30 +9,30 @@ module YAML = struct config |> Yaml.of_string |> Result.map_error (fun _ -> - OSnap_Response.Config_Parse_Error - (Printf.sprintf "YAML could not be parsed", Some path)) + `OSnap_Config_Parse_Error ("YAML could not be parsed", path)) in - let* base_url = yaml |> OSnap_Config_Utils.YAML.get_string "baseUrl" in + let* base_url = yaml |> OSnap_Config_Utils.YAML.get_string ~path "baseUrl" in let* fullscreen = yaml - |> OSnap_Config_Utils.YAML.get_bool_option "fullScreen" + |> OSnap_Config_Utils.YAML.get_bool_option ~path "fullScreen" |> Result.map (Option.value ~default:false) in let* threshold = yaml - |> OSnap_Config_Utils.YAML.get_int_option "threshold" + |> OSnap_Config_Utils.YAML.get_int_option ~path "threshold" |> Result.map (Option.value ~default:0) in let* ignore_patterns = yaml - |> OSnap_Config_Utils.YAML.get_string_list_option "ignorePatterns" + |> OSnap_Config_Utils.YAML.get_string_list_option ~path "ignorePatterns" |> Result.map (Option.value ~default:[ "**/node_modules/**" ]) in let* default_sizes = yaml |> OSnap_Config_Utils.YAML.get_list_option + ~path "defaultSizes" - ~parser:OSnap_Config_Utils.YAML.parse_size + ~parser:(OSnap_Config_Utils.YAML.parse_size ~path) |> Result.map (Option.value ~default:[]) in let* functions = @@ -45,8 +45,9 @@ module YAML = struct let* actions = f |> OSnap_Config_Utils.YAML.get_list_option + ~path key - ~parser:OSnap_Config_Utils.YAML.parse_action + ~parser:(OSnap_Config_Utils.YAML.parse_action ~path) |> Result.map (Option.value ~default:[]) in (key, actions) |> Result.ok)) @@ -54,26 +55,26 @@ module YAML = struct in let* snapshot_directory = yaml - |> OSnap_Config_Utils.YAML.get_string_option "snapshotDirectory" + |> OSnap_Config_Utils.YAML.get_string_option ~path "snapshotDirectory" |> Result.map (Option.value ~default:"__snapshots__") in let* parallelism = yaml - |> OSnap_Config_Utils.YAML.get_int_option "parallelism" + |> OSnap_Config_Utils.YAML.get_int_option ~path "parallelism" |> Result.map (Option.value ~default:8) |> Result.map (max 1) in let root_path = Filename.dirname path in let* test_pattern = yaml - |> OSnap_Config_Utils.YAML.get_string_option "testPattern" + |> OSnap_Config_Utils.YAML.get_string_option ~path "testPattern" |> Result.map (Option.value ~default:"**/*.osnap.yaml") in let* diff_pixel_color = yaml |> Yaml.Util.find "diffPixelColor" |> Result.map_error (function `Msg message -> - OSnap_Response.Config_Parse_Error (message, Some path)) + `OSnap_Config_Parse_Error (message, path)) |> Result.map (Option.map (fun colors -> let get_color = function @@ -81,14 +82,14 @@ module YAML = struct | `String s -> Result.ok (int_of_string s) | _ -> Result.error - (OSnap_Response.Config_Parse_Error - ("diffPixelColor does not have a correct format", Some path)) + (`OSnap_Config_Parse_Error + ("diffPixelColor does not have a correct format", path)) in let* r = colors |> Yaml.Util.find "r" |> Result.map_error (function `Msg message -> - OSnap_Response.Config_Parse_Error (message, Some path)) + `OSnap_Config_Parse_Error (message, path)) |> Result.map (Option.map get_color) |> Result.map OSnap_Config_Utils.to_result_option |> Result.join @@ -98,7 +99,7 @@ module YAML = struct colors |> Yaml.Util.find "g" |> Result.map_error (function `Msg message -> - OSnap_Response.Config_Parse_Error (message, Some path)) + `OSnap_Config_Parse_Error (message, path)) |> Result.map (Option.map get_color) |> Result.map OSnap_Config_Utils.to_result_option |> Result.join @@ -108,7 +109,7 @@ module YAML = struct colors |> Yaml.Util.find "b" |> Result.map_error (function `Msg message -> - OSnap_Response.Config_Parse_Error (message, Some path)) + `OSnap_Config_Parse_Error (message, path)) |> Result.map (Option.map get_color) |> Result.map OSnap_Config_Utils.to_result_option |> Result.join @@ -128,7 +129,7 @@ module YAML = struct name) in if List.length duplicates <> 0 - then Result.error (OSnap_Response.Config_Duplicate_Size_Names duplicates) + then Result.error (`OSnap_Config_Duplicate_Size_Names duplicates) else Result.ok { root_path @@ -160,7 +161,7 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, Some path)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* fullscreen = try @@ -171,7 +172,7 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, Some path)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* threshold = try @@ -182,17 +183,17 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, Some path)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* default_sizes = try json |> Yojson.Basic.Util.member "defaultSizes" |> Yojson.Basic.Util.to_list - |> OSnap_Utils.List.map_until_exception OSnap_Config_Utils.JSON.parse_size + |> OSnap_Utils.List.map_until_exception (OSnap_Config_Utils.JSON.parse_size ~path) with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, Some path)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* functions = json @@ -207,16 +208,15 @@ module JSON = struct actions |> Yojson.Basic.Util.to_list |> OSnap_Utils.List.map_until_exception - OSnap_Config_Utils.JSON.parse_action + (OSnap_Config_Utils.JSON.parse_action ~path) with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, Some path)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in Result.ok (key, actions)) | _ -> Result.error - (OSnap_Response.Config_Parse_Error - ("The functions option has to be an object.", Some path)) + (`OSnap_Config_Parse_Error ("The functions option has to be an object.", path)) in let* snapshot_directory = try @@ -227,7 +227,7 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, Some path)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* parallelism = try @@ -239,7 +239,7 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, Some path)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let root_path = Filename.dirname path in let* ignore_patterns = @@ -252,11 +252,11 @@ module JSON = struct |> OSnap_Utils.List.map_until_exception (fun item -> try Yojson.Basic.Util.to_string item |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, Some path))) + Result.error (`OSnap_Config_Parse_Error (message, path))) | _ -> Result.ok [ "**/node_modules/**" ] with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, Some path)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* test_pattern = try @@ -267,7 +267,7 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, Some path)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* diff_pixel_color = json @@ -279,8 +279,8 @@ module JSON = struct | `Float f -> Result.ok (int_of_float f) | _ -> Result.error - (OSnap_Response.Config_Parse_Error - ("diffPixelColor does not have a correct format", Some path)) + (`OSnap_Config_Parse_Error + ("diffPixelColor does not have a correct format", path)) in let* r = assoc |> Yojson.Basic.Util.member "r" |> get_color in let* g = assoc |> Yojson.Basic.Util.member "g" |> get_color in @@ -289,8 +289,8 @@ module JSON = struct | `Null -> Result.ok (255, 0, 0) | _ -> Result.error - (OSnap_Response.Config_Parse_Error - ("diffPixelColor does not have a correct format", Some path)) + (`OSnap_Config_Parse_Error + ("diffPixelColor does not have a correct format", path)) in let duplicates = default_sizes @@ -301,7 +301,7 @@ module JSON = struct name) in if List.length duplicates <> 0 - then Result.error (OSnap_Response.Config_Duplicate_Size_Names duplicates) + then Result.error (`OSnap_Config_Duplicate_Size_Names duplicates) else Result.ok { root_path @@ -359,7 +359,7 @@ let init ~config_path = then ( match find [ "osnap.config.json"; "osnap.config.yaml" ] with | Some path -> Result.ok path - | None -> Result.error OSnap_Response.Config_Global_Not_Found) + | None -> Result.error `OSnap_Config_Global_Not_Found) else Result.ok config_path in let* format = OSnap_Config_Utils.get_format config in diff --git a/lib/OSnap_Config/OSnap_Config_Global.mli b/lib/OSnap_Config/OSnap_Config_Global.mli index a5be930..0ccd366 100644 --- a/lib/OSnap_Config/OSnap_Config_Global.mli +++ b/lib/OSnap_Config/OSnap_Config_Global.mli @@ -1 +1,10 @@ -val init : config_path:string -> (OSnap_Config_Types.global, OSnap_Response.t) result +val init + : config_path:string + -> ( OSnap_Config_Types.global + , [> `OSnap_Config_Duplicate_Size_Names of string list + | `OSnap_Config_Global_Not_Found + | `OSnap_Config_Invalid of string * string + | `OSnap_Config_Parse_Error of string * string + | `OSnap_Config_Unsupported_Format of string + ] ) + result diff --git a/lib/OSnap_Config/OSnap_Config_Test.ml b/lib/OSnap_Config/OSnap_Config_Test.ml index f2f9804..3e6b729 100644 --- a/lib/OSnap_Config/OSnap_Config_Test.ml +++ b/lib/OSnap_Config/OSnap_Config_Test.ml @@ -11,11 +11,11 @@ module Common = struct |> List.map (fun (s : OSnap_Config_Types.size) -> Option.value s.name ~default:"") in if List.length duplicates <> 0 - then Result.error (OSnap_Response.Config_Duplicate_Size_Names duplicates) + then Result.error (`OSnap_Config_Duplicate_Size_Names duplicates) else Result.ok () ;; - let collect_ignore ~size_restriction ~selector ~selector_all ~x1 ~y1 ~x2 ~y2 = + let collect_ignore ~path ~size_restriction ~selector ~selector_all ~x1 ~y1 ~x2 ~y2 = match selector_all, selector, x1, y1, x2, y2 with | Some selector_all, None, None, None, None, None -> SelectorAll (selector_all, size_restriction) |> Result.ok @@ -25,13 +25,13 @@ module Common = struct Coordinates ((x1, y1), (x2, y2), size_restriction) |> Result.ok | _ -> Result.error - (OSnap_Response.Config_Invalid - ("Did not find a complete configuration for an ignore region.", None)) + (`OSnap_Config_Invalid + ("Did not find a complete configuration for an ignore region.", path)) ;; end module JSON = struct - let parse_ignore r = + let parse_ignore ~path r = let* size_restriction = try r @@ -41,35 +41,35 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* x1 = try r |> Yojson.Basic.Util.member "x1" |> Yojson.Basic.Util.to_int_option |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* y1 = try r |> Yojson.Basic.Util.member "y1" |> Yojson.Basic.Util.to_int_option |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* x2 = try r |> Yojson.Basic.Util.member "x2" |> Yojson.Basic.Util.to_int_option |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* y2 = try r |> Yojson.Basic.Util.member "y2" |> Yojson.Basic.Util.to_int_option |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* selector = try @@ -79,7 +79,7 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* selector_all = try @@ -89,12 +89,12 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in - Common.collect_ignore ~size_restriction ~selector ~selector_all ~x1 ~y1 ~x2 ~y2 + Common.collect_ignore ~path ~size_restriction ~selector ~selector_all ~x1 ~y1 ~x2 ~y2 ;; - let parse_single_test (global_config : OSnap_Config_Types.global) test = + let parse_single_test ~path (global_config : OSnap_Config_Types.global) test = let* name = try test @@ -103,7 +103,7 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* only = try @@ -114,7 +114,7 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* skip = try @@ -125,7 +125,7 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* threshold = try @@ -136,14 +136,14 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + 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 with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* sizes = test @@ -151,24 +151,25 @@ module JSON = struct |> function | `Null -> Result.ok global_config.default_sizes | `List list -> - list |> OSnap_Utils.List.map_until_exception OSnap_Config_Utils.JSON.parse_size - | _ -> - Result.error - (OSnap_Response.Config_Invalid ("sizes has an invalid format.", None)) + list + |> OSnap_Utils.List.map_until_exception (OSnap_Config_Utils.JSON.parse_size ~path) + | _ -> Result.error (`OSnap_Config_Invalid ("sizes has an invalid format.", path)) in let* actions = test |> Yojson.Basic.Util.member "actions" |> function | `List list -> - OSnap_Utils.List.map_until_exception OSnap_Config_Utils.JSON.parse_action list + OSnap_Utils.List.map_until_exception + (OSnap_Config_Utils.JSON.parse_action ~path) + list | _ -> Result.ok [] in let* ignore = test |> Yojson.Basic.Util.member "ignore" |> function - | `List list -> OSnap_Utils.List.map_until_exception parse_ignore list + | `List list -> OSnap_Utils.List.map_until_exception (parse_ignore ~path) list | _ -> Result.ok [] in let* () = Common.collect_duplicates sizes in @@ -181,60 +182,69 @@ module JSON = struct try json |> Yojson.Basic.Util.to_list - |> OSnap_Utils.List.map_until_exception (parse_single_test global_config) + |> OSnap_Utils.List.map_until_exception (parse_single_test ~path global_config) with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) ;; end module YAML = struct - let parse_ignore r = - let* size_restriction = r |> OSnap_Config_Utils.YAML.get_string_list_option "@" in - let* x1 = r |> OSnap_Config_Utils.YAML.get_int_option "x1" in - let* y1 = r |> OSnap_Config_Utils.YAML.get_int_option "y1" in - let* x2 = r |> OSnap_Config_Utils.YAML.get_int_option "x2" in - let* y2 = r |> OSnap_Config_Utils.YAML.get_int_option "y2" in - let* selector = r |> OSnap_Config_Utils.YAML.get_string_option "selector" in - let* selector_all = r |> OSnap_Config_Utils.YAML.get_string_option "selectorAll" in - Common.collect_ignore ~size_restriction ~selector ~selector_all ~x1 ~y1 ~x2 ~y2 + let parse_ignore ~path r = + let* size_restriction = + r |> OSnap_Config_Utils.YAML.get_string_list_option ~path "@" + in + let* x1 = r |> OSnap_Config_Utils.YAML.get_int_option ~path "x1" in + let* y1 = r |> OSnap_Config_Utils.YAML.get_int_option ~path "y1" in + let* x2 = r |> OSnap_Config_Utils.YAML.get_int_option ~path "x2" in + let* y2 = r |> OSnap_Config_Utils.YAML.get_int_option ~path "y2" in + let* selector = r |> OSnap_Config_Utils.YAML.get_string_option ~path "selector" in + let* selector_all = + r |> OSnap_Config_Utils.YAML.get_string_option ~path "selectorAll" + in + Common.collect_ignore ~path ~size_restriction ~selector ~selector_all ~x1 ~y1 ~x2 ~y2 ;; - let parse_single_test (global_config : OSnap_Config_Types.global) test = - let* name = test |> OSnap_Config_Utils.YAML.get_string "name" in - let* url = test |> OSnap_Config_Utils.YAML.get_string "url" in + let parse_single_test ~path (global_config : OSnap_Config_Types.global) test = + let* name = test |> OSnap_Config_Utils.YAML.get_string ~path "name" in + let* url = test |> OSnap_Config_Utils.YAML.get_string ~path "url" in let* only = test - |> OSnap_Config_Utils.YAML.get_bool_option "only" + |> OSnap_Config_Utils.YAML.get_bool_option ~path "only" |> Result.map (Option.value ~default:false) in let* skip = test - |> OSnap_Config_Utils.YAML.get_bool_option "skip" + |> OSnap_Config_Utils.YAML.get_bool_option ~path "skip" |> Result.map (Option.value ~default:false) in let* threshold = test - |> OSnap_Config_Utils.YAML.get_int_option "threshold" + |> OSnap_Config_Utils.YAML.get_int_option ~path "threshold" |> Result.map (Option.value ~default:global_config.threshold) in let* sizes = test |> OSnap_Config_Utils.YAML.get_list_option + ~path "sizes" - ~parser:OSnap_Config_Utils.YAML.parse_size + ~parser:(OSnap_Config_Utils.YAML.parse_size ~path) |> Result.map (Option.value ~default:global_config.default_sizes) in let* actions = test |> OSnap_Config_Utils.YAML.get_list_option + ~path "actions" - ~parser:OSnap_Config_Utils.YAML.parse_action + ~parser:(OSnap_Config_Utils.YAML.parse_action ~path) |> Result.map (Option.value ~default:[]) in let* ignore = test - |> OSnap_Config_Utils.YAML.get_list_option "ignore" ~parser:parse_ignore + |> OSnap_Config_Utils.YAML.get_list_option + ~path + "ignore" + ~parser:(parse_ignore ~path) |> Result.map (Option.value ~default:[]) in let* () = Common.collect_duplicates sizes in @@ -247,44 +257,18 @@ module YAML = struct config |> Yaml.of_string |> Result.map_error (fun _ -> - OSnap_Response.Config_Parse_Error - (Printf.sprintf "YAML could not be parsed", Some path)) + `OSnap_Config_Parse_Error ("YAML could not be parsed", path)) in yaml |> (function | `A lst -> Result.ok lst | _ -> Result.error - (OSnap_Response.Config_Parse_Error - ("A test file has to be an array of tests.", Some path))) - |> Result.map (OSnap_Utils.List.map_until_exception (parse_single_test global_config)) + (`OSnap_Config_Parse_Error + ("A test file has to be an array of tests.", path))) + |> Result.map + (OSnap_Utils.List.map_until_exception (parse_single_test ~path global_config)) |> Result.join - |> Result.map_error (fun err -> - match err with - | OSnap_Response.Config_Parse_Error (err, None) -> - OSnap_Response.Config_Parse_Error (err, Some path) - | OSnap_Response.Config_Parse_Error (err, Some path) -> - OSnap_Response.Config_Parse_Error (err, Some path) - | OSnap_Response.Config_Global_Not_Found -> - OSnap_Response.Config_Global_Not_Found - | OSnap_Response.Config_Global_Invalid s -> - OSnap_Response.Config_Global_Invalid s - | OSnap_Response.Config_Unsupported_Format f -> - OSnap_Response.Config_Unsupported_Format f - | OSnap_Response.Config_Invalid (msg, None) -> - OSnap_Response.Config_Invalid (msg, Some path) - | OSnap_Response.Config_Invalid (msg, Some path) -> - OSnap_Response.Config_Invalid (msg, Some path) - | OSnap_Response.Config_Duplicate_Tests t -> - OSnap_Response.Config_Duplicate_Tests t - | OSnap_Response.Config_Duplicate_Size_Names n -> - OSnap_Response.Config_Duplicate_Size_Names n - | OSnap_Response.CDP_Protocol_Error e -> OSnap_Response.CDP_Protocol_Error e - | OSnap_Response.CDP_Connection_Failed -> OSnap_Response.CDP_Connection_Failed - | OSnap_Response.Invalid_Run s -> OSnap_Response.Invalid_Run s - | OSnap_Response.FS_Error e -> OSnap_Response.FS_Error e - | OSnap_Response.Test_Failure -> OSnap_Response.Test_Failure - | OSnap_Response.Unknown_Error e -> OSnap_Response.Unknown_Error e) ;; end @@ -312,8 +296,8 @@ let find ?(root_path = "/") ?(pattern = "**/*.osnap.json") ?(ignore_patterns = [ with | _ -> Result.error - (OSnap_Response.Config_Global_Invalid - "The testPattern path could not be resolved. Please make sure it exists") + (`OSnap_Config_Global_Invalid + "The testPattern path could not be resolved. Please make sure it exists") in let pattern = pattern |> Re.Glob.glob |> Re.compile in let ignore_patterns = @@ -353,6 +337,6 @@ let init config = | [] -> Result.ok tests | duplicates -> Result.error - (OSnap_Response.Config_Duplicate_Tests - (duplicates |> List.map (fun (t : OSnap_Config_Types.test) -> t.name))) + (`OSnap_Config_Duplicate_Tests + (duplicates |> List.map (fun (t : OSnap_Config_Types.test) -> t.name))) ;; diff --git a/lib/OSnap_Config/OSnap_Config_Test.mli b/lib/OSnap_Config/OSnap_Config_Test.mli index 34ecf7e..ee0f75b 100644 --- a/lib/OSnap_Config/OSnap_Config_Test.mli +++ b/lib/OSnap_Config/OSnap_Config_Test.mli @@ -1,3 +1,11 @@ val init : OSnap_Config_Types.global - -> (OSnap_Config_Types.test list, OSnap_Response.t) result + -> ( OSnap_Config_Types.test list + , [> `OSnap_Config_Duplicate_Size_Names of string list + | `OSnap_Config_Duplicate_Tests of string list + | `OSnap_Config_Global_Invalid of string + | `OSnap_Config_Invalid of string * string + | `OSnap_Config_Parse_Error of string * string + | `OSnap_Config_Unsupported_Format of string + ] ) + result diff --git a/lib/OSnap_Config/OSnap_Config_Utils.ml b/lib/OSnap_Config/OSnap_Config_Utils.ml index d99b862..7129bf6 100644 --- a/lib/OSnap_Config/OSnap_Config_Utils.ml +++ b/lib/OSnap_Config/OSnap_Config_Utils.ml @@ -5,7 +5,7 @@ let get_format path = |> function | ".json" -> Result.ok OSnap_Config_Types.JSON | ".yaml" -> Result.ok OSnap_Config_Types.YAML - | _ -> Result.error (OSnap_Response.Config_Unsupported_Format path) + | _ -> Result.error (`OSnap_Config_Unsupported_Format path) ;; let to_result_option = function @@ -14,22 +14,22 @@ let to_result_option = function | Some (Error e) -> Error e ;; -let collect_action ~selector ~size_restriction ~name ~text ~timeout ~px action = +let collect_action ~path ~selector ~size_restriction ~name ~text ~timeout ~px action = match action with | "scroll" -> (match selector, px with | None, None -> Result.error - (OSnap_Response.Config_Invalid - ( "Neither selector nor px was provided for scroll action. Please provide \ - one of them." - , None )) + (`OSnap_Config_Invalid + ( "Neither selector nor px was provided for scroll action. Please provide one \ + of them." + , path )) | Some _, Some _ -> Result.error - (OSnap_Response.Config_Invalid - ( "Both selector and px were provided for scroll action. Please provide only \ - one of them." - , None )) + (`OSnap_Config_Invalid + ( "Both selector and px were provided for scroll action. Please provide only \ + one of them." + , path )) | None, Some px -> OSnap_Config_Types.Scroll (`PxAmount px, size_restriction) |> Result.ok | Some selector, None -> @@ -38,40 +38,35 @@ let collect_action ~selector ~size_restriction ~name ~text ~timeout ~px action = (match selector with | None -> Result.error - (OSnap_Response.Config_Invalid ("no selector for click action provided", None)) + (`OSnap_Config_Invalid ("no selector for click action provided", path)) | Some selector -> OSnap_Config_Types.Click (selector, size_restriction) |> Result.ok) | "type" -> (match selector, text with | None, _ -> - Result.error - (OSnap_Response.Config_Invalid ("no selector for type action provided", None)) + Result.error (`OSnap_Config_Invalid ("no selector for type action provided", path)) | _, None -> - Result.error - (OSnap_Response.Config_Invalid ("no text for type action provided", None)) + Result.error (`OSnap_Config_Invalid ("no text for type action provided", path)) | Some selector, Some text -> OSnap_Config_Types.Type (selector, text, size_restriction) |> Result.ok) | "wait" -> (match timeout with | None -> - Result.error - (OSnap_Response.Config_Invalid ("no timeout for wait action provided", None)) + Result.error (`OSnap_Config_Invalid ("no timeout for wait action provided", path)) | Some timeout -> OSnap_Config_Types.Wait (timeout, size_restriction) |> Result.ok) | "function" -> (match name with | None -> - Result.error - (OSnap_Response.Config_Invalid ("no name for function action provided", None)) + Result.error (`OSnap_Config_Invalid ("no name for function action provided", path)) | Some name -> OSnap_Config_Types.Function (name, size_restriction) |> Result.ok) | action -> Result.error - (OSnap_Response.Config_Invalid - (Printf.sprintf "found unknown action %S" action, None)) + (`OSnap_Config_Invalid (Printf.sprintf "found unknown action %S" action, path)) ;; module JSON = struct let ( let* ) = Result.bind - let parse_size size = + let parse_size ~path size = let* name = try size @@ -80,7 +75,7 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* width = try @@ -89,15 +84,15 @@ module JSON = struct |> (function | `Null -> Result.error - (OSnap_Response.Config_Parse_Error - ( "defaultSize has an invalid format. \"width\" is required but not \ - provided!" - , None )) + (`OSnap_Config_Parse_Error + ( "defaultSize has an invalid format. \"width\" is required but not \ + provided!" + , path )) | v -> Result.ok v) |> Result.map Yojson.Basic.Util.to_int with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* height = try @@ -106,26 +101,26 @@ module JSON = struct |> (function | `Null -> Result.error - (OSnap_Response.Config_Parse_Error - ( "defaultSize has an invalid format. \"height\" is required but not \ - provided!" - , None )) + (`OSnap_Config_Parse_Error + ( "defaultSize has an invalid format. \"height\" is required but not \ + provided!" + , path )) | v -> Result.ok v) |> Result.map Yojson.Basic.Util.to_int with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in OSnap_Config_Types.{ name; width; height } |> Result.ok ;; - let parse_action a = + let parse_action ~path a = let* action = try a |> Yojson.Basic.Util.member "action" |> Yojson.Basic.Util.to_string |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* size_restriction = try @@ -136,14 +131,14 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* px = try a |> Yojson.Basic.Util.member "px" |> Yojson.Basic.Util.to_int_option |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* selector = try @@ -153,7 +148,7 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* text = try @@ -163,7 +158,7 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* timeout = try @@ -173,7 +168,7 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in let* name = try @@ -183,59 +178,59 @@ module JSON = struct |> Result.ok with | Yojson.Basic.Util.Type_error (message, _) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + Result.error (`OSnap_Config_Parse_Error (message, path)) in - collect_action ~selector ~size_restriction ~text ~timeout ~name ~px action + collect_action ~path ~selector ~size_restriction ~text ~timeout ~name ~px action ;; end module YAML = struct let ( let* ) = Result.bind - let get_list_option ~parser key obj = + let get_list_option ~path ~parser key obj = obj |> Yaml.Util.find key |> Result.map_error (function `Msg message -> - OSnap_Response.Config_Parse_Error (message, None)) + `OSnap_Config_Parse_Error (message, path)) |> Result.map (Option.map (fun v -> match v with | `A l -> Result.ok l | `Bool _ -> Result.error - (OSnap_Response.Config_Parse_Error - ( Printf.sprintf - "%S is in an invalid format. Expected array, got boolean." - key - , None )) + (`OSnap_Config_Parse_Error + ( Printf.sprintf + "%S is in an invalid format. Expected array, got boolean." + key + , path )) | `Float _ -> Result.error - (OSnap_Response.Config_Parse_Error - ( Printf.sprintf - "%S is in an invalid format. Expected array, got number." - key - , None )) + (`OSnap_Config_Parse_Error + ( Printf.sprintf + "%S is in an invalid format. Expected array, got number." + key + , path )) | `Null -> Result.error - (OSnap_Response.Config_Parse_Error - ( Printf.sprintf - "%S is in an invalid format. Expected array, got null." - key - , None )) + (`OSnap_Config_Parse_Error + ( Printf.sprintf + "%S is in an invalid format. Expected array, got null." + key + , path )) | `O _ -> Result.error - (OSnap_Response.Config_Parse_Error - ( Printf.sprintf - "%S is in an invalid format. Expected array, got object." - key - , None )) + (`OSnap_Config_Parse_Error + ( Printf.sprintf + "%S is in an invalid format. Expected array, got object." + key + , path )) | `String _ -> Result.error - (OSnap_Response.Config_Parse_Error - ( Printf.sprintf - "%S is in an invalid format. Expected array, got string." - key - , None )))) + (`OSnap_Config_Parse_Error + ( Printf.sprintf + "%S is in an invalid format. Expected array, got string." + key + , path )))) |> Result.map to_result_option |> Result.join |> Result.map (Option.map (OSnap_Utils.List.map_until_exception parser)) @@ -243,26 +238,26 @@ module YAML = struct |> Result.join ;; - let get_string_list_option key obj = + let get_string_list_option ~path key obj = let parser v = Yaml.Util.to_string v |> Result.map_error (function `Msg message -> - OSnap_Response.Config_Parse_Error (message, None)) + `OSnap_Config_Parse_Error (message, path)) in - get_list_option ~parser key obj + get_list_option ~path ~parser key obj ;; - let get_string_option key obj = + let get_string_option ~path key obj = obj |> Yaml.Util.find key |> Result.map (Option.map Yaml.Util.to_string) |> Result.map to_result_option |> Result.join |> Result.map_error (function `Msg message -> - OSnap_Response.Config_Parse_Error (message, None)) + `OSnap_Config_Parse_Error (message, path)) ;; - let get_string ?(additional_error_message = "") key obj = + let get_string ~path ?(additional_error_message = "") key obj = obj |> Yaml.Util.find key |> Result.map (Option.map Yaml.Util.to_string) @@ -272,27 +267,26 @@ module YAML = struct | Ok (Some string) -> Result.ok string | Ok None -> Result.error - (OSnap_Response.Config_Parse_Error - ( Printf.sprintf - "%S is required but not provided! %s" - key - additional_error_message - , None )) - | Error (`Msg message) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + (`OSnap_Config_Parse_Error + ( Printf.sprintf + "%S is required but not provided! %s" + key + additional_error_message + , path )) + | Error (`Msg message) -> Result.error (`OSnap_Config_Parse_Error (message, path)) ;; - let get_bool_option key obj = + let get_bool_option ~path key obj = obj |> Yaml.Util.find key |> Result.map (Option.map Yaml.Util.to_bool) |> Result.map to_result_option |> Result.join |> Result.map_error (function `Msg message -> - OSnap_Response.Config_Parse_Error (message, None)) + `OSnap_Config_Parse_Error (message, path)) ;; - let get_bool ?(additional_error_message = "") key obj = + let get_bool ~path ?(additional_error_message = "") key obj = obj |> Yaml.Util.find key |> Result.map (Option.map Yaml.Util.to_bool) @@ -302,17 +296,16 @@ module YAML = struct | Ok (Some string) -> Result.ok string | Ok None -> Result.error - (OSnap_Response.Config_Parse_Error - ( Printf.sprintf - "%S is required but not provided! %s" - key - additional_error_message - , None )) - | Error (`Msg message) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + (`OSnap_Config_Parse_Error + ( Printf.sprintf + "%S is required but not provided! %s" + key + additional_error_message + , path )) + | Error (`Msg message) -> Result.error (`OSnap_Config_Parse_Error (message, path)) ;; - let get_int ?(additional_error_message = "") key obj = + let get_int ~path ?(additional_error_message = "") key obj = obj |> Yaml.Util.find key |> Result.map (Option.map Yaml.Util.to_float) @@ -323,17 +316,16 @@ module YAML = struct | Ok (Some number) -> Result.ok number | Ok None -> Result.error - (OSnap_Response.Config_Parse_Error - ( Printf.sprintf - "%S is required but not provided! %s" - key - additional_error_message - , None )) - | Error (`Msg message) -> - Result.error (OSnap_Response.Config_Parse_Error (message, None)) + (`OSnap_Config_Parse_Error + ( Printf.sprintf + "%S is required but not provided! %s" + key + additional_error_message + , path )) + | Error (`Msg message) -> Result.error (`OSnap_Config_Parse_Error (message, path)) ;; - let get_int_option key obj = + let get_int_option ~path key obj = obj |> Yaml.Util.find key |> Result.map (Option.map Yaml.Util.to_float) @@ -341,24 +333,24 @@ module YAML = struct |> Result.join |> Result.map (Option.map Float.to_int) |> Result.map_error (function `Msg message -> - OSnap_Response.Config_Parse_Error (message, None)) + `OSnap_Config_Parse_Error (message, path)) ;; - let parse_size size = - let* name = size |> get_string_option "name" in - let* height = size |> get_int "height" in - let* width = size |> get_int "width" in + let parse_size ~path size = + let* name = size |> get_string_option ~path "name" in + let* height = size |> get_int ~path "height" in + let* width = size |> get_int ~path "width" in OSnap_Config_Types.{ name; width; height } |> Result.ok ;; - let parse_action a = - let* size_restriction = a |> get_string_list_option "@" in - let* action = a |> get_string "action" in - let* selector = a |> get_string_option "selector" in - let* px = a |> get_int_option "px" in - let* name = a |> get_string_option "name" in - let* text = a |> get_string_option "text" in - let* timeout = a |> get_int_option "timeout" in - collect_action ~selector ~size_restriction ~text ~name ~timeout ~px action + let parse_action ~path a = + let* size_restriction = a |> get_string_list_option ~path "@" in + let* action = a |> get_string ~path "action" in + let* selector = a |> get_string_option ~path "selector" in + let* px = a |> get_int_option ~path "px" in + let* name = a |> get_string_option ~path "name" in + let* text = a |> get_string_option ~path "text" in + let* timeout = a |> get_int_option ~path "timeout" in + collect_action ~path ~selector ~size_restriction ~text ~name ~timeout ~px action ;; end diff --git a/lib/OSnap_Config/dune b/lib/OSnap_Config/dune index d0e495e..92383a2 100644 --- a/lib/OSnap_Config/dune +++ b/lib/OSnap_Config/dune @@ -1,3 +1,3 @@ (library (name OSnap_Config) - (libraries OSnap_Response OSnap_Utils re fileutils yaml yojson)) + (libraries OSnap_Utils re fileutils yaml yojson)) diff --git a/lib/OSnap_Paths.ml b/lib/OSnap_Paths/OSnap_Paths.ml similarity index 67% rename from lib/OSnap_Paths.ml rename to lib/OSnap_Paths/OSnap_Paths.ml index efa1742..45d72f4 100644 --- a/lib/OSnap_Paths.ml +++ b/lib/OSnap_Paths/OSnap_Paths.ml @@ -29,3 +29,13 @@ let get config = ; diff = get_diff_dir config } ;; + +let init_folder_structure config = + let dirs = get config in + if not (Sys.file_exists dirs.base) + then FileUtil.mkdir ~parent:true ~mode:(`Octal 0o755) dirs.base; + FileUtil.rm ~recurse:true [ dirs.updated ]; + FileUtil.mkdir ~parent:true ~mode:(`Octal 0o755) dirs.updated; + FileUtil.rm ~recurse:true [ dirs.diff ]; + FileUtil.mkdir ~parent:true ~mode:(`Octal 0o755) dirs.diff +;; diff --git a/lib/OSnap_Paths/OSnap_Paths.mli b/lib/OSnap_Paths/OSnap_Paths.mli new file mode 100644 index 0000000..b0374c3 --- /dev/null +++ b/lib/OSnap_Paths/OSnap_Paths.mli @@ -0,0 +1,13 @@ +val get_snapshot_root_path : OSnap_Config.Types.global -> string +val get_base_images_dir : OSnap_Config.Types.global -> string +val get_updated_dir : OSnap_Config.Types.global -> string +val get_diff_dir : OSnap_Config.Types.global -> string + +type t = + { base : string + ; updated : string + ; diff : string + } + +val get : OSnap_Config.Types.global -> t +val init_folder_structure : OSnap_Config.Types.global -> unit diff --git a/lib/OSnap_Paths/dune b/lib/OSnap_Paths/dune new file mode 100644 index 0000000..82b3807 --- /dev/null +++ b/lib/OSnap_Paths/dune @@ -0,0 +1,3 @@ +(library + (name OSnap_Paths) + (libraries OSnap_Config fileutils)) diff --git a/lib/OSnap_Response/OSnap_Response.ml b/lib/OSnap_Response/OSnap_Response.ml deleted file mode 100644 index 3688aeb..0000000 --- a/lib/OSnap_Response/OSnap_Response.ml +++ /dev/null @@ -1,14 +0,0 @@ -type t = - | Config_Parse_Error of string * string option - | Config_Global_Not_Found - | Config_Global_Invalid of string - | Config_Unsupported_Format of string - | Config_Invalid of string * string option - | Config_Duplicate_Tests of string list - | Config_Duplicate_Size_Names of string list - | CDP_Protocol_Error of string - | CDP_Connection_Failed - | Invalid_Run of string - | FS_Error of string - | Test_Failure - | Unknown_Error of exn diff --git a/lib/OSnap_Response/dune b/lib/OSnap_Response/dune deleted file mode 100644 index 0a27a5a..0000000 --- a/lib/OSnap_Response/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (name OSnap_Response) - (ocamlopt_flags -O3)) diff --git a/lib/OSnap_Test.ml b/lib/OSnap_Test.ml index 2a9d6a2..a7cc171 100644 --- a/lib/OSnap_Test.ml +++ b/lib/OSnap_Test.ml @@ -20,7 +20,7 @@ let save_screenshot ~path data = let* io = try Lwt_io.open_file ~mode:Output path |> Lwt_result.ok with | _ -> - OSnap_Response.FS_Error (Printf.sprintf "Could not save screenshot to %s" path) + `OSnap_FS_Error (Printf.sprintf "Could not save screenshot to %s" path) |> Lwt_result.fail in let* () = Lwt_io.write io data |> Lwt_result.ok in @@ -32,7 +32,7 @@ let read_file_contents ~path = let* io = try Lwt_io.open_file ~mode:Input path |> Lwt_result.ok with | _ -> - OSnap_Response.FS_Error (Printf.sprintf "Could not open file %S for reading" path) + `OSnap_FS_Error (Printf.sprintf "Could not open file %S for reading" path) |> Lwt_result.fail in let* data = Lwt_io.read io |> Lwt_result.ok in @@ -90,14 +90,12 @@ let rec execute_action ~document ~global_config target size_name action = |> Lwt_list.map_s (execute_action ~document ~global_config target (Some size_name)) >>= Lwt_list.fold_left_s - (fun (acc : (unit, OSnap_Response.t) Result.t) curr -> + (fun acc curr -> if Result.is_ok acc && Result.is_ok curr then Lwt.return acc else Lwt.return curr) (Result.ok ()) - | None -> - Lwt_result.fail - (OSnap_Response.Invalid_Run ("Tried to call non existant function " ^ name))) + | None -> Lwt_result.fail (`OSnap_Config_Undefined_Function name)) else Lwt_result.return () | Function (name, None), _ -> (match global_config.functions |> List.assoc_opt name with @@ -106,14 +104,12 @@ let rec execute_action ~document ~global_config target size_name action = actions |> Lwt_list.map_s (execute_action ~document ~global_config target size_name) >>= Lwt_list.fold_left_s - (fun (acc : (unit, OSnap_Response.t) Result.t) curr -> + (fun acc curr -> if Result.is_ok acc && Result.is_ok curr then Lwt.return acc else Lwt.return curr) (Result.ok ()) - | None -> - Lwt_result.fail - (OSnap_Response.Invalid_Run ("Tried to call non existant function " ^ name))) + | None -> Lwt_result.fail (`OSnap_Config_Undefined_Function name)) ;; let get_ignore_regions ~document target size_name regions = @@ -189,7 +185,7 @@ let run (global_config : Config.Types.global) target test = test.actions |> Lwt_list.map_s (execute_action ~document ~global_config target test.size_name) >>= Lwt_list.fold_left_s - (fun (acc : (unit, OSnap_Response.t) Result.t) curr -> + (fun acc curr -> if Result.is_ok acc && Result.is_ok curr then Lwt.return acc else Lwt.return curr) diff --git a/lib/OSnap_Utils/OSnap_Utils.ml b/lib/OSnap_Utils/OSnap_Utils.ml index b715102..a8cd3cd 100644 --- a/lib/OSnap_Utils/OSnap_Utils.ml +++ b/lib/OSnap_Utils/OSnap_Utils.ml @@ -67,6 +67,8 @@ let path_of_segments paths = ;; module List = struct + include List + let map_until_exception fn list = let rec loop acc list = match list with @@ -80,3 +82,30 @@ module List = struct loop [] list ;; end + +module Lwt_list = struct + include Lwt_list + + let map_p_until_exception fn list = + let open! Lwt.Syntax in + let rec loop acc list = + match list with + | [] -> Lwt_result.return acc + | list -> + let* resolved, pending = Lwt.nchoose_split list in + let success, error = + resolved + |> List.partition_map (function + | Ok v -> Either.left v + | Error e -> Either.right e) + in + (match error with + | [] -> loop (success @ acc) pending + | hd :: _tl -> + pending |> List.iter Lwt.cancel; + Lwt_result.fail hd) + in + let promises = list |> List.map (Lwt.apply fn) in + loop [] promises + ;; +end diff --git a/lib/OSnap_Utils/OSnap_Utils.mli b/lib/OSnap_Utils/OSnap_Utils.mli deleted file mode 100644 index 4f9de95..0000000 --- a/lib/OSnap_Utils/OSnap_Utils.mli +++ /dev/null @@ -1,16 +0,0 @@ -type platform = - | Win32 - | Win64 - | MacOS - | MacOS_ARM - | Linux - -val detect_platform : unit -> platform -val get_file_contents : string -> string -val contains_substring : search:string -> string -> bool -val find_duplicates : ('a -> 'b) -> 'a list -> 'a list -val path_of_segments : string list -> string - -module List : sig - val map_until_exception : ('a -> ('b, 'c) result) -> 'a list -> ('b list, 'c) result -end diff --git a/lib/OSnap_Utils/dune b/lib/OSnap_Utils/dune index 433e0ec..89934bc 100644 --- a/lib/OSnap_Utils/dune +++ b/lib/OSnap_Utils/dune @@ -1,3 +1,3 @@ (library (name OSnap_Utils) - (libraries unix)) + (libraries unix lwt)) diff --git a/lib/dune b/lib/dune index 297ac6b..1d15829 100644 --- a/lib/dune +++ b/lib/dune @@ -2,7 +2,7 @@ (name OSnap) (ocamlopt_flags -O3) (libraries - OSnap_Response + OSnap_Paths OSnap_Utils OSnap_Diff OSnap_Printer @@ -12,5 +12,4 @@ lwt.unix cdp base64 - fileutils fmt))