├── .github └── workflows │ └── workflow.yml ├── .gitignore ├── Changelog ├── LICENSE ├── Makefile ├── README.md ├── aws-s3-async.opam ├── aws-s3-async ├── bin │ ├── aws_cli_async.ml │ └── dune ├── credentials.ml ├── dune ├── io.ml ├── io.mli └── s3.ml ├── aws-s3-lwt.opam ├── aws-s3-lwt ├── bin │ ├── aws_cli_lwt.ml │ └── dune ├── credentials.ml ├── dune ├── io.ml ├── io.mli └── s3.ml ├── aws-s3.opam ├── aws-s3 ├── authorization.ml ├── authorization.mli ├── aws.ml ├── aws.mli ├── aws_s3.ml ├── body.ml ├── body.mli ├── credentials.ml ├── credentials.mli ├── dune ├── headers.ml ├── headers.mli ├── http.ml ├── http.mli ├── region.ml ├── region.mli ├── s3.ml ├── s3.mli ├── time.ml ├── time.mli ├── types.ml ├── util.ml └── util.mli ├── clear_multi_part.sh ├── cli ├── aws.ml ├── cli.ml └── dune ├── dune-project ├── integration.sh └── minio └── docker-compose.yml /.github/workflows/workflow.yml: -------------------------------------------------------------------------------- 1 | name: Main workflow 2 | 3 | on: 4 | - push 5 | - workflow_dispatch 6 | 7 | jobs: 8 | build: 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | os: 13 | - ubuntu-latest 14 | ocaml-compiler: 15 | - 5 16 | - 4 17 | - 4.08.0 18 | concurrency: 19 | - async 20 | - lwt 21 | exclude: 22 | - ocaml-compiler: 4.08.0 23 | concurrency: async 24 | 25 | runs-on: ${{ matrix.os }} 26 | 27 | env: 28 | AWS_ACCESS_KEY_ID: minioadmin 29 | AWS_SECRET_ACCESS_KEY: minioadmin 30 | 31 | services: 32 | minio: 33 | image: fclairamb/minio-github-actions 34 | ports: 35 | - 9000:9000 36 | 37 | steps: 38 | - name: Checkout code 39 | uses: actions/checkout@v3 40 | 41 | - name: Setup Minio 42 | run: | 43 | mkdir ~/.aws 44 | echo '[default]' > ~/.aws/credentials 45 | echo 'aws_access_key_id = minioadmin' >> ~/.aws/credentials 46 | echo 'aws_secret_access_key = minioadmin' >> ~/.aws/credentials 47 | pip3 install minio 48 | python3 - <<'EOF' 49 | from minio import Minio 50 | minio = Minio( 51 | 'localhost:9000', 52 | access_key='minioadmin', 53 | secret_key='minioadmin', 54 | secure=False 55 | ) 56 | minio.make_bucket('bucket-${{ matrix.concurrency }}') 57 | EOF 58 | 59 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 60 | uses: ocaml/setup-ocaml@v2 61 | with: 62 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 63 | opam-pin: false 64 | opam-depext: false 65 | 66 | - run: opam pin . --no-action 67 | - run: opam depext aws-s3 aws-s3-${{ matrix.concurrency }} --yes --with-doc --with-test 68 | - run: opam install aws-s3 aws-s3-${{ matrix.concurrency }} --deps-only --with-doc --with-test 69 | - run: opam exec -- dune build aws-s3 aws-s3-${{ matrix.concurrency }} 70 | - run: opam exec -- dune runtest aws-s3 aws-s3-${{ matrix.concurrency }} 71 | 72 | - run: ./integration.sh -t ${{ matrix.concurrency }} -b bucket-${{ matrix.concurrency }} -m 127.0.0.1:9000 73 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | .merlin 3 | *.install 4 | -------------------------------------------------------------------------------- /Changelog: -------------------------------------------------------------------------------- 1 | -*- mode: fundamental -*- 2 | 3 | ## 4.8.1: Release 2024-03-13 4 | - [x]: Forward compatibility with Lwt release 5.7/6.0 5 | - [x]: Fix bug causing a leak in filedescriptors (thanks @quernd) 6 | 7 | ## 4.8.0: Released 2022-09-04 8 | - [x]: Add short lived credentials tokens through X-Amz-Security-Token http header (Thanks @ anuragsoni) 9 | - [x]: Update dependencies on yojson (Thanks @Leonidas-from-XIV) 10 | 11 | ## 4.7.0: Released 2022-04-19 12 | - [x]: Add option ` confirm_requester_pays` (thanks @barko) 13 | - [x]: Relax constraint on core (thanks @AndreasDahl) 14 | 15 | ## 4.6.0: Released 2022-04-06 16 | - [x]: Added Backblaze vendor region (thanks @roddyyaga) 17 | - [x]: Use xmlm instead of xml_light 18 | - [x]: Fix compilation warning on 4.12.0 19 | - [x]: Update dependencies to latest version of core and cmdliner 20 | - [x]: Add option to add user-supplied headers on object put (thanks @AndreasDahl) 21 | - [x]: Adding support to specify minio address for cli 22 | - [x]: Enable CI tests against minio-server 23 | - [x]: extend head request to return user defined metadata headers 24 | 25 | ## 4.5.1: Released 2020-03-31 26 | - [x]: Allow compilation with core/async 0.13 27 | 28 | 4.5.0: Released 2019-12-04 29 | - [x]: Add connection_timeout_ms option to all calls 30 | 31 | ## 4.4.1: Released 2019-11-12 32 | - [x]: Aws-s3-async: Fix uncaught error if connection timed out. 33 | - [x]: Remove warnings when compiling with 4.08 34 | 35 | ## 4.4.0: Released 2019-04-22 36 | - [x]: Update to newest version of ppx_protocol_conv 37 | - [x]: Support for custom hosts in presigned URLs (@hcarty) 38 | 39 | ## 4.3.0: Released 2019-03-03 40 | - [x]: Require Base64 >= 3.1 [Adam Ringwood] 41 | - [x]: Add support for generating s3 presigned urls [Adam Ringwood] 42 | 43 | ## 4.2.0: Released 2018-10-26 44 | - [x]: Update opam files to opam 2.0 45 | - [x]: Depend on digestif 0.7 [hcarty] 46 | - [x]: Add support for 3rd party s3 compatible providers [hcarty] 47 | - [x]: Support ocaml-tls [hcarty] 48 | 49 | ## 4.1.0: Released 2018-08-27 50 | - [x]: Add start_after argument to ls 51 | - [x]: Extend cli to accpet max_keys > 1000 and a start_after option for ls 52 | - [x]: Reduce linked libaries 53 | 54 | ## 4.0.1: Released 2018-08-20 55 | - [x] Fix harmless bug when scanning for seperators with more than one character. 56 | - [x] Fix bug when parsing multi delete reply in case of error 57 | 58 | ## 4.0.0: Released 2018-08-16 59 | - [x] Support HEAD operation on objects. 60 | - [x] Change signature to use string for etag rather than 61 | Caml.Digest.t for clearer documentation 62 | - [x] Support Digest 0.6 63 | - [x] Remove dependency to Core 64 | - [x] Rewrite authentication code 65 | - [x] Switch to use Ptime for time conversion routines 66 | - [x] Support chunked transfer (put) 67 | - [x] Add streaming API 68 | - [x] Remove dependency on Cohttp 69 | - [x] Switch to dune 70 | - [x] Support IPv6 71 | - [x] Add option to use expect-100. 72 | - [x] Add option to limit result of ls 73 | - [x] Extend aws-cli 74 | - [x] Move region related function to own Region module 75 | 76 | ## 3.0.0: Released 2018-05-16 77 | - [x] Add parameter to specify scheme(http|https) 78 | - [x] Fix IAM handling for lwt version. 79 | - [x] Always use http when accessing s3. 80 | - [x] Support copying s3 -> s3 81 | - [x] Support multipart upload 82 | - [x] Support permanent/temporary redirect error code 83 | - [x] Return an error indicating the redirect to successive calls 84 | - [x] Switch to use Digistif module 85 | - [x] Remove support for gzip 86 | - Users can set the content encoding to gzip, and use ezgzip instead 87 | - [x] Compatibility with base.v0.11.0 88 | 89 | ## 2.0.0: 90 | - [x] Calling delete multi with an empty list is now a noop 91 | - [x] Return Md5.t digest type instead of strings 92 | - [x] Fix multi delete 93 | - [x] Support range get 94 | - [x] Compatibility with core >= v0.9.0 95 | - [x] Split into multiple packages (aws-s3-lwt / aws-s3-async / aws-s3) 96 | - [x] Funtorize over the concurrency monad (Async / Lwt) 97 | - [x] Dont compile with -safe-string 98 | - [x] return md5 of uploaded file 99 | 100 | ## 1.1.0: 101 | - [x] Switch to use ppx_deriving_protocol, and compile with -safe-string 102 | 103 | ## 1.0.0: 104 | - [x] Switch to use jbuilder and require core >= 0.9. 105 | 106 | ## 0.9.0: 107 | - [x] initial release 108 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2021 Anders Fugmann. All rights reserved. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are 5 | met: 6 | 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above 11 | copyright notice, this list of conditions and the following 12 | disclaimer in the documentation and/or other materials provided 13 | with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its 16 | contributors may be used to endorse or promote products derived 17 | from this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build 2 | build: 3 | dune build @install 4 | 5 | .PHONY: lwt 6 | lwt: 7 | dune build aws-s3-lwt.install 8 | 9 | .PHONY: async 10 | async: 11 | dune build aws-s3-async.install 12 | 13 | .PHONY: install 14 | install: build 15 | dune install 16 | 17 | .PHONY: clean 18 | clean: 19 | dune clean 20 | 21 | .PHONY: test 22 | test: build 23 | dune runtest 24 | 25 | .PHONY: integration 26 | integration: 27 | ./integration.sh 28 | 29 | release: 30 | dune-release 31 | 32 | doc: 33 | dune build @doc 34 | 35 | gh-pages: doc 36 | git clone `git config --get remote.origin.url` .gh-pages --reference . 37 | git -C .gh-pages checkout --orphan gh-pages 38 | git -C .gh-pages reset 39 | git -C .gh-pages clean -dxf 40 | cp -r _build/default/_doc/_html/* .gh-pages 41 | git -C .gh-pages add . 42 | git -C .gh-pages config user.email 'docs@aws-s3' 43 | git -C .gh-pages commit -m "Update documentation" 44 | git -C .gh-pages push origin gh-pages -f 45 | rm -rf .gh-pages 46 | 47 | .PHONY: minio 48 | minio: 49 | mkdir -p /tmp/minio/aws-s3-bucket 50 | docker run --rm -it -p 9000:9000 -v /tmp/minio:/minio minio/minio:latest server /minio 51 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Ocaml library for accessing Amazon S3 2 | 3 | [![Main workflow](https://github.com/andersfugmann/aws-s3/actions/workflows/workflow.yml/badge.svg)](https://github.com/andersfugmann/aws-s3/actions/workflows/workflow.yml) 4 | 5 | 6 | This library provides access to Amazon Simple Storage Solution (S3). 7 | 8 | The following S3 operations are supported: 9 | * Copying file to and from s3 10 | * List files in S3 (from root) 11 | * Delete single/multi object in S3 12 | * HEAD operation on single objects 13 | * Streaming transfer to and from aws 14 | * Multi part upload (including s3 -> s3 copy) 15 | 16 | The library also implements fetching credentials through IAM service. 17 | 18 | The library supports both lwt and async concurrency models. 19 | * For lwt, please install `aws-s3-lwt` package 20 | * For Async, please install `aws-s3-async` package 21 | 22 | [Api](https://andersfugmann.github.io/aws-s3/) 23 | 24 | This library is originally based on [s3_cp.ml](https://raw.githubusercontent.com/mirage/ocaml-cohttp/5c3d77cde632f366bfdf9521b95648527174a2f3/examples/async/s3_cp.ml) from the mirage project but has diverted (and grown) substantially since. 25 | -------------------------------------------------------------------------------- /aws-s3-async.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Anders Fugmann " 3 | authors: "Anders Fugmann" 4 | license: "BSD-3-Clause" 5 | homepage: "https://github.com/andersfugmann/aws-s3" 6 | dev-repo: "git+https://github.com/andersfugmann/aws-s3" 7 | bug-reports: "https://github.com/andersfugmann/aws-s3/issues" 8 | doc: "https://andersfugmann.github.io/aws-s3/" 9 | build: [ 10 | ["dune" "subst"] {dev} 11 | ["dune" "build" "-p" name "-j" jobs] 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.14.0"} 15 | "dune" {>= "2.0.0"} 16 | "aws-s3" {= version} 17 | "async_kernel" {>= "v0.9.0"} 18 | "async_unix" {>= "v0.9.0"} 19 | "conduit-async" {>= "4.0.0"} 20 | "core" {>= "v0.16.0"} 21 | "core_unix" {>= "v0.16.0"} 22 | ] 23 | synopsis: "Ocaml library for accessing Amazon S3 - Async version" 24 | description: """ 25 | This library provides access to Amazon Simple Storage Solution (S3). 26 | The library supports: 27 | * Copying file to and from s3 28 | * List files in S3 (from root) 29 | * Delete single/multi object in S3 30 | * HEAD operation on single objects 31 | * Streaming transfer to and from aws. 32 | * Multi part upload (including s3 -> s3 copy) 33 | * Fetching machine role/credentials (though IAM) 34 | 35 | This library uses async for concurrency""" 36 | -------------------------------------------------------------------------------- /aws-s3-async/bin/aws_cli_async.ml: -------------------------------------------------------------------------------- 1 | module Aws = Aws_cli.Aws.Make(Aws_s3_async.Io) 2 | 3 | let exec cmd = 4 | Async.Thread_safe.block_on_async_exn (fun () -> Aws.exec cmd) 5 | 6 | let () = 7 | Aws_cli.Cli.parse exec 8 | -------------------------------------------------------------------------------- /aws-s3-async/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name aws_cli_async) 3 | (public_name aws-cli-async) 4 | (libraries aws_cli aws-s3-async) 5 | (package aws-s3-async) 6 | ) 7 | -------------------------------------------------------------------------------- /aws-s3-async/credentials.ml: -------------------------------------------------------------------------------- 1 | (** Async aware Credentials. 2 | For API documentation 3 | @see <../../../aws-s3/Aws_s3/Credentials/Make/index.html>({!module:Aws_s3.Credentials.Make}) 4 | *) 5 | include Aws_s3.Credentials.Make(Io) 6 | type t = Aws_s3.Credentials.t 7 | -------------------------------------------------------------------------------- /aws-s3-async/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name aws_s3_async) 4 | (public_name aws-s3-async) 5 | (synopsis "Async backed for aws-s3") 6 | (libraries aws-s3 async_kernel ipaddr.unix async_unix conduit-async core core_unix) 7 | ) 8 | -------------------------------------------------------------------------------- /aws-s3-async/io.ml: -------------------------------------------------------------------------------- 1 | open Async 2 | module Deferred = struct 3 | type 'a t = 'a Async_kernel.Deferred.t 4 | 5 | module Or_error = struct 6 | type nonrec 'a t = ('a, exn) result t 7 | let return v = Async_kernel.Deferred.return (Ok v) 8 | let fail exn = Async_kernel.Deferred.return (Error exn) 9 | let catch f = 10 | Async_kernel.Monitor.try_with f >>= function 11 | | Ok v -> Async_kernel.return v 12 | | Error exn -> Async_kernel.return (Error exn) 13 | 14 | let (>>=) : 'a t -> ('a -> 'b t) -> 'b t = fun v f -> 15 | v >>= function 16 | | Ok v -> f v 17 | | Error exn -> Async_kernel.return (Error exn) 18 | end 19 | 20 | let (>>=) = Async_kernel.(>>=) 21 | let (>>|) = Async_kernel.(>>|) 22 | let (>>=?) v f = 23 | v >>= function 24 | | Ok v -> f v 25 | | Error exn -> return (Error exn) 26 | 27 | let return = Async_kernel.return 28 | let after delay = Async_kernel.after (Core.Time_ns.Span.of_sec delay) 29 | let catch f = Async_kernel.Monitor.try_with f 30 | let async = don't_wait_for 31 | end 32 | 33 | module Ivar = struct 34 | type 'a t = 'a Async.Ivar.t 35 | let create () = Async.Ivar.create () 36 | let fill t v = Async.Ivar.fill t v 37 | let wait t = Async.Ivar.read t 38 | end 39 | 40 | module Pipe = struct 41 | open Async_kernel 42 | open Deferred 43 | 44 | type ('a, 'b) pipe = ('a, 'b) Pipe.pipe 45 | type writer_phantom = Pipe.Writer.phantom 46 | type reader_phantom = Pipe.Reader.phantom 47 | type 'a writer = 'a Pipe.Writer.t 48 | type 'a reader = 'a Pipe.Reader.t 49 | 50 | let flush writer = Pipe.downstream_flushed writer >>= fun _ -> return () 51 | let read reader = Pipe.read reader >>= function 52 | | `Eof -> return None 53 | | `Ok v -> return (Some v) 54 | let write writer data = 55 | (* Pipe.write writer data *) 56 | Pipe.write_without_pushback writer data; 57 | return () 58 | let close writer = Pipe.close writer 59 | let close_reader reader = Pipe.close_read reader 60 | let create_reader ~f = Pipe.create_reader ~close_on_exception:true f 61 | let create_writer ~f = Pipe.create_writer f 62 | let transfer reader writer = Pipe.transfer_id reader writer 63 | let create () = Pipe.create () 64 | let is_closed pipe = Pipe.is_closed pipe 65 | let closed pipe = Pipe.closed pipe 66 | end 67 | 68 | module Net = struct 69 | let connect ?connect_timeout_ms ~inet ~host ~port ~scheme () = 70 | let uri = 71 | let scheme = match scheme with 72 | | `Http -> "http" 73 | | `Https -> "https" 74 | in 75 | Uri.make ~scheme ~host:host ~port () 76 | in 77 | let options = 78 | let domain : Async_unix.Unix.socket_domain = 79 | match inet with 80 | | `V4 -> PF_INET 81 | | `V6 -> PF_INET6 82 | in 83 | Core_unix.[AI_FAMILY domain] 84 | in 85 | let close_socket_no_error = function 86 | | Conduit_async.V3.Inet_sock socket -> try Socket.shutdown socket `Both; with _ -> () 87 | in 88 | let interrupt = match connect_timeout_ms with 89 | | None -> None 90 | | Some ms -> Some (Async.after (Time_float_unix.Span.of_int_ms ms)) 91 | in 92 | Async.try_with (fun () -> Conduit_async.V3.connect_uri ?interrupt ~options uri) >>=? fun (socket, ic, oc) -> 93 | let reader = Reader.pipe ic in 94 | don't_wait_for ( 95 | Async_kernel.Pipe.closed reader >>= fun () -> 96 | Monitor.try_with ~name:"Io.Net.connect connection-cleanup" (fun () -> 97 | Writer.close oc >>= fun () -> 98 | Reader.close ic >>= fun () -> 99 | return () 100 | ) >>= fun _ -> 101 | close_socket_no_error socket; 102 | return () 103 | ); 104 | let writer = Writer.pipe oc in 105 | Deferred.Or_error.return (reader, writer) 106 | end 107 | -------------------------------------------------------------------------------- /aws-s3-async/io.mli: -------------------------------------------------------------------------------- 1 | include Aws_s3.Types.Io 2 | with type 'a Deferred.t = 'a Async_kernel.Deferred.t 3 | and type ('a, 'b) Pipe.pipe = ('a, 'b) Async_kernel.Pipe.t 4 | and type Pipe.reader_phantom = Async_kernel.Pipe.Reader.phantom 5 | and type Pipe.writer_phantom = Async_kernel.Pipe.Writer.phantom 6 | and type 'a Pipe.reader = 'a Async_kernel.Pipe.Reader.t 7 | and type 'a Pipe.writer = 'a Async_kernel.Pipe.Writer.t 8 | -------------------------------------------------------------------------------- /aws-s3-async/s3.ml: -------------------------------------------------------------------------------- 1 | (** Async aware S3 commands. 2 | For API documentation 3 | @see <../../../aws-s3/Aws_s3/S3/Make/index.html>({!module:Aws_s3.S3.Make}) 4 | *) 5 | include Aws_s3.S3.Make(Io) 6 | -------------------------------------------------------------------------------- /aws-s3-lwt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Anders Fugmann " 3 | authors: "Anders Fugmann" 4 | license: "BSD-3-Clause" 5 | homepage: "https://github.com/andersfugmann/aws-s3" 6 | dev-repo: "git+https://github.com/andersfugmann/aws-s3" 7 | bug-reports: "https://github.com/andersfugmann/aws-s3/issues" 8 | build: [ 9 | ["dune" "subst"] {dev} 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | depends: [ 13 | "ocaml" {>= "4.08.0"} 14 | "dune" {>= "2.0.0"} 15 | "aws-s3" {= version} 16 | "lwt" 17 | "conduit-lwt-unix" {>= "5.0.0"} 18 | ] 19 | synopsis: "Ocaml library for accessing Amazon S3 - Lwt version" 20 | description: """ 21 | This library provides access to Amazon Simple Storage Solution (S3). 22 | The library supports: 23 | * Copying file to and from s3 24 | * List files in S3 (from root) 25 | * Delete single/multi object in S3 26 | * HEAD operation on single objects 27 | * Streaming transfer to and from aws. 28 | * Multi part upload (including s3 -> s3 copy) 29 | * Fetching machine role/credentials (though IAM) 30 | 31 | This library uses lwt for concurrency""" 32 | -------------------------------------------------------------------------------- /aws-s3-lwt/bin/aws_cli_lwt.ml: -------------------------------------------------------------------------------- 1 | module Aws = Aws_cli.Aws.Make(Aws_s3_lwt.Io) 2 | 3 | let exec cmd = Lwt_main.run (Aws.exec cmd) 4 | 5 | let () = 6 | Aws_cli.Cli.parse exec 7 | -------------------------------------------------------------------------------- /aws-s3-lwt/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name aws_cli_lwt) 3 | (public_name aws-cli-lwt) 4 | (libraries aws_cli aws-s3-lwt) 5 | (package aws-s3-lwt) 6 | ) 7 | -------------------------------------------------------------------------------- /aws-s3-lwt/credentials.ml: -------------------------------------------------------------------------------- 1 | (** Lwt aware Credentials. 2 | For API documentation 3 | @see <../../../aws-s3/Aws_s3/Credentials/Make/index.html>({!module:Aws_s3.Credentials.Make}) 4 | *) 5 | include Aws_s3.Credentials.Make(Io) 6 | type t = Aws_s3.Credentials.t 7 | -------------------------------------------------------------------------------- /aws-s3-lwt/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name aws_s3_lwt) 3 | (public_name aws-s3-lwt) 4 | (synopsis "Lwt backed for aws-s3") 5 | (libraries aws-s3 lwt ipaddr.unix conduit-lwt-unix conduit-lwt) 6 | ) 7 | -------------------------------------------------------------------------------- /aws-s3-lwt/io.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | module Deferred = struct 3 | type 'a t = 'a Lwt.t 4 | 5 | module Or_error = struct 6 | type nonrec 'a t = ('a, exn) Lwt_result.t 7 | let return = Lwt_result.return 8 | let fail = Lwt_result.fail 9 | let catch : (unit -> 'a t) -> 'a t = fun f -> 10 | Lwt.catch f Lwt_result.fail 11 | 12 | let (>>=) a b = 13 | a >>= function 14 | | Ok v -> b v 15 | | Error _ as err -> Lwt.return err 16 | end 17 | 18 | let (>>=) = Lwt.Infix.(>>=) 19 | let (>>|) a b = a >>= fun v -> Lwt.return (b v) 20 | let (>>=?) = Lwt_result.Infix.(>>=) 21 | 22 | let return = Lwt.return 23 | let after delay = Lwt_unix.sleep delay 24 | let catch f = 25 | Lwt.catch 26 | (fun () -> f () >>= Or_error.return) 27 | (fun exn -> Or_error.fail exn) 28 | let async t = Lwt.async (fun () -> t) 29 | end 30 | 31 | module Ivar = struct 32 | type 'a t = ('a Lwt.t * 'a Lwt.u) 33 | let create () = Lwt.wait () 34 | let fill t v = Lwt.wakeup_later (snd t) v 35 | let wait t = fst t 36 | end 37 | 38 | module Pipe = struct 39 | open Lwt.Infix 40 | type 'a elem = Flush of unit Lwt.u 41 | | Data of 'a 42 | 43 | type writer_phantom = [`Writer] 44 | type reader_phantom = [`Reader] 45 | 46 | type ('a, 'phantom) pipe = 47 | { cond: unit Lwt_condition.t; 48 | queue: 'a elem Queue.t; 49 | mutable closed: bool; 50 | closer: (unit Lwt.t * unit Lwt.u); 51 | } 52 | 53 | type 'a reader = ('a, reader_phantom) pipe 54 | type 'a writer = ('a, writer_phantom) pipe 55 | 56 | let on_close pipe = 57 | match Lwt.is_sleeping (fst pipe.closer) with 58 | | true -> Lwt.wakeup_later (snd pipe.closer) () 59 | | false -> () 60 | 61 | let write writer data = 62 | match writer.closed with 63 | | false -> 64 | Queue.add (Data data) writer.queue; 65 | if Queue.length writer.queue = 1 then Lwt_condition.signal writer.cond (); 66 | Lwt.return_unit 67 | | true -> 68 | failwith (__LOC__ ^ ": Closed") 69 | 70 | let flush writer = 71 | match Queue.length writer.queue = 0 && writer.closed with 72 | | true -> Lwt.return () 73 | | false -> 74 | let waiter, wakeup = Lwt.wait () in 75 | Queue.add (Flush wakeup) writer.queue; 76 | if Queue.length writer.queue = 1 then Lwt_condition.signal writer.cond (); 77 | waiter 78 | 79 | let close (writer : 'a writer) = 80 | writer.closed <- true; 81 | Lwt_condition.broadcast writer.cond (); 82 | on_close writer 83 | 84 | let close_reader (reader : 'a reader) = 85 | reader.closed <- true; 86 | Lwt_condition.broadcast reader.cond (); 87 | on_close reader 88 | 89 | let rec read (reader : 'a reader) = 90 | match Queue.take reader.queue with 91 | | Data data -> Lwt.return (Some data) 92 | | Flush wakeup -> 93 | Lwt.wakeup_later wakeup (); 94 | read reader 95 | | exception Queue.Empty when reader.closed -> 96 | Lwt.return None 97 | | exception Queue.Empty -> 98 | Lwt_condition.wait reader.cond >>= fun () -> 99 | read reader 100 | 101 | let create : unit -> 'a reader * 'a writer = fun () -> 102 | let pipe = { cond = Lwt_condition.create (); 103 | queue = Queue.create (); 104 | closed = false; 105 | closer = Lwt.wait (); 106 | } 107 | in 108 | pipe, pipe 109 | 110 | let create_reader: f:('a writer -> unit Lwt.t) -> 'a reader = fun ~f -> 111 | let reader, writer = create () in 112 | Lwt.async (fun () -> 113 | Lwt.catch 114 | (fun () -> f writer) 115 | (fun _ -> Printf.eprintf "Create_reader raised\n%!"; Lwt.return ()) >>= fun () -> 116 | close_reader reader; Lwt.return () 117 | ); 118 | reader 119 | 120 | let create_writer: f:('a reader -> unit Lwt.t) -> 'a writer = fun ~f -> 121 | let reader, writer = create () in 122 | Lwt.async (fun () -> 123 | Lwt.catch 124 | (fun () -> f reader) 125 | (fun _ -> Printf.eprintf "Create_writer raised\n%!"; Lwt.return ()) >>= fun () -> 126 | close writer; Lwt.return () 127 | ); 128 | writer 129 | 130 | let is_closed pipe = pipe.closed 131 | let closed pipe = fst pipe.closer 132 | 133 | (* If the writer is closed, so is the reader *) 134 | let rec transfer reader writer = 135 | match is_closed writer with 136 | | true -> 137 | Printf.eprintf "Writer closed early\n%!"; 138 | close_reader reader; 139 | Lwt.return () 140 | | false -> begin 141 | match Queue.take reader.queue with 142 | | v -> 143 | Queue.push v writer.queue; 144 | if Queue.length writer.queue = 1 then Lwt_condition.signal writer.cond (); 145 | transfer reader writer 146 | | exception Queue.Empty when reader.closed -> 147 | Lwt.return (); 148 | | exception Queue.Empty -> 149 | Lwt_condition.wait reader.cond >>= fun () -> 150 | transfer reader writer 151 | end 152 | end 153 | 154 | module Net = struct 155 | let (>>=?) = Lwt_result.Infix.(>>=) 156 | let lookup ~domain host = 157 | let open Lwt_unix in 158 | getaddrinfo host "" [AI_FAMILY domain 159 | ; AI_SOCKTYPE SOCK_STREAM] 160 | >>= function 161 | | {ai_addr=ADDR_INET (addr, _);_} :: _ -> Deferred.Or_error.return addr 162 | | _ -> Deferred.Or_error.fail (failwith ("Failed to resolve host: " ^ host)) 163 | 164 | let connect ?connect_timeout_ms ~inet ~host ~port ~scheme () = 165 | ignore connect_timeout_ms; 166 | let domain : Lwt_unix.socket_domain = 167 | match inet with 168 | | `V4 -> PF_INET 169 | | `V6 -> PF_INET6 170 | in 171 | lookup ~domain host >>=? fun addr -> 172 | let addr = Ipaddr_unix.of_inet_addr addr in 173 | let endp = match scheme with 174 | | `Http -> `TCP (`IP addr, `Port port) 175 | | `Https -> `TLS (`Hostname host, `IP addr, `Port port) 176 | in 177 | let connect () = 178 | let f () = Conduit_lwt_unix.connect ~ctx:(Lazy.force Conduit_lwt_unix.default_ctx) endp in 179 | match connect_timeout_ms with 180 | | Some ms -> Lwt_unix.with_timeout (float ms /. 1000.) f 181 | | None -> f () 182 | in 183 | connect () >>= fun (_flow, ic, oc) -> 184 | 185 | (* Lwt_io.input_channel *) 186 | let reader, input = Pipe.create () in 187 | let buffer_size = Lwt_io.buffer_size ic in 188 | let catch_result f = Lwt.catch (fun () -> Lwt_result.ok (f ())) Lwt_result.fail in 189 | let rec read () = 190 | catch_result (fun () -> Lwt_io.read ~count:buffer_size ic) >>= fun data -> 191 | match input.Pipe.closed, data with 192 | | _, Ok "" 193 | | _, Error _ -> 194 | Pipe.close input; 195 | Lwt.return () 196 | | true, _ -> 197 | Lwt.return () 198 | | false, Ok data -> 199 | Pipe.write input data >>= fun () -> 200 | read () 201 | in 202 | (* We close input and output when input is closed *) 203 | Lwt.async (fun () -> Pipe.closed reader >>= fun () -> 204 | Lwt_io.close oc >>= fun () -> Lwt_io.close ic); 205 | Lwt.async read; 206 | 207 | let output, writer = Pipe.create () in 208 | 209 | let rec write () = 210 | match Queue.take output.Pipe.queue with 211 | | Flush waiter -> 212 | Lwt_io.flush oc >>= fun () -> 213 | Lwt.wakeup_later waiter (); 214 | write () 215 | | Data data -> 216 | Lwt_io.write oc data >>= fun () -> 217 | write () 218 | | exception Queue.Empty when output.Pipe.closed -> 219 | Lwt.return () 220 | | exception Queue.Empty -> 221 | Lwt_condition.wait output.Pipe.cond >>= fun () -> 222 | write () 223 | in 224 | Lwt.async write; 225 | Deferred.Or_error.return (reader, writer) 226 | end 227 | -------------------------------------------------------------------------------- /aws-s3-lwt/io.mli: -------------------------------------------------------------------------------- 1 | include Aws_s3.Types.Io 2 | with type 'a Deferred.t = 'a Lwt.t 3 | -------------------------------------------------------------------------------- /aws-s3-lwt/s3.ml: -------------------------------------------------------------------------------- 1 | (** Lwt aware S3 commands. 2 | For API documentation 3 | @see <../../../aws-s3/Aws_s3/S3/Make/index.html>({!module:Aws_s3.S3.Make}) 4 | 5 | Lwt uses a default buffer size of 4096 bytes, which means that on high speed connections 6 | lwt will make needlessly many read / write system calls. 7 | 8 | When transferring data over high speed connections, it is recommended to increase 9 | the global channel buffer size e.g: Lwt_io.set_default_buffer_size (128*1024). 10 | 11 | Each operation will allocate at least 2*default_buffer_size. 12 | *) 13 | include Aws_s3.S3.Make(Io) 14 | -------------------------------------------------------------------------------- /aws-s3.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Anders Fugmann " 3 | authors: "Anders Fugmann" 4 | license: "BSD-3-Clause" 5 | homepage: "https://github.com/andersfugmann/aws-s3" 6 | dev-repo: "git+https://github.com/andersfugmann/aws-s3" 7 | bug-reports: "https://github.com/andersfugmann/aws-s3/issues" 8 | doc: "https://andersfugmann.github.io/aws-s3/" 9 | build: [ 10 | ["dune" "subst"] {dev} 11 | ["dune" "build" "-p" name "-j" jobs] 12 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 13 | ] 14 | depends: [ 15 | "ocaml" {>= "4.08.0"} 16 | "dune" {>= "2.0.0"} 17 | "ocaml-inifiles" 18 | "digestif" {>= "0.7"} 19 | "ptime" 20 | "uri" 21 | "ezxmlm" {>= "1.1.0"} 22 | "ppx_protocol_conv_xmlm" {>= "5.0.0"} 23 | "ppx_protocol_conv_json" {>= "5.0.0"} 24 | "yojson" 25 | "cmdliner" {>= "1.1.0"} 26 | "ppx_inline_test" {with-test} 27 | "base64" {>= "3.1.0"} 28 | ] 29 | synopsis: "Ocaml library for accessing Amazon S3" 30 | description: """ 31 | This library provides access to Amazon Simple Storage Solution (S3). 32 | The library supports: 33 | * Copying file to and from s3 34 | * List files in S3 (from root) 35 | * Delete single/multi object in S3 36 | * HEAD operation on single objects 37 | * Streaming transfer to and from aws. 38 | * Multi part upload (including s3 -> s3 copy) 39 | * Fetching machine role/credentials (though IAM) 40 | 41 | The library supports both lwt and async concurrency models. 42 | * For lwt, please install `aws-s3-lwt` package 43 | * For Async, please install `aws-s3-async` package""" 44 | -------------------------------------------------------------------------------- /aws-s3/authorization.ml: -------------------------------------------------------------------------------- 1 | (* Auth based on aws papers 2 | https://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html 3 | *) 4 | open StdLabels 5 | let sprintf = Printf.sprintf 6 | 7 | let debug = false 8 | let log fmt = match debug with 9 | | true -> Printf.kfprintf (fun _ -> ()) stderr ("%s: " ^^ fmt ^^ "\n%!") __MODULE__ 10 | | false -> Printf.ikfprintf (fun _ -> ()) stderr fmt 11 | 12 | let hash_sha256 s = 13 | Digestif.SHA256.digest_string s 14 | 15 | let hmac_sha256 ~key v = 16 | Digestif.SHA256.hmac_string ~key v 17 | 18 | let to_raw sha256 = Digestif.SHA256.to_raw_string sha256 19 | 20 | let to_hex str = Digestif.SHA256.to_hex str 21 | 22 | let make_signing_key = 23 | let cache = Hashtbl.create 0 in 24 | fun ?(bypass_cache=false) ~date ~region ~credentials ~service () -> 25 | match Hashtbl.find_opt cache (credentials.Credentials.access_key, region) with 26 | | Some (d, signing_key) when d = date && not bypass_cache -> signing_key 27 | | Some _ | None -> 28 | let date_key = hmac_sha256 ~key:("AWS4" ^ credentials.Credentials.secret_key) date in 29 | let date_region_key = hmac_sha256 ~key:(to_raw date_key) region in 30 | let date_region_service_key = hmac_sha256 ~key:(to_raw date_region_key) service in 31 | let signing_key = hmac_sha256 ~key:(to_raw date_region_service_key) "aws4_request" in 32 | Hashtbl.replace cache (credentials.Credentials.access_key, region) (date, signing_key); 33 | signing_key 34 | 35 | let make_scope ~date ~region ~service = 36 | sprintf "%s/%s/%s/aws4_request" date region service 37 | 38 | let string_to_sign ~date ~time ~verb ~path ~query ~headers ~payload_sha ~scope = 39 | let query = List.sort ~cmp:(fun a b -> String.compare (fst a) (fst b)) query in 40 | assert (Headers.cardinal headers > 0); 41 | (* Count sizes of headers *) 42 | let (key_size, value_size) = 43 | Headers.fold ( 44 | fun key data (h, v) -> (h + String.length key, v + String.length data) 45 | ) headers (0,0) 46 | in 47 | let header_count = Headers.cardinal headers in 48 | let canonical_headers = Buffer.create (key_size + value_size + (2 (*:\n*) * header_count)) in 49 | let signed_headers = Buffer.create (key_size + (Headers.cardinal headers - 1)) in 50 | 51 | let first = ref true in 52 | Headers.iter (fun key data -> 53 | let lower_header = String.lowercase_ascii key in 54 | if (not !first) then Buffer.add_string signed_headers ";"; 55 | Buffer.add_string signed_headers lower_header; 56 | Buffer.add_string canonical_headers lower_header; 57 | Buffer.add_string canonical_headers ":"; 58 | Buffer.add_string canonical_headers data; 59 | Buffer.add_string canonical_headers "\n"; 60 | first := false; 61 | ) headers; 62 | 63 | (* Strip the trailing from signed_headers *) 64 | let signed_headers = Buffer.contents signed_headers in 65 | let canonical_query = 66 | query 67 | |> List.map ~f:(fun (k, v) -> sprintf "%s=%s" (Uri.pct_encode ~component:`Userinfo k) (Uri.pct_encode ~component:`Userinfo v)) 68 | |> String.concat ~sep:"&" 69 | in 70 | 71 | 72 | let canonical_request = sprintf "%s\n%s\n%s\n%s\n%s\n%s" 73 | verb 74 | (Util.encode_string path) 75 | canonical_query 76 | (Buffer.contents canonical_headers) 77 | signed_headers 78 | payload_sha 79 | in 80 | log "Canonical request:\n%s\n" canonical_request; 81 | (* This could be cached. Its more or less static *) 82 | let string_to_sign = sprintf "AWS4-HMAC-SHA256\n%sT%sZ\n%s\n%s" 83 | date time 84 | scope 85 | (hash_sha256 canonical_request |> to_hex) 86 | in 87 | log "String to sign:\n%s\n" string_to_sign; 88 | log "Signed headers:\n%s\n" signed_headers; 89 | 90 | (string_to_sign, signed_headers) 91 | 92 | let make_signature ~date ~time ~verb ~path 93 | ~headers ~query ~scope ~(signing_key:Digestif.SHA256.t) ~payload_sha = 94 | let (string_to_sign, signed_headers) = 95 | string_to_sign ~date ~time ~verb ~path ~query ~headers ~payload_sha ~scope 96 | in 97 | (hmac_sha256 ~key:(to_raw signing_key) string_to_sign |> to_hex, signed_headers) 98 | 99 | let make_auth_header ~credentials ~scope ~signed_headers ~signature = 100 | sprintf "AWS4-HMAC-SHA256 Credential=%s/%s,SignedHeaders=%s,Signature=%s" 101 | credentials.Credentials.access_key 102 | scope 103 | signed_headers 104 | signature 105 | 106 | let make_presigned_url ?(scheme=`Https) ?host ?port ~credentials ~date ~region ~path ~bucket ~verb ~duration () = 107 | let service = "s3" in 108 | let ((y, m, d), ((h, mi, s), _)) = Ptime.to_date_time date in 109 | let verb = match verb with 110 | | `Get -> "GET" 111 | | `Put -> "PUT" in 112 | let scheme = match scheme with 113 | | `Http -> "http" 114 | | `Https -> "https" in 115 | let date = sprintf "%02d%02d%02d" y m d in 116 | let time = sprintf "%02d%02d%02d" h mi s in 117 | let (host, path) = 118 | match host with 119 | | None -> (sprintf "%s.s3.amazonaws.com" bucket, path) 120 | | Some h -> (h, sprintf "/%s/%s" bucket path) 121 | in 122 | let host_header = match port with 123 | | None -> host 124 | | Some p -> String.concat ~sep:":" [host; string_of_int p] 125 | in 126 | let duration = string_of_int duration in 127 | let region = Region.to_string region in 128 | let headers = Headers.singleton "Host" host_header in 129 | let query = 130 | let base = [ 131 | ("X-Amz-Algorithm", "AWS4-HMAC-SHA256"); 132 | ("X-Amz-Credential", sprintf "%s/%s/%s/s3/aws4_request" credentials.Credentials.access_key date region); 133 | ("X-Amz-Date", sprintf "%sT%sZ" date time); 134 | ("X-Amz-Expires", duration); 135 | ("X-Amz-SignedHeaders", "host"); 136 | ] 137 | in 138 | match credentials.token with 139 | | None -> base 140 | | Some token -> ("X-Amz-Security-Token", token) :: base 141 | in 142 | let scope = make_scope ~date ~region ~service in 143 | let signing_key = make_signing_key ~date ~region ~service ~credentials () in 144 | let signature, _signed_headers = 145 | make_signature ~date ~time ~verb ~path ~headers ~query ~signing_key ~scope ~payload_sha:"UNSIGNED-PAYLOAD" 146 | in 147 | let query = 148 | ("X-Amz-Signature", signature) :: query 149 | |> List.map ~f:(fun (k, v) -> (k, [v])) 150 | in 151 | Uri.make ~scheme ~host ?port ~path ~query () 152 | 153 | let%test "presigned_url (aws)" = 154 | let credentials = Credentials.make 155 | ~access_key:"AKIAIOSFODNN7EXAMPLE" 156 | ~secret_key:"wJalrXUtnFEMI/K7MDENG/bPxRfiCYEXAMPLEKEY" 157 | () 158 | in 159 | let date = match Ptime.of_date (2013, 5, 24) with Some x -> x | _ -> Ptime.epoch in 160 | let region = Region.of_string "us-east-1" in 161 | let path = "/test.txt" in 162 | let bucket = "examplebucket" in 163 | let verb = `Get in 164 | let duration = 86400 in 165 | let expected = "https://examplebucket.s3.amazonaws.com/test.txt?X-Amz-Signature=aeeed9bbccd4d02ee5c0109b86d86835f995330da4c265957d157751f604d404&X-Amz-Algorithm=AWS4-HMAC-SHA256&X-Amz-Credential=AKIAIOSFODNN7EXAMPLE/20130524/us-east-1/s3/aws4_request&X-Amz-Date=20130524T000000Z&X-Amz-Expires=86400&X-Amz-SignedHeaders=host" in 166 | let actual = make_presigned_url ~credentials ~date ~region ~path ~bucket ~verb ~duration () |> Uri.to_string in 167 | expected = actual 168 | 169 | let%test "presigned_url (minio)" = 170 | let credentials = Credentials.make 171 | ~access_key:"access" 172 | ~secret_key:"secretsecret" 173 | () 174 | in 175 | let date = match Ptime.of_date_time ((2019, 3, 6), ((23, 49, 50), 0)) with Some x -> x | _ -> assert false in 176 | let region = Region.Us_east_1 in 177 | let path = "dune" in 178 | let bucket = "example" in 179 | let verb = `Get in 180 | let duration = 604800 in 181 | let expected = "https://localhost:9000/example/dune?X-Amz-Signature=977ea9a866571ffba77fa1c0d843177bdba8cf004a2f61544cb3fade3f98d434&X-Amz-Algorithm=AWS4-HMAC-SHA256&X-Amz-Credential=access/20190306/us-east-1/s3/aws4_request&X-Amz-Date=20190306T234950Z&X-Amz-Expires=604800&X-Amz-SignedHeaders=host" in 182 | let actual = make_presigned_url ~host:"localhost" ~port:9000 ~credentials ~date ~region ~path ~bucket ~verb ~duration () |> Uri.to_string in 183 | expected = actual 184 | 185 | let%test "signing key" = 186 | let credentials = Credentials.make 187 | ~access_key:"AKIAIOSFODNN7EXAMPLE" 188 | ~secret_key:"wJalrXUtnFEMI/K7MDENG+bPxRfiCYEXAMPLEKEY" 189 | () 190 | in 191 | let date = "20120215" in 192 | let region = "us-east-1" in 193 | let service = "iam" in 194 | let signing_key = 195 | make_signing_key ~bypass_cache:true ~date ~region ~service ~credentials () 196 | |> to_hex 197 | in 198 | let expected = "f4780e2d9f65fa895f9c67b32ce1baf0b0d8a43505a000a1a9e090d414db404d" in 199 | signing_key = expected 200 | 201 | let%test "auth header" = 202 | let credentials = Credentials.make 203 | ~access_key:"AKIAIOSFODNN7EXAMPLE" 204 | ~secret_key:"wJalrXUtnFEMI/K7MDENG/bPxRfiCYEXAMPLEKEY" 205 | () 206 | in 207 | let date = "20130524" in 208 | let region = "us-east-1" in 209 | let path = "/test.txt" in 210 | let service = "s3" in 211 | let headers = 212 | [ ("Host","examplebucket.s3.amazonaws.com"); 213 | ("Range", "bytes=0-9"); 214 | ("x-amz-content-sha256", "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"); 215 | ("x-amz-date", "20130524T000000Z") 216 | ] 217 | |> List.fold_left ~f:(fun acc (key, value) -> Headers.add ~key ~value acc) ~init:Headers.empty 218 | in 219 | let verb = "GET" in 220 | let query = [] in 221 | let payload_sha = hash_sha256 "" |> to_hex in 222 | let scope = make_scope ~date ~region ~service in 223 | let signing_key = make_signing_key ~date ~region ~service ~credentials () in 224 | let signature, signed_headers = 225 | make_signature ~date ~time:"000000" ~verb ~path ~headers ~query ~signing_key ~scope ~payload_sha 226 | in 227 | let auth = make_auth_header ~credentials ~signature ~scope ~signed_headers in 228 | 229 | let expected = 230 | "AWS4-HMAC-SHA256 Credential=AKIAIOSFODNN7EXAMPLE/20130524/us-east-1/s3/aws4_request,SignedHeaders=host;range;x-amz-content-sha256;x-amz-date,Signature=f0e8bdb87c964420e857bd35b5d6ed310bd44f0170aba48dd91039c6036bdb41" 231 | in 232 | auth = expected 233 | 234 | let empty_sha_hex = hash_sha256 "" |> to_hex 235 | let chunk_signature ~(signing_key: Digestif.SHA256.t) ~date ~time ~scope ~previous_signature ~sha = 236 | let _initial = "STREAMING-AWS4-HMAC-SHA256-PAYLOAD" in 237 | let string_to_sign = sprintf "AWS4-HMAC-SHA256-PAYLOAD\n%sT%sZ\n%s\n%s\n%s\n%s" 238 | date time 239 | scope 240 | previous_signature 241 | empty_sha_hex 242 | (to_hex sha) 243 | in 244 | hmac_sha256 ~key:(to_raw signing_key) string_to_sign 245 | 246 | let%test "chunk_signature" = 247 | let credentials = Credentials.make 248 | ~access_key:"AKIAIOSFODNN7EXAMPLE" 249 | ~secret_key:"wJalrXUtnFEMI/K7MDENG/bPxRfiCYEXAMPLEKEY" 250 | () 251 | in 252 | 253 | let previous_signature = 254 | "4f232c4386841ef735655705268965c44a0e4690baa4adea153f7db9fa80a0a9" 255 | in 256 | let date = "20130524" in 257 | let time = "000000" in 258 | let scope = "20130524/us-east-1/s3/aws4_request" in 259 | let signing_key = make_signing_key 260 | ~bypass_cache:true 261 | ~date 262 | ~region:"us-east-1" 263 | ~service:"s3" 264 | ~credentials 265 | () 266 | in 267 | let sha = String.make 65536 'a' |> hash_sha256 in 268 | let signature = chunk_signature 269 | ~signing_key 270 | ~date ~time 271 | ~scope 272 | ~previous_signature 273 | ~sha 274 | in 275 | let expect = "ad80c730a21e5b8d04586a2213dd63b9a0e99e0e2307b0ade35a65485a288648" in 276 | signature |> to_hex = expect 277 | -------------------------------------------------------------------------------- /aws-s3/authorization.mli: -------------------------------------------------------------------------------- 1 | (**/**) 2 | val hash_sha256 : string -> Digestif.SHA256.t 3 | val hmac_sha256 : key:string -> string -> Digestif.SHA256.t 4 | val to_hex : Digestif.SHA256.t -> string 5 | 6 | val make_signing_key : 7 | ?bypass_cache:bool -> 8 | date:string -> 9 | region:string -> 10 | credentials:Credentials.t -> 11 | service:string -> unit -> Digestif.SHA256.t 12 | 13 | val make_scope : date:string -> region:string -> service:string -> string 14 | 15 | val string_to_sign : 16 | date:string -> 17 | time:string -> 18 | verb:string -> 19 | path:string -> 20 | query:(string * string) list -> 21 | headers:string Headers.t -> 22 | payload_sha:string -> scope:string -> 23 | string * string 24 | 25 | val make_signature : 26 | date:string -> 27 | time:string -> 28 | verb:string -> 29 | path:string -> 30 | headers:string Headers.t -> 31 | query:(string * string) list -> 32 | scope:string -> 33 | signing_key:Digestif.SHA256.t -> 34 | payload_sha:string -> 35 | string * string 36 | 37 | val make_auth_header : 38 | credentials:Credentials.t -> 39 | scope:string -> 40 | signed_headers:string -> 41 | signature:string -> string 42 | 43 | val chunk_signature: 44 | signing_key:Digestif.SHA256.t -> 45 | date:string -> 46 | time:string -> 47 | scope:string -> 48 | previous_signature:string -> 49 | sha:Digestif.SHA256.t -> Digestif.SHA256.t 50 | (**/**) 51 | 52 | (** This makes a presigned url that can be used to upload or download a file from s3 without any credentials other than those embedded in the url. [verb] should be either the string GET for download or PUT for upload.*) 53 | val make_presigned_url : 54 | ?scheme:[`Http | `Https] -> 55 | ?host:string -> 56 | ?port:int -> 57 | credentials:Credentials.t -> 58 | date:Ptime.t -> 59 | region:Region.t -> 60 | path:string -> 61 | bucket:string -> 62 | verb:[`Get | `Put] -> 63 | duration:int -> 64 | unit -> 65 | Uri.t 66 | -------------------------------------------------------------------------------- /aws-s3/aws.ml: -------------------------------------------------------------------------------- 1 | open StdLabels 2 | let sprintf = Printf.sprintf 3 | let debug = false 4 | let log fmt = match debug with 5 | | true -> Printf.kfprintf (fun _ -> ()) stderr ("%s: " ^^ fmt ^^ "\n%!") __MODULE__ 6 | | false -> Printf.ikfprintf (fun _ -> ()) stderr fmt 7 | let _ = log 8 | 9 | let empty_sha = Authorization.hash_sha256 "" |> Authorization.to_hex 10 | 11 | let get_chunked_length ~chunk_size payload_length = 12 | let lengths = 13 | (sprintf "%x" chunk_size |> String.length) * (payload_length / chunk_size) + 14 | (match payload_length mod chunk_size with 15 | | 0 -> 0 16 | | n -> (sprintf "%x" n |> String.length)) 17 | in 18 | let chunks = (payload_length + (chunk_size - 1)) / chunk_size + 1 in 19 | chunks * (4 + 17 + 64) + lengths + 1 + 20 | payload_length 21 | 22 | let%test "get_chunk_length" = 23 | get_chunked_length ~chunk_size:(64*1024) (65*1024) = 66824 24 | 25 | module Make(Io : Types.Io) = struct 26 | module Body = Body.Make(Io) 27 | module Http = Http.Make(Io) 28 | open Io 29 | open Deferred 30 | 31 | let chunk_writer ~signing_key ~scope ~initial_signature ~date ~time ~chunk_size reader = 32 | let open Deferred in 33 | let sub ~pos ?len str = 34 | let res = match pos, len with 35 | | 0, None -> str 36 | | 0, Some len when len = String.length str -> str 37 | | pos, None -> 38 | String.sub ~pos ~len:(String.length str - pos) str 39 | | pos, Some len -> 40 | String.sub ~pos ~len str 41 | in 42 | res 43 | in 44 | let send writer sha previous_signature elements length = 45 | let flush_done = Pipe.flush writer in 46 | let sha = Digestif.SHA256.get sha in 47 | let signature = Authorization.chunk_signature ~signing_key ~date ~time ~scope 48 | ~previous_signature ~sha |> Authorization.to_hex in 49 | Io.Pipe.write writer 50 | (Printf.sprintf "%x;chunk-signature=%s\r\n" length signature) >>= fun () -> 51 | List.fold_left 52 | ~init:(Deferred.return ()) ~f:(fun x data -> x >>= fun () -> Io.Pipe.write writer data) 53 | elements >>= fun () -> 54 | Io.Pipe.write writer "\r\n" >>= fun () -> 55 | flush_done >>= fun () -> 56 | return signature 57 | in 58 | let rec transfer previous_signature ctx (buffered:int) queue current writer = 59 | begin 60 | match current with 61 | | Some v -> return (Some v) 62 | | None -> 63 | Io.Pipe.read reader >>= function 64 | | None -> 65 | return None 66 | | Some v -> 67 | return (Some (v, 0)) 68 | end >>= function 69 | | None -> 70 | send writer ctx previous_signature (List.rev queue) buffered >>= fun signature -> 71 | send writer Digestif.SHA256.empty signature [] 0 >>= fun _signature -> 72 | Deferred.return () 73 | | Some (data, offset) -> begin 74 | let remain = chunk_size - buffered in 75 | match (String.length data) - offset with 76 | | n when n >= remain -> 77 | let elem = sub data ~pos:offset ~len:remain in 78 | let ctx = Digestif.SHA256.feed_string ctx elem in 79 | let elements = elem :: queue |> List.rev in 80 | send writer ctx previous_signature elements chunk_size >>= fun signature -> 81 | (* Recursive call. *) 82 | let data = match String.length data > remain with 83 | | true -> 84 | Some (data, offset + remain) 85 | | false -> 86 | None 87 | in 88 | transfer signature Digestif.SHA256.empty 0 [] data writer 89 | | _ -> 90 | let elem = sub ~pos:offset data in 91 | let ctx = Digestif.SHA256.feed_string ctx elem in 92 | transfer previous_signature ctx 93 | (buffered + String.length elem) 94 | (elem :: queue) None writer 95 | end 96 | in 97 | Pipe.create_reader ~f:(transfer initial_signature Digestif.SHA256.empty 0 [] None) 98 | 99 | let make_request ~(endpoint: Region.endpoint) ?connect_timeout_ms ?(expect=false) ~sink ?(body=Body.Empty) ?(credentials:Credentials.t option) ~headers ~meth ~path ~query () = 100 | let (date, time) = Unix.gettimeofday () |> Time.iso8601_of_time in 101 | 102 | (* Create headers structure *) 103 | let content_length = 104 | match meth, body with 105 | | (`PUT | `POST), Body.String body -> Some (String.length body |> string_of_int) 106 | | (`PUT | `POST), Body.Chunked { length; chunk_size; _ } -> 107 | Some (get_chunked_length ~chunk_size length |> string_of_int ) 108 | | (`PUT | `POST), Body.Empty -> Some "0" 109 | | _ -> None 110 | in 111 | let payload_sha = match body with 112 | | Body.Empty -> empty_sha 113 | | Body.String body -> Authorization.hash_sha256 body |> Authorization.to_hex 114 | | Body.Chunked _ -> "STREAMING-AWS4-HMAC-SHA256-PAYLOAD" 115 | in 116 | let token = match credentials with 117 | | Some { Credentials.token ; _ } -> token 118 | | None -> None 119 | in 120 | 121 | let headers, body = 122 | let decoded_content_length = match body with 123 | | Body.Chunked { length; _ } -> Some (string_of_int length) 124 | | _ -> None 125 | in 126 | let open Headers in 127 | let headers = 128 | List.fold_left ~init:empty ~f:(fun m (key, value) -> add ~key ~value m) headers 129 | |> add ~key:"Host" ~value:endpoint.host 130 | |> add ~key:"x-amz-content-sha256" ~value:payload_sha 131 | |> add ~key:"x-amz-date" ~value:(sprintf "%sT%sZ" date time) 132 | |> add_opt ~key:"x-amz-security-token" ~value:token 133 | |> add_opt ~key:"Content-Length" ~value:content_length 134 | |> change ~key:"User-Agent" ~f:(function Some _ as r -> r | None -> Some "aws-s3 ocaml client") 135 | |> add_opt ~key:"x-amz-decoded-content-length" ~value:decoded_content_length 136 | |> change ~key:"Content-Encoding" ~f:(fun v -> match body, v with 137 | | Body.Chunked _, Some v -> Some ("aws-chunked," ^ v) 138 | | Body.Chunked _, None -> Some "aws-chunked" 139 | | _, v -> v) 140 | in 141 | 142 | let auth, body = 143 | match credentials with 144 | | Some credentials -> 145 | let verb = Http.string_of_method meth in 146 | let region = Region.to_string endpoint.region in 147 | let signing_key = 148 | Authorization.make_signing_key ~date ~region ~service:"s3" ~credentials () 149 | in 150 | let scope = Authorization.make_scope ~date ~region ~service:"s3" in 151 | let signature, signed_headers = 152 | Authorization.make_signature ~date ~time ~verb ~path 153 | ~headers ~query:query ~scope ~signing_key ~payload_sha 154 | in 155 | let auth = (Authorization.make_auth_header ~credentials ~scope ~signed_headers ~signature) in 156 | let body = match body with 157 | | Body.String body -> 158 | let reader, writer = Pipe.create () in 159 | Pipe.write writer body >>= fun () -> 160 | Pipe.close writer; 161 | return (Some reader) 162 | | Body.Empty -> return None 163 | | Body.Chunked { pipe; chunk_size; _ } -> 164 | let pipe = 165 | (* Get errors if the chunk_writer fails *) 166 | chunk_writer ~signing_key ~scope 167 | ~initial_signature:signature ~date ~time ~chunk_size pipe 168 | in 169 | return (Some pipe) 170 | in 171 | Some auth, body 172 | | None -> 173 | let body = match body with 174 | | Body.String body -> 175 | let reader, writer = Pipe.create () in 176 | Pipe.write writer body >>= fun () -> 177 | Pipe.close writer; 178 | return (Some reader) 179 | | Body.Empty -> return None 180 | | Body.Chunked { pipe; _} -> 181 | return (Some pipe) 182 | in 183 | None, body 184 | in 185 | (Headers.add_opt ~key:"Authorization" ~value:auth headers), body 186 | in 187 | body >>= fun body -> 188 | Http.call ?connect_timeout_ms ~endpoint ~path ~query ~headers ~expect ~sink ?body meth >>=? fun (code, msg, headers, body) -> 189 | Deferred.Or_error.return (code, msg, headers, body) 190 | end 191 | -------------------------------------------------------------------------------- /aws-s3/aws.mli: -------------------------------------------------------------------------------- 1 | (**/**) 2 | module Make(Io : Types.Io) : sig 3 | open Io 4 | val make_request : 5 | endpoint:Region.endpoint -> 6 | ?connect_timeout_ms:int -> 7 | ?expect:bool -> 8 | sink:string Io.Pipe.writer -> 9 | ?body:Body.Make(Io).t -> 10 | ?credentials:Credentials.t -> 11 | headers:(string * string) list -> 12 | meth:[`GET | `PUT | `POST | `DELETE | `HEAD ] -> 13 | path:string -> 14 | query:(string * string) list -> 15 | unit -> 16 | (int * string * string Headers.t * string) Deferred.Or_error.t 17 | end 18 | (**/**) 19 | -------------------------------------------------------------------------------- /aws-s3/aws_s3.ml: -------------------------------------------------------------------------------- 1 | module S3 = S3 2 | module Types = Types 3 | module Credentials = Credentials 4 | module Region = Region 5 | module Authorization = Authorization 6 | -------------------------------------------------------------------------------- /aws-s3/body.ml: -------------------------------------------------------------------------------- 1 | open StdLabels 2 | 3 | module Make(Io : Types.Io) = struct 4 | open Io 5 | open Deferred 6 | 7 | type t = 8 | | String of string 9 | | Empty 10 | | Chunked of { pipe: string Pipe.reader; length: int; chunk_size: int } 11 | 12 | let null () = 13 | let rec read reader = 14 | Pipe.read reader >>= function 15 | | None -> return () 16 | | Some _ -> read reader 17 | in 18 | Pipe.create_writer ~f:read 19 | 20 | let to_string body = 21 | let rec loop acc = 22 | Pipe.read body >>= function 23 | | Some data -> 24 | loop (data :: acc) 25 | | None -> 26 | String.concat ~sep:"" (List.rev acc) |> return 27 | in 28 | loop [] 29 | 30 | let read_string ?start ~length reader = 31 | let rec loop acc data remain = 32 | match data, remain with 33 | | data, 0 -> Or_error.return (Buffer.contents acc, data) 34 | | None, remain -> begin 35 | Pipe.read reader >>= function 36 | | None -> Or_error.fail (Failure "EOF") 37 | | data -> loop acc data remain 38 | end 39 | | Some data, remain when String.length data < remain -> 40 | Buffer.add_string acc data; 41 | loop acc None (remain - String.length data) 42 | | Some data, remain -> 43 | Buffer.add_substring acc data 0 remain; 44 | Or_error.return 45 | (Buffer.contents acc, Some (String.sub data ~pos:remain ~len:(String.length data - remain))) 46 | in 47 | loop (Buffer.create length) start length 48 | 49 | let transfer ?start ~length reader writer = 50 | let rec loop writer data remain = 51 | match remain, data with 52 | | 0, data -> 53 | Or_error.return data 54 | | remain, Some data -> begin 55 | match remain - String.length data with 56 | | n when n >= 0 -> 57 | Pipe.write writer data >>= fun () -> 58 | loop writer None n 59 | | _ -> (* Only write whats expected and discard the rest *) 60 | Pipe.write writer (String.sub ~pos:0 ~len:remain data) >>= fun () -> 61 | loop writer None 0 62 | end 63 | | remain, None -> 64 | begin 65 | Pipe.read reader >>= function 66 | | None -> Or_error.fail (Failure "Premature end of input"); 67 | | data -> loop writer data remain 68 | end 69 | in 70 | loop writer start length 71 | 72 | let read_until ?start ~sep reader = 73 | let buffer = 74 | let b = Buffer.create 256 in 75 | match start with 76 | | Some data -> Buffer.add_string b data; b 77 | | None -> b 78 | in 79 | let rec loop offset = function 80 | | sep_index when sep_index = String.length sep -> 81 | (* Found it. Return data *) 82 | let v = Buffer.sub buffer 0 (offset - String.length sep) in 83 | let remain = 84 | match offset < Buffer.length buffer with 85 | | true -> Some (Buffer.sub buffer offset (Buffer.length buffer - offset)) 86 | | false -> None 87 | in 88 | Or_error.return (v, remain) 89 | | sep_index when offset >= (Buffer.length buffer) -> begin 90 | Pipe.read reader >>= function 91 | | Some data -> 92 | Buffer.add_string buffer data; 93 | loop offset sep_index; 94 | | None -> 95 | Or_error.fail (Failure (Printf.sprintf "EOF while looking for '%d'" (Char.code sep.[sep_index]))) 96 | end 97 | | sep_index when Buffer.nth buffer offset = sep.[sep_index] -> 98 | loop (offset + 1) (sep_index + 1) 99 | | sep_index -> 100 | (* Reset sep index. Look for the next element. *) 101 | loop (offset - sep_index + 1) 0 102 | in 103 | loop 0 0 104 | 105 | (** Chunked encoding 106 | format: \r\n\r\n. Always ends with 0 length chunk 107 | *) 108 | let chunked_transfer ?start reader writer = 109 | let rec read_chunk data remain = 110 | match data, remain with 111 | | data, 0 -> return (Ok data) 112 | | Some data, remain when String.length data < remain -> 113 | Pipe.write writer data >>= fun () -> 114 | read_chunk None (remain - String.length data) 115 | | Some data, remain -> 116 | Pipe.write writer (String.sub ~pos:0 ~len:remain data) >>= fun () -> 117 | read_chunk (Some (String.sub ~pos:remain ~len:(String.length data - remain) data)) 0 118 | | None, _ -> begin 119 | Pipe.read reader >>= function 120 | | None -> Or_error.fail (Failure "Premature EOF on input") 121 | | v -> read_chunk v remain 122 | end 123 | in 124 | let rec read remain = 125 | read_until ?start:remain ~sep:"\r\n" reader >>=? fun (size_str, data) -> 126 | begin 127 | try Scanf.sscanf size_str "%x" (fun x -> x) |> Or_error.return 128 | with _ -> Or_error.fail (Failure "Malformed chunk: Invalid length") 129 | end >>=? fun chunk_size -> 130 | match chunk_size with 131 | | 0 -> read_until ?start:data ~sep:"\r\n" reader >>=? fun (_, remain) -> 132 | Or_error.return remain 133 | | n -> 134 | read_chunk data n >>=? fun data -> 135 | read_string ?start:data ~length:2 reader >>=? function 136 | | ("\r\n", data) -> 137 | read data 138 | | (_, _data) -> 139 | Or_error.fail (Failure "Malformed chunk: CRLF not present") 140 | in 141 | read start 142 | end 143 | -------------------------------------------------------------------------------- /aws-s3/body.mli: -------------------------------------------------------------------------------- 1 | module Make(Io : Types.Io) : sig 2 | open Io 3 | type t = 4 | | String of string 5 | | Empty 6 | | Chunked of { pipe : string Pipe.reader; length : int; chunk_size : int; } 7 | (**/**) 8 | val to_string : 9 | string Pipe.reader -> 10 | string Deferred.t 11 | 12 | val read_string : 13 | ?start:string -> 14 | length:int -> 15 | string Pipe.reader -> (string * string option) Deferred.Or_error.t 16 | 17 | val read_until : 18 | ?start:string -> 19 | sep:string -> 20 | string Pipe.reader -> (string * string option) Deferred.Or_error.t 21 | 22 | val chunked_transfer : 23 | ?start:string -> 24 | string Pipe.reader -> 25 | string Pipe.writer -> 26 | string option Deferred.Or_error.t 27 | 28 | val transfer: 29 | ?start:string -> 30 | length:int -> 31 | string Pipe.reader -> 32 | string Pipe.writer -> 33 | string option Deferred.Or_error.t 34 | 35 | val null: unit -> string Pipe.writer 36 | (**/**) 37 | end 38 | -------------------------------------------------------------------------------- /aws-s3/credentials.ml: -------------------------------------------------------------------------------- 1 | open !StdLabels [@@warning "-66"] 2 | let sprintf = Printf.sprintf 3 | open Protocol_conv_json 4 | 5 | type time = float 6 | let time_of_json_exn t = 7 | try 8 | Json.to_string t |> Time.parse_iso8601_string 9 | with 10 | | _ -> raise Json.(Protocol_error (make_error ~value:t "Not an iso8601 string")) 11 | 12 | let%test "time conv" = 13 | time_of_json_exn (`String "2018-08-06T19:26:20Z") = 1533583580. 14 | 15 | type t = { 16 | access_key: string [@key "AccessKeyId"]; 17 | secret_key: string [@key "SecretAccessKey"]; 18 | token: string option [@key "Token"]; 19 | expiration: time option [@key "Expiration"]; 20 | } [@@deriving of_protocol ~driver:(module Json)] 21 | 22 | let make ~access_key ~secret_key ?token ?expiration () = 23 | { access_key; secret_key; token; expiration } 24 | 25 | module Make(Io : Types.Io) = struct 26 | module Http = Http.Make(Io) 27 | module Body = Body.Make(Io) 28 | open Io 29 | open Deferred 30 | 31 | module Iam = struct 32 | let instance_data_endpoint = 33 | let instance_data_host = "instance-data.ec2.internal" in 34 | let instance_region = Region.Other instance_data_host in 35 | Region.endpoint ~inet:`V4 ~scheme:`Http instance_region 36 | let get_role () = 37 | let path = "/latest/meta-data/iam/security-credentials/" in 38 | let body, sink = 39 | let reader, writer = Pipe.create () in 40 | Body.to_string reader, writer 41 | in 42 | Http.call ~endpoint:instance_data_endpoint ~path ~sink ~headers:Headers.empty `GET >>=? fun (status, message, _headers, error_body) -> 43 | match status with 44 | | code when code >= 200 && code < 300 -> 45 | body >>= fun body -> 46 | Deferred.Or_error.return body 47 | | _ -> 48 | let msg = sprintf "Failed to get role. %s. Reponse %s" message error_body in 49 | Deferred.Or_error.fail (Failure msg) 50 | 51 | let get_credentials role = 52 | let path = sprintf "/latest/meta-data/iam/security-credentials/%s" role in 53 | let body, sink = 54 | let reader, writer = Pipe.create () in 55 | Body.to_string reader, writer 56 | in 57 | Http.call ~endpoint:instance_data_endpoint ~path ~sink ~headers:Headers.empty `GET >>=? fun (status, message, _headers, error_body) -> 58 | match status with 59 | | code when code >= 200 && code < 300 -> 60 | body >>= fun body -> 61 | let json = Yojson.Safe.from_string body in 62 | Deferred.Or_error.catch (fun () -> of_json_exn json |> Deferred.Or_error.return) 63 | | _ -> 64 | let msg = sprintf "Failed to get credentials. %s. Reponse %s" message error_body in 65 | Deferred.Or_error.fail (Failure msg) 66 | end 67 | 68 | module Local = struct 69 | let get_credentials ?(profile="default") () = 70 | let home = Sys.getenv_opt "HOME" |> function Some v -> v | None -> "." in 71 | let creds_file = Printf.sprintf "%s/.aws/credentials" home in 72 | Deferred.Or_error.catch @@ 73 | fun () -> 74 | let ini = new Inifiles.inifile creds_file in 75 | let access_key = ini#getval profile "aws_access_key_id" in 76 | let secret_key = ini#getval profile "aws_secret_access_key" in 77 | make ~access_key ~secret_key () |> Deferred.Or_error.return 78 | end 79 | 80 | module Helper = struct 81 | let get_credentials ?profile () = 82 | match profile with 83 | | Some profile -> Local.get_credentials ~profile () 84 | | None -> begin 85 | Local.get_credentials ~profile:"default" () >>= function 86 | | Result.Ok c -> Deferred.Or_error.return c 87 | | Error _ -> 88 | Iam.get_role () >>=? fun role -> 89 | Iam.get_credentials role 90 | end 91 | end 92 | end 93 | -------------------------------------------------------------------------------- /aws-s3/credentials.mli: -------------------------------------------------------------------------------- 1 | (** Loading credentials locally or from IAM service. *) 2 | type t = { 3 | access_key: string; 4 | secret_key: string; 5 | token: string option; 6 | expiration: float option; 7 | } 8 | 9 | (** Make credentials *) 10 | val make : 11 | access_key:string -> secret_key:string -> 12 | ?token:string -> ?expiration:float -> unit -> t 13 | 14 | module Make(Io : Types.Io) : sig 15 | open Io 16 | 17 | module Iam : sig 18 | 19 | (** Get machine role though IAM service *) 20 | val get_role : unit -> string Deferred.Or_error.t 21 | 22 | (** Retrieve a credentials for a given role [role] *) 23 | val get_credentials : string -> t Deferred.Or_error.t 24 | 25 | end 26 | 27 | module Local : sig 28 | (** Load credentials from ~/.aws/credentials (file format compatible 29 | with botocore). *) 30 | val get_credentials : 31 | ?profile:string -> unit -> t Deferred.Or_error.t 32 | end 33 | 34 | module Helper : sig 35 | 36 | (** Get credentials locally or though IAM service. 37 | [profile] is used to speficy a specific section thethe local file. 38 | 39 | If profile is not supplied and no credentials can be found in 40 | the default section, then credentials are retrieved though Iam 41 | service, using an assigned machine role. 42 | *) 43 | val get_credentials : 44 | ?profile:string -> unit -> t Deferred.Or_error.t 45 | end 46 | end 47 | -------------------------------------------------------------------------------- /aws-s3/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name aws_s3) 3 | (public_name aws-s3) 4 | (synopsis "Amazon S3 access library") 5 | (libraries ptime inifiles digestif.c 6 | base64 uri yojson 7 | ppx_protocol_conv_json 8 | ppx_protocol_conv_xmlm str) 9 | (preprocess (pps ppx_inline_test ppx_protocol_conv)) 10 | (inline_tests) 11 | ) 12 | -------------------------------------------------------------------------------- /aws-s3/headers.ml: -------------------------------------------------------------------------------- 1 | include Map.Make(struct 2 | type t = string 3 | let compare a b = String.(compare (lowercase_ascii a) (lowercase_ascii b)) 4 | end) 5 | 6 | let change ~key ~f map = 7 | match f (find_opt key map) with 8 | | None -> remove key map 9 | | Some v -> add key v map 10 | 11 | let add ~key ~value map = add key value map 12 | 13 | let add_opt ~key ~value map = 14 | match value with 15 | | Some value -> add ~key ~value map 16 | | None -> map 17 | 18 | let find_prefix ~prefix map = 19 | let prefix_length = String.length prefix in 20 | let has_prefix s = 21 | match prefix_length <= String.length s with 22 | | false -> false 23 | | true -> 24 | let rec inner = function 25 | | 0 -> true 26 | | n -> 27 | let i = n - 1 in 28 | match Char.equal prefix.[i] s.[i] with 29 | | true -> inner (i) 30 | | false -> false 31 | in 32 | inner (String.length prefix) 33 | in 34 | fold (fun key v acc -> match has_prefix key with 35 | | true -> 36 | let key = String.sub key prefix_length (String.length key - prefix_length) in 37 | (key, v) :: acc 38 | | false -> acc) map [] 39 | -------------------------------------------------------------------------------- /aws-s3/headers.mli: -------------------------------------------------------------------------------- 1 | type key = string 2 | type 'a t 3 | val empty : 'a t 4 | val is_empty : 'a t -> bool 5 | val mem : key -> 'a t -> bool 6 | val singleton : key -> 'a -> 'a t 7 | val remove : key -> 'a t -> 'a t 8 | val merge : 9 | (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t 10 | val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t 11 | val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int 12 | val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool 13 | val iter : (key -> 'a -> unit) -> 'a t -> unit 14 | val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b 15 | val for_all : (key -> 'a -> bool) -> 'a t -> bool 16 | val exists : (key -> 'a -> bool) -> 'a t -> bool 17 | val filter : (key -> 'a -> bool) -> 'a t -> 'a t 18 | val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t 19 | val cardinal : 'a t -> int 20 | val bindings : 'a t -> (key * 'a) list 21 | val find : key -> 'a t -> 'a 22 | val find_opt : key -> 'a t -> 'a option 23 | val find_first : (key -> bool) -> 'a t -> key * 'a 24 | val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option 25 | val find_last : (key -> bool) -> 'a t -> key * 'a 26 | val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option 27 | val map : ('a -> 'b) -> 'a t -> 'b t 28 | val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t 29 | val change : key:key -> f:('a option -> 'a option) -> 'a t -> 'a t 30 | val add : key:key -> value:'a -> 'a t -> 'a t 31 | val add_opt : key:key -> value:'a option -> 'a t -> 'a t 32 | val find_prefix : prefix:string -> 'a t -> (key * 'a) list 33 | -------------------------------------------------------------------------------- /aws-s3/http.ml: -------------------------------------------------------------------------------- 1 | (**/**) 2 | open StdLabels 3 | let sprintf = Printf.sprintf 4 | let debug = false 5 | let log fmt = match debug with 6 | | true -> Printf.kfprintf (fun _ -> ()) stderr ("%s: " ^^ fmt ^^ "\n%!") __MODULE__ 7 | | false -> Printf.ikfprintf (fun _ -> ()) stderr fmt 8 | 9 | type meth = [ `DELETE | `GET | `HEAD | `POST | `PUT ] 10 | 11 | module Make(Io : Types.Io) = struct 12 | module Body = Body.Make(Io) 13 | open Io 14 | open Deferred 15 | 16 | let string_of_method = function 17 | | `GET -> "GET" 18 | | `PUT -> "PUT" 19 | | `HEAD -> "HEAD" 20 | | `POST -> "POST" 21 | | `DELETE -> "DELETE" 22 | 23 | let read_status ?start reader = 24 | let remain = start in 25 | (* Start reading the reply *) 26 | Body.read_until ?start:remain ~sep:" " reader >>=? fun (_http_version, remain) -> 27 | Body.read_until ?start:remain ~sep:" " reader >>=? fun (status_code, remain) -> 28 | Body.read_until ?start:remain ~sep:"\r\n" reader >>=? fun (status_message, remain) -> 29 | Or_error.return ((int_of_string status_code, status_message), remain) 30 | 31 | let read_headers ?start reader = 32 | let rec inner ?start acc = 33 | Body.read_until ?start ~sep:"\r\n" reader >>=? function 34 | | ("", remain) -> Or_error.return (acc, remain) 35 | | (line, remain) -> 36 | let (key, value) = 37 | match Str.split (Str.regexp ": ") line with 38 | | [] -> failwith "Illegal header" 39 | | [ k ] -> (k, "") 40 | | [ k; v ] -> (k, v) 41 | | k :: vs -> (k, String.concat ~sep:": " vs) 42 | in 43 | inner ?start:remain (Headers.add ~key ~value acc) 44 | in 45 | inner ?start Headers.empty 46 | 47 | let send_request ~expect ~path ~query ~headers ~meth writer () = 48 | let headers = match expect with 49 | | true -> Headers.add ~key:"Expect" ~value:"100-continue" headers 50 | | false -> headers 51 | in 52 | let path_with_params = 53 | let query = List.map ~f:(fun (k, v) -> k, [v]) query in 54 | Uri.make ~path ~query () |> Uri.to_string 55 | in 56 | let header = sprintf "%s %s HTTP/1.1\r\n" (string_of_method meth) path_with_params in 57 | Pipe.write writer header >>= fun () -> 58 | (* Write all headers *) 59 | Headers.fold (fun key value acc -> 60 | acc >>= fun () -> 61 | Pipe.write writer key >>= fun () -> 62 | Pipe.write writer ": " >>= fun () -> 63 | Pipe.write writer value >>= fun () -> 64 | Pipe.write writer "\r\n" >>= fun () -> 65 | return () 66 | ) headers (return ()) >>= fun () -> 67 | Pipe.write writer "\r\n" >>= fun () -> 68 | return () 69 | 70 | let handle_expect ~expect reader = 71 | match expect with 72 | | true -> begin 73 | log "Expect 100-continue"; 74 | read_status reader >>=? function 75 | | ((100, _), remain) -> 76 | log "Got 100-continue"; 77 | Or_error.return (`Continue remain) 78 | | ((code, message), remain) -> 79 | Or_error.return (`Failed ((code, message), remain)) 80 | end 81 | | false -> Or_error.return (`Continue None) 82 | 83 | let send_body ?body writer = 84 | let rec transfer reader writer = 85 | Pipe.read reader >>= function 86 | | Some data -> 87 | Pipe.write writer data >>= fun () -> 88 | transfer reader writer 89 | | None -> return () 90 | in 91 | match body with 92 | | None -> Or_error.return () 93 | | Some reader -> 94 | catch (fun () -> transfer reader writer) >>= fun result -> 95 | (* Close the reader and writer in any case *) 96 | Pipe.close_reader reader; 97 | return result (* Might contain an exception *) 98 | 99 | let read_data ?start ~sink ~headers reader = 100 | (* Test if the reply is chunked *) 101 | let chunked_transfer = 102 | match Headers.find_opt "transfer-encoding" headers with 103 | | Some encoding -> 104 | List.mem "chunked" ~set:(String.split_on_char ~sep:',' encoding) 105 | | None -> false 106 | in 107 | begin 108 | match (Headers.find_opt "content-length" headers, chunked_transfer) with 109 | | (None, false) -> Or_error.return None 110 | | Some length, false -> 111 | let length = int_of_string length in 112 | Body.transfer ?start ~length reader sink 113 | | _, true -> (* Actually we should not accept a content 114 | length then when encoding is chunked, but AWS 115 | does require this when uploading, so we 116 | accept it for symmetry.*) 117 | Body.chunked_transfer ?start reader sink 118 | end >>=? fun _remain -> 119 | (* We could log here is we have extra data *) 120 | Pipe.close sink; 121 | Or_error.return () 122 | 123 | let do_request ~expect ~path ?(query=[]) ~headers ~sink ?body meth reader writer = 124 | catch (send_request ~expect ~path ~query ~headers ~meth writer) >>=? fun () -> 125 | begin 126 | handle_expect ~expect reader >>=? function 127 | | `Failed ((code, message), remain) -> 128 | Or_error.return ((code, message), remain) 129 | | `Continue remain -> 130 | send_body ?body writer >>=? fun () -> 131 | read_status ?start:remain reader 132 | end >>=? fun ((code, message), remain) -> 133 | read_headers ?start:remain reader >>=? fun (headers, remain) -> 134 | 135 | 136 | let error_body, error_sink = 137 | let reader, writer = Pipe.create () in 138 | Body.to_string reader, writer 139 | in 140 | 141 | begin match meth with 142 | | `HEAD -> Or_error.return "" 143 | | _ -> 144 | let sink = match code with 145 | | n when 200 <= n && n < 300 -> 146 | Pipe.close error_sink; 147 | sink 148 | | _ -> 149 | Pipe.close sink; 150 | error_sink 151 | in 152 | read_data ?start:remain ~sink ~headers reader >>=? fun () -> 153 | error_body >>= fun error_body -> 154 | Or_error.return error_body 155 | end >>=? fun error_body -> 156 | Or_error.return (code, message, headers, error_body) 157 | 158 | 159 | let call ?(expect=false) ?connect_timeout_ms ~(endpoint:Region.endpoint) ~path ?(query=[]) ~headers ~sink ?body (meth:meth) = 160 | Net.connect ?connect_timeout_ms ~inet:endpoint.inet ~host:endpoint.host ~port:endpoint.port ~scheme:endpoint.scheme () >>=? fun (reader, writer) -> 161 | (* At this point we need to make sure reader and writer are closed properly. *) 162 | do_request ~expect ~path ~query ~headers ~sink ?body meth reader writer >>= fun result -> 163 | (* Close the reader and writer regardless of status *) 164 | Pipe.close writer; 165 | Pipe.close_reader reader; 166 | Pipe.close sink; 167 | return result 168 | end 169 | -------------------------------------------------------------------------------- /aws-s3/http.mli: -------------------------------------------------------------------------------- 1 | (**/**) 2 | type meth = [ `DELETE | `GET | `HEAD | `POST | `PUT ] 3 | 4 | module Make : functor(Io: Types.Io) -> sig 5 | open Io 6 | 7 | val string_of_method : meth -> string 8 | 9 | val call: 10 | ?expect:bool -> 11 | ?connect_timeout_ms:int -> 12 | endpoint:Region.endpoint -> 13 | path:string -> 14 | ?query:(string * string) list -> 15 | headers:string Headers.t -> 16 | sink:string Io.Pipe.writer -> 17 | ?body:string Pipe.reader -> 18 | meth -> 19 | (int * string * string Headers.t * string) Deferred.Or_error.t 20 | end 21 | (**/**) 22 | -------------------------------------------------------------------------------- /aws-s3/region.ml: -------------------------------------------------------------------------------- 1 | open !StdLabels 2 | let sprintf = Printf.sprintf 3 | 4 | type vendor = { 5 | region_name: string; 6 | host: string; 7 | port: int option; 8 | } 9 | 10 | type t = 11 | | Ap_northeast_1 (* Asia Pacific (Tokyo) *) 12 | | Ap_northeast_2 (* Asia Pacific (Seoul) *) 13 | | Ap_northeast_3 (* Asia Pacific (Osaka-Local) *) 14 | | Ap_southeast_1 (* Asia Pacific (Singapore) *) 15 | | Ap_southeast_2 (* Asia Pacific (Sydney) *) 16 | | Ap_south_1 (* Asia Pacific (Mumbai) *) 17 | | Eu_central_1 (* EU (Frankfurt) *) 18 | | Cn_northwest_1 (* China (Ningxia) *) 19 | | Cn_north_1 (* China (Beijing) *) 20 | | Eu_west_1 (* EU (Ireland) *) 21 | | Eu_west_2 (* EU (London) *) 22 | | Eu_west_3 (* EU (Paris) *) 23 | | Sa_east_1 (* South America (São Paulo) *) 24 | | Us_east_1 (* US East (N. Virginia) *) 25 | | Us_east_2 (* US East (Ohio) *) 26 | | Us_west_1 (* US West (N. California) *) 27 | | Us_west_2 (* US West (Oregon) *) 28 | | Ca_central_1 (* Canada - central *) 29 | | Other of string (* Other unknown *) 30 | | Vendor of vendor (* S3-compatible vendor/service *) 31 | 32 | let to_string = function 33 | | Ap_northeast_1 -> "ap-northeast-1" 34 | | Ap_northeast_2 -> "ap-northeast-2" 35 | | Ap_northeast_3 -> "ap-northeast-3" 36 | | Ap_southeast_1 -> "ap-southeast-1" 37 | | Ap_southeast_2 -> "ap-southeast-2" 38 | | Ap_south_1 -> "ap-south-1" 39 | | Eu_central_1 -> "eu-central-1" 40 | | Cn_northwest_1 -> "cn-northwest-1" 41 | | Cn_north_1 -> "cn-north-1" 42 | | Eu_west_1 -> "eu-west-1" 43 | | Eu_west_2 -> "eu-west-2" 44 | | Eu_west_3 -> "eu-west-3" 45 | | Sa_east_1 -> "sa-east-1" 46 | | Us_east_1 -> "us-east-1" 47 | | Us_east_2 -> "us-east-2" 48 | | Us_west_1 -> "us-west-1" 49 | | Us_west_2 -> "us-west-2" 50 | | Ca_central_1 -> "ca-central-1" 51 | | Other s -> s 52 | | Vendor v -> v.region_name 53 | 54 | let of_string = function 55 | | "ap-northeast-1" -> Ap_northeast_1 56 | | "ap-northeast-2" -> Ap_northeast_2 57 | | "ap-northeast-3" -> Ap_northeast_3 58 | | "ap-southeast-1" -> Ap_southeast_1 59 | | "ap-southeast-2" -> Ap_southeast_2 60 | | "ap-south-1" -> Ap_south_1 61 | | "eu-central-1" -> Eu_central_1 62 | | "cn-northwest-1" -> Cn_northwest_1 63 | | "cn-north-1" -> Cn_north_1 64 | | "eu-west-1" -> Eu_west_1 65 | | "eu-west-2" -> Eu_west_2 66 | | "eu-west-3" -> Eu_west_3 67 | | "sa-east-1" -> Sa_east_1 68 | | "us-east-1" -> Us_east_1 69 | | "us-east-2" -> Us_east_2 70 | | "us-west-1" -> Us_west_1 71 | | "us-west-2" -> Us_west_2 72 | | "ca-central-1" -> Ca_central_1 73 | | s -> failwith ("Unknown region: " ^ s) 74 | 75 | let vendor ~region_name ?port ~host () = 76 | Vendor { region_name; host; port } 77 | 78 | let minio ?port ~host () = 79 | vendor ~region_name:(to_string Us_east_1) ~host ?port () 80 | 81 | let backblaze ~region_name () = 82 | vendor ~region_name 83 | ?port:None 84 | ~host:(sprintf "s3.%s.backblazeb2.com" region_name) () 85 | 86 | type endpoint = { 87 | inet: [`V4 | `V6]; 88 | scheme: [`Http | `Https]; 89 | host: string; 90 | port: int; 91 | region: t; 92 | } 93 | 94 | 95 | let of_host host = 96 | match String.split_on_char ~sep:'.' host |> List.rev with 97 | | "com" :: "amazonaws" :: "s3" :: _ -> 98 | Us_east_1 99 | | "com" :: "amazonaws" :: host :: _ when 100 | String.length host > 3 && 101 | host.[0] = 's' && 102 | host.[1] = '3' && 103 | host.[2] = '-' -> 104 | String.sub ~pos:3 ~len:(String.length host - 3) host 105 | |> of_string 106 | | "com" :: "amazonaws" :: host :: _ -> 107 | host |> of_string 108 | | _ -> failwith "Cannot parse region from host" 109 | 110 | let to_host ~dualstack region = 111 | match region with 112 | | Vendor v -> v.host 113 | | _ -> 114 | let dualstack = match dualstack with 115 | | true -> ".dualstack" 116 | | false -> "" 117 | in 118 | to_string region |> sprintf "s3%s.%s.amazonaws.com" dualstack 119 | 120 | let to_port region = 121 | match region with 122 | | Vendor v -> v.port 123 | | _ -> None 124 | 125 | let endpoint ~inet ~scheme region = 126 | let port = 127 | match to_port region with 128 | | Some p -> p 129 | | None -> 130 | match scheme with 131 | | `Http -> 80 132 | | `Https -> 443 133 | in 134 | let dualstack = 135 | match inet with 136 | | `V4 -> false 137 | | `V6 -> true 138 | in 139 | { inet; scheme; host = to_host ~dualstack region; port; region } 140 | -------------------------------------------------------------------------------- /aws-s3/region.mli: -------------------------------------------------------------------------------- 1 | type vendor 2 | 3 | type t = 4 | | Ap_northeast_1 5 | | Ap_northeast_2 6 | | Ap_northeast_3 7 | | Ap_southeast_1 8 | | Ap_southeast_2 9 | | Ap_south_1 10 | | Eu_central_1 11 | | Cn_northwest_1 12 | | Cn_north_1 13 | | Eu_west_1 14 | | Eu_west_2 15 | | Eu_west_3 16 | | Sa_east_1 17 | | Us_east_1 18 | | Us_east_2 19 | | Us_west_1 20 | | Us_west_2 21 | | Ca_central_1 22 | | Other of string 23 | | Vendor of vendor 24 | 25 | val vendor : region_name:string -> ?port:int -> host:string -> unit -> t 26 | 27 | val minio : ?port:int -> host:string -> unit -> t 28 | 29 | val backblaze : region_name:string -> unit -> t 30 | 31 | type endpoint = { 32 | inet: [`V4 | `V6]; 33 | scheme: [`Http | `Https]; 34 | host: string; 35 | port: int; 36 | region: t; 37 | } 38 | 39 | val endpoint : 40 | inet:[`V4 | `V6] -> scheme:[`Http | `Https] -> t -> endpoint 41 | 42 | val to_string : t -> string 43 | val of_string : string -> t 44 | val of_host : string -> t 45 | -------------------------------------------------------------------------------- /aws-s3/s3.ml: -------------------------------------------------------------------------------- 1 | (*{{{ 2 | * Copyright (C) 2015 Trevor Smith 3 | * Copyright (C) 2017 Anders Fugmann 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | * 17 | }}}*) 18 | open StdLabels 19 | let sprintf = Printf.sprintf 20 | 21 | let xmlm_of_string string = 22 | let (_dtd, nodes) = Ezxmlm.from_string string in 23 | List.hd nodes 24 | 25 | let make_xmlm_node ?(ns = "") name attrs nodes : 'a Xmlm.frag = 26 | `El (((ns, name), attrs), nodes) 27 | 28 | module Option = struct 29 | let map ?default ~f = function 30 | | None -> default 31 | | Some v -> Some (f v) 32 | 33 | let value ~default = function 34 | | None -> default 35 | | Some v -> v 36 | 37 | let value_map ~default ~f v = 38 | map ~f v 39 | |> value ~default 40 | 41 | let value_exn ~message = function 42 | | Some v -> v 43 | | None -> failwith message 44 | 45 | end 46 | 47 | let rec filter_map ~f = function 48 | | [] -> [] 49 | | x :: xs -> begin 50 | match f x with 51 | | Some x -> x :: (filter_map ~f xs) 52 | | None -> (filter_map ~f xs) 53 | end 54 | 55 | 56 | (* Protocol definitions *) 57 | module Protocol(P: sig type 'a result end) = struct 58 | type time = float 59 | let time_of_xmlm_exn t = 60 | try 61 | Protocol_conv_xmlm.Xmlm.to_string t |> Time.parse_iso8601_string 62 | with 63 | | _ -> raise Protocol_conv_xmlm.Xmlm.(Protocol_error (make_error ~value:t "Not an iso8601 string")) 64 | 65 | let unquote s = 66 | match String.length s with 67 | | 0 | 1 -> s 68 | | _ when s.[0] = '"' -> 69 | String.sub s ~pos:1 ~len:(String.length s - 2) 70 | | _ -> s 71 | 72 | type etag = string 73 | let etag_of_xmlm_exn t = 74 | Protocol_conv_xmlm.Xmlm.to_string t |> unquote 75 | 76 | type storage_class = 77 | | Standard [@key "STANDARD"] 78 | | Standard_ia [@key "STANDARD_IA"] 79 | | Onezone_ia [@key "ONEZONE_IA"] 80 | | Reduced_redundancy [@key "REDUCED_REDUNDANCY"] 81 | | Glacier [@key "GLACIER"] 82 | and content = { 83 | storage_class: storage_class [@key "StorageClass"]; 84 | size: int [@key "Size"]; 85 | last_modified: time [@key "LastModified"]; 86 | key: string [@key "Key"]; 87 | etag: etag [@key "ETag"]; 88 | meta_headers: (string * string) list option; [@default None] 89 | (** Add expiration date option *) 90 | } [@@deriving of_protocol ~driver:(module Protocol_conv_xmlm.Xmlm)] 91 | 92 | module Ls = struct 93 | 94 | type result = { 95 | prefix: string option [@key "Prefix"]; 96 | common_prefixes: string option [@key "CommonPrefixes"]; 97 | delimiter: string option [@key "Delimiter"]; 98 | next_continuation_token: string option [@key "NextContinuationToken"]; 99 | name: string [@key "Name"]; 100 | max_keys: int [@key "MaxKeys"]; 101 | key_count: int [@key "KeyCount"]; 102 | is_truncated: bool [@key "IsTruncated"]; 103 | contents: content list [@key "Contents"]; 104 | start_after: string option [@key "StartAfter"]; 105 | } [@@deriving of_protocol ~driver:(module Protocol_conv_xmlm.Xmlm)] 106 | 107 | type t = (content list * cont) P.result 108 | and cont = More of (?max_keys:int -> unit -> t) | Done 109 | 110 | end 111 | 112 | let set_element_name: string -> 'a Xmlm.frag -> 'a Xmlm.frag = fun name -> function 113 | | `El (((ns, _), attrs), elems) -> 114 | make_xmlm_node ~ns name attrs elems 115 | | `Data _ -> failwith "Not an element" 116 | 117 | module Delete_multi = struct 118 | type objekt = { 119 | key: string [@key "Key"]; 120 | version_id: string option [@key "VersionId"]; 121 | } [@@deriving of_protocol ~driver:(module Protocol_conv_xmlm.Xmlm)] 122 | 123 | (** We must not transmit the version id at all if not specified *) 124 | let objekt_to_xmlm = function 125 | | { key; version_id = None } -> 126 | make_xmlm_node "object" [] [ make_xmlm_node "Key" [] [`Data key] ] 127 | | { key; version_id = Some version } -> 128 | make_xmlm_node "object" [] [ 129 | make_xmlm_node "Key" [] [`Data key]; 130 | make_xmlm_node "VersionId" [] [`Data version]; 131 | ] 132 | 133 | type request = { 134 | quiet: bool [@key "Quiet"]; 135 | objects: objekt list [@key "Object"] 136 | } [@@deriving to_protocol ~driver:(module Protocol_conv_xmlm.Xmlm)] 137 | 138 | let xml_of_request request = 139 | request_to_xmlm request |> set_element_name "Delete" 140 | 141 | type error = { 142 | key: string [@key "Key"]; 143 | version_id: string option [@key "VersionId"]; 144 | code: string [@key "Code"]; 145 | message : string [@key "Message"]; 146 | } [@@deriving of_protocol ~driver:(module Protocol_conv_xmlm.Xmlm)] 147 | 148 | type delete_marker = bool 149 | 150 | let delete_marker_of_xmlm_exn t = 151 | Protocol_conv_xmlm.Xmlm.to_option (Protocol_conv_xmlm.Xmlm.to_bool) t 152 | |> function None -> false 153 | | Some x -> x 154 | 155 | type result = { 156 | delete_marker: delete_marker [@key "DeleteMarker"]; 157 | delete_marker_version_id: string option [@key "DeleteMarkerVersionId"]; 158 | deleted: objekt list [@key "Deleted"]; 159 | error: error list [@key "Error"]; 160 | } [@@deriving of_protocol ~driver:(module Protocol_conv_xmlm.Xmlm)] 161 | 162 | end 163 | 164 | module Error_response = struct 165 | type t = { 166 | code: string [@key "Code"]; 167 | message: string [@key "Message"]; 168 | bucket: string option [@key "Bucket"]; 169 | endpoint: string option [@key "Endpoint"]; 170 | region: string option [@key "Region"]; 171 | request_id: string [@key "RequestId"]; 172 | host_id: string [@key "HostId"]; 173 | } [@@deriving of_protocol ~driver:(module Protocol_conv_xmlm.Xmlm)] 174 | end 175 | 176 | module Multipart = struct 177 | type part = { part_number: int [@key "PartNumber"]; 178 | etag: string [@key "ETag"]; 179 | } 180 | [@@deriving to_protocol ~driver:(module Protocol_conv_xmlm.Xmlm)] 181 | 182 | module Initiate = struct 183 | type t = { 184 | bucket: string [@key "Bucket"]; 185 | key: string [@key "Key"]; 186 | upload_id: string [@key "UploadId"]; 187 | } [@@deriving of_protocol ~driver:(module Protocol_conv_xmlm.Xmlm)] 188 | end 189 | module Complete = struct 190 | type request = { 191 | parts: part list [@key "Part"]; 192 | } 193 | [@@deriving to_protocol ~driver:(module Protocol_conv_xmlm.Xmlm)] 194 | let xml_of_request request = 195 | request_to_xmlm request |> set_element_name "CompleteMultipartUpload" 196 | type response = { location: string [@key "Location"]; 197 | bucket: string [@key "Bucket"]; 198 | key: string [@key "Key"]; 199 | etag: string [@key "ETag"]; 200 | } 201 | [@@deriving of_protocol ~driver:(module Protocol_conv_xmlm.Xmlm)] 202 | end 203 | module Copy = struct 204 | type t = { 205 | etag: string [@key "ETag"]; 206 | last_modified: time [@key "LastModified"]; 207 | } 208 | [@@deriving of_protocol ~driver:(module Protocol_conv_xmlm.Xmlm)] 209 | end 210 | end 211 | end 212 | 213 | module Make(Io : Types.Io) = struct 214 | module Aws = Aws.Make(Io) 215 | module Body = Body.Make(Io) 216 | open Io 217 | open Deferred 218 | type error = 219 | | Redirect of Region.endpoint 220 | | Throttled 221 | | Unknown of int * string 222 | | Failed of exn 223 | | Forbidden 224 | | Not_found 225 | 226 | let string_sink () = 227 | let reader, writer = Pipe.create () in 228 | Body.to_string reader, writer 229 | 230 | include Protocol(struct type nonrec 'a result = ('a, error) result Deferred.t end) 231 | 232 | type range = { first: int option; last: int option } 233 | 234 | type nonrec 'a result = ('a, error) result Deferred.t 235 | type 'a command = ?credentials:Credentials.t -> ?connect_timeout_ms:int -> ?confirm_requester_pays:bool -> endpoint:Region.endpoint -> 'a 236 | 237 | (** Conditionally add a header indicating caller's willingness to 238 | pay for AWS data transfer costs. This only applies to buckets 239 | configured to limit access to paying requesters. *) 240 | let maybe_add_request_payer confirm_requester_pays headers = 241 | match confirm_requester_pays with 242 | | true -> ("x-amz-request-payer", "requester") :: headers 243 | | false -> headers 244 | 245 | (**/**) 246 | let do_command ~(endpoint:Region.endpoint) cmd = 247 | cmd () >>= 248 | (function Ok v -> return (Ok v) | Error exn -> return (Error (Failed exn))) >>=? fun (code, _message, headers, body) -> 249 | match code with 250 | | code when 200 <= code && code < 300 -> 251 | Deferred.return (Ok headers) 252 | | 403 -> Deferred.return (Error Forbidden) 253 | | 404 -> Deferred.return (Error Not_found) 254 | | c when 300 <= c && c < 400 -> 255 | (* Redirect of sorts *) 256 | let region = 257 | Region.of_string 258 | (Headers.find "x-amz-bucket-region" headers) 259 | in 260 | Deferred.return (Error (Redirect {endpoint with region})) 261 | | c when 400 <= c && c < 500 -> begin 262 | let open Error_response in 263 | let xml = xmlm_of_string body in 264 | match Error_response.of_xmlm_exn xml with 265 | | { code = "PermanentRedirect"; endpoint = Some host; _ } 266 | | { code = "TemporaryRedirect"; endpoint = Some host; _ } -> 267 | let region = Region.of_host host in 268 | Deferred.return (Error (Redirect {endpoint with region})) 269 | | { code = "AuthorizationHeaderMalformed"; region = Some region; _ } -> 270 | let region = Region.of_string region in 271 | Deferred.return (Error (Redirect {endpoint with region})) 272 | | { code; _ } -> 273 | Deferred.return (Error (Unknown (c, code))) 274 | end 275 | | (500 | 503) -> 276 | (* 500, InternalError | 503, SlowDown | 503, ServiceUnavailable -> Throttle *) 277 | Deferred.return (Error Throttled) 278 | | code -> 279 | let resp = Error_response.of_xmlm_exn (xmlm_of_string body) in 280 | Deferred.return (Error (Unknown (code, resp.code))) 281 | 282 | 283 | let put_common ?credentials ?connect_timeout_ms ?(confirm_requester_pays=false) ~endpoint ?content_type ?content_encoding ?acl ?cache_control ?expect ?(meta_headers=[]) ~bucket ~key ~body () = 284 | let path = sprintf "/%s/%s" bucket key in 285 | let headers = 286 | ( 287 | [ "Content-Type", content_type; 288 | "Content-Encoding", content_encoding; 289 | "Cache-Control", cache_control; 290 | "x-amz-acl", acl; 291 | ] 292 | |> List.filter ~f:(function (_, Some _) -> true | (_, None) -> false) 293 | |> List.map ~f:(function (k, Some v) -> (k, v) | (_, None) -> failwith "Impossible") 294 | ) 295 | |> List.rev_append (meta_headers |> List.map ~f:(fun (k, v) -> (Printf.sprintf "x-amz-meta-%s" k, v))) 296 | |> maybe_add_request_payer confirm_requester_pays 297 | in 298 | let sink = Body.null () in 299 | let cmd () = 300 | Aws.make_request ~endpoint ?expect ?credentials ?connect_timeout_ms ~headers ~meth:`PUT ~path ~sink ~body ~query:[] () 301 | in 302 | 303 | do_command ~endpoint cmd >>=? fun headers -> 304 | let etag = 305 | match Headers.find_opt "etag" headers with 306 | | None -> failwith "Put reply did not contain an etag header" 307 | | Some etag -> unquote etag 308 | in 309 | Deferred.return (Ok etag) 310 | 311 | (**/**) 312 | 313 | module Stream = struct 314 | 315 | let get ?credentials ?connect_timeout_ms ?(confirm_requester_pays=false) ~endpoint ?range ~bucket ~key ~data () = 316 | let headers = 317 | let r_opt = function 318 | | Some r -> (string_of_int r) 319 | | None -> "" 320 | in 321 | match range with 322 | | Some { first = None; last = None } -> [] 323 | | Some { first = Some first; last } -> 324 | [ "Range", sprintf "bytes=%d-%s" first (r_opt last) ] 325 | | Some { first = None; last = Some last } when last < 0 -> 326 | [ "Range", sprintf "bytes=-%d" last ] 327 | | Some { first = None; last = Some last } -> 328 | [ "Range", sprintf "bytes=0-%d" last ] 329 | | None -> [] 330 | in 331 | let headers = maybe_add_request_payer confirm_requester_pays headers in 332 | let path = sprintf "/%s/%s" bucket key in 333 | let cmd () = 334 | Aws.make_request ~endpoint ?credentials ?connect_timeout_ms ~sink:data ~headers ~meth:`GET ~path ~query:[] () 335 | in 336 | do_command ~endpoint cmd >>=? fun (_headers) -> 337 | Deferred.return (Ok ()) 338 | 339 | let put ?credentials ?connect_timeout_ms ?confirm_requester_pays ~endpoint ?content_type ?content_encoding ?acl ?cache_control ?expect ?meta_headers ~bucket ~key ~data ~chunk_size ~length () = 340 | let body = Body.Chunked { length; chunk_size; pipe=data } in 341 | put_common ~endpoint ?credentials ?connect_timeout_ms ?confirm_requester_pays ?content_type ?content_encoding ?acl ?cache_control ?expect ?meta_headers ~bucket ~key ~body () 342 | end 343 | (* End streaming module *) 344 | 345 | let put ?credentials ?connect_timeout_ms ?confirm_requester_pays ~endpoint ?content_type ?content_encoding ?acl ?cache_control ?expect ?meta_headers ~bucket ~key ~data () = 346 | let body = Body.String data in 347 | put_common ?credentials ?connect_timeout_ms ?confirm_requester_pays ?content_type ?content_encoding ?acl ?cache_control ?expect ?meta_headers ~endpoint ~bucket ~key ~body () 348 | 349 | let get ?credentials ?connect_timeout_ms ?confirm_requester_pays ~endpoint ?range ~bucket ~key () = 350 | let body, data = string_sink () in 351 | Stream.get ?credentials ?connect_timeout_ms ?confirm_requester_pays ~endpoint ?range ~bucket ~key ~data () >>=? fun () -> 352 | body >>= fun body -> 353 | Deferred.return (Ok body) 354 | 355 | let delete ?credentials ?connect_timeout_ms ?(confirm_requester_pays=false) ~endpoint ~bucket ~key () = 356 | let path = sprintf "/%s/%s" bucket key in 357 | let sink = Body.null () in 358 | let headers = maybe_add_request_payer confirm_requester_pays [] in 359 | let cmd () = 360 | Aws.make_request ?credentials ?connect_timeout_ms ~endpoint ~headers ~meth:`DELETE ~path ~query:[] ~sink () 361 | in 362 | do_command ~endpoint cmd >>=? fun _headers -> 363 | Deferred.return (Ok ()) 364 | 365 | 366 | let head ?credentials ?connect_timeout_ms ?(confirm_requester_pays=false) ~endpoint ~bucket ~key () = 367 | let path = sprintf "/%s/%s" bucket key in 368 | let sink = Body.null () in 369 | let headers = maybe_add_request_payer confirm_requester_pays [] in 370 | let cmd () = 371 | Aws.make_request ?credentials ?connect_timeout_ms ~endpoint ~headers ~meth:`HEAD ~path ~query:[] ~sink () 372 | in 373 | do_command ~endpoint cmd >>=? fun headers -> 374 | let result = 375 | let (>>=) a f = match a with 376 | | Some x -> f x 377 | | None -> None 378 | in 379 | Headers.find_opt "content-length" headers >>= fun size -> 380 | Headers.find_opt "etag" headers >>= fun etag -> 381 | Headers.find_opt "last-modified" headers >>= fun last_modified -> 382 | let meta_headers = Headers.find_prefix ~prefix:"x-amz-meta-" headers in 383 | let last_modified = Time.parse_rcf1123_string last_modified in 384 | let size = size |> int_of_string in 385 | let storage_class = 386 | Headers.find_opt "x-amz-storage-class" headers 387 | |> Option.value_map ~default:Standard ~f:(fun s -> 388 | storage_class_of_xmlm_exn (make_xmlm_node "p" [] [`Data s]) 389 | ) 390 | in 391 | Some { storage_class; size; last_modified; key; etag = unquote etag; meta_headers = Some meta_headers} 392 | in 393 | match result with 394 | | Some r -> Deferred.return (Ok r) 395 | | None -> Deferred.return (Error (Unknown (1, "Result did not return correct headers"))) 396 | 397 | let delete_multi ?credentials ?connect_timeout_ms ?(confirm_requester_pays=false) ~endpoint ~bucket ~objects () = 398 | match objects with 399 | | [] -> Delete_multi.{ 400 | delete_marker = false; 401 | delete_marker_version_id = None; 402 | deleted = []; 403 | error = []; 404 | } |> (fun r -> Deferred.return (Ok r)) 405 | | _ -> 406 | let request = 407 | Delete_multi.{ 408 | quiet=false; 409 | objects=objects; 410 | } 411 | |> Delete_multi.xml_of_request 412 | |> fun req -> Ezxmlm.to_string [ req ] 413 | in 414 | let headers = [ "Content-MD5", Base64.encode_string (Stdlib.Digest.string request) ] in 415 | let headers = maybe_add_request_payer confirm_requester_pays headers in 416 | let body, sink = string_sink () in 417 | let cmd () = 418 | Aws.make_request ~endpoint 419 | ~body:(Body.String request) ?credentials ?connect_timeout_ms ~headers 420 | ~meth:`POST ~query:["delete", ""] ~path:("/" ^ bucket) ~sink () 421 | in 422 | do_command ~endpoint cmd >>=? fun _headers -> 423 | body >>= fun body -> 424 | let result = Delete_multi.result_of_xmlm_exn (xmlm_of_string body) in 425 | Deferred.return (Ok result) 426 | 427 | (** List contents of bucket in s3. *) 428 | let rec ls ?credentials ?connect_timeout_ms ?(confirm_requester_pays=false) ~endpoint ?start_after ?continuation_token ?prefix ?max_keys ~bucket () = 429 | let max_keys = match max_keys with 430 | | Some n when n > 1000 -> None 431 | | n -> n 432 | in 433 | let query = [ Some ("list-type", "2"); 434 | Option.map ~f:(fun ct -> ("continuation-token", ct)) continuation_token; 435 | Option.map ~f:(fun prefix -> ("prefix", prefix)) prefix; 436 | Option.map ~f:(fun max_keys -> ("max-keys", string_of_int max_keys)) max_keys; 437 | Option.map ~f:(fun start_after -> ("start-after", start_after)) start_after; 438 | ] |> filter_map ~f:(fun x -> x) 439 | in 440 | let headers = maybe_add_request_payer confirm_requester_pays [] in 441 | let body, sink = string_sink () in 442 | let cmd () = 443 | Aws.make_request ?credentials ?connect_timeout_ms ~endpoint ~headers ~meth:`GET ~path:("/" ^ bucket) ~query ~sink () 444 | in 445 | do_command ~endpoint cmd >>=? fun _headers -> 446 | body >>= fun body -> 447 | let result = Ls.result_of_xmlm_exn (xmlm_of_string body) in 448 | let continuation = match Ls.(result.next_continuation_token) with 449 | | Some ct -> 450 | Ls.More (ls ?credentials ?connect_timeout_ms ?start_after:None ~continuation_token:ct ?prefix ~confirm_requester_pays ~endpoint ~bucket) 451 | | None -> Ls.Done 452 | in 453 | Deferred.return (Ok (Ls.(result.contents, continuation))) 454 | 455 | (** Function for doing multipart uploads *) 456 | module Multipart_upload = struct 457 | type t = { id: string; 458 | mutable parts: Multipart.part list; 459 | bucket: string; 460 | key: string; 461 | } 462 | 463 | (** Initiate a multipart upload *) 464 | let init ?credentials ?connect_timeout_ms ?(confirm_requester_pays=false) ~endpoint ?content_type ?content_encoding ?acl ?cache_control ~bucket ~key () = 465 | let path = sprintf "/%s/%s" bucket key in 466 | let query = ["uploads", ""] in 467 | let headers = 468 | let content_type = Option.map ~f:(fun ct -> ("Content-Type", ct)) content_type in 469 | let cache_control = Option.map ~f:(fun cc -> ("Cache-Control", cc)) cache_control in 470 | let acl = Option.map ~f:(fun acl -> ("x-amz-acl", acl)) acl in 471 | filter_map ~f:(fun x -> x) [ content_type; content_encoding; cache_control; acl ] 472 | in 473 | let headers = maybe_add_request_payer confirm_requester_pays headers in 474 | let body, sink = string_sink () in 475 | let cmd () = 476 | Aws.make_request ?credentials ?connect_timeout_ms ~endpoint ~headers ~meth:`POST ~path ~query ~sink () 477 | in 478 | do_command ~endpoint cmd >>=? fun _headers -> 479 | body >>= fun body -> 480 | let resp = Multipart.Initiate.of_xmlm_exn (xmlm_of_string body) in 481 | Ok { id = resp.Multipart.Initiate.upload_id; 482 | parts = []; 483 | bucket; 484 | key; 485 | } 486 | |> Deferred.return 487 | 488 | (** Upload a part of the file. 489 | Parts must be at least 5Mb except for the last part 490 | [part_number] specifies the part numer. Parts will be assembled in order, but 491 | does not have to be consecutive 492 | *) 493 | let upload_part ?credentials ?connect_timeout_ms ?(confirm_requester_pays=false) ~endpoint t ~part_number ?expect ~data () = 494 | let path = sprintf "/%s/%s" t.bucket t.key in 495 | let query = 496 | [ "partNumber", string_of_int part_number; 497 | "uploadId", t.id ] 498 | in 499 | let sink = Body.null () in 500 | let headers = maybe_add_request_payer confirm_requester_pays [] in 501 | let cmd () = 502 | Aws.make_request ?expect ?credentials ?connect_timeout_ms ~endpoint ~headers ~meth:`PUT ~path 503 | ~body:(Body.String data) ~query ~sink () 504 | in 505 | do_command ~endpoint cmd >>=? fun headers -> 506 | let etag = 507 | Headers.find_opt "etag" headers 508 | |> (fun etag -> Option.value_exn ~message:"Put reply did not contain an etag header" etag) 509 | |> fun etag -> unquote etag 510 | in 511 | t.parts <- { etag; part_number } :: t.parts; 512 | Deferred.return (Ok ()) 513 | 514 | (** Specify a part to be a file on s3. 515 | [range] can be used to only include a part of the s3 file 516 | *) 517 | let copy_part ?credentials ?connect_timeout_ms ?(confirm_requester_pays=false) ~endpoint t ~part_number ?range ~bucket ~key () = 518 | let path = sprintf "/%s/%s" t.bucket t.key in 519 | let query = 520 | [ "partNumber", string_of_int part_number; 521 | "uploadId", t.id ] 522 | in 523 | let headers = 524 | ("x-amz-copy-source", sprintf "/%s/%s" bucket key) :: 525 | Option.value_map ~default:[] ~f:(fun (first, last) -> 526 | [ "x-amz-copy-source-range", sprintf "bytes=%d-%d" first last ]) range 527 | in 528 | let headers = maybe_add_request_payer confirm_requester_pays headers in 529 | let body, sink = string_sink () in 530 | let cmd () = 531 | Aws.make_request ?credentials ?connect_timeout_ms ~endpoint ~headers ~meth:`PUT ~path ~query ~sink () 532 | in 533 | 534 | do_command ~endpoint cmd >>=? fun _headers -> 535 | body >>= fun body -> 536 | let xml = xmlm_of_string body in 537 | match Multipart.Copy.of_xmlm_exn xml with 538 | | { Multipart.Copy.etag; _ } -> 539 | t.parts <- { etag; part_number } :: t.parts; 540 | Deferred.return (Ok ()) 541 | 542 | (** Complete the multipart upload. 543 | The returned etag is a opaque identifier (not md5) 544 | *) 545 | let complete ?credentials ?connect_timeout_ms ?(confirm_requester_pays=false) ~endpoint t () = 546 | let path = sprintf "/%s/%s" t.bucket t.key in 547 | let query = [ "uploadId", t.id ] in 548 | let request = 549 | (* TODO: Sort the parts by partNumber *) 550 | let parts = Stdlib.List.sort (fun a b -> compare a.Multipart.part_number b.part_number) t.parts in 551 | Multipart.Complete.(xml_of_request { parts }) 552 | |> (fun node -> Format.asprintf "%a" Ezxmlm.pp [node]) 553 | in 554 | let body, sink = string_sink () in 555 | let headers = maybe_add_request_payer confirm_requester_pays [] in 556 | let cmd () = 557 | Aws.make_request ?credentials ?connect_timeout_ms ~endpoint ~headers ~meth:`POST ~path ~query ~body:(Body.String request) ~sink () 558 | in 559 | do_command ~endpoint cmd >>=? fun _headers -> 560 | body >>= fun body -> 561 | let xml = xmlm_of_string body in 562 | match Multipart.Complete.response_of_xmlm_exn xml with 563 | | { location=_; etag; bucket; key } when bucket = t.bucket && key = t.key -> 564 | Ok etag |> Deferred.return 565 | | _ -> 566 | Error (Unknown ((-1), "Bucket/key does not match")) 567 | |> Deferred.return 568 | 569 | 570 | (** Abort a multipart upload, deleting all specified parts *) 571 | let abort ?credentials ?connect_timeout_ms ?(confirm_requester_pays=false) ~endpoint t () = 572 | let path = sprintf "/%s/%s" t.bucket t.key in 573 | let query = [ "uploadId", t.id ] in 574 | let sink = Body.null () in 575 | let headers = maybe_add_request_payer confirm_requester_pays [] in 576 | let cmd () = 577 | Aws.make_request ?credentials ~endpoint ?connect_timeout_ms ~headers ~meth:`DELETE ~path ~query ~sink () 578 | in 579 | do_command ~endpoint cmd >>=? fun _headers -> 580 | Deferred.return (Ok ()) 581 | 582 | module Stream = struct 583 | let upload_part ?credentials ?connect_timeout_ms ?(confirm_requester_pays=false) ~endpoint t ~part_number ?expect ~data ~length ~chunk_size () = 584 | let path = sprintf "/%s/%s" t.bucket t.key in 585 | let query = 586 | [ "partNumber", string_of_int part_number; 587 | "uploadId", t.id ] 588 | in 589 | let body = Body.Chunked { length; chunk_size; pipe=data } in 590 | let sink = Body.null () in 591 | let headers = maybe_add_request_payer confirm_requester_pays [] in 592 | let cmd () = 593 | Aws.make_request ?expect ?credentials ?connect_timeout_ms ~endpoint ~headers ~meth:`PUT ~path 594 | ~body ~query ~sink () 595 | in 596 | 597 | do_command ~endpoint cmd >>=? fun headers -> 598 | let etag = 599 | Headers.find_opt "etag" headers 600 | |> (fun etag -> Option.value_exn ~message:"Put reply did not contain an etag header" etag) 601 | |> fun etag -> String.sub ~pos:1 ~len:(String.length etag - 2) etag 602 | in 603 | t.parts <- { etag; part_number } :: t.parts; 604 | Deferred.return (Ok ()) 605 | end 606 | 607 | end 608 | 609 | let retry ~endpoint ~retries ~f () = 610 | let delay n = 611 | let jitter = Random.float 0.5 +. 0.5 in 612 | let backoff = 2.0 ** (float n) in 613 | (min 60.0 backoff) *. jitter 614 | in 615 | let rec inner ~endpoint ~retry_count ~redirected () = 616 | f ~endpoint () >>= function 617 | | Error (Redirect _) as e when redirected -> 618 | Deferred.return e 619 | | Error (Redirect endpoint) -> 620 | inner ~endpoint ~retry_count ~redirected:true () 621 | | Error _ as e when retry_count = retries -> 622 | Deferred.return e 623 | | Error (Throttled) -> 624 | Deferred.after (delay (retry_count + 1)) >>= fun () -> 625 | inner ~endpoint ~retry_count:(retry_count + 1) ~redirected () 626 | | Error _ -> 627 | inner ~endpoint ~retry_count:(retry_count + 1) ~redirected () 628 | | Ok r -> Deferred.return (Ok r) 629 | in 630 | inner ~endpoint ~retry_count:0 ~redirected:false () 631 | end 632 | 633 | let%test _ = 634 | let module Protocol = Protocol(struct type 'a result = 'a end) in 635 | let data = {| 636 | 637 | s3_osd 638 | 639 | 1 640 | 1000 641 | false 642 | 643 | STANDARD 644 | test 645 | 2018-02-27T13:39:35.000Z 646 | "7538d2bd85ea5dfb689ed65a0f60a7aa" 647 | 20 648 | 649 | 650 | STANDARD 651 | test 652 | 2018-02-27T13:39:35.000Z 653 | "7538d2bd85ea5dfb689ed65a0f60a7aa" 654 | 20 655 | 656 | 657 | |} 658 | in 659 | let xml = xmlm_of_string data in 660 | let result = Protocol.Ls.result_of_xmlm_exn xml in 661 | 2 = (List.length result.Protocol.Ls.contents) && 662 | "7538d2bd85ea5dfb689ed65a0f60a7aa" = (List.hd result.Protocol.Ls.contents).Protocol.etag 663 | 664 | let%test "parse Error_response.t" = 665 | let module Protocol = Protocol(struct type 'a result = 'a end) in 666 | let data = 667 | {| 668 | PermanentRedirect 669 | The bucket you are attempting to access must be addressed using the specified endpoint. Please send all future requests to this endpoint. 670 | testbucket 671 | testbucket.s3.amazonaws.com 672 | 9E23E3919C24476C 673 | zdQmjTUli+pR+gwwhfGt2/s7VVerHquAPqgi9KpZ9OVsYhfF+9uAkkRJtxPcLCJKk2ZjzV1VV= 674 | 675 | |} 676 | in 677 | let xml = xmlm_of_string data in 678 | let error = Protocol.Error_response.of_xmlm_exn xml in 679 | "PermanentRedirect" = error.Protocol.Error_response.code 680 | 681 | let%test "parse Delete_multi.result" = 682 | let module Protocol = Protocol(struct type 'a result = 'a end) in 683 | let data = 684 | {| 685 | 686 | test key1 687 | InternalError 688 | We encountered an internal error. Please try again. 689 | 690 | 691 | test key2 692 | InternalError 693 | We encountered an internal error. Please try again. 694 | 695 | 696 | |} 697 | in 698 | let xml = xmlm_of_string data in 699 | let error = Protocol.Delete_multi.result_of_xmlm_exn xml in 700 | 2 = (List.length error.Protocol.Delete_multi.error) && 701 | "InternalError" = (List.hd error.Protocol.Delete_multi.error).Protocol.Delete_multi.code 702 | -------------------------------------------------------------------------------- /aws-s3/s3.mli: -------------------------------------------------------------------------------- 1 | (** S3 functions 2 | All function requires a [region], [scheme] and [credentials]. 3 | 4 | The default region is [Us_east_1]. 5 | 6 | The default scheme is [http]. If you are connecting from outside AWS, 7 | it is strongly recommended that you use https. 8 | To use https, make sure to have the relevant opam packages installed: 9 | [async_ssl] for [async] and [lwt_ssl]/[tls] for [lwt]. 10 | Please note that connections are not reused due to a limitation on the AWS endpoint. 11 | 12 | 13 | If no credentials is provided, the requests will not be signed, 14 | The bucket / objects need to be configured accordingly. 15 | 16 | *) 17 | module Make(Io : Types.Io) : sig 18 | open Io 19 | 20 | type error = 21 | | Redirect of Region.endpoint 22 | | Throttled 23 | | Unknown of int * string 24 | | Failed of exn 25 | | Forbidden 26 | | Not_found 27 | 28 | type etag = string 29 | type storage_class = Standard | Standard_ia | Onezone_ia | Reduced_redundancy | Glacier 30 | type content = { 31 | storage_class : storage_class; 32 | size : int; 33 | last_modified : float; (** Seconds since epoch *) 34 | key : string; 35 | etag : etag; (** Etag as a string. this us usually the MD5, unless the object was constructed by multi-upload *) 36 | meta_headers: (string * string) list option; (** Meta headers. If None, the information was not retrieved. *) 37 | 38 | } 39 | 40 | type nonrec 'a result = ('a, error) result Deferred.t 41 | 42 | (** The type of S3 requests. [credentials] refers to AWS 43 | credentials, as created by [Credentials.make]. 44 | [connect_timeout_ms] specifies the request timeout, in 45 | milliseconds. If [confirm_requester_pays], caller acknowledges 46 | that it will pay AWS data transfer costs, should the target 47 | bucket be so configured. [endpoint] encapsulates the AWS 48 | endpoint, as created by [Region.endpoint]. *) 49 | type 'a command = ?credentials:Credentials.t -> ?connect_timeout_ms:int -> ?confirm_requester_pays:bool -> endpoint:Region.endpoint -> 'a 50 | 51 | module Ls : sig 52 | type t = (content list * cont) result 53 | and cont = More of (?max_keys:int -> unit -> t) | Done 54 | end 55 | 56 | module Delete_multi : sig 57 | type objekt = { key : string; version_id : string option; } 58 | type error = { 59 | key : string; 60 | version_id : string option; 61 | code : string; 62 | message : string; 63 | } 64 | type result = { 65 | delete_marker : bool; 66 | delete_marker_version_id : string option; 67 | deleted : objekt list; 68 | error : error list; 69 | } 70 | end 71 | 72 | type range = { first: int option; last:int option } 73 | 74 | (** Upload [data] to [bucket]/[key]. 75 | Returns the etag of the object. The etag is the md5 checksum (RFC 1864) 76 | 77 | @param expect If true, the body will not be sent until a 78 | status has been received from the server. This incurs a delay 79 | in transfer, but avoid sending a large body, if the request can be 80 | know to fail before the body is sent. 81 | @param meta_headers Can be used to set User-defined object metadata. 82 | arguments are expected to be a list of key-value pairs, the keys will be 83 | prefixed with "x-amz-meta-". 84 | @see https://docs.aws.amazon.com/AmazonS3/latest/userguide/UsingMetadata.html#UserMetadata 85 | *) 86 | val put : 87 | (?content_type:string -> 88 | ?content_encoding:string -> 89 | ?acl:string -> 90 | ?cache_control:string -> 91 | ?expect:bool -> 92 | ?meta_headers:(string * string) list -> 93 | bucket:string -> 94 | key:string -> 95 | data:string -> unit -> etag result) command 96 | 97 | (** Download [key] from s3 in [bucket] 98 | If [range] is specified, only a part of the file is retrieved: 99 | - If [first] is None, then start from the beginning of the object. 100 | - If [last] is None, then get to the end of the object. 101 | *) 102 | val get : 103 | (?range:range -> bucket:string -> key:string -> unit -> string result) command 104 | 105 | (** Call head on the object to retrieve info on a single object *) 106 | val head : 107 | (bucket:string -> key:string -> unit -> content result) command 108 | 109 | (** Delete [key] from [bucket]. *) 110 | val delete : 111 | (bucket:string -> key:string -> unit -> unit result) command 112 | 113 | (** Delete multiple objects from [bucket]. 114 | 115 | The result will indicate which items failed and which are deleted. If 116 | an item is not found it will be reported as successfully deleted 117 | (the operation is idempotent). 118 | *) 119 | val delete_multi : 120 | (bucket:string -> objects:Delete_multi.objekt list -> unit -> Delete_multi.result result) command 121 | 122 | (** List contents in [bucket] 123 | Aws will return at most 1000 keys per request. If not all keys are 124 | returned, the function will return a continuation. 125 | 126 | Keys in s3 are stored in lexicographical order, and also returned as such. 127 | 128 | If a [continuation_token] is given the result will continue from last call. 129 | 130 | If [start_after] is given then keys only keys after start_with are returned. 131 | Note that is both [start_after] and a [continuation_token] is given 132 | then start_after argument is ignored. 133 | 134 | If prefix is given, then only keys starting with the given prefix will be returned. 135 | *) 136 | val ls : 137 | (?start_after:string -> ?continuation_token:string -> ?prefix:string -> ?max_keys:int -> bucket:string -> unit -> Ls.t) command 138 | 139 | (** Streaming functions. 140 | Streaming function seeks to limit the amount of used memory used when 141 | operating of large objects by operating on streams. 142 | *) 143 | module Stream : sig 144 | 145 | (** Streaming version of put. 146 | @param length Amount of data to copy 147 | @param chunk_size The size of chunks send to s3. 148 | The system will have 2 x chunk_size byte in flight 149 | @param data stream to be uploaded. Data will not be consumed after 150 | the result is determined. If using [expect], then data may not have been consumed at all, 151 | but it is up to the caller to test if data has been consumed from the input data. 152 | 153 | see {!Aws_s3.S3.Make.put} 154 | *) 155 | val put : 156 | (?content_type:string -> 157 | ?content_encoding:string -> 158 | ?acl:string -> 159 | ?cache_control:string -> 160 | ?expect:bool -> 161 | ?meta_headers:(string * string) list -> 162 | bucket:string -> 163 | key:string -> 164 | data:string Io.Pipe.reader -> 165 | chunk_size:int -> 166 | length:int -> 167 | unit -> etag result) command 168 | 169 | (** Streaming version of get. 170 | The caller must supply a [data] sink to which retrieved data is streamed. 171 | The result will be determined after all data has been sent to the sink, and the data sink is closed. 172 | 173 | Connections to s3 is closed once the result has been determined. 174 | The caller should ways examine the result of the function. 175 | If the result is [Ok ()], then it is guaranteed that all data has been retrieved successfully and written to the data sink. 176 | In case of [Error _], only parts of the data may have been written to the data sink. 177 | 178 | The rationale for using a data sink rather than returning a pipe reader from which data 179 | can be consumed is that a reader does not allow simple relay of error states during the transfer. 180 | 181 | For other parameters see {!Aws_s3.S3.Make.get} 182 | *) 183 | val get : 184 | (?range:range -> bucket:string -> key:string -> data:string Io.Pipe.writer -> unit -> unit result) command 185 | 186 | end 187 | 188 | module Multipart_upload: sig 189 | type t 190 | 191 | (** Initialize multipart upload *) 192 | val init : 193 | (?content_type:string -> 194 | ?content_encoding:string * string -> 195 | ?acl:string -> 196 | ?cache_control:string -> 197 | bucket:string -> key:string -> unit -> t result) command 198 | 199 | (** Upload a part of the file. All parts except the last part must 200 | be at least 5Mb big. All parts must have a unique part number. 201 | The final file will be assembled from all parts ordered by part 202 | number 203 | 204 | @param expect: If true, the body will not be sent until a 205 | tatus has been received from the server. This incurs a delay 206 | in transfer, but avoid sending a large body, if the request is 207 | know to fail before the body is sent. 208 | *) 209 | val upload_part : 210 | (t -> 211 | part_number:int -> 212 | ?expect:bool -> 213 | data:string -> 214 | unit -> 215 | unit result) command 216 | 217 | (** Specify a part as a copy of an existing object in S3. *) 218 | val copy_part : 219 | (t -> part_number:int -> ?range:int * int -> bucket:string -> key:string -> unit -> unit result) command 220 | 221 | (** Complete a multipart upload. The returned string is an opaque identifier used as etag. 222 | the etag return is _NOT_ the md5 *) 223 | val complete : (t -> unit -> etag result) command 224 | 225 | (** Abort a multipart upload. This also discards all uploaded parts. *) 226 | val abort : (t -> unit -> unit result) command 227 | 228 | (** Streaming functions *) 229 | module Stream : sig 230 | 231 | (** Streaming version of upload_part. 232 | @param length is the amount of data to copy 233 | @param chunk_size Is the size of chunks send to s3. 234 | The system will have 2 x chunk_size byte in flight 235 | @param data the streamed data. Data will not be consumed after 236 | the result is determined. If using [expect], then data may not have been consumed at all, 237 | but it is up to the caller to test if data has been consumed from the input data. 238 | 239 | see {!Aws_s3.S3.Make.Multipart_upload.upload_part} 240 | *) 241 | val upload_part : 242 | (t -> 243 | part_number:int -> 244 | ?expect:bool -> 245 | data:string Io.Pipe.reader -> 246 | length:int -> 247 | chunk_size:int -> 248 | unit -> 249 | unit result) command 250 | end 251 | end 252 | 253 | (** Helper function to handle error codes. 254 | The function handle redirects and throttling. 255 | *) 256 | val retry : endpoint:Region.endpoint -> retries:int -> 257 | f:(endpoint:Region.endpoint -> unit -> 'a result) -> unit -> 'a result 258 | end 259 | -------------------------------------------------------------------------------- /aws-s3/time.ml: -------------------------------------------------------------------------------- 1 | open !StdLabels [@@warning "-66"] 2 | let sprintf = Printf.sprintf 3 | 4 | (* Use ptime for time conversions. This is error prone as we fiddle with the environment *) 5 | let parse_iso8601_string str = 6 | (* 7 | Scanf.sscanf str "%d-%d-%dT%d:%d:%d.%s" 8 | (fun year month day hour min sec _frac -> 9 | match Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)) with 10 | | None -> failwith "Illegal time format" 11 | | Some t -> Ptime.to_float_s t) 12 | *) 13 | Ptime.of_rfc3339 str 14 | |> function 15 | | Ok (t, _, _) -> Ptime.to_float_s t 16 | | Error _ -> failwith "Could not parse date string" 17 | 18 | let%test _ = 19 | parse_iso8601_string "2018-02-27T13:39:35.000Z" = 1519738775.0 20 | 21 | let parse_rcf1123_string date_str = 22 | let int_of_month = function 23 | | "Jan" -> 1 24 | | "Feb" -> 2 25 | | "Mar" -> 3 26 | | "Apr" -> 4 27 | | "May" -> 5 28 | | "Jun" -> 6 29 | | "Jul" -> 7 30 | | "Aug" -> 8 31 | | "Sep" -> 9 32 | | "Oct" -> 10 33 | | "Nov" -> 11 34 | | "Dec" -> 12 35 | | _ -> failwith "Unknown month" 36 | in 37 | Scanf.sscanf date_str "%s %d %s %d %d:%d:%d %s" 38 | (fun _dayname day month_str year hour min sec _zone -> 39 | let month = int_of_month month_str in 40 | match Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)) with 41 | | None -> failwith "Illegal time format" 42 | | Some t -> Ptime.to_float_s t) 43 | 44 | let%test _ = 45 | parse_rcf1123_string "Mon, 16 Jul 2018 10:31:41 GMT" = 1531737101.0 46 | 47 | let iso8601_of_time time = 48 | let t = 49 | Ptime.of_float_s time 50 | |> function Some t -> t | None -> failwith "Time out of range" 51 | in 52 | 53 | let (year, month, day), ((hour, min, sec), _) = Ptime.to_date_time t in 54 | let date_str = sprintf "%.4d%.2d%.2d" year month day in 55 | let time_str = sprintf "%.2d%.2d%.2d" hour min sec in 56 | (date_str, time_str) 57 | 58 | let%test _ = 59 | let t = 1369353600.0 in 60 | ("20130524", "000000") = iso8601_of_time t 61 | -------------------------------------------------------------------------------- /aws-s3/time.mli: -------------------------------------------------------------------------------- 1 | (**/**) 2 | val parse_rcf1123_string : string -> float 3 | val parse_iso8601_string : string -> float 4 | 5 | val iso8601_of_time : float -> string * string 6 | (**/**) 7 | -------------------------------------------------------------------------------- /aws-s3/types.ml: -------------------------------------------------------------------------------- 1 | (** Module for abstracting async and lwt *) 2 | module type Io = sig 3 | module Deferred : sig 4 | type 'a t 5 | module Or_error: sig 6 | type nonrec 'a t = ('a, exn) result t 7 | val return: 'a -> 'a t 8 | val fail: exn -> 'a t 9 | val catch: (unit -> 'a t) -> 'a t 10 | val (>>=): 'a t -> ('a -> 'b t) -> 'b t 11 | end 12 | 13 | val return: 'a -> 'a t 14 | val after: float -> unit t 15 | val catch: (unit -> 'a t) -> 'a Or_error.t 16 | val async: unit t -> unit 17 | 18 | val (>>=): 'a t -> ('a -> 'b t) -> 'b t 19 | val (>>|): 'a t -> ('a -> 'b) -> 'b t 20 | val (>>=?): ('a, 'c) result t -> ('a -> ('b, 'c) result t) -> ('b, 'c) result t 21 | end 22 | 23 | (**/**) 24 | module Ivar : sig 25 | type 'a t 26 | val create: unit -> 'a t 27 | val fill: 'a t -> 'a -> unit 28 | val wait: 'a t -> 'a Deferred.t 29 | end 30 | (**/**) 31 | 32 | (** Module mimicking Async.Pipe *) 33 | module Pipe : sig 34 | (** Generic pipe *) 35 | type ('a, 'b) pipe 36 | 37 | (**/**) 38 | type writer_phantom 39 | type reader_phantom 40 | 41 | (**/**) 42 | type 'a writer = ('a, writer_phantom) pipe 43 | type 'a reader = ('a, reader_phantom) pipe 44 | 45 | (** Create a reader given a function f that fills the reader. Once f completes, the reader is closed *) 46 | val create_reader : f:('a writer -> unit Deferred.t) -> 'a reader 47 | 48 | (** Create a writer given a function f that reads off the writer. Once f completes, the writer is closed *) 49 | val create_writer : f:('a reader -> unit Deferred.t) -> 'a writer 50 | 51 | (** Create a reader/writer pipe. Data written to the reader can be read by the writer. 52 | Closing one end will close both ends. *) 53 | val create : unit -> 'a reader * 'a writer 54 | 55 | (** Flush a writer. The result we be determined once all elements in the pipe has been consumed *) 56 | val flush : 'a writer -> unit Deferred.t 57 | 58 | (** Write to a writer. If the writer is closed, the function raises an exception *) 59 | val write: 'a writer -> 'a -> unit Deferred.t 60 | 61 | (** Close a writer *) 62 | val close: 'a writer -> unit 63 | 64 | (** Close a reader *) 65 | val close_reader: 'a reader -> unit 66 | 67 | (** Read one element from a reader. The function will block until an element becomes available or the 68 | reader is closed, in which case [None] is returned *) 69 | val read: 'a reader -> 'a option Deferred.t 70 | 71 | (** Transfer all data from the reader to the writer. The function becomes determined when the reader or writer is closed *) 72 | val transfer: 'a reader -> 'a writer -> unit Deferred.t 73 | 74 | (** Return the state of a pipe *) 75 | val is_closed: ('a, 'b) pipe -> bool 76 | 77 | (** Wait for a pipe to be closed. The function is determined once the pipe is closed. 78 | the function can be called multiple times. 79 | 80 | Note that not all elements may have been consumed yet. 81 | *) 82 | val closed : ('a, 'b) pipe -> unit Deferred.t 83 | end 84 | 85 | (**/**) 86 | module Net : sig 87 | val connect : 88 | ?connect_timeout_ms:int -> 89 | inet:[ `V4 | `V6 ] -> 90 | host:string -> 91 | port:int -> 92 | scheme:[< `Http | `Https ] -> 93 | unit -> 94 | (string Pipe.reader * string Pipe.writer) Deferred.Or_error.t 95 | end 96 | (**/**) 97 | 98 | end 99 | -------------------------------------------------------------------------------- /aws-s3/util.ml: -------------------------------------------------------------------------------- 1 | (*{{{ 2 | * Copyright (C) 2015 Trevor Smith 3 | * Copyright (C) 2018 Anders Fugmann 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | * 17 | }}}*) 18 | open StdLabels 19 | 20 | (* @see https://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-streaming.html 21 | public static String UriEncode(CharSequence input, boolean encodeSlash) { 22 | StringBuilder result = new StringBuilder(); 23 | for (int i = 0; i < input.length(); i++) { 24 | char ch = input.charAt(i); 25 | if ((ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9') || ch == '_' || ch == '-' || ch == '~' || ch == '.') { 26 | result.append(ch); 27 | } else if (ch == '/') { 28 | result.append(encodeSlash ? "%2F" : ch); 29 | } else { 30 | result.append(toHexUTF8(ch)); 31 | } 32 | } 33 | return result.toString(); 34 | } 35 | *) 36 | let encode_string s = 37 | (* Percent encode the path as s3 wants it. Uri doesn't 38 | encode $, or the other sep characters in a path. 39 | If upstream allows that we can nix this function *) 40 | let n = String.length s in 41 | let buf = Buffer.create (n * 3) in 42 | for i = 0 to (n-1) do 43 | let c = String.get s i in 44 | match c with 45 | | 'a' .. 'z' 46 | | 'A' .. 'Z' 47 | | '0' .. '9' 48 | | '_' | '-' | '~' | '.' | '/' -> Buffer.add_char buf c 49 | | '%' -> 50 | (* Sigh. Annoying we're expecting already escaped strings so ignore the escapes *) 51 | begin 52 | let is_hex = function 53 | | 'a' .. 'f' | 'A' .. 'F' | '0' .. '9' -> true 54 | | _ -> false 55 | in 56 | if (i + 2) < n then 57 | if is_hex(String.get s (i+1)) && is_hex(String.get s (i+2)) then 58 | Buffer.add_char buf c 59 | else 60 | Buffer.add_string buf "%25" 61 | end 62 | | _ -> Buffer.add_string buf (Printf.sprintf "%%%X" (Char.code c)) 63 | done; 64 | Buffer.contents buf 65 | -------------------------------------------------------------------------------- /aws-s3/util.mli: -------------------------------------------------------------------------------- 1 | (**/**) 2 | val encode_string : string -> string 3 | (**/**) 4 | -------------------------------------------------------------------------------- /clear_multi_part.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | BUCKET=$1 3 | aws s3api list-multipart-uploads --bucket $BUCKET | 4 | jq -r '.Uploads[] | "\(.UploadId) \(.Key)"' | 5 | while read id key; do 6 | echo KEY: $key, ID $id 7 | aws s3api abort-multipart-upload --bucket $BUCKET --key $key --upload-id $id 8 | done 9 | -------------------------------------------------------------------------------- /cli/aws.ml: -------------------------------------------------------------------------------- 1 | open StdLabels 2 | let sprintf = Printf.sprintf 3 | let ok_exn = function 4 | | Ok v -> v 5 | | Error exn -> raise exn 6 | 7 | module Option = struct 8 | let value ~default = function 9 | | Some v -> v 10 | | None -> default 11 | 12 | let value_exn ~message = function 13 | | Some v -> v 14 | | None -> failwith message 15 | end 16 | 17 | 18 | module Make(Io : Aws_s3.Types.Io) = struct 19 | module S3 = Aws_s3.S3.Make(Io) 20 | module Credentials = Aws_s3.Credentials.Make(Io) 21 | module Body = Aws_s3__Body.Make(Io) 22 | open Io 23 | open Deferred 24 | 25 | let file_length file = 26 | let ic = open_in file in 27 | let len = in_channel_length ic in 28 | close_in ic; 29 | len 30 | 31 | let read_file ~pos ~len file = 32 | let ic = open_in file in 33 | seek_in ic pos; 34 | let data = really_input_string ic len in 35 | close_in ic; 36 | data 37 | 38 | let file_reader ?(chunk_size=4097) ~pos ~len file = 39 | (* Create a stream with the data *) 40 | let ic = open_in file in 41 | (* Seek first *) 42 | seek_in ic pos; 43 | let rec read len writer = 44 | match len with 45 | | 0 -> return () 46 | | n when n < chunk_size -> 47 | let data = really_input_string ic n in 48 | Io.Pipe.write writer data 49 | | n -> 50 | let data = really_input_string ic chunk_size in 51 | Io.Pipe.write writer data >>= fun () -> 52 | (* Yield *) 53 | after 0.0 >>= fun () -> 54 | read (n - chunk_size) writer 55 | in 56 | let reader = Io.Pipe.create_reader ~f:(read len) in 57 | Io.Deferred.async (Io.Pipe.closed reader >>= fun () -> close_in ic; return ()); 58 | reader 59 | 60 | let save_file file contents = 61 | let oc = open_out file in 62 | output_string oc contents; 63 | close_out oc 64 | 65 | type objekt = { bucket: string; key: string } 66 | let objekt_of_uri u = 67 | match String.split_on_char ~sep:'/' u with 68 | | "s3:" :: "" :: bucket :: key -> 69 | { bucket; key = String.concat ~sep:"/" key } 70 | | _ -> failwith ("Illegal uri: " ^ u) 71 | 72 | let string_of_error = function 73 | | S3.Redirect _ -> "Redirect" 74 | | S3.Throttled -> "Throttled" 75 | | S3.Unknown (code, msg) -> sprintf "Unknown: %d, %s" code msg 76 | | S3.Failed exn -> sprintf "Failed: %s" (Printexc.to_string exn) 77 | | S3.Forbidden -> "Forbidden" 78 | | S3.Not_found -> "Not_found" 79 | 80 | type cmd = 81 | | S3toLocal of objekt * string 82 | | LocaltoS3 of string * objekt 83 | | S3toS3 of objekt * objekt 84 | 85 | let determine_paths src dst = 86 | let is_s3 u = 87 | String.split_on_char ~sep:'/' u 88 | |> List.hd 89 | |> fun scheme -> scheme = "s3:" 90 | in 91 | match is_s3 src, is_s3 dst with 92 | | (true, false) -> S3toLocal (objekt_of_uri src, dst) 93 | | (false, true) -> LocaltoS3 (src, objekt_of_uri dst) 94 | | (true, true) -> S3toS3 (objekt_of_uri src, objekt_of_uri dst) 95 | | (false, false) -> failwith "Use cp(1)" 96 | 97 | let rec upload_parts t endpoint ~retries ~expect ~credentials ?(offset=0) ~total ?(part_number=1) ?chunk_size src = 98 | let f ~size ~endpoint ()= 99 | match chunk_size with 100 | | None -> 101 | let data = read_file ~pos:offset ~len:size src in 102 | S3.Multipart_upload.upload_part ~endpoint ~expect ~credentials t ~part_number ~data () 103 | | Some chunk_size -> 104 | (* Create a reader for this section *) 105 | let reader = file_reader ~pos:offset ~len:size src in 106 | S3.Multipart_upload.Stream.upload_part ~endpoint ~expect ~credentials t ~part_number ~data:reader ~chunk_size ~length:size () 107 | in 108 | match (total - offset) with 109 | | 0 -> [] 110 | | len -> 111 | let size = min len (5*1024*1024) in 112 | (S3.retry ~endpoint ~retries ~f:(f ~size)) () :: 113 | upload_parts t endpoint ~retries ~expect ~credentials ~offset:(offset + size) ~total ~part_number:(part_number + 1) ?chunk_size src 114 | 115 | let cp profile endpoint ~retries ~expect ~confirm_requester_pays ?(use_multi=false) ?first ?last ?chunk_size src dst = 116 | let range = { S3.first; last } in 117 | Credentials.Helper.get_credentials ?profile () >>= fun credentials -> 118 | let credentials = ok_exn credentials in 119 | match determine_paths src dst with 120 | | S3toLocal (src, dst) -> 121 | let f ~endpoint () = match chunk_size with 122 | | None -> 123 | S3.get ~endpoint ~credentials ~range ~confirm_requester_pays ~bucket:src.bucket ~key:src.key () 124 | | Some _ -> 125 | let body, data = 126 | let r, w = Pipe.create () in 127 | Body.to_string r, w 128 | in 129 | S3.Stream.get ~endpoint ~credentials ~range ~confirm_requester_pays ~bucket:src.bucket ~key:src.key ~data () >>=? fun () -> 130 | body >>= fun body -> Deferred.return (Ok body) 131 | in 132 | S3.retry ~endpoint ~retries ~f () >>=? fun data -> 133 | save_file dst data; 134 | Deferred.return (Ok ()) 135 | | LocaltoS3 (src, dst) when use_multi -> 136 | let offset = match first with 137 | | None -> 0 138 | | Some n -> n 139 | in 140 | let last = match last with 141 | | None -> file_length src 142 | | Some n -> n 143 | in 144 | S3.retry ~endpoint ~retries 145 | ~f:(fun ~endpoint () -> S3.Multipart_upload.init ~confirm_requester_pays ~endpoint ~credentials ~bucket:dst.bucket ~key:dst.key ()) () >>=? fun t -> 146 | let uploads = upload_parts t endpoint ~retries ~expect ?chunk_size ~credentials ~offset ~total:last src in 147 | List.fold_left ~init:(Deferred.return (Ok ())) ~f:(fun acc x -> acc >>=? fun () -> x) uploads >>=? 148 | S3.retry ~endpoint ~retries 149 | ~f:(fun ~endpoint () -> S3.Multipart_upload.complete ~endpoint ~credentials t ()) >>=? fun _md5 -> 150 | Deferred.return (Ok ()) 151 | | LocaltoS3 (src, dst) -> 152 | let pos = Option.value ~default:0 first in 153 | let len = match last with 154 | | None -> file_length src - pos 155 | | Some l -> l - pos 156 | in 157 | let f = match chunk_size with 158 | | None -> 159 | let data = read_file ~pos ~len src in 160 | fun ~endpoint () -> S3.put ~endpoint ~expect ~credentials ~bucket:dst.bucket ~key:dst.key 161 | ~data () 162 | | Some chunk_size -> 163 | let reader = file_reader ~pos ~len src in 164 | fun ~endpoint () -> S3.Stream.put ~endpoint ~expect ~credentials ~bucket:dst.bucket ~key:dst.key 165 | ~data:reader ~chunk_size ~length:len () 166 | in 167 | S3.retry ~endpoint ~retries ~f () >>=? fun _etag -> 168 | Deferred.return (Ok ()) 169 | | S3toS3 (src, dst) -> 170 | S3.retry ~endpoint ~retries 171 | ~f:(fun ~endpoint () -> S3.Multipart_upload.init ~endpoint ~credentials ~bucket:dst.bucket ~key:dst.key ()) () >>=? fun t -> 172 | S3.retry ~endpoint ~retries 173 | ~f:(fun ~endpoint () -> S3.Multipart_upload.copy_part ~endpoint ~credentials t ~bucket:src.bucket ~key:src.key ~part_number:1 ()) () >>=? 174 | S3.retry ~endpoint ~retries 175 | ~f:(fun ~endpoint () -> S3.Multipart_upload.complete ~endpoint ~credentials t ()) >>=? fun _md5 -> 176 | Deferred.return (Ok ()) 177 | 178 | let rm profile endpoint ~confirm_requester_pays ~retries bucket paths = 179 | Credentials.Helper.get_credentials ?profile () >>= fun credentials -> 180 | let credentials = ok_exn credentials in 181 | match paths with 182 | | [ key ] -> 183 | S3.retry ~endpoint ~retries ~f:(S3.delete ~connect_timeout_ms:5000 ~credentials ~confirm_requester_pays ~bucket ~key) () 184 | | keys -> 185 | let objects : S3.Delete_multi.objekt list = List.map ~f:(fun key -> { S3.Delete_multi.key; version_id = None }) keys in 186 | S3.retry ~endpoint ~retries 187 | ~f:(S3.delete_multi ~connect_timeout_ms:5000 ~credentials ~confirm_requester_pays ~bucket ~objects) () >>=? fun _deleted -> 188 | Deferred.return (Ok ()) 189 | 190 | let head profile endpoint ~retries ~confirm_requester_pays path = 191 | Credentials.Helper.get_credentials ?profile () >>= fun credentials -> 192 | let credentials = ok_exn credentials in 193 | let { bucket; key } = objekt_of_uri path in 194 | S3.retry ~endpoint ~retries 195 | ~f:(S3.head ~connect_timeout_ms:5000 ~confirm_requester_pays ~credentials ~bucket ~key) () >>= function 196 | | Ok { S3.key; etag; size; meta_headers; _ } -> 197 | let meta_headers = List.map ~f:(fun (key, value) -> sprintf "%s=%s" key value) (Option.value ~default:[] meta_headers) |> String.concat ~sep:"; " in 198 | Printf.printf "Key: %s, Size: %d, etag: %s, meta_headers: [%s]\n" 199 | key size etag meta_headers; 200 | Deferred.return (Ok ()) 201 | | Error _ as e -> Deferred.return e 202 | 203 | let ls profile endpoint ~retries ~confirm_requester_pays ?ratelimit ?start_after ?max_keys ?prefix bucket = 204 | let ratelimit_f = match ratelimit with 205 | | None -> fun () -> Deferred.return (Ok ()) 206 | | Some n -> fun () -> after (1000. /. float n) >>= fun () -> Deferred.return (Ok ()) 207 | in 208 | let string_of_time time = 209 | Ptime.of_float_s time |> function 210 | | None -> "" 211 | | Some t -> Ptime.to_rfc3339 ~space:false t 212 | in 213 | let rec ls_all ?max_keys (result, cont) = 214 | List.iter ~f:(fun { S3.last_modified; key; size; etag; _ } -> Stdlib.Printf.printf "%s\t%d\t%s\t%s\n%!" (string_of_time last_modified) size key etag) result; 215 | let max_keys = match max_keys with 216 | | Some n -> Some (n - List.length result) 217 | | None -> None 218 | in 219 | match cont with 220 | | S3.Ls.More continuation -> ratelimit_f () 221 | >>=? S3.retry ~endpoint ~retries ~f:(fun ~endpoint:_ () -> continuation ?max_keys ()) 222 | >>=? ls_all ?max_keys 223 | | S3.Ls.Done -> Deferred.return (Ok ()) 224 | in 225 | Credentials.Helper.get_credentials ?profile () >>= fun credentials -> 226 | let credentials = ok_exn credentials in 227 | S3.retry ~endpoint ~retries ~f:(S3.ls ?connect_timeout_ms:None ~confirm_requester_pays ?start_after ?continuation_token:None ~credentials ?max_keys ?prefix ~bucket) () >>=? ls_all ?max_keys 228 | 229 | let exec ({ Cli.profile; https; minio; retries; ipv6; expect; confirm_requester_pays }, cmd) = 230 | let inet = if ipv6 then `V6 else `V4 in 231 | let scheme = if https then `Https else `Http in 232 | (* TODO: Get the region from the CLI *) 233 | let region : Aws_s3.Region.t = 234 | match minio with 235 | | Some minio -> 236 | let host, port = match String.split_on_char ~sep:':' minio with 237 | | [host; port] -> host, Some (int_of_string port) 238 | | [host] -> host, None 239 | | _ -> failwith "Unable to parse minio address" 240 | in 241 | Aws_s3.Region.minio ?port ~host () 242 | | None -> Us_east_1 243 | in 244 | let endpoint = Aws_s3.Region.endpoint ~inet ~scheme region in 245 | begin 246 | match cmd with 247 | | Cli.Cp { src; dest; first; last; multi; chunk_size } -> 248 | cp profile endpoint ~retries ~confirm_requester_pays ~expect ~use_multi:multi ?first ?last ?chunk_size src dest 249 | | Rm { bucket; paths } -> 250 | rm profile endpoint ~retries ~confirm_requester_pays bucket paths 251 | | Ls { ratelimit; bucket; prefix; start_after; max_keys } -> 252 | ls profile endpoint ~retries ~confirm_requester_pays ?ratelimit ?start_after ?prefix ?max_keys bucket 253 | | Head { path } -> 254 | head profile endpoint ~retries ~confirm_requester_pays path 255 | end >>= function 256 | | Ok _ -> return 0 257 | | Error e -> 258 | Printf.eprintf "Error: %s\n%!" (string_of_error e); 259 | return 1 260 | end 261 | -------------------------------------------------------------------------------- /cli/cli.ml: -------------------------------------------------------------------------------- 1 | (** Parse command line options *) 2 | open Cmdliner 3 | 4 | type actions = 5 | | Ls of { bucket: string; prefix: string option; start_after: string option; ratelimit: int option; max_keys: int option} 6 | | Head of { path: string; } 7 | | Rm of { bucket: string; paths : string list } 8 | | Cp of { src: string; dest: string; first: int option; last: int option; multi: bool; chunk_size: int option} 9 | 10 | type options = 11 | { profile: string option; minio: string option; https: bool; retries: int; ipv6: bool; expect: bool; confirm_requester_pays : bool } 12 | 13 | let parse exec = 14 | let profile = 15 | let doc = "Specify profile to use." in 16 | Arg.(value & opt (some string) None & info ["profile"; "p"] ~docv:"PROFILE" ~doc) 17 | in 18 | 19 | let ratelimit = 20 | let doc = "Limit requests to N/sec." in 21 | Arg.(value & opt (some int) None & info ["ratelimit"; "r"] ~docv:"LIMIT" ~doc) 22 | in 23 | 24 | let https = 25 | let doc = "Enable/disable https." in 26 | Arg.(value & opt bool false & info ["https"] ~docv:"HTTPS" ~doc) 27 | in 28 | 29 | let minio = 30 | let doc = "Connect to minio address [:port]" in 31 | Arg.(value & opt (some string) None & info ["minio"] ~docv:"MINIO" ~doc) 32 | in 33 | 34 | let ipv6 = 35 | let doc = "Use ipv6" in 36 | Arg.(value & flag & info ["6"] ~docv:"IPV6" ~doc) 37 | in 38 | 39 | let retries = 40 | let doc = "Retries in case of error" in 41 | Arg.(value & opt int 0 & info ["retries"] ~docv:"RETRIES" ~doc) 42 | in 43 | 44 | let expect = 45 | let doc = "Use expect -> 100-continue for put/upload_chunk" in 46 | Arg.(value & flag & info ["expect"; "e"] ~docv:"EXPECT" ~doc) 47 | in 48 | 49 | let confirm_requester_pays = 50 | let doc = "indicate that the client is willing to pay for the \ 51 | request, should the target bucket be configured to \ 52 | impose those costs on the requester." in 53 | Arg.(value & flag & info ["requester-pays"] ~docv:"REQUESTER-PAYS" ~doc) 54 | in 55 | 56 | let common_opts = 57 | let make profile minio https retries ipv6 expect confirm_requester_pays = { profile; minio; https; retries; ipv6; expect; confirm_requester_pays } in 58 | Term.(const make $ profile $ minio $ https $ retries $ ipv6 $ expect $ confirm_requester_pays ) 59 | in 60 | 61 | let bucket n = 62 | let doc = "S3 bucket name" in 63 | Arg.(required & pos n (some string) None & info [] ~docv:"BUCKET" ~doc) 64 | in 65 | 66 | let path n name = 67 | let doc = "path: |s3:///" in 68 | Arg.(required & pos n (some string) None & info [] ~docv:name ~doc) 69 | in 70 | 71 | let cp = 72 | let make opts first last multi chunk_size src dest = 73 | opts, Cp { src; dest; first; last; multi; chunk_size } 74 | in 75 | let first = 76 | let doc = "first byte of the source object to copy. If omitted means from the start." in 77 | Arg.(value & opt (some int) None & info ["first"; "f"] ~docv:"FIRST" ~doc) 78 | in 79 | let last = 80 | let doc = "last byte of the source object to copy. If omitted means to the end" in 81 | Arg.(value & opt (some int) None & info ["last"; "l"] ~docv:"LAST" ~doc) 82 | in 83 | let multi = 84 | let doc = "Use multipart upload" in 85 | Arg.(value & flag & info ["multi"; "m"] ~docv:"MULTI" ~doc) 86 | in 87 | 88 | let chunk_size = 89 | let doc = "Use streaming get / put the given chunk_size" in 90 | Arg.(value & opt (some int) None & info ["chunk-size"; "c"] ~docv:"CHUNK SIZE" ~doc) 91 | in 92 | Cmd.v 93 | Cmd.(info "cp" ~doc:"Copy files to and from S3") 94 | Term.(const make $ common_opts $ first $ last $ multi $ chunk_size $ path 0 "SRC" $ path 1 "DEST") 95 | in 96 | let rm = 97 | let objects = 98 | let doc = "name of the object to delete" in 99 | Arg.(non_empty & pos_right 0 string [] & info [] ~docv:"OBJECT" ~doc) 100 | in 101 | 102 | let make opts bucket paths = opts, Rm { bucket; paths } in 103 | Cmd.v 104 | Cmd.(info "rm" ~doc:"Delete files from s3") 105 | Term.(const make $ common_opts $ bucket 0 $ objects) 106 | in 107 | 108 | let head = 109 | let path = 110 | let doc = "object: s3:///" in 111 | Arg.(required & pos 0 (some string) None & info [] ~docv:"PATH" ~doc) 112 | in 113 | 114 | let make opts path = opts, Head { path } in 115 | Cmd.v 116 | Cmd.(info "head" ~doc:"Head files from s3") 117 | Term.(const make $ common_opts $ path) 118 | in 119 | 120 | let ls = 121 | let make opts ratelimit prefix start_after bucket max_keys = opts, Ls { bucket; prefix; start_after; ratelimit; max_keys } in 122 | 123 | let prefix = 124 | let doc = "Only list elements with the given prefix" in 125 | Arg.(value & opt (some string) None & info ["prefix"] ~docv:"PREFIX" ~doc) 126 | in 127 | 128 | let max_keys = 129 | let doc = "Max keys returned per ls request" in 130 | Arg.(value & opt (some int) None & info ["max-keys"] ~docv:"MAX KEYS" ~doc) 131 | in 132 | 133 | let start_after = 134 | let doc = "List objects after the given key" in 135 | Arg.(value & opt (some string) None & info ["start-after"] ~docv:"START AFTER" ~doc) 136 | in 137 | 138 | Cmd.v 139 | (Cmd.info "ls" ~doc:"List files in bucket") 140 | (Term.(const make $ common_opts $ ratelimit $ prefix $ start_after $ bucket 0 $ max_keys)) 141 | in 142 | 143 | (* Where do the result go? *) 144 | let help = 145 | let doc = "Amazon s3 command line interface" in 146 | Cmd.info Sys.argv.(0) ~doc 147 | in 148 | 149 | let commands = 150 | let cmds = [cp; rm; ls; head] in 151 | Cmd.group (help) cmds 152 | |> Cmd.eval_value 153 | in 154 | let run = function 155 | | Ok (`Ok cmd) -> exec cmd 156 | | _ -> 254 157 | in 158 | run @@ commands |> exit 159 | -------------------------------------------------------------------------------- /cli/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name aws_cli) 3 | (modules "aws" "cli") 4 | (libraries aws-s3 cmdliner) 5 | ) 6 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (name aws-s3) 3 | -------------------------------------------------------------------------------- /integration.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | #set -ex 4 | #set -o pipefail 5 | 6 | BUCKET=aws-s3-bucket 7 | PREFIX=aws-s3-test/ 8 | MINIO=127.0.0.1:9000 9 | #REDIRECT_BUCKET=aws-s3-test-eu 10 | 11 | while [ -n "$1" ]; do 12 | case "$1" in 13 | "-b"|"--bucket") BUCKET=$2; shift;; 14 | "-p"|"--prefix") PREFIX=$2; shift;; 15 | "-m"|"--minio") MINIO=$2; shift;; 16 | "-t"|"--type") TYPES="$TYPES $2"; shift;; 17 | "-r"|"--redirect") REDIRECT_BUCKET=$2; shift;; 18 | *) 19 | echo "Unknown option: $1" 20 | exit 1 21 | esac 22 | shift 23 | done 24 | 25 | TEMP=/tmp/test_data.bin 26 | 27 | LARGE_FILE=/tmp/rnd_big.bin 28 | FILE=/tmp/rnd.bin 29 | dd if=/dev/urandom of=$LARGE_FILE ibs=1k count=17k > /dev/null 2>&1 30 | dd if=$LARGE_FILE of=$FILE ibs=1k count=129 > /dev/null 2>&1 31 | 32 | FIRST_PART=1000 33 | LAST_PART=68000 34 | PART=/tmp/part.bin 35 | dd if=${LARGE_FILE} of=${PART} ibs=1 skip=$(( FIRST_PART )) count=$(( LAST_PART - FIRST_PART + 1)) > /dev/null 2>&1 36 | 37 | TEST=0 38 | function test { 39 | TEST=$(( TEST + 1)) 40 | echo -n "$TEST. $1: " 41 | shift 42 | $@ 43 | if [ $? -eq 0 ]; then 44 | echo "ok" 45 | else 46 | echo "fail" 47 | echo "Command: $@" 48 | exit 1 49 | fi 50 | } 51 | 52 | function cleanup { 53 | rm -f ${TEMP} 54 | rm -f ${PART} 55 | rm -f ${FILE} 56 | } 57 | 58 | #trap cleanup EXIT 59 | function test_simple () { 60 | BIN=$1;shift 61 | RETRIES=$1;shift 62 | HTTPS=$1;shift 63 | 64 | OPTIONS="--minio=${MINIO} --https=${HTTPS} --retries=${RETRIES}" 65 | 66 | echo "TEST SIMPLE aws-s3-$TYPE ${OPTIONS}" 67 | test "upload" ${BIN} cp ${OPTIONS} $FILE "s3://${BUCKET}/${PREFIX}test" 68 | test "head" ${BIN} head ${OPTIONS} "s3://${BUCKET}/${PREFIX}test" 69 | test "download" ${BIN} cp ${OPTIONS} "s3://${BUCKET}/${PREFIX}test" ${TEMP} 70 | test "data" diff -u $FILE ${TEMP} 71 | } 72 | 73 | function test_complete () { 74 | BIN=$1;shift 75 | RETRIES=$1;shift 76 | HTTPS=$1;shift 77 | 78 | OPTIONS="--minio=${MINIO} --https=${HTTPS} --retries=${RETRIES}" 79 | 80 | echo "TEST aws-s3-$TYPE ${OPTIONS}" 81 | 82 | #test "redirect upload expect" ${BIN} cp -e --retries=${RETRIES} $FILE s3://${REDIRECT_BUCKET}/${PREFIX}test 83 | #test "redirect head" ${BIN} head --retries=${RETRIES} s3://${REDIRECT_BUCKET}/${PREFIX}test 84 | #test "redirect download" ${BIN} cp --retries=${RETRIES} s3://${REDIRECT_BUCKET}/${PREFIX}test ${TEMP} 85 | #test "redirect data" diff -u $FILE ${TEMP} 86 | 87 | test "upload expect" ${BIN} cp -e ${OPTIONS} $FILE "s3://${BUCKET}/${PREFIX}test" 88 | test "head" ${BIN} head ${OPTIONS} "s3://${BUCKET}/${PREFIX}test" 89 | test "download" ${BIN} cp ${OPTIONS} "s3://${BUCKET}/${PREFIX}test" ${TEMP} 90 | test "data" diff -u $FILE ${TEMP} 91 | 92 | test "download stream" ${BIN} cp -c 8209 ${OPTIONS} "s3://${BUCKET}/${PREFIX}test ${TEMP}" 93 | test "data" diff -u $FILE ${TEMP} 94 | 95 | test "upload chunked expect" ${BIN} cp -e -c 8209 ${OPTIONS} $FILE "s3://${BUCKET}/${PREFIX}test" 96 | test "download stream" ${BIN} cp -c 8209 ${OPTIONS} "s3://${BUCKET}/${PREFIX}test ${TEMP}" 97 | test "data" diff -u $FILE ${TEMP} 98 | 99 | test "multi_upload" ${BIN} cp ${OPTIONS} -m $LARGE_FILE "s3://${BUCKET}/${PREFIX}test" 100 | test "download" ${BIN} cp ${OPTIONS} "s3://${BUCKET}/${PREFIX}test" ${TEMP} 101 | test "data" diff -u $LARGE_FILE ${TEMP} 102 | 103 | test "multi_upload chunked" ${BIN} cp -c 8209 ${OPTIONS} -m $LARGE_FILE "s3://${BUCKET}/${PREFIX}test" 104 | test "download" ${BIN} cp ${OPTIONS} "s3://${BUCKET}/${PREFIX}test" ${TEMP} 105 | test "data" diff -u $LARGE_FILE ${TEMP} 106 | 107 | test "multi_upload chunked expect" ${BIN} cp -e -c 8209 ${OPTIONS} -m $LARGE_FILE "s3://${BUCKET}/${PREFIX}test" 108 | test "download" ${BIN} cp ${OPTIONS} "s3://${BUCKET}/${PREFIX}test" ${TEMP} 109 | test "data" diff -u $LARGE_FILE ${TEMP} 110 | 111 | test "partial download" ${BIN} cp ${OPTIONS} "s3://${BUCKET}/${PREFIX}test" --first=$FIRST_PART --last=$LAST_PART ${TEMP} 112 | test "partial data" diff -u ${PART} ${TEMP} 113 | 114 | test "partial download stream" ${BIN} cp ${OPTIONS} --first=$FIRST_PART --last=$LAST_PART "s3://${BUCKET}/${PREFIX}test ${TEMP}" 115 | test "partial data" diff -u ${PART} ${TEMP} 116 | 117 | test "rm" ${BIN} rm ${OPTIONS} ${BUCKET} "${PREFIX}test" 118 | test "upload" ${BIN} cp ${OPTIONS} $FILE "s3://${BUCKET}/${PREFIX}test1" 119 | test "s3 cp" ${BIN} cp ${OPTIONS} "s3://${BUCKET}/${PREFIX}test1" "s3://${BUCKET}/${PREFIX}test2" 120 | test "ls" ${BIN} ls --max-keys=1 ${OPTIONS} ${BUCKET} --prefix="$PREFIX" 121 | test "multi rm" ${BIN} rm ${OPTIONS} ${BUCKET} "${PREFIX}test1" "${PREFIX}test2" 122 | } 123 | 124 | for TYPE in ${TYPES:-lwt}; do 125 | opam exec -- dune build aws-s3-${TYPE}/bin/aws_cli_${TYPE}.exe 126 | BIN=_build/default/aws-s3-${TYPE}/bin/aws_cli_${TYPE}.exe 127 | 128 | if [ -z "${MINIO}" ]; then 129 | test_simple "$BIN" 0 true 130 | fi 131 | test_simple "$BIN" 0 false 132 | 133 | if [ -z "${MINIO}" ]; then 134 | test_complete "$BIN" 0 true 135 | fi 136 | test_complete "$BIN" 0 false 137 | done 138 | -------------------------------------------------------------------------------- /minio/docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: '3' 2 | 3 | services: 4 | minio: 5 | image: minio/minio 6 | volumes: 7 | - data:/data 8 | ports: 9 | - "9000:9000" 10 | environment: 11 | MINIO_ACCESS_KEY: minio 12 | MINIO_SECRET_KEY: minio123 13 | command: server /data 14 | 15 | volumes: 16 | data: 17 | --------------------------------------------------------------------------------