Move src/helpers to bot-components (#351)

Depend on #350 
- Move `src/helpers` to `bot-components/Utils.ml`
- Split `bot-components/Utils` to
  - `String_utils`
  - `HTTP_utils`
  - Move functions related to Git operations to `Git_utils`

Author: lykimq

bot-components/GitHub_app.ml

@@ -39,13 +39,17 @@ let make_jwt ~key ~app_id =
 
 let get ~bot_info ~token ~url =
   let* () = Lwt_io.printl ("Making get request to " ^ url) in
-  let headers = headers (github_headers token) bot_info.Bot_info.github_name in
+  let headers =
+    HTTP_utils.headers (github_headers token) bot_info.Bot_info.github_name
+  in
   let* _response, body = Client.get ~headers (Uri.of_string url) in
   Cohttp_lwt.Body.to_string body
 
 let post ~bot_info ~body ~token ~url =
   let* () = Lwt_io.printl ("Making post request to " ^ url) in
-  let headers = headers (github_headers token) bot_info.Bot_info.github_name in
+  let headers =
+    HTTP_utils.headers (github_headers token) bot_info.Bot_info.github_name
+  in
   let body =
     (match body with None -> "{}" | Some json -> Yojson.to_string json)
     |> Cohttp_lwt.Body.of_string

bot-components/GitHub_mutations.ml

@@ -280,15 +280,17 @@ let remove_labels ~bot_info ~labels ~issue =
 (* TODO: use GraphQL API *)
 
 let remove_milestone ~bot_info (issue : issue) =
-  let headers = headers (github_header bot_info) bot_info.github_name in
+  let headers =
+    HTTP_utils.headers (HTTP_utils.github_header bot_info) bot_info.github_name
+  in
   let uri =
     f "https://api.github.com/repos/%s/%s/issues/%d" issue.owner issue.repo
       issue.number
     |> Uri.of_string
   in
   let body = {|{"milestone": null}|} |> Cohttp_lwt.Body.of_string in
   Lwt_io.printf "Sending patch request.\n"
-  >>= fun () -> Client.patch ~headers ~body uri >>= print_response
+  >>= fun () -> Client.patch ~headers ~body uri >>= HTTP_utils.print_response
 
 let send_status_check ~bot_info ~repo_full_name ~commit ~state ~url ~context
     ~description =
@@ -305,4 +307,6 @@ let send_status_check ~bot_info ~repo_full_name ~commit ~state ~url ~context
     "https://api.github.com/repos/" ^ repo_full_name ^ "/statuses/" ^ commit
     |> Uri.of_string
   in
-  send_request ~body ~uri (github_header bot_info) bot_info.github_name
+  HTTP_utils.send_request ~body ~uri
+    (HTTP_utils.github_header bot_info)
+    bot_info.github_name

bot-components/GitHub_queries.ml

@@ -16,23 +16,23 @@ let extract_backport_info ~(bot_info : Bot_info.t) description :
   let backport_info_unit = main_regexp ^ "; \\(.*\\)$" in
   let end_regexp = main_regexp in
   let rec aux description =
-    if string_match ~regexp:backport_info_unit description then
+    if String_utils.string_match ~regexp:backport_info_unit description then
       let backport_to = Str.matched_group 1 description in
       let rejected_milestone =
         Str.matched_group 2 description |> Int.of_string
       in
       Str.matched_group 3 description
       |> aux
       |> List.cons {backport_to; rejected_milestone}
-    else if string_match ~regexp:end_regexp description then
+    else if String_utils.string_match ~regexp:end_regexp description then
       let backport_to = Str.matched_group 1 description in
       let rejected_milestone =
         Str.matched_group 2 description |> Int.of_string
       in
       [{backport_to; rejected_milestone}]
     else []
   in
-  if string_match ~regexp:begin_regexp description then
+  if String_utils.string_match ~regexp:begin_regexp description then
     Str.matched_group 1 description |> aux
   else []
 
@@ -1025,7 +1025,7 @@ let get_project_field_values ~bot_info ~organization ~project ~field ~options =
       Lwt.return_error err
 
 let get_artifact_blob ~bot_info ~owner ~repo ~artifact_id =
-  generic_get_zip ~bot_info
+  HTTP_utils.github_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)) )

bot-components/GitHub_subscriptions.ml

@@ -28,7 +28,8 @@ let issue_info_of_json ?issue_json json =
       (match issue_json |> member "milestone" with `Null -> false | _ -> true)
   ; pull_request=
       issue_json |> member "html_url" |> to_string
-      |> string_match ~regexp:"https://github.com/[^/]*/[^/]*/pull/[0-9]*"
+      |> String_utils.string_match
+           ~regexp:"https://github.com/[^/]*/[^/]*/pull/[0-9]*"
   ; body= issue_json |> member "body" |> to_string_option
   ; assignees=
       issue_json |> member "assignees" |> to_list

bot-components/GitLab_mutations.ml

@@ -11,7 +11,8 @@ let generic_retry ~bot_info ~gitlab_domain ~url_part =
       Lwt_io.printlf "Error when retrying job %s: %s." url_part err
   | Ok (name, token) ->
       let gitlab_header = [("Private-Token", token)] in
-      Utils.send_request ~body:Cohttp_lwt.Body.empty ~uri gitlab_header name
+      HTTP_utils.send_request ~body:Cohttp_lwt.Body.empty ~uri gitlab_header
+        name
 
 let retry_job ~bot_info ~gitlab_domain ~project_id ~build_id =
   generic_retry ~bot_info ~gitlab_domain
@@ -46,4 +47,4 @@ let play_job ~bot_info ~gitlab_domain ~project_id ~build_id
             |> f {|{ "job_variables_attributes": [%s] }|}
             |> Cohttp_lwt.Body.of_string
       in
-      Utils.send_request ~body ~uri gitlab_header name
+      HTTP_utils.send_request ~body ~uri gitlab_header name

bot-components/GitLab_queries.ml

@@ -17,7 +17,7 @@ let get_build_trace ~bot_info ~gitlab_domain ~project_id ~build_id =
   |> Lwt.return
   >>= fun (name, token) ->
   let gitlab_header = [("Private-Token", token)] in
-  let headers = Utils.headers gitlab_header name in
+  let headers = HTTP_utils.headers gitlab_header name in
   let open Lwt.Infix in
   Client.get ~headers uri
   >>= fun (_response, body) ->

bot-components/GitLab_subscriptions.ml

@@ -9,7 +9,7 @@ let extract_commit json =
   let commit_json = json |> member "commit" in
   let message = commit_json |> member "message" |> to_string in
   if
-    string_match
+    String_utils.string_match
       ~regexp:"Bot merge \\([a-zA-Z0-9]*\\) [a-z]* \\([a-zA-Z0-9]*\\)" message
   then (Some (Str.matched_group 1 message), Str.matched_group 2 message)
   else

bot-components/Git_utils.ml

@@ -93,8 +93,12 @@ let execute_cmd ?(mask = []) command =
   Lwt_io.printf "Executing command: %s\n" command
   >>= fun () ->
   let process = Lwt_process.open_process_full (Lwt_process.shell command) in
-  let stdout_pipe = Utils.copy_stream ~src:process#stdout ~dst:Lwt_io.stdout in
-  let stderr_pipe = Utils.copy_stream ~src:process#stderr ~dst:Lwt_io.stderr in
+  let stdout_pipe =
+    HTTP_utils.copy_stream ~src:process#stdout ~dst:Lwt_io.stdout
+  in
+  let stderr_pipe =
+    HTTP_utils.copy_stream ~src:process#stderr ~dst:Lwt_io.stderr
+  in
   (* Capture stdout and stderr in parallel *)
   (* Wait for the process to finish *)
   let+ _stdout_content = stdout_pipe
@@ -161,3 +165,123 @@ let git_test_modified ~base ~head pattern =
       Error (f "%s killed by signal %d." command signal)
   | Unix.WSTOPPED signal ->
       Error (f "%s stopped by signal %d." command signal)
+
+let git_coq_bug_minimizer ~bot_info ~script ~comment_thread_id ~comment_author
+    ~owner ~repo ~coq_version ~ocaml_version ~minimizer_extra_arguments =
+  (* To push a new branch we need to identify as coqbot the GitHub
+     user, who is a collaborator on the run-coq-bug-minimizer repo,
+     not coqbot the GitHub App *)
+  Stdlib.Filename.quote_command "./coq_bug_minimizer.sh"
+    [ script
+    ; GitHub_ID.to_string comment_thread_id
+    ; comment_author
+    ; bot_info.github_pat
+    ; bot_info.github_name
+    ; bot_info.domain
+    ; owner
+    ; repo
+    ; coq_version
+    ; ocaml_version
+    ; String.concat ~sep:" " minimizer_extra_arguments ]
+  |> execute_cmd ~mask:[bot_info.github_pat]
+
+let git_run_ci_minimization ~bot_info ~comment_thread_id ~owner ~repo ~pr_number
+    ~docker_image ~target ~ci_targets ~opam_switch ~failing_urls ~passing_urls
+    ~base ~head ~minimizer_extra_arguments ~bug_file_name =
+  (* To push a new branch we need to identify as coqbot the GitHub
+     user, who is a collaborator on the run-coq-bug-minimizer repo,
+     not coqbot the GitHub App *)
+  ( [ GitHub_ID.to_string comment_thread_id
+    ; bot_info.github_pat
+    ; bot_info.github_name
+    ; bot_info.domain
+    ; owner
+    ; repo
+    ; pr_number
+    ; docker_image
+    ; target
+    ; String.concat ~sep:" " ci_targets
+    ; opam_switch
+    ; failing_urls
+    ; passing_urls
+    ; base
+    ; head
+    ; String.concat ~sep:" " minimizer_extra_arguments ]
+  @
+  match bug_file_name with Some bug_file_name -> [bug_file_name] | None -> [] )
+  |> Stdlib.Filename.quote_command "./run_ci_minimization.sh"
+  |> execute_cmd ~mask:[bot_info.github_pat]
+
+let pr_from_branch branch =
+  if String_utils.string_match ~regexp:"^pr-\\([0-9]*\\)$" branch then
+    (Some (Str.matched_group 1 branch |> Int.of_string), "pull request")
+  else (None, "branch")
+
+let github_repo_of_gitlab_project_path ~gitlab_mapping ~gitlab_domain
+    ~gitlab_repo_full_name =
+  let full_name_with_domain = gitlab_domain ^ "/" ^ gitlab_repo_full_name in
+  let github_full_name =
+    match Hashtbl.find gitlab_mapping full_name_with_domain with
+    | Some value ->
+        value
+    | None ->
+        Stdio.printf
+          "Warning: No correspondence found for GitLab repository %s.\n"
+          full_name_with_domain ;
+        gitlab_repo_full_name
+  in
+  match Str.split (Str.regexp "/") github_full_name with
+  | [owner; repo] ->
+      (owner, repo)
+  | _ ->
+      failwith
+        (f "Could not split repository full name %s into (owner, repo)."
+           github_full_name )
+
+let parse_gitlab_repo_url ~http_repo_url =
+  if
+    not
+      (String_utils.string_match ~regexp:"https?://\\([^/]*\\)/\\(.*/.*\\)"
+         http_repo_url )
+  then
+    Result.Error (f "Could not parse GitLab repository URL %s." http_repo_url)
+  else
+    Result.Ok
+      (Str.matched_group 1 http_repo_url, Str.matched_group 2 http_repo_url)
+
+let parse_gitlab_repo_url_and_print ~http_repo_url =
+  match parse_gitlab_repo_url ~http_repo_url with
+  | Ok (gitlab_domain, gitlab_repo_full_name) ->
+      Stdio.printf "GitLab domain: \"%s\"\n" gitlab_domain ;
+      Stdio.printf "GitLab repository full name: \"%s\"\n" gitlab_repo_full_name
+  | Error msg ->
+      Stdio.print_endline msg
+
+let%expect_test "http_repo_url_parsing_coq" =
+  parse_gitlab_repo_url_and_print ~http_repo_url:"https://gitlab.com/coq/coq" ;
+  [%expect
+    {|
+   GitLab domain: "gitlab.com"
+   GitLab repository full name: "coq/coq" |}]
+
+let%expect_test "http_repo_url_parsing_mathcomp" =
+  parse_gitlab_repo_url_and_print
+    ~http_repo_url:"https://gitlab.inria.fr/math-comp/math-comp" ;
+  [%expect
+    {|
+  GitLab domain: "gitlab.inria.fr"
+  GitLab repository full name: "math-comp/math-comp" |}]
+
+let%expect_test "http_repo_url_parsing_example_from_gitlab_docs" =
+  parse_gitlab_repo_url_and_print
+    ~http_repo_url:"https://gitlab.example.com/gitlab-org/gitlab-test" ;
+  [%expect
+    {|
+  GitLab domain: "gitlab.example.com"
+  GitLab repository full name: "gitlab-org/gitlab-test" |}]
+
+let github_repo_of_gitlab_url ~gitlab_mapping ~http_repo_url =
+  parse_gitlab_repo_url ~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 )

bot-components/Git_utils.mli

@@ -40,3 +40,49 @@ val git_make_ancestor :
 
 val git_test_modified :
   base:string -> head:string -> string -> (bool, string) result Lwt.t
+
+val git_coq_bug_minimizer :
+     bot_info:Bot_info.t
+  -> script:string
+  -> comment_thread_id:GitHub_ID.t
+  -> comment_author:string
+  -> owner:string
+  -> repo:string
+  -> coq_version:string
+  -> ocaml_version:string
+  -> minimizer_extra_arguments:string list
+  -> (unit, string) result Lwt.t
+
+val git_run_ci_minimization :
+     bot_info:Bot_info.t
+  -> comment_thread_id:GitHub_ID.t
+  -> owner:string
+  -> repo:string
+  -> pr_number:string
+  -> docker_image:string
+  -> target:string
+  -> ci_targets:string list
+  -> opam_switch:string
+  -> failing_urls:string
+  -> passing_urls:string
+  -> base:string
+  -> head:string
+  -> minimizer_extra_arguments:string list
+  -> bug_file_name:string option
+  -> (unit, string) result Lwt.t
+
+val pr_from_branch : string -> int option * string
+
+val github_repo_of_gitlab_project_path :
+     gitlab_mapping:(string, string) Base.Hashtbl.t
+  -> gitlab_domain:string
+  -> gitlab_repo_full_name:string
+  -> string * string
+
+val parse_gitlab_repo_url :
+  http_repo_url:string -> (string * string, string) result
+
+val github_repo_of_gitlab_url :
+     gitlab_mapping:(string, string) Base.Hashtbl.t
+  -> http_repo_url:string
+  -> (string * string, string) result