diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,202 @@
+
+ Apache License
+ Version 2.0, January 2004
+ http://www.apache.org/licenses/
+
+ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
+
+ 1. Definitions.
+
+ "License" shall mean the terms and conditions for use, reproduction,
+ and distribution as defined by Sections 1 through 9 of this document.
+
+ "Licensor" shall mean the copyright owner or entity authorized by
+ the copyright owner that is granting the License.
+
+ "Legal Entity" shall mean the union of the acting entity and all
+ other entities that control, are controlled by, or are under common
+ control with that entity. For the purposes of this definition,
+ "control" means (i) the power, direct or indirect, to cause the
+ direction or management of such entity, whether by contract or
+ otherwise, or (ii) ownership of fifty percent (50%) or more of the
+ outstanding shares, or (iii) beneficial ownership of such entity.
+
+ "You" (or "Your") shall mean an individual or Legal Entity
+ exercising permissions granted by this License.
+
+ "Source" form shall mean the preferred form for making modifications,
+ including but not limited to software source code, documentation
+ source, and configuration files.
+
+ "Object" form shall mean any form resulting from mechanical
+ transformation or translation of a Source form, including but
+ not limited to compiled object code, generated documentation,
+ and conversions to other media types.
+
+ "Work" shall mean the work of authorship, whether in Source or
+ Object form, made available under the License, as indicated by a
+ copyright notice that is included in or attached to the work
+ (an example is provided in the Appendix below).
+
+ "Derivative Works" shall mean any work, whether in Source or Object
+ form, that is based on (or derived from) the Work and for which the
+ editorial revisions, annotations, elaborations, or other modifications
+ represent, as a whole, an original work of authorship. For the purposes
+ of this License, Derivative Works shall not include works that remain
+ separable from, or merely link (or bind by name) to the interfaces of,
+ the Work and Derivative Works thereof.
+
+ "Contribution" shall mean any work of authorship, including
+ the original version of the Work and any modifications or additions
+ to that Work or Derivative Works thereof, that is intentionally
+ submitted to Licensor for inclusion in the Work by the copyright owner
+ or by an individual or Legal Entity authorized to submit on behalf of
+ the copyright owner. For the purposes of this definition, "submitted"
+ means any form of electronic, verbal, or written communication sent
+ to the Licensor or its representatives, including but not limited to
+ communication on electronic mailing lists, source code control systems,
+ and issue tracking systems that are managed by, or on behalf of, the
+ Licensor for the purpose of discussing and improving the Work, but
+ excluding communication that is conspicuously marked or otherwise
+ designated in writing by the copyright owner as "Not a Contribution."
+
+ "Contributor" shall mean Licensor and any individual or Legal Entity
+ on behalf of whom a Contribution has been received by Licensor and
+ subsequently incorporated within the Work.
+
+ 2. Grant of Copyright License. Subject to the terms and conditions of
+ this License, each Contributor hereby grants to You a perpetual,
+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+ copyright license to reproduce, prepare Derivative Works of,
+ publicly display, publicly perform, sublicense, and distribute the
+ Work and such Derivative Works in Source or Object form.
+
+ 3. Grant of Patent License. Subject to the terms and conditions of
+ this License, each Contributor hereby grants to You a perpetual,
+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+ (except as stated in this section) patent license to make, have made,
+ use, offer to sell, sell, import, and otherwise transfer the Work,
+ where such license applies only to those patent claims licensable
+ by such Contributor that are necessarily infringed by their
+ Contribution(s) alone or by combination of their Contribution(s)
+ with the Work to which such Contribution(s) was submitted. If You
+ institute patent litigation against any entity (including a
+ cross-claim or counterclaim in a lawsuit) alleging that the Work
+ or a Contribution incorporated within the Work constitutes direct
+ or contributory patent infringement, then any patent licenses
+ granted to You under this License for that Work shall terminate
+ as of the date such litigation is filed.
+
+ 4. Redistribution. You may reproduce and distribute copies of the
+ Work or Derivative Works thereof in any medium, with or without
+ modifications, and in Source or Object form, provided that You
+ meet the following conditions:
+
+ (a) You must give any other recipients of the Work or
+ Derivative Works a copy of this License; and
+
+ (b) You must cause any modified files to carry prominent notices
+ stating that You changed the files; and
+
+ (c) You must retain, in the Source form of any Derivative Works
+ that You distribute, all copyright, patent, trademark, and
+ attribution notices from the Source form of the Work,
+ excluding those notices that do not pertain to any part of
+ the Derivative Works; and
+
+ (d) If the Work includes a "NOTICE" text file as part of its
+ distribution, then any Derivative Works that You distribute must
+ include a readable copy of the attribution notices contained
+ within such NOTICE file, excluding those notices that do not
+ pertain to any part of the Derivative Works, in at least one
+ of the following places: within a NOTICE text file distributed
+ as part of the Derivative Works; within the Source form or
+ documentation, if provided along with the Derivative Works; or,
+ within a display generated by the Derivative Works, if and
+ wherever such third-party notices normally appear. The contents
+ of the NOTICE file are for informational purposes only and
+ do not modify the License. You may add Your own attribution
+ notices within Derivative Works that You distribute, alongside
+ or as an addendum to the NOTICE text from the Work, provided
+ that such additional attribution notices cannot be construed
+ as modifying the License.
+
+ You may add Your own copyright statement to Your modifications and
+ may provide additional or different license terms and conditions
+ for use, reproduction, or distribution of Your modifications, or
+ for any such Derivative Works as a whole, provided Your use,
+ reproduction, and distribution of the Work otherwise complies with
+ the conditions stated in this License.
+
+ 5. Submission of Contributions. Unless You explicitly state otherwise,
+ any Contribution intentionally submitted for inclusion in the Work
+ by You to the Licensor shall be under the terms and conditions of
+ this License, without any additional terms or conditions.
+ Notwithstanding the above, nothing herein shall supersede or modify
+ the terms of any separate license agreement you may have executed
+ with Licensor regarding such Contributions.
+
+ 6. Trademarks. This License does not grant permission to use the trade
+ names, trademarks, service marks, or product names of the Licensor,
+ except as required for reasonable and customary use in describing the
+ origin of the Work and reproducing the content of the NOTICE file.
+
+ 7. Disclaimer of Warranty. Unless required by applicable law or
+ agreed to in writing, Licensor provides the Work (and each
+ Contributor provides its Contributions) on an "AS IS" BASIS,
+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
+ implied, including, without limitation, any warranties or conditions
+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
+ PARTICULAR PURPOSE. You are solely responsible for determining the
+ appropriateness of using or redistributing the Work and assume any
+ risks associated with Your exercise of permissions under this License.
+
+ 8. Limitation of Liability. In no event and under no legal theory,
+ whether in tort (including negligence), contract, or otherwise,
+ unless required by applicable law (such as deliberate and grossly
+ negligent acts) or agreed to in writing, shall any Contributor be
+ liable to You for damages, including any direct, indirect, special,
+ incidental, or consequential damages of any character arising as a
+ result of this License or out of the use or inability to use the
+ Work (including but not limited to damages for loss of goodwill,
+ work stoppage, computer failure or malfunction, or any and all
+ other commercial damages or losses), even if such Contributor
+ has been advised of the possibility of such damages.
+
+ 9. Accepting Warranty or Additional Liability. While redistributing
+ the Work or Derivative Works thereof, You may choose to offer,
+ and charge a fee for, acceptance of support, warranty, indemnity,
+ or other liability obligations and/or rights consistent with this
+ License. However, in accepting such obligations, You may act only
+ on Your own behalf and on Your sole responsibility, not on behalf
+ of any other Contributor, and only if You agree to indemnify,
+ defend, and hold each Contributor harmless for any liability
+ incurred by, or claims asserted against, such Contributor by reason
+ of your accepting any such warranty or additional liability.
+
+ END OF TERMS AND CONDITIONS
+
+ APPENDIX: How to apply the Apache License to your work.
+
+ To apply the Apache License to your work, attach the following
+ boilerplate notice, with the fields enclosed by brackets "[]"
+ replaced with your own identifying information. (Don't include
+ the brackets!) The text should be enclosed in the appropriate
+ comment syntax for the file format. We also recommend that a
+ file or class name and description of purpose be included on the
+ same "printed page" as the copyright notice for easier
+ identification within third-party archives.
+
+ Copyright [yyyy] [name of copyright owner]
+
+ 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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/minio-hs.cabal b/minio-hs.cabal
new file mode 100644
--- /dev/null
+++ b/minio-hs.cabal
@@ -0,0 +1,143 @@
+name: minio-hs
+version: 0.0.1
+synopsis: A Minio client library, compatible with S3 like services.
+description: Please see README.md
+homepage: https://github.com/donatello/minio-hs#readme
+license: Apache-2.0
+license-file: LICENSE
+author: Aditya Manthramurthy, Krishnan Parthasarathi
+maintainer: aditya.mmy@gmail.com
+category: Network, AWS, Object Storage
+build-type: Simple
+-- extra-source-files:
+cabal-version: >=1.10
+
+library
+ hs-source-dirs: src
+ ghc-options: -Wall
+ exposed-modules: Network.Minio
+ , Network.Minio.S3API
+ other-modules: Lib.Prelude
+ , Network.Minio.API
+ , Network.Minio.Data
+ , Network.Minio.Data.ByteString
+ , Network.Minio.Data.Crypto
+ , Network.Minio.Data.Time
+ , Network.Minio.ListOps
+ , Network.Minio.PutObject
+ , Network.Minio.Sign.V4
+ , Network.Minio.Utils
+ , Network.Minio.XmlGenerator
+ , Network.Minio.XmlParser
+ build-depends: base >= 4.7 && < 5
+ , protolude >= 0.1.6 && < 0.2
+ , async
+ , bytestring
+ , case-insensitive
+ , conduit
+ , conduit-combinators
+ , conduit-extra
+ , containers
+ , cryptonite
+ , cryptonite-conduit
+ , data-default
+ , exceptions
+ , filepath
+ , http-client
+ , http-conduit
+ , http-types
+ , lifted-async
+ , lifted-base
+ , memory
+ , monad-control
+ , resourcet
+ , text
+ , time
+ , transformers
+ , transformers-base
+ , xml-conduit
+ default-language: Haskell2010
+ default-extensions: FlexibleContexts
+ , FlexibleInstances
+ , MultiParamTypeClasses
+ , MultiWayIf
+ , NoImplicitPrelude
+ , OverloadedStrings
+ , RankNTypes
+ , ScopedTypeVariables
+ , TypeFamilies
+ , TupleSections
+
+test-suite minio-hs-test
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test, src
+ main-is: Spec.hs
+ build-depends: base
+ , minio-hs
+ , protolude >= 0.1.6 && < 0.2
+ , async
+ , bytestring
+ , case-insensitive
+ , conduit
+ , conduit-combinators
+ , conduit-extra
+ , containers
+ , cryptonite
+ , cryptonite-conduit
+ , data-default
+ , directory
+ , exceptions
+ , filepath
+ , http-client
+ , http-conduit
+ , http-types
+ , lifted-async
+ , lifted-base
+ , memory
+ , monad-control
+ , QuickCheck
+ , resourcet
+ , tasty
+ , tasty-hunit
+ , tasty-quickcheck
+ , tasty-smallcheck
+ , temporary
+ , text
+ , time
+ , transformers
+ , transformers-base
+ , xml-conduit
+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
+ -- ghc-options: -Wall
+ default-language: Haskell2010
+ default-extensions: FlexibleContexts
+ , FlexibleInstances
+ , OverloadedStrings
+ , NoImplicitPrelude
+ , MultiParamTypeClasses
+ , MultiWayIf
+ , ScopedTypeVariables
+ , RankNTypes
+ , TupleSections
+ , TypeFamilies
+ other-modules: Lib.Prelude
+ , Network.Minio
+ , Network.Minio.API
+ , Network.Minio.Data
+ , Network.Minio.Data.ByteString
+ , Network.Minio.Data.Crypto
+ , Network.Minio.Data.Time
+ , Network.Minio.ListOps
+ , Network.Minio.PutObject
+ , Network.Minio.S3API
+ , Network.Minio.Sign.V4
+ , Network.Minio.Utils
+ , Network.Minio.XmlGenerator
+ , Network.Minio.XmlGenerator.Test
+ , Network.Minio.XmlParser
+ , Network.Minio.XmlParser.Test
+
+
+source-repository head
+ type: git
+ location: https://github.com/donatello/minio-hs
diff --git a/src/Lib/Prelude.hs b/src/Lib/Prelude.hs
new file mode 100644
--- /dev/null
+++ b/src/Lib/Prelude.hs
@@ -0,0 +1,16 @@
+{-
+Welcome to your custom Prelude
+Export here everything that should always be in your library scope
+For more info on what is exported by Protolude check:
+https://github.com/sdiehl/protolude/blob/master/Symbols.md
+-}
+module Lib.Prelude
+ ( module Exports
+ ) where
+
+import Protolude as Exports
+
+import Data.Time as Exports (UTCTime)
+import Control.Monad.Trans.Maybe as Exports (runMaybeT, MaybeT(..))
+
+import Control.Monad.Catch as Exports (throwM, MonadThrow, MonadCatch)
diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Minio.hs
@@ -0,0 +1,89 @@
+module Network.Minio
+ (
+
+ ConnectInfo(..)
+ , awsCI
+ , minioPlayCI
+ , connect
+
+ , Minio
+ , runMinio
+ , runResourceT
+
+ -- * Error handling
+ -----------------------
+ -- | Data types representing various errors that may occur while working
+ -- with an object storage service.
+ , MinioErr(..)
+ , MErrV(..)
+ , MError(..)
+
+ -- * Data Types
+ ----------------
+ -- | Data types representing various object store concepts.
+ , Bucket
+ , Object
+ , BucketInfo(..)
+ , UploadId
+ , ObjectData(..)
+
+ -- * Bucket Operations
+ ----------------------
+ , getService
+ , getLocation
+
+ , listObjects
+ , listIncompleteUploads
+ , listIncompleteParts
+
+ -- * Object Operations
+ ----------------------
+ , fGetObject
+ , fPutObject
+ , putObjectFromSource
+
+ , getObject
+
+ ) where
+
+{-
+This module exports the high-level Minio API for object storage.
+-}
+
+import Control.Monad.Trans.Resource (runResourceT)
+import qualified Data.Conduit as C
+import qualified Data.Conduit.Binary as CB
+
+import Lib.Prelude
+
+import Network.Minio.Data
+import Network.Minio.ListOps
+import Network.Minio.PutObject
+import Network.Minio.S3API
+
+-- | 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
+
+-- | Upload the given file to the given object.
+fPutObject :: Bucket -> Object -> FilePath -> Minio ()
+fPutObject bucket object f = void $ putObject bucket object $
+ 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
+-- performing a multipart upload. If not specified, it is assumed that
+-- the object can be potentially 5TiB and selects multipart sizes
+-- appropriately.
+putObjectFromSource :: Bucket -> Object -> C.Producer Minio ByteString
+ -> Maybe Int64 -> Minio ()
+putObjectFromSource bucket object src sizeMay = void $ putObject bucket object $
+ ODStream src sizeMay
+
+-- | 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 [] []
diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Minio/API.hs
@@ -0,0 +1,77 @@
+module Network.Minio.API
+ (
+ connect
+ , RequestInfo(..)
+ , runMinio
+ , executeRequest
+ , mkStreamRequest
+ ) where
+
+import qualified Data.Conduit as C
+import Data.Conduit.Binary (sourceHandleRange)
+import Network.HTTP.Conduit (Response)
+import qualified Network.HTTP.Conduit as NC
+import qualified Network.HTTP.Types as HT
+
+import Lib.Prelude
+
+import Network.Minio.Data
+import Network.Minio.Data.Crypto
+import Network.Minio.Sign.V4
+import Network.Minio.Utils
+
+sha256Header :: ByteString -> HT.Header
+sha256Header = ("x-amz-content-sha256", )
+
+getPayloadSHA256Hash :: (MonadIO m) => Payload -> m ByteString
+getPayloadSHA256Hash (PayloadBS bs) = return $ hashSHA256 bs
+getPayloadSHA256Hash (PayloadH h off size) = hashSHA256FromSource $
+ sourceHandleRange h
+ (return . fromIntegral $ off)
+ (return . fromIntegral $ size)
+
+getRequestBody :: Payload -> NC.RequestBody
+getRequestBody (PayloadBS bs) = NC.RequestBodyBS bs
+getRequestBody (PayloadH h off size) =
+ NC.requestBodySource (fromIntegral size) $
+ sourceHandleRange h
+ (return . fromIntegral $ off)
+ (return . fromIntegral $ size)
+
+buildRequest :: (MonadIO m, MonadReader MinioConn m)
+ => RequestInfo -> m NC.Request
+buildRequest ri = do
+ sha256Hash <- getPayloadSHA256Hash (riPayload ri)
+ let newRi = ri {
+ riPayloadHash = sha256Hash
+ , riHeaders = sha256Header sha256Hash : (riHeaders ri)
+ }
+
+ ci <- asks mcConnInfo
+
+ reqHeaders <- liftIO $ signV4 ci newRi
+
+ return NC.defaultRequest {
+ NC.method = riMethod newRi
+ , NC.secure = connectIsSecure ci
+ , NC.host = encodeUtf8 $ connectHost ci
+ , NC.port = connectPort ci
+ , NC.path = getPathFromRI newRi
+ , NC.queryString = HT.renderQuery False $ riQueryParams newRi
+ , NC.requestHeaders = reqHeaders
+ , NC.requestBody = getRequestBody (riPayload newRi)
+ }
+
+executeRequest :: RequestInfo -> Minio (Response LByteString)
+executeRequest ri = do
+ req <- buildRequest ri
+ mgr <- asks mcConnManager
+ httpLbs req mgr
+
+
+mkStreamRequest :: RequestInfo
+ -> Minio (Response (C.ResumableSource Minio ByteString))
+mkStreamRequest ri = do
+ req <- buildRequest ri
+ mgr <- asks mcConnManager
+ http req mgr
diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Minio/Data.hs
@@ -0,0 +1,248 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}
+module Network.Minio.Data where
+
+import Control.Monad.Base
+import qualified Control.Monad.Catch as MC
+import Control.Monad.Trans.Control
+import Control.Monad.Trans.Resource
+import qualified Data.ByteString as B
+import Data.Default (Default(..))
+import Network.HTTP.Client (defaultManagerSettings, HttpException)
+import qualified Network.HTTP.Conduit as NC
+import Network.HTTP.Types (Method, Header, Query)
+import qualified Network.HTTP.Types as HT
+import Text.XML
+
+import Lib.Prelude
+
+-- | Connection Info data type. Use the Default instance to create
+-- connection info for your service.
+data ConnectInfo = ConnectInfo {
+ connectHost :: Text
+ , connectPort :: Int
+ , connectAccessKey :: Text
+ , connectSecretKey :: Text
+ , connectIsSecure :: Bool
+ } deriving (Eq, Show)
+
+instance Default ConnectInfo where
+ def = ConnectInfo "localhost" 9000 "minio" "minio123" False
+
+-- |
+-- Default aws ConnectInfo. Credentials should be supplied before use.
+awsCI :: ConnectInfo
+awsCI = def {
+ connectHost = "s3.amazonaws.com"
+ , connectPort = 443
+ , connectAccessKey = ""
+ , connectSecretKey = ""
+ , connectIsSecure = True
+ }
+
+-- |
+-- Default minio play server ConnectInfo. Credentials are already filled.
+minioPlayCI :: ConnectInfo
+minioPlayCI = def {
+ connectHost = "play.minio.io"
+ , connectPort = 9000
+ , connectAccessKey = "Q3AM3UQ867SPQQA43P2F"
+ , connectSecretKey = "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG"
+ , connectIsSecure = True
+ }
+
+-- |
+-- Represents a bucket in the object store
+type Bucket = Text
+
+-- |
+-- Represents an object name
+type Object = Text
+
+-- |
+-- Represents a region
+-- TODO: This could be a Sum Type with all defined regions for AWS.
+type Region = Text
+
+-- | A type alias to represent an Entity-Tag returned by S3-compatible
+-- APIs.
+type ETag = Text
+
+-- |
+-- BucketInfo returned for list buckets call
+data BucketInfo = BucketInfo {
+ biName :: Bucket
+ , biCreationDate :: UTCTime
+ } deriving (Show, Eq)
+
+-- | A type alias to represent a part-number for multipart upload
+type PartNumber = Int16
+
+-- | A type alias to represent an upload-id for multipart upload
+type UploadId = Text
+
+-- | A data-type to represent info about a part
+data PartInfo = PartInfo PartNumber ETag
+ deriving (Show, Eq)
+
+instance Ord PartInfo where
+ (PartInfo a _) `compare` (PartInfo b _) = a `compare` b
+
+
+-- | Represents result from a listing of object parts of an ongoing
+-- multipart upload.
+data ListPartsResult = ListPartsResult {
+ lprHasMore :: Bool
+ , lprNextPart :: Maybe Int
+ , lprParts :: [ListPartInfo]
+ } deriving (Show, Eq)
+
+
+-- | Represents information about an object part in an ongoing
+-- multipart upload.
+data ListPartInfo = ListPartInfo {
+ piNumber :: PartNumber
+ , piETag :: ETag
+ , piSize :: Int64
+ , piModTime :: UTCTime
+ } deriving (Show, Eq)
+
+-- | Represents result from a listing of incomplete uploads to a
+-- bucket.
+data ListUploadsResult = ListUploadsResult {
+ lurHasMore :: Bool
+ , lurNextKey :: Maybe Text
+ , lurNextUpload :: Maybe Text
+ , lurUploads :: [UploadInfo]
+ , lurCPrefixes :: [Text]
+ } deriving (Show, Eq)
+
+-- | Represents information about a multipart upload.
+data UploadInfo = UploadInfo {
+ uiKey :: Object
+ , uiUploadId :: UploadId
+ , uiInitTime :: UTCTime
+ } deriving (Show, Eq)
+
+-- | Represents result from a listing of objects in a bucket.
+data ListObjectsResult = ListObjectsResult {
+ lorHasMore :: Bool
+ , lorNextToken :: Maybe Text
+ , lorObjects :: [ObjectInfo]
+ , lorCPrefixes :: [Text]
+ } deriving (Show, Eq)
+
+-- | Represents information about an object.
+data ObjectInfo = ObjectInfo {
+ oiObject :: Object
+ , oiModTime :: UTCTime
+ , oiETag :: ETag
+ , oiSize :: Int64
+ } deriving (Show, Eq)
+
+-- | Represents different kinds of payload that are used with S3 API
+-- requests.
+data Payload = PayloadBS ByteString
+ | PayloadH Handle
+ Int64 -- offset
+ Int64 -- size
+
+instance Default Payload where
+ def = PayloadBS ""
+
+data RequestInfo = RequestInfo {
+ riMethod :: Method
+ , riBucket :: Maybe Bucket
+ , riObject :: Maybe Object
+ , riQueryParams :: Query
+ , riHeaders :: [Header]
+ , riPayload :: Payload
+ , riPayloadHash :: ByteString
+ , riRegion :: Maybe Region
+ }
+
+instance Default RequestInfo where
+ def = RequestInfo HT.methodGet def def def def def "" def
+
+getPathFromRI :: RequestInfo -> ByteString
+getPathFromRI ri = B.concat $ parts
+ where
+ objPart = maybe [] (\o -> ["/", encodeUtf8 o]) $ riObject ri
+ parts = maybe ["/"] (\b -> "/" : encodeUtf8 b : objPart) $ riBucket ri
+
+getRegionFromRI :: RequestInfo -> Text
+getRegionFromRI ri = maybe "us-east-1" identity (riRegion ri)
+
+newtype Minio a = Minio {
+ unMinio :: ReaderT MinioConn (ResourceT IO) a
+ }
+ deriving (
+ Functor
+ , Applicative
+ , Monad
+ , MonadIO
+ , MonadReader MinioConn
+ , MonadThrow
+ , MonadCatch
+ , MonadBase IO
+ , MonadResource
+ )
+
+instance MonadBaseControl IO Minio where
+ type StM Minio a = a
+ liftBaseWith f = Minio $ liftBaseWith $ \q -> f (q . unMinio)
+ restoreM = Minio . restoreM
+
+-- | MinioConn holds connection info and a connection pool
+data MinioConn = MinioConn {
+ mcConnInfo :: ConnectInfo
+ , mcConnManager :: NC.Manager
+ }
+
+-- | 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
+ mgr <- NC.newManager settings
+ return $ MinioConn ci mgr
+
+-- | Run the Minio action and return the result or an error.
+runMinio :: ConnectInfo -> Minio a -> ResourceT IO (Either MinioErr a)
+runMinio ci m = do
+ conn <- liftIO $ connect ci
+ flip runReaderT conn . unMinio $
+ (m >>= (return . Right)) `MC.catches`
+ [MC.Handler handlerME, MC.Handler handlerHE, MC.Handler handlerFE]
+ where
+ handlerME = return . Left . ME
+ handlerHE = return . Left . MEHttp
+ handlerFE = return . Left . MEFile
+
+s3Name :: Text -> Name
+s3Name s = Name s (Just "http://s3.amazonaws.com/doc/2006-03-01/") Nothing
+
+---------------------------------
+-- Errors
+---------------------------------
+-- | Various validation errors
+data MErrV = MErrVSinglePUTSizeExceeded Int64
+ | MErrVPutSizeExceeded Int64
+ | MErrVETagHeaderNotFound
+ deriving (Show, Eq)
+
+-- | Errors thrown by the library
+data MinioErr = ME MError
+ | MEHttp HttpException
+ | MEFile IOException
+ deriving (Show)
+
+instance Exception MinioErr
+
+-- | Library internal errors
+data MError = XMLParseError Text
+ | ResponseError (NC.Response LByteString)
+ | ValidationError MErrV
+ deriving (Show, Eq)
+
+instance Exception MError
diff --git a/src/Network/Minio/Data/ByteString.hs b/src/Network/Minio/Data/ByteString.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Minio/Data/ByteString.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE FlexibleInstances #-}
+module Network.Minio.Data.ByteString
+ (
+ stripBS
+ , UriEncodable(..)
+ ) where
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Builder as BB
+import qualified Data.ByteString.Char8 as BC8
+import qualified Data.ByteString.Lazy as LB
+import Data.Char (isSpace, toUpper)
+import qualified Data.Text as T
+import Numeric (showHex)
+
+import Lib.Prelude
+
+stripBS :: ByteString -> ByteString
+stripBS = BC8.dropWhile isSpace . fst . BC8.spanEnd isSpace
+
+class UriEncodable s where
+ uriEncode :: Bool -> s -> ByteString
+
+instance UriEncodable [Char] where
+ uriEncode encodeSlash payload =
+ LB.toStrict $ BB.toLazyByteString $ mconcat $
+ map (flip uriEncodeChar encodeSlash) payload
+
+instance UriEncodable ByteString where
+ -- assumes that uriEncode is passed ASCII encoded strings.
+ uriEncode encodeSlash bs =
+ uriEncode encodeSlash $ BC8.unpack bs
+
+instance UriEncodable Text where
+ uriEncode encodeSlash txt =
+ uriEncode encodeSlash $ T.unpack txt
+
+-- | URI encode a char according to AWS S3 signing rules - see
+-- UriEncode() at
+-- https://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html
+uriEncodeChar :: Char -> Bool -> BB.Builder
+uriEncodeChar '/' True = BB.byteString "%2F"
+uriEncodeChar '/' False = BB.char7 '/'
+uriEncodeChar ch _
+ | (ch >= 'A' && ch <= 'Z')
+ || (ch >= 'a' && ch <= 'z')
+ || (ch >= '0' && ch <= '9')
+ || (ch == '_')
+ || (ch == '-')
+ || (ch == '.')
+ || (ch == '~') = BB.char7 ch
+ | otherwise = mconcat $ map f $ B.unpack $ encodeUtf8 $ T.singleton ch
+ where
+ f :: Word8 -> BB.Builder
+ f n = BB.char7 '%' <> BB.string7 hexStr
+ where
+ hexStr = map toUpper $ showHex q $ showHex r ""
+ (q, r) = divMod (fromIntegral n) (16::Word8)
diff --git a/src/Network/Minio/Data/Crypto.hs b/src/Network/Minio/Data/Crypto.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Minio/Data/Crypto.hs
@@ -0,0 +1,58 @@
+module Network.Minio.Data.Crypto
+ (
+ hashSHA256
+ , hashSHA256FromSource
+
+ , hashMD5
+ , hashMD5FromSource
+
+ , hmacSHA256
+ , hmacSHA256RawBS
+ , digestToBS
+ , 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 Lib.Prelude
+
+hashSHA256 :: ByteString -> ByteString
+hashSHA256 = digestToBase16 . hashWith SHA256
+
+hashSHA256FromSource :: Monad m => C.Producer m ByteString -> m ByteString
+hashSHA256FromSource src = do
+ digest <- src C.$$ sinkSHA256Hash
+ return $ digestToBase16 digest
+ where
+ -- To help with type inference
+ sinkSHA256Hash :: Monad m => C.Consumer ByteString m (Digest SHA256)
+ sinkSHA256Hash = sinkHash
+
+hashMD5 :: ByteString -> ByteString
+hashMD5 = digestToBase16 . hashWith MD5
+
+hashMD5FromSource :: Monad m => C.Producer m ByteString -> m ByteString
+hashMD5FromSource src = do
+ digest <- src C.$$ sinkMD5Hash
+ return $ digestToBase16 digest
+ where
+ -- To help with type inference
+ sinkMD5Hash :: Monad m => C.Consumer ByteString m (Digest MD5)
+ sinkMD5Hash = sinkHash
+
+hmacSHA256 :: ByteString -> ByteString -> HMAC SHA256
+hmacSHA256 message key = hmac key message
+
+hmacSHA256RawBS :: ByteString -> ByteString -> ByteString
+hmacSHA256RawBS message key = convert $ hmacSHA256 message key
+
+digestToBS :: ByteArrayAccess a => a -> ByteString
+digestToBS = convert
+
+digestToBase16 :: ByteArrayAccess a => a -> ByteString
+digestToBase16 = convertToBase Base16
diff --git a/src/Network/Minio/Data/Time.hs b/src/Network/Minio/Data/Time.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Minio/Data/Time.hs
@@ -0,0 +1,29 @@
+module Network.Minio.Data.Time
+ (
+ awsTimeFormat
+ , awsTimeFormatBS
+ , awsDateFormat
+ , awsDateFormatBS
+ , awsParseTime
+ ) where
+
+
+import Data.ByteString.Char8 (pack)
+import qualified Data.Time as Time
+
+import Lib.Prelude
+
+awsTimeFormat :: UTCTime -> [Char]
+awsTimeFormat = Time.formatTime Time.defaultTimeLocale "%Y%m%dT%H%M%SZ"
+
+awsTimeFormatBS :: UTCTime -> ByteString
+awsTimeFormatBS = pack . awsTimeFormat
+
+awsDateFormat :: UTCTime -> [Char]
+awsDateFormat = Time.formatTime Time.defaultTimeLocale "%Y%m%d"
+
+awsDateFormatBS :: UTCTime -> ByteString
+awsDateFormatBS = pack . awsDateFormat
+
+awsParseTime :: [Char] -> Maybe UTCTime
+awsParseTime = Time.parseTimeM False Time.defaultTimeLocale "%Y%m%dT%H%M%SZ"
diff --git a/src/Network/Minio/ListOps.hs b/src/Network/Minio/ListOps.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Minio/ListOps.hs
@@ -0,0 +1,56 @@
+module Network.Minio.ListOps where
+
+import qualified Data.Conduit as C
+import qualified Data.Conduit.List as CL
+
+import Lib.Prelude
+
+import Network.Minio.Data
+import Network.Minio.S3API
+
+-- | 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 prefix recurse = loop Nothing
+ where
+ loop :: Maybe Text -> C.Producer Minio ObjectInfo
+ loop nextToken = do
+ let
+ delimiter = bool (Just "/") Nothing recurse
+
+ res <- lift $ listObjects' bucket prefix nextToken delimiter
+ CL.sourceList $ lorObjects res
+ when (lorHasMore res) $
+ loop (lorNextToken res)
+
+-- | List incomplete uploads in a bucket matching the given prefix. If
+-- recurse is set to True incomplete uploads for the given prefix are
+-- recursively listed.
+listIncompleteUploads :: Bucket -> Maybe Text -> Bool
+ -> C.Producer Minio UploadInfo
+listIncompleteUploads bucket prefix recurse = loop Nothing Nothing
+ where
+ loop :: Maybe Text -> Maybe Text -> C.Producer Minio UploadInfo
+ loop nextKeyMarker nextUploadIdMarker = do
+ let
+ delimiter = bool (Just "/") Nothing recurse
+
+ res <- lift $ listIncompleteUploads' bucket prefix delimiter
+ nextKeyMarker nextUploadIdMarker
+ CL.sourceList $ lurUploads res
+ when (lurHasMore res) $
+ loop nextKeyMarker nextUploadIdMarker
+
+-- | List object parts of an ongoing multipart upload for given
+-- bucket, object and uploadId.
+listIncompleteParts :: Bucket -> Object -> UploadId
+ -> C.Producer Minio ListPartInfo
+listIncompleteParts bucket object uploadId = loop Nothing
+ where
+ loop :: Maybe Text -> C.Producer Minio ListPartInfo
+ loop nextPartMarker = do
+ res <- lift $ listIncompleteParts' bucket object uploadId Nothing
+ nextPartMarker
+ CL.sourceList $ lprParts res
+ when (lprHasMore res) $
+ loop (show <$> lprNextPart res)
diff --git a/src/Network/Minio/PutObject.hs b/src/Network/Minio/PutObject.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Minio/PutObject.hs
@@ -0,0 +1,180 @@
+module Network.Minio.PutObject
+ (
+ putObject
+ , ObjectData(..)
+ , selectPartSizes
+ ) where
+
+
+import qualified Data.ByteString as B
+import qualified Data.Conduit as C
+import Data.Conduit.Binary (sourceHandleRange)
+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.Map.Strict as Map
+
+import Lib.Prelude
+
+import Network.Minio.Data
+import Network.Minio.Data.Crypto
+import Network.Minio.ListOps
+import Network.Minio.S3API
+import Network.Minio.Utils
+
+
+-- | max obj size is 5TiB
+maxObjectSize :: Int64
+maxObjectSize = 5 * 1024 * 1024 * 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.
+--
+-- For files, a size may be provided - this is useful in cases when
+-- the file size cannot be automatically determined or if only some
+-- prefix of the file is desired.
+--
+-- 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.
+
+-- | Put an object from ObjectData. This high-level API handles
+-- objects of all sizes, and even if the object size is unknown.
+putObject :: Bucket -> Object -> ObjectData Minio -> Minio ETag
+putObject b o (ODStream src sizeMay) = sequentialMultipartUpload b o sizeMay src
+putObject b o (ODFile fp sizeMay) = do
+ hResE <- withNewHandle fp $ \h ->
+ liftM2 (,) (isHandleSeekable h) (getFileSize h)
+
+ (isSeekable, handleSizeMay) <- either (const $ return (False, Nothing)) return
+ hResE
+
+ -- prefer given size to queried size.
+ let finalSizeMay = listToMaybe $ catMaybes [sizeMay, handleSizeMay]
+
+ case finalSizeMay of
+ -- unable to get size, so assume non-seekable file and max-object size
+ Nothing -> sequentialMultipartUpload b o (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)
+ | size > maxObjectSize -> throwM $ ValidationError $
+ MErrVPutSizeExceeded size
+ | isSeekable -> parallelMultipartUpload b o fp size
+ | otherwise -> sequentialMultipartUpload b o (Just size) $
+ CB.sourceFile fp
+
+-- | Select part sizes - the logic is that the minimum part-size will
+-- be 64MiB. TODO: write quickcheck tests.
+selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)]
+selectPartSizes size = List.zip3 [1..] partOffsets partSizes
+ where
+ ceil :: Double -> Int64
+ ceil = ceiling
+ partSize = max (64 * oneMiB) (ceil $ fromIntegral size /
+ fromIntegral maxMultipartParts)
+ (numParts, lastPartSize) = size `divMod` partSize
+ lastPart = filter (> 0) [lastPartSize]
+ partSizes = replicate (fromIntegral numParts) partSize ++ lastPart
+ partOffsets = List.scanl' (+) 0 partSizes
+
+-- returns partinfo if part is already uploaded.
+checkUploadNeeded :: Payload -> PartNumber
+ -> Map.Map PartNumber ListPartInfo
+ -> Minio (Maybe PartInfo)
+checkUploadNeeded payload n pmap = do
+ (md5hash, pSize) <- case payload of
+ PayloadBS bs -> return (hashMD5 bs, fromIntegral $ B.length bs)
+ PayloadH h off size -> liftM (, size) $
+ hashMD5FromSource $ sourceHandleRange h (Just $ fromIntegral off)
+ (Just $ fromIntegral size)
+ case Map.lookup n pmap of
+ Nothing -> return Nothing
+ Just (ListPartInfo _ etag size _) -> return $
+ bool Nothing (Just (PartInfo n etag)) $
+ md5hash == encodeUtf8 etag && size == pSize
+
+parallelMultipartUpload :: Bucket -> Object -> FilePath -> Int64
+ -> Minio ETag
+parallelMultipartUpload b o filePath size = do
+ (uidMay, pmap) <- getExistingUpload b o
+
+ -- get a new upload id if needed.
+ uploadId <- maybe (newMultipartUpload b o []) return uidMay
+
+ let partSizeInfo = selectPartSizes size
+
+ -- perform upload with 10 threads
+ uploadedPartsE <- limitedMapConcurrently 10
+ (uploadPart pmap uploadId) partSizeInfo
+
+ -- if there were any errors, rethrow exception.
+ mapM_ throwM $ lefts uploadedPartsE
+
+ -- if we get here, all parts were successfully uploaded.
+ completeMultipartUpload b o uploadId $ rights uploadedPartsE
+ where
+ uploadPart pmap uploadId (partNum, offset, sz) =
+ withNewHandle filePath $ \h -> do
+ let payload = PayloadH h offset sz
+ pInfoMay <- checkUploadNeeded payload partNum pmap
+ maybe
+ (putObjectPart b o uploadId partNum [] payload)
+ return pInfoMay
+
+-- | Upload multipart object from conduit source sequentially
+sequentialMultipartUpload :: Bucket -> Object -> Maybe Int64
+ -> C.Producer Minio ByteString -> Minio ETag
+sequentialMultipartUpload b o sizeMay src = do
+ (uidMay, pmap) <- getExistingUpload b o
+
+ -- get a new upload id if needed.
+ uploadId <- maybe (newMultipartUpload b o []) return uidMay
+
+ -- upload parts in loop
+ let partSizes = selectPartSizes $ maybe maxObjectSize identity sizeMay
+ (pnums, _, sizes) = List.unzip3 partSizes
+ uploadedParts <- src
+ C..| chunkBSConduit sizes
+ C..| CL.map PayloadBS
+ C..| checkAndUpload uploadId pmap pnums
+ C.$$ CC.sinkList
+
+ -- complete multipart upload
+ completeMultipartUpload b o uploadId uploadedParts
+
+ where
+ checkAndUpload _ _ [] = return ()
+ checkAndUpload uid pmap (pn:pns) = do
+ payloadMay <- C.await
+ case payloadMay of
+ Nothing -> return ()
+ Just payload -> do partMay <- lift $ checkUploadNeeded payload pn pmap
+ pinfo <- maybe
+ (lift $ putObjectPart b o uid pn [] payload)
+ return partMay
+ C.yield pinfo
+ checkAndUpload uid pmap pns
+
+-- | Looks for incomplete uploads for an object. Returns the first one
+-- if there are many.
+getExistingUpload :: Bucket -> Object
+ -> Minio (Maybe UploadId, Map.Map PartNumber ListPartInfo)
+getExistingUpload b o = do
+ uidMay <- (fmap . fmap) uiUploadId $
+ listIncompleteUploads b (Just o) False C.$$ CC.head
+ parts <- maybe (return [])
+ (\uid -> listIncompleteParts b o uid C.$$ CC.sinkList) uidMay
+ return (uidMay, Map.fromList $ map (\p -> (piNumber p, p)) parts)
diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Minio/S3API.hs
@@ -0,0 +1,249 @@
+module Network.Minio.S3API
+ (
+ getLocation
+
+ -- * Listing buckets
+ --------------------
+ , getService
+
+ -- * Listing objects
+ --------------------
+ , listObjects'
+
+ -- * Retrieving objects
+ -----------------------
+ , getObject'
+
+ -- * Creating buckets and objects
+ ---------------------------------
+ , putBucket
+ , putObjectSingle
+
+ -- * Multipart Upload APIs
+ --------------------------
+ , newMultipartUpload
+ , putObjectPart
+ , completeMultipartUpload
+ , abortMultipartUpload
+ , listIncompleteUploads'
+ , listIncompleteParts'
+
+ -- * Deletion APIs
+ --------------------------
+ , deleteBucket
+ , deleteObject
+
+ ) where
+
+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 Lib.Prelude
+
+import Network.Minio.Data
+import Network.Minio.API
+import Network.Minio.Utils
+import Network.Minio.XmlParser
+import Network.Minio.XmlGenerator
+
+
+-- | Fetch all buckets from the service.
+getService :: Minio [BucketInfo]
+getService = do
+ resp <- executeRequest $ def
+ parseListBuckets $ NC.responseBody resp
+
+-- | Fetch bucket location (region)
+getLocation :: Bucket -> Minio Text
+getLocation bucket = do
+ resp <- executeRequest $ def { riBucket = Just bucket
+ , riQueryParams = [("location", Nothing)]
+ }
+ parseLocation $ NC.responseBody resp
+
+-- | 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)
+getObject' bucket object queryParams headers = do
+ resp <- mkStreamRequest reqInfo
+ return $ (NC.responseHeaders resp, NC.responseBody resp)
+ where
+ reqInfo = def { riBucket = Just bucket
+ , riObject = Just object
+ , riQueryParams = queryParams
+ , riHeaders = headers}
+
+-- | Creates a bucket via a PUT bucket call.
+putBucket :: Bucket -> Region -> Minio ()
+putBucket bucket location = do
+ void $ executeRequest $
+ def { riMethod = HT.methodPut
+ , riBucket = Just bucket
+ , riPayload = PayloadBS $ mkCreateBucketConfig location
+ }
+
+-- | Single PUT object size.
+maxSinglePutObjectSizeBytes :: Int64
+maxSinglePutObjectSizeBytes = 5 * 1024 * 1024 * 1024
+
+-- | 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
+ -> Int64 -> Minio ETag
+putObjectSingle bucket object headers h offset size = do
+ -- check length is within single PUT object size.
+ when (size > maxSinglePutObjectSizeBytes) $
+ throwM $ ValidationError $ 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 = PayloadH h offset size
+ }
+
+ let rheaders = NC.responseHeaders resp
+ etag = getETagHeader rheaders
+ maybe
+ (throwM $ ValidationError MErrVETagHeaderNotFound)
+ return etag
+
+
+
+-- | List objects in a bucket matching prefix up to delimiter,
+-- starting from nextToken.
+listObjects' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text
+ -> Minio ListObjectsResult
+listObjects' bucket prefix nextToken delimiter = do
+ resp <- executeRequest $ def { riMethod = HT.methodGet
+ , riBucket = Just bucket
+ , riQueryParams = mkOptionalParams params
+ }
+ parseListObjectsResponse $ NC.responseBody resp
+ where
+ params = [
+ ("list-type", Just "2")
+ , ("continuation_token", nextToken)
+ , ("prefix", prefix)
+ , ("delimiter", delimiter)
+ ]
+
+-- | DELETE a bucket from the service.
+deleteBucket :: Bucket -> Minio ()
+deleteBucket bucket = do
+ void $ executeRequest $
+ def { riMethod = HT.methodDelete
+ , riBucket = Just bucket
+ }
+
+-- | DELETE an object from the service.
+deleteObject :: Bucket -> Object -> Minio ()
+deleteObject bucket object = do
+ void $ executeRequest $
+ def { riMethod = HT.methodDelete
+ , riBucket = Just bucket
+ , riObject = Just object
+ }
+
+-- | Create a new multipart upload.
+newMultipartUpload :: Bucket -> Object -> [HT.Header] -> Minio UploadId
+newMultipartUpload bucket object headers = do
+ resp <- executeRequest $ def { riMethod = HT.methodPost
+ , riBucket = Just bucket
+ , riObject = Just object
+ , riQueryParams = [("uploads", Nothing)]
+ , riHeaders = headers
+ }
+ parseNewMultipartUpload $ NC.responseBody resp
+
+-- | PUT a part of an object as part of a multipart upload.
+putObjectPart :: Bucket -> Object -> UploadId -> PartNumber -> [HT.Header]
+ -> Payload -> Minio PartInfo
+putObjectPart bucket object uploadId partNumber headers payload = do
+ resp <- executeRequest $
+ def { riMethod = HT.methodPut
+ , riBucket = Just bucket
+ , riObject = Just object
+ , riQueryParams = mkOptionalParams params
+ , riHeaders = headers
+ , riPayload = payload
+ }
+ let rheaders = NC.responseHeaders resp
+ etag = getETagHeader rheaders
+ maybe
+ (throwM $ ValidationError MErrVETagHeaderNotFound)
+ (return . PartInfo partNumber) etag
+ where
+ params = [
+ ("uploadId", Just uploadId)
+ , ("partNumber", Just $ show partNumber)
+ ]
+
+-- | Complete a multipart upload.
+completeMultipartUpload :: Bucket -> Object -> UploadId -> [PartInfo]
+ -> Minio ETag
+completeMultipartUpload bucket object uploadId partInfo = do
+ resp <- executeRequest $
+ def { riMethod = HT.methodPost
+ , riBucket = Just bucket
+ , riObject = Just object
+ , riQueryParams = mkOptionalParams params
+ , riPayload = PayloadBS $
+ mkCompleteMultipartUploadRequest partInfo
+ }
+ parseCompleteMultipartUploadResponse $ NC.responseBody resp
+ where
+ params = [("uploadId", Just uploadId)]
+
+-- | Abort a multipart upload.
+abortMultipartUpload :: Bucket -> Object -> UploadId -> Minio ()
+abortMultipartUpload bucket object uploadId = do
+ void $ executeRequest $ def { riMethod = HT.methodDelete
+ , riBucket = Just bucket
+ , riObject = Just object
+ , riQueryParams = mkOptionalParams params
+ }
+ where
+ params = [("uploadId", Just uploadId)]
+
+-- | List incomplete multipart uploads.
+listIncompleteUploads' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text
+ -> Maybe Text -> Minio ListUploadsResult
+listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker = do
+ resp <- executeRequest $ def { riMethod = HT.methodGet
+ , riBucket = Just bucket
+ , riQueryParams = ("uploads", Nothing): mkOptionalParams params
+ }
+ parseListUploadsResponse $ NC.responseBody resp
+ where
+ -- build optional query params
+ params = [
+ ("prefix", prefix)
+ , ("delimiter", delimiter)
+ , ("key-marker", keyMarker)
+ , ("upload-id-marker", uploadIdMarker)
+ ]
+
+
+-- | List parts of an ongoing multipart upload.
+listIncompleteParts' :: Bucket -> Object -> UploadId -> Maybe Text
+ -> Maybe Text -> Minio ListPartsResult
+listIncompleteParts' bucket object uploadId maxParts partNumMarker = do
+ resp <- executeRequest $ def { riMethod = HT.methodGet
+ , riBucket = Just bucket
+ , riObject = Just object
+ , riQueryParams = mkOptionalParams params
+ }
+ parseListPartsResponse $ NC.responseBody resp
+ where
+ -- build optional query params
+ params = [
+ ("uploadId", Just uploadId)
+ , ("part-number-marker", partNumMarker)
+ , ("max-parts", maxParts)
+ ]
diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Minio/Sign/V4.hs
@@ -0,0 +1,157 @@
+module Network.Minio.Sign.V4
+ (
+ signV4
+ , signV4AtTime
+ , getScope
+ , getHeadersToSign
+ , getCanonicalRequest
+ , SignV4Data(..)
+ , debugPrintSignV4Data
+ ) where
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B8
+import Data.ByteString.Char8 (pack)
+import Data.CaseInsensitive (mk)
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Set as Set
+import qualified Data.Time as Time
+import Network.HTTP.Types (Header)
+
+import Lib.Prelude
+import Network.Minio.Data
+import Network.Minio.Data.ByteString
+import Network.Minio.Data.Crypto
+import Network.Minio.Data.Time
+
+ignoredHeaders :: Set ByteString
+ignoredHeaders = Set.fromList $ map CI.foldedCase [
+ mk "Authorization",
+ mk "Content-Type",
+ mk "Content-Length",
+ mk "User-Agent"
+ ]
+
+data SignV4Data = SignV4Data {
+ sv4SignTime :: UTCTime
+ , sv4Scope :: ByteString
+ , sv4CanonicalRequest :: ByteString
+ , sv4HeadersToSign :: [(ByteString, ByteString)]
+ , sv4InputHeaders :: [Header]
+ , sv4OutputHeaders :: [Header]
+ , sv4StringToSign :: ByteString
+ , sv4SigningKey :: ByteString
+ } deriving (Show)
+
+debugPrintSignV4Data :: SignV4Data -> IO ()
+debugPrintSignV4Data (SignV4Data t s cr h2s ih oh sts sk) = do
+ B8.putStrLn "SignV4Data:"
+ B8.putStr "Timestamp: " >> print t
+ B8.putStr "Scope: " >> B8.putStrLn s
+ B8.putStrLn "Canonical Request:"
+ B8.putStrLn cr
+ B8.putStr "Headers to Sign: " >> print h2s
+ B8.putStr "Input headers: " >> print ih
+ B8.putStr "Output headers: " >> print oh
+ B8.putStr "StringToSign: " >> B8.putStrLn sts
+ B8.putStr "SigningKey: " >> printBytes sk
+ B8.putStrLn "END of SignV4Data ========="
+ where
+ printBytes b = do
+ mapM_ (\x -> B.putStr $ B.concat [show x, " "]) $ B.unpack b
+ B8.putStrLn ""
+
+-- | Given MinioClient and request details, including request method,
+-- request path, headers, query params and payload hash, generates an
+-- updated set of headers, including the x-amz-date header and the
+-- Authorization header, which includes the signature.
+signV4 :: ConnectInfo -> RequestInfo
+ -> IO [Header]
+signV4 ci ri = do
+ timestamp <- Time.getCurrentTime
+ let signData = signV4AtTime timestamp ci ri
+ -- debugPrintSignV4Data signData
+ return $ sv4OutputHeaders signData
+
+-- | Takes a timestamp, server params and request params and generates
+-- an updated list of headers.
+signV4AtTime :: UTCTime -> ConnectInfo -> RequestInfo -> SignV4Data
+signV4AtTime ts ci ri =
+ SignV4Data ts scope canonicalRequest headersToSign (riHeaders ri) outHeaders stringToSign signingKey
+ where
+ outHeaders = authHeader : headersWithDate
+ timeBS = awsTimeFormatBS ts
+ dateHeader = (mk "X-Amz-Date", timeBS)
+ hostHeader = (mk "host", encodeUtf8 $ connectHost ci)
+
+ headersWithDate = dateHeader : hostHeader : (riHeaders ri)
+
+ authHeader = (mk "Authorization", authHeaderValue)
+
+ scope = getScope ts ri
+
+ authHeaderValue = B.concat [
+ "AWS4-HMAC-SHA256 Credential=",
+ encodeUtf8 (connectAccessKey ci), "/", scope,
+ ", SignedHeaders=", signedHeaders,
+ ", Signature=", signature
+ ]
+
+ headersToSign = getHeadersToSign headersWithDate
+
+ signedHeaders = B.intercalate ";" $ map fst headersToSign
+
+ signature = digestToBase16 $ hmacSHA256 stringToSign signingKey
+
+ signingKey = hmacSHA256RawBS "aws4_request"
+ . hmacSHA256RawBS "s3"
+ . hmacSHA256RawBS (encodeUtf8 $ getRegionFromRI ri)
+ . hmacSHA256RawBS (awsDateFormatBS ts)
+ $ (B.concat ["AWS4", encodeUtf8 $ connectSecretKey ci])
+
+ stringToSign = B.intercalate "\n" $
+ ["AWS4-HMAC-SHA256",
+ timeBS,
+ scope,
+ hashSHA256 $ canonicalRequest
+ ]
+
+ canonicalRequest = getCanonicalRequest ri headersToSign
+
+
+getScope :: UTCTime -> RequestInfo -> ByteString
+getScope ts ri = B.intercalate "/" $ [
+ pack $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts,
+ encodeUtf8 $ getRegionFromRI ri, "s3", "aws4_request"
+ ]
+
+getHeadersToSign :: [Header] -> [(ByteString, ByteString)]
+getHeadersToSign h =
+ sort $
+ filter (flip Set.notMember ignoredHeaders . fst) $
+ map (\(x, y) -> (CI.foldedCase x, stripBS y)) $
+ h
+
+getCanonicalRequest :: RequestInfo -> [(ByteString, ByteString)] -> ByteString
+getCanonicalRequest ri headersForSign = B.intercalate "\n" $ [
+ riMethod ri,
+ uriEncode False path,
+ canonicalQueryString,
+ canonicalHeaders,
+ signedHeaders,
+ riPayloadHash ri
+ ]
+ where
+ path = getPathFromRI ri
+
+ canonicalQueryString = B.intercalate "&" $
+ map (\(x, y) -> B.concat [x, "=", y]) $
+ sort $ map (\(x, y) ->
+ (uriEncode True x, maybe "" (uriEncode True) y)) $
+ riQueryParams ri
+
+ canonicalHeaders = B.concat $
+ map (\(x, y) -> B.concat [x, ":", y, "\n"]) $
+ headersForSign
+
+ signedHeaders = B.intercalate ";" $ map fst headersForSign
diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Minio/Utils.hs
@@ -0,0 +1,159 @@
+module Network.Minio.Utils where
+
+import qualified Control.Concurrent.Async.Lifted as A
+import qualified Control.Concurrent.QSem as Q
+import qualified Control.Exception.Lifted as ExL
+import qualified Control.Monad.Catch as MC
+import Control.Monad.Trans.Control (liftBaseOp_, StM)
+import qualified Control.Monad.Trans.Resource as R
+
+import qualified Data.ByteString as B
+import qualified Data.Conduit as C
+import Data.Text.Encoding.Error (lenientDecode)
+import qualified Network.HTTP.Client as NClient
+import Network.HTTP.Conduit (Response)
+import qualified Network.HTTP.Conduit as NC
+import qualified Network.HTTP.Types as HT
+import qualified System.IO as IO
+
+import Lib.Prelude
+
+import Network.Minio.Data
+
+allocateReadFile :: (R.MonadResource m, R.MonadResourceBase m)
+ => FilePath -> m (R.ReleaseKey, Handle)
+allocateReadFile fp = do
+ (rk, hdlE) <- R.allocate (openReadFile fp) cleanup
+ either (throwM . MEFile) (return . (rk,)) hdlE
+ where
+ openReadFile f = ExL.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)
+ => 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
+
+-- | Queries if handle is seekable. Catches any file operation
+-- exceptions and return False instead.
+isHandleSeekable :: (R.MonadResource m, R.MonadResourceBase m)
+ => Handle -> m Bool
+isHandleSeekable h = do
+ resE <- liftIO $ try $ IO.hIsSeekable h
+ case resE of
+ Left (_ :: IOException) -> return False
+ 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)
+ => FilePath -> (Handle -> m a) -> m (Either MError a)
+withNewHandle fp fileAction = do
+ -- opening a handle can throw MError exception.
+ handleE <- MC.try $ allocateReadFile fp
+ either (return . Left) doAction handleE
+ where
+ doAction (rkey, h) = do
+ -- fileAction may also throw MError exception, so we catch and
+ -- return it.
+ resE <- MC.try $ fileAction h
+ R.release rkey
+ return resE
+
+
+lookupHeader :: HT.HeaderName -> [HT.Header] -> Maybe ByteString
+lookupHeader hdr = headMay . map snd . filter (\(h, _) -> h == hdr)
+
+getETagHeader :: [HT.Header] -> Maybe Text
+getETagHeader hs = decodeUtf8Lenient <$> lookupHeader "ETag" hs
+
+decodeUtf8Lenient :: ByteString -> Text
+decodeUtf8Lenient = decodeUtf8With lenientDecode
+
+isSuccessStatus :: HT.Status -> Bool
+isSuccessStatus sts = let s = HT.statusCode sts
+ in (s >= 200 && s < 300)
+
+httpLbs :: (R.MonadThrow m, MonadIO m)
+ => NC.Request -> NC.Manager
+ -> m (NC.Response LByteString)
+httpLbs req mgr = do
+ respE <- liftIO $ tryHttpEx $ (NClient.httpLbs req mgr)
+ resp <- either throwM return respE
+ unless (isSuccessStatus $ NC.responseStatus resp) $
+ throwM $ ResponseError resp
+ return resp
+ where
+ tryHttpEx :: (IO (NC.Response LByteString))
+ -> IO (Either NC.HttpException (NC.Response LByteString))
+ tryHttpEx = try
+
+http :: (R.MonadResourceBase m, R.MonadResource m)
+ => NC.Request -> NC.Manager
+ -> m (Response (C.ResumableSource m ByteString))
+http req mgr = do
+ respE <- tryHttpEx $ NC.http req mgr
+ resp <- either throwM return respE
+ unless (isSuccessStatus $ NC.responseStatus resp) $ do
+ lbsResp <- NC.lbsResponse resp
+ throwM $ ResponseError lbsResp
+ return resp
+ where
+ tryHttpEx :: (R.MonadResourceBase m) => (m a)
+ -> m (Either NC.HttpException a)
+ tryHttpEx = ExL.try
+
+-- like mapConcurrently but with a limited number of concurrent
+-- threads.
+limitedMapConcurrently :: forall t a (m :: * -> *) b.
+ (MonadIO m, R.MonadBaseControl IO m,
+ StM m a ~ StM m b)
+ => Int -> (t -> m a) -> [t] -> m [b]
+limitedMapConcurrently count act args = do
+ qSem <- liftIO $ Q.newQSem count
+ threads <- workOn qSem args
+ mapM A.wait threads
+ where
+ workOn _ [] = return []
+ workOn qs (a:as) = liftBaseOp_
+ (bracket_ (Q.waitQSem qs) (Q.signalQSem qs)) $
+ do
+ thread <- A.async $ act a
+ others <- workOn qs as
+ return (thread : others)
+
+
+-- helper function to 'drop' empty optional parameter.
+mkQuery :: Text -> Maybe Text -> Maybe (Text, Text)
+mkQuery k mv = (k,) <$> mv
+
+-- helper function to build query parameters that are optional.
+-- don't use it with mandatory query params with empty value.
+mkOptionalParams :: [(Text, Maybe Text)] -> HT.Query
+mkOptionalParams params = HT.toQuery $ (uncurry mkQuery) <$> params
+
+chunkBSConduit :: (Monad m, Integral a)
+ => [a] -> C.Conduit ByteString m ByteString
+chunkBSConduit s = loop 0 [] s
+ where
+ loop _ _ [] = return ()
+ loop n readChunks (size:sizes) = do
+ bsMay <- C.await
+ case bsMay of
+ Nothing -> if n > 0
+ then C.yield $ B.concat readChunks
+ else return ()
+ Just bs -> if n + fromIntegral (B.length bs) >= size
+ then do let (a, b) = B.splitAt (fromIntegral $ size - n) bs
+ chunkBS = B.concat $ readChunks ++ [a]
+ C.yield chunkBS
+ loop (fromIntegral $ B.length b) [b] sizes
+ else loop (n + fromIntegral (B.length bs))
+ (readChunks ++ [bs]) (size:sizes)
diff --git a/src/Network/Minio/XmlGenerator.hs b/src/Network/Minio/XmlGenerator.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Minio/XmlGenerator.hs
@@ -0,0 +1,41 @@
+module Network.Minio.XmlGenerator
+ ( mkCreateBucketConfig
+ , mkCompleteMultipartUploadRequest
+ ) where
+
+
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Map as M
+import qualified Data.Text as T
+import Text.XML
+
+import Lib.Prelude
+
+import Network.Minio.Data
+
+
+-- | Create a bucketConfig request body XML
+mkCreateBucketConfig :: Region -> ByteString
+mkCreateBucketConfig location = LBS.toStrict $ renderLBS def bucketConfig
+ where
+ s3Element n = Element (s3Name n) M.empty
+ root = s3Element "CreateBucketConfiguration"
+ [ NodeElement $ s3Element "LocationConstraint"
+ [ NodeContent location]
+ ]
+ bucketConfig = Document (Prologue [] Nothing []) root []
+
+-- | Create a completeMultipartUpload request body XML
+mkCompleteMultipartUploadRequest :: [PartInfo] -> ByteString
+mkCompleteMultipartUploadRequest partInfo =
+ LBS.toStrict $ renderLBS def cmur
+ where
+ root = Element "CompleteMultipartUpload" M.empty $
+ map (NodeElement . mkPart) partInfo
+ mkPart (PartInfo n etag) = Element "Part" M.empty
+ [ NodeElement $ Element "PartNumber" M.empty
+ [NodeContent $ T.pack $ show n]
+ , NodeElement $ Element "ETag" M.empty
+ [NodeContent etag]
+ ]
+ cmur = Document (Prologue [] Nothing []) root []
diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Minio/XmlParser.hs
@@ -0,0 +1,154 @@
+module Network.Minio.XmlParser
+ ( parseListBuckets
+ , parseLocation
+ , parseNewMultipartUpload
+ , parseCompleteMultipartUploadResponse
+ , parseListObjectsResponse
+ , parseListUploadsResponse
+ , parseListPartsResponse
+ ) where
+
+import Control.Monad.Trans.Resource
+import Data.List (zip3, zip4)
+import qualified Data.Text as T
+import Data.Text.Read (decimal)
+import Data.Time
+import Text.XML
+import Text.XML.Cursor
+
+import Lib.Prelude
+
+import Network.Minio.Data
+
+
+-- | Helper functions.
+uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
+uncurry3 f (a, b, c) = f a b c
+
+uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
+uncurry4 f (a, b, c, d) = f a b c d
+
+-- | Represent the time format string returned by S3 API calls.
+s3TimeFormat :: [Char]
+s3TimeFormat = iso8601DateFormat $ Just "%T%QZ"
+
+-- | Parse time strings from XML
+parseS3XMLTime :: (MonadThrow m) => Text -> m UTCTime
+parseS3XMLTime = either (throwM . XMLParseError) return
+ . parseTimeM True defaultTimeLocale s3TimeFormat
+ . T.unpack
+
+parseDecimals :: (MonadThrow m, Integral a) => [Text] -> m [a]
+parseDecimals numStr = forM numStr $ \str ->
+ either (throwM . XMLParseError . show) return $ fst <$> decimal str
+
+s3Elem :: Text -> Axis
+s3Elem = element . s3Name
+
+parseRoot :: (MonadThrow m) => LByteString -> m Cursor
+parseRoot = either (throwM . XMLParseError . show) (return . fromDocument)
+ . parseLBS def
+
+-- | Parse the response XML of a list buckets call.
+parseListBuckets :: (MonadThrow m) => LByteString -> m [BucketInfo]
+parseListBuckets xmldata = do
+ r <- parseRoot xmldata
+ let
+ names = r $// s3Elem "Bucket" &// s3Elem "Name" &/ content
+ timeStrings = r $// s3Elem "Bucket" &// s3Elem "CreationDate" &/ content
+
+ times <- mapM parseS3XMLTime timeStrings
+ return $ map (\(n, t) -> BucketInfo n t) $ zip names times
+
+-- | Parse the response XML of a location request.
+parseLocation :: (MonadThrow m) => LByteString -> m Region
+parseLocation xmldata = do
+ r <- parseRoot xmldata
+ return $ T.concat $ r $/ content
+
+-- | Parse the response XML of an newMultipartUpload call.
+parseNewMultipartUpload :: (MonadThrow m)
+ => LByteString -> m UploadId
+parseNewMultipartUpload xmldata = do
+ r <- parseRoot xmldata
+ return $ T.concat $ r $// s3Elem "UploadId" &/ content
+
+-- | Parse the response XML of completeMultipartUpload call.
+parseCompleteMultipartUploadResponse :: (MonadThrow m)
+ => LByteString -> m ETag
+parseCompleteMultipartUploadResponse xmldata = do
+ r <- parseRoot xmldata
+ return $ T.concat $ r $// s3Elem "ETag" &/ content
+
+-- | Parse the response XML of a list objects call.
+parseListObjectsResponse :: (MonadThrow m)
+ => LByteString -> m ListObjectsResult
+parseListObjectsResponse xmldata = do
+ r <- parseRoot xmldata
+ let
+ hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content)
+
+ nextToken = headMay $ r $/ s3Elem "NextContinuationToken" &/ content
+
+ prefixes = r $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ content
+
+ keys = r $/ s3Elem "Contents" &/ s3Elem "Key" &/ content
+ modTimeStr = r $/ s3Elem "Contents" &/ s3Elem "LastModified" &/ content
+ etagsList = r $/ s3Elem "Contents" &/ s3Elem "ETag" &/ content
+ -- if response xml contains empty etag response fill them with as
+ -- many empty Text for the zip4 below to work as intended.
+ etags = etagsList ++ repeat ""
+ sizeStr = r $/ s3Elem "Contents" &/ s3Elem "Size" &/ content
+
+ modTimes <- mapM parseS3XMLTime modTimeStr
+ sizes <- parseDecimals sizeStr
+
+ let
+ objects = map (uncurry4 ObjectInfo) $ zip4 keys modTimes etags sizes
+
+ return $ ListObjectsResult hasMore nextToken objects prefixes
+
+-- | Parse the response XML of a list incomplete multipart upload call.
+parseListUploadsResponse :: (MonadThrow m)
+ => LByteString -> m ListUploadsResult
+parseListUploadsResponse xmldata = do
+ r <- parseRoot xmldata
+ let
+ hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content)
+ prefixes = r $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ content
+ nextKey = headMay $ r $/ s3Elem "NextKeyMarker" &/ content
+ nextUpload = headMay $ r $/ s3Elem "NextUploadIdMarker" &/ content
+ uploadKeys = r $/ s3Elem "Upload" &/ s3Elem "Key" &/ content
+ uploadIds = r $/ s3Elem "Upload" &/ s3Elem "UploadId" &/ content
+ uploadInitTimeStr = r $/ s3Elem "Upload" &/ s3Elem "Initiated" &/ content
+
+ uploadInitTimes <- mapM parseS3XMLTime uploadInitTimeStr
+
+ let
+ uploads = map (uncurry3 UploadInfo) $
+ zip3 uploadKeys uploadIds uploadInitTimes
+
+ return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes
+
+parseListPartsResponse :: (MonadThrow m)
+ => LByteString -> m ListPartsResult
+parseListPartsResponse xmldata = do
+ r <- parseRoot xmldata
+ let
+ hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content)
+ nextPartNumStr = headMay $ r $/ s3Elem "NextPartNumberMarker" &/ content
+ partNumberStr = r $/ s3Elem "Part" &/ s3Elem "PartNumber" &/ content
+ partModTimeStr = r $/ s3Elem "Part" &/ s3Elem "LastModified" &/ content
+ partETags = r $/ s3Elem "Part" &/ s3Elem "ETag" &/ content
+ partSizeStr = r $/ s3Elem "Part" &/ s3Elem "Size" &/ content
+
+ partModTimes <- mapM parseS3XMLTime partModTimeStr
+ partSizes <- parseDecimals partSizeStr
+ partNumbers <- parseDecimals partNumberStr
+ nextPartNum <- parseDecimals $ maybeToList nextPartNumStr
+
+ let
+ partInfos = map (uncurry4 ListPartInfo) $
+ zip4 partNumbers partETags partSizes partModTimes
+
+ return $ ListPartsResult hasMore (listToMaybe nextPartNum) partInfos
diff --git a/test/Network/Minio/XmlGenerator/Test.hs b/test/Network/Minio/XmlGenerator/Test.hs
new file mode 100644
--- /dev/null
+++ b/test/Network/Minio/XmlGenerator/Test.hs
@@ -0,0 +1,39 @@
+module Network.Minio.XmlGenerator.Test
+ ( xmlGeneratorTests
+ ) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Lib.Prelude
+
+import Network.Minio.XmlGenerator
+import Network.Minio.Data
+
+xmlGeneratorTests :: TestTree
+xmlGeneratorTests = testGroup "XML Generator Tests"
+ [ testCase "Test mkCreateBucketConfig" testMkCreateBucketConfig
+ , testCase "Test mkCompleteMultipartUploadRequest" testMkCompleteMultipartUploadRequest
+ ]
+
+testMkCreateBucketConfig :: Assertion
+testMkCreateBucketConfig = do
+ assertEqual "CreateBucketConfiguration xml should match: " expected $
+ mkCreateBucketConfig "EU"
+ where
+ expected = "\
+ \\
+ \EU\
+ \"
+
+testMkCompleteMultipartUploadRequest :: Assertion
+testMkCompleteMultipartUploadRequest =
+ assertEqual "completeMultipartUpload xml should match: " expected $
+ mkCompleteMultipartUploadRequest [PartInfo 1 "abc"]
+ where
+ expected = "\
+ \\
+ \\
+ \1abc\
+ \\
+ \"
diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs
new file mode 100644
--- /dev/null
+++ b/test/Network/Minio/XmlParser/Test.hs
@@ -0,0 +1,212 @@
+module Network.Minio.XmlParser.Test
+ (
+ xmlParserTests
+ ) where
+
+import qualified Control.Monad.Catch as MC
+import Data.Time (fromGregorian, UTCTime(..))
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Lib.Prelude
+
+import Network.Minio.Data
+import Network.Minio.XmlParser
+
+xmlParserTests :: TestTree
+xmlParserTests = testGroup "XML Parser Tests"
+ [ testCase "Test parseLocation" testParseLocation
+ , testCase "Test parseNewMultipartUpload" testParseNewMultipartUpload
+ , testCase "Test parseListObjectsResponse" testParseListObjectsResult
+ , testCase "Test parseListUploadsresponse" testParseListIncompleteUploads
+ , testCase "Test parseCompleteMultipartUploadResponse" testParseCompleteMultipartUploadResponse
+ , testCase "Test parseListPartsResponse" testParseListPartsResponse
+ ]
+
+tryMError :: (MC.MonadCatch m) => m a -> m (Either MError a)
+tryMError act = MC.try act
+
+assertMError :: MError -> Assertion
+assertMError e = assertFailure $ "Failed due to exception => " ++ show e
+
+eitherMError :: Either MError a -> (a -> Assertion) -> Assertion
+eitherMError (Left e) _ = assertMError e
+eitherMError (Right a) f = f a
+
+testParseLocation :: Assertion
+testParseLocation = do
+ -- 1. Test parsing of an invalid location constraint xml.
+ parseResE <- tryMError $ parseLocation "ClearlyInvalidXml"
+ when (isRight parseResE) $
+ assertFailure $ "Parsing should have failed => " ++ show parseResE
+
+ forM_ cases $ \(xmldata, expectedLocation) -> do
+ parseLocE <- tryMError $ parseLocation xmldata
+ either assertMError (@?= expectedLocation) parseLocE
+ where
+ cases = [
+ -- 2. Test parsing of a valid location xml.
+ ("\
+ \EU",
+ "EU"
+ )
+ ,
+ -- 3. Test parsing of a valid, empty location xml.
+ ("",
+ ""
+ )
+ ]
+
+
+testParseNewMultipartUpload :: Assertion
+testParseNewMultipartUpload = do
+ forM_ cases $ \(xmldata, expectedUploadId) -> do
+ parsedUploadIdE <- tryMError $ parseNewMultipartUpload xmldata
+ eitherMError parsedUploadIdE (@?= expectedUploadId)
+ where
+ cases = [
+ ("\
+ \\
+ \ example-bucket\
+ \ example-object\
+ \ VXBsb2FkIElEIGZvciA2aWWpbmcncyBteS1tb3ZpZS5tMnRzIHVwbG9hZA\
+ \",
+ "VXBsb2FkIElEIGZvciA2aWWpbmcncyBteS1tb3ZpZS5tMnRzIHVwbG9hZA"
+ ),
+ ("\
+ \\
+ \ example-bucket\
+ \ example-object\
+ \ EXAMPLEJZ6e0YupT2h66iePQCc9IEbYbDUy4RTpMeoSMLPRp8Z5o1u8feSRonpvnWsKKG35tI2LB9VDPiCgTy.Gq2VxQLYjrue4Nq.NBdqI-\
+ \",
+ "EXAMPLEJZ6e0YupT2h66iePQCc9IEbYbDUy4RTpMeoSMLPRp8Z5o1u8feSRonpvnWsKKG35tI2LB9VDPiCgTy.Gq2VxQLYjrue4Nq.NBdqI-"
+ )
+ ]
+
+testParseListObjectsResult :: Assertion
+testParseListObjectsResult = do
+ let
+ xmldata = "\
+ \\
+ \bucket\
+ \\
+ \205\
+ \1000\
+ \false\
+ \\
+ \my-image.jpg\
+ \2009-10-12T17:50:30.000Z\
+ \"fba9dede5f27731c9771645a39863328"\
+ \434234\
+ \STANDARD\
+ \\
+ \"
+
+ expectedListResult = ListObjectsResult False Nothing [object1] []
+ object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234
+ modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12
+
+ parsedListObjectsResult <- tryMError $ parseListObjectsResponse xmldata
+ eitherMError parsedListObjectsResult (@?= expectedListResult)
+
+testParseListIncompleteUploads :: Assertion
+testParseListIncompleteUploads = do
+ let
+ xmldata = "\
+ \example-bucket\
+ \\
+ \\
+ \sample.jpg\
+ \Xgw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1W99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--\
+ \/\
+ \\
+ \1000\
+ \false\
+ \\
+ \sample.jpg\
+ \Agw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1N99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--\
+ \\
+ \314133b66967d86f031c7249d1d9a80249109428335cd0ef1cdc487b4566cb1b\
+ \s3-nickname\
+ \\
+ \\
+ \314133b66967d86f031c7249d1d9a80249109428335cd0ef1cdc487b4566cb1b\
+ \s3-nickname\
+ \\
+ \STANDARD\
+ \2010-11-26T19:24:17.000Z\
+ \\
+ \\
+ \photos/\
+ \\
+ \\
+ \videos/\
+ \\
+ \"
+ expectedListResult = ListUploadsResult False (Just "sample.jpg") (Just "Xgw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1W99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--") uploads prefixes
+ uploads = [UploadInfo "sample.jpg" "Agw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1N99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--" initTime]
+ initTime = UTCTime (fromGregorian 2010 11 26) 69857
+ prefixes = ["photos/", "videos/"]
+
+ parsedListUploadsResult <- tryMError $ parseListUploadsResponse xmldata
+ eitherMError parsedListUploadsResult (@?= expectedListResult)
+
+
+testParseCompleteMultipartUploadResponse :: Assertion
+testParseCompleteMultipartUploadResponse = do
+ let
+ xmldata = "\
+\\
+ \http://Example-Bucket.s3.amazonaws.com/Example-Object\
+ \Example-Bucket\
+ \Example-Object\
+ \\"3858f62230ac3c915f300c664312c11f-9\"\
+\"
+ expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\""
+
+ parsedETagE <- runExceptT $ parseCompleteMultipartUploadResponse xmldata
+ eitherMError parsedETagE (@?= expectedETag)
+
+testParseListPartsResponse :: Assertion
+testParseListPartsResponse = do
+ let
+ xmldata = "\
+\\
+ \example-bucket\
+ \example-object\
+ \XXBsb2FkIElEIGZvciBlbHZpbmcncyVcdS1tb3ZpZS5tMnRzEEEwbG9hZA\
+ \\
+ \arn:aws:iam::111122223333:user/some-user-11116a31-17b5-4fb7-9df5-b288870f11xx\
+ \umat-user-11116a31-17b5-4fb7-9df5-b288870f11xx\
+ \\
+ \\
+ \75aa57f09aa0c8caeab4f8c24e99d10f8e7faeebf76c078efc7c6caea54ba06a\
+ \someName\
+ \\
+ \STANDARD\
+ \1\
+ \3\
+ \2\
+ \true\
+ \\
+ \2\
+ \2010-11-10T20:48:34.000Z\
+ \\"7778aef83f66abc1fa1e8477f296d394\"\
+ \10485760\
+ \\
+ \\
+ \3\
+ \2010-11-10T20:48:33.000Z\
+ \\"aaaa18db4cc2f85cedef654fccc4a4x8\"\
+ \10485760\
+ \\
+\"
+
+ expectedListResult = ListPartsResult True (Just 3) [part1, part2]
+ part1 = ListPartInfo 2 "\"7778aef83f66abc1fa1e8477f296d394\"" 10485760 modifiedTime1
+ modifiedTime1 = flip UTCTime 74914 $ fromGregorian 2010 11 10
+ part2 = ListPartInfo 3 "\"aaaa18db4cc2f85cedef654fccc4a4x8\"" 10485760 modifiedTime2
+ modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10
+
+ parsedListPartsResult <- runExceptT $ parseListPartsResponse xmldata
+ eitherMError parsedListPartsResult (@?= expectedListResult)
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,305 @@
+import Test.QuickCheck (generate)
+import qualified Test.QuickCheck as Q
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Lib.Prelude
+
+import System.Directory (getTemporaryDirectory)
+import qualified System.IO as SIO
+
+import qualified Control.Monad.Trans.Resource as R
+import qualified Data.ByteString as BS
+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.Text as T
+
+import Network.Minio
+import Network.Minio.Data
+import Network.Minio.S3API
+import Network.Minio.Utils
+import Network.Minio.XmlGenerator.Test
+import Network.Minio.XmlParser.Test
+
+main :: IO ()
+main = defaultMain tests
+
+tests :: TestTree
+tests = testGroup "Tests" [properties, unitTests, liveServerUnitTests]
+
+properties :: TestTree
+properties = testGroup "Properties" [] -- [scProps, qcProps]
+
+-- scProps = testGroup "(checked by SmallCheck)"
+-- [ SC.testProperty "sort == sort . reverse" $
+-- \list -> sort (list :: [Int]) == sort (reverse list)
+-- , SC.testProperty "Fermat's little theorem" $
+-- \x -> ((x :: Integer)^7 - x) `mod` 7 == 0
+-- -- the following property does not hold
+-- , SC.testProperty "Fermat's last theorem" $
+-- \x y z n ->
+-- (n :: Integer) >= 3 SC.==> x^n + y^n /= (z^n :: Integer)
+-- ]
+
+-- qcProps = testGroup "(checked by QuickCheck)"
+-- [ QC.testProperty "sort == sort . reverse" $
+-- \list -> sort (list :: [Int]) == sort (reverse list)
+-- , QC.testProperty "Fermat's little theorem" $
+-- \x -> ((x :: Integer)^7 - x) `mod` 7 == 0
+-- -- the following property does not hold
+-- , QC.testProperty "Fermat's last theorem" $
+-- \x y z n ->
+-- (n :: Integer) >= 3 QC.==> x^n + y^n /= (z^n :: Integer)
+-- ]
+
+-- conduit that generates random binary stream of given length
+randomDataSrc :: MonadIO m => Int64 -> C.Producer m ByteString
+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)
+
+ genBS s = do
+ w8s <- liftIO $ generate $ Q.vectorOf 64 (Q.choose (0, 255))
+ let byteArr64 = BS.pack w8s
+ if s < oneMiB
+ then yield $ concatIt byteArr64 s
+ else do yield $ concatIt byteArr64 oneMiB
+ genBS (s - oneMiB)
+
+mkRandFile :: R.MonadResource m => Int64 -> m FilePath
+mkRandFile size = do
+ dir <- liftIO $ getTemporaryDirectory
+ randomDataSrc size C.$$ CB.sinkTempFile dir "miniohstest.random"
+
+funTestBucketPrefix :: Text
+funTestBucketPrefix = "miniohstest-"
+
+funTestWithBucket :: TestName
+ -> (([Char] -> Minio ()) -> Bucket -> Minio ()) -> TestTree
+funTestWithBucket t minioTest = testCaseSteps t $ \step -> do
+ -- generate a random name for the bucket
+ bktSuffix <- liftIO $ generate $ Q.vectorOf 10 (Q.choose ('a', 'z'))
+ let b = T.concat [funTestBucketPrefix, T.pack bktSuffix]
+ liftStep = liftIO . step
+ ret <- runResourceT $ runMinio def $ do
+ liftStep $ "Creating bucket for test - " ++ t
+ putBucket b "us-east-1"
+ minioTest liftStep b
+ deleteBucket b
+ isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret)
+
+liveServerUnitTests :: TestTree
+liveServerUnitTests = testGroup "Unit tests against a live server"
+ [ funTestWithBucket "Basic tests" $ \step bucket -> do
+ step "getService works and contains the test bucket."
+ buckets <- getService
+ unless (length (filter (== bucket) $ map biName buckets) == 1) $
+ liftIO $
+ assertFailure ("The bucket " ++ show bucket ++
+ " was expected to exist.")
+
+ step "getLocation works"
+ region <- getLocation bucket
+ liftIO $ region == "" @? ("Got unexpected region => " ++ show region)
+
+ step "singlepart putObject works"
+ fPutObject bucket "lsb-release" "/etc/lsb-release"
+
+ outFile <- mkRandFile 0
+ step "simple getObject works"
+ fGetObject bucket "lsb-release" outFile
+
+ step "create new multipart upload works"
+ uid <- newMultipartUpload bucket "newmpupload" []
+ liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
+
+ step "abort a new multipart upload works"
+ abortMultipartUpload bucket "newmpupload" uid
+
+ step "delete object works"
+ deleteObject bucket "lsb-release"
+
+ , funTestWithBucket "Basic Multipart Test" $ \step bucket -> do
+ let object = "newmpupload"
+
+ step "create new multipart upload"
+ uid <- newMultipartUpload bucket object []
+ liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
+
+ let mb15 = 15 * 1024 * 1024
+ randFile <- mkRandFile mb15
+
+ step "put object parts 1 of 1"
+ h <- liftIO $ SIO.openBinaryFile randFile SIO.ReadMode
+ partInfo <- putObjectPart bucket object uid 1 [] $ PayloadH h 0 mb15
+
+ step "complete multipart"
+ void $ completeMultipartUpload bucket object uid [partInfo]
+
+ destFile <- mkRandFile 0
+ step $ "Retrieve the created object and check size"
+ fGetObject bucket object destFile
+ gotSize <- withNewHandle destFile getFileSize
+ liftIO $ gotSize == Right (Just mb15) @?
+ "Wrong file size of put file after getting"
+
+ step $ "Cleanup actions"
+ deleteObject bucket object
+
+ , funTestWithBucket "Multipart test with unknown object size" $
+ \step bucket -> do
+ let obj = "mpart"
+
+ step "Prepare"
+ let mb100 = 100 * 1024 * 1024
+ rFile <- mkRandFile mb100
+
+ step "Upload multipart file."
+ putObjectFromSource bucket obj (CB.sourceFile rFile) Nothing
+
+ step "Retrieve and verify file size"
+ destFile <- mkRandFile 0
+ fGetObject bucket obj destFile
+ gotSize <- withNewHandle destFile getFileSize
+ liftIO $ gotSize == Right (Just mb100) @?
+ "Wrong file size of put file after getting"
+
+ step $ "Cleanup actions"
+ deleteObject bucket obj
+
+ , funTestWithBucket "Multipart test with non-seekable file" $
+ \step bucket -> do
+ let obj = "mpart"
+ mb100 = 100 * 1024 * 1024
+
+ step "Upload multipart file."
+ void $ putObject bucket obj $ ODFile "/dev/zero" (Just mb100)
+
+ step "Retrieve and verify file size"
+ destFile <- mkRandFile 0
+ fGetObject bucket obj destFile
+ gotSize <- withNewHandle destFile getFileSize
+ liftIO $ gotSize == Right (Just mb100) @?
+ "Wrong file size of put file after getting"
+
+ step $ "Cleanup actions"
+ deleteObject bucket obj
+
+ , funTestWithBucket "Basic listObjects Test" $ \step bucket -> do
+ step "put 10 objects"
+ forM_ [1..10::Int] $ \s ->
+ fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release"
+
+ step "Simple list"
+ res <- listObjects' bucket 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)
+
+ step "Cleanup actions"
+ forM_ [1..10::Int] $ \s -> deleteObject bucket (T.concat ["lsb-release", T.pack (show s)])
+
+ , funTestWithBucket "Basic listMultipartUploads Test" $ \step bucket -> do
+ let object = "newmpupload"
+ step "create 10 multipart uploads"
+ forM_ [1..10::Int] $ \_ -> do
+ uid <- newMultipartUpload bucket object []
+ liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
+
+ step "list incomplete multipart uploads"
+ incompleteUploads <- listIncompleteUploads' bucket Nothing Nothing Nothing Nothing
+ liftIO $ (length $ lurUploads incompleteUploads) @?= 10
+
+ , funTestWithBucket "multipart" $ \step bucket -> do
+
+ step "upload large object"
+ void $ putObject bucket "big" (ODFile "/dev/zero" $ Just $ 1024*1024*100)
+
+ step "cleanup"
+ deleteObject bucket "big"
+
+ , funTestWithBucket "Basic listIncompleteParts Test" $ \step bucket -> do
+ let
+ object = "newmpupload"
+ mb15 = 15 * 1024 * 1024
+
+ step "create a multipart upload"
+ uid <- newMultipartUpload bucket object []
+ liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
+
+ step "put object parts 1..10"
+ inputFile <- mkRandFile mb15
+ h <- liftIO $ SIO.openBinaryFile inputFile SIO.ReadMode
+ forM_ [1..10] $ \pnum ->
+ putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb15
+
+ step "fetch list parts"
+ listPartsResult <- listIncompleteParts' bucket object uid Nothing Nothing
+ liftIO $ (length $ lprParts listPartsResult) @?= 10
+
+ , funTestWithBucket "High-level listObjects Test" $ \step bucket -> do
+ step "put 3 objects"
+ let expected = [
+ "dir/o1"
+ , "dir/dir1/o2"
+ , "dir/dir2/o3"
+ ]
+ forM_ expected $
+ \obj -> fPutObject bucket obj "/etc/lsb-release"
+
+ step "High-level listing of objects"
+ objects <- (listObjects bucket Nothing True) $$ sinkList
+
+ liftIO $ assertEqual "Objects match failed!" (sort expected)
+ (map oiObject objects)
+
+ step "Cleanup actions"
+ forM_ expected $
+ \obj -> deleteObject bucket obj
+
+ , funTestWithBucket "High-level listIncompleteUploads Test" $ \step bucket -> do
+ let object = "newmpupload"
+ step "create 10 multipart uploads"
+ forM_ [1..10::Int] $ \_ -> do
+ uid <- newMultipartUpload bucket object []
+ liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
+
+ step "High-level listing of incomplete multipart uploads"
+ uploads <- (listIncompleteUploads bucket Nothing True) $$ sinkList
+
+ liftIO $ (length uploads) @?= 10
+
+ , funTestWithBucket "High-level listIncompleteParts Test" $ \step bucket -> do
+ let
+ object = "newmpupload"
+ mb15 = 15 * 1024 * 1024
+
+ step "create a multipart upload"
+ uid <- newMultipartUpload bucket object []
+ liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
+
+ step "put object parts 1..10"
+ inputFile <- mkRandFile mb15
+ h <- liftIO $ SIO.openBinaryFile inputFile SIO.ReadMode
+ forM_ [1..10] $ \pnum ->
+ putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb15
+
+ step "fetch list parts"
+ incompleteParts <- (listIncompleteParts bucket object uid) $$ sinkList
+ liftIO $ (length incompleteParts) @?= 10
+
+ ]
+
+unitTests :: TestTree
+unitTests = testGroup "Unit tests" [xmlGeneratorTests, xmlParserTests]