packages feed

minio-hs 0.1.0 → 0.2.0

raw patch · 22 files changed

+1535/−501 lines, 22 filesdep +text-formatdep ~basedep ~http-conduitsetup-changednew-uploader

Dependencies added: text-format

Dependency ranges changed: base, http-conduit

Files

LICENSE view
@@ -1,4 +1,3 @@-                                  Apache License                            Version 2.0, January 2004                         http://www.apache.org/licenses/@@ -179,7 +178,7 @@    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 "[]"+      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@@ -187,7 +186,7 @@       same "printed page" as the copyright notice for easier       identification within third-party archives. -   Copyright [yyyy] [name of copyright owner]+   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.
Setup.hs view
@@ -1,2 +1,18 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ import Distribution.Simple main = defaultMain
minio-hs.cabal view
@@ -1,14 +1,17 @@ name:                minio-hs-version:             0.1.0+version:             0.2.0 synopsis:            A Minio client library, compatible with S3 like services.-description:         Please see README.md-homepage:            https://github.com/donatello/minio-hs#readme+description:         minio-hs provides simple APIs to access Minio and Amazon+                     S3 compatible object storage server. For more details,+                     please see README.md.+homepage:            https://github.com/minio/minio-hs#readme license:             Apache-2.0 license-file:        LICENSE author:              Aditya Manthramurthy, Krishnan Parthasarathi-maintainer:          aditya.mmy@gmail.com+maintainer:          dev@minio.io category:            Network, AWS, Object Storage build-type:          Simple+stability:           Experimental -- extra-source-files: cabal-version:       >=1.10 @@ -23,6 +26,7 @@                      , Network.Minio.Data.ByteString                      , Network.Minio.Data.Crypto                      , Network.Minio.Data.Time+                     , Network.Minio.Errors                      , Network.Minio.ListOps                      , Network.Minio.PutObject                      , Network.Minio.Sign.V4@@ -52,6 +56,7 @@                      , monad-control                      , resourcet                      , text+                     , text-format                      , time                      , transformers                      , transformers-base@@ -68,6 +73,82 @@                      , TypeFamilies                      , TupleSections +Flag live-test+  Default: True+  Manual: True++test-suite minio-hs-live-server-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test, src+  main-is:             LiveServer.hs+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N+  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.Errors+                     , 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+  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+                     , text-format+                     , time+                     , transformers+                     , transformers-base+                     , xml-conduit+  if !flag(live-test)+    buildable: False+ test-suite minio-hs-test   type:                exitcode-stdio-1.0   hs-source-dirs:      test, src@@ -103,6 +184,7 @@                      , tasty-smallcheck                      , temporary                      , text+                     , text-format                      , time                      , transformers                      , transformers-base@@ -127,6 +209,7 @@                      , Network.Minio.Data.ByteString                      , Network.Minio.Data.Crypto                      , Network.Minio.Data.Time+                     , Network.Minio.Errors                      , Network.Minio.ListOps                      , Network.Minio.PutObject                      , Network.Minio.S3API@@ -140,4 +223,4 @@  source-repository head   type:     git-  location: https://github.com/donatello/minio-hs+  location: https://github.com/minio/minio-hs
src/Lib/Prelude.hs view
@@ -1,3 +1,19 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ {- Welcome to your custom Prelude Export here everything that should always be in your library scope@@ -6,11 +22,28 @@ -} module Lib.Prelude     ( module Exports+    , both++    , format     ) where -import Protolude as Exports+import           Protolude as Exports -import Data.Time as Exports (UTCTime)-import Control.Monad.Trans.Maybe as Exports (runMaybeT, MaybeT(..))+import           Data.Time as Exports (UTCTime(..), diffUTCTime)+import           Control.Monad.Trans.Maybe as Exports (runMaybeT, MaybeT(..)) -import Control.Monad.Catch as Exports (throwM, MonadThrow, MonadCatch)+import           Control.Monad.Catch as Exports (throwM, MonadThrow, MonadCatch)++import           Data.Text.Format as Exports (Shown(..))+import qualified Data.Text.Format as TF+import           Data.Text.Format.Params (Params)+import qualified Data.Text.Lazy as LT++format :: Params ps => TF.Format -> ps -> Text+format f args = LT.toStrict $ TF.format f args++-- import Data.Tuple as Exports (uncurry)++-- | Apply a function on both elements of a pair+both :: (a -> b) -> (a, a) -> (b, b)+both f (a, b) = (f a, f b)
src/Network/Minio.hs view
@@ -1,13 +1,32 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ module Network.Minio   (      ConnectInfo(..)   , awsCI+  , awsWithRegionCI   , minioPlayCI+  , minioCI    , Minio   , runMinio   , runResourceT+  , def    -- * Error handling   -----------------------@@ -15,7 +34,7 @@   -- with an object storage service.   , MinioErr(..)   , MErrV(..)-  , MError(..)+  , ServiceErr(..)    -- * Data Types   ----------------@@ -25,25 +44,28 @@   , BucketInfo(..)   , ObjectInfo(..)   , UploadInfo(..)-  , ListPartInfo(..)+  , ObjectPartInfo(..)   , UploadId   , ObjectData(..)+  , CopyPartSource(..)    -- * Bucket Operations   -----------------------  , getService+  , listBuckets   , getLocation   , makeBucket+  , removeBucket    , listObjects   , listIncompleteUploads-  , listIncompleteParts    -- * Object Operations   ----------------------   , fGetObject   , fPutObject-  , putObjectFromSource+  , putObject+  , copyObject+  , removeObject    , getObject   , statObject@@ -57,14 +79,21 @@ import           Control.Monad.Trans.Resource (runResourceT) import qualified Data.Conduit as C import qualified Data.Conduit.Binary as CB+import           Data.Default (def)+import qualified Data.Map as Map  import           Lib.Prelude  import           Network.Minio.Data+import           Network.Minio.Errors import           Network.Minio.ListOps import           Network.Minio.PutObject import           Network.Minio.S3API +-- | Lists buckets.+listBuckets :: Minio [BucketInfo]+listBuckets = getService+ -- | 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.@@ -75,23 +104,37 @@  -- | Upload the given file to the given object. fPutObject :: Bucket -> Object -> FilePath -> Minio ()-fPutObject bucket object f = void $ putObject bucket object $+fPutObject bucket object f = void $ putObjectInternal 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+-- known; this helps the library select optimal part sizes to perform+-- a multipart upload. If not specified, it is assumed that the object+-- can be potentially 5TiB and selects multipart sizes appropriately.+putObject :: Bucket -> Object -> C.Producer Minio ByteString+          -> Maybe Int64 -> Minio ()+putObject bucket object src sizeMay =+  void $ putObjectInternal bucket object $ ODStream src sizeMay +-- | Perform a server-side copy operation to create an object with the+-- given bucket and object name from the source specification in+-- CopyPartSource. This function performs a multipart copy operation+-- if the new object is to be greater than 5GiB in size.+copyObject :: Bucket -> Object -> CopyPartSource -> Minio ()+copyObject bucket object cps = void $ copyObjectInternal bucket object cps++-- | Remove an object from the object store.+removeObject :: Bucket -> Object -> Minio ()+removeObject = deleteObject+ -- | Get an object from the object store as a resumable source (conduit). getObject :: Bucket -> Object -> Minio (C.ResumableSource Minio ByteString) getObject bucket object = snd <$> getObject' bucket object [] [] +-- | Get an object's metadata from the object store.+statObject :: Bucket -> Object -> Minio ObjectInfo+statObject bucket object = headObject bucket object+ -- | Creates a new bucket in the object store. The Region can be -- optionally specified. If not specified, it will use the region -- configured in ConnectInfo, which is by default, the US Standard@@ -100,7 +143,9 @@ makeBucket bucket regionMay= do   region <- maybe (asks $ connectRegion . mcConnInfo) return regionMay   putBucket bucket region+  modify (Map.insert bucket region) --- | Get an object's metadata from the object store.-statObject :: Bucket -> Object -> Minio ObjectInfo-statObject bucket object = headObject bucket object+removeBucket :: Bucket -> Minio ()+removeBucket bucket = do+  deleteBucket bucket+  modify (Map.delete bucket)
src/Network/Minio/API.hs view
@@ -1,3 +1,19 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ module Network.Minio.API   (     connect@@ -5,10 +21,14 @@   , runMinio   , executeRequest   , mkStreamRequest+  , getLocation   ) where  import qualified Data.Conduit as C import           Data.Conduit.Binary (sourceHandleRange)+import           Data.Default (def)+import qualified Data.Map as Map+import qualified Data.Text as T import           Network.HTTP.Conduit (Response) import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Types as HT@@ -17,8 +37,10 @@  import           Network.Minio.Data import           Network.Minio.Data.Crypto+import           Network.Minio.Errors import           Network.Minio.Sign.V4 import           Network.Minio.Utils+import           Network.Minio.XmlParser  sha256Header :: ByteString -> HT.Header sha256Header = ("x-amz-content-sha256", )@@ -38,24 +60,76 @@       (return . fromIntegral $ off)       (return . fromIntegral $ size) -buildRequest :: (MonadIO m, MonadReader MinioConn m)-             => RequestInfo -> m NC.Request++-- | Fetch bucket location (region)+getLocation :: Bucket -> Minio Region+getLocation bucket = do+  resp <- executeRequest $ def {+      riBucket = Just bucket+    , riQueryParams = [("location", Nothing)]+    , riNeedsLocation = False+    }+  parseLocation $ NC.responseBody resp+++-- | Looks for region in RegionMap and updates it using getLocation if+-- absent.+discoverRegion :: RequestInfo -> Minio (Maybe Region)+discoverRegion ri = runMaybeT $ do+  bucket <- MaybeT $ return $ riBucket ri+  regionMay <- gets (Map.lookup bucket)+  maybe (do+            l <- lift $ getLocation bucket+            modify $ Map.insert bucket l+            return l+        ) return regionMay+++buildRequest :: RequestInfo -> Minio NC.Request buildRequest ri = do-  sha256Hash <- getPayloadSHA256Hash (riPayload ri)-  let newRi = ri {-          riPayloadHash = sha256Hash-        , riHeaders = sha256Header sha256Hash : (riHeaders ri)-        }+  {-+    If ListBuckets/MakeBucket/GetLocation then use connectRegion ci+    Else If discovery off use connectRegion ci+    Else { +    // Here discovery is on+    Lookup region in regionMap+    If present use that+    Else getLocation+    }+  -}   ci <- asks mcConnInfo+  region <- if | not $ riNeedsLocation ri -> -- getService/makeBucket/getLocation+                                             -- don't need location+                   return $ Just $ connectRegion ci+               | not $ connectAutoDiscoverRegion ci -> -- if autodiscovery of location is disabled by user+                   return $ Just $ connectRegion ci+               | otherwise -> discoverRegion ri -  reqHeaders <- liftIO $ signV4 ci newRi+  regionHost <- case region of+    Nothing ->  return $ connectHost ci+    Just r -> if "amazonaws.com" `T.isSuffixOf` (connectHost ci)+              then maybe+                   (throwM $ MErrVRegionNotSupported r)+                   return+                   (Map.lookup r awsRegionMap)+              else return $ connectHost ci ++  sha256Hash <- getPayloadSHA256Hash (riPayload ri)+  let newRi = ri { riPayloadHash = sha256Hash+                 , riHeaders = sha256Header sha256Hash : (riHeaders ri)+                 , riRegion = region+                 }+      newCi = ci { connectHost = regionHost }++  reqHeaders <- liftIO $ signV4 newCi newRi+   return NC.defaultRequest {       NC.method = riMethod newRi-    , NC.secure = connectIsSecure ci-    , NC.host = encodeUtf8 $ connectHost ci-    , NC.port = connectPort ci+    , NC.secure = connectIsSecure newCi+    , NC.host = encodeUtf8 $ connectHost newCi+    , NC.port = connectPort newCi     , NC.path = getPathFromRI newRi     , NC.queryString = HT.renderQuery False $ riQueryParams newRi     , NC.requestHeaders = reqHeaders
src/Network/Minio/Data.hs view
@@ -1,3 +1,19 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} module Network.Minio.Data where @@ -5,18 +21,47 @@ 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 Data.Map as Map+import qualified Data.Text as T+import           Data.Time (formatTime, defaultTimeLocale)+import           Network.HTTP.Client (defaultManagerSettings) import qualified Network.HTTP.Conduit as NC import           Network.HTTP.Types (Method, Header, Query) import qualified Network.HTTP.Types as HT+import           Network.Minio.Errors import           Text.XML  import           Lib.Prelude --- | Connection Info data type. Use the Default instance to create--- connection info for your service.++-- TODO: Add a type which provides typed constants for region.  this+-- type should have a IsString instance to infer the appropriate+-- constant.+-- | awsRegionMap - library constant+awsRegionMap :: Map.Map Text Text+awsRegionMap = Map.fromList [+      ("us-east-1", "s3.amazonaws.com")+    , ("us-east-2", "s3-us-east-2.amazonaws.com")+    , ("us-west-1", "s3-us-west-1.amazonaws.com")+    , ("us-east-2", "s3-us-west-2.amazonaws.com")+    , ("ca-central-1", "s3-ca-central-1.amazonaws.com")+    , ("ap-south-1", "s3-ap-south-1.amazonaws.com")+    , ("ap-northeast-1", "s3-ap-northeast-1.amazonaws.com")+    , ("ap-northeast-2", "s3-ap-northeast-2.amazonaws.com")+    , ("ap-southeast-1", "s3-ap-southeast-1.amazonaws.com")+    , ("ap-southeast-2", "s3-ap-southeast-2.amazonaws.com")+    , ("eu-west-1", "s3-eu-west-1.amazonaws.com")+    , ("eu-west-2", "s3-eu-west-2.amazonaws.com")+    , ("eu-central-1", "s3-eu-central-1.amazonaws.com")+    , ("sa-east-1", "s3-sa-east-1.amazonaws.com")+  ]++-- | Connection Info data type. To create a 'ConnectInfo' value, use one+-- of the provided smart constructors or override fields of the+-- Default instance. data ConnectInfo = ConnectInfo {     connectHost :: Text   , connectPort :: Int@@ -24,13 +69,22 @@   , connectSecretKey :: Text   , connectIsSecure :: Bool   , connectRegion :: Region+  , connectAutoDiscoverRegion :: Bool   } deriving (Eq, Show) +-- | Connects to a Minio server located at @localhost:9000@ with access+-- key /minio/ and secret key /minio123/. It is over __HTTP__ by+-- default. instance Default ConnectInfo where-  def = ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1"+  def = ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1" True --- |--- Default aws ConnectInfo. Credentials should be supplied before use.+-- | Default AWS ConnectInfo. Connects to "us-east-1". Credentials+-- should be supplied before use, for e.g.:+--+-- > awsCI {+-- >   connectAccessKey = "my-access-key"+-- > , connectSecretKey = "my-secret-key"+-- > } awsCI :: ConnectInfo awsCI = def {     connectHost = "s3.amazonaws.com"@@ -40,8 +94,30 @@   , connectIsSecure = True   } --- |--- Default minio play server ConnectInfo. Credentials are already filled.+-- | AWS ConnectInfo with a specified region. It can optionally+-- disable the automatic discovery of a bucket's region via the+-- Boolean argument.+--+-- > awsWithRegionCI "us-west-1" False {+-- >   connectAccessKey = "my-access-key"+-- > , connectSecretKey = "my-secret-key"+-- > }+--+-- This restricts all operations to the "us-west-1" region and does+-- not perform any bucket location requests.+awsWithRegionCI :: Region -> Bool -> ConnectInfo+awsWithRegionCI region autoDiscoverRegion =+  let host = maybe "s3.amazonaws.com" identity $+             Map.lookup region awsRegionMap+  in awsCI {+      connectHost = host+    , connectRegion = region+    , connectAutoDiscoverRegion = autoDiscoverRegion+    }+++-- | <https://play.minio.io:9000 Minio Play Server>+-- ConnectInfo. Credentials are already filled in. minioPlayCI :: ConnectInfo minioPlayCI = def {     connectHost = "play.minio.io"@@ -49,8 +125,28 @@   , connectAccessKey = "Q3AM3UQ867SPQQA43P2F"   , connectSecretKey = "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG"   , connectIsSecure = True+  , connectAutoDiscoverRegion = False   } +-- | ConnectInfo for Minio server. Takes hostname, port and a Boolean+-- to enable TLS.+--+-- > minioCI "minio.example.com" 9000 True {+-- >   connectAccessKey = "my-access-key"+-- > , connectSecretKey = "my-secret-key"+-- > }+--+-- This connects to a Minio server at the given hostname and port over+-- HTTPS.+minioCI :: Text -> Int -> Bool -> ConnectInfo+minioCI host port isSecure = def {+    connectHost = host+  , connectPort = port+  , connectRegion = "us-east-1"+  , connectIsSecure = isSecure+  , connectAutoDiscoverRegion = False+  }+ -- | -- Represents a bucket in the object store type Bucket = Text@@ -81,30 +177,25 @@ -- | 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-+-- | A type to represent a part-number and etag.+type PartTuple = (PartNumber, ETag)  -- | Represents result from a listing of object parts of an ongoing -- multipart upload. data ListPartsResult = ListPartsResult {     lprHasMore :: Bool   , lprNextPart :: Maybe Int-  , lprParts :: [ListPartInfo]+  , lprParts :: [ObjectPartInfo]  } 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+data ObjectPartInfo = ObjectPartInfo {+    opiNumber :: PartNumber+  , opiETag :: ETag+  , opiSize :: Int64+  , opiModTime :: UTCTime   } deriving (Show, Eq)  -- | Represents result from a listing of incomplete uploads to a@@ -113,7 +204,7 @@     lurHasMore :: Bool   , lurNextKey :: Maybe Text   , lurNextUpload :: Maybe Text-  , lurUploads :: [UploadInfo]+  , lurUploads :: [(Object, UploadId, UTCTime)]   , lurCPrefixes :: [Text]   } deriving (Show, Eq) @@ -122,6 +213,7 @@     uiKey :: Object   , uiUploadId :: UploadId   , uiInitTime :: UTCTime+  , uiSize :: Int64   } deriving (Show, Eq)  -- | Represents result from a listing of objects in a bucket.@@ -140,6 +232,47 @@   , oiSize :: Int64   } deriving (Show, Eq) +data CopyPartSource = CopyPartSource {+    cpSource :: Text -- | formatted like "/sourceBucket/sourceObject"+  , cpSourceRange :: Maybe (Int64, Int64) -- | (0, 9) means first ten+                                          -- bytes of the source+                                          -- object+  , cpSourceIfMatch :: Maybe Text+  , cpSourceIfNoneMatch :: Maybe Text+  , cpSourceIfUnmodifiedSince :: Maybe UTCTime+  , cpSourceIfModifiedSince :: Maybe UTCTime+  } deriving (Show, Eq)++instance Default CopyPartSource where+  def = CopyPartSource "" def def def def def++cpsToHeaders :: CopyPartSource -> [HT.Header]+cpsToHeaders cps = ("x-amz-copy-source", encodeUtf8 $ cpSource cps) :+                   (rangeHdr ++ (zip names values))+  where+    names = ["x-amz-copy-source-if-match", "x-amz-copy-source-if-none-match",+             "x-amz-copy-source-if-unmodified-since",+             "x-amz-copy-source-if-modified-since"]+    values = concatMap (maybeToList . fmap encodeUtf8 . (cps &))+             [cpSourceIfMatch, cpSourceIfNoneMatch,+              fmap formatRFC1123 . cpSourceIfUnmodifiedSince,+              fmap formatRFC1123 . cpSourceIfModifiedSince]+    rangeHdr = ("x-amz-copy-source-range",)+             . HT.renderByteRanges+             . (:[])+             . uncurry HT.ByteRangeFromTo+           <$> (map (both fromIntegral) $+                maybeToList $ cpSourceRange cps)++-- | Extract the source bucket and source object name. TODO: validate+-- the bucket and object name extracted.+cpsToObject :: CopyPartSource -> Maybe (Bucket, Object)+cpsToObject cps = do+  [_, bucket, object] <- Just splits+  return (bucket, object)+  where+    splits = T.splitOn "/" $ cpSource cps+ -- | Represents different kinds of payload that are used with S3 API -- requests. data Payload = PayloadBS ByteString@@ -159,10 +292,11 @@   , riPayload :: Payload   , riPayloadHash :: ByteString   , riRegion :: Maybe Region+  , riNeedsLocation :: Bool   }  instance Default RequestInfo where-  def = RequestInfo HT.methodGet def def def def def "" def+  def = RequestInfo HT.methodGet def def def def def "" def True  getPathFromRI :: RequestInfo -> ByteString getPathFromRI ri = B.concat $ parts@@ -170,11 +304,10 @@     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)+type RegionMap = Map.Map Bucket Region  newtype Minio a = Minio {-  unMinio :: ReaderT MinioConn (ResourceT IO) a+  unMinio :: ReaderT MinioConn (StateT RegionMap (ResourceT IO)) a   }   deriving (       Functor@@ -182,6 +315,7 @@     , Monad     , MonadIO     , MonadReader MinioConn+    , MonadState RegionMap     , MonadThrow     , MonadCatch     , MonadBase IO@@ -189,7 +323,7 @@     )  instance MonadBaseControl IO Minio where-  type StM Minio a = a+  type StM Minio a = (a, RegionMap)   liftBaseWith f = Minio $ liftBaseWith $ \q -> f (q . unMinio)   restoreM = Minio . restoreM @@ -212,39 +346,22 @@ runMinio :: ConnectInfo -> Minio a -> ResourceT IO (Either MinioErr a) runMinio ci m = do   conn <- liftIO $ connect ci-  flip runReaderT conn . unMinio $+  flip evalStateT Map.empty . flip runReaderT conn . unMinio $     (m >>= (return . Right)) `MC.catches`-    [MC.Handler handlerME, MC.Handler handlerHE, MC.Handler handlerFE]+    [ MC.Handler handlerServiceErr+    , MC.Handler handlerHE+    , MC.Handler handlerFE+    , MC.Handler handlerValidation+    ]   where-    handlerME = return . Left . ME-    handlerHE = return . Left . MEHttp-    handlerFE = return . Left . MEFile+    handlerServiceErr = return . Left . MErrService+    handlerHE = return . Left . MErrHTTP+    handlerFE = return . Left . MErrIO+    handlerValidation = return . Left . MErrValidation  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-           | MErrVInvalidObjectInfoResponse-  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+-- | Format as per RFC 1123.+formatRFC1123 :: UTCTime -> T.Text+formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"
src/Network/Minio/Data/ByteString.hs view
@@ -1,3 +1,19 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ {-# LANGUAGE FlexibleInstances #-} module Network.Minio.Data.ByteString   (
src/Network/Minio/Data/Crypto.hs view
@@ -1,3 +1,19 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ module Network.Minio.Data.Crypto   (     hashSHA256
src/Network/Minio/Data/Time.hs view
@@ -1,3 +1,19 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ module Network.Minio.Data.Time   (     awsTimeFormat
+ src/Network/Minio/Errors.hs view
@@ -0,0 +1,79 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.Errors where++import           Control.Exception+import qualified Network.HTTP.Conduit as NC++import           Lib.Prelude+++---------------------------------+-- Errors+---------------------------------+-- | Various validation errors+data MErrV = MErrVSinglePUTSizeExceeded Int64+           | MErrVPutSizeExceeded Int64+           | MErrVETagHeaderNotFound+           | MErrVInvalidObjectInfoResponse+           | MErrVInvalidSrcObjSpec Text+           | MErrVInvalidSrcObjByteRange (Int64, Int64)+           | MErrVCopyObjSingleNoRangeAccepted+           | MErrVRegionNotSupported Text+           | MErrXmlParse Text+  deriving (Show, Eq)++instance Exception MErrV++-- | Errors returned by S3 compatible service+data ServiceErr = BucketAlreadyExists+                | BucketAlreadyOwnedByYou+                | NoSuchBucket+                | InvalidBucketName+                | NoSuchKey+                | ServiceErr Text Text+  deriving (Show, Eq)++instance Exception ServiceErr++toServiceErr :: Text -> Text -> ServiceErr+toServiceErr "NoSuchKey" _               = NoSuchKey+toServiceErr "NoSuchBucket" _            = NoSuchBucket+toServiceErr "InvalidBucketName" _       = InvalidBucketName+toServiceErr "BucketAlreadyOwnedByYou" _ = BucketAlreadyOwnedByYou+toServiceErr "BucketAlreadyExists" _     = BucketAlreadyExists+toServiceErr code message                = ServiceErr code message+++-- | Errors thrown by the library+data MinioErr = MErrHTTP NC.HttpException+              | MErrIO IOException+              | MErrService ServiceErr+              | MErrValidation MErrV+  deriving (Show)++instance Eq MinioErr where+  MErrHTTP _       == MErrHTTP _        = True+  MErrHTTP _       ==  _                = False+  MErrIO _         == MErrIO _          = True+  MErrIO _         == _                 = False+  MErrService a    == MErrService b     = a == b+  MErrService _    == _                 = False+  MErrValidation a == MErrValidation b  = a == b+  MErrValidation _ == _                 = False++instance Exception MinioErr
src/Network/Minio/ListOps.hs view
@@ -1,6 +1,23 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ module Network.Minio.ListOps where  import qualified Data.Conduit as C+import qualified Data.Conduit.Combinators as CC import qualified Data.Conduit.List as CL  import           Lib.Prelude@@ -37,17 +54,28 @@        res <- lift $ listIncompleteUploads' bucket prefix delimiter              nextKeyMarker nextUploadIdMarker-      CL.sourceList $ lurUploads res++      aggrSizes <- lift $ forM (lurUploads res) $ \((uKey, uId, _)) -> do+            partInfos <- listIncompleteParts bucket uKey uId C.$$ CC.sinkList+            return $ foldl (\sizeSofar p -> opiSize p + sizeSofar) 0+              $ partInfos++      CL.sourceList $+        map (\((uKey, uId, uInitTime), size) ->+                UploadInfo uKey uId uInitTime size+            ) $ zip (lurUploads res) aggrSizes+       when (lurHasMore res) $-        loop nextKeyMarker nextUploadIdMarker+        loop (lurNextKey res) (lurNextUpload res) + -- | List object parts of an ongoing multipart upload for given -- bucket, object and uploadId. listIncompleteParts :: Bucket -> Object -> UploadId-                    -> C.Producer Minio ListPartInfo+                    -> C.Producer Minio ObjectPartInfo listIncompleteParts bucket object uploadId = loop Nothing   where-    loop :: Maybe Text -> C.Producer Minio ListPartInfo+    loop :: Maybe Text -> C.Producer Minio ObjectPartInfo     loop nextPartMarker = do       res <- lift $ listIncompleteParts' bucket object uploadId Nothing              nextPartMarker
src/Network/Minio/PutObject.hs view
@@ -1,8 +1,27 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ module Network.Minio.PutObject   (-    putObject+    putObjectInternal   , ObjectData(..)   , selectPartSizes+  , copyObjectInternal+  , selectCopyRanges+  , minPartSize   ) where  @@ -19,6 +38,7 @@  import           Network.Minio.Data import           Network.Minio.Data.Crypto+import           Network.Minio.Errors import           Network.Minio.ListOps import           Network.Minio.S3API import           Network.Minio.Utils@@ -28,6 +48,10 @@ maxObjectSize :: Int64 maxObjectSize = 5 * 1024 * 1024 * oneMiB +-- | minimum size of parts used in multipart operations.+minPartSize :: Int64+minPartSize = 64 * oneMiB+ oneMiB :: Int64 oneMiB = 1024 * 1024 @@ -44,14 +68,15 @@ -- For streams also, a size may be provided. This is useful to limit -- the input - if it is not provided, upload will continue until the -- stream ends or the object reaches `maxObjectsize` size.-data ObjectData m = ODFile FilePath (Maybe Int64) -- ^ Takes filepath and optional size.-                  | ODStream (C.Producer m ByteString) (Maybe Int64) -- ^ Pass size in bytes as maybe if known.+data ObjectData m =+  ODFile FilePath (Maybe Int64) -- ^ Takes filepath and optional size.+  | ODStream (C.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+putObjectInternal :: Bucket -> Object -> ObjectData Minio -> Minio ETag+putObjectInternal b o (ODStream src sizeMay) = sequentialMultipartUpload b o sizeMay src+putObjectInternal b o (ODFile fp sizeMay) = do   hResE <- withNewHandle fp $ \h ->     liftM2 (,) (isHandleSeekable h) (getFileSize h) @@ -70,30 +95,32 @@     Just size ->       if | size <= 64 * oneMiB -> either throwM return =<<            withNewHandle fp (\h -> putObjectSingle b o [] h 0 size)-         | size > maxObjectSize -> throwM $ ValidationError $-                                   MErrVPutSizeExceeded size+         | size > maxObjectSize -> throwM $ 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.+-- be 64MiB. selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)]-selectPartSizes size = List.zip3 [1..] partOffsets partSizes+selectPartSizes size = uncurry (List.zip3 [1..]) $+                       List.unzip $ loop 0 size   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+    partSize = max minPartSize (ceil $ fromIntegral size /+                               fromIntegral maxMultipartParts) +    m = fromIntegral partSize+    loop st sz+      | st > sz = []+      | st + m >= sz = [(st, sz - st)]+      | otherwise = (st, m) : loop (st + m) sz+ -- returns partinfo if part is already uploaded. checkUploadNeeded :: Payload -> PartNumber-                  -> Map.Map PartNumber ListPartInfo-                  -> Minio (Maybe PartInfo)+                  -> Map.Map PartNumber ObjectPartInfo+                  -> Minio (Maybe PartTuple) checkUploadNeeded payload n pmap = do   (md5hash, pSize) <- case payload of     PayloadBS bs -> return (hashMD5 bs, fromIntegral $ B.length bs)@@ -102,8 +129,8 @@       (Just $ fromIntegral size)   case Map.lookup n pmap of     Nothing -> return Nothing-    Just (ListPartInfo _ etag size _) -> return $-      bool Nothing (Just (PartInfo n etag)) $+    Just (ObjectPartInfo _ etag size _) -> return $+      bool Nothing (Just (n, etag)) $       md5hash == encodeUtf8 etag && size == pSize  parallelMultipartUpload :: Bucket -> Object -> FilePath -> Int64@@ -171,10 +198,76 @@ -- | 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)+                  -> Minio (Maybe UploadId, Map.Map PartNumber ObjectPartInfo) 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)+  return (uidMay, Map.fromList $ map (\p -> (opiNumber p, p)) parts)++-- | Copy an object using single or multipart copy strategy.+copyObjectInternal :: Bucket -> Object -> CopyPartSource+                   -> Minio ETag+copyObjectInternal b' o cps = do+  -- validate and extract the src bucket and object+  (srcBucket, srcObject) <- maybe+    (throwM $ MErrVInvalidSrcObjSpec $ cpSource cps)+    return $ cpsToObject cps++  -- get source object size with a head request+  (ObjectInfo _ _ _ srcSize) <- headObject srcBucket srcObject++  -- check that byte offsets are valid if specified in cps+  when (isJust (cpSourceRange cps) &&+        or [fst range < 0, snd range < fst range,+            snd range >= fromIntegral srcSize]) $+    throwM $ MErrVInvalidSrcObjByteRange range++  -- 1. If sz > 64MiB (minPartSize) use multipart copy, OR+  -- 2. If startOffset /= 0 use multipart copy+  let destSize = (\(a, b) -> b - a + 1 ) $+                 maybe (0, srcSize - 1) identity $ cpSourceRange cps+      startOffset = maybe 0 fst $ cpSourceRange cps+      endOffset = maybe (srcSize - 1) snd $ cpSourceRange cps++  if destSize > minPartSize || (endOffset - startOffset + 1 /= srcSize)+    then multiPartCopyObject b' o cps srcSize++    else fst <$> copyObjectSingle b' o cps{cpSourceRange = Nothing} []++  where+    range = maybe (0, 0) identity $ cpSourceRange cps++-- | Given the input byte range of the source object, compute the+-- splits for a multipart copy object procedure. Minimum part size+-- used is minPartSize.+selectCopyRanges :: (Int64, Int64) -> [(PartNumber, (Int64, Int64))]+selectCopyRanges (st, end) = zip pns $+  map (\(x, y) -> (st + x, st + x + y - 1)) $ zip startOffsets partSizes+  where+    size = end - st + 1+    (pns, startOffsets, partSizes) = List.unzip3 $ selectPartSizes size++-- | Perform a multipart copy object action. Since we cannot verify+-- existing parts based on the source object, there is no resuming+-- copy action support.+multiPartCopyObject :: Bucket -> Object -> CopyPartSource -> Int64+                    -> Minio ETag+multiPartCopyObject b o cps srcSize = do+  uid <- newMultipartUpload b o []++  let byteRange = maybe (0, fromIntegral $ srcSize - 1) identity $+                  cpSourceRange cps+      partRanges = selectCopyRanges byteRange+      partSources = map (\(x, y) -> (x, cps {cpSourceRange = Just y}))+                    partRanges++  copiedParts <- limitedMapConcurrently 10+                 (\(pn, cps') -> do+                     (etag, _) <- copyObjectPart b o cps' uid pn []+                     return $ (pn, etag)+                 )+                 partSources++  completeMultipartUpload b o uid copiedParts
src/Network/Minio/S3API.hs view
@@ -1,3 +1,19 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ module Network.Minio.S3API   (     Region@@ -22,20 +38,23 @@   , putBucket   , ETag   , putObjectSingle+  , copyObjectSingle    -- * Multipart Upload APIs   --------------------------   , UploadId-  , PartInfo+  , PartTuple   , Payload(..)   , PartNumber+  , CopyPartSource(..)   , newMultipartUpload   , putObjectPart+  , copyObjectPart   , completeMultipartUpload   , abortMultipartUpload   , ListUploadsResult   , listIncompleteUploads'-  , ListPartsResult+  , ListPartsResult(..)   , listIncompleteParts'    -- * Deletion APIs@@ -52,27 +71,22 @@  import           Lib.Prelude -import           Network.Minio.Data import           Network.Minio.API+import           Network.Minio.Data+import           Network.Minio.Errors import           Network.Minio.Utils-import           Network.Minio.XmlParser import           Network.Minio.XmlGenerator+import           Network.Minio.XmlParser   -- | Fetch all buckets from the service. getService :: Minio [BucketInfo] getService = do-  resp <- executeRequest $ def+  resp <- executeRequest $ def {+      riNeedsLocation = False+    }   parseListBuckets $ NC.responseBody resp --- | Fetch bucket location (region)-getLocation :: Bucket -> Minio Region-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]@@ -94,6 +108,7 @@     def { riMethod = HT.methodPut         , riBucket = Just bucket         , riPayload = PayloadBS $ mkCreateBucketConfig location+        , riNeedsLocation = False         }  -- | Single PUT object size.@@ -107,7 +122,7 @@ putObjectSingle bucket object headers h offset size = do   -- check length is within single PUT object size.   when (size > maxSinglePutObjectSizeBytes) $-    throwM $ ValidationError $ MErrVSinglePUTSizeExceeded size+    throwM $ MErrVSinglePUTSizeExceeded size    -- content-length header is automatically set by library.   resp <- executeRequest $@@ -121,7 +136,7 @@   let rheaders = NC.responseHeaders resp       etag = getETagHeader rheaders   maybe-    (throwM $ ValidationError MErrVETagHeaderNotFound)+    (throwM MErrVETagHeaderNotFound)     return etag  -- | List objects in a bucket matching prefix up to delimiter,@@ -172,7 +187,7 @@  -- | PUT a part of an object as part of a multipart upload. putObjectPart :: Bucket -> Object -> UploadId -> PartNumber -> [HT.Header]-              -> Payload -> Minio PartInfo+              -> Payload -> Minio PartTuple putObjectPart bucket object uploadId partNumber headers payload = do   resp <- executeRequest $           def { riMethod = HT.methodPut@@ -185,25 +200,62 @@   let rheaders = NC.responseHeaders resp       etag = getETagHeader rheaders   maybe-    (throwM $ ValidationError MErrVETagHeaderNotFound)-    (return . PartInfo partNumber) etag+    (throwM MErrVETagHeaderNotFound)+    (return . (partNumber, )) etag   where     params = [         ("uploadId", Just uploadId)       , ("partNumber", Just $ show partNumber)       ] +-- | Performs server-side copy of an object or part of an object as an+-- upload part of an ongoing multi-part upload.+copyObjectPart :: Bucket -> Object -> CopyPartSource -> UploadId+               -> PartNumber -> [HT.Header] -> Minio (ETag, UTCTime)+copyObjectPart bucket object cps uploadId partNumber headers = do+  resp <- executeRequest $+          def { riMethod = HT.methodPut+              , riBucket = Just bucket+              , riObject = Just object+              , riQueryParams = mkOptionalParams params+              , riHeaders = headers ++ cpsToHeaders cps+              }++  parseCopyObjectResponse $ NC.responseBody resp+  where+    params = [+        ("uploadId", Just uploadId)+      , ("partNumber", Just $ show partNumber)+      ]++-- | Performs server-side copy of an object that is upto 5GiB in+-- size. If the object is greater than 5GiB, this function throws the+-- error returned by the server.+copyObjectSingle :: Bucket -> Object -> CopyPartSource -> [HT.Header]+                 -> Minio (ETag, UTCTime)+copyObjectSingle bucket object cps headers = do+  -- validate that cpSourceRange is Nothing for this API.+  when (isJust $ cpSourceRange cps) $+    throwM MErrVCopyObjSingleNoRangeAccepted+  resp <- executeRequest $+          def { riMethod = HT.methodPut+              , riBucket = Just bucket+              , riObject = Just object+              , riHeaders = headers ++ cpsToHeaders cps+              }+  parseCopyObjectResponse $ NC.responseBody resp+ -- | Complete a multipart upload.-completeMultipartUpload :: Bucket -> Object -> UploadId -> [PartInfo]+completeMultipartUpload :: Bucket -> Object -> UploadId -> [PartTuple]                         -> Minio ETag-completeMultipartUpload bucket object uploadId partInfo = do+completeMultipartUpload bucket object uploadId partTuple = do   resp <- executeRequest $           def { riMethod = HT.methodPost               , riBucket = Just bucket               , riObject = Just object               , riQueryParams = mkOptionalParams params               , riPayload = PayloadBS $-                            mkCompleteMultipartUploadRequest partInfo+                            mkCompleteMultipartUploadRequest partTuple               }   parseCompleteMultipartUploadResponse $ NC.responseBody resp   where@@ -226,22 +278,22 @@ listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker = do   resp <- executeRequest $ def { riMethod = HT.methodGet                                , riBucket = Just bucket-                               , riQueryParams = ("uploads", Nothing): mkOptionalParams params+                               , riQueryParams = params                                }   parseListUploadsResponse $ NC.responseBody resp   where-    -- build optional query params-    params = [-        ("prefix", prefix)-      , ("delimiter", delimiter)-      , ("key-marker", keyMarker)-      , ("upload-id-marker", uploadIdMarker)-      ]+    -- build query params+    params = ("uploads", Nothing) : mkOptionalParams+             [ ("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+                     -> Maybe Text -> Minio ListPartsResult listIncompleteParts' bucket object uploadId maxParts partNumMarker = do   resp <- executeRequest $ def { riMethod = HT.methodGet                                , riBucket = Just bucket@@ -271,5 +323,5 @@     etag = getETagHeader headers     size = getContentLength headers -  maybe (throwM $ ValidationError MErrVInvalidObjectInfoResponse) return $+  maybe (throwM MErrVInvalidObjectInfoResponse) return $     ObjectInfo <$> Just object <*> modTime <*> etag <*> size
src/Network/Minio/Sign/V4.hs view
@@ -1,3 +1,19 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ module Network.Minio.Sign.V4   (     signV4@@ -82,14 +98,17 @@     outHeaders = authHeader : headersWithDate     timeBS = awsTimeFormatBS ts     dateHeader = (mk "X-Amz-Date", timeBS)-    hostHeader = (mk "host", encodeUtf8 $ connectHost ci)+    hostHeader = (mk "host", encodeUtf8 $ format "{}:{}" $+                   [connectHost ci, show $ connectPort ci])      headersWithDate = dateHeader : hostHeader : (riHeaders ri)      authHeader = (mk "Authorization", authHeaderValue) -    scope = getScope ts ri+    region = maybe (connectRegion ci) identity $ riRegion ri +    scope = getScope ts region+     authHeaderValue = B.concat [       "AWS4-HMAC-SHA256 Credential=",       encodeUtf8 (connectAccessKey ci), "/", scope,@@ -105,7 +124,7 @@      signingKey = hmacSHA256RawBS "aws4_request"                . hmacSHA256RawBS "s3"-               . hmacSHA256RawBS (encodeUtf8 $ getRegionFromRI ri)+               . hmacSHA256RawBS (encodeUtf8 region)                . hmacSHA256RawBS (awsDateFormatBS ts)                $ (B.concat ["AWS4", encodeUtf8 $ connectSecretKey ci]) @@ -119,10 +138,10 @@     canonicalRequest = getCanonicalRequest ri headersToSign  -getScope :: UTCTime -> RequestInfo -> ByteString-getScope ts ri = B.intercalate "/" $ [+getScope :: UTCTime -> Region -> ByteString+getScope ts region = B.intercalate "/" $ [   pack $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts,-  encodeUtf8 $ getRegionFromRI ri, "s3", "aws4_request"+  encodeUtf8 region, "s3", "aws4_request"   ]  getHeadersToSign :: [Header] -> [(ByteString, ByteString)]
src/Network/Minio/Utils.hs view
@@ -1,3 +1,19 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ module Network.Minio.Utils where  import qualified Control.Concurrent.Async.Lifted as A@@ -9,6 +25,8 @@  import qualified Data.ByteString as B import qualified Data.Conduit as C+import qualified Data.Conduit.Binary as CB+import           Data.Default (Default(..)) import qualified Data.Text as T import           Data.Text.Encoding.Error (lenientDecode) import           Data.Text.Read (decimal)@@ -22,17 +40,14 @@  import           Lib.Prelude -import           Network.Minio.Data---- | Represent the time format string returned by S3 API calls.-s3TimeFormat :: [Char]-s3TimeFormat = iso8601DateFormat $ Just "%T%QZ"+import           Network.Minio.Errors+import           Network.Minio.XmlParser (parseErrResponse) -allocateReadFile :: (R.MonadResource m, R.MonadResourceBase m)+allocateReadFile :: (R.MonadResource m, R.MonadResourceBase m, MonadCatch m)                  => FilePath -> m (R.ReleaseKey, Handle) allocateReadFile fp = do   (rk, hdlE) <- R.allocate (openReadFile fp) cleanup-  either (throwM . MEFile) (return . (rk,)) hdlE+  either (\(e :: IOException) -> throwM e) (return . (rk,)) hdlE   where     openReadFile f = ExL.try $ IO.openBinaryFile f IO.ReadMode     cleanup = either (const $ return ()) IO.hClose@@ -62,7 +77,7 @@ -- 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)+              => FilePath -> (Handle -> m a) -> m (Either IOException a) withNewHandle fp fileAction = do   -- opening a handle can throw MError exception.   handleE <- MC.try $ allocateReadFile fp@@ -107,12 +122,19 @@   respE <- liftIO $ tryHttpEx $ (NClient.httpLbs req mgr)   resp <- either throwM return respE   unless (isSuccessStatus $ NC.responseStatus resp) $-    throwM $ ResponseError resp+    case contentTypeMay resp of+      Just "application/xml" -> do+        sErr <- parseErrResponse $ NC.responseBody resp+        throwM sErr++      _ -> throwM $ NC.StatusCodeException (NC.responseStatus resp) [] def+   return resp   where     tryHttpEx :: (IO (NC.Response LByteString))               -> IO (Either NC.HttpException (NC.Response LByteString))     tryHttpEx = try+    contentTypeMay resp = lookupHeader Hdr.hContentType $ NC.responseHeaders resp  http :: (R.MonadResourceBase m, R.MonadResource m)      => NC.Request -> NC.Manager@@ -120,14 +142,21 @@ 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+  unless (isSuccessStatus $ NC.responseStatus resp) $+    case contentTypeMay resp of+      Just "application/xml" -> do+        respBody <- NC.responseBody resp C.$$+- CB.sinkLbs+        sErr <- parseErrResponse $ respBody+        throwM sErr++      _ -> throwM $ NC.StatusCodeException (NC.responseStatus resp) [] def+   return resp   where     tryHttpEx :: (R.MonadResourceBase m) => (m a)-              -> m (Either NC.HttpException a)+              -> m (Either MinioErr a)     tryHttpEx = ExL.try+    contentTypeMay resp = lookupHeader Hdr.hContentType $ NC.responseHeaders resp  -- like mapConcurrently but with a limited number of concurrent -- threads.
src/Network/Minio/XmlGenerator.hs view
@@ -1,3 +1,19 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ module Network.Minio.XmlGenerator   ( mkCreateBucketConfig   , mkCompleteMultipartUploadRequest@@ -26,13 +42,13 @@       bucketConfig = Document (Prologue [] Nothing []) root []  -- | Create a completeMultipartUpload request body XML-mkCompleteMultipartUploadRequest :: [PartInfo] -> ByteString+mkCompleteMultipartUploadRequest :: [PartTuple] -> 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+    mkPart (n, etag) = Element "Part" M.empty                                [ NodeElement $ Element "PartNumber" M.empty                                  [NodeContent $ T.pack $ show n]                                , NodeElement $ Element "ETag" M.empty
src/Network/Minio/XmlParser.hs view
@@ -1,11 +1,29 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ module Network.Minio.XmlParser   ( parseListBuckets   , parseLocation   , parseNewMultipartUpload   , parseCompleteMultipartUploadResponse+  , parseCopyObjectResponse   , parseListObjectsResponse   , parseListUploadsResponse   , parseListPartsResponse+  , parseErrResponse   ) where  import           Control.Monad.Trans.Resource@@ -14,29 +32,30 @@ import           Data.Text.Read (decimal) import           Data.Time import           Text.XML-import           Text.XML.Cursor+import           Text.XML.Cursor hiding (bool)  import           Lib.Prelude  import           Network.Minio.Data-import           Network.Minio.Utils (s3TimeFormat)+import           Network.Minio.Errors  --- | Helper functions.-uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d-uncurry3 f (a, b, c) = f a b c+-- | Represent the time format string returned by S3 API calls.+s3TimeFormat :: [Char]+s3TimeFormat = iso8601DateFormat $ Just "%T%QZ" +-- | Helper functions. uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e uncurry4 f (a, b, c, d) = f a b c d  -- | Parse time strings from XML parseS3XMLTime :: (MonadThrow m) => Text -> m UTCTime-parseS3XMLTime = either (throwM . XMLParseError) return+parseS3XMLTime = either (throwM . MErrXmlParse) return                . parseTimeM True defaultTimeLocale s3TimeFormat                . T.unpack  parseDecimal :: (MonadThrow m, Integral a) => Text -> m a-parseDecimal numStr = either (throwM . XMLParseError . show) return $ fst <$> decimal numStr+parseDecimal numStr = either (throwM . MErrXmlParse . show) return $ fst <$> decimal numStr  parseDecimals :: (MonadThrow m, Integral a) => [Text] -> m [a] parseDecimals numStr = forM numStr parseDecimal@@ -45,7 +64,7 @@ s3Elem = element . s3Name  parseRoot :: (MonadThrow m) => LByteString -> m Cursor-parseRoot = either (throwM . XMLParseError . show) (return . fromDocument)+parseRoot = either (throwM . MErrXmlParse . show) (return . fromDocument)           . parseLBS def  -- | Parse the response XML of a list buckets call.@@ -63,7 +82,8 @@ parseLocation :: (MonadThrow m) => LByteString -> m Region parseLocation xmldata = do   r <- parseRoot xmldata-  return $ T.concat $ r $/ content+  let region = T.concat $ r $/ content+  return $ bool "us-east-1" region $ region /= ""  -- | Parse the response XML of an newMultipartUpload call. parseNewMultipartUpload :: (MonadThrow m)@@ -79,6 +99,16 @@   r <- parseRoot xmldata   return $ T.concat $ r $// s3Elem "ETag" &/ content +-- | Parse the response XML of copyObject and copyObjectPart+parseCopyObjectResponse :: (MonadThrow m) => LByteString -> m (ETag, UTCTime)+parseCopyObjectResponse xmldata = do+  r <- parseRoot xmldata+  let+    mtimeStr = T.concat $ r $// s3Elem "LastModified" &/ content++  mtime <- parseS3XMLTime mtimeStr+  return $ (T.concat $ r $// s3Elem "ETag" &/ content, mtime)+ -- | Parse the response XML of a list objects call. parseListObjectsResponse :: (MonadThrow m)                          => LByteString -> m ListObjectsResult@@ -124,8 +154,7 @@   uploadInitTimes <- mapM parseS3XMLTime uploadInitTimeStr    let-    uploads = map (uncurry3 UploadInfo) $-              zip3 uploadKeys uploadIds uploadInitTimes+    uploads = zip3 uploadKeys uploadIds uploadInitTimes    return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes @@ -147,7 +176,16 @@   nextPartNum <- parseDecimals $ maybeToList nextPartNumStr    let-    partInfos = map (uncurry4 ListPartInfo) $+    partInfos = map (uncurry4 ObjectPartInfo) $                 zip4 partNumbers partETags partSizes partModTimes    return $ ListPartsResult hasMore (listToMaybe nextPartNum) partInfos+++parseErrResponse :: (MonadThrow m)+                 => LByteString -> m ServiceErr+parseErrResponse xmldata = do+  r <- parseRoot xmldata+  let code = T.concat $ r $/ element "Code" &/ content+      message = T.concat $ r $/ element "Message" &/ content+  return $ toServiceErr code message
+ test/LiveServer.hs view
@@ -0,0 +1,443 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++import qualified Test.QuickCheck as Q+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.QuickCheck as QC++import           Lib.Prelude++import           System.Directory (getTemporaryDirectory)+import qualified System.IO as SIO++import qualified Control.Monad.Catch as MC+import qualified Control.Monad.Trans.Resource as R+import qualified Data.ByteString as BS+import           Data.Conduit (($$), yield)+import 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           System.Environment (lookupEnv)++import           Network.Minio+import           Network.Minio.Data+import           Network.Minio.Errors+import           Network.Minio.ListOps+import           Network.Minio.PutObject+import           Network.Minio.S3API+import           Network.Minio.Utils++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [liveServerUnitTests]++-- 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+  connInfo <- maybe minioPlayCI (const def) <$> lookupEnv "MINIO_LOCAL"+  ret <- runResourceT $ runMinio connInfo $ do+    liftStep $ "Creating bucket for test - " ++ t+    makeBucket b def+    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 "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised."+      mbE <- MC.try $ makeBucket bucket Nothing+      case mbE of+        Left exn -> liftIO $ exn @?= BucketAlreadyOwnedByYou+        _ -> return ()++      step "makeBucket with an invalid bucket name and check for appropriate exception."+      invalidMBE <- MC.try $ makeBucket "invalidBucketName" Nothing+      case invalidMBE of+        Left exn -> liftIO $ exn @?= InvalidBucketName+        _ -> return ()++      step "getLocation works"+      region <- getLocation bucket+      liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region)++      step "singlepart putObject works"+      fPutObject bucket "lsb-release" "/etc/lsb-release"++      step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception"+      fpE <- MC.try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release"+      case fpE of+        Left exn -> liftIO $ exn @?= NoSuchBucket+        _ -> return ()++      outFile <- mkRandFile 0+      step "simple fGetObject works"+      fGetObject bucket "lsb-release" outFile++      step "fGetObject a non-existent object and check for NoSuchKey exception"+      resE <- MC.try $ fGetObject bucket "noSuchKey" outFile+      case resE of+        Left exn -> liftIO $ exn @?= NoSuchKey+        _ -> return ()+++      step "create new multipart upload works"+      uid <- newMultipartUpload bucket "newmpupload" []+      liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")++      step "abort a new multipart upload works"+      abortMultipartUpload bucket "newmpupload" uid++      step "delete object works"+      deleteObject bucket "lsb-release"++      step "statObject test"+      let object = "sample"+      step "create an object"+      inputFile <- mkRandFile 0+      fPutObject bucket object inputFile++      step "get metadata of the object"+      res <- statObject bucket object+      liftIO $ (oiSize res) @?= 0++      step "delete object"+      deleteObject bucket object++  , funTestWithBucket "Multipart Tests" $+    \step bucket -> do+      -- low-level multipart operation tests.+      let object = "newmpupload"+          mb15 = 15 * 1024 * 1024++      step "Prepare for low-level multipart tests."+      step "create new multipart upload"+      uid <- newMultipartUpload bucket object []+      liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")++      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"+      removeObject bucket object++      -- putObject test (conduit source, no size specified)+      let obj = "mpart"+          mb100 = 100 * 1024 * 1024++      step "Prepare for putObject with from source without providing size."+      rFile <- mkRandFile mb100++      step "Upload multipart file."+      putObject 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++      step "Prepare for putObjectInternal with non-seekable file, with size."+      step "Upload multipart file."+      void $ putObjectInternal 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"+      removeObject bucket obj++      step "Prepare for putObjectInternal with large file as source."+      step "upload large object"+      void $ putObjectInternal bucket "big" (ODFile "/dev/zero" $+                                             Just $ 1024*1024*100)++      step "cleanup"+      removeObject bucket "big"+++  , funTestWithBucket "Listing Test" $ \step bucket -> do+      step "listObjects' test"+      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)])++      step "listIncompleteUploads' test"+      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++      step "cleanup"+      forM_ (lurUploads incompleteUploads) $+        \(_, uid, _) -> abortMultipartUpload bucket object uid++      step "Basic listIncompleteParts Test"+      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+      abortMultipartUpload bucket object uid++      step "High-level listObjects Test"+      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 -> removeObject bucket obj++      step "High-level listIncompleteUploads Test"+      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++      step "cleanup"+      forM_ uploads $ \(UploadInfo _ uid _ _) ->+                        abortMultipartUpload bucket object uid++      step "High-level listIncompleteParts Test"+      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++      step "cleanup"+      abortMultipartUpload bucket object uid++  , funTestWithBucket "copyObject related tests" $ \step bucket -> do+      step "copyObjectSingle basic tests"+      let object = "xxx"+          objCopy = "xxxCopy"+          size1 = 100 :: Int64++      step "create server object to copy"+      inputFile <- mkRandFile size1+      fPutObject bucket object inputFile++      step "copy object"+      let cps = def { cpSource = format "/{}/{}" [bucket, object] }+      (etag, modTime) <- copyObjectSingle bucket objCopy cps []++      -- retrieve obj info to check+      ObjectInfo _ t e s <- headObject bucket objCopy++      let isMTimeDiffOk = abs (diffUTCTime modTime t) < 1.0++      liftIO $ (s == size1 && e == etag && isMTimeDiffOk) @?+        "Copied object did not match expected."++      step "cleanup actions"+      removeObject bucket object+      removeObject bucket objCopy++      step "copyObjectPart basic tests"+      let srcObj = "XXX"+          copyObj = "XXXCopy"++      step "Prepare"+      let mb15 = 15 * 1024 * 1024+          mb5 = 5 * 1024 * 1024+      randFile <- mkRandFile mb15+      fPutObject bucket srcObj randFile++      step "create new multipart upload"+      uid <- newMultipartUpload bucket copyObj []+      liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")++      step "put object parts 1-3"+      let cps = def {cpSource = format "/{}/{}" [bucket, srcObj]}+      parts <- forM [1..3] $ \p -> do+        (etag, _) <- copyObjectPart bucket copyObj cps{+          cpSourceRange = Just ((p-1)*mb5, (p-1)*mb5 + (mb5 - 1))+          } uid (fromIntegral p) []+        return $ (fromIntegral p, etag)++      step "complete multipart"+      void $ completeMultipartUpload bucket copyObj uid parts++      step "verify copied object size"+      (ObjectInfo _ _ _ s) <- headObject bucket copyObj++      liftIO $ (s == mb15) @? "Size failed to match"++      step $ "Cleanup actions"+      removeObject bucket srcObj+      removeObject bucket copyObj++      step "copyObject basic tests"+      let srcs = ["XXX", "XXXL"]+          copyObjs = ["XXXCopy", "XXXLCopy"]+          sizes = map (* (1024 * 1024)) [15, 65]++      step "Prepare"+      forM_ (zip srcs sizes) $ \(src, size) ->+        fPutObject bucket src =<< mkRandFile size++      step "make small and large object copy"+      forM_ (zip copyObjs srcs) $ \(cp, src) ->+        copyObject bucket cp def{cpSource = format "/{}/{}" [bucket, src]}++      step "verify uploaded objects"+      uploadedSizes <- fmap (fmap oiSize) $ forM copyObjs (headObject bucket)++      liftIO $ (sizes == uploadedSizes) @? "Uploaded obj sizes failed to match"++      forM_ (concat [srcs, copyObjs]) (removeObject bucket)++      step "copyObject with offset test "+      let src = "XXX"+          copyObj = "XXXCopy"+          size = 15 * 1024 * 1024++      step "Prepare"+      fPutObject bucket src =<< mkRandFile size++      step "copy last 10MiB of object"+      copyObject bucket copyObj def{+          cpSource = format "/{}/{}" [bucket, src]+        , cpSourceRange = Just (5 * 1024 * 1024, size - 1)+        }++      step "verify uploaded object"+      cSize <- oiSize <$> headObject bucket copyObj++      liftIO $ (cSize == 10 * 1024 * 1024) @? "Uploaded obj size mismatched!"++      forM_ [src, copyObj] (removeObject bucket)+  ]
test/Network/Minio/XmlGenerator/Test.hs view
@@ -1,3 +1,19 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ module Network.Minio.XmlGenerator.Test   ( xmlGeneratorTests   ) where@@ -8,7 +24,6 @@ import Lib.Prelude  import Network.Minio.XmlGenerator-import Network.Minio.Data  xmlGeneratorTests :: TestTree xmlGeneratorTests = testGroup "XML Generator Tests"@@ -29,7 +44,7 @@ testMkCompleteMultipartUploadRequest :: Assertion testMkCompleteMultipartUploadRequest =   assertEqual "completeMultipartUpload xml should match: " expected $-  mkCompleteMultipartUploadRequest [PartInfo 1 "abc"]+  mkCompleteMultipartUploadRequest [(1, "abc")]   where     expected = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\     \<CompleteMultipartUpload>\
test/Network/Minio/XmlParser/Test.hs view
@@ -1,16 +1,33 @@+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ module Network.Minio.XmlParser.Test   (     xmlParserTests   ) where  import qualified Control.Monad.Catch as MC-import           Data.Time (fromGregorian, UTCTime(..))+import           Data.Time (fromGregorian) import           Test.Tasty import           Test.Tasty.HUnit  import           Lib.Prelude  import           Network.Minio.Data+import           Network.Minio.Errors import           Network.Minio.XmlParser  xmlParserTests :: TestTree@@ -21,28 +38,29 @@   , testCase "Test parseListUploadsresponse" testParseListIncompleteUploads   , testCase "Test parseCompleteMultipartUploadResponse" testParseCompleteMultipartUploadResponse   , testCase "Test parseListPartsResponse" testParseListPartsResponse+  , testCase "Test parseCopyObjectResponse" testParseCopyObjectResponse   ] -tryMError :: (MC.MonadCatch m) => m a -> m (Either MError a)-tryMError act = MC.try act+tryValidationErr :: (MC.MonadCatch m) => m a -> m (Either MErrV a)+tryValidationErr act = MC.try act -assertMError :: MError -> Assertion-assertMError e = assertFailure $ "Failed due to exception => " ++ show e+assertValidtionErr :: MErrV -> Assertion+assertValidtionErr e = assertFailure $ "Failed due to validation error => " ++ show e -eitherMError :: Either MError a -> (a -> Assertion) -> Assertion-eitherMError (Left e) _ = assertMError e-eitherMError (Right a) f = f a+eitherValidationErr :: Either MErrV a -> (a -> Assertion) -> Assertion+eitherValidationErr (Left e) _ = assertValidtionErr e+eitherValidationErr (Right a) f = f a  testParseLocation :: Assertion testParseLocation = do   -- 1. Test parsing of an invalid location constraint xml.-  parseResE <- tryMError $ parseLocation "ClearlyInvalidXml"+  parseResE <- tryValidationErr $ 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+    parseLocE <- tryValidationErr $ parseLocation xmldata+    either assertValidtionErr (@?= expectedLocation) parseLocE   where     cases =  [       -- 2. Test parsing of a valid location xml.@@ -53,7 +71,7 @@       ,       -- 3. Test parsing of a valid, empty location xml.       ("<LocationConstraint xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"/>",-       ""+       "us-east-1"       )       ] @@ -61,8 +79,8 @@ testParseNewMultipartUpload :: Assertion testParseNewMultipartUpload = do   forM_ cases $ \(xmldata, expectedUploadId) -> do-    parsedUploadIdE <- tryMError $ parseNewMultipartUpload xmldata-    eitherMError parsedUploadIdE (@?= expectedUploadId)+    parsedUploadIdE <- tryValidationErr $ parseNewMultipartUpload xmldata+    eitherValidationErr parsedUploadIdE (@?= expectedUploadId)   where     cases = [       ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\@@ -106,8 +124,8 @@     object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234     modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12 -  parsedListObjectsResult <- tryMError $ parseListObjectsResponse xmldata-  eitherMError parsedListObjectsResult (@?= expectedListResult)+  parsedListObjectsResult <- tryValidationErr $ parseListObjectsResponse xmldata+  eitherValidationErr parsedListObjectsResult (@?= expectedListResult)  testParseListIncompleteUploads :: Assertion testParseListIncompleteUploads = do@@ -144,12 +162,12 @@   \</CommonPrefixes>\   \</ListMultipartUploadsResult>"     expectedListResult = ListUploadsResult False (Just "sample.jpg") (Just "Xgw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1W99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--") uploads prefixes-    uploads = [UploadInfo "sample.jpg" "Agw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1N99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--" initTime]+    uploads = [("sample.jpg", "Agw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1N99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--", initTime)]     initTime = UTCTime (fromGregorian 2010 11 26) 69857     prefixes = ["photos/", "videos/"] -  parsedListUploadsResult <- tryMError $ parseListUploadsResponse xmldata-  eitherMError parsedListUploadsResult (@?= expectedListResult)+  parsedListUploadsResult <- tryValidationErr $ parseListUploadsResponse xmldata+  eitherValidationErr parsedListUploadsResult (@?= expectedListResult)   testParseCompleteMultipartUploadResponse :: Assertion@@ -165,7 +183,7 @@     expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\""    parsedETagE <- runExceptT $ parseCompleteMultipartUploadResponse xmldata-  eitherMError parsedETagE (@?= expectedETag)+  eitherValidationErr parsedETagE (@?= expectedETag)  testParseListPartsResponse :: Assertion testParseListPartsResponse = do@@ -203,10 +221,32 @@ \</ListPartsResult>"      expectedListResult = ListPartsResult True (Just 3) [part1, part2]-    part1 = ListPartInfo 2 "\"7778aef83f66abc1fa1e8477f296d394\"" 10485760 modifiedTime1+    part1 = ObjectPartInfo 2 "\"7778aef83f66abc1fa1e8477f296d394\"" 10485760 modifiedTime1     modifiedTime1 = flip UTCTime 74914 $ fromGregorian 2010 11 10-    part2 = ListPartInfo 3 "\"aaaa18db4cc2f85cedef654fccc4a4x8\"" 10485760 modifiedTime2+    part2 = ObjectPartInfo 3 "\"aaaa18db4cc2f85cedef654fccc4a4x8\"" 10485760 modifiedTime2     modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10    parsedListPartsResult <- runExceptT $ parseListPartsResponse xmldata-  eitherMError parsedListPartsResult (@?= expectedListResult)+  eitherValidationErr parsedListPartsResult (@?= expectedListResult)++testParseCopyObjectResponse :: Assertion+testParseCopyObjectResponse = do+  let+    cases = [ ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\+\<CopyObjectResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+   \<LastModified>2009-10-28T22:32:00.000Z</LastModified>\+   \<ETag>\"9b2cf535f27731c974343645a3985328\"</ETag>\+\</CopyObjectResult>",+              ("\"9b2cf535f27731c974343645a3985328\"",+               UTCTime (fromGregorian 2009 10 28) 81120))+            , ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\+\<CopyPartResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+   \<LastModified>2009-10-28T22:32:00.000Z</LastModified>\+   \<ETag>\"9b2cf535f27731c974343645a3985328\"</ETag>\+\</CopyPartResult>",+              ("\"9b2cf535f27731c974343645a3985328\"",+              UTCTime (fromGregorian 2009 10 28) 81120))]++  forM_ cases $ \(xmldata, (etag, modTime)) -> do+    parseResult <- runExceptT $ parseCopyObjectResponse xmldata+    eitherValidationErr parseResult (@?= (etag, modTime))
test/Spec.hs view
@@ -1,28 +1,27 @@-import qualified Test.QuickCheck as Q+--+-- Minio Haskell SDK, (C) 2017 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+ import           Test.Tasty-import           Test.Tasty.HUnit import           Test.Tasty.QuickCheck as QC -import           Lib.Prelude--import           System.Directory (getTemporaryDirectory)-import qualified System.IO as SIO--import qualified Control.Monad.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 qualified Data.List as L -import           Network.Minio-import           Network.Minio.Data+import           Lib.Prelude+ import           Network.Minio.PutObject-import           Network.Minio.S3API-import           Network.Minio.Utils import           Network.Minio.XmlGenerator.Test import           Network.Minio.XmlParser.Test @@ -30,7 +29,7 @@ main = defaultMain tests  tests :: TestTree-tests = testGroup "Tests" [properties, unitTests, liveServerUnitTests]+tests = testGroup "Tests" [properties, unitTests]  properties :: TestTree properties = testGroup "Properties" [qcProps] -- [scProps]@@ -48,7 +47,7 @@  qcProps :: TestTree qcProps = testGroup "(checked by QuickCheck)"-  [ QC.testProperty "selectPartSizes: simple properties" $+  [ QC.testProperty "selectPartSizes:" $     \n -> let (pns, offs, sizes) = L.unzip3 (selectPartSizes n)                -- check that pns increments from 1.@@ -62,284 +61,52 @@               isOffsetsAsc = all (\(a, b) -> a < b) $ consPairs offs                -- check sizes sums to n.-              isSumSizeOk = n < 0 || (sum sizes == n && all (> 0) sizes)+              isSumSizeOk = sum sizes == n                -- check sizes are constant except last               isSizesConstantExceptLast =-                n <= 0 || all (\(a, b) -> a == b) (consPairs $ L.init sizes)--          in isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk &&-             isSizesConstantExceptLast--  , QC.testProperty "selectPartSizes: part-size is at least 64MiB" $-    \n -> let (_, _, sizes) = L.unzip3 (selectPartSizes n)-              mib64 = 64 * 1024 * 1024-          in if | length sizes > 1 -> -- last part can be smaller but > 0-                    all (>= mib64) (L.init sizes) && L.last sizes > 0-                | length sizes == 1 -> maybe True (> 0) $ head sizes-                | otherwise -> True-  ]----- 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-    makeBucket b def-    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+                all (\(a, b) -> a == b) (consPairs $ L.init sizes) -      step "create a multipart upload"-      uid <- newMultipartUpload bucket object []-      liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")+              -- check each part except last is at least minPartSize;+              -- last part may be 0 only if it is the only part.+              nparts = length sizes+              isMinPartSizeOk =+                if | nparts > 1 -> -- last part can be smaller but > 0+                     all (>= minPartSize) (take (nparts - 1) sizes) &&+                     all (\s -> s > 0) (drop (nparts - 1) sizes)+                   | nparts == 1 -> -- size may be 0 here.+                       maybe True (\x -> x >= 0 && x <= minPartSize) $+                       headMay sizes+                   | otherwise -> False -      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+          in n < 0 ||+             (isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk &&+              isSizesConstantExceptLast && isMinPartSizeOk) -      step "fetch list parts"-      incompleteParts <- (listIncompleteParts bucket object uid) $$ sinkList-      liftIO $ (length incompleteParts) @?= 10+  , QC.testProperty "selectCopyRanges:" $+    \(start, end) ->+      let (_, pairs) = L.unzip (selectCopyRanges (start, end)) -  , funTestWithBucket "High-level statObject Test" $ \step bucket -> do-      let-        object = "sample"-        zeroByte = 0+          -- is last part's snd offset end?+          isLastPartOk = maybe False ((end ==) . snd) $ lastMay pairs+          -- is first part's fst offset start+          isFirstPartOk = maybe False ((start ==) . fst) $ headMay pairs -      step "create an object"-      inputFile <- mkRandFile zeroByte-      fPutObject bucket object inputFile+          -- each pair is >=64MiB except last, and all those parts+          -- have same size.+          initSizes = maybe [] (map (\(a, b) -> b - a + 1)) $ initMay pairs+          isPartSizesOk = all (>= minPartSize) initSizes &&+                          maybe True (\k -> all (== k) initSizes)+                          (headMay initSizes) -      step "get metadata of the object"-      res <- statObject bucket object-      liftIO $ (oiSize res) @?= 0+          -- returned offsets are contiguous.+          fsts = drop 1 $ map fst pairs+          snds = take (length pairs - 1) $ map snd pairs+          isContParts = length fsts == length snds &&+                        and (map (\(a, b) -> a == b + 1) $ zip fsts snds) -      step "delete object"-      deleteObject bucket object+      in start < 0 || start > end ||+         (isLastPartOk && isFirstPartOk && isPartSizesOk && isContParts)   ]  unitTests :: TestTree