Support coqbot resume ci minimize ci-foo url

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