diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,77 @@ +Changelog +========== + +## Version 1.0.0 + +This new release changes the following APIs to add new capabilities: + +* Copy Object API now supports more options for source and destination (#73) +* get/put Object functions now support a wider set of options via a + separate settings parameter (#71, #72) +* getBucketPolicy and setBucketPolicy APIs are added (#82) +* The library now uses UnliftIO (#83) + +## Version 0.3.2 + +This release brings the following changes: + +* Add `removeIncompleteUpload` API (#49) +* Add presigned operations APIs (#56) +* Add presigned Post Policy API (#58) +* Skip SHA256 checksum header for secure connections (#65) +* Remove resuming capability in PutObject (#67) +* Add ListObjectsV1 API support (#66) +* Add Bucket Notification APIs (#59) +* Reverse #54 - tests fix. + +## Version 0.3.1 + +This is a bug-fix release: + +* Fix concurrency bug in `limitedMapConcurrently` (#53) +* Fix tests related to listing incomplete uploads to accommodate Minio + server's changed behaviour to not list incomplete uploads. Note that + running these tests against AWS S3 are expected to fail. (#54) + +## Version 0.3.0 + +This release includes a breaking change: + +Users of the library need not call `runResourceT` explicitly after +calling `runMinio`. This is now done, within the `runMinio` call +making usage a bit simpler. + +Other changes: + +* Export ListUploadsResult and ListObjectsResult (#48) + * Also take max-keys as an argument for listObjects and max-uploads + for listIncompleteUploads. +* Add bucket and object name validation (#45) +* Add bucketExists and headBucket APIs (#42) + +## Version 0.2.1 + +* Update dependencies, and switch to Stackage LTS 8.5 + +## Version 0.2.0 + +This is an interim release which brings some new features. However, +the library is not complete and APIs may change. + +* Remove `listIncompleteParts` API and augment `listIncompleteUploads` + API with information about aggregate size of parts uploaded. +* Refactors error types and simpler error throwing/handling behaviour. +* Add `removeObject` API to delete objects from the service. +* Rename `Network.Minio.getService` to `Network.Minio.listBuckets`. +* Add `docs/API.md` and examples directory with comprehensive + documentation and examples of high-level APIs exported by the + library. +* Rename types: + * Rename PartInfo -> PartTuple + * Rename ListPartInfo -> ObjectPartInfo +* Add a bucket region cache to avoid locating a bucket's region for + every operation (mainly useful for AWS S3). +* Add new `copyObject` API to perform server side object copying. +* Rename `putObjectFromSource` API as `putObject`. +* Separate out tests into two suites, one with a live-server and the + other without any external dependencies. diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,8 @@ +# Contributors Guide +* Fork minio-hs. +* Create your feature branch (`$ git checkout -b my-new-feature`). +* Hack, hack, hack... +* Commit your changes (`$ git commit -am 'Add some feature'`). +* Do test build (`$ stack test`). +* Push to the branch (`$ git push origin my-new-feature`). +* Create new Pull Request. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,113 @@ +# Minio Client SDK for Haskell [![Build Status](https://travis-ci.org/minio/minio-hs.svg?branch=master)](https://travis-ci.org/minio/minio-hs)[![Hackage](https://img.shields.io/hackage/v/minio-hs.svg)](https://hackage.haskell.org/package/minio-hs)[![Slack](https://slack.minio.io/slack?type=svg)](https://slack.minio.io) + +The Minio Haskell Client SDK provides simple APIs to access [Minio](https://minio.io) and Amazon S3 compatible object storage server. + +## Minimum Requirements + +- The Haskell [stack](https://docs.haskellstack.org/en/stable/README/) + +## Installation + +```sh +git clone https://github.com/minio/minio-hs.git + +cd minio-hs/ + +stack install +``` + +Tests can be run with: + +```sh + +stack test + +``` + +A section of the tests use the remote Minio Play server at +`https://play.minio.io:9000` by default. For library development, +using this remote server maybe slow. To run the tests against a +locally running Minio live server at `http://localhost:9000`, just set +the environment `MINIO_LOCAL` to any value (and unset it to switch +back to Play). + +Documentation can be locally built with: + +```sh + +stack haddock + +``` + +## Quick-Start Example - File Uploader + +### FileUploader.hs +``` haskell +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs --package optparse-applicative --package filepath + +{-# Language OverloadedStrings, ScopedTypeVariables #-} +import Network.Minio + +import Control.Monad.Catch (catchIf) +import Control.Monad.IO.Class (liftIO) +import Data.Monoid ((<>)) +import Data.Text (pack) +import Options.Applicative +import Prelude +import System.FilePath.Posix + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +-- optparse-applicative package based command-line parsing. +fileNameArgs :: Parser FilePath +fileNameArgs = strArgument + (metavar "FILENAME" + <> help "Name of file to upload to AWS S3 or a Minio server") + +cmdParser = info + (helper <*> fileNameArgs) + (fullDesc + <> progDesc "FileUploader" + <> header + "FileUploader - a simple file-uploader program using minio-hs") + +ignoreMinioErr :: ServiceErr -> Minio () +ignoreMinioErr = return . const () + + +main :: IO () +main = do + let bucket = "my-bucket" + + -- Parse command line argument, namely --filename. + filepath <- execParser cmdParser + let object = pack $ takeBaseName filepath + + res <- runMinio minioPlayCI $ do + -- Make a bucket; catch bucket already exists exception if thrown. + catchIf (== BucketAlreadyOwnedByYou) (makeBucket bucket Nothing) ignoreMinioErr + + -- Upload filepath to bucket; object is derived from filepath. + fPutObject bucket object filepath + + case res of + Left e -> putStrLn $ "file upload failed due to " ++ (show e) + Right () -> putStrLn "file upload succeeded." +``` + +### Run FileUploader + +``` sh +./FileUploader.hs "path/to/my/file" + +``` + +## Contribute + +[Contributors Guide](https://github.com/minio/minio-hs/blob/master/CONTRIBUTING.md) diff --git a/docs/API.md b/docs/API.md new file mode 100644 --- /dev/null +++ b/docs/API.md @@ -0,0 +1,924 @@ +# Minio Haskell SDK API Reference + +## Initialize Minio Client object. + +### Minio - for public Play server + +```haskell +minioPlayCI :: ConnectInfo +minioPlayCI + +``` + +### AWS S3 + +```haskell +awsCI :: ConnectInfo +awsCI { connectAccesskey = "your-access-key" + , connectSecretkey = "your-secret-key" + } + +``` + +|Bucket operations|Object Operations|Presigned Operations| +|:---|:---|:---| +|[`listBuckets`](#listBuckets) |[`getObject`](#getObject)|[`presignedGetObjectUrl`](#presignedGetObjectUrl)| +|[`makeBucket`](#makeBucket)|[`putObject`](#putObject)|[`presignedPutObjectUrl`](#presignedPutObjectUrl)| +|[`removeBucket`](#removeBucket)|[`fGetObject`](#fGetObject)|[`presignedPostPolicy`](#presignedPostPolicy)| +|[`listObjects`](#listObjects)|[`fPutObject`](#fPutObject)|| +|[`listObjectsV1`](#listObjectsV1)|[`copyObject`](#copyObject)|| +|[`listIncompleteUploads`](#listIncompleteUploads)|[`removeObject`](#removeObject)|| +|[`bucketExists`](#bucketExists)||| + +## 1. Connecting and running operations on the storage service + +The Haskell Minio SDK provides high-level functionality to perform +operations on a Minio server or any AWS S3-like API compatible storage +service. + +### The `ConnectInfo` type + +The `ConnectInfo` record-type contains connection information for a +particular server. It is recommended to construct the `ConnectInfo` +value using one of the several smart constructors provided by the +library, documented in the following subsections. + +The library automatically discovers the region of a bucket by +default. This is especially useful with AWS, where buckets may be in +different regions. When performing an upload, download or other +operation, the library requests the service for the location of a +bucket and caches it for subsequent requests. + +#### awsCI :: ConnectInfo + +`awsCI` is a value that provides connection information for AWS +S3. Credentials can be supplied by overriding a couple of fields like +so: + +``` haskell +awsConn = awsCI { + connectAccessKey = "my-AWS-access-key" + , connectSecretKey = "my-AWS-secret-key" + } +``` + +#### awsWithRegionCI :: Region -> Bool -> ConnectInfo + +This constructor allows to specify the initial region and a Boolean to +enable/disable the automatic region discovery behaviour. + +The parameters in the expression `awsWithRegion region autoDiscover` are: + +|Parameter|Type|Description| +|:---|:---|:---| +| `region` | _Region_ (alias for `Text`) | The region to connect to by default for all requests. | +| `autoDiscover` | _Bool_ | If `True`, region discovery will be enabled. If `False`, discovery is disabled, and all requests go the given region only.| + +#### minioPlayCI :: ConnectInfo + +This constructor provides connection and authentication information to +connect to the public Minio Play server at +`https://play.minio.io:9000/`. + +#### minioCI :: Text -> Int -> Bool -> ConnectInfo + +Use to connect to a Minio server. + +The parameters in the expression `minioCI host port isSecure` are: + +|Parameter|Type|Description| +|:---|:---|:---| +| `host` | _Text_ | Hostname of the Minio or other S3-API compatible server | +| `port` | _Int_ | Port number to connect to| +| `isSecure` | _Bool_ | Does the server use HTTPS? | + +#### The ConnectInfo fields and Default instance + +The following table shows the fields in the `ConnectInfo` record-type: + +| Field | Type | Description | +|:---|:---|:---| +| `connectHost` | _Text_ | Host name of the server. Defaults to `localhost`. | +| `connectPort` | _Int_ | Port number on which the server listens. Defaults to `9000`. | +| `connectAccessKey` | _Text_ | Access key to use in authentication. Defaults to `minio`. | +| `connectSecretkey` | _Text_ | Secret key to use in authentication. Defaults to `minio123`. | +| `connectIsSecure` | _Bool_ | Specifies if the server used TLS. Defaults to `False` | +| `connectRegion` | _Region_ (alias for `Text`) | Specifies the region to use. Defaults to 'us-east-1' | +| `connectAutoDiscoverRegion` | _Bool_ | Specifies if the library should automatically discover the region of a bucket. Defaults to `True`| + +The `def` value of type `ConnectInfo` has all the above default +values. + +### The Minio Monad + +This monad provides the required environment to perform requests +against a Minio or other S3 API compatible server. It uses the +connection information from the `ConnectInfo` value provided to it. It +performs connection pooling, bucket location caching, error handling +and resource clean-up actions. + +The `runMinio` function performs the provided action in the `Minio` +monad and returns a `IO (Either MinioErr a)` value: + +``` haskell +{-# Language OverloadedStrings #-} + +import Network.Minio + +main :: IO () +main = do + result <- runMinio def $ do + buckets <- listBuckets + return $ length buckets + + case result of + Left e -> putStrLn $ "Failed operation with error: " ++ show e + Right n -> putStrLn $ show n ++ " bucket(s) found." +``` + +The above performs a `listBuckets` operation and returns the number of +buckets in the server. If there were any errors, they will be returned +as values of type `MinioErr` as a `Left` value. + +## 2. Bucket operations + + +### listBuckets :: Minio [BucketInfo] +Lists buckets. + +__Return Value__ + +|Return type |Description | +|:---|:---| +| _Minio [BucketInfo]_| List of buckets | + + +__BucketInfo record type__ + +|Field |Type |Description | +|:---|:---| :---| +| `biName` | _Bucket_ (alias of `Text`) | Name of the bucket | +| `biCreationDate` | _UTCTime_ | Creation time of the bucket | + + + +### makeBucket :: Bucket -> Maybe Region -> Minio () + +Create a new bucket. If the region is not specified, the region +specified by `ConnectInfo` is used. + +__Parameters__ + +In the expression `makeBucket bucketName region` the arguments are: + +| Param | Type | Description | +|---|---|---| +|`bucketName` | _Bucket_ (alias for `Text`) | Name of the bucket | +| `region` | _Maybe Region_ | Region where the bucket is to be created. If not specified, default to the region in `ConnectInfo`.| + +__Example__ + +``` haskell +{-# Language OverloadedStrings #-} + +main :: IO () +main = do + res <- runMinio minioPlayCI $ do + makeBucket bucketName (Just "us-east-1") + + case res of + Left err -> putStrLn $ "Failed to make bucket: " ++ (show res) + Right _ -> putStrLn $ "makeBucket successful." + +``` + + +### removeBucket :: Bucket -> Minio () + +Remove a bucket. The bucket must be empty or an error will be thrown. + +__Parameters__ + +In the expression `removeBucket bucketName` the arguments are: + +| Param | Type | Description | +|---|---|---| +|`bucketName` | _Bucket_ (alias for `Text`) | Name of the bucket | + + +__Example__ + + +``` haskell +{-# Language OverloadedStrings #-} + +main :: IO () +main = do + res <- runMinio minioPlayCI $ do + removeBucket "mybucket" + + case res of + Left err -> putStrLn $ "Failed to remove bucket: " ++ (show res) + Right _ -> putStrLn $ "removeBucket successful." + +``` + + + +### listObjects :: Bucket -> Maybe Text -> Bool -> C.Producer Minio ObjectInfo + +List objects in the given bucket, implements version 2 of AWS S3 API. + +__Parameters__ + +In the expression `listObjects bucketName prefix recursive` the +arguments are: + +|Param |Type |Description | +|:---|:---| :---| +| `bucketName` | _Bucket_ (alias for `Text`) | Name of the bucket | +| `prefix` | _Maybe Text_ | Optional prefix that listed objects should have | +| `recursive` | _Bool_ |`True` indicates recursive style listing and `False` indicates directory style listing delimited by '/'. | + +__Return Value__ + +|Return type |Description | +|:---|:---| +| _C.Producer Minio ObjectInfo_ | A Conduit Producer of `ObjectInfo` values corresponding to each object. | + +__ObjectInfo record type__ + +|Field |Type |Description | +|:---|:---| :---| +|`oiObject` | _Object_ (alias for `Text`) | Name of object | +|`oiModTime` | _UTCTime_ | Last modified time of the object | +|`oiETag` | _ETag_ (alias for `Text`) | ETag of the object | +|`oiSize` | _Int64_ | Size of the object in bytes | + +__Example__ + +``` haskell +{-# Language OverloadedStrings #-} + +import Data.Conduit (($$)) +import Conduit.Combinators (sinkList) + +main :: IO () +main = do + let + bucket = "test" + + -- Performs a recursive listing of all objects under bucket "test" + -- on play.minio.io. + res <- runMinio minioPlayCI $ do + listObjects bucket Nothing True $$ sinkList + print res + +``` + + +### listObjectsV1 :: Bucket -> Maybe Text -> Bool -> C.Producer Minio ObjectInfo + +List objects in the given bucket, implements version 1 of AWS S3 API. This API +is provided for legacy S3 compatible object storage endpoints. + +__Parameters__ + +In the expression `listObjectsV1 bucketName prefix recursive` the +arguments are: + +|Param |Type |Description | +|:---|:---| :---| +| `bucketName` | _Bucket_ (alias for `Text`) | Name of the bucket | +| `prefix` | _Maybe Text_ | Optional prefix that listed objects should have | +| `recursive` | _Bool_ |`True` indicates recursive style listing and `False` indicates directory style listing delimited by '/'. | + +__Return Value__ + +|Return type |Description | +|:---|:---| +| _C.Producer Minio ObjectInfo_ | A Conduit Producer of `ObjectInfo` values corresponding to each object. | + +__ObjectInfo record type__ + +|Field |Type |Description | +|:---|:---| :---| +|`oiObject` | _Object_ (alias for `Text`) | Name of object | +|`oiModTime` | _UTCTime_ | Last modified time of the object | +|`oiETag` | _ETag_ (alias for `Text`) | ETag of the object | +|`oiSize` | _Int64_ | Size of the object in bytes | + +__Example__ + +``` haskell +{-# Language OverloadedStrings #-} + +import Data.Conduit (($$)) +import Conduit.Combinators (sinkList) + +main :: IO () +main = do + let + bucket = "test" + + -- Performs a recursive listing of all objects under bucket "test" + -- on play.minio.io. + res <- runMinio minioPlayCI $ do + listObjectsV1 bucket Nothing True $$ sinkList + print res + +``` + + +### listIncompleteUploads :: Bucket -> Maybe Prefix -> Bool -> C.Producer Minio UploadInfo + +List incompletely uploaded objects. + +__Parameters__ + +In the expression `listIncompleteUploads bucketName prefix recursive` +the parameters are: + +|Param |Type |Description | +|:---|:---| :---| +| `bucketName` | _Bucket_ (alias for `Text`) | Name of the bucket | +| `prefix` | _Maybe Text_ | Optional prefix that listed objects should have. | +| `recursive` | _Bool_ |`True` indicates recursive style listing and `Talse` indicates directory style listing delimited by '/'. | + +__Return Value__ + +|Return type |Description | +|:---|:---| +| _C.Producer Minio UploadInfo_ | A Conduit Producer of `UploadInfo` values corresponding to each incomplete multipart upload | + +__UploadInfo record type__ + +|Field |Type |Description | +|:---|:---| :---| +|`uiKey` | _Object_ |Name of incompletely uploaded object | +|`uiUploadId` | _String_ |Upload ID of incompletely uploaded object | +|`uiSize` | _Int64_ |Size of incompletely uploaded object | + +__Example__ + +```haskell +{-# Language OverloadedStrings #-} + +import Data.Conduit (($$)) +import Conduit.Combinators (sinkList) + +main :: IO () +main = do + let + bucket = "test" + + -- Performs a recursive listing of all incompletely uploaded objects + -- under bucket "test" on play.minio.io. + res <- runMinio minioPlayCI $ do + listIncompleteUploads bucket Nothing True $$ sinkList + print res + +``` + +## 3. Object operations + + +### getObject :: Bucket -> Object -> Minio (C.ResumableSource Minio ByteString) + +Get an object from the service. + +__Parameters__ + +In the expression `getObject bucketName objectName` the parameters +are: + +|Param |Type |Description | +|:---|:---| :---| +| `bucketName` | _Bucket_ (alias for `Text`) | Name of the bucket | +| `objectName` | _Object_ (alias for `Text`) | Name of the object | + +__Return Value__ + +The return value can be incrementally read to process the contents of +the object. +|Return type |Description | +|:---|:---| +| _C.ResumableSource Minio ByteString_ | A Conduit ResumableSource of `ByteString` values. | + +__Example__ + +```haskell +{-# Language OverloadedStrings #-} + +import Network.Minio +import Data.Conduit (($$+-)) +import Data.Conduit.Binary (sinkLbs) +import qualified Data.ByteString.Lazy as LB + +main :: IO () +main = do + let + bucket = "mybucket" + object = "myobject" + + -- Lists the parts in an incompletely uploaded object identified by + -- bucket, object and upload ID. + res <- runMinio minioPlayCI $ do + source <- getObject bucket object + source $$+- sinkLbs + + -- the following the prints the contents of the object. + putStrLn $ either + (("Failed to getObject: " ++) . show) + (("Read an object of length: " ++) . show . LB.length) + res +``` + + +### putObject :: Bucket -> Object -> C.Producer Minio ByteString -> Maybe Int64 -> Minio () +Uploads an object to a bucket in the service, from the given input +byte stream of optionally supplied length + +__Parameters__ + +In the expression `putObject bucketName objectName inputSrc` the parameters +are: + +|Param |Type |Description | +|:---|:---| :---| +| `bucketName` | _Bucket_ (alias for `Text`) | Name of the bucket | +| `objectName` | _Object_ (alias for `Text`) | Name of the object | +| `inputSrc` | _C.Producer Minio ByteString_ | A Conduit Producer of `ByteString` values | + +__Example__ + +```haskell +{-# Language OverloadedStrings #-} +import Network.Minio +import qualified Data.Conduit.Combinators as CC + +main :: IO () +main = do + let + bucket = "mybucket" + object = "myobject" + kb15 = 15 * 1024 + + res <- runMinio minioPlayCI $ do + putObject bucket object (CC.repeat "a") (Just kb15) + + case res of + Left e -> putStrLn $ "Failed to putObject " ++ show bucket ++ "/" ++ show object + Right _ -> putStrLn "PutObject was successful" +``` + + +### fGetObject :: Bucket -> Object -> FilePath -> GetObjectOptions -> Minio () +Downloads an object from a bucket in the service, to the given file + +__Parameters__ + +In the expression `fGetObject bucketName objectName inputFile` the parameters +are: + +|Param |Type |Description | +|:---|:---| :---| +| `bucketName` | _Bucket_ (alias for `Text`) | Name of the bucket | +| `objectName` | _Object_ (alias for `Text`) | Name of the object | +| `inputFile` | _FilePath_ | Path to the file to be uploaded | +| `opts` | _GetObjectOptions_ | Options for GET requests specifying additional options like If-Match, Range | + + +__GetObjectOptions record type__ + +|Field |Type |Description | +|:---|:---| :---| +| `gooRange` | `Maybe ByteRanges` | Represents the byte range of object. E.g ByteRangeFromTo 0 9 represents first ten bytes of the object| +| `gooIfMatch` | `Maybe ETag` (alias for `Text`) | (Optional) ETag of object should match | +| `gooIfNoneMatch` | `Maybe ETag` (alias for `Text`) | (Optional) ETag of object shouldn't match | +| `gooIfUnmodifiedSince` | `Maybe UTCTime` | (Optional) Time since object wasn't modified | +| `gooIfModifiedSince` | `Maybe UTCTime` | (Optional) Time since object was modified | + +``` haskell + +{-# Language OverloadedStrings #-} +import Network.Minio + +import Data.Conduit (($$+-)) +import Data.Conduit.Binary (sinkLbs) +import Prelude + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + let + bucket = "my-bucket" + object = "my-object" + localFile = "/etc/lsb-release" + + res <- runMinio minioPlayCI $ do + src <- fGetObject bucket object localFile def + (src $$+- sinkLbs) + + case res of + Left e -> putStrLn $ "fGetObject failed." ++ (show e) + Right _ -> putStrLn "fGetObject succeeded." +``` + + +### fPutObject :: Bucket -> Object -> FilePath -> Minio () +Uploads an object to a bucket in the service, from the given file + +__Parameters__ + +In the expression `fPutObject bucketName objectName inputFile` the parameters +are: + +|Param |Type |Description | +|:---|:---| :---| +| `bucketName` | _Bucket_ (alias for `Text`) | Name of the bucket | +| `objectName` | _Object_ (alias for `Text`) | Name of the object | +| `inputFile` | _FilePath_ | Path to the file to be uploaded | + +__Example__ + +```haskell +{-# Language OverloadedStrings #-} +import Network.Minio +import qualified Data.Conduit.Combinators as CC + +main :: IO () +main = do + let + bucket = "mybucket" + object = "myobject" + localFile = "/etc/lsb-release" + + res <- runMinio minioPlayCI $ do + fPutObject bucket object localFile + + case res of + Left e -> putStrLn $ "Failed to fPutObject " ++ show bucket ++ "/" ++ show object + Right _ -> putStrLn "fPutObject was successful" +``` + + +### copyObject :: DestinationInfo -> SourceInfo -> Minio () +Copies content of an object from the service to another + +__Parameters__ + +In the expression `copyObject dstInfo srcInfo` the parameters +are: + +|Param |Type |Description | +|:---|:---| :---| +| `dstInfo` | _DestinationInfo_ | A value representing properties of the destination object | +| `srcInfo` | _SourceInfo_ | A value representing properties of the source object | + + +__SourceInfo record type__ + +|Field |Type |Description | +|:---|:---| :---| +| `srcBucket` | `Bucket` | Name of source bucket | +| `srcObject` | `Object` | Name of source object | +| `srcRange` | `Maybe (Int64, Int64)` | (Optional) Represents the byte range of source object. (0, 9) represents first ten bytes of source object| +| `srcIfMatch` | `Maybe Text` | (Optional) ETag source object should match | +| `srcIfNoneMatch` | `Maybe Text` | (Optional) ETag source object shouldn't match | +| `srcIfUnmodifiedSince` | `Maybe UTCTime` | (Optional) Time since source object wasn't modified | +| `srcIfModifiedSince` | `Maybe UTCTime` | (Optional) Time since source object was modified | + +__Destination record type__ + +|Field |Type |Description | +|:---|:---| :---| +| `dstBucket` | `Bucket` | Name of destination bucket in server-side copyObject | +| `dstObject` | `Object` | Name of destination object in server-side copyObject | + +__Example__ + +```haskell +{-# Language OverloadedStrings #-} +import Network.Minio + +main :: IO () +main = do + let + bucket = "mybucket" + object = "myobject" + objectCopy = "obj-copy" + + res <- runMinio minioPlayCI $ do + copyObject def { dstBucket = bucket, dstObject = objectCopy } def { srcBucket = bucket, srcObject = object } + + case res of + Left e -> putStrLn $ "Failed to copyObject " ++ show bucket ++ show "/" ++ show object + Right _ -> putStrLn "copyObject was successful" +``` + + +### removeObject :: Bucket -> Object -> Minio () +Removes an object from the service + +__Parameters__ + +In the expression `removeObject bucketName objectName` the parameters +are: + +|Param |Type |Description | +|:---|:---| :---| +| `bucketName` | _Bucket_ (alias for `Text`) | Name of the bucket | +| `objectName` | _Object_ (alias for `Text`) | Name of the object | + +__Example__ + +```haskell +{-# Language OverloadedStrings #-} +import Network.Minio + +main :: IO () +main = do + let + bucket = "mybucket" + object = "myobject" + + res <- runMinio minioPlayCI $ do + removeObject bucket object + + case res of + Left e -> putStrLn $ "Failed to remove " ++ show bucket ++ "/" ++ show object + Right _ -> putStrLn "Removed object successfully" +``` + + +### removeIncompleteUpload :: Bucket -> Object -> Minio () +Removes an ongoing multipart upload of an object from the service + +__Parameters__ + +In the expression `removeIncompleteUpload bucketName objectName` the parameters +are: + +|Param |Type |Description | +|:---|:---| :---| +| `bucketName` | _Bucket_ (alias for `Text`) | Name of the bucket | +| `objectName` | _Object_ (alias for `Text`) | Name of the object | + +__Example__ + +```haskell +{-# Language OverloadedStrings #-} +import Network.Minio + +main :: IO () +main = do + let + bucket = "mybucket" + object = "myobject" + + res <- runMinio minioPlayCI $ + removeIncompleteUpload bucket object + + case res of + Left _ -> putStrLn $ "Failed to remove " ++ show bucket ++ "/" ++ show object + Right _ -> putStrLn "Removed incomplete upload successfully" +``` + + +### bucketExists :: Bucket -> Minio Bool +Checks if a bucket exists. + +__Parameters__ + +In the expression `bucketExists bucketName` the parameters are: + +|Param |Type |Description | +|:---|:---| :---| +| `bucketName` | _Bucket_ (alias for `Text`) | Name of the bucket | + + +## 4. Presigned operations + + +### presignedGetObjectUrl :: Bucket -> Object -> UrlExpiry -> Query -> RequestHeaders -> Minio ByteString + +Generate a URL with authentication signature to GET (download) an +object. All extra query parameters and headers passed here will be +signed and are required when the generated URL is used. Query +parameters could be used to change the response headers sent by the +server. Headers can be used to set Etag match conditions among others. + +For a list of possible request parameters and headers, please refer +to the GET object REST API AWS S3 documentation. + +__Parameters__ + +In the expression `presignedGetObjectUrl bucketName objectName expiry queryParams headers` +the parameters are: + +|Param |Type |Description | +|:---|:---| :---| +| `bucketName` | _Bucket_ (alias for `Text`) | Name of the bucket | +| `objectName` | _Object_ (alias for `Text`) | Name of the object | +| `expiry` | _UrlExpiry_ (alias for `Int`) | Url expiry time in seconds | +| `queryParams` | _Query_ (from package `http-types:Network.HTTP.Types`) | Query parameters to add to the URL | +| `headers` | _RequestHeaders_ (from package `http-types:Network.HTTP.Types` | Request headers that would be used with the URL | + +__Return Value__ + +Returns the generated URL - it will include authentication +information. + +|Return type |Description | +|:---|:---| +| _ByteString_ | Generated presigned URL | + +__Example__ + +```haskell +{-# Language OverloadedStrings #-} + +import Network.Minio +import qualified Data.ByteString.Char8 as B + +main :: IO () +main = do + let + bucket = "mybucket" + object = "myobject" + + res <- runMinio minioPlayCI $ do + -- Set a 7 day expiry for the URL + presignedGetObjectUrl bucket object (7*24*3600) [] [] + + -- Print the URL on success. + putStrLn $ either + (("Failed to generate URL: " ++) . show) + B.unpack + res +``` + + +### presignedPutObjectUrl :: Bucket -> Object -> UrlExpiry -> RequestHeaders -> Minio ByteString + +Generate a URL with authentication signature to PUT (upload) an +object. Any extra headers if passed, are signed, and so they are +required when the URL is used to upload data. This could be used, for +example, to set user-metadata on the object. + +For a list of possible headers to pass, please refer to the PUT object +REST API AWS S3 documentation. + +__Parameters__ + +In the expression `presignedPutObjectUrl bucketName objectName expiry headers` +the parameters are: + +|Param |Type |Description | +|:---|:---| :---| +| `bucketName` | _Bucket_ (alias for `Text`) | Name of the bucket | +| `objectName` | _Object_ (alias for `Text`) | Name of the object | +| `expiry` | _UrlExpiry_ (alias for `Int`) | Url expiry time in seconds | +| `headers` | _RequestHeaders_ (from package `http-types:Network.HTTP.Types` | Request headers that would be used with the URL | + +__Return Value__ + +Returns the generated URL - it will include authentication +information. + +|Return type |Description | +|:---|:---| +| _ByteString_ | Generated presigned URL | + +__Example__ + +```haskell +{-# Language OverloadedStrings #-} + +import Network.Minio +import qualified Data.ByteString.Char8 as B + +main :: IO () +main = do + let + bucket = "mybucket" + object = "myobject" + + res <- runMinio minioPlayCI $ do + -- Set a 7 day expiry for the URL + presignedPutObjectUrl bucket object (7*24*3600) [] [] + + -- Print the URL on success. + putStrLn $ either + (("Failed to generate URL: " ++) . show) + B.unpack + res +``` + + +### presignedPostPolicy :: PostPolicy -> Minio (ByteString, Map.Map Text ByteString) + +Generate a presigned URL and POST policy to upload files via a POST +request. This is intended for browser uploads and generates form data +that should be submitted in the request. + +The `PostPolicy` argument is created using the `newPostPolicy` function: + +#### newPostPolicy :: UTCTime -> [PostPolicyCondition] -> Either PostPolicyError PostPolicy + +In the expression `newPostPolicy expirationTime conditions` the parameters are: + +|Param | Type| Description | +|:---|:---|:---| +| `expirationTime` | _UTCTime_ (from package `time:Data.Time.UTCTime`) | The expiration time for the policy | +| `conditions` | _[PostPolicyConditions]_ | List of conditions to be added to the policy | + +The policy conditions are created using various helper functions - +please refer to the Haddocks for details. + +Since conditions are validated by `newPostPolicy` it returns an +`Either` value. + +__Return Value__ + +`presignedPostPolicy` returns a 2-tuple - the generated URL and a map +containing the form-data that should be submitted with the request. + +__Example__ + +```haskell +{-# Language OverloadedStrings #-} + +import Network.Minio + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.Map.Strict as Map +import qualified Data.Text.Encoding as Enc +import qualified Data.Time as Time + +main :: IO () +main = do + now <- Time.getCurrentTime + let + bucket = "mybucket" + object = "myobject" + + -- set an expiration time of 10 days + expireTime = Time.addUTCTime (3600 * 24 * 10) now + + -- create a policy with expiration time and conditions - since the + -- conditions are validated, newPostPolicy returns an Either value + policyE = newPostPolicy expireTime + [ -- set the object name condition + ppCondKey "photos/my-object" + -- set the bucket name condition + , ppCondBucket "my-bucket" + -- set the size range of object as 1B to 10MiB + , ppCondContentLengthRange 1 (10*1024*1024) + -- set content type as jpg image + , ppCondContentType "image/jpeg" + -- on success set the server response code to 200 + , ppCondSuccessActionStatus 200 + ] + + case policyE of + Left err -> putStrLn $ show err + Right policy -> do + res <- runMinio minioPlayCI $ do + (url, formData) <- presignedPostPolicy policy + + -- a curl command is output to demonstrate using the generated + -- URL and form-data + let + formFn (k, v) = B.concat ["-F ", Enc.encodeUtf8 k, "=", + "'", v, "'"] + formOptions = B.intercalate " " $ map formFn $ Map.toList formData + + + return $ B.intercalate " " $ + ["curl", formOptions, "-F file=@/tmp/photo.jpg", url] + + case res of + Left e -> putStrLn $ "post-policy error: " ++ (show e) + Right cmd -> do + putStrLn $ "Put a photo at /tmp/photo.jpg and run command:\n" + + -- print the generated curl command + Char8.putStrLn cmd +``` + + + + + + + + diff --git a/examples/BucketExists.hs b/examples/BucketExists.hs new file mode 100644 --- /dev/null +++ b/examples/BucketExists.hs @@ -0,0 +1,43 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +{-# Language OverloadedStrings #-} +import Network.Minio + +import Control.Monad.IO.Class (liftIO) +import Prelude + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + let bucket = "missingbucket" + + res1 <- runMinio minioPlayCI $ do + foundBucket <- bucketExists bucket + liftIO $ putStrLn $ "Does " ++ show bucket ++ " exist? - " ++ show foundBucket + + case res1 of + Left e -> putStrLn $ "bucketExists failed." ++ show e + Right () -> return () diff --git a/examples/CopyObject.hs b/examples/CopyObject.hs new file mode 100644 --- /dev/null +++ b/examples/CopyObject.hs @@ -0,0 +1,56 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +{-# LANGUAGE OverloadedStrings #-} +import Network.Minio + +import Control.Monad.Catch (catchIf) +import Prelude + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +ignoreMinioErr :: ServiceErr -> Minio () +ignoreMinioErr = return . const () + +main :: IO () +main = do + let + bucket = "test" + object = "obj" + objectCopy = "obj-copy" + localFile = "/etc/lsb-release" + + res1 <- runMinio minioPlayCI $ do + -- 1. Make a bucket; Catch BucketAlreadyOwnedByYou exception. + catchIf (== BucketAlreadyOwnedByYou) (makeBucket bucket Nothing) ignoreMinioErr + + -- 2. Upload a file to bucket/object. + fPutObject bucket object localFile + + -- 3. Copy bucket/object to bucket/objectCopy. + copyObject def {dstBucket = bucket, dstObject = objectCopy} def { srcBucket = bucket , srcObject = object } + + case res1 of + Left e -> putStrLn $ "copyObject failed." ++ show e + Right () -> putStrLn "copyObject succeeded." diff --git a/examples/FileUploader.hs b/examples/FileUploader.hs new file mode 100644 --- /dev/null +++ b/examples/FileUploader.hs @@ -0,0 +1,74 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs --package optparse-applicative --package filepath + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +import Network.Minio + +import Control.Monad.Catch (catchIf) +import Control.Monad.IO.Class (liftIO) +import Data.Monoid ((<>)) +import Data.Text (pack) +import Options.Applicative +import Prelude +import System.FilePath.Posix + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +-- optparse-applicative package based command-line parsing. +fileNameArgs :: Parser FilePath +fileNameArgs = strArgument + (metavar "FILENAME" + <> help "Name of file to upload to AWS S3 or a Minio server") + +cmdParser = info + (helper <*> fileNameArgs) + (fullDesc + <> progDesc "FileUploader" + <> header + "FileUploader - a simple file-uploader program using minio-hs") + +ignoreMinioErr :: ServiceErr -> Minio () +ignoreMinioErr = return . const () + + +main :: IO () +main = do + let bucket = "my-bucket" + + -- Parse command line argument + filepath <- execParser cmdParser + let object = pack $ takeBaseName filepath + + res <- runMinio minioPlayCI $ do + -- Make a bucket; catch bucket already exists exception if thrown. + catchIf (== BucketAlreadyOwnedByYou) (makeBucket bucket Nothing) ignoreMinioErr + + -- Upload filepath to bucket; object is derived from filepath. + fPutObject bucket object filepath + + case res of + Left e -> putStrLn $ "file upload failed due to " ++ (show e) + Right () -> putStrLn "file upload succeeded." diff --git a/examples/GetObject.hs b/examples/GetObject.hs new file mode 100644 --- /dev/null +++ b/examples/GetObject.hs @@ -0,0 +1,45 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +{-# LANGUAGE OverloadedStrings #-} +import Network.Minio + +import Data.Conduit (($$+-)) +import Data.Conduit.Binary (sinkLbs) +import Prelude + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + let + bucket = "my-bucket" + object = "my-object" + res <- runMinio minioPlayCI $ do + src <- getObject bucket object + (src $$+- sinkLbs) + + case res of + Left e -> putStrLn $ "getObject failed." ++ (show e) + Right _ -> putStrLn "getObject succeeded." diff --git a/examples/HeadObject.hs b/examples/HeadObject.hs new file mode 100644 --- /dev/null +++ b/examples/HeadObject.hs @@ -0,0 +1,43 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +{-# LANGUAGE OverloadedStrings #-} +import Network.Minio +import Network.Minio.S3API + +import Prelude + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + let + bucket = "test" + object = "passwd" + res <- runMinio minioPlayCI $ + headObject bucket object + + case res of + Left e -> putStrLn $ "headObject failed." ++ show e + Right objInfo -> putStrLn $ "headObject succeeded." ++ show objInfo diff --git a/examples/ListBuckets.hs b/examples/ListBuckets.hs new file mode 100644 --- /dev/null +++ b/examples/ListBuckets.hs @@ -0,0 +1,41 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +{-# LANGUAGE OverloadedStrings #-} +import Network.Minio + +import Control.Monad.IO.Class (liftIO) +import Prelude + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +-- This example list buckets that belongs to the user and returns +-- region of the first bucket returned. +main :: IO () +main = do + firstRegionE <- runMinio minioPlayCI $ do + buckets <- listBuckets + liftIO $ print $ "Top 5 buckets: " ++ show (take 5 buckets) + getLocation $ biName $ head buckets + print firstRegionE diff --git a/examples/ListIncompleteUploads.hs b/examples/ListIncompleteUploads.hs new file mode 100644 --- /dev/null +++ b/examples/ListIncompleteUploads.hs @@ -0,0 +1,54 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +{-# LANGUAGE OverloadedStrings #-} +import Network.Minio + +import Data.Conduit (($$)) +import Data.Conduit.Combinators (sinkList) +import Prelude + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + let + bucket = "test" + + -- Performs a recursive listing of incomplete uploads under bucket "test" + -- on a local minio server. + res <- runMinio minioPlayCI $ + listIncompleteUploads bucket Nothing True $$ sinkList + print res + + {- + Following is the output of the above program on a local Minio server. + + Right [UploadInfo { uiKey = "go1.6.2.linux-amd64.tar.gz" + , uiUploadId = "063eb592-bdd7-4a0c-be48-34fb3ceb63e2" + , uiInitTime = 2017-03-01 10:16:25.698 UTC + , uiSize = 17731794 + } + ] + -} diff --git a/examples/ListObjects.hs b/examples/ListObjects.hs new file mode 100644 --- /dev/null +++ b/examples/ListObjects.hs @@ -0,0 +1,50 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +{-# LANGUAGE OverloadedStrings #-} +import Network.Minio + +import qualified Data.Conduit as C +import qualified Data.Conduit.Combinators as CC +import Prelude + + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + let + bucket = "test" + + -- Performs a recursive listing of all objects under bucket "test" + -- on play.minio.io. + res <- runMinio minioPlayCI $ + listObjects bucket Nothing True C.$$ CC.sinkList + print res + + {- + Following is the output of the above program on a local Minio server. + + Right [ObjectInfo {oiObject = "ADVANCED.png", oiModTime = 2017-02-10 05:33:24.816 UTC, oiETag = "\"a69f3af6bbb06fe1d42ac910ec30482f\"", oiSize = 94026},ObjectInfo {oiObject = "obj", oiModTime = 2017-02-10 08:49:26.777 UTC, oiETag = "\"715a872a253a3596652c1490081b4b6a-1\"", oiSize = 15728640}] + -} diff --git a/examples/Makebucket.hs b/examples/Makebucket.hs new file mode 100644 --- /dev/null +++ b/examples/Makebucket.hs @@ -0,0 +1,40 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + + +{-# LANGUAGE OverloadedStrings #-} +import Network.Minio + +import Prelude + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + let + bucket = "my-bucket" + res <- runMinio minioPlayCI $ + -- N B the region provided for makeBucket is optional. + makeBucket bucket (Just "us-east-1") + print res diff --git a/examples/PresignedGetObject.hs b/examples/PresignedGetObject.hs new file mode 100644 --- /dev/null +++ b/examples/PresignedGetObject.hs @@ -0,0 +1,83 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +{-# LANGUAGE OverloadedStrings #-} +import Network.Minio + +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString.Char8 as B +import Data.CaseInsensitive (original) +import qualified Data.Conduit.Combinators as CC +import qualified Data.Text.Encoding as E + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + let + bucket = "my-bucket" + object = "my-object" + kb15 = 15*1024 + + -- Set query parameter to modify content disposition response + -- header + queryParam = [("response-content-disposition", + Just "attachment; filename=\"your-filename.txt\"")] + + res <- runMinio minioPlayCI $ do + liftIO $ B.putStrLn "Upload a file that we will fetch with a presigned URL..." + putObject bucket object (CC.repeat "a") (Just kb15) def + liftIO $ putStrLn $ "Done. Object created at: my-bucket/my-object" + + -- Extract Etag of uploaded object + oi <- statObject bucket object + let etag = oiETag oi + + -- Set header to add an if-match constraint - this makes sure + -- the fetching fails if the object is changed on the server + let headers = [("If-Match", E.encodeUtf8 etag)] + + -- Generate a URL with 7 days expiry time - note that the headers + -- used above must be added to the request with the signed URL + -- generated. + url <- presignedGetObjectUrl "my-bucket" "my-object" (7*24*3600) + queryParam headers + + return (headers, etag, url) + + case res of + Left e -> putStrLn $ "presignedPutObject URL failed." ++ show e + Right (headers, etag, url) -> do + + -- We generate a curl command to demonstrate usage of the signed + -- URL. + let + hdrOpt (k, v) = B.concat ["-H '", original k, ": ", v, "'"] + curlCmd = B.intercalate " " $ + ["curl --fail"] ++ map hdrOpt headers ++ + ["-o /tmp/myfile", B.concat ["'", url, "'"]] + + putStrLn $ "The following curl command would use the presigned " ++ + "URL to fetch the object and write it to \"/tmp/myfile\":" + B.putStrLn curlCmd diff --git a/examples/PresignedPostPolicy.hs b/examples/PresignedPostPolicy.hs new file mode 100644 --- /dev/null +++ b/examples/PresignedPostPolicy.hs @@ -0,0 +1,84 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +{-# LANGUAGE OverloadedStrings #-} +import Network.Minio + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.Map.Strict as Map +import qualified Data.Text.Encoding as Enc +import qualified Data.Time as Time + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + now <- Time.getCurrentTime + let + bucket = "my-bucket" + object = "my-object" + + -- set an expiration time of 10 days + expireTime = Time.addUTCTime (3600 * 24 * 10) now + + -- create a policy with expiration time and conditions - since the + -- conditions are validated, newPostPolicy returns an Either value + policyE = newPostPolicy expireTime + [ -- set the object name condition + ppCondKey "photos/my-object" + -- set the bucket name condition + , ppCondBucket "my-bucket" + -- set the size range of object as 1B to 10MiB + , ppCondContentLengthRange 1 (10*1024*1024) + -- set content type as jpg image + , ppCondContentType "image/jpeg" + -- on success set the server response code to 200 + , ppCondSuccessActionStatus 200 + ] + + case policyE of + Left err -> putStrLn $ show err + Right policy -> do + res <- runMinio minioPlayCI $ do + (url, formData) <- presignedPostPolicy policy + + -- a curl command is output to demonstrate using the generated + -- URL and form-data + let + formFn (k, v) = B.concat ["-F ", Enc.encodeUtf8 k, "=", + "'", v, "'"] + formOptions = B.intercalate " " $ map formFn $ Map.toList formData + + + return $ B.intercalate " " $ + ["curl", formOptions, "-F file=@/tmp/photo.jpg", url] + + case res of + Left e -> putStrLn $ "post-policy error: " ++ (show e) + Right cmd -> do + putStrLn $ "Put a photo at /tmp/photo.jpg and run command:\n" + + -- print the generated curl command + Char8.putStrLn cmd diff --git a/examples/PresignedPutObject.hs b/examples/PresignedPutObject.hs new file mode 100644 --- /dev/null +++ b/examples/PresignedPutObject.hs @@ -0,0 +1,59 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +{-# LANGUAGE OverloadedStrings #-} +import Network.Minio + +import qualified Data.ByteString.Char8 as B +import Data.CaseInsensitive (original) + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + let + -- Use headers to set user-metadata - note that this header will + -- need to be set when the URL is used to make an upload. + headers = [("x-amz-meta-url-creator", + "minio-hs-presigned-put-example")] + res <- runMinio minioPlayCI $ do + + -- generate a URL with 7 days expiry time + presignedPutObjectUrl "my-bucket" "my-object" (7*24*3600) headers + + case res of + Left e -> putStrLn $ "presignedPutObject URL failed." ++ show e + Right url -> do + + -- We generate a curl command to demonstrate usage of the signed + -- URL. + let + hdrOpt (k, v) = B.concat ["-H '", original k, ": ", v, "'"] + curlCmd = B.intercalate " " $ + ["curl "] ++ map hdrOpt headers ++ + ["-T /tmp/myfile", B.concat ["'", url, "'"]] + + putStrLn $ "The following curl command would use the presigned " ++ + "URL to upload the file at \"/tmp/myfile\":" + B.putStrLn curlCmd diff --git a/examples/PutObject.hs b/examples/PutObject.hs new file mode 100644 --- /dev/null +++ b/examples/PutObject.hs @@ -0,0 +1,53 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +{-# LANGUAGE OverloadedStrings #-} +import Network.Minio + +import qualified Data.Conduit.Combinators as CC + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + let + bucket = "test" + object = "obj" + localFile = "/etc/lsb-release" + kb15 = 15 * 1024 + + -- Eg 1. Upload a stream of repeating "a" using putObject with default options. + res1 <- runMinio minioPlayCI $ + putObject bucket object (CC.repeat "a") (Just kb15) def + case res1 of + Left e -> putStrLn $ "putObject failed." ++ show e + Right () -> putStrLn "putObject succeeded." + + + -- Eg 2. Upload a file using fPutObject with default options. + res2 <- runMinio minioPlayCI $ + fPutObject bucket object localFile def + case res2 of + Left e -> putStrLn $ "fPutObject failed." ++ show e + Right () -> putStrLn "fPutObject succeeded." diff --git a/examples/RemoveIncompleteUpload.hs b/examples/RemoveIncompleteUpload.hs new file mode 100644 --- /dev/null +++ b/examples/RemoveIncompleteUpload.hs @@ -0,0 +1,43 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +{-# LANGUAGE OverloadedStrings #-} +import Network.Minio + +import Prelude + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + let + bucket = "mybucket" + object = "myobject" + + res <- runMinio minioPlayCI $ + removeIncompleteUpload bucket object + + case res of + Left _ -> putStrLn $ "Failed to remove " ++ show bucket ++ "/" ++ show object + Right _ -> putStrLn "Removed incomplete upload successfully" diff --git a/examples/RemoveObject.hs b/examples/RemoveObject.hs new file mode 100644 --- /dev/null +++ b/examples/RemoveObject.hs @@ -0,0 +1,36 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +{-# LANGUAGE OverloadedStrings #-} + +import Network.Minio +import Prelude + +main :: IO () +main = do + let + bucket = "mybucket" + object = "myobject" + + res <- runMinio minioPlayCI $ + removeObject bucket object + + case res of + Left _ -> putStrLn $ "Failed to remove " ++ show bucket ++ "/" ++ show object + Right _ -> putStrLn "Removed object successfully" diff --git a/examples/Removebucket.hs b/examples/Removebucket.hs new file mode 100644 --- /dev/null +++ b/examples/Removebucket.hs @@ -0,0 +1,38 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + + +{-# LANGUAGE OverloadedStrings #-} +import Network.Minio + +import Prelude + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + let + bucket = "my-bucket" + res <- runMinio minioPlayCI $ removeBucket bucket + print res diff --git a/minio-hs.cabal b/minio-hs.cabal --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -1,5 +1,5 @@ name: minio-hs -version: 0.3.2 +version: 1.0.0 synopsis: A Minio Haskell Library for Amazon S3 compatible cloud storage. description: The Minio Haskell client library provides simple APIs to @@ -8,12 +8,19 @@ homepage: https://github.com/minio/minio-hs#readme license: Apache-2.0 license-file: LICENSE -author: Aditya Manthramurthy, Krishnan Parthasarathi +author: Minio Dev Team maintainer: dev@minio.io category: Network, AWS, Object Storage build-type: Simple stability: Experimental --- extra-source-files: +extra-source-files: + CHANGELOG.md + CONTRIBUTING.md + docs/API.md + examples/*.hs + README.md + stack.yaml + cabal-version: >=1.10 library @@ -27,6 +34,7 @@ , Network.Minio.Data.ByteString , Network.Minio.Data.Crypto , Network.Minio.Data.Time + , Network.Minio.CopyObject , Network.Minio.Errors , Network.Minio.ListOps , Network.Minio.PresignedOperations @@ -38,12 +46,10 @@ build-depends: base >= 4.7 && < 5 , protolude >= 0.1.6 , aeson - , async , base64-bytestring , bytestring , case-insensitive , conduit - , conduit-combinators , conduit-extra , containers , cryptonite @@ -54,22 +60,19 @@ , http-client , http-conduit , http-types - , lifted-async - , lifted-base , memory - , monad-control , resourcet , text , text-format , time , transformers - , transformers-base - , vector + , unliftio + , unliftio-core , xml-conduit default-language: Haskell2010 - default-extensions: FlexibleContexts + default-extensions: BangPatterns + , FlexibleContexts , FlexibleInstances - , BangPatterns , MultiParamTypeClasses , MultiWayIf , NoImplicitPrelude @@ -92,17 +95,18 @@ default-extensions: BangPatterns , FlexibleContexts , FlexibleInstances - , OverloadedStrings - , NoImplicitPrelude , MultiParamTypeClasses , MultiWayIf - , ScopedTypeVariables + , NoImplicitPrelude + , OverloadedStrings , RankNTypes + , ScopedTypeVariables , TupleSections , TypeFamilies other-modules: Lib.Prelude , Network.Minio , Network.Minio.API + , Network.Minio.CopyObject , Network.Minio.Data , Network.Minio.Data.ByteString , Network.Minio.Data.Crypto @@ -124,12 +128,10 @@ , minio-hs , protolude >= 0.1.6 , aeson - , async , base64-bytestring , bytestring , case-insensitive , conduit - , conduit-combinators , conduit-extra , containers , cryptonite @@ -141,10 +143,7 @@ , http-client , http-conduit , http-types - , lifted-async - , lifted-base , memory - , monad-control , QuickCheck , resourcet , tasty @@ -156,8 +155,8 @@ , text-format , time , transformers - , transformers-base - , vector + , unliftio + , unliftio-core , xml-conduit if !flag(live-test) buildable: False @@ -170,12 +169,10 @@ , minio-hs , protolude >= 0.1.6 , aeson - , async , base64-bytestring , bytestring , case-insensitive , conduit - , conduit-combinators , conduit-extra , containers , cryptonite @@ -183,14 +180,10 @@ , data-default , directory , exceptions - , filepath , http-client , http-conduit , http-types - , lifted-async - , lifted-base , memory - , monad-control , QuickCheck , resourcet , tasty @@ -202,20 +195,20 @@ , text-format , time , transformers - , transformers-base - , vector + , unliftio + , unliftio-core , xml-conduit ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 default-extensions: BangPatterns , FlexibleContexts , FlexibleInstances - , OverloadedStrings - , NoImplicitPrelude , MultiParamTypeClasses , MultiWayIf - , ScopedTypeVariables + , NoImplicitPrelude + , OverloadedStrings , RankNTypes + , ScopedTypeVariables , TupleSections , TypeFamilies other-modules: Lib.Prelude @@ -225,6 +218,7 @@ , Network.Minio.Data.ByteString , Network.Minio.Data.Crypto , Network.Minio.Data.Time + , Network.Minio.CopyObject , Network.Minio.Errors , Network.Minio.ListOps , Network.Minio.PresignedOperations diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -1,5 +1,5 @@ -- --- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -55,16 +55,25 @@ -- ** Listing , BucketInfo(..) , listBuckets - , ObjectInfo(..) + + -- ** Object info type represents object metadata information. + , ObjectInfo + , oiObject + , oiModTime + , oiETag + , oiSize + , oiMetadata + , listObjects , listObjectsV1 + , UploadId , UploadInfo(..) , listIncompleteUploads , ObjectPartInfo(..) , listIncompleteParts - -- ** Notifications + -- ** Bucket Notifications , Notification(..) , NotificationConfig(..) , Arn @@ -79,7 +88,6 @@ -- * Object Operations ---------------------- - , Object -- ** File operations @@ -88,11 +96,39 @@ -- ** Conduit-based streaming operations , putObject + -- | Input data type represents PutObject options. + , PutObjectOptions + , pooContentType + , pooContentEncoding + , pooContentDisposition + , pooContentLanguage + , pooCacheControl + , pooStorageClass + , pooUserMetadata + , pooNumThreads + , getObject + -- | Input data type represents GetObject options. + , GetObjectOptions + , gooRange + , gooIfMatch + , gooIfNoneMatch + , gooIfModifiedSince + , gooIfUnmodifiedSince -- ** Server-side copying - , CopyPartSource(..) , copyObject + , SourceInfo + , srcBucket + , srcObject + , srcRange + , srcIfMatch + , srcIfNoneMatch + , srcIfModifiedSince + , srcIfUnmodifiedSince + , DestinationInfo + , dstBucket + , dstObject -- ** Querying , statObject @@ -142,15 +178,16 @@ import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Combinators as CC import Data.Default (def) -import qualified Data.Map as Map import Lib.Prelude +import Network.Minio.CopyObject import Network.Minio.Data import Network.Minio.Errors import Network.Minio.ListOps import Network.Minio.PutObject import Network.Minio.S3API +import Network.Minio.Utils -- | Lists buckets. listBuckets :: Minio [BucketInfo] @@ -159,39 +196,44 @@ -- | Fetch the object and write it to the given file safely. The -- object is first written to a temporary file in the same directory -- and then moved to the given path. -fGetObject :: Bucket -> Object -> FilePath -> Minio () -fGetObject bucket object fp = do - src <- getObject bucket object - src C.$$+- CB.sinkFileCautious fp +fGetObject :: Bucket -> Object -> FilePath -> GetObjectOptions -> Minio () +fGetObject bucket object fp opts = do + src <- getObject bucket object opts + C.connect src $ CB.sinkFileCautious fp -- | Upload the given file to the given object. -fPutObject :: Bucket -> Object -> FilePath -> Minio () -fPutObject bucket object f = void $ putObjectInternal bucket object $ - ODFile f Nothing +fPutObject :: Bucket -> Object -> FilePath + -> PutObjectOptions -> Minio () +fPutObject bucket object f opts = + void $ putObjectInternal bucket object opts $ ODFile f Nothing -- | Put an object from a conduit source. The size can be provided if -- known; this helps the library select optimal part sizes to perform -- a multipart upload. If not specified, it is assumed that the object -- can be potentially 5TiB and selects multipart sizes appropriately. -putObject :: Bucket -> Object -> C.Producer Minio ByteString - -> Maybe Int64 -> Minio () -putObject bucket object src sizeMay = - void $ putObjectInternal bucket object $ ODStream src sizeMay +putObject :: Bucket -> Object -> C.ConduitM () ByteString Minio () + -> Maybe Int64 -> PutObjectOptions -> Minio () +putObject bucket object src sizeMay opts = + void $ putObjectInternal bucket object opts $ ODStream src sizeMay --- | Perform a server-side copy operation to create an object with the --- given bucket and object name from the source specification in --- CopyPartSource. This function performs a multipart copy operation --- if the new object is to be greater than 5GiB in size. -copyObject :: Bucket -> Object -> CopyPartSource -> Minio () -copyObject bucket object cps = void $ copyObjectInternal bucket object cps +-- | Perform a server-side copy operation to create an object based on +-- the destination specification in DestinationInfo from the source +-- specification in SourceInfo. This function performs a multipart +-- copy operation if the new object is to be greater than 5GiB in +-- size. +copyObject :: DestinationInfo -> SourceInfo -> Minio () +copyObject dstInfo srcInfo = void $ copyObjectInternal (dstBucket dstInfo) + (dstObject dstInfo) srcInfo -- | Remove an object from the object store. removeObject :: Bucket -> Object -> Minio () removeObject = deleteObject -- | Get an object from the object store as a resumable source (conduit). -getObject :: Bucket -> Object -> Minio (C.ResumableSource Minio ByteString) -getObject bucket object = snd <$> getObject' bucket object [] [] +getObject :: Bucket -> Object -> GetObjectOptions + -> Minio (C.ConduitM () ByteString Minio ()) +getObject bucket object opts = snd <$> getObject' bucket object [] + (gooToHeaders opts) -- | Get an object's metadata from the object store. statObject :: Bucket -> Object -> Minio ObjectInfo @@ -205,21 +247,21 @@ makeBucket bucket regionMay = do region <- maybe (asks $ connectRegion . mcConnInfo) return regionMay putBucket bucket region - modify (Map.insert bucket region) + addToRegionCache bucket region -- | Removes a bucket from the object store. removeBucket :: Bucket -> Minio () removeBucket bucket = do deleteBucket bucket - modify (Map.delete bucket) + deleteFromRegionCache bucket -- | Query the object store if a given bucket is present. bucketExists :: Bucket -> Minio Bool bucketExists = headBucket - -- | Removes an ongoing multipart upload of an object. removeIncompleteUpload :: Bucket -> Object -> Minio () removeIncompleteUpload bucket object = do - uploads <- listIncompleteUploads bucket (Just object) False C.$$ CC.sinkList + uploads <- C.runConduit $ listIncompleteUploads bucket (Just object) False + C..| CC.sinkList mapM_ (abortMultipartUpload bucket object) (uiUploadId <$> uploads) diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -15,8 +15,7 @@ -- module Network.Minio.API - ( - connect + ( connect , RequestInfo(..) , runMinio , executeRequest @@ -86,10 +85,10 @@ discoverRegion :: RequestInfo -> Minio (Maybe Region) discoverRegion ri = runMaybeT $ do bucket <- MaybeT $ return $ riBucket ri - regionMay <- gets (Map.lookup bucket) + regionMay <- lift $ lookupRegionCache bucket maybe (do l <- lift $ getLocation bucket - modify $ Map.insert bucket l + lift $ addToRegionCache bucket l return l ) return regionMay @@ -161,7 +160,7 @@ mkStreamRequest :: RequestInfo - -> Minio (Response (C.ResumableSource Minio ByteString)) + -> Minio (Response (C.ConduitM () ByteString Minio ())) mkStreamRequest ri = do req <- buildRequest ri mgr <- asks mcConnManager diff --git a/src/Network/Minio/CopyObject.hs b/src/Network/Minio/CopyObject.hs new file mode 100644 --- /dev/null +++ b/src/Network/Minio/CopyObject.hs @@ -0,0 +1,93 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +module Network.Minio.CopyObject where + +import Data.Default (def) +import qualified Data.List as List + +import Lib.Prelude + +import Network.Minio.Data +import Network.Minio.Errors +import Network.Minio.S3API +import Network.Minio.Utils + + +-- | Copy an object using single or multipart copy strategy. +copyObjectInternal :: Bucket -> Object -> SourceInfo + -> Minio ETag +copyObjectInternal b' o srcInfo = do + let sBucket = srcBucket srcInfo + sObject = srcObject srcInfo + + -- get source object size with a head request + oi <- headObject sBucket sObject + let srcSize = oiSize oi + + -- check that byte offsets are valid if specified in cps + let rangeMay = srcRange srcInfo + range = maybe (0, srcSize) identity rangeMay + startOffset = fst range + endOffset = snd range + + when (isJust rangeMay && + or [startOffset < 0, endOffset < startOffset, + endOffset >= fromIntegral srcSize]) $ + throwM $ MErrVInvalidSrcObjByteRange range + + -- 1. If sz > 64MiB (minPartSize) use multipart copy, OR + -- 2. If startOffset /= 0 use multipart copy + let destSize = (\(a, b) -> b - a + 1 ) $ + maybe (0, srcSize - 1) identity rangeMay + + if destSize > minPartSize || (endOffset - startOffset + 1 /= srcSize) + then multiPartCopyObject b' o srcInfo srcSize + + else fst <$> copyObjectSingle b' o srcInfo{srcRange = Nothing} [] + +-- | Given the input byte range of the source object, compute the +-- splits for a multipart copy object procedure. Minimum part size +-- used is minPartSize. +selectCopyRanges :: (Int64, Int64) -> [(PartNumber, (Int64, Int64))] +selectCopyRanges (st, end) = zip pns $ + map (\(x, y) -> (st + x, st + x + y - 1)) $ zip startOffsets partSizes + where + size = end - st + 1 + (pns, startOffsets, partSizes) = List.unzip3 $ selectPartSizes size + +-- | Perform a multipart copy object action. Since we cannot verify +-- existing parts based on the source object, there is no resuming +-- copy action support. +multiPartCopyObject :: Bucket -> Object -> SourceInfo -> Int64 + -> Minio ETag +multiPartCopyObject b o cps srcSize = do + uid <- newMultipartUpload b o [] + + let byteRange = maybe (0, fromIntegral $ srcSize - 1) identity $ srcRange cps + partRanges = selectCopyRanges byteRange + partSources = map (\(x, (start, end)) -> (x, cps {srcRange = Just (start, end) })) + partRanges + dstInfo = def { dstBucket = b, dstObject = o} + + copiedParts <- limitedMapConcurrently 10 + (\(pn, cps') -> do + (etag, _) <- copyObjectPart dstInfo cps' uid pn [] + return (pn, etag) + ) + partSources + + completeMultipartUpload b o uid copiedParts diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -14,31 +14,50 @@ -- limitations under the License. -- -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} module Network.Minio.Data where -import Control.Monad.Base -import qualified Control.Monad.Catch as MC -import Control.Monad.Trans.Control +import Control.Concurrent.MVar (MVar) +import qualified Control.Concurrent.MVar as M +import qualified Control.Monad.Catch as MC +import Control.Monad.IO.Unlift (MonadUnliftIO, UnliftIO (..), + askUnliftIO, withUnliftIO) import Control.Monad.Trans.Resource -import qualified Data.ByteString as B -import Data.Default (Default(..)) -import qualified Data.Map as Map -import qualified Data.Text as T -import Data.Time (formatTime, defaultTimeLocale) -import Network.HTTP.Client (defaultManagerSettings) -import qualified Network.HTTP.Conduit as NC -import Network.HTTP.Types (Method, Header, Query) -import qualified Network.HTTP.Types as HT +import qualified Data.ByteString as B +import Data.CaseInsensitive (mk) +import Data.Default (Default (..)) +import qualified Data.Map as Map +import qualified Data.Text as T +import Data.Time (defaultTimeLocale, formatTime) +import Network.HTTP.Client (defaultManagerSettings) +import qualified Network.HTTP.Conduit as NC +import Network.HTTP.Types (ByteRange, Header, Method, Query, + hRange) +import qualified Network.HTTP.Types as HT import Network.Minio.Errors import Text.XML -import GHC.Show (Show(..)) +import GHC.Show (Show (..)) import Lib.Prelude +-- | max obj size is 5TiB +maxObjectSize :: Int64 +maxObjectSize = 5 * 1024 * 1024 * oneMiB +-- | minimum size of parts used in multipart operations. +minPartSize :: Int64 +minPartSize = 64 * oneMiB + +oneMiB :: Int64 +oneMiB = 1024 * 1024 + +-- | maximum number of parts that can be uploaded for a single object. +maxMultipartParts :: Int64 +maxMultipartParts = 10000 + -- TODO: Add a type which provides typed constants for region. this -- type should have a IsString instance to infer the appropriate -- constant. @@ -65,12 +84,12 @@ -- of the provided smart constructors or override fields of the -- Default instance. data ConnectInfo = ConnectInfo { - connectHost :: Text - , connectPort :: Int - , connectAccessKey :: Text - , connectSecretKey :: Text - , connectIsSecure :: Bool - , connectRegion :: Region + connectHost :: Text + , connectPort :: Int + , connectAccessKey :: Text + , connectSecretKey :: Text + , connectIsSecure :: Bool + , connectRegion :: Region , connectAutoDiscoverRegion :: Bool } deriving (Eq, Show) @@ -167,9 +186,57 @@ type ETag = Text -- | +-- Data type represents various options specified for PutObject call. +-- To specify PutObject options use the poo* accessors. +data PutObjectOptions = PutObjectOptions { + pooContentType :: Maybe Text + , pooContentEncoding :: Maybe Text + , pooContentDisposition :: Maybe Text + , pooCacheControl :: Maybe Text + , pooContentLanguage :: Maybe Text + , pooStorageClass :: Maybe Text + , pooUserMetadata :: [(Text, Text)] + , pooNumThreads :: Maybe Word + } deriving (Show, Eq) + +-- Provide a default instance +instance Default PutObjectOptions where + def = PutObjectOptions def def def def def def [] def + +addXAmzMetaPrefix :: Text -> Text +addXAmzMetaPrefix s = do + if (T.isPrefixOf "x-amz-meta-" s) + then s + else T.concat ["x-amz-meta-", s] + +mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header] +mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix $ T.toLower x, encodeUtf8 y)) + +pooToHeaders :: PutObjectOptions -> [HT.Header] +pooToHeaders poo = userMetadata + ++ (catMaybes $ map tupToMaybe (zipWith (,) names values)) + where + tupToMaybe (k, Just v) = Just (k, v) + tupToMaybe (_, Nothing) = Nothing + + userMetadata = mkHeaderFromMetadata $ pooUserMetadata poo + + names = ["content-type", + "content-encoding", + "content-disposition", + "content-language", + "cache-control", + "x-amz-storage-class"] + values = map (fmap encodeUtf8 . (poo &)) + [pooContentType, pooContentEncoding, + pooContentDisposition, pooContentLanguage, + pooCacheControl, pooStorageClass] + + +-- | -- BucketInfo returned for list buckets call data BucketInfo = BucketInfo { - biName :: Bucket + biName :: Bucket , biCreationDate :: UTCTime } deriving (Show, Eq) @@ -185,103 +252,113 @@ -- | Represents result from a listing of object parts of an ongoing -- multipart upload. data ListPartsResult = ListPartsResult { - lprHasMore :: Bool + lprHasMore :: Bool , lprNextPart :: Maybe Int - , lprParts :: [ObjectPartInfo] + , lprParts :: [ObjectPartInfo] } deriving (Show, Eq) - -- | Represents information about an object part in an ongoing -- multipart upload. data ObjectPartInfo = ObjectPartInfo { - opiNumber :: PartNumber - , opiETag :: ETag - , opiSize :: Int64 + opiNumber :: PartNumber + , opiETag :: ETag + , opiSize :: Int64 , opiModTime :: UTCTime } deriving (Show, Eq) -- | Represents result from a listing of incomplete uploads to a -- bucket. data ListUploadsResult = ListUploadsResult { - lurHasMore :: Bool - , lurNextKey :: Maybe Text + lurHasMore :: Bool + , lurNextKey :: Maybe Text , lurNextUpload :: Maybe Text - , lurUploads :: [(Object, UploadId, UTCTime)] - , lurCPrefixes :: [Text] + , lurUploads :: [(Object, UploadId, UTCTime)] + , lurCPrefixes :: [Text] } deriving (Show, Eq) -- | Represents information about a multipart upload. data UploadInfo = UploadInfo { - uiKey :: Object + uiKey :: Object , uiUploadId :: UploadId , uiInitTime :: UTCTime - , uiSize :: Int64 + , uiSize :: Int64 } deriving (Show, Eq) -- | Represents result from a listing of objects in a bucket. data ListObjectsResult = ListObjectsResult { - lorHasMore :: Bool + lorHasMore :: Bool , lorNextToken :: Maybe Text - , lorObjects :: [ObjectInfo] + , lorObjects :: [ObjectInfo] , lorCPrefixes :: [Text] } deriving (Show, Eq) -- | Represents result from a listing of objects version 1 in a bucket. data ListObjectsV1Result = ListObjectsV1Result { - lorHasMore' :: Bool + lorHasMore' :: Bool , lorNextMarker :: Maybe Text - , lorObjects' :: [ObjectInfo] + , lorObjects' :: [ObjectInfo] , lorCPrefixes' :: [Text] } deriving (Show, Eq) -- | Represents information about an object. data ObjectInfo = ObjectInfo { - oiObject :: Object - , oiModTime :: UTCTime - , oiETag :: ETag - , oiSize :: Int64 + oiObject :: Object + , oiModTime :: UTCTime + , oiETag :: ETag + , oiSize :: Int64 + , oiMetadata :: Map.Map Text Text } deriving (Show, Eq) -data CopyPartSource = CopyPartSource { - -- | formatted like "\/sourceBucket\/sourceObject" - cpSource :: Text - -- | (0, 9) means first ten bytes of the source object - , cpSourceRange :: Maybe (Int64, Int64) - , cpSourceIfMatch :: Maybe Text - , cpSourceIfNoneMatch :: Maybe Text - , cpSourceIfUnmodifiedSince :: Maybe UTCTime - , cpSourceIfModifiedSince :: Maybe UTCTime +-- | Represents source object in server-side copy object +data SourceInfo = SourceInfo { + srcBucket :: Text + , srcObject :: Text + , srcRange :: Maybe (Int64, Int64) + , srcIfMatch :: Maybe Text + , srcIfNoneMatch :: Maybe Text + , srcIfModifiedSince :: Maybe UTCTime + , srcIfUnmodifiedSince :: Maybe UTCTime } deriving (Show, Eq) -instance Default CopyPartSource where - def = CopyPartSource "" def def def def def +instance Default SourceInfo where + def = SourceInfo "" "" def def def def def -cpsToHeaders :: CopyPartSource -> [HT.Header] -cpsToHeaders cps = ("x-amz-copy-source", encodeUtf8 $ cpSource cps) : - rangeHdr ++ zip names values - where - names = ["x-amz-copy-source-if-match", "x-amz-copy-source-if-none-match", - "x-amz-copy-source-if-unmodified-since", - "x-amz-copy-source-if-modified-since"] - values = mapMaybe (fmap encodeUtf8 . (cps &)) - [cpSourceIfMatch, cpSourceIfNoneMatch, - fmap formatRFC1123 . cpSourceIfUnmodifiedSince, - fmap formatRFC1123 . cpSourceIfModifiedSince] - rangeHdr = ("x-amz-copy-source-range",) - . HT.renderByteRanges - . (:[]) - . uncurry HT.ByteRangeFromTo - <$> map (both fromIntegral) (maybeToList $ cpSourceRange cps) +-- | Represents destination object in server-side copy object +data DestinationInfo = DestinationInfo { + dstBucket :: Text + , dstObject :: Text + } deriving (Show, Eq) --- | Extract the source bucket and source object name. TODO: validate --- the bucket and object name extracted. -cpsToObject :: CopyPartSource -> Maybe (Bucket, Object) -cpsToObject cps = do - [_, bucket, object] <- Just splits - return (bucket, object) +instance Default DestinationInfo where + def = DestinationInfo "" "" + +data GetObjectOptions = GetObjectOptions { + -- | [ByteRangeFromTo 0 9] means first ten bytes of the source object. + gooRange :: Maybe ByteRange + , gooIfMatch :: Maybe ETag + , gooIfNoneMatch :: Maybe ETag + , gooIfUnmodifiedSince :: Maybe UTCTime + , gooIfModifiedSince :: Maybe UTCTime + } deriving (Show, Eq) + +instance Default GetObjectOptions where + def = GetObjectOptions def def def def def + +gooToHeaders :: GetObjectOptions -> [HT.Header] +gooToHeaders goo = rangeHdr ++ zip names values where - splits = T.splitOn "/" $ cpSource cps + names = ["If-Match", + "If-None-Match", + "If-Unmodified-Since", + "If-Modified-Since"] + values = mapMaybe (fmap encodeUtf8 . (goo &)) + [gooIfMatch, gooIfNoneMatch, + fmap formatRFC1123 . gooIfUnmodifiedSince, + fmap formatRFC1123 . gooIfModifiedSince] + rangeHdr = maybe [] (\a -> [(hRange, HT.renderByteRanges [a])]) + $ gooRange goo + -- | A data-type for events that can occur in the object storage -- server. Reference: -- https://docs.aws.amazon.com/AmazonS3/latest/dev/NotificationHowTo.html#supported-notification-event-types @@ -352,7 +429,7 @@ -- for objects having a suffix of ".jpg", and the `prefixRule` -- restricts it to objects having a prefix of "images/". data FilterRule = FilterRule - { frName :: Text + { frName :: Text , frValue :: Text } deriving (Show, Eq) @@ -362,8 +439,8 @@ -- notification system. It could represent a Queue, Topic or Lambda -- Function configuration. data NotificationConfig = NotificationConfig - { ncId :: Text - , ncArn :: Arn + { ncId :: Text + , ncArn :: Arn , ncEvents :: [Event] , ncFilter :: Filter } deriving (Show, Eq) @@ -374,8 +451,8 @@ -- described at -- data Notification = Notification - { nQueueConfigurations :: [NotificationConfig] - , nTopicConfigurations :: [NotificationConfig] + { nQueueConfigurations :: [NotificationConfig] + , nTopicConfigurations :: [NotificationConfig] , nCloudFunctionConfigurations :: [NotificationConfig] } deriving (Eq, Show) @@ -393,14 +470,14 @@ def = PayloadBS "" data RequestInfo = RequestInfo { - riMethod :: Method - , riBucket :: Maybe Bucket - , riObject :: Maybe Object - , riQueryParams :: Query - , riHeaders :: [Header] - , riPayload :: Payload - , riPayloadHash :: Maybe ByteString - , riRegion :: Maybe Region + riMethod :: Method + , riBucket :: Maybe Bucket + , riObject :: Maybe Object + , riQueryParams :: Query + , riHeaders :: [Header] + , riPayload :: Payload + , riPayloadHash :: Maybe ByteString + , riRegion :: Maybe Region , riNeedsLocation :: Bool } @@ -423,7 +500,7 @@ type RegionMap = Map.Map Bucket Region newtype Minio a = Minio { - unMinio :: ReaderT MinioConn (StateT RegionMap (ResourceT IO)) a + unMinio :: ReaderT MinioConn (ResourceT IO) a } deriving ( Functor @@ -431,38 +508,38 @@ , Monad , MonadIO , MonadReader MinioConn - , MonadState RegionMap , MonadThrow , MonadCatch - , MonadBase IO , MonadResource ) -instance MonadBaseControl IO Minio where - type StM Minio a = (a, RegionMap) - liftBaseWith f = Minio $ liftBaseWith $ \q -> f (q . unMinio) - restoreM = Minio . restoreM +instance MonadUnliftIO Minio where + askUnliftIO = Minio $ ReaderT $ \r -> + withUnliftIO $ \u -> + return (UnliftIO (unliftIO u . flip runReaderT r . unMinio)) -- | MinioConn holds connection info and a connection pool -data MinioConn = MinioConn { - mcConnInfo :: ConnectInfo +data MinioConn = MinioConn + { mcConnInfo :: ConnectInfo , mcConnManager :: NC.Manager + , mcRegionMap :: MVar RegionMap } -- | Takes connection information and returns a connection object to -- be passed to 'runMinio' connect :: ConnectInfo -> IO MinioConn connect ci = do - let settings = bool defaultManagerSettings NC.tlsManagerSettings $ - connectIsSecure ci + let settings | connectIsSecure ci = NC.tlsManagerSettings + | otherwise = defaultManagerSettings mgr <- NC.newManager settings - return $ MinioConn ci mgr + rMapMVar <- M.newMVar Map.empty + return $ MinioConn ci mgr rMapMVar -- | Run the Minio action and return the result or an error. runMinio :: ConnectInfo -> Minio a -> IO (Either MinioErr a) runMinio ci m = do conn <- liftIO $ connect ci - runResourceT . flip evalStateT Map.empty . flip runReaderT conn . unMinio $ + runResourceT . flip runReaderT conn . unMinio $ fmap Right m `MC.catches` [ MC.Handler handlerServiceErr , MC.Handler handlerHE diff --git a/src/Network/Minio/Data/Crypto.hs b/src/Network/Minio/Data/Crypto.hs --- a/src/Network/Minio/Data/Crypto.hs +++ b/src/Network/Minio/Data/Crypto.hs @@ -28,37 +28,38 @@ , digestToBase16 ) where -import Crypto.Hash (SHA256(..), MD5(..), hashWith, Digest) -import Crypto.Hash.Conduit (sinkHash) -import Crypto.MAC.HMAC (hmac, HMAC) -import Data.ByteArray (ByteArrayAccess, convert) -import Data.ByteArray.Encoding (convertToBase, Base(Base16)) -import qualified Data.Conduit as C +import Crypto.Hash (Digest, MD5 (..), SHA256 (..), + hashWith) +import Crypto.Hash.Conduit (sinkHash) +import Crypto.MAC.HMAC (HMAC, hmac) +import Data.ByteArray (ByteArrayAccess, convert) +import Data.ByteArray.Encoding (Base (Base16), convertToBase) +import qualified Data.Conduit as C import Lib.Prelude hashSHA256 :: ByteString -> ByteString hashSHA256 = digestToBase16 . hashWith SHA256 -hashSHA256FromSource :: Monad m => C.Producer m ByteString -> m ByteString +hashSHA256FromSource :: Monad m => C.ConduitM () ByteString m () -> m ByteString hashSHA256FromSource src = do - digest <- src C.$$ sinkSHA256Hash + digest <- C.connect src sinkSHA256Hash return $ digestToBase16 digest where -- To help with type inference - sinkSHA256Hash :: Monad m => C.Consumer ByteString m (Digest SHA256) + sinkSHA256Hash :: Monad m => C.ConduitM ByteString Void m (Digest SHA256) sinkSHA256Hash = sinkHash hashMD5 :: ByteString -> ByteString hashMD5 = digestToBase16 . hashWith MD5 -hashMD5FromSource :: Monad m => C.Producer m ByteString -> m ByteString +hashMD5FromSource :: Monad m => C.ConduitM () ByteString m () -> m ByteString hashMD5FromSource src = do - digest <- src C.$$ sinkMD5Hash + digest <- C.connect src sinkMD5Hash return $ digestToBase16 digest where -- To help with type inference - sinkMD5Hash :: Monad m => C.Consumer ByteString m (Digest MD5) + sinkMD5Hash :: Monad m => C.ConduitM ByteString Void m (Digest MD5) sinkMD5Hash = sinkHash hmacSHA256 :: ByteString -> ByteString -> HMAC SHA256 diff --git a/src/Network/Minio/ListOps.hs b/src/Network/Minio/ListOps.hs --- a/src/Network/Minio/ListOps.hs +++ b/src/Network/Minio/ListOps.hs @@ -16,9 +16,9 @@ module Network.Minio.ListOps where -import qualified Data.Conduit as C +import qualified Data.Conduit as C import qualified Data.Conduit.Combinators as CC -import qualified Data.Conduit.List as CL +import qualified Data.Conduit.List as CL import Lib.Prelude @@ -27,10 +27,10 @@ -- | List objects in a bucket matching the given prefix. If recurse is -- set to True objects matching prefix are recursively listed. -listObjects :: Bucket -> Maybe Text -> Bool -> C.Producer Minio ObjectInfo +listObjects :: Bucket -> Maybe Text -> Bool -> C.ConduitM () ObjectInfo Minio () listObjects bucket prefix recurse = loop Nothing where - loop :: Maybe Text -> C.Producer Minio ObjectInfo + loop :: Maybe Text -> C.ConduitM () ObjectInfo Minio () loop nextToken = do let delimiter = bool (Just "/") Nothing recurse @@ -42,10 +42,11 @@ -- | List objects in a bucket matching the given prefix. If recurse is -- set to True objects matching prefix are recursively listed. -listObjectsV1 :: Bucket -> Maybe Text -> Bool -> C.Producer Minio ObjectInfo +listObjectsV1 :: Bucket -> Maybe Text -> Bool + -> C.ConduitM () ObjectInfo Minio () listObjectsV1 bucket prefix recurse = loop Nothing where - loop :: Maybe Text -> C.Producer Minio ObjectInfo + loop :: Maybe Text -> C.ConduitM () ObjectInfo Minio () loop nextMarker = do let delimiter = bool (Just "/") Nothing recurse @@ -59,10 +60,10 @@ -- recurse is set to True incomplete uploads for the given prefix are -- recursively listed. listIncompleteUploads :: Bucket -> Maybe Text -> Bool - -> C.Producer Minio UploadInfo + -> C.ConduitM () UploadInfo Minio () listIncompleteUploads bucket prefix recurse = loop Nothing Nothing where - loop :: Maybe Text -> Maybe Text -> C.Producer Minio UploadInfo + loop :: Maybe Text -> Maybe Text -> C.ConduitM () UploadInfo Minio () loop nextKeyMarker nextUploadIdMarker = do let delimiter = bool (Just "/") Nothing recurse @@ -71,7 +72,8 @@ nextKeyMarker nextUploadIdMarker Nothing aggrSizes <- lift $ forM (lurUploads res) $ \(uKey, uId, _) -> do - partInfos <- listIncompleteParts bucket uKey uId C.$$ CC.sinkList + partInfos <- C.runConduit $ listIncompleteParts bucket uKey uId + C..| CC.sinkList return $ foldl (\sizeSofar p -> opiSize p + sizeSofar) 0 partInfos CL.sourceList $ @@ -86,10 +88,10 @@ -- | List object parts of an ongoing multipart upload for given -- bucket, object and uploadId. listIncompleteParts :: Bucket -> Object -> UploadId - -> C.Producer Minio ObjectPartInfo + -> C.ConduitM () ObjectPartInfo Minio () listIncompleteParts bucket object uploadId = loop Nothing where - loop :: Maybe Text -> C.Producer Minio ObjectPartInfo + loop :: Maybe Text -> C.ConduitM () ObjectPartInfo Minio () loop nextPartMarker = do res <- lift $ listIncompleteParts' bucket object uploadId Nothing nextPartMarker diff --git a/src/Network/Minio/PutObject.hs b/src/Network/Minio/PutObject.hs --- a/src/Network/Minio/PutObject.hs +++ b/src/Network/Minio/PutObject.hs @@ -19,17 +19,15 @@ putObjectInternal , ObjectData(..) , selectPartSizes - , copyObjectInternal - , selectCopyRanges - , minPartSize ) where -import qualified Data.Conduit as C -import qualified Data.Conduit.Binary as CB +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Combinators as CC -import qualified Data.Conduit.List as CL -import qualified Data.List as List +import qualified Data.Conduit.List as CL +import qualified Data.List as List import Lib.Prelude @@ -39,20 +37,6 @@ import Network.Minio.Utils --- | max obj size is 5TiB -maxObjectSize :: Int64 -maxObjectSize = 5 * 1024 * 1024 * oneMiB - --- | minimum size of parts used in multipart operations. -minPartSize :: Int64 -minPartSize = 64 * oneMiB - -oneMiB :: Int64 -oneMiB = 1024 * 1024 - -maxMultipartParts :: Int64 -maxMultipartParts = 10000 - -- | A data-type to represent the source data for an object. A -- file-path or a producer-conduit may be provided. -- @@ -63,15 +47,33 @@ -- For streams also, a size may be provided. This is useful to limit -- the input - if it is not provided, upload will continue until the -- stream ends or the object reaches `maxObjectsize` size. -data ObjectData m = - ODFile FilePath (Maybe Int64) -- ^ Takes filepath and optional size. - | ODStream (C.Producer m ByteString) (Maybe Int64) -- ^ Pass size in bytes as maybe if known. +data ObjectData m + = ODFile FilePath (Maybe Int64) -- ^ Takes filepath and optional + -- size. + | ODStream (C.ConduitM () ByteString m ()) (Maybe Int64) -- ^ Pass + -- size + -- (bytes) + -- if + -- known. -- | Put an object from ObjectData. This high-level API handles -- objects of all sizes, and even if the object size is unknown. -putObjectInternal :: Bucket -> Object -> ObjectData Minio -> Minio ETag -putObjectInternal b o (ODStream src sizeMay) = sequentialMultipartUpload b o sizeMay src -putObjectInternal b o (ODFile fp sizeMay) = do +putObjectInternal :: Bucket -> Object -> PutObjectOptions + -> ObjectData Minio -> Minio ETag +putObjectInternal b o opts (ODStream src sizeMay) = do + case sizeMay of + -- unable to get size, so assume non-seekable file and max-object size + Nothing -> sequentialMultipartUpload b o opts (Just maxObjectSize) src + + -- got file size, so check for single/multipart upload + Just size -> + if | size <= 64 * oneMiB -> do + bs <- C.runConduit $ src C..| CB.sinkLbs + putObjectSingle' b o (pooToHeaders opts) $ LBS.toStrict bs + | size > maxObjectSize -> throwM $ MErrVPutSizeExceeded size + | otherwise -> sequentialMultipartUpload b o opts (Just size) src + +putObjectInternal b o opts (ODFile fp sizeMay) = do hResE <- withNewHandle fp $ \h -> liftM2 (,) (isHandleSeekable h) (getFileSize h) @@ -83,45 +85,30 @@ case finalSizeMay of -- unable to get size, so assume non-seekable file and max-object size - Nothing -> sequentialMultipartUpload b o (Just maxObjectSize) $ + Nothing -> sequentialMultipartUpload b o opts (Just maxObjectSize) $ CB.sourceFile fp -- got file size, so check for single/multipart upload Just size -> if | size <= 64 * oneMiB -> either throwM return =<< - withNewHandle fp (\h -> putObjectSingle b o [] h 0 size) + withNewHandle fp (\h -> putObjectSingle b o (pooToHeaders opts) h 0 size) | size > maxObjectSize -> throwM $ MErrVPutSizeExceeded size - | isSeekable -> parallelMultipartUpload b o fp size - | otherwise -> sequentialMultipartUpload b o (Just size) $ + | isSeekable -> parallelMultipartUpload b o opts fp size + | otherwise -> sequentialMultipartUpload b o opts (Just size) $ CB.sourceFile fp --- | Select part sizes - the logic is that the minimum part-size will --- be 64MiB. -selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)] -selectPartSizes size = uncurry (List.zip3 [1..]) $ - List.unzip $ loop 0 size - where - ceil :: Double -> Int64 - ceil = ceiling - partSize = max minPartSize (ceil $ fromIntegral size / - fromIntegral maxMultipartParts) - - m = fromIntegral partSize - loop st sz - | st > sz = [] - | st + m >= sz = [(st, sz - st)] - | otherwise = (st, m) : loop (st + m) sz - -parallelMultipartUpload :: Bucket -> Object -> FilePath -> Int64 - -> Minio ETag -parallelMultipartUpload b o filePath size = do +parallelMultipartUpload :: Bucket -> Object -> PutObjectOptions + -> FilePath -> Int64 -> Minio ETag +parallelMultipartUpload b o opts filePath size = do -- get a new upload id. - uploadId <- newMultipartUpload b o [] + uploadId <- newMultipartUpload b o (pooToHeaders opts) let partSizeInfo = selectPartSizes size - -- perform upload with 10 threads - uploadedPartsE <- limitedMapConcurrently 10 + let threads = fromMaybe 10 $ pooNumThreads opts + + -- perform upload with 'threads' threads + uploadedPartsE <- limitedMapConcurrently (fromIntegral threads) (uploadPart uploadId) partSizeInfo -- if there were any errors, rethrow exception. @@ -129,6 +116,7 @@ -- if we get here, all parts were successfully uploaded. completeMultipartUpload b o uploadId $ rights uploadedPartsE + where uploadPart uploadId (partNum, offset, sz) = withNewHandle filePath $ \h -> do @@ -136,20 +124,23 @@ putObjectPart b o uploadId partNum [] payload -- | Upload multipart object from conduit source sequentially -sequentialMultipartUpload :: Bucket -> Object -> Maybe Int64 - -> C.Producer Minio ByteString -> Minio ETag -sequentialMultipartUpload b o sizeMay src = do +sequentialMultipartUpload :: Bucket -> Object -> PutObjectOptions + -> Maybe Int64 + -> C.ConduitM () ByteString Minio () + -> Minio ETag +sequentialMultipartUpload b o opts sizeMay src = do -- get a new upload id. - uploadId <- newMultipartUpload b o [] + uploadId <- newMultipartUpload b o (pooToHeaders opts) -- upload parts in loop let partSizes = selectPartSizes $ maybe maxObjectSize identity sizeMay (pnums, _, sizes) = List.unzip3 partSizes - uploadedParts <- src + uploadedParts <- C.runConduit + $ src C..| chunkBSConduit sizes C..| CL.map PayloadBS C..| uploadPart' uploadId pnums - C.$$ CC.sinkList + C..| CC.sinkList -- complete multipart upload completeMultipartUpload b o uploadId uploadedParts @@ -163,69 +154,3 @@ Just payload -> do pinfo <- lift $ putObjectPart b o uid pn [] payload C.yield pinfo uploadPart' uid pns - --- | Copy an object using single or multipart copy strategy. -copyObjectInternal :: Bucket -> Object -> CopyPartSource - -> Minio ETag -copyObjectInternal b' o cps = do - -- validate and extract the src bucket and object - (srcBucket, srcObject) <- maybe - (throwM $ MErrVInvalidSrcObjSpec $ cpSource cps) - return $ cpsToObject cps - - -- get source object size with a head request - (ObjectInfo _ _ _ srcSize) <- headObject srcBucket srcObject - - -- check that byte offsets are valid if specified in cps - when (isJust (cpSourceRange cps) && - or [fst range < 0, snd range < fst range, - snd range >= fromIntegral srcSize]) $ - throwM $ MErrVInvalidSrcObjByteRange range - - -- 1. If sz > 64MiB (minPartSize) use multipart copy, OR - -- 2. If startOffset /= 0 use multipart copy - let destSize = (\(a, b) -> b - a + 1 ) $ - maybe (0, srcSize - 1) identity $ cpSourceRange cps - startOffset = maybe 0 fst $ cpSourceRange cps - endOffset = maybe (srcSize - 1) snd $ cpSourceRange cps - - if destSize > minPartSize || (endOffset - startOffset + 1 /= srcSize) - then multiPartCopyObject b' o cps srcSize - - else fst <$> copyObjectSingle b' o cps{cpSourceRange = Nothing} [] - - where - range = maybe (0, 0) identity $ cpSourceRange cps - --- | Given the input byte range of the source object, compute the --- splits for a multipart copy object procedure. Minimum part size --- used is minPartSize. -selectCopyRanges :: (Int64, Int64) -> [(PartNumber, (Int64, Int64))] -selectCopyRanges (st, end) = zip pns $ - map (\(x, y) -> (st + x, st + x + y - 1)) $ zip startOffsets partSizes - where - size = end - st + 1 - (pns, startOffsets, partSizes) = List.unzip3 $ selectPartSizes size - --- | Perform a multipart copy object action. Since we cannot verify --- existing parts based on the source object, there is no resuming --- copy action support. -multiPartCopyObject :: Bucket -> Object -> CopyPartSource -> Int64 - -> Minio ETag -multiPartCopyObject b o cps srcSize = do - uid <- newMultipartUpload b o [] - - let byteRange = maybe (0, fromIntegral $ srcSize - 1) identity $ - cpSourceRange cps - partRanges = selectCopyRanges byteRange - partSources = map (\(x, y) -> (x, cps {cpSourceRange = Just y})) - partRanges - - copiedParts <- limitedMapConcurrently 10 - (\(pn, cps') -> do - (etag, _) <- copyObjectPart b o cps' uid pn [] - return (pn, etag) - ) - partSources - - completeMultipartUpload b o uid copiedParts diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -1,5 +1,5 @@ -- --- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -42,6 +42,7 @@ --------------------------------- , putBucket , ETag + , putObjectSingle' , putObjectSingle , copyObjectSingle @@ -51,7 +52,6 @@ , PartTuple , Payload(..) , PartNumber - , CopyPartSource(..) , newMultipartUpload , putObjectPart , copyObjectPart @@ -71,6 +71,10 @@ ----------------------------- , module Network.Minio.PresignedOperations + -- ** Bucket Policies + , getBucketPolicy + , setBucketPolicy + -- * Bucket Notifications ------------------------- , Notification(..) @@ -86,24 +90,25 @@ , removeAllBucketNotification ) where -import Control.Monad.Catch (catches, Handler(..)) -import qualified Data.Conduit as C -import Data.Default (def) -import qualified Network.HTTP.Conduit as NC -import qualified Network.HTTP.Types as HT -import Network.HTTP.Types.Status (status404) +import Control.Monad.Catch (Handler (..), catches) +import qualified Data.ByteString as BS +import qualified Data.Conduit as C +import Data.Default (def) +import qualified Data.Text as T -import Lib.Prelude hiding (catches) +import Lib.Prelude hiding (catches) +import qualified Network.HTTP.Conduit as NC +import qualified Network.HTTP.Types as HT +import Network.HTTP.Types.Status (status404) import Network.Minio.API import Network.Minio.Data import Network.Minio.Errors +import Network.Minio.PresignedOperations import Network.Minio.Utils import Network.Minio.XmlGenerator import Network.Minio.XmlParser -import Network.Minio.PresignedOperations - -- | Fetch all buckets from the service. getService :: Minio [BucketInfo] getService = do @@ -115,7 +120,7 @@ -- | GET an object from the service and return the response headers -- and a conduit source for the object content getObject' :: Bucket -> Object -> HT.Query -> [HT.Header] - -> Minio ([HT.Header], C.ResumableSource Minio ByteString) + -> Minio ([HT.Header], C.ConduitM () ByteString Minio ()) getObject' bucket object queryParams headers = do resp <- mkStreamRequest reqInfo return (NC.responseHeaders resp, NC.responseBody resp) @@ -140,6 +145,28 @@ maxSinglePutObjectSizeBytes :: Int64 maxSinglePutObjectSizeBytes = 5 * 1024 * 1024 * 1024 +putObjectSingle' :: Bucket -> Object -> [HT.Header] -> ByteString -> Minio ETag +putObjectSingle' bucket object headers bs = do + let size = fromIntegral (BS.length bs) + -- check length is within single PUT object size. + when (size > maxSinglePutObjectSizeBytes) $ + throwM $ MErrVSinglePUTSizeExceeded size + + -- content-length header is automatically set by library. + resp <- executeRequest $ + def { riMethod = HT.methodPut + , riBucket = Just bucket + , riObject = Just object + , riHeaders = headers + , riPayload = PayloadBS bs + } + + let rheaders = NC.responseHeaders resp + etag = getETagHeader rheaders + maybe + (throwM MErrVETagHeaderNotFound) + return etag + -- | PUT an object into the service. This function performs a single -- PUT object call, and so can only transfer objects upto 5GiB. putObjectSingle :: Bucket -> Object -> [HT.Header] -> Handle -> Int64 @@ -252,17 +279,33 @@ , ("partNumber", Just $ show partNumber) ] +srcInfoToHeaders :: SourceInfo -> [HT.Header] +srcInfoToHeaders srcInfo = ("x-amz-copy-source", encodeUtf8 $ format "/{}/{}" [srcBucket srcInfo, srcObject srcInfo]) : + rangeHdr ++ zip names values + where + names = ["x-amz-copy-source-if-match", "x-amz-copy-source-if-none-match", + "x-amz-copy-source-if-unmodified-since", + "x-amz-copy-source-if-modified-since"] + values = mapMaybe (fmap encodeUtf8 . (srcInfo &)) + [srcIfMatch, srcIfNoneMatch, + fmap formatRFC1123 . srcIfUnmodifiedSince, + fmap formatRFC1123 . srcIfModifiedSince] + rangeHdr = maybe [] (\a -> [("x-amz-copy-source-range", HT.renderByteRanges [a])]) + $ toByteRange <$> srcRange srcInfo + toByteRange :: (Int64, Int64) -> HT.ByteRange + toByteRange (x, y) = HT.ByteRangeFromTo (fromIntegral x) (fromIntegral y) + -- | Performs server-side copy of an object or part of an object as an -- upload part of an ongoing multi-part upload. -copyObjectPart :: Bucket -> Object -> CopyPartSource -> UploadId +copyObjectPart :: DestinationInfo -> SourceInfo -> UploadId -> PartNumber -> [HT.Header] -> Minio (ETag, UTCTime) -copyObjectPart bucket object cps uploadId partNumber headers = do +copyObjectPart dstInfo srcInfo uploadId partNumber headers = do resp <- executeRequest $ def { riMethod = HT.methodPut - , riBucket = Just bucket - , riObject = Just object + , riBucket = Just $ dstBucket dstInfo + , riObject = Just $ dstObject dstInfo , riQueryParams = mkOptionalParams params - , riHeaders = headers ++ cpsToHeaders cps + , riHeaders = headers ++ srcInfoToHeaders srcInfo } parseCopyObjectResponse $ NC.responseBody resp @@ -275,17 +318,17 @@ -- | Performs server-side copy of an object that is upto 5GiB in -- size. If the object is greater than 5GiB, this function throws the -- error returned by the server. -copyObjectSingle :: Bucket -> Object -> CopyPartSource -> [HT.Header] +copyObjectSingle :: Bucket -> Object -> SourceInfo -> [HT.Header] -> Minio (ETag, UTCTime) -copyObjectSingle bucket object cps headers = do - -- validate that cpSourceRange is Nothing for this API. - when (isJust $ cpSourceRange cps) $ +copyObjectSingle bucket object srcInfo headers = do + -- validate that srcRange is Nothing for this API. + when (isJust $ srcRange srcInfo) $ throwM MErrVCopyObjSingleNoRangeAccepted resp <- executeRequest $ def { riMethod = HT.methodPut , riBucket = Just bucket , riObject = Just object - , riHeaders = headers ++ cpsToHeaders cps + , riHeaders = headers ++ srcInfoToHeaders srcInfo } parseCopyObjectResponse $ NC.responseBody resp @@ -367,10 +410,10 @@ modTime = getLastModifiedHeader headers etag = getETagHeader headers size = getContentLength headers + metadata = getMetadataMap headers maybe (throwM MErrVInvalidObjectInfoResponse) return $ - ObjectInfo <$> Just object <*> modTime <*> etag <*> size - + ObjectInfo <$> Just object <*> modTime <*> etag <*> size <*> Just metadata -- | Query the object store if a given bucket exists. @@ -420,3 +463,38 @@ -- | Remove all notifications configured on a bucket. removeAllBucketNotification :: Bucket -> Minio () removeAllBucketNotification = flip putBucketNotification def + +-- | Fetch the policy if any on a bucket. +getBucketPolicy :: Bucket -> Minio Text +getBucketPolicy bucket = do + resp <- executeRequest $ def { riMethod = HT.methodGet + , riBucket = Just bucket + , riQueryParams = [("policy", Nothing)] + } + return $ toS $ NC.responseBody resp + +-- | Set a new policy on a bucket. +-- As a special condition if the policy is empty +-- then we treat it as policy DELETE operation. +setBucketPolicy :: Bucket -> Text -> Minio () +setBucketPolicy bucket policy = do + if T.null policy + then deleteBucketPolicy bucket + else putBucketPolicy bucket policy + +-- | Save a new policy on a bucket. +putBucketPolicy :: Bucket -> Text -> Minio() +putBucketPolicy bucket policy = do + void $ executeRequest $ def { riMethod = HT.methodPut + , riBucket = Just bucket + , riQueryParams = [("policy", Nothing)] + , riPayload = PayloadBS $ encodeUtf8 policy + } + +-- | Delete any policy set on a bucket. +deleteBucketPolicy :: Bucket -> Minio() +deleteBucketPolicy bucket = do + void $ executeRequest $ def { riMethod = HT.methodDelete + , riBucket = Just bucket + , riQueryParams = [("policy", Nothing)] + } diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -16,66 +16,71 @@ module Network.Minio.Utils where -import qualified Control.Concurrent.Async.Lifted as A -import qualified Control.Concurrent.QSem.Lifted as Q -import qualified Control.Exception.Lifted as ExL -import qualified Control.Monad.Catch as MC -import qualified Control.Monad.Trans.Resource as R - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LB -import qualified Data.Conduit as C -import qualified Data.Conduit.Binary as CB -import qualified Data.Text as T -import Data.Text.Encoding.Error (lenientDecode) -import Data.Text.Read (decimal) -import Data.Time -import Network.HTTP.Conduit (Response) -import qualified Network.HTTP.Conduit as NC -import qualified Network.HTTP.Types as HT -import qualified Network.HTTP.Types.Header as Hdr -import qualified System.IO as IO -import Data.CaseInsensitive (mk) - +import qualified Control.Monad.Catch as MC +import Control.Monad.IO.Unlift (MonadUnliftIO) +import qualified Control.Monad.Trans.Resource as R +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import Data.CaseInsensitive (mk, original) +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Text as T +import Data.Text.Encoding.Error (lenientDecode) +import Data.Text.Read (decimal) +import Data.Time (defaultTimeLocale, parseTimeM, + rfc822DateFormat) +import Network.HTTP.Conduit (Response) +import qualified Network.HTTP.Conduit as NC +import qualified Network.HTTP.Types as HT +import qualified Network.HTTP.Types.Header as Hdr +import qualified System.IO as IO +import qualified UnliftIO.Async as A +import qualified UnliftIO.Exception as UEx +import qualified UnliftIO.MVar as UM +import qualified UnliftIO.STM as U import Lib.Prelude -import Network.Minio.XmlParser (parseErrResponse) +import Network.Minio.Data +import Network.Minio.Data.ByteString +import Network.Minio.XmlParser (parseErrResponse) -allocateReadFile :: (R.MonadResource m, R.MonadResourceBase m, MonadCatch m) +allocateReadFile :: (MonadUnliftIO m, R.MonadResource m, MonadCatch m) => FilePath -> m (R.ReleaseKey, Handle) allocateReadFile fp = do (rk, hdlE) <- R.allocate (openReadFile fp) cleanup either (\(e :: IOException) -> throwM e) (return . (rk,)) hdlE where - openReadFile f = ExL.try $ IO.openBinaryFile f IO.ReadMode + openReadFile f = UEx.try $ IO.openBinaryFile f IO.ReadMode cleanup = either (const $ return ()) IO.hClose -- | Queries the file size from the handle. Catches any file operation -- exceptions and returns Nothing instead. -getFileSize :: (R.MonadResourceBase m, R.MonadResource m) +getFileSize :: (MonadUnliftIO m, R.MonadResource m) => Handle -> m (Maybe Int64) getFileSize h = do resE <- liftIO $ try $ fromIntegral <$> IO.hFileSize h case resE of Left (_ :: IOException) -> return Nothing - Right s -> return $ Just s + Right s -> return $ Just s -- | Queries if handle is seekable. Catches any file operation -- exceptions and return False instead. -isHandleSeekable :: (R.MonadResource m, R.MonadResourceBase m) +isHandleSeekable :: (R.MonadResource m, MonadUnliftIO m) => Handle -> m Bool isHandleSeekable h = do resE <- liftIO $ try $ IO.hIsSeekable h case resE of Left (_ :: IOException) -> return False - Right v -> return v + Right v -> return v -- | Helper function that opens a handle to the filepath and performs -- the given action on it. Exceptions of type MError are caught and -- returned - both during file handle allocation and when the action -- is run. -withNewHandle :: (R.MonadResourceBase m, R.MonadResource m, MonadCatch m) +withNewHandle :: (MonadUnliftIO m, R.MonadResource m, MonadCatch m) => FilePath -> (Handle -> m a) -> m (Either IOException a) withNewHandle fp fileAction = do -- opening a handle can throw MError exception. @@ -98,6 +103,12 @@ getETagHeader :: [HT.Header] -> Maybe Text getETagHeader hs = decodeUtf8Lenient <$> lookupHeader Hdr.hETag hs +getMetadata :: [HT.Header] -> [(Text, Text)] +getMetadata = map ((\(x, y) -> (decodeUtf8Lenient $ original x, decodeUtf8Lenient $ stripBS y))) + +getMetadataMap :: [HT.Header] -> Map Text Text +getMetadataMap hs = Map.fromList (getMetadata hs) + getLastModifiedHeader :: [HT.Header] -> Maybe UTCTime getLastModifiedHeader hs = do modTimebs <- decodeUtf8Lenient <$> lookupHeader Hdr.hLastModified hs @@ -139,16 +150,17 @@ contentTypeMay resp = lookupHeader Hdr.hContentType $ NC.responseHeaders resp -http :: (R.MonadResourceBase m, R.MonadResource m) +http :: (MonadUnliftIO m, MonadThrow m, R.MonadResource m) => NC.Request -> NC.Manager - -> m (Response (C.ResumableSource m ByteString)) + -> m (Response (C.ConduitT () ByteString m ())) http req mgr = do respE <- tryHttpEx $ NC.http req mgr resp <- either throwM return respE unless (isSuccessStatus $ NC.responseStatus resp) $ case contentTypeMay resp of Just "application/xml" -> do - respBody <- NC.responseBody resp C.$$+- CB.sinkLbs + respBody <- C.connect (NC.responseBody resp) CB.sinkLbs + --respBody <- C.unsealConduitT (NC.responseBody resp) C.$$+- CB.sinkLbs sErr <- parseErrResponse respBody throwM sErr @@ -160,24 +172,35 @@ return resp where - tryHttpEx :: (R.MonadResourceBase m) => m a + tryHttpEx :: (MonadUnliftIO m) => m a -> m (Either NC.HttpException a) - tryHttpEx = ExL.try + tryHttpEx = UEx.try contentTypeMay resp = lookupHeader Hdr.hContentType $ NC.responseHeaders resp -- Similar to mapConcurrently but limits the number of threads that -- can run using a quantity semaphore. -limitedMapConcurrently :: (MonadIO m, R.MonadBaseControl IO m) +limitedMapConcurrently :: MonadUnliftIO m => Int -> (t -> m a) -> [t] -> m [a] +limitedMapConcurrently 0 _ _ = return [] limitedMapConcurrently count act args = do - qSem <- liftIO $ Q.newQSem count - threads <- mapM (A.async . wThread qSem) args + t' <- U.newTVarIO count + threads <- mapM (A.async . wThread t') args mapM A.wait threads where - -- grab 1 unit from semaphore, run action and release it - wThread qs arg = - ExL.bracket_ (Q.waitQSem qs) (Q.signalQSem qs) $ act arg + wThread t arg = + UEx.bracket_ (waitSem t) (signalSem t) $ act arg + -- quantity semaphore implementation using TVar + waitSem t = U.atomically $ do + v <- U.readTVar t + if v > 0 + then U.writeTVar t (v-1) + else U.retrySTM + + signalSem t = U.atomically $ do + v <- U.readTVar t + U.writeTVar t (v+1) + -- helper function to 'drop' empty optional parameter. mkQuery :: Text -> Maybe Text -> Maybe (Text, Text) mkQuery k mv = (k,) <$> mv @@ -188,7 +211,7 @@ mkOptionalParams params = HT.toQuery $ uncurry mkQuery <$> params chunkBSConduit :: (Monad m, Integral a) - => [a] -> C.Conduit ByteString m ByteString + => [a] -> C.ConduitM ByteString ByteString m () chunkBSConduit s = loop 0 [] s where loop _ _ [] = return () @@ -203,3 +226,36 @@ loop (fromIntegral $ B.length b) [b] sizes else loop (n + fromIntegral (B.length bs)) (readChunks ++ [bs]) (size:sizes) + +-- | Select part sizes - the logic is that the minimum part-size will +-- be 64MiB. +selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)] +selectPartSizes size = uncurry (List.zip3 [1..]) $ + List.unzip $ loop 0 size + where + ceil :: Double -> Int64 + ceil = ceiling + partSize = max minPartSize (ceil $ fromIntegral size / + fromIntegral maxMultipartParts) + + m = fromIntegral partSize + loop st sz + | st > sz = [] + | st + m >= sz = [(st, sz - st)] + | otherwise = (st, m) : loop (st + m) sz + +lookupRegionCache :: Bucket -> Minio (Maybe Region) +lookupRegionCache b = do + rMVar <- asks mcRegionMap + rMap <- UM.readMVar rMVar + return $ Map.lookup b rMap + +addToRegionCache :: Bucket -> Region -> Minio () +addToRegionCache b region = do + rMVar <- asks mcRegionMap + UM.modifyMVar_ rMVar $ return . Map.insert b region + +deleteFromRegionCache :: Bucket -> Minio () +deleteFromRegionCache b = do + rMVar <- asks mcRegionMap + UM.modifyMVar_ rMVar $ return . Map.delete b diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -29,8 +29,9 @@ ) where import Control.Monad.Trans.Resource -import Data.List (zip3, zip4) +import Data.List (zip3, zip4, zip5) import qualified Data.Text as T +import qualified Data.Map as Map import Data.Text.Read (decimal) import Data.Time import Text.XML @@ -50,6 +51,9 @@ uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e uncurry4 f (a, b, c, d) = f a b c d +uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a, b, c, d, e) -> f +uncurry5 f (a, b, c, d, e) = f a b c d e + -- | Parse time strings from XML parseS3XMLTime :: (MonadThrow m) => Text -> m UTCTime parseS3XMLTime = either (throwM . MErrVXmlParse) return @@ -134,7 +138,7 @@ sizes <- parseDecimals sizeStr let - objects = map (uncurry4 ObjectInfo) $ zip4 keys modTimes etags sizes + objects = map (uncurry5 ObjectInfo) $ zip5 keys modTimes etags sizes (repeat Map.empty) return $ ListObjectsV1Result hasMore nextMarker objects prefixes @@ -161,7 +165,7 @@ sizes <- parseDecimals sizeStr let - objects = map (uncurry4 ObjectInfo) $ zip4 keys modTimes etags sizes + objects = map (uncurry5 ObjectInfo) $ zip5 keys modTimes etags sizes (repeat Map.empty) return $ ListObjectsResult hasMore nextToken objects prefixes diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-11.1 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- '.' +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.1" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/test/LiveServer.hs b/test/LiveServer.hs --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -1,5 +1,5 @@ -- --- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -19,30 +19,29 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck as QC -import Lib.Prelude - -import System.Directory (getTemporaryDirectory) -import qualified System.IO as SIO - import qualified Control.Monad.Catch as MC import qualified Control.Monad.Trans.Resource as R import qualified Data.ByteString as BS -import Data.Conduit (yield, ($$)) +import Data.Conduit (yield) import qualified Data.Conduit as C import qualified Data.Conduit.Binary as CB import Data.Conduit.Combinators (sinkList) import Data.Default (Default (..)) import qualified Data.Map.Strict as Map import qualified Data.Text as T +import Data.Time (fromGregorian) import qualified Data.Time as Time import qualified Network.HTTP.Client.MultipartFormData as Form import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Types as HT +import System.Directory (getTemporaryDirectory) import System.Environment (lookupEnv) +import qualified System.IO as SIO +import Lib.Prelude + import Network.Minio import Network.Minio.Data -import Network.Minio.ListOps import Network.Minio.PutObject import Network.Minio.S3API import Network.Minio.Utils @@ -54,11 +53,9 @@ tests = testGroup "Tests" [liveServerUnitTests] -- conduit that generates random binary stream of given length -randomDataSrc :: MonadIO m => Int64 -> C.Producer m ByteString +randomDataSrc :: MonadIO m => Int64 -> C.ConduitM () ByteString m () randomDataSrc s' = genBS s' where - oneMiB = 1024*1024 - concatIt bs n = BS.concat $ replicate (fromIntegral q) bs ++ [BS.take (fromIntegral r) bs] where (q, r) = n `divMod` fromIntegral (BS.length bs) @@ -74,7 +71,7 @@ mkRandFile :: R.MonadResource m => Int64 -> m FilePath mkRandFile size = do dir <- liftIO $ getTemporaryDirectory - randomDataSrc size C.$$ CB.sinkTempFile dir "miniohstest.random" + C.runConduit $ randomDataSrc size C..| CB.sinkTempFile dir "miniohstest.random" funTestBucketPrefix :: Text funTestBucketPrefix = "miniohstest-" @@ -119,7 +116,7 @@ destFile <- mkRandFile 0 step "Retrieve the created object and check size" - fGetObject bucket object destFile + fGetObject bucket object destFile def gotSize <- withNewHandle destFile getFileSize liftIO $ gotSize == Right (Just mb15) @? "Wrong file size of put file after getting" @@ -127,6 +124,29 @@ step "Cleanup actions" removeObject bucket object +putObjectSizeTest :: TestTree +putObjectSizeTest = funTestWithBucket "PutObject of conduit source with size" $ + \step bucket -> do + -- putObject test (conduit source, size specified) + let obj = "msingle" + mb1 = 1 * 1024 * 1024 + + step "Prepare for putObject with from source with size." + rFile <- mkRandFile mb1 + + step "Upload single file." + putObject bucket obj (CB.sourceFile rFile) (Just mb1) def + + step "Retrieve and verify file size" + destFile <- mkRandFile 0 + fGetObject bucket obj destFile def + gotSize <- withNewHandle destFile getFileSize + liftIO $ gotSize == Right (Just mb1) @? + "Wrong file size of put file after getting" + + step "Cleanup actions" + deleteObject bucket obj + putObjectNoSizeTest :: TestTree putObjectNoSizeTest = funTestWithBucket "PutObject of conduit source with no size" $ \step bucket -> do @@ -138,11 +158,11 @@ rFile <- mkRandFile mb70 step "Upload multipart file." - putObject bucket obj (CB.sourceFile rFile) Nothing + putObject bucket obj (CB.sourceFile rFile) Nothing def step "Retrieve and verify file size" destFile <- mkRandFile 0 - fGetObject bucket obj destFile + fGetObject bucket obj destFile def gotSize <- withNewHandle destFile getFileSize liftIO $ gotSize == Right (Just mb70) @? "Wrong file size of put file after getting" @@ -157,17 +177,21 @@ step "put 3 objects" let expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3"] forM_ expectedObjects $ - \obj -> fPutObject bucket obj "/etc/lsb-release" + \obj -> fPutObject bucket obj "/etc/lsb-release" def step "High-level listing of objects" - objects <- listObjects bucket Nothing True $$ sinkList + objects <- C.runConduit $ listObjects bucket Nothing True C..| sinkList liftIO $ assertEqual "Objects match failed!" (sort expectedObjects) (map oiObject objects) step "High-level listing of objects (version 1)" - objects <- listObjectsV1 bucket Nothing True $$ sinkList + objectsV1 <- C.runConduit $ listObjectsV1 bucket Nothing True C..| + sinkList + liftIO $ assertEqual "Objects match failed!" (sort expectedObjects) + (map oiObject objectsV1) + step "Cleanup actions" forM_ expectedObjects $ \obj -> removeObject bucket obj @@ -180,11 +204,10 @@ liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") step "High-level listing of incomplete multipart uploads" - uploads <- listIncompleteUploads bucket Nothing True $$ sinkList - -- Minio server behaviour changed to list no incomplete uploads, - -- so the check below reflects this; this test is expected to - -- fail on AWS S3. - liftIO $ length uploads @?= 0 + uploads <- C.runConduit $ + listIncompleteUploads bucket (Just "newmpupload") True C..| + sinkList + liftIO $ length uploads @?= 10 step "cleanup" forM_ uploads $ \(UploadInfo _ uid _ _) -> @@ -204,7 +227,8 @@ putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5 step "fetch list parts" - incompleteParts <- listIncompleteParts bucket object uid $$ sinkList + incompleteParts <- C.runConduit $ listIncompleteParts bucket object uid + C..| sinkList liftIO $ length incompleteParts @?= 10 step "cleanup" @@ -217,7 +241,7 @@ let objects = (\s ->T.concat ["lsb-release", T.pack (show s)]) <$> [1..10::Int] forM_ [1..10::Int] $ \s -> - fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release" + fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release" def step "Simple list" res <- listObjects' bucket Nothing Nothing Nothing Nothing @@ -226,14 +250,14 @@ (map oiObject $ lorObjects res) step "Simple list version 1" - res <- listObjectsV1' bucket Nothing Nothing Nothing Nothing + resV1 <- listObjectsV1' bucket Nothing Nothing Nothing Nothing let expected = sort $ map (T.concat . ("lsb-release":) . (\x -> [x]) . T.pack . show) [1..10::Int] liftIO $ assertEqual "Objects match failed!" expected - (map oiObject $ lorObjects' res) + (map oiObject $ lorObjects' resV1) step "Cleanup actions" forM_ objects $ \obj -> deleteObject bucket obj @@ -246,12 +270,9 @@ liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") step "list incomplete multipart uploads" - incompleteUploads <- listIncompleteUploads' bucket Nothing Nothing + incompleteUploads <- listIncompleteUploads' bucket (Just "newmpupload") Nothing Nothing Nothing Nothing - -- Minio server behaviour changed to list no incomplete uploads, - -- so the check below reflects this; this test is expected to - -- fail on AWS S3. - liftIO $ (length $ lurUploads incompleteUploads) @?= 0 + liftIO $ (length $ lurUploads incompleteUploads) @?= 10 step "cleanup" forM_ (lurUploads incompleteUploads) $ @@ -282,6 +303,7 @@ , listingTest , highLevelListingTest , lowLevelMultipartTest + , putObjectSizeTest , putObjectNoSizeTest , funTestWithBucket "Multipart Tests" $ \step bucket -> do @@ -290,11 +312,11 @@ let mb80 = 80 * 1024 * 1024 obj = "mpart" - void $ putObjectInternal bucket obj $ ODFile "/dev/zero" (Just mb80) + void $ putObjectInternal bucket obj def $ ODFile "/dev/zero" (Just mb80) step "Retrieve and verify file size" destFile <- mkRandFile 0 - fGetObject bucket obj destFile + fGetObject bucket obj destFile def gotSize <- withNewHandle destFile getFileSize liftIO $ gotSize == Right (Just mb80) @? "Wrong file size of put file after getting" @@ -323,10 +345,108 @@ step "remove ongoing upload" removeIncompleteUpload bucket object - uploads <- listIncompleteUploads bucket (Just object) False C.$$ sinkList + uploads <- C.runConduit $ listIncompleteUploads bucket (Just object) False + C..| sinkList liftIO $ (null uploads) @? "removeIncompleteUploads didn't complete successfully" + , funTestWithBucket "putObject contentType tests" $ \step bucket -> do + step "fPutObject content type test" + let object = "xxx-content-type" + size1 = 100 :: Int64 + step "create server object with content-type" + inputFile <- mkRandFile size1 + fPutObject bucket object inputFile def{ + pooContentType = Just "application/javascript" + } + + -- retrieve obj info to check + oi <- headObject bucket object + let m = oiMetadata oi + + step "Validate content-type" + liftIO $ assertEqual "Content-Type did not match" (Just "application/javascript") (Map.lookup "Content-Type" m) + + step "upload object with content-encoding set to identity" + fPutObject bucket object inputFile def { + pooContentEncoding = Just "identity" + } + + oiCE <- headObject bucket object + let m' = oiMetadata oiCE + + step "Validate content-encoding" + liftIO $ assertEqual "Content-Encoding did not match" (Just "identity") + (Map.lookup "Content-Encoding" m') + + step "Cleanup actions" + + removeObject bucket object + + , funTestWithBucket "putObject contentLanguage tests" $ \step bucket -> do + step "fPutObject content language test" + let object = "xxx-content-language" + size1 = 100 :: Int64 + + step "create server object with content-language" + inputFile <- mkRandFile size1 + fPutObject bucket object inputFile def{ + pooContentLanguage = Just "en-US" + } + + -- retrieve obj info to check + oi <- headObject bucket object + let m = oiMetadata oi + + step "Validate content-language" + liftIO $ assertEqual "content-language did not match" (Just "en-US") + (Map.lookup "Content-Language" m) + step "Cleanup actions" + + removeObject bucket object + + , funTestWithBucket "putObject storageClass tests" $ \step bucket -> do + step "fPutObject storage class test" + let object = "xxx-storage-class-standard" + object' = "xxx-storage-class-reduced" + object'' = "xxx-storage-class-invalid" + size1 = 100 :: Int64 + size0 = 0 :: Int64 + + step "create server objects with storageClass" + inputFile <- mkRandFile size1 + inputFile' <- mkRandFile size1 + inputFile'' <- mkRandFile size0 + + fPutObject bucket object inputFile def{ + pooStorageClass = Just "STANDARD" + } + + fPutObject bucket object' inputFile' def{ + pooStorageClass = Just "REDUCED_REDUNDANCY" + } + + removeObject bucket object + + -- retrieve obj info to check + oi' <- headObject bucket object' + let m' = oiMetadata oi' + + step "Validate x-amz-storage-class rrs" + liftIO $ assertEqual "storageClass did not match" (Just "REDUCED_REDUNDANCY") + (Map.lookup "X-Amz-Storage-Class" m') + + fpE <- MC.try $ fPutObject bucket object'' inputFile'' def{ + pooStorageClass = Just "INVALID_STORAGE_CLASS" + } + case fpE of + Left exn -> liftIO $ exn @?= ServiceErr "InvalidStorageClass" "Invalid storage class." + _ -> return () + + step "Cleanup actions" + + removeObject bucket object' + , funTestWithBucket "copyObject related tests" $ \step bucket -> do step "copyObjectSingle basic tests" let object = "xxx" @@ -335,14 +455,17 @@ step "create server object to copy" inputFile <- mkRandFile size1 - fPutObject bucket object inputFile + fPutObject bucket object inputFile def step "copy object" - let cps = def { cpSource = format "/{}/{}" [bucket, object] } - (etag, modTime) <- copyObjectSingle bucket objCopy cps [] + let srcInfo = def { srcBucket = bucket, srcObject = object} + (etag, modTime) <- copyObjectSingle bucket objCopy srcInfo [] -- retrieve obj info to check - ObjectInfo _ t e s <- headObject bucket objCopy + oi <- headObject bucket objCopy + let t = oiModTime oi + let e = oiETag oi + let s = oiSize oi let isMTimeDiffOk = abs (diffUTCTime modTime t) < 1.0 @@ -361,17 +484,18 @@ let mb15 = 15 * 1024 * 1024 mb5 = 5 * 1024 * 1024 randFile <- mkRandFile mb15 - fPutObject bucket srcObj randFile + fPutObject bucket srcObj randFile def step "create new multipart upload" uid <- newMultipartUpload bucket copyObj [] liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id." step "put object parts 1-3" - let cps' = def {cpSource = format "/{}/{}" [bucket, srcObj]} + let srcInfo' = def { srcBucket = bucket, srcObject = srcObj } + dstInfo' = def { dstBucket = bucket, dstObject = copyObj } parts <- forM [1..3] $ \p -> do - (etag', _) <- copyObjectPart bucket copyObj cps'{ - cpSourceRange = Just ((p-1)*mb5, (p-1)*mb5 + (mb5 - 1)) + (etag', _) <- copyObjectPart dstInfo' srcInfo'{ + srcRange = Just $ (,) ((p-1)*mb5) ((p-1)*mb5 + (mb5 - 1)) } uid (fromIntegral p) [] return (fromIntegral p, etag') @@ -379,7 +503,8 @@ void $ completeMultipartUpload bucket copyObj uid parts step "verify copied object size" - (ObjectInfo _ _ _ s') <- headObject bucket copyObj + oi' <- headObject bucket copyObj + let s' = oiSize oi' liftIO $ (s' == mb15) @? "Size failed to match" @@ -393,12 +518,13 @@ sizes = map (* (1024 * 1024)) [15, 65] step "Prepare" - forM_ (zip srcs sizes) $ \(src, size) -> - fPutObject bucket src =<< mkRandFile size + forM_ (zip srcs sizes) $ \(src, size) -> do + inputFile' <- mkRandFile size + fPutObject bucket src inputFile' def step "make small and large object copy" forM_ (zip copyObjs srcs) $ \(cp, src) -> - copyObject bucket cp def{cpSource = format "/{}/{}" [bucket, src]} + copyObject def {dstBucket = bucket, dstObject = cp} def{srcBucket = bucket, srcObject = src} step "verify uploaded objects" uploadedSizes <- fmap oiSize <$> forM copyObjs (headObject bucket) @@ -412,12 +538,14 @@ size = 15 * 1024 * 1024 step "Prepare" - fPutObject bucket src =<< mkRandFile size + inputFile' <- mkRandFile size + fPutObject bucket src inputFile' def step "copy last 10MiB of object" - copyObject bucket copyObj def{ - cpSource = format "/{}/{}" [bucket, src] - , cpSourceRange = Just (5 * 1024 * 1024, size - 1) + copyObject def { dstBucket = bucket, dstObject = copyObj } def{ + srcBucket = bucket + , srcObject = src + , srcRange = Just $ (,) (5 * 1024 * 1024) (size - 1) } step "verify uploaded object" @@ -429,6 +557,7 @@ , presignedUrlFunTest , presignedPostPolicyFunTest + , bucketPolicyFunTest ] basicTests :: TestTree @@ -457,25 +586,54 @@ liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region) step "singlepart putObject works" - fPutObject bucket "lsb-release" "/etc/lsb-release" + fPutObject bucket "lsb-release" "/etc/lsb-release" def step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception" - fpE <- MC.try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release" + fpE <- MC.try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release" def case fpE of Left exn -> liftIO $ exn @?= NoSuchBucket _ -> return () outFile <- mkRandFile 0 step "simple fGetObject works" - fGetObject bucket "lsb-release" outFile + fGetObject bucket "lsb-release" outFile def - step "fGetObject a non-existent object and check for NoSuchKey exception" - resE <- MC.try $ fGetObject bucket "noSuchKey" outFile + let unmodifiedTime = UTCTime (fromGregorian 2010 11 26) 69857 + step "fGetObject an object which is modified now but requesting as un-modified in past, check for exception" + resE <- MC.try $ fGetObject bucket "lsb-release" outFile def{ + gooIfUnmodifiedSince = (Just unmodifiedTime) + } case resE of - Left exn -> liftIO $ exn @?= NoSuchKey + Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold" _ -> return () + step "fGetObject an object with no matching etag, check for exception" + resE1 <- MC.try $ fGetObject bucket "lsb-release" outFile def{ + gooIfMatch = (Just "invalid-etag") + } + case resE1 of + Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold" + _ -> return () + step "fGetObject an object with no valid range, check for exception" + resE2 <- MC.try $ fGetObject bucket "lsb-release" outFile def{ + gooRange = (Just $ HT.ByteRangeFromTo 100 200) + } + case resE2 of + Left exn -> liftIO $ exn @?= ServiceErr "InvalidRange" "The requested range is not satisfiable" + _ -> return () + + step "fGetObject on object with a valid range" + fGetObject bucket "lsb-release" outFile def{ + gooRange = (Just $ HT.ByteRangeFrom 1) + } + + step "fGetObject a non-existent object and check for NoSuchKey exception" + resE3 <- MC.try $ fGetObject bucket "noSuchKey" outFile def + case resE3 of + Left exn -> liftIO $ exn @?= NoSuchKey + _ -> return () + step "create new multipart upload works" uid <- newMultipartUpload bucket "newmpupload" [] liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") @@ -490,7 +648,7 @@ let object = "sample" step "create an object" inputFile <- mkRandFile 0 - fPutObject bucket object inputFile + fPutObject bucket object inputFile def step "get metadata of the object" res <- statObject bucket object @@ -529,7 +687,7 @@ "presigned GET failed" -- read content from file to compare with response above - bs <- CB.sourceFile inputFile $$ CB.sinkLbs + bs <- C.runConduit $ CB.sourceFile inputFile C..| CB.sinkLbs liftIO $ (bs == NC.responseBody getResp) @? "presigned put and get got mismatched data" @@ -564,7 +722,7 @@ "presigned GET failed (presignedGetObjectUrl)" -- read content from file to compare with response above - bs2 <- CB.sourceFile testFile $$ CB.sinkLbs + bs2 <- C.runConduit $ CB.sourceFile testFile C..| CB.sinkLbs liftIO $ (bs2 == NC.responseBody getResp2) @? "presigned put and get got mismatched data (presigned*Url)" @@ -624,3 +782,38 @@ req' <- Form.formDataBody parts' req mgr <- NC.newManager NC.tlsManagerSettings NC.httpLbs req' mgr + +bucketPolicyFunTest :: TestTree +bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $ + \step bucket -> do + + step "bucketPolicy basic test - no policy exception" + resE <- MC.try $ getBucketPolicy bucket + case resE of + Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist" + _ -> return () + + resE' <- MC.try $ setBucketPolicy bucket T.empty + case resE' of + Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist" + _ -> return () + + let expectedPolicyJSON = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket\"],\"Sid\":\"\"},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket/*\"],\"Sid\":\"\"}]}" + + step "try a malformed policy, expect error" + resE'' <- MC.try $ setBucketPolicy bucket expectedPolicyJSON + case resE'' of + Left exn -> liftIO $ exn @?= ServiceErr "MalformedPolicy" "Policy has invalid resource." + _ -> return () + + let expectedPolicyJSON' = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "\"],\"Sid\":\"\"},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "/*\"],\"Sid\":\"\"}]}" + + step "set bucket policy" + setBucketPolicy bucket expectedPolicyJSON' + + step "verify if bucket policy was properly set" + policyJSON <- getBucketPolicy bucket + liftIO $ policyJSON @?= expectedPolicyJSON' + + step "delete bucket policy" + setBucketPolicy bucket T.empty diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs --- a/test/Network/Minio/XmlParser/Test.hs +++ b/test/Network/Minio/XmlParser/Test.hs @@ -21,6 +21,7 @@ import qualified Control.Monad.Catch as MC import Data.Time (fromGregorian) +import qualified Data.Map as Map import Test.Tasty import Test.Tasty.HUnit @@ -126,7 +127,7 @@ \" expectedListResult = ListObjectsResult True (Just "opaque") [object1] [] - object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 + object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 Map.empty modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12 parsedListObjectsResult <- tryValidationErr $ parseListObjectsResponse xmldata @@ -153,7 +154,7 @@ \" expectedListResult = ListObjectsV1Result True (Just "my-image1.jpg") [object1] [] - object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 + object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 Map.empty modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12 parsedListObjectsV1Result <- tryValidationErr $ parseListObjectsV1Response xmldata diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -22,6 +22,8 @@ import Lib.Prelude import Network.Minio.API.Test +import Network.Minio.CopyObject +import Network.Minio.Data import Network.Minio.PutObject import Network.Minio.Utils.Test import Network.Minio.XmlGenerator.Test