Add response headers to head results

aws-s3/s3.ml

@@ -85,10 +85,21 @@ module Protocol(P: sig type 'a result end) = struct
     last_modified: time [@key "LastModified"];
     key: string [@key "Key"];
     etag: etag [@key "ETag"];
+    response_headers: (string * string) list option; [@default None]
     meta_headers: (string * string) list option; [@default None]
     (** Add expiration date option *)
   } [@@deriving of_protocol ~driver:(module Protocol_conv_xmlm.Xmlm)]
 
+  (* The server picks the case it sends a header name in. *)
+  let find_header ~name content =
+    let name = String.lowercase_ascii name in
+    match content.response_headers with
+    | None -> None
+    | Some headers ->
+      match List.find_opt ~f:(fun (key, _) -> String.lowercase_ascii key = name) headers with
+      | Some (_, value) -> Some value
+      | None -> None
+
   module Ls = struct
 
     type result = {
@@ -371,6 +382,7 @@ module Make(Io : Types.Io) = struct
       Aws.make_request ?credentials ?connect_timeout_ms ~endpoint ~headers ~meth:`HEAD ~path ~query:[] ~sink ()
     in
     do_command ~endpoint cmd >>=? fun headers ->
+    let response_headers = Some (Headers.bindings headers) in
     let result =
       let (>>=) a f = match a with
         | Some x -> f x
@@ -388,7 +400,8 @@ module Make(Io : Types.Io) = struct
             storage_class_of_xmlm_exn (make_xmlm_node "p" [] [`Data s])
         )
       in
-      Some { storage_class; size; last_modified; key; etag = unquote etag; meta_headers = Some meta_headers}
+      Some { storage_class; size; last_modified; key; etag = unquote etag;
+             response_headers; meta_headers = Some meta_headers }
     in
     match result with
     | Some r -> Deferred.return (Ok r)
@@ -693,6 +706,42 @@ let%test "parse Error_response.t" =
   let error = Protocol.Error_response.of_xmlm_exn xml in
   "PermanentRedirect" = error.Protocol.Error_response.code
 
+let%test "response_headers is None in XML-parsed content" =
+  let module Protocol = Protocol(struct type 'a result = 'a end) in
+  let data = {|
+      <ListBucketResult>
+        <Name>s3_osd</Name>
+        <Prefix></Prefix>
+        <KeyCount>1</KeyCount>
+        <MaxKeys>1000</MaxKeys>
+        <IsTruncated>false</IsTruncated>
+        <Contents>
+          <StorageClass>STANDARD</StorageClass>
+          <Key>test</Key>
+          <LastModified>2018-02-27T13:39:35.000Z</LastModified>
+          <ETag>"7538d2bd85ea5dfb689ed65a0f60a7aa"</ETag>
+          <Size>20</Size>
+        </Contents>
+      </ListBucketResult>
+      |}
+  in
+  let xml = xmlm_of_string data in
+  let result = Protocol.Ls.result_of_xmlm_exn xml in
+  let c = List.hd result.Protocol.Ls.contents in
+  c.Protocol.response_headers = None
+
+let%test "find_header ignores the case the server chose" =
+  let module Protocol = Protocol(struct type 'a result = 'a end) in
+  let content =
+    { Protocol.storage_class = Protocol.Standard; size = 0; last_modified = 0.;
+      key = "test"; etag = "e";
+      response_headers = Some ["Content-Type", "text/plain"];
+      meta_headers = None }
+  in
+  Protocol.find_header ~name:"content-type" content = Some "text/plain"
+  && Protocol.find_header ~name:"content-encoding" content = None
+  && Protocol.find_header ~name:"content-type" { content with Protocol.response_headers = None } = None
+
 let%test "parse Delete_multi.result" =
   let module Protocol = Protocol(struct type 'a result = 'a end) in
   let data =

aws-s3/s3.mli

@@ -33,10 +33,17 @@ module Make(Io : Types.Io) : sig
     last_modified : float; (** Seconds since epoch *)
     key : string;
     etag : etag; (** Etag as a string. this us usually the MD5, unless the object was constructed by multi-upload *)
+    response_headers : (string * string) list option;
+    (** All headers of the response. If None, the information was not
+        retrieved: [ls] parses an xml listing, which carries no per-object
+        headers. *)
     meta_headers: (string * string) list option; (** Meta headers. If None, the information was not retrieved. *)
-
   }
 
+  (** Look up a response header, ignoring the case the server chose for its
+      name. *)
+  val find_header : name:string -> content -> string option
+
   type nonrec 'a result = ('a, error) result Deferred.t
 
   (** The type of S3 requests. [credentials] refers to AWS