diff --git a/bot-components.opam b/bot-components.opam index f96a21d5..c08b9c63 100644 --- a/bot-components.opam +++ b/bot-components.opam @@ -23,6 +23,7 @@ depends: [ "x509" {>= "0.11.2"} "cstruct" {>= "5.0.0"} "ISO8601" {>= "0.2.0"} + "camlzip" {>= "1.08"} "odoc" {>= "1.5.2" & with-doc} ] build: [ diff --git a/bot-components/GitHub_queries.ml b/bot-components/GitHub_queries.ml index 1af574e9..74853d20 100644 --- a/bot-components/GitHub_queries.ml +++ b/bot-components/GitHub_queries.ml @@ -1021,3 +1021,9 @@ let get_project_field_values ~bot_info ~organization ~project ~field ~options = Lwt.return_error (f "Organization %s does not exist." organization) ) | Error err -> Lwt.return_error err + +let get_artifact_blob ~bot_info ~owner ~repo ~artifact_id = + generic_get_zip ~bot_info + (f "repos/%s/%s/actions/artifacts/%s/zip" owner repo artifact_id) + (let open Zip in + List.map ~f:(fun (entry, contents) -> (entry.filename, contents)) ) diff --git a/bot-components/GitHub_queries.mli b/bot-components/GitHub_queries.mli index b9b569e4..969e4ba6 100644 --- a/bot-components/GitHub_queries.mli +++ b/bot-components/GitHub_queries.mli @@ -151,3 +151,10 @@ val get_project_field_values : , string ) result Lwt.t + +val get_artifact_blob : + bot_info:Bot_info.t + -> owner:string + -> repo:string + -> artifact_id:string + -> ((string * string) list, string) result Lwt.t diff --git a/bot-components/Utils.ml b/bot-components/Utils.ml index 8587df60..f7c932c7 100644 --- a/bot-components/Utils.ml +++ b/bot-components/Utils.ml @@ -3,6 +3,7 @@ open Bot_info open Cohttp open Cohttp_lwt_unix open Lwt +open Zip let f = Printf.sprintf @@ -43,6 +44,30 @@ let handle_json action body = | Yojson.Basic.Util.Type_error (err, _) -> Error (f "Json type error: %s\n" err) +let handle_zip action body = + let open Lwt_result.Infix in + Lwt_io.with_temp_file (fun (tmp_name, tmp_channel) -> + let open Lwt.Infix in + Lwt_io.write tmp_channel body + >>= fun () -> + Lwt_io.close tmp_channel + >>= Lwt_preemptive.detach (fun () -> + try + let zip_entries = + let zf = Zip.open_in tmp_name in + let entries = + Zip.entries zf + |> List.filter ~f:(fun entry -> not entry.is_directory) + |> List.map ~f:(fun entry -> + (entry, Zip.read_entry zf entry) ) + in + Zip.close_in zf ; entries + in + Ok zip_entries + with Zip.Error (zip_name, entry_name, message) -> + Error (f "Zip.Error(%s, %s, %s)" zip_name entry_name message) ) ) + >|= action + (* GitHub specific *) let project_api_preview_header = @@ -51,14 +76,64 @@ let project_api_preview_header = let app_api_preview_header = [("Accept", "application/vnd.github.machine-man-preview+json")] +let api_json_header = [("Accept", "application/vnd.github+json")] + let github_header bot_info = [("Authorization", "bearer " ^ github_token bot_info)] -let generic_get ~bot_info relative_uri ?(header_list = []) json_handler = - let uri = "https://api.github.com/" ^ relative_uri |> Uri.of_string in - let headers = - headers (header_list @ github_header bot_info) bot_info.github_name - in +let headers_of_list = headers + +(* when following a redirect from GitHub to Azure, passing along the + Authorization header results in 403 Forbidden. So we strip the + headers when we recurse by default. *) +let rec client_get ?(follow_redirects = true) + ?(include_headers_in_redirects = false) ~user_agent ~headers uri = Client.get ~headers uri - >>= (fun (_response, body) -> Cohttp_lwt.Body.to_string body) - >|= handle_json json_handler + >>= fun (resp, body) -> + match Response.status resp with + | `OK -> + Lwt.return_ok body + | `Moved_permanently + | `Found + | `See_other + | `Temporary_redirect + | `Permanent_redirect + when follow_redirects -> ( + let headers = + if include_headers_in_redirects then headers + else headers_of_list [] user_agent + in + match Header.get_location (Response.headers resp) with + | Some new_uri -> + Lwt_io.printlf "Following redirect to %s" (Uri.to_string new_uri) + >>= fun () -> + client_get ~follow_redirects ~include_headers_in_redirects ~headers + ~user_agent new_uri + | None -> + let msg = + f "Redirected from %s, but no Location header found" + (Uri.to_string uri) + in + Lwt.return_error msg ) + | status_code -> + let msg = + f "HTTP request to %s failed with status code: %s" (Uri.to_string uri) + (Code.string_of_status status_code) + in + Lwt.return_error msg + +let generic_get ~bot_info relative_uri ?(header_list = []) handler = + let open Lwt_result.Infix in + let uri = "https://api.github.com/" ^ relative_uri |> Uri.of_string in + let user_agent = bot_info.github_name in + let headers = headers (header_list @ github_header bot_info) user_agent in + client_get ~headers ~user_agent uri + >>= (fun body -> Cohttp_lwt.Body.to_string body |> Lwt_result.ok) + >>= handler + +let generic_get_json ~bot_info relative_uri ?(header_list = []) json_handler = + generic_get ~bot_info relative_uri ~header_list (fun body -> + body |> handle_json json_handler |> Lwt.return ) + +let generic_get_zip ~bot_info relative_uri ?(header_list = []) zip_handler = + generic_get ~bot_info relative_uri ~header_list (handle_zip zip_handler) diff --git a/bot-components/Utils.mli b/bot-components/Utils.mli index 142a99e2..747b0cdc 100644 --- a/bot-components/Utils.mli +++ b/bot-components/Utils.mli @@ -17,11 +17,20 @@ val project_api_preview_header : (string * string) list val app_api_preview_header : (string * string) list +val api_json_header : (string * string) list + val github_header : Bot_info.t -> (string * string) list -val generic_get : +val generic_get_json : bot_info:Bot_info.t -> string -> ?header_list:(string * string) list -> (Yojson.Basic.t -> 'a) -> ('a, string) result Lwt.t + +val generic_get_zip : + bot_info:Bot_info.t + -> string + -> ?header_list:(string * string) list + -> ((Zip.entry * string) list -> 'a) + -> ('a, string) result Lwt.t diff --git a/bot-components/dune b/bot-components/dune index e7f35d79..a2c5ba1a 100644 --- a/bot-components/dune +++ b/bot-components/dune @@ -1,8 +1,8 @@ (library (name Bot_components) (public_name bot-components) - (libraries base cohttp-lwt-unix cstruct eqaf hex mirage-crypto stdio str - x509 yojson ISO8601) + (libraries base camlzip cohttp-lwt-unix cstruct eqaf hex mirage-crypto stdio + str x509 yojson ISO8601) (private_modules GraphQL_query GitHub_GraphQL Utils) (modules_without_implementation GitHub_types GitLab_types) (preprocess diff --git a/dune-project b/dune-project index bfdb5abf..80011b81 100644 --- a/dune-project +++ b/dune-project @@ -50,5 +50,6 @@ (x509 (>= 0.11.2)) (cstruct (>= 5.0.0)) (ISO8601 (>= 0.2.0)) + (camlzip (>= 1.08)) (odoc (and (>= 1.5.2) :with-doc))) ) diff --git a/src/actions.ml b/src/actions.ml index 280adb98..00a7744a 100644 --- a/src/actions.ml +++ b/src/actions.ml @@ -732,27 +732,130 @@ type ci_minimization_info = ; failing_urls: string ; passing_urls: string } +type coqbot_minimize_script_data = + | MinimizeScript of {quote_kind: string; body: string} + | MinimizeAttachment of {description: string; url: string} + +type artifact_info = + | ArtifactInfo of + {artifact_owner: string; artifact_repo: string; artifact_id: string} + +let parse_github_artifact_url url = + let github_prefix = "https://github.com/" in + let regexp = + Str.quote github_prefix + ^ "\\([^/]+\\)/\\([^/]+\\)/\\(actions/runs\\|suites\\)/.*/artifacts/\\([0-9]+\\)" + in + if string_match ~regexp url then + Some + (ArtifactInfo + { artifact_owner= Str.matched_group 1 url + ; artifact_repo= Str.matched_group 2 url + ; artifact_id= Str.matched_group 4 url } ) + else None + +type artifact_error = + | ArtifactEmpty + | ArtifactContainsMultipleFiles of string list + | ArtifactDownloadError of string + +type run_ci_minimization_error = + | ArtifactError of + {url: string; artifact: artifact_info; artifact_error: artifact_error} + | DownloadError of {url: string; error: string} + +let run_ci_minimization_error_to_string = function + | ArtifactError + { url= artifact_url + ; artifact= ArtifactInfo {artifact_owner; artifact_repo; artifact_id} + ; artifact_error } -> ( + match artifact_error with + | ArtifactEmpty -> + f "Could not resume minimization with [empty artifact](%s)" artifact_url + | ArtifactContainsMultipleFiles filenames -> + f + "Could not resume minimization because [artifact](%s) contains more \ + than one file: %s" + artifact_url + (String.concat ~sep:", " filenames) + | ArtifactDownloadError error -> + f + "Could not resume minimization because [artifact %s/%s:%s](%s) \ + failed to download:\n\ + %s" + artifact_owner artifact_repo artifact_id artifact_url error ) + | DownloadError {url; error} -> + f + "Could not resume minimization because [artifact](%s) failed to \ + download:\n\ + %s" + url error + let run_ci_minimization ~bot_info ~comment_thread_id ~owner ~repo ~pr_number - ~base ~head ~ci_minimization_infos ~bug_file_contents - ~minimizer_extra_arguments = + ~base ~head ~ci_minimization_infos ~bug_file ~minimizer_extra_arguments = + let open Lwt_result.Infix in (* for convenience of control flow, we always create the temporary file, but we only pass in the file name if the bug file contents is non-None *) Lwt_io.with_temp_file (fun (bug_file_name, bug_file_ch) -> - Lwt_io.write bug_file_ch (Option.value ~default:"" bug_file_contents) + (let open Lwt.Infix in + match bug_file with + | None -> + Lwt.return_ok () + | Some (MinimizeScript {body= bug_file_contents}) -> + Lwt_io.write bug_file_ch bug_file_contents >>= Lwt.return_ok + | Some (MinimizeAttachment {url}) -> ( + match parse_github_artifact_url url with + | Some + ( ArtifactInfo {artifact_owner; artifact_repo; artifact_id} as + artifact ) -> ( + Lwt_io.printlf + "Downloading artifact %s/%s:%s for %s/%s#%s (%s) (parsed from %s)" + artifact_owner artifact_repo artifact_id owner repo pr_number + (GitHub_ID.to_string comment_thread_id) + url + >>= fun () -> + GitHub_queries.get_artifact_blob ~bot_info ~owner:artifact_owner + ~repo:artifact_repo ~artifact_id + >>= function + | Ok [(_filename, bug_file_contents)] -> + Lwt_io.write bug_file_ch bug_file_contents >>= Lwt.return_ok + | Ok [] -> + Lwt.return_error + (ArtifactError {url; artifact; artifact_error= ArtifactEmpty}) + | Ok files -> + files + |> List.map ~f:(fun (filename, _contents) -> filename) + |> fun artifact_filenames -> + Lwt.return_error + (ArtifactError + { url + ; artifact + ; artifact_error= + ArtifactContainsMultipleFiles artifact_filenames } ) + | Error message -> + Lwt.return_error + (ArtifactError + { url + ; artifact + ; artifact_error= ArtifactDownloadError message } ) ) + | None -> + download_to ~uri:(Uri.of_string url) bug_file_ch + |> Lwt_result.map_error (fun error -> DownloadError {url; error}) ) + ) >>= fun () -> + let open Lwt.Infix in Lwt_io.flush bug_file_ch >>= fun () -> - let bug_file_name = - Option.map ~f:(fun _ -> bug_file_name) bug_file_contents - in + let bug_file_name = Option.map ~f:(fun _ -> bug_file_name) bug_file in Lwt_list.map_s (fun {target; opam_switch; failing_urls; passing_urls; docker_image} -> git_run_ci_minimization ~bot_info ~comment_thread_id ~owner ~repo ~pr_number ~docker_image ~target ~opam_switch ~failing_urls ~passing_urls ~base ~head ~minimizer_extra_arguments ~bug_file_name >>= fun result -> Lwt.return (target, result) ) - ci_minimization_infos ) + ci_minimization_infos + >>= Lwt.return_ok ) >>= fun results -> results |> List.partition_map ~f:(function @@ -760,7 +863,7 @@ let run_ci_minimization ~bot_info ~comment_thread_id ~owner ~repo ~pr_number Either.First target | target, Error f -> Either.Second (target, f) ) - |> Lwt.return + |> Lwt.return_ok type ci_minimization_job_suggestion_info = { base_job_failed: bool @@ -1200,8 +1303,8 @@ let accumulate_extra_minimizer_arguments options = >>= fun inline_stdlib_args -> inline_stdlib_args @ extra_args |> Lwt.return let minimize_failed_tests ~bot_info ~owner ~repo ~pr_number - ~head_pipeline_summary ~request ~comment_on_error ~bug_file_contents - ~options ?base_sha ?head_sha () = + ~head_pipeline_summary ~request ~comment_on_error ~bug_file ~options + ?base_sha ?head_sha () = let options = format_options_for_getopts options in accumulate_extra_minimizer_arguments options >>= fun minimizer_extra_arguments -> @@ -1297,447 +1400,475 @@ let minimize_failed_tests ~bot_info ~owner ~repo ~pr_number run_ci_minimization ~bot_info ~comment_thread_id ~owner ~repo ~pr_number:(Int.to_string pr_number) ~base ~head ~ci_minimization_infos:jobs_to_minimize ~minimizer_extra_arguments - ~bug_file_contents - >>= fun (jobs_minimized, jobs_that_could_not_be_minimized) -> - let pluralize word ?plural ls = - match (ls, plural) with - | [_], _ -> - word - | _, Some plural -> - plural - | _, _ -> - word ^ "s" - in - (* Construct a comment body *) - let unminimizable_jobs_description ~f = - match - unminimizable_jobs |> List.filter ~f:(fun (name, _) -> f name) - with - | [] -> - None - | [(name, err)] -> - Some - (Printf.sprintf "The job %s could not be minimized because %s.\n" - name err ) - | unminimizable_jobs -> - Some - ( "The following jobs could not be minimized:\n" - ^ ( unminimizable_jobs - |> List.map ~f:(fun (name, err) -> - Printf.sprintf "- %s (%s)" name err ) - |> String.concat ~sep:"\n" ) - ^ "\n\n" ) - in - let bad_jobs_description ~f = - match - bad_jobs_to_minimize - |> List.filter ~f:(fun (_, {target (*; full_target*)}) -> - f target (*|| f full_target*) ) - with - | [] -> - None - | [(reason, {target})] -> - Some - (Printf.sprintf "The job %s was not minimized because %s.\n" - target reason ) - | bad_jobs -> - Some - ( "The following jobs were not minimized:\n" - ^ ( bad_jobs - |> List.map ~f:(fun (reason, {target}) -> - Printf.sprintf "- %s because %s" target reason ) - |> String.concat ~sep:"\n" ) - ^ "\n\n" ) - in - let bad_and_unminimizable_jobs_description ~f = - match (bad_jobs_description ~f, unminimizable_jobs_description ~f) with - | None, None -> - None - | Some msg, None | None, Some msg -> - Some msg - | Some msg1, Some msg2 -> - Some (msg1 ^ msg2) - in - let failed_minimization_description = - match jobs_that_could_not_be_minimized with - | [] -> - None - | _ :: _ -> - Some - ( "I failed to trigger minimization on the following jobs:\n" - ^ ( jobs_that_could_not_be_minimized - |> List.map ~f:(fun (name, err) -> - Printf.sprintf "- %s (%s)" name err ) - |> String.concat ~sep:"\n" ) - ^ "\n\n" ) - in - let unfinished_pipelines_description = - (if base_pipeline_finished then [] else [f "base commit (%s)" base]) - @ if head_pipeline_finished then [] else [f "head commit (%s)" head] - in - let try_again_msg = - match unfinished_pipelines_description with - | [] -> - "" - | ls -> - f "\nHowever, you may want to try again once the %s for the %s %s." - (pluralize "pipeline" ls) - (ls |> String.concat ~sep:" and ") - (pluralize "finishes" ~plural:"finish" ls) - in - let may_wish_to_wait_msg = - match unfinished_pipelines_description with - | [] -> - "" - | ls -> - f - "\n\n\ - :warning: :hourglass: You may want to wait until the %s for the \ - %s %s." - (pluralize "pipeline" ls) - (ls |> String.concat ~sep:" and ") - (pluralize "finishes" ~plural:"finish" ls) - in - let note_some_head_unfinished_msg = - if head_pipeline_finished then "" - else - f - "\n\ - Some jobs may have been missed because the pipeline for the head \ - commit (%s) has not yet finished." - head - in - let note_some_base_unfinished_msg = - if base_pipeline_finished then "" - else - f - "\n\ - However, minimization may fail because the pipeline for the base \ - commit (%s) has not yet finished." - base - in - ( match (request, jobs_minimized, failed_minimization_description) with - | RequestAll, [], None -> - Lwt.return_some - ( match - bad_and_unminimizable_jobs_description ~f:(fun _ -> true) - with - | None -> - f "No valid CI jobs detected for %s.%s" head try_again_msg - | Some msg -> - f - "I attempted to run all CI jobs at commit %s for \ - minimization, but was unable to find any jobs to \ - minimize.%s\n\n\ - %s" - head try_again_msg msg ) - | RequestAll, _, _ -> - ( match bad_and_unminimizable_jobs_description ~f:(fun _ -> true) with - | Some msg -> - Lwt_io.printlf - "When attempting to run CI Minimization by request all on \ - %s/%s@%s for PR #%d:\n\ - %s" - owner repo head pr_number msg - | None -> - Lwt.return_unit ) - >>= fun () -> - ( match jobs_minimized with - | [] -> - f - "I did not succeed at triggering minimization on any jobs at \ - commit %s.%s" - head try_again_msg - | _ :: _ -> - f - "I am now %s minimization at commit %s on %s. I'll come back \ - to you with the results once it's done.%s" - ( if Option.is_none bug_file_contents then "running" - else "resuming" ) - head - (jobs_minimized |> String.concat ~sep:", ") - note_some_head_unfinished_msg ) - ^ "\n\n" - ^ Option.value ~default:"" failed_minimization_description - |> Lwt.return_some - | RequestExplicit requests, _, _ -> - (* N.B. requests may be things like library:ci-cross_crypto, - while the job targets are things like GitLab CI job - library:ci-cross_crypto (pull request) *) - requests - |> List.partition3_map ~f:(fun request -> - match - ( List.exists - ~f:(string_match ~regexp:(Str.quote request)) - jobs_minimized - , List.find - ~f:(fun (target, _) -> - string_match ~regexp:(Str.quote request) target ) - jobs_that_could_not_be_minimized - , List.find - ~f:(fun (target, _) -> - string_match ~regexp:(Str.quote request) target ) - unminimizable_jobs - , List.find - ~f:(fun (_, {target}) -> - string_match ~regexp:(Str.quote request) target ) - bad_jobs_to_minimize ) - with - | true, _, _, _ -> - `Fst request - | false, Some (target, err), _, _ -> - `Snd - (f "%s: failed to trigger minimization (%s)" target err) - | false, None, Some (target, err), _ -> - `Snd (f "%s could not be minimized (%s)" target err) - | false, None, None, Some (reason, {target}) -> - `Snd (f "%s was not minimized because %s" target reason) - | false, None, None, None -> - `Trd request ) - |> fun (successful_requests, unsuccessful_requests, unfound_requests) -> - let unsuccessful_requests_report = - match unsuccessful_requests with + ~bug_file + >>= function + | Ok (jobs_minimized, jobs_that_could_not_be_minimized) -> ( + let pluralize word ?plural ls = + match (ls, plural) with + | [_], _ -> + word + | _, Some plural -> + plural + | _, _ -> + word ^ "s" + in + (* Construct a comment body *) + let unminimizable_jobs_description ~f = + match + unminimizable_jobs |> List.filter ~f:(fun (name, _) -> f name) + with | [] -> None - | [msg] -> - Some msg - | _ -> + | [(name, err)] -> + Some + (Printf.sprintf + "The job %s could not be minimized because %s.\n" name err ) + | unminimizable_jobs -> Some - ( "The following requests were not fulfilled:\n" - ^ ( unsuccessful_requests - |> List.map ~f:(fun msg -> "- " ^ msg) + ( "The following jobs could not be minimized:\n" + ^ ( unminimizable_jobs + |> List.map ~f:(fun (name, err) -> + Printf.sprintf "- %s (%s)" name err ) |> String.concat ~sep:"\n" ) ^ "\n\n" ) in - let unfound_requests_report = - let all_jobs = - List.map - ~f:(fun (target, _) -> target) - jobs_that_could_not_be_minimized - @ List.map ~f:(fun (target, _) -> target) unminimizable_jobs - @ List.map ~f:(fun (_, {target}) -> target) bad_jobs_to_minimize - |> List.sort ~compare:String.compare - in - match unfound_requests with + let bad_jobs_description ~f = + match + bad_jobs_to_minimize + |> List.filter ~f:(fun (_, {target (*; full_target*)}) -> + f target (*|| f full_target*) ) + with | [] -> None - | [request] -> + | [(reason, {target})] -> Some - (f - "requested target '%s' could not be found among the jobs \ - %s.%s" - request - (all_jobs |> String.concat ~sep:", ") - note_some_head_unfinished_msg ) - | _ :: _ :: _ -> + (Printf.sprintf "The job %s was not minimized because %s.\n" + target reason ) + | bad_jobs -> Some - (f - "requested targets %s could not be found among the jobs \ - %s.%s" - (unfound_requests |> String.concat ~sep:", ") - (all_jobs |> String.concat ~sep:", ") - note_some_head_unfinished_msg ) + ( "The following jobs were not minimized:\n" + ^ ( bad_jobs + |> List.map ~f:(fun (reason, {target}) -> + Printf.sprintf "- %s because %s" target reason ) + |> String.concat ~sep:"\n" ) + ^ "\n\n" ) in - let unsuccessful_requests_report = - match (unsuccessful_requests_report, unfound_requests_report) with + let bad_and_unminimizable_jobs_description ~f = + match + (bad_jobs_description ~f, unminimizable_jobs_description ~f) + with | None, None -> None - | Some msg, None -> + | Some msg, None | None, Some msg -> Some msg - | None, Some msg -> - Some ("The " ^ msg) | Some msg1, Some msg2 -> - Some (msg1 ^ "\nAdditionally, the " ^ msg2) + Some (msg1 ^ msg2) in - ( match (successful_requests, unsuccessful_requests_report) with - | [], None -> - "No CI minimization requests made?" - | [], Some msg -> - "I was unable to minimize any of the CI targets that you \ - requested." ^ try_again_msg ^ "\n" ^ msg - | _ :: _, _ -> - f - "I am now %s minimization at commit %s on requested %s %s. \ - I'll come back to you with the results once it's done.%s\n\n\ - %s" - ( if Option.is_none bug_file_contents then "running" - else "resuming" ) - head - (pluralize "target" successful_requests) - (successful_requests |> String.concat ~sep:", ") - note_some_base_unfinished_msg - (Option.value ~default:"" unsuccessful_requests_report) ) - |> Lwt.return_some - | RequestSuggested, [], None -> - ( match possible_jobs_to_minimize with - | [] -> - f "No CI jobs are available to be minimized for commit %s.%s" head - try_again_msg - | _ :: _ -> - f - "You requested minimization of suggested failing CI jobs, but \ - no jobs were suggested at commit %s. You can trigger \ - minimization of %s with `ci minimize all` or by requesting \ - some targets by name.%s" - head - ( possible_jobs_to_minimize - |> List.map ~f:(fun (_, {target}) -> target) - |> String.concat ~sep:", " ) - may_wish_to_wait_msg ) - |> Lwt.return_some - | RequestSuggested, [], Some failed_minimization_description -> - f - "I attempted to minimize suggested failing CI jobs at commit %s, \ - but was unable to succeed on any jobs.%s\n\ - %s" - head try_again_msg failed_minimization_description - |> Lwt.return_some - | RequestSuggested, _ :: _, _ -> - f - "I have initiated minimization at commit %s for the suggested %s \ - %s as requested.%s\n\n\ - %s" - head - (pluralize "target" jobs_minimized) - (jobs_minimized |> String.concat ~sep:", ") - try_again_msg - (Option.value ~default:"" failed_minimization_description) - |> Lwt.return_some - | Auto, jobs_minimized, failed_minimization_description -> ( - ( match bad_and_unminimizable_jobs_description ~f:(fun _ -> true) with - | Some msg -> - Lwt_io.printlf - "When attempting to run CI Minimization by auto on %s/%s@%s \ - for PR #%d:\n\ - %s" - owner repo head pr_number msg - | None -> - Lwt.return_unit ) - >>= fun () -> - let suggest_jobs = - match suggested_jobs_to_minimize with + let failed_minimization_description = + match jobs_that_could_not_be_minimized with | [] -> None - | _ -> + | _ :: _ -> Some - (f - ":runner: @%s ci minimize will minimize the \ - following %s: %s" - bot_info.github_name - (pluralize "target" suggested_jobs_to_minimize) - ( suggested_jobs_to_minimize - |> List.map ~f:(fun {target} -> target) - |> String.concat ~sep:", " ) ) + ( "I failed to trigger minimization on the following jobs:\n" + ^ ( jobs_that_could_not_be_minimized + |> List.map ~f:(fun (name, err) -> + Printf.sprintf "- %s (%s)" name err ) + |> String.concat ~sep:"\n" ) + ^ "\n\n" ) in - let suggest_only_all_jobs = - let pre_message = - f - "- If you tag me saying `@%s ci minimize all`, I will \ - additionally minimize the following %s (which I do not \ - suggest minimizing):" - bot_info.github_name - (pluralize "target" possible_jobs_to_minimize) - in - match possible_jobs_to_minimize with + let unfinished_pipelines_description = + (if base_pipeline_finished then [] else [f "base commit (%s)" base]) + @ if head_pipeline_finished then [] else [f "head commit (%s)" head] + in + let try_again_msg = + match unfinished_pipelines_description with | [] -> - None - | [(reason, {target})] -> - Some (f "%s %s (because %s)\n\n\n" pre_message target reason) - | _ -> - Some - (f "%s\n%s\n\n\n" pre_message - ( possible_jobs_to_minimize - |> List.map ~f:(fun (reason, {target}) -> - f " - %s (because %s)" target reason ) - |> String.concat ~sep:"\n" ) ) + "" + | ls -> + f + "\n\ + However, you may want to try again once the %s for the %s \ + %s." + (pluralize "pipeline" ls) + (ls |> String.concat ~sep:" and ") + (pluralize "finishes" ~plural:"finish" ls) in - match - ( jobs_minimized - , failed_minimization_description - , suggest_jobs - , suggest_only_all_jobs - , suggest_minimization ) - with - | [], None, None, None, _ -> - Lwt_io.printlf - "No candidates found for minimization on %s/%s@%s for PR #%d." - owner repo head pr_number - >>= fun () -> Lwt.return_none - | [], None, None, Some msg, _ -> - Lwt_io.printlf - "No suggested candidates found for minimization on %s/%s@%s \ - for PR #%d:\n\ - %s" - owner repo head pr_number msg - >>= fun () -> Lwt.return_none - | [], None, Some suggestion_msg, _, Error reason -> - Lwt_io.printlf - "Candidates found for minimization on %s/%s@%s for PR #%d, but \ - I am not commenting because minimization is not suggested \ - because %s:\n\ - %s\n\ - %s" - owner repo head pr_number reason suggestion_msg - (Option.value ~default:"" suggest_only_all_jobs) - >>= fun () -> Lwt.return_none - | [], Some failed_minimization_description, _, _, _ -> - Lwt_io.printlf - "Candidates found for auto minimization on %s/%s@%s for PR \ - #%d, but all attempts to trigger minimization failed:\n\ - %s" - owner repo head pr_number failed_minimization_description - >>= fun () -> Lwt.return_none - | [], None, Some suggestion_msg, _, Ok () -> + let may_wish_to_wait_msg = + match unfinished_pipelines_description with + | [] -> + "" + | ls -> + f + "\n\n\ + :warning: :hourglass: You may want to wait until the %s for \ + the %s %s." + (pluralize "pipeline" ls) + (ls |> String.concat ~sep:" and ") + (pluralize "finishes" ~plural:"finish" ls) + in + let note_some_head_unfinished_msg = + if head_pipeline_finished then "" + else f - ":red_circle: CI %s at commit %s without any failure in the \ - test-suite\n\n\ - :heavy_check_mark: Corresponding %s for the base commit %s \ - succeeded\n\n\ - :grey_question: Ask me to try to extract %s that can be added \ - to the test-suite\n\n\ -
%s\n\n\ - - You can also pass me a specific list of targets to minimize \ - as arguments.\n\ - %s\n\ -
%s" - (pluralize "failure" suggested_jobs_to_minimize) + "\n\ + Some jobs may have been missed because the pipeline for the \ + head commit (%s) has not yet finished." head - (pluralize "job" suggested_jobs_to_minimize) + in + let note_some_base_unfinished_msg = + if base_pipeline_finished then "" + else + f + "\n\ + However, minimization may fail because the pipeline for the \ + base commit (%s) has not yet finished." base - (pluralize "a minimal test case" ~plural:"minimal test cases" - suggested_jobs_to_minimize ) - suggestion_msg - (Option.value ~default:"" suggest_only_all_jobs) - may_wish_to_wait_msg + in + ( match (request, jobs_minimized, failed_minimization_description) with + | RequestAll, [], None -> + Lwt.return_some + ( match + bad_and_unminimizable_jobs_description ~f:(fun _ -> true) + with + | None -> + f "No valid CI jobs detected for %s.%s" head try_again_msg + | Some msg -> + f + "I attempted to run all CI jobs at commit %s for \ + minimization, but was unable to find any jobs to \ + minimize.%s\n\n\ + %s" + head try_again_msg msg ) + | RequestAll, _, _ -> + ( match + bad_and_unminimizable_jobs_description ~f:(fun _ -> true) + with + | Some msg -> + Lwt_io.printlf + "When attempting to run CI Minimization by request all on \ + %s/%s@%s for PR #%d:\n\ + %s" + owner repo head pr_number msg + | None -> + Lwt.return_unit ) + >>= fun () -> + ( match jobs_minimized with + | [] -> + f + "I did not succeed at triggering minimization on any jobs \ + at commit %s.%s" + head try_again_msg + | _ :: _ -> + f + "I am now %s minimization at commit %s on %s. I'll come \ + back to you with the results once it's done.%s" + (if Option.is_none bug_file then "running" else "resuming") + head + (jobs_minimized |> String.concat ~sep:", ") + note_some_head_unfinished_msg ) + ^ "\n\n" + ^ Option.value ~default:"" failed_minimization_description |> Lwt.return_some - | _ :: _, _, _, _, _ -> + | RequestExplicit requests, _, _ -> + (* N.B. requests may be things like library:ci-cross_crypto, + while the job targets are things like GitLab CI job + library:ci-cross_crypto (pull request) *) + requests + |> List.partition3_map ~f:(fun request -> + match + ( List.exists + ~f:(string_match ~regexp:(Str.quote request)) + jobs_minimized + , List.find + ~f:(fun (target, _) -> + string_match ~regexp:(Str.quote request) target ) + jobs_that_could_not_be_minimized + , List.find + ~f:(fun (target, _) -> + string_match ~regexp:(Str.quote request) target ) + unminimizable_jobs + , List.find + ~f:(fun (_, {target}) -> + string_match ~regexp:(Str.quote request) target ) + bad_jobs_to_minimize ) + with + | true, _, _, _ -> + `Fst request + | false, Some (target, err), _, _ -> + `Snd + (f "%s: failed to trigger minimization (%s)" target + err ) + | false, None, Some (target, err), _ -> + `Snd (f "%s could not be minimized (%s)" target err) + | false, None, None, Some (reason, {target}) -> + `Snd + (f "%s was not minimized because %s" target reason) + | false, None, None, None -> + `Trd request ) + |> fun ( successful_requests + , unsuccessful_requests + , unfound_requests ) -> + let unsuccessful_requests_report = + match unsuccessful_requests with + | [] -> + None + | [msg] -> + Some msg + | _ -> + Some + ( "The following requests were not fulfilled:\n" + ^ ( unsuccessful_requests + |> List.map ~f:(fun msg -> "- " ^ msg) + |> String.concat ~sep:"\n" ) + ^ "\n\n" ) + in + let unfound_requests_report = + let all_jobs = + List.map + ~f:(fun (target, _) -> target) + jobs_that_could_not_be_minimized + @ List.map ~f:(fun (target, _) -> target) unminimizable_jobs + @ List.map + ~f:(fun (_, {target}) -> target) + bad_jobs_to_minimize + |> List.sort ~compare:String.compare + in + match unfound_requests with + | [] -> + None + | [request] -> + Some + (f + "requested target '%s' could not be found among the \ + jobs %s.%s" + request + (all_jobs |> String.concat ~sep:", ") + note_some_head_unfinished_msg ) + | _ :: _ :: _ -> + Some + (f + "requested targets %s could not be found among the \ + jobs %s.%s" + (unfound_requests |> String.concat ~sep:", ") + (all_jobs |> String.concat ~sep:", ") + note_some_head_unfinished_msg ) + in + let unsuccessful_requests_report = + match + (unsuccessful_requests_report, unfound_requests_report) + with + | None, None -> + None + | Some msg, None -> + Some msg + | None, Some msg -> + Some ("The " ^ msg) + | Some msg1, Some msg2 -> + Some (msg1 ^ "\nAdditionally, the " ^ msg2) + in + ( match (successful_requests, unsuccessful_requests_report) with + | [], None -> + "No CI minimization requests made?" + | [], Some msg -> + "I was unable to minimize any of the CI targets that you \ + requested." ^ try_again_msg ^ "\n" ^ msg + | _ :: _, _ -> + f + "I am now %s minimization at commit %s on requested %s %s. \ + I'll come back to you with the results once it's done.%s\n\n\ + %s" + (if Option.is_none bug_file then "running" else "resuming") + head + (pluralize "target" successful_requests) + (successful_requests |> String.concat ~sep:", ") + note_some_base_unfinished_msg + (Option.value ~default:"" unsuccessful_requests_report) ) + |> Lwt.return_some + | RequestSuggested, [], None -> + ( match possible_jobs_to_minimize with + | [] -> + f "No CI jobs are available to be minimized for commit %s.%s" + head try_again_msg + | _ :: _ -> + f + "You requested minimization of suggested failing CI jobs, \ + but no jobs were suggested at commit %s. You can trigger \ + minimization of %s with `ci minimize all` or by \ + requesting some targets by name.%s" + head + ( possible_jobs_to_minimize + |> List.map ~f:(fun (_, {target}) -> target) + |> String.concat ~sep:", " ) + may_wish_to_wait_msg ) + |> Lwt.return_some + | RequestSuggested, [], Some failed_minimization_description -> f - ":red_circle: CI %s at commit %s without any failure in the \ - test-suite\n\n\ - :heavy_check_mark: Corresponding %s for the base commit %s \ - succeeded\n\n\ -
:runner: I have automatically started \ - minimization for %s to augment the test-suite\n\n\ - - You can also pass me a specific list of targets to minimize \ - as arguments.\n\ - %s\n\ -
" - (pluralize "failure" jobs_minimized) + "I attempted to minimize suggested failing CI jobs at commit \ + %s, but was unable to succeed on any jobs.%s\n\ + %s" + head try_again_msg failed_minimization_description + |> Lwt.return_some + | RequestSuggested, _ :: _, _ -> + f + "I have initiated minimization at commit %s for the suggested \ + %s %s as requested.%s\n\n\ + %s" head - (pluralize "job" jobs_minimized) - base + (pluralize "target" jobs_minimized) (jobs_minimized |> String.concat ~sep:", ") - (Option.value ~default:"" suggest_only_all_jobs) - |> Lwt.return_some ) ) - >>= function - | Some message -> - GitHub_mutations.post_comment ~id:comment_thread_id ~message ~bot_info - >>= GitHub_mutations.report_on_posting_comment - | None -> - Lwt_io.printlf - "NOT commenting with CI minimization information at %s/%s@%s (PR \ - #%d)." - owner repo head pr_number ) + try_again_msg + (Option.value ~default:"" failed_minimization_description) + |> Lwt.return_some + | Auto, jobs_minimized, failed_minimization_description -> ( + ( match + bad_and_unminimizable_jobs_description ~f:(fun _ -> true) + with + | Some msg -> + Lwt_io.printlf + "When attempting to run CI Minimization by auto on \ + %s/%s@%s for PR #%d:\n\ + %s" + owner repo head pr_number msg + | None -> + Lwt.return_unit ) + >>= fun () -> + let suggest_jobs = + match suggested_jobs_to_minimize with + | [] -> + None + | _ -> + Some + (f + ":runner: @%s ci minimize will minimize \ + the following %s: %s" + bot_info.github_name + (pluralize "target" suggested_jobs_to_minimize) + ( suggested_jobs_to_minimize + |> List.map ~f:(fun {target} -> target) + |> String.concat ~sep:", " ) ) + in + let suggest_only_all_jobs = + let pre_message = + f + "- If you tag me saying `@%s ci minimize all`, I will \ + additionally minimize the following %s (which I do not \ + suggest minimizing):" + bot_info.github_name + (pluralize "target" possible_jobs_to_minimize) + in + match possible_jobs_to_minimize with + | [] -> + None + | [(reason, {target})] -> + Some + (f "%s %s (because %s)\n\n\n" pre_message target reason) + | _ -> + Some + (f "%s\n%s\n\n\n" pre_message + ( possible_jobs_to_minimize + |> List.map ~f:(fun (reason, {target}) -> + f " - %s (because %s)" target reason ) + |> String.concat ~sep:"\n" ) ) + in + match + ( jobs_minimized + , failed_minimization_description + , suggest_jobs + , suggest_only_all_jobs + , suggest_minimization ) + with + | [], None, None, None, _ -> + Lwt_io.printlf + "No candidates found for minimization on %s/%s@%s for PR \ + #%d." + owner repo head pr_number + >>= fun () -> Lwt.return_none + | [], None, None, Some msg, _ -> + Lwt_io.printlf + "No suggested candidates found for minimization on \ + %s/%s@%s for PR #%d:\n\ + %s" + owner repo head pr_number msg + >>= fun () -> Lwt.return_none + | [], None, Some suggestion_msg, _, Error reason -> + Lwt_io.printlf + "Candidates found for minimization on %s/%s@%s for PR #%d, \ + but I am not commenting because minimization is not \ + suggested because %s:\n\ + %s\n\ + %s" + owner repo head pr_number reason suggestion_msg + (Option.value ~default:"" suggest_only_all_jobs) + >>= fun () -> Lwt.return_none + | [], Some failed_minimization_description, _, _, _ -> + Lwt_io.printlf + "Candidates found for auto minimization on %s/%s@%s for PR \ + #%d, but all attempts to trigger minimization failed:\n\ + %s" + owner repo head pr_number failed_minimization_description + >>= fun () -> Lwt.return_none + | [], None, Some suggestion_msg, _, Ok () -> + f + ":red_circle: CI %s at commit %s without any failure in \ + the test-suite\n\n\ + :heavy_check_mark: Corresponding %s for the base commit \ + %s succeeded\n\n\ + :grey_question: Ask me to try to extract %s that can be \ + added to the test-suite\n\n\ +
%s\n\n\ + - You can also pass me a specific list of targets to \ + minimize as arguments.\n\ + %s\n\ +
%s" + (pluralize "failure" suggested_jobs_to_minimize) + head + (pluralize "job" suggested_jobs_to_minimize) + base + (pluralize "a minimal test case" + ~plural:"minimal test cases" suggested_jobs_to_minimize ) + suggestion_msg + (Option.value ~default:"" suggest_only_all_jobs) + may_wish_to_wait_msg + |> Lwt.return_some + | _ :: _, _, _, _, _ -> + f + ":red_circle: CI %s at commit %s without any failure in \ + the test-suite\n\n\ + :heavy_check_mark: Corresponding %s for the base commit \ + %s succeeded\n\n\ +
:runner: I have automatically started \ + minimization for %s to augment the test-suite\n\n\ + - You can also pass me a specific list of targets to \ + minimize as arguments.\n\ + %s\n\ +
" + (pluralize "failure" jobs_minimized) + head + (pluralize "job" jobs_minimized) + base + (jobs_minimized |> String.concat ~sep:", ") + (Option.value ~default:"" suggest_only_all_jobs) + |> Lwt.return_some ) ) + >>= function + | Some message -> + GitHub_mutations.post_comment ~id:comment_thread_id ~message + ~bot_info + >>= GitHub_mutations.report_on_posting_comment + | None -> + Lwt_io.printlf + "NOT commenting with CI minimization information at %s/%s@%s \ + (PR #%d)." + owner repo head pr_number ) + | Error err -> + let message = run_ci_minimization_error_to_string err in + if comment_on_error then + GitHub_mutations.post_comment ~id:comment_thread_id ~message + ~bot_info + >>= GitHub_mutations.report_on_posting_comment + else + Lwt_io.printlf "Error while attempting to minimize from PR #%d:\n%s" + pr_number message ) | Error (Some comment_thread_id, err) when comment_on_error -> GitHub_mutations.post_comment ~id:comment_thread_id ~message: @@ -1751,7 +1882,7 @@ let minimize_failed_tests ~bot_info ~owner ~repo ~pr_number pr_number err let ci_minimize ~bot_info ~comment_info ~requests ~comment_on_error ~options - ~bug_file_contents = + ~bug_file = minimize_failed_tests ~bot_info ~owner:comment_info.issue.issue.owner ~repo:comment_info.issue.issue.repo ~pr_number:comment_info.issue.number ~head_pipeline_summary:None @@ -1763,7 +1894,7 @@ let ci_minimize ~bot_info ~comment_info ~requests ~comment_on_error ~options RequestAll | requests -> RequestExplicit requests ) - ~comment_on_error ~options ~bug_file_contents () + ~comment_on_error ~options ~bug_file () let pipeline_action ~bot_info ({common_info= {http_repo_url}} as pipeline_info) ~gitlab_mapping : unit Lwt.t = @@ -1890,17 +2021,12 @@ let pipeline_action ~bot_info ({common_info= {http_repo_url}} as pipeline_info) minimize_failed_tests ~bot_info ~owner:gh_owner ~repo:gh_repo ~pr_number ~head_pipeline_summary:(Some summary) ~request:Auto - ~comment_on_error:false ~options:"" - ~bug_file_contents:None + ~comment_on_error:false ~options:"" ~bug_file:None ?base_sha:pipeline_info.common_info.base_commit ~head_sha:pipeline_info.common_info.head_commit () | _ -> Lwt.return_unit ) ) ) ) -type coqbot_minimize_script_data = - | MinimizeScript of {quote_kind: string; body: string} - | MinimizeAttachment of {description: string; url: string} - let run_coq_minimizer ~bot_info ~script ~comment_thread_id ~comment_author ~owner ~repo ~options = let options = format_options_for_getopts options in @@ -2028,15 +2154,18 @@ let coq_bug_minimizer_resume_ci_minimization_action ~bot_info ~key ~app_id body ; passing_urls ; docker_image ; full_target= target (* dummy value *) } ] - ~bug_file_contents:(Some bug_file_contents) ) + ~bug_file: + (Some + (MinimizeScript + {quote_kind= ""; body= bug_file_contents} ) ) ) >>= function - | [], [] -> + | Ok ([], []) -> Lwt_io.printlf "Somehow no jobs were returned from minimization \ resumption?\n\ %s" message - | jobs_minimized, jobs_that_could_not_be_minimized -> ( + | Ok (jobs_minimized, jobs_that_could_not_be_minimized) -> ( ( match jobs_minimized with | [] -> Lwt.return_unit @@ -2053,7 +2182,15 @@ let coq_bug_minimizer_resume_ci_minimization_action ~bot_info ~key ~app_id body Lwt.return_unit | msgs -> Lwt_io.printlf "Could not resume minimization of %s" - (msgs |> String.concat ~sep:", ") ) ) + (msgs |> String.concat ~sep:", ") ) + | Error err -> + Lwt_io.printlf + "Internal error (should not happen because no url was \ + passed):\n\ + Could not resume minimization of %s for %s/%s#%s:\n\ + %s" + target owner repo pr_number + (run_ci_minimization_error_to_string err) ) |> Lwt.async ; Server.respond_string ~status:`OK ~body:"Handling CI minimization resumption." () diff --git a/src/actions.mli b/src/actions.mli index 7630d62f..578204dc 100644 --- a/src/actions.mli +++ b/src/actions.mli @@ -103,7 +103,7 @@ val ci_minimize : -> requests:string list -> comment_on_error:bool -> options:string - -> bug_file_contents:string option + -> bug_file:coqbot_minimize_script_data option -> unit Lwt.t val coq_bug_minimizer_resume_ci_minimization_action : diff --git a/src/bot.ml b/src/bot.ml index 95e7ed28..bfd768e4 100644 --- a/src/bot.ml +++ b/src/bot.ml @@ -54,6 +54,17 @@ let callback _conn req body = |> Str.split (Str.regexp_string "\n```") |> List.hd |> Option.value ~default:"" in + let extract_minimize_script quote_kind body = + MinimizeScript + { quote_kind= quote_kind |> Str.global_replace (Str.regexp "[ \r]") "" + ; body= body |> extract_minimize_file } + in + let extract_minimize_url url = + url |> Str.global_replace (Str.regexp "^[` ]+\\|[` ]+$") "" + in + let extract_minimize_attachment ?(description = "") url = + MinimizeAttachment {description; url= url |> extract_minimize_url} + in let parse_minimiation_requests requests = requests |> Str.global_replace (Str.regexp "[ ,]+") " " @@ -81,12 +92,7 @@ let callback _conn req body = , Str.matched_group 2 body , Str.matched_group 3 body ) in - Some - ( options - , MinimizeScript - { quote_kind= - quote_kind |> Str.global_replace (Str.regexp "[ \r]") "" - ; body= body |> extract_minimize_file } ) + Some (options, extract_minimize_script quote_kind body) else if string_match ~regexp: @@ -100,7 +106,7 @@ let callback _conn req body = , Str.matched_group 2 body , Str.matched_group 3 body ) in - Some (options, MinimizeAttachment {description; url}) + Some (options, extract_minimize_attachment ~description url) else None in let coqbot_ci_minimize_text_of_body body = @@ -125,14 +131,59 @@ let callback _conn req body = "@%s:?\\( [^\n\ ]*\\)\\bresume [Cc][Ii][- ][Mm]inimiz\\(e\\|ation\\):?\\([^\n\ ]*\\)\n\ - +```[^\n\ - ]*\n\ + +```\\([^\n\ + ]*\\)\n\ \\(\\(.\\|\n\ \\)+\\)" @@ Str.quote github_bot_name ) body then - let options, requests, body = + let options, requests, quote_kind, body = + ( Str.matched_group 1 body + , Str.matched_group 3 body + , Str.matched_group 4 body + , Str.matched_group 5 body ) + in + Some + ( options + , requests |> parse_minimiation_requests + , extract_minimize_script quote_kind body ) + else if + string_match + ~regexp: + ( f + "@%s:?\\( [^\n\ + ]*\\)\\bresume [Cc][Ii][- ][Mm]inimiz\\(e\\|ation\\):?[ \n\ + ]+\\([^ \n\ + ]+\\)[ \n\ + ]+\\[\\([^]]*\\)\\] *(\\([^)]*\\))" + @@ Str.quote github_bot_name ) + body + then + let options, requests, description, url = + ( Str.matched_group 1 body + , Str.matched_group 3 body + , Str.matched_group 4 body + , Str.matched_group 5 body ) + in + Some + ( options + , requests |> parse_minimiation_requests + , extract_minimize_attachment ~description url ) + else if + string_match + ~regexp: + ( f + "@%s:?\\( [^\n\ + ]*\\)\\bresume [Cc][Ii][- ][Mm]inimiz\\(e\\|ation\\):?[ \n\ + ]+\\([^ \n\ + ]+\\)[ \n\ + ]+\\(https?://[^ \n\ + ]+\\)" + @@ Str.quote github_bot_name ) + body + then + let options, requests, url = ( Str.matched_group 1 body , Str.matched_group 3 body , Str.matched_group 4 body ) @@ -140,7 +191,7 @@ let callback _conn req body = Some ( options , requests |> parse_minimiation_requests - , body |> extract_minimize_file ) + , extract_minimize_attachment url ) else None in ( coqbot_minimize_text_of_body @@ -363,14 +414,14 @@ let callback _conn req body = don't want to parse "resume" as an option, we test resumption first *) match coqbot_resume_ci_minimize_text_of_body body with - | Some (options, requests, bug_file_contents) -> + | Some (options, requests, bug_file) -> (fun () -> init_git_bare_repository ~bot_info >>= fun () -> action_as_github_app ~bot_info ~key ~app_id ~owner:comment_info.issue.issue.owner (ci_minimize ~comment_info ~requests ~comment_on_error:true - ~options ~bug_file_contents:(Some bug_file_contents) ) ) + ~options ~bug_file:(Some bug_file) ) ) |> Lwt.async ; Server.respond_string ~status:`OK ~body:"Handling CI minimization resumption." () @@ -383,8 +434,7 @@ let callback _conn req body = action_as_github_app ~bot_info ~key ~app_id ~owner:comment_info.issue.issue.owner (ci_minimize ~comment_info ~requests - ~comment_on_error:true ~options ~bug_file_contents:None ) - ) + ~comment_on_error:true ~options ~bug_file:None ) ) |> Lwt.async ; Server.respond_string ~status:`OK ~body:"Handling CI minimization." () diff --git a/src/helpers.ml b/src/helpers.ml index 4ac155fc..00076b35 100644 --- a/src/helpers.ml +++ b/src/helpers.ml @@ -1,4 +1,8 @@ open Base +open Lwt.Syntax +open Cohttp +open Cohttp_lwt +open Cohttp_lwt_unix let f = Printf.sprintf @@ -131,3 +135,37 @@ let github_repo_of_gitlab_url ~gitlab_mapping ~http_repo_url = |> Result.map ~f:(fun (gitlab_domain, gitlab_repo_full_name) -> github_repo_of_gitlab_project_path ~gitlab_mapping ~gitlab_domain ~gitlab_repo_full_name ) + +let download_cps ~uri ~with_file = + let open Lwt.Infix in + let rec inner_download uri = + let* resp, body = Client.get uri in + match Response.status resp with + | `OK -> + let stream = Body.to_stream body in + with_file (fun chan -> Lwt_stream.iter_s (Lwt_io.write chan) stream) + >>= Lwt.return_ok + | `Moved_permanently + | `Found + | `See_other + | `Temporary_redirect + | `Permanent_redirect -> ( + match Header.get_location (Response.headers resp) with + | Some new_uri -> + inner_download new_uri + | None -> + f "Redirected from %s, but no Location header found" + (Uri.to_string uri) + |> Lwt.return_error ) + | status_code -> + f "HTTP request to %s failed with status code: %s" (Uri.to_string uri) + (Code.string_of_status status_code) + |> Lwt.return_error + in + inner_download uri + +let download ~uri dest = + download_cps ~uri ~with_file:(Lwt_io.with_file ~mode:Lwt_io.output dest) + +let download_to ~uri chan = + download_cps ~uri ~with_file:(fun write_to -> write_to chan) diff --git a/src/helpers.mli b/src/helpers.mli index c3a32fb8..f5c65e3c 100644 --- a/src/helpers.mli +++ b/src/helpers.mli @@ -35,3 +35,8 @@ val github_repo_of_gitlab_url : gitlab_mapping:(string, string) Base.Hashtbl.t -> http_repo_url:string -> (string * string, string) result + +val download : uri:Uri.t -> string -> (unit, string) Lwt_result.t + +val download_to : + uri:Uri.t -> Lwt_io.output_channel -> (unit, string) Lwt_result.t