Fix support for url-based resumption via github api

bot-components/GitHub_queries.ml

@@ -1034,3 +1034,9 @@ let get_pull_request_labels ~bot_info ~owner ~repo ~pr_number =
         Lwt.return @@ Error err
   in
   get_list getter
+
+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

@@ -137,3 +137,10 @@ val get_pull_request_labels :
   -> repo:string
   -> pr_number:int
   -> (string list, 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,26 @@ let handle_json action body =
   | Yojson.Basic.Util.Type_error (err, _) ->
       Error (f "Json type error: %s\n" err)
 
+let handle_zip action body_stream =
+  Lwt_io.with_temp_file (fun (tmp_name, tmp_channel) ->
+      body_stream
+      |> Lwt_stream.iter_s (Lwt_io.write tmp_channel)
+      >>= fun () ->
+      Lwt_io.close tmp_channel
+      >>= Lwt_preemptive.detach (fun () ->
+              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
+              zip_entries ) )
+  >|= action >>= Lwt.return_ok
+
 (* GitHub specific *)
 
 let project_api_preview_header =
@@ -51,6 +72,8 @@ 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)]
 
@@ -62,3 +85,12 @@ let generic_get ~bot_info relative_uri ?(header_list = []) json_handler =
   Client.get ~headers uri
   >>= (fun (_response, body) -> Cohttp_lwt.Body.to_string body)
   >|= handle_json json_handler
+
+let generic_get_zip ~bot_info relative_uri ?(header_list = []) zip_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
+  Client.get ~headers uri
+  >>= fun (_response, body) ->
+  Cohttp_lwt.Body.to_stream body |> handle_zip zip_handler

bot-components/Utils.mli

@@ -17,6 +17,8 @@ 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 :
@@ -25,3 +27,10 @@ val generic_get :
   -> ?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