Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

license

  • Loading branch information...
commit 96c5f0a4bc05a7959e6dc197e61b01fc3a5938e1 0 parents
barko authored
31 LICENSE
@@ -0,0 +1,31 @@
+Copyright (c) 2010, barko 00336ea19fcb53de187740c490f764f4
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the
+ distribution.
+
+3. Neither the name of barko nor the names of contributors may be used
+ to endorse or promote products derived from this software without
+ specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
6 META
@@ -0,0 +1,6 @@
+description = "Aws -- clients of Amazon Web Services"
+version = "1.0"
+requires = "netstring cryptokit calendar xml-light ocaml-cohttp lwt.syntax"
+preprocessor = "foo"
+archive(byte) = "aws.cma"
+archive(native) = "aws.cmxa"
27 OMakefile
@@ -0,0 +1,27 @@
+USE_OCAMLFIND = true
+OCAMLPACKS[] = \
+ netstring \
+ cryptokit \
+ calendar \
+ cohttp \
+ lwt.syntax \
+ xml-light
+
+NATIVE_ENABLED = true
+BYTE_ENABLED = true
+
+OCAMLFLAGS += -dtypes
+OCAMLFINDFLAGS += -syntax camlp4o
+
+FILES[] = s3 util creds
+
+LIB = aws
+OCAML_LIBS[] = $(LIB)
+
+.DEFAULT: $(OCamlLibrary $(LIB), $(FILES)) \
+ $(OCamlProgram s3c, s3c)
+
+.PHONY: clean
+
+clean:
+ rm -f $(filter-proper-targets $(ls R, .)) *.s *.annot
45 OMakeroot
@@ -0,0 +1,45 @@
+########################################################################
+# Permission is hereby granted, free of charge, to any person
+# obtaining a copy of this file, to deal in the File without
+# restriction, including without limitation the rights to use,
+# copy, modify, merge, publish, distribute, sublicense, and/or
+# sell copies of the File, and to permit persons to whom the
+# File is furnished to do so, subject to the following condition:
+#
+# THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
+# DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
+# OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE FILE OR
+# THE USE OR OTHER DEALINGS IN THE FILE.
+
+########################################################################
+# The standard OMakeroot file.
+# You will not normally need to modify this file.
+# By default, your changes should be placed in the
+# OMakefile in this directory.
+#
+# If you decide to modify this file, note that it uses exactly
+# the same syntax as the OMakefile.
+#
+
+#
+# Include the standard installed configuration files.
+# Any of these can be deleted if you are not using them,
+# but you probably want to keep the Common file.
+#
+open build/C
+open build/OCaml
+open build/LaTeX
+
+#
+# The command-line variables are defined *after* the
+# standard configuration has been loaded.
+#
+DefineCommandVars()
+
+#
+# Include the OMakefile in this directory.
+#
+.SUBDIRS: .
21 README.md
@@ -0,0 +1,21 @@
+Package to provide OCaml client access to Amazon services, such as S3,
+EC2, FPS, etc.
+
+Aws depends on the following packages:
+
+- omake
+- netstring
+- cryptokit
+- calendar
+- lwt
+- xml-light
+- cohttp: forked from to [avsm's
+ cohttp](http://github.com/avs/ocaml-cohttp) to [barko's
+ cohttp](http://github.com/barko/ocaml-cohttp)
+
+All of the packages except the last are available via GODI.
+
+In an ideal world, the code in these modules would be generated
+automatically, from a formal type definition. The monstrosity know as
+SOAP is painfully distant from this ideal.
+
5 creds.ml
@@ -0,0 +1,5 @@
+type t = {
+ aws_access_key_id : string ;
+ aws_secret_access_key : string ;
+}
+
413 s3.ml
@@ -0,0 +1,413 @@
+(* Copyright (c) 2010, barko 00336ea19fcb53de187740c490f764f4 All
+ rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are
+ met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the
+ distribution.
+
+ 3. Neither the name of barko nor the names of contributors may be used
+ to endorse or promote products derived from this software without
+ specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+module C = CalendarLib.Calendar
+module P = CalendarLib.Printer.CalendarPrinter
+module K = Cryptokit
+module HC = Cohttp.Http_client
+module X = Xml
+
+open Lwt
+
+let sprintf = Printf.sprintf
+
+let service_url = "http://s3.amazonaws.com/"
+
+let now_as_string () =
+ P.sprint "%a, %d %b %Y %H:%M:%S GMT" (C.now ())
+
+(*
+let parse_date_string str =
+ P.from_fstring "%Y-%M-%dT%H:%M:%S.%z" str
+*)
+
+let now_header () =
+ "Date", now_as_string ()
+
+type http_method = [`GET | `POST | `HEAD | `DELETE ]
+
+let string_of_http_method = function
+ | `GET -> "GET"
+ | `PUT -> "PUT"
+ | `HEAD -> "HEAD"
+ | `DELETE -> "DELETE"
+
+let sign key string_to_sign =
+ let hmac_sha1 = K.MAC.hmac_sha1 key in
+ let hashed_string_to_sign = K.hash_string hmac_sha1 string_to_sign in
+ Util.base64 hashed_string_to_sign
+
+let authorization_header creds string_to_sign =
+ let signature = sign creds.Creds.aws_secret_access_key string_to_sign in
+ "Authorization", sprintf "AWS %s:%s" creds.Creds.aws_access_key_id signature
+
+exception Error of string
+
+let error_msg body =
+ (* <Error><Code>SomeMessage</Code>...</Error> *)
+ match X.parse_string body with
+ | X.Element ("Error",_, (X.Element ("Code",_, [X.PCData msg])) :: _ ) ->
+ return (`Error msg)
+ | _ ->
+ (* complain if can't interpret the xml, and then just use the
+ entire body as the payload for the exception *)
+ fail (Error body)
+
+let get_object_h creds_opt ~s3_bucket ~s3_object =
+ let now = now_as_string () in
+ let authorization_header =
+ match creds_opt with
+ | None -> [] (* anonymous *)
+ | Some creds ->
+ let string_to_sign = sprintf "%s\n\n\n%s\n/%s/%s"
+ (string_of_http_method `GET) now s3_bucket s3_object
+ in
+ [ authorization_header creds string_to_sign ]
+ in
+
+ let headers = ("Date", now) :: authorization_header in
+ let request_url = sprintf "%s%s/%s" service_url
+ (Util.encode_url s3_bucket) (Util.encode_url s3_object)
+ in
+ headers, request_url
+
+let get_object_s creds_opt ~s3_bucket ~s3_object =
+ let headers, request_url = get_object_h creds_opt ~s3_bucket ~s3_object in
+ try_lwt
+ lwt _, body = HC.get ~headers:headers request_url in
+ return (`Ok body)
+ with
+ | HC.Http_error (404,_,_) -> return `NotFound
+ | HC.Http_error (_, _, body) -> error_msg body
+
+let get_object creds_opt ~s3_bucket ~s3_object ~path =
+ let headers, request_url = get_object_h creds_opt ~s3_bucket ~s3_object in
+ let flags = [ Unix.O_CREAT; Unix.O_WRONLY; Unix.O_APPEND ] in
+ let outchan = Lwt_io.open_file ~flags ~mode:Lwt_io.output path in
+ lwt res =
+ try_lwt
+ lwt _ = HC.get_to_chan ~headers:headers request_url outchan in
+ return `Ok
+ with
+ | HC.Http_error (404,_,_) -> return `NotFound
+ | HC.Http_error (_, _, body) -> error_msg body
+ in
+ lwt () = Lwt_io.close outchan in
+ return res
+
+
+type acl = [`Private]
+
+let string_of_acl = function
+ | `Private -> "private"
+
+let create_bucket creds s3_bucket acl =
+ let now = now_as_string () in
+ let acl_s = string_of_acl acl in
+ let string_to_sign = sprintf "%s\n\n\n%s\nx-amz-acl:%s\n/%s"
+ (string_of_http_method `PUT) now acl_s s3_bucket
+ in
+ let authorization_header = authorization_header creds string_to_sign in
+ let request_url = sprintf "http://s3.amazonaws.com/%s" s3_bucket in
+ let headers = [
+ authorization_header;
+ "Date", now;
+ "x-amz-acl", acl_s
+ ]
+ in
+ try_lwt
+ lwt _ = HC.put ~headers:headers ?body:None request_url in
+ return `Ok
+ with HC.Http_error (_, _, body) ->
+ error_msg body
+
+
+let delete_bucket creds s3_bucket =
+ let now = now_as_string () in
+ let string_to_sign = sprintf "%s\n\n\n%s\n/%s"
+ (string_of_http_method `DELETE) now s3_bucket
+ in
+ let authorization_header = authorization_header creds string_to_sign in
+ let request_url = sprintf "http://s3.amazonaws.com/%s" s3_bucket in
+ let headers = [ authorization_header; "Date", now ] in
+ try_lwt
+ lwt _ = HC.delete ~headers:headers request_url in
+ (* an `Ok response actually transmitted via a 204 *)
+ fail (Error "delete_bucket")
+ with
+ | HC.Http_error (204, _, _) ->
+ return `Ok
+ | HC.Http_error (_,_,body) ->
+ error_msg body
+
+let rec bucket = function
+ | X.Element (
+ "Bucket",_, [
+ X.Element ("Name",_, [X.PCData name ]) ;
+ X.Element ("CreationDate",_,[X.PCData creation_date_s])
+ ] )->
+ (object
+ method name = name
+ method creation_date = creation_date_s
+ end)
+ | _ -> raise (Error "ListAllMyBucketsResult:2")
+
+and list_all_my_buckets_result_of_xml = function
+ | X.Element ("ListAllMyBucketsResult",_, [_ ; X.Element ("Buckets",_,buckets) ] ) ->
+ List.map bucket buckets
+ | _ -> raise (Error "ListAllMyBucketsResult:1")
+
+let list_buckets creds =
+ let now = now_as_string () in
+ let string_to_sign = sprintf "%s\n\n\n%s\n/" (string_of_http_method `GET) now in
+ let authorization_header = authorization_header creds string_to_sign in
+ let headers = [ authorization_header ; "Date", now ] in
+ let request_url = service_url in
+ try_lwt
+ lwt headers, body = HC.get ~headers:headers request_url in
+ try
+ let buckets = list_all_my_buckets_result_of_xml (X.parse_string body) in
+ return (`Ok buckets)
+ with (Error _) as exn ->
+ fail exn
+ with HC.Http_error (_, _, body) ->
+ error_msg body
+
+
+let noop () = return ()
+
+let put_object
+ ?(content_type="binary/octet-stream")
+ ?(acl=`Private)
+ creds
+ ~s3_bucket
+ ~s3_object
+ ~body =
+ let now = now_as_string () in
+ let bucket_object = (Util.encode_url s3_bucket) ^ "/" ^
+ (Util.encode_url s3_object)
+ in
+ let request_url = service_url ^ bucket_object in
+ let acl_s = string_of_acl acl in
+ let headers = [
+ "Date", now;
+ "x-amz-acl", acl_s;
+ "Content-Type", content_type
+ ]
+ in
+ let string_to_sign = sprintf "%s\n\n%s\n%s\nx-amz-acl:%s\n/%s"
+ (string_of_http_method `PUT) content_type now acl_s bucket_object in
+ let authorization_header = authorization_header creds string_to_sign in
+ let headers = authorization_header :: headers in
+ (* [close] closes the input channel, if any *)
+ let request_body, close =
+ match body with
+ | `String contents ->
+ `String contents, noop
+ | `File path ->
+ let file_size = Util.file_size path in
+ let flags = [Unix.O_RDONLY] in
+ let inchan = Lwt_io.open_file ~flags ~mode:Lwt_io.input path in
+ `InChannel (file_size, inchan), fun _ -> Lwt_io.close inchan
+ in
+ try_lwt
+ lwt _ = HC.put ~headers:headers ~body:request_body request_url in
+ lwt () = close () in
+ return `Ok
+ with
+ | HC.Http_error (_, _, body) ->
+ lwt () = close () in
+ error_msg body
+ | exn ->
+ lwt () = close () in
+ raise exn
+
+
+let assoc_header headers err name =
+ let name = String.lowercase name in
+ try
+ let _, v = List.find (fun (n,v) -> (String.lowercase n) = name) headers in
+ v
+ with Not_found ->
+ raise (Error err)
+
+let get_object_metadata creds ~s3_bucket ~s3_object =
+ let now = now_as_string () in
+ let string_to_sign = sprintf "%s\n\n\n%s\n/%s/%s"
+ (string_of_http_method `HEAD) now s3_bucket s3_object in
+ let authorization_header = authorization_header creds string_to_sign in
+ let headers = [ "Date", now ; authorization_header ] in
+ let bucket_object = (Util.encode_url s3_bucket) ^ "/" ^
+ (Util.encode_url s3_object) in
+ let request_url = service_url ^ bucket_object in
+ try_lwt
+ lwt response_headers, _ = HC.head ~headers request_url in
+ let find k = assoc_header response_headers ("GetObjectMetadata:" ^ k) k in
+ let content_type = find "Content-Type" in
+ let etag = find "ETag" in
+ let last_modified = find "Last-Modified" in
+ let content_length = int_of_string (find "Content-Length") in
+ let meta = (object
+ method content_type = content_type
+ method etag = etag
+ method last_modified = last_modified
+ method content_length = content_length
+ end)
+ in
+ return (`Ok meta)
+ with
+ | HC.Http_error (404,_,_) -> return `NotFound
+ | HC.Http_error (_,_,body) -> error_msg body
+
+
+let option_pcdata err = function
+ | [X.PCData x] -> Some x
+ | [] -> None
+ | _ -> raise (Error err)
+
+let rec list_bucket_result_of_xml = function
+ | X.Element ("ListBucketResult",_,kids) -> (
+ match kids with
+ | X.Element ("Name",_,[X.PCData name]) ::
+ X.Element ("Prefix",_,prefix_opt) ::
+ X.Element ("Marker",_,marker_opt) ::
+ X.Element ("MaxKeys",_,[X.PCData max_keys]) ::
+ X.Element ("IsTruncated",_,[X.PCData is_truncated]) ::
+ contents ->
+
+ let prefix_opt = option_pcdata "ListBucketResult:prefix" prefix_opt in
+ let marker_opt = option_pcdata "ListBucketResult:marker" marker_opt in
+ let max_keys = int_of_string max_keys in
+ let is_truncated = bool_of_string is_truncated in
+ let contents = contents_of_xml contents in
+
+ (object
+ method name = name
+ method prefix = prefix_opt
+ method marker = marker_opt
+ method max_keys = max_keys
+ method is_truncated = is_truncated
+ method objects = contents
+ end)
+ | _ ->
+ raise (Error "ListBucketResult:k")
+ )
+ | _ ->
+ raise (Error "ListBucketResult:t")
+
+and contents_of_xml contents =
+ List.map objects_of_xml contents
+
+and objects_of_xml = function
+ | X.Element ("Contents",_, [
+ X.Element ("Key",_,[X.PCData name]);
+ X.Element ("LastModified",_,[X.PCData last_modified]);
+ X.Element ("ETag",_,[X.PCData etag]);
+ X.Element ("Size",_,[X.PCData size]);
+ X.Element ("Owner",_,[
+ X.Element ("ID",_,[X.PCData owner_id]);
+ X.Element ("DisplayName",_,[X.PCData owner_display_name])
+ ]);
+ X.Element ("StorageClass",_,[X.PCData storage_class])
+ ]) ->
+ let size = int_of_string size in
+ (object
+ method name = name
+ method last_modified = last_modified (* TODO Calendar.t *)
+ method etag = etag
+ method size = size
+ method storage_class = storage_class
+ method owner_id = owner_id
+ method owner_display_name = owner_display_name
+ end)
+ | _ -> raise (Error "ListBucketResult:c")
+
+
+let list_objects creds ~s3_bucket =
+ let now = now_as_string () in
+ let string_to_sign = sprintf "%s\n\n\n%s\n/%s"
+ (string_of_http_method `GET) now s3_bucket in
+ let authorization_header = authorization_header creds string_to_sign in
+ let headers = [ "Date", now ; authorization_header ] in
+ let request_url = service_url ^ (Util.encode_url s3_bucket) in
+ try_lwt
+ lwt response_headers, response_body = HC.get ~headers request_url in
+ return (`Ok (list_bucket_result_of_xml (X.parse_string response_body)))
+ with
+ | HC.Http_error (404,_,_) -> return `NotFound
+ | HC.Http_error (_,_,body) -> error_msg body
+
+
+let access_control_policy_of_xml = function
+ | X.Element ("AccessControlPolicy",_,[
+ X.Element ("Owner",_,[
+ X.Element ("ID",_,[X.PCData owner_id]);
+ X.Element ("DisplayName",_,[X.PCData owner_display_name])
+ ]);
+ X.Element ("AccessControlList",_,[
+ X.Element ("Grant",_,[
+ X.Element ("Grantee",atts,[
+ X.Element ("ID",_,[X.PCData grantee_id]);
+ X.Element ("DisplayName",_,[X.PCData grantee_display_name])
+ ]);
+ X.Element ("Permission",_,[X.PCData permission])
+ ])
+ ])
+ ]) ->
+ (object
+ method owner_id = owner_id
+ method owner_display_name = owner_display_name
+ method grantee_id = grantee_id
+ method grantee_display_name = grantee_display_name
+ method permission = permission
+ end)
+ | _ ->
+ raise (Error "AccessControlPolicy")
+
+let get_bucket_acl creds ~s3_bucket =
+ let now = now_as_string () in
+ let string_to_sign = sprintf "%s\n\n\n%s\n/%s/?acl"
+ (string_of_http_method `GET) now s3_bucket
+ in
+ let authorization_header = authorization_header creds string_to_sign in
+ let headers = [ "Date", now ; authorization_header ] in
+ let request_url = service_url ^ (Util.encode_url s3_bucket) ^ "/?acl" in
+ try_lwt
+ lwt response_headers, response_body = HC.get ~headers request_url in
+ return (`Ok (access_control_policy_of_xml (X.parse_string response_body)))
+ with
+ | HC.Http_error (404,_,_) -> return `NotFound
+ | HC.Http_error (_,_,body) -> error_msg body
+
+
+
+
121 s3.mli
@@ -0,0 +1,121 @@
+(** client module to Amazon's S3 service *)
+
+(* Copyright (c) 2010, barko 00336ea19fcb53de187740c490f764f4 All
+ rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are
+ met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the
+ distribution.
+
+ 3. Neither the name of barko nor the names of contributors may be used
+ to endorse or promote products derived from this software without
+ specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+exception Error of string
+
+type acl = [ `Private ]
+
+val create_bucket : Creds.t -> string -> acl ->
+ [> `Error of string | `Ok ] Lwt.t
+
+val delete_bucket : Creds.t -> string ->
+ [> `Error of string | `Ok ] Lwt.t
+
+val list_buckets : Creds.t ->
+ [> `Error of string
+ | `Ok of < creation_date : string; name : string > list ] Lwt.t
+
+val get_object_s :
+ Creds.t option ->
+ s3_bucket:string ->
+ s3_object:string ->
+ [> `NotFound | `Error of string | `Ok of string ] Lwt.t
+
+val get_object :
+ Creds.t option ->
+ s3_bucket:string ->
+ s3_object:string ->
+ path:string ->
+ [> `Error of string | `NotFound | `Ok ] Lwt.t
+
+val put_object :
+ ?content_type:string ->
+ ?acl:acl ->
+ Creds.t ->
+ s3_bucket:string ->
+ s3_object:string ->
+ body:[ `File of string | `String of string ] ->
+ [> `Error of string | `Ok ] Lwt.t
+
+val get_object_metadata :
+ Creds.t ->
+ s3_bucket:string ->
+ s3_object:string ->
+ [> `NotFound
+ | `Error of string
+ | `Ok of <
+ content_length : int;
+ content_type : string;
+ etag : string;
+ last_modified : string (* TODO : CalendarLib.Calendar.t *)
+ >
+ ] Lwt.t
+
+
+val list_objects :
+ Creds.t ->
+ s3_bucket:string ->
+ [> `Error of string
+ | `NotFound
+ | `Ok of <
+ name : string;
+ prefix : string option;
+ marker : string option;
+ max_keys : int;
+ is_truncated : bool;
+ objects : <
+ etag : string;
+ last_modified : string;
+ name : string;
+ owner_display_name : string;
+ owner_id : string;
+ size : int;
+ storage_class : string
+ > list;
+ >
+ ] Lwt.t
+
+val get_bucket_acl :
+ Creds.t ->
+ s3_bucket:string ->
+ [> `Error of string
+ | `NotFound
+ | `Ok of <
+ grantee_display_name : string;
+ grantee_id : string;
+ owner_display_name : string;
+ owner_id : string;
+ permission : string
+ >
+ ] Lwt.t
236 s3c.ml
@@ -0,0 +1,236 @@
+(** command-line client to Amazon's S3 *)
+
+(* Copyright (c) 2010, barko 00336ea19fcb53de187740c490f764f4 All
+ rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are
+ met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the
+ distribution.
+
+ 3. Neither the name of barko nor the names of contributors may be used
+ to endorse or promote products derived from this software without
+ specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+open Lwt
+open Creds
+open Printf
+
+let create_bucket creds bucket () =
+ lwt result = S3.create_bucket creds bucket `Private in
+ let exit_code =
+ match result with
+ | `Ok -> print_endline "ok"; 0
+ | `Error msg -> print_endline msg; 1
+ in
+ return exit_code
+
+let delete_bucket creds bucket () =
+ lwt result = S3.delete_bucket creds bucket in
+ let exit_code =
+ match result with
+ | `Ok -> print_endline "ok"; 0
+ | `Error msg -> print_endline msg; 1
+ in
+ return exit_code
+
+let list_buckets creds () =
+ lwt result = S3.list_buckets creds in
+ let exit_code =
+ match result with
+ | `Ok bucket_infos ->
+ List.iter (
+ fun b ->
+ printf "%s\t%s\n" b#creation_date b#name
+ ) bucket_infos;
+ 0
+ | `Error body -> print_endline body; 1
+ in
+ return exit_code
+
+let get_object_s creds s3_bucket s3_object () =
+ lwt result = S3.get_object_s (Some creds) ~s3_bucket ~s3_object in
+ let exit_code =
+ match result with
+ | `Ok body -> print_string body; 0
+ | `NotFound -> printf "%s/%s not found\n%!" s3_bucket s3_object; 0
+ | `Error msg -> print_endline msg; 1
+ in
+ return exit_code
+
+let get_object creds s3_bucket s3_object path () =
+ lwt result = S3.get_object (Some creds) ~s3_bucket ~s3_object ~path in
+ let exit_code =
+ match result with
+ | `Ok -> print_endline "ok"; 0
+ | `NotFound -> printf "%s/%s not found\n%!" s3_bucket s3_object; 0
+ | `Error msg -> print_endline msg; 1
+ in
+ return exit_code
+
+let put_object creds s3_bucket s3_object path () =
+ lwt result = S3.put_object creds ~s3_bucket ~s3_object ~body:(`File path) in
+ let exit_code =
+ match result with
+ | `Ok -> 0
+ | `Error msg -> print_endline msg; 1
+ in
+ return exit_code
+
+let put_object_s creds s3_bucket s3_object contents () =
+ lwt result = S3.put_object creds ~s3_bucket ~s3_object ~body:(`String contents) in
+ let exit_code =
+ match result with
+ | `Ok -> 0
+ | `Error msg -> print_endline msg; 1
+ in
+ return exit_code
+
+let print_kv_list kv_list =
+ List.iter (
+ fun (k,v) ->
+ printf "%s: %s\n" k v
+ ) kv_list
+
+let get_object_metadata creds s3_bucket s3_object () =
+ lwt result = S3.get_object_metadata creds ~s3_bucket ~s3_object in
+ let exit_code =
+ match result with
+ | `Ok m ->
+ print_kv_list [
+ "Content-Type", m#content_type;
+ "Content-Length", string_of_int m#content_length;
+ "ETag", m#etag;
+ "Last-Modified", m#last_modified
+ ];
+ 0
+ | `NotFound -> printf "%S/%S not found\n%!" s3_bucket s3_object; 1
+ | `Error msg -> print_endline msg; 1
+ in
+ return exit_code
+
+let some_or_empty = function
+ | Some s -> s
+ | None -> ""
+
+let list_objects creds s3_bucket () =
+ lwt result = S3.list_objects creds ~s3_bucket in
+ let exit_code =
+ match result with
+ | `Ok res ->
+ print_kv_list [
+ "name", res#name;
+ "prefix", (some_or_empty res#prefix);
+ "marker", (some_or_empty res#marker);
+ "truncated", (string_of_bool res#is_truncated);
+ "objects", ""
+ ];
+ List.iter (
+ fun o ->
+ printf "%s\t%s\t%s\t%d\t%s\t%s\t%s\n"
+ o#name
+ o#last_modified
+ o#etag
+ o#size
+ o#storage_class
+ o#owner_id
+ o#owner_display_name
+ ) res#objects;
+ 0
+ | `NotFound -> printf "bucket %S not found\n%!" s3_bucket; 1
+ | `Error msg -> print_endline msg; 1
+ in
+ return exit_code
+
+let get_bucket_acl creds s3_bucket () =
+ lwt result = S3.get_bucket_acl creds ~s3_bucket in
+ let exit_code =
+ match result with
+ | `Ok r ->
+ print_kv_list [
+ "owner-id", r#owner_id;
+ "owner-display-name", r#owner_display_name;
+ "grantee-id", r#grantee_id;
+ "grantee-display-name", r#grantee_display_name;
+ "permission", r#permission
+ ];
+ 0
+ | `NotFound -> Printf.printf "bucket %S not found\n%!" s3_bucket; 1
+ | `Error msg -> print_endline msg; 1
+ in
+ return exit_code
+
+
+let _ =
+ let getenv_else_exit k =
+ try
+ Unix.getenv k
+ with Not_found ->
+ Printf.printf "environment variable %S not set\n%!" k;
+ exit 1
+ in
+
+ let creds = {
+ aws_access_key_id = getenv_else_exit "AWS_ACCESS_KEY_ID";
+ aws_secret_access_key = getenv_else_exit "AWS_SECRET_ACCESS_KEY"
+ }
+ in
+
+ let command =
+ match Sys.argv with
+ | [| _; "delete_bucket"; bucket |] ->
+ delete_bucket creds bucket
+
+ | [| _; "create_bucket"; bucket |] ->
+ create_bucket creds bucket
+
+ | [| _; "get_object_s"; bucket; objekt |] ->
+ get_object_s creds bucket objekt
+
+ | [| _; "get_object"; bucket; objekt; path|] ->
+ get_object creds bucket objekt path
+
+ | [| _; "put_object"; bucket; objekt ; path |] ->
+ put_object creds bucket objekt path
+
+ | [| _; "put_object_s"; bucket; objekt ; contents |] ->
+ put_object_s creds bucket objekt contents
+
+ | [| _; "get_object_metadata"; bucket ; objekt |] ->
+ get_object_metadata creds bucket objekt
+
+ | [| _; "list_objects"; bucket |] ->
+ list_objects creds bucket
+
+ | [| _; "get_bucket_acl"; bucket |] ->
+ get_bucket_acl creds bucket
+
+ | [| _; "list_buckets" |] ->
+ list_buckets creds
+
+ | _ ->
+ print_endline "unknown command" ; exit 1
+
+ in
+ let exit_code = Lwt_unix.run (command ()) in
+ exit exit_code
59 util.ml
@@ -0,0 +1,59 @@
+(* Copyright (c) 2010, barko 00336ea19fcb53de187740c490f764f4 All
+ rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are
+ met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the
+ distribution.
+
+ 3. Neither the name of barko nor the names of contributors may be used
+ to endorse or promote products derived from this software without
+ specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+
+let remove_newline =
+ Pcre.replace ~rex:(Pcre.regexp "\n") ~templ:""
+
+let base64 str =
+ (* the encoder is consumed by its use, so we have to recreated *)
+ let b64_encoder = Cryptokit.Base64.encode_multiline () in
+ let encoded = Cryptokit.transform_string b64_encoder str in
+
+ (* we want to retain the trailing '=' characters, but eliminate the
+ newlines. Unfortunately, [encode_compact] has neither. *)
+ remove_newline encoded
+
+let colon_space (k, v) = k ^ ": " ^ v
+
+let encode_url s = Netencoding.Url.encode s
+
+let encode_key_equals_value kvs =
+ List.map (
+ fun (k,v) ->
+ (encode_url k) ^ "=" ^ (encode_url v)
+ ) kvs
+
+
+let file_size path =
+ let s = Unix.stat path in
+ s.Unix.st_size
Please sign in to comment.
Something went wrong with that request. Please try again.