diff --git a/aws-s3/s3.ml b/aws-s3/s3.ml index bf0ff0b..7f692a8 100644 --- a/aws-s3/s3.ml +++ b/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 = {| + + s3_osd + + 1 + 1000 + false + + STANDARD + test + 2018-02-27T13:39:35.000Z + "7538d2bd85ea5dfb689ed65a0f60a7aa" + 20 + + + |} + 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 = diff --git a/aws-s3/s3.mli b/aws-s3/s3.mli index 051736a..7dd2dfe 100644 --- a/aws-s3/s3.mli +++ b/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