Support coqbot resume ci minimize ci-foo url (#298)

Some notes on usage:
- Both `ci minimize ci-foo https://...` and `ci minimize ci-foo [description](url)` are supported.
- you can directly link to the artifacts of previous runs, such as the `tmp.v` file, and coqbot will unpack the artifact
- other links need to be to text files that are the buggy file (you can upload it as .txt or .v.txt or .log or w/e)
- plausibly in the future we can support non-artifact links to .zip files and .tar.gz files, etc; in the interim, I don't expect this to be a big issue

Author: JasonGross

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: [

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)) )

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

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)

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

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

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)))
 )