minio-hs (empty) → 0.0.1
raw patch · 20 files changed
+2474/−0 lines, 20 filesdep +QuickCheckdep +asyncdep +basesetup-changed
Dependencies added: QuickCheck, async, base, 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, minio-hs, monad-control, protolude, resourcet, tasty, tasty-hunit, tasty-quickcheck, tasty-smallcheck, temporary, text, time, transformers, transformers-base, xml-conduit
Files
- LICENSE +202/−0
- Setup.hs +2/−0
- minio-hs.cabal +143/−0
- src/Lib/Prelude.hs +16/−0
- src/Network/Minio.hs +89/−0
- src/Network/Minio/API.hs +77/−0
- src/Network/Minio/Data.hs +248/−0
- src/Network/Minio/Data/ByteString.hs +58/−0
- src/Network/Minio/Data/Crypto.hs +58/−0
- src/Network/Minio/Data/Time.hs +29/−0
- src/Network/Minio/ListOps.hs +56/−0
- src/Network/Minio/PutObject.hs +180/−0
- src/Network/Minio/S3API.hs +249/−0
- src/Network/Minio/Sign/V4.hs +157/−0
- src/Network/Minio/Utils.hs +159/−0
- src/Network/Minio/XmlGenerator.hs +41/−0
- src/Network/Minio/XmlParser.hs +154/−0
- test/Network/Minio/XmlGenerator/Test.hs +39/−0
- test/Network/Minio/XmlParser/Test.hs +212/−0
- test/Spec.hs +305/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ minio-hs.cabal view
@@ -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
+ src/Lib/Prelude.hs view
@@ -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)
+ src/Network/Minio.hs view
@@ -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 [] []
+ src/Network/Minio/API.hs view
@@ -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
+ src/Network/Minio/Data.hs view
@@ -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
+ src/Network/Minio/Data/ByteString.hs view
@@ -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)
+ src/Network/Minio/Data/Crypto.hs view
@@ -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
+ src/Network/Minio/Data/Time.hs view
@@ -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"
+ src/Network/Minio/ListOps.hs view
@@ -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)
+ src/Network/Minio/PutObject.hs view
@@ -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)
+ src/Network/Minio/S3API.hs view
@@ -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)+ ]
+ src/Network/Minio/Sign/V4.hs view
@@ -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
+ src/Network/Minio/Utils.hs view
@@ -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)
+ src/Network/Minio/XmlGenerator.hs view
@@ -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 []
+ src/Network/Minio/XmlParser.hs view
@@ -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
+ test/Network/Minio/XmlGenerator/Test.hs view
@@ -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 = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\+ \<CreateBucketConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+ \<LocationConstraint>EU</LocationConstraint>\+ \</CreateBucketConfiguration>"++testMkCompleteMultipartUploadRequest :: Assertion+testMkCompleteMultipartUploadRequest =+ assertEqual "completeMultipartUpload xml should match: " expected $+ mkCompleteMultipartUploadRequest [PartInfo 1 "abc"]+ where+ expected = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\+ \<CompleteMultipartUpload>\+ \<Part>\+ \<PartNumber>1</PartNumber><ETag>abc</ETag>\+ \</Part>\+ \</CompleteMultipartUpload>"
+ test/Network/Minio/XmlParser/Test.hs view
@@ -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.+ ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\+ \<LocationConstraint xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">EU</LocationConstraint>",+ "EU"+ )+ ,+ -- 3. Test parsing of a valid, empty location xml.+ ("<LocationConstraint xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"/>",+ ""+ )+ ]+++testParseNewMultipartUpload :: Assertion+testParseNewMultipartUpload = do+ forM_ cases $ \(xmldata, expectedUploadId) -> do+ parsedUploadIdE <- tryMError $ parseNewMultipartUpload xmldata+ eitherMError parsedUploadIdE (@?= expectedUploadId)+ where+ cases = [+ ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\+ \<InitiateMultipartUploadResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+ \ <Bucket>example-bucket</Bucket>\+ \ <Key>example-object</Key>\+ \ <UploadId>VXBsb2FkIElEIGZvciA2aWWpbmcncyBteS1tb3ZpZS5tMnRzIHVwbG9hZA</UploadId>\+ \</InitiateMultipartUploadResult>",+ "VXBsb2FkIElEIGZvciA2aWWpbmcncyBteS1tb3ZpZS5tMnRzIHVwbG9hZA"+ ),+ ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\+ \<InitiateMultipartUploadResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+ \ <Bucket>example-bucket</Bucket>\+ \ <Key>example-object</Key>\+ \ <UploadId>EXAMPLEJZ6e0YupT2h66iePQCc9IEbYbDUy4RTpMeoSMLPRp8Z5o1u8feSRonpvnWsKKG35tI2LB9VDPiCgTy.Gq2VxQLYjrue4Nq.NBdqI-</UploadId>\+ \</InitiateMultipartUploadResult>",+ "EXAMPLEJZ6e0YupT2h66iePQCc9IEbYbDUy4RTpMeoSMLPRp8Z5o1u8feSRonpvnWsKKG35tI2LB9VDPiCgTy.Gq2VxQLYjrue4Nq.NBdqI-"+ )+ ]++testParseListObjectsResult :: Assertion+testParseListObjectsResult = do+ let+ xmldata = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\+ \<ListBucketResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+ \<Name>bucket</Name>\+ \<Prefix/>\+ \<KeyCount>205</KeyCount>\+ \<MaxKeys>1000</MaxKeys>\+ \<IsTruncated>false</IsTruncated>\+ \<Contents>\+ \<Key>my-image.jpg</Key>\+ \<LastModified>2009-10-12T17:50:30.000Z</LastModified>\+ \<ETag>"fba9dede5f27731c9771645a39863328"</ETag>\+ \<Size>434234</Size>\+ \<StorageClass>STANDARD</StorageClass>\+ \</Contents>\+ \</ListBucketResult>"++ 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 = "<ListMultipartUploadsResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+ \<Bucket>example-bucket</Bucket>\+ \<KeyMarker/>\+ \<UploadIdMarker/>\+ \<NextKeyMarker>sample.jpg</NextKeyMarker>\+ \<NextUploadIdMarker>Xgw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1W99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--</NextUploadIdMarker>\+ \<Delimiter>/</Delimiter>\+ \<Prefix/>\+ \<MaxUploads>1000</MaxUploads>\+ \<IsTruncated>false</IsTruncated>\+ \<Upload>\+ \<Key>sample.jpg</Key>\+ \<UploadId>Agw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1N99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--</UploadId>\+ \<Initiator>\+ \<ID>314133b66967d86f031c7249d1d9a80249109428335cd0ef1cdc487b4566cb1b</ID>\+ \<DisplayName>s3-nickname</DisplayName>\+ \</Initiator>\+ \<Owner>\+ \<ID>314133b66967d86f031c7249d1d9a80249109428335cd0ef1cdc487b4566cb1b</ID>\+ \<DisplayName>s3-nickname</DisplayName>\+ \</Owner>\+ \<StorageClass>STANDARD</StorageClass>\+ \<Initiated>2010-11-26T19:24:17.000Z</Initiated>\+ \</Upload>\+ \<CommonPrefixes>\+ \<Prefix>photos/</Prefix>\+ \</CommonPrefixes>\+ \<CommonPrefixes>\+ \<Prefix>videos/</Prefix>\+ \</CommonPrefixes>\+ \</ListMultipartUploadsResult>"+ 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 = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\+\<CompleteMultipartUploadResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+ \<Location>http://Example-Bucket.s3.amazonaws.com/Example-Object</Location>\+ \<Bucket>Example-Bucket</Bucket>\+ \<Key>Example-Object</Key>\+ \<ETag>\"3858f62230ac3c915f300c664312c11f-9\"</ETag>\+\</CompleteMultipartUploadResult>"+ expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\""++ parsedETagE <- runExceptT $ parseCompleteMultipartUploadResponse xmldata+ eitherMError parsedETagE (@?= expectedETag)++testParseListPartsResponse :: Assertion+testParseListPartsResponse = do+ let+ xmldata = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\+\<ListPartsResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+ \<Bucket>example-bucket</Bucket>\+ \<Key>example-object</Key>\+ \<UploadId>XXBsb2FkIElEIGZvciBlbHZpbmcncyVcdS1tb3ZpZS5tMnRzEEEwbG9hZA</UploadId>\+ \<Initiator>\+ \<ID>arn:aws:iam::111122223333:user/some-user-11116a31-17b5-4fb7-9df5-b288870f11xx</ID>\+ \<DisplayName>umat-user-11116a31-17b5-4fb7-9df5-b288870f11xx</DisplayName>\+ \</Initiator>\+ \<Owner>\+ \<ID>75aa57f09aa0c8caeab4f8c24e99d10f8e7faeebf76c078efc7c6caea54ba06a</ID>\+ \<DisplayName>someName</DisplayName>\+ \</Owner>\+ \<StorageClass>STANDARD</StorageClass>\+ \<PartNumberMarker>1</PartNumberMarker>\+ \<NextPartNumberMarker>3</NextPartNumberMarker>\+ \<MaxParts>2</MaxParts>\+ \<IsTruncated>true</IsTruncated>\+ \<Part>\+ \<PartNumber>2</PartNumber>\+ \<LastModified>2010-11-10T20:48:34.000Z</LastModified>\+ \<ETag>\"7778aef83f66abc1fa1e8477f296d394\"</ETag>\+ \<Size>10485760</Size>\+ \</Part>\+ \<Part>\+ \<PartNumber>3</PartNumber>\+ \<LastModified>2010-11-10T20:48:33.000Z</LastModified>\+ \<ETag>\"aaaa18db4cc2f85cedef654fccc4a4x8\"</ETag>\+ \<Size>10485760</Size>\+ \</Part>\+\</ListPartsResult>"++ 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)
+ test/Spec.hs view
@@ -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]