minio-hs 0.3.1 → 0.3.2

raw patch · 18 files changed

+1416/−394 lines, 18 filesdep +aesondep +base64-bytestringdep +vectordep ~protoludePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson, base64-bytestring, vector

Dependency ranges changed: protolude

API changes (from Hackage documentation)

Files

• minio-hs.cabal +21/−6
• src/Lib/Prelude.hs +5/−8
• src/Network/Minio.hs +103/−32
• src/Network/Minio/API.hs +17/−5
• src/Network/Minio/Data.hs +127/−10
• src/Network/Minio/Data/Time.hs +4/−0
• src/Network/Minio/Errors.hs +1/−0
• src/Network/Minio/ListOps.hs +15/−0
• src/Network/Minio/PresignedOperations.hs +281/−0
• src/Network/Minio/PutObject.hs +12/−54
• src/Network/Minio/S3API.hs +62/−0
• src/Network/Minio/Sign/V4.hs +147/−74
• src/Network/Minio/Utils.hs +4/−0
• src/Network/Minio/XmlGenerator.hs +47/−2
• src/Network/Minio/XmlParser.hs +68/−17
• test/LiveServer.hs +345/−176
• test/Network/Minio/XmlGenerator/Test.hs +45/−4
• test/Network/Minio/XmlParser/Test.hs +112/−6

@@ -1,5 +1,5 @@ name:                minio-hs-version:             0.3.1+version:             0.3.2 synopsis:            A Minio Haskell Library for Amazon S3 compatible cloud                      storage. description:         The Minio Haskell client library provides simple APIs to@@ -29,14 +29,17 @@                      , Network.Minio.Data.Time                      , Network.Minio.Errors                      , Network.Minio.ListOps+                     , Network.Minio.PresignedOperations                      , Network.Minio.PutObject                      , Network.Minio.Sign.V4                      , Network.Minio.Utils                      , Network.Minio.XmlGenerator                      , Network.Minio.XmlParser   build-depends:       base >= 4.7 && < 5-                     , protolude >= 0.1.6 && < 0.2+                     , protolude >= 0.1.6+                     , aeson                      , async+                     , base64-bytestring                      , bytestring                      , case-insensitive                      , conduit@@ -61,10 +64,12 @@                      , time                      , transformers                      , transformers-base+                     , vector                      , xml-conduit   default-language:    Haskell2010   default-extensions:  FlexibleContexts                      , FlexibleInstances+                     , BangPatterns                      , MultiParamTypeClasses                      , MultiWayIf                      , NoImplicitPrelude@@ -84,7 +89,8 @@   main-is:             LiveServer.hs   ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010-  default-extensions:  FlexibleContexts+  default-extensions:  BangPatterns+                     , FlexibleContexts                      , FlexibleInstances                      , OverloadedStrings                      , NoImplicitPrelude@@ -103,6 +109,7 @@                      , Network.Minio.Data.Time                      , Network.Minio.Errors                      , Network.Minio.ListOps+                     , Network.Minio.PresignedOperations                      , Network.Minio.PutObject                      , Network.Minio.S3API                      , Network.Minio.Sign.V4@@ -115,8 +122,10 @@                      , Network.Minio.XmlParser.Test   build-depends:       base                      , minio-hs-                     , protolude >= 0.1.6 && < 0.2+                     , protolude >= 0.1.6+                     , aeson                      , async+                     , base64-bytestring                      , bytestring                      , case-insensitive                      , conduit@@ -148,6 +157,7 @@                      , time                      , transformers                      , transformers-base+                     , vector                      , xml-conduit   if !flag(live-test)     buildable: False@@ -158,8 +168,10 @@   main-is:             Spec.hs   build-depends:       base                      , minio-hs-                     , protolude >= 0.1.6 && < 0.2+                     , protolude >= 0.1.6+                     , aeson                      , async+                     , base64-bytestring                      , bytestring                      , case-insensitive                      , conduit@@ -191,10 +203,12 @@                      , time                      , transformers                      , transformers-base+                     , vector                      , xml-conduit   ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010-  default-extensions:  FlexibleContexts+  default-extensions:  BangPatterns+                     , FlexibleContexts                      , FlexibleInstances                      , OverloadedStrings                      , NoImplicitPrelude@@ -213,6 +227,7 @@                      , Network.Minio.Data.Time                      , Network.Minio.Errors                      , Network.Minio.ListOps+                     , Network.Minio.PresignedOperations                      , Network.Minio.PutObject                      , Network.Minio.S3API                      , Network.Minio.Sign.V4

@@ -14,17 +14,12 @@ -- limitations under the License. -- -{--Welcome to your custom Prelude-Export here everything that should always be in your library scope-For more info on what is exported by Protolude check:-https://github.com/sdiehl/protolude/blob/master/Symbols.md--} module Lib.Prelude     ( module Exports     , both      , format+    , formatBS     ) where  import           Protolude as Exports@@ -37,10 +32,12 @@ 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+format f args = toS $ TF.format f args++formatBS :: Params ps => TF.Format -> ps -> ByteString+formatBS f args = toS $ TF.format f args  -- import Data.Tuple as Exports (uncurry) 

@@ -14,72 +14,135 @@ -- limitations under the License. -- ++ module Network.Minio   ( +  -- * Connecting to object storage+  ---------------------------------     ConnectInfo(..)   , awsCI++  -- ** Connection helpers+  ------------------------   , awsWithRegionCI   , minioPlayCI   , minioCI +  -- * Minio Monad+  ----------------+  -- | The Minio monad provides connection-reuse, bucket-location+  -- caching, resource management and simpler error handling+  -- functionality. All actions on object storage are performed within+  -- this Monad.+   , Minio   , runMinio   , def -  -- * Error handling-  ------------------------  -- | Data types representing various errors that may occur while working-  -- with an object storage service.-  , MinioErr(..)-  , MErrV(..)-  , ServiceErr(..)--  -- * Data Types-  -----------------  -- | Data types representing various object store concepts.-  , Bucket-  , Object-  , BucketInfo(..)-  , ObjectInfo(..)-  , UploadInfo(..)-  , ObjectPartInfo(..)-  , UploadId-  , ObjectData(..)-  , CopyPartSource(..)-   -- * Bucket Operations   -----------------------  , listBuckets-  , getLocation-  , bucketExists++  -- ** Creation, removal and querying+  , Bucket   , makeBucket   , removeBucket+  , bucketExists+  , Region+  , getLocation +  -- ** Listing+  , BucketInfo(..)+  , listBuckets+  , ObjectInfo(..)   , listObjects+  , listObjectsV1+  , UploadId+  , UploadInfo(..)   , listIncompleteUploads+  , ObjectPartInfo(..)+  , listIncompleteParts +  -- ** Notifications+  , Notification(..)+  , NotificationConfig(..)+  , Arn+  , Event(..)+  , Filter(..)+  , FilterKey(..)+  , FilterRules(..)+  , FilterRule(..)+  , getBucketNotification+  , putBucketNotification+  , removeAllBucketNotification+   -- * Object Operations   ----------------------++  , Object++  -- ** File operations   , fGetObject   , fPutObject++  -- ** Conduit-based streaming operations   , putObject+  , getObject++  -- ** Server-side copying+  , CopyPartSource(..)   , copyObject-  , removeObject -  , getObject+  -- ** Querying   , statObject -  ) where+  -- ** Object removal functions+  , removeObject+  , removeIncompleteUpload +  -- * Presigned Operations+  -------------------------+  , UrlExpiry+  , presignedPutObjectUrl+  , presignedGetObjectUrl+  , presignedHeadObjectUrl++  -- ** Utilities for POST (browser) uploads+  , PostPolicy+  , PostPolicyError(..)+  , newPostPolicy+  , presignedPostPolicy+  , showPostPolicy++  -- *** Utilities to specify Post Policy conditions+  , PostPolicyCondition+  , ppCondBucket+  , ppCondContentLengthRange+  , ppCondContentType+  , ppCondKey+  , ppCondKeyStartsWith+  , ppCondSuccessActionStatus++  -- * Error handling+  -----------------------+  -- | Data types representing various errors that may occur while working+  -- with an object storage service.+  , MinioErr(..)+  , MErrV(..)+  , ServiceErr(..)++) where+ {- This module exports the high-level Minio API for object storage. -} -import qualified Data.Conduit as C-import qualified Data.Conduit.Binary as CB-import           Data.Default (def)-import qualified Data.Map as Map+import qualified Data.Conduit             as C+import qualified Data.Conduit.Binary      as CB+import qualified Data.Conduit.Combinators as CC+import           Data.Default             (def)+import qualified Data.Map                 as Map  import           Lib.Prelude @@ -139,11 +202,12 @@ -- configured in ConnectInfo, which is by default, the US Standard -- Region. makeBucket :: Bucket -> Maybe Region -> Minio ()-makeBucket bucket regionMay= do+makeBucket bucket regionMay = do   region <- maybe (asks $ connectRegion . mcConnInfo) return regionMay   putBucket bucket region   modify (Map.insert bucket region) +-- | Removes a bucket from the object store. removeBucket :: Bucket -> Minio () removeBucket bucket = do   deleteBucket bucket@@ -152,3 +216,10 @@ -- | Query the object store if a given bucket is present. bucketExists :: Bucket -> Minio Bool bucketExists = headBucket+++-- | Removes an ongoing multipart upload of an object.+removeIncompleteUpload :: Bucket -> Object -> Minio ()+removeIncompleteUpload bucket object = do+  uploads <- listIncompleteUploads bucket (Just object) False C.$$ CC.sinkList+  mapM_ (abortMultipartUpload bucket object) (uiUploadId <$> uploads)

@@ -36,9 +36,11 @@ import qualified Data.Char as C import qualified Data.Text as T import qualified Data.ByteString as B+ import           Network.HTTP.Conduit (Response) import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Types as HT+import Network.HTTP.Types.Header (hHost)  import           Lib.Prelude @@ -120,15 +122,25 @@                    (Map.lookup r awsRegionMap)               else return $ connectHost ci +  sha256Hash <- if | connectIsSecure ci ->+                       -- if secure connection+                       return "UNSIGNED-PAYLOAD" -  sha256Hash <- getPayloadSHA256Hash (riPayload ri)-  let newRi = ri { riPayloadHash = sha256Hash-                 , riHeaders = sha256Header sha256Hash : riHeaders ri+                   -- otherwise compute sha256+                   | otherwise -> getPayloadSHA256Hash (riPayload ri)++  let hostHeader = (hHost, formatBS "{}:{}" [connectHost ci,+                                             show $ connectPort ci])++      newRi = ri { riPayloadHash = Just sha256Hash+                 , riHeaders = hostHeader+                             : sha256Header sha256Hash+                             : riHeaders ri                  , riRegion = region                  }       newCi = ci { connectHost = regionHost } -  reqHeaders <- liftIO $ signV4 newCi newRi+  signHeaders <- liftIO $ signV4 newCi newRi Nothing    return NC.defaultRequest {       NC.method = riMethod newRi@@ -137,7 +149,7 @@     , NC.port = connectPort newCi     , NC.path = getPathFromRI newRi     , NC.queryString = HT.renderQuery False $ riQueryParams newRi-    , NC.requestHeaders = reqHeaders+    , NC.requestHeaders = riHeaders newRi ++ mkHeaderFromPairs signHeaders     , NC.requestBody = getRequestBody (riPayload newRi)     } 

@@ -34,6 +34,8 @@ import           Network.Minio.Errors import           Text.XML +import           GHC.Show (Show(..))+ import           Lib.Prelude  @@ -224,6 +226,14 @@   , lorCPrefixes :: [Text]   } deriving (Show, Eq) +-- | Represents result from a listing of objects version 1 in a bucket.+data ListObjectsV1Result = ListObjectsV1Result {+    lorHasMore' :: Bool+  , lorNextMarker :: Maybe Text+  , lorObjects' :: [ObjectInfo]+  , lorCPrefixes' :: [Text]+  } deriving (Show, Eq)+ -- | Represents information about an object. data ObjectInfo = ObjectInfo {     oiObject :: Object@@ -233,10 +243,10 @@   } 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+    -- | formatted like "\/sourceBucket\/sourceObject"+    cpSource :: Text+    -- | (0, 9) means first ten bytes of the source object+  , cpSourceRange :: Maybe (Int64, Int64)   , cpSourceIfMatch :: Maybe Text   , cpSourceIfNoneMatch :: Maybe Text   , cpSourceIfUnmodifiedSince :: Maybe UTCTime@@ -272,6 +282,106 @@   where     splits = T.splitOn "/" $ cpSource cps +-- | A data-type for events that can occur in the object storage+-- server. Reference:+-- https://docs.aws.amazon.com/AmazonS3/latest/dev/NotificationHowTo.html#supported-notification-event-types+data Event = ObjectCreated+           | ObjectCreatedPut+           | ObjectCreatedPost+           | ObjectCreatedCopy+           | ObjectCreatedMultipartUpload+           | ObjectRemoved+           | ObjectRemovedDelete+           | ObjectRemovedDeleteMarkerCreated+           | ReducedRedundancyLostObject+           deriving (Eq)++instance Show Event where+  show ObjectCreated                    = "s3:ObjectCreated:*"+  show ObjectCreatedPut                 = "s3:ObjectCreated:Put"+  show ObjectCreatedPost                = "s3:ObjectCreated:Post"+  show ObjectCreatedCopy                = "s3:ObjectCreated:Copy"+  show ObjectCreatedMultipartUpload     = "s3:ObjectCreated:MultipartUpload"+  show ObjectRemoved                    = "s3:ObjectRemoved:*"+  show ObjectRemovedDelete              = "s3:ObjectRemoved:Delete"+  show ObjectRemovedDeleteMarkerCreated = "s3:ObjectRemoved:DeleteMarkerCreated"+  show ReducedRedundancyLostObject      = "s3:ReducedRedundancyLostObject"++textToEvent :: Text -> Maybe Event+textToEvent t = case t of+  "s3:ObjectCreated:*"                   -> Just ObjectCreated+  "s3:ObjectCreated:Put"                 -> Just ObjectCreatedPut+  "s3:ObjectCreated:Post"                -> Just ObjectCreatedPost+  "s3:ObjectCreated:Copy"                -> Just ObjectCreatedCopy+  "s3:ObjectCreated:MultipartUpload"     -> Just ObjectCreatedMultipartUpload+  "s3:ObjectRemoved:*"                   -> Just ObjectRemoved+  "s3:ObjectRemoved:Delete"              -> Just ObjectRemovedDelete+  "s3:ObjectRemoved:DeleteMarkerCreated" -> Just ObjectRemovedDeleteMarkerCreated+  "s3:ReducedRedundancyLostObject"       -> Just ReducedRedundancyLostObject+  _                                      -> Nothing+++data Filter = Filter+  { fFilter :: FilterKey+  } deriving (Show, Eq)++instance Default Filter where+  def = Filter def++data FilterKey = FilterKey+  { fkKey :: FilterRules+  } deriving (Show, Eq)++instance Default FilterKey where+  def = FilterKey def++data FilterRules = FilterRules+  { frFilterRules :: [FilterRule]+  } deriving (Show, Eq)++instance Default FilterRules where+  def = FilterRules []++-- | A filter rule that can act based on the suffix or prefix of an+-- object. As an example, let's create two filter rules:+--+--    > let suffixRule = FilterRule "suffix" ".jpg"+--    > let prefixRule = FilterRule "prefix" "images/"+--+-- The `suffixRule` restricts the notification to be triggered only+-- for objects having a suffix of ".jpg", and the `prefixRule`+-- restricts it to objects having a prefix of "images/".+data FilterRule = FilterRule+  { frName :: Text+  , frValue :: Text+  } deriving (Show, Eq)++type Arn = Text++-- | A data-type representing the configuration for a particular+-- notification system. It could represent a Queue, Topic or Lambda+-- Function configuration.+data NotificationConfig = NotificationConfig+  { ncId :: Text+  , ncArn :: Arn+  , ncEvents :: [Event]+  , ncFilter :: Filter+  } deriving (Show, Eq)++-- | A data-type to represent bucket notification configuration. It is+-- a collection of queue, topic or lambda function configurations. The+-- structure of the types follow closely the XML representation+-- described at+-- <https://docs.aws.amazon.com/AmazonS3/latest/API/RESTBucketPUTnotification.html>+data Notification = Notification+  { nQueueConfigurations :: [NotificationConfig]+  , nTopicConfigurations :: [NotificationConfig]+  , nCloudFunctionConfigurations :: [NotificationConfig]+  } deriving (Eq, Show)++instance Default Notification where+  def = Notification [] [] []+ -- | Represents different kinds of payload that are used with S3 API -- requests. data Payload = PayloadBS ByteString@@ -289,19 +399,26 @@   , riQueryParams :: Query   , riHeaders :: [Header]   , riPayload :: Payload-  , riPayloadHash :: ByteString+  , riPayloadHash :: Maybe ByteString   , riRegion :: Maybe Region   , riNeedsLocation :: Bool   }  instance Default RequestInfo where-  def = RequestInfo HT.methodGet def def def def def "" def True+  def = RequestInfo HT.methodGet def def def def def Nothing def True  getPathFromRI :: RequestInfo -> ByteString-getPathFromRI ri = B.concat parts-  where-    objPart = maybe [] (\o -> ["/", encodeUtf8 o]) $ riObject ri-    parts = maybe ["/"] (\b -> "/" : encodeUtf8 b : objPart) $ riBucket ri+getPathFromRI ri =+  let+    b = riBucket ri+    o = riObject ri+    segments = map toS $ catMaybes $ b : bool [] [o] (isJust b)+  in+    B.concat ["/", B.intercalate "/" segments]++-- | Time to expire for a presigned URL. It interpreted as a number of+-- seconds. The maximum duration that can be specified is 7 days.+type UrlExpiry = Int  type RegionMap = Map.Map Bucket Region 

@@ -21,6 +21,7 @@   , awsDateFormat   , awsDateFormatBS   , awsParseTime+  , iso8601TimeFormat   ) where  @@ -43,3 +44,6 @@  awsParseTime :: [Char] -> Maybe UTCTime awsParseTime = Time.parseTimeM False Time.defaultTimeLocale "%Y%m%dT%H%M%SZ"++iso8601TimeFormat :: UTCTime -> [Char]+iso8601TimeFormat = Time.formatTime Time.defaultTimeLocale (Time.iso8601DateFormat $ Just "%T%QZ")

@@ -37,6 +37,7 @@            | MErrVXmlParse Text            | MErrVInvalidBucketName Text            | MErrVInvalidObjectName Text+           | MErrVInvalidUrlExpiry Int   deriving (Show, Eq)  instance Exception MErrV

@@ -40,6 +40,21 @@       when (lorHasMore res) $         loop (lorNextToken res) +-- | List objects in a bucket matching the given prefix. If recurse is+-- set to True objects matching prefix are recursively listed.+listObjectsV1 :: Bucket -> Maybe Text -> Bool -> C.Producer Minio ObjectInfo+listObjectsV1 bucket prefix recurse = loop Nothing+  where+    loop :: Maybe Text -> C.Producer Minio ObjectInfo+    loop nextMarker = do+      let+        delimiter = bool (Just "/") Nothing recurse++      res <- lift $ listObjectsV1' bucket prefix nextMarker delimiter Nothing+      CL.sourceList $ lorObjects' res+      when (lorHasMore' res) $+        loop (lorNextMarker res)+ -- | List incomplete uploads in a bucket matching the given prefix. If -- recurse is set to True incomplete uploads for the given prefix are -- recursively listed.

@@ -0,0 +1,281 @@+--+-- 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.PresignedOperations+  ( UrlExpiry+  , makePresignedUrl+  , presignedPutObjectUrl+  , presignedGetObjectUrl+  , presignedHeadObjectUrl++  , PostPolicyCondition(..)+  , ppCondBucket+  , ppCondContentLengthRange+  , ppCondContentType+  , ppCondKey+  , ppCondKeyStartsWith+  , ppCondSuccessActionStatus++  , PostPolicy(..)+  , PostPolicyError(..)+  , newPostPolicy+  , showPostPolicy+  , presignedPostPolicy+  ) where++import           Data.Aeson                ((.=))+import qualified Data.Aeson                as Json+import           Data.ByteString.Builder   (byteString, toLazyByteString)+import           Data.Default              (def)+import qualified Data.Map.Strict           as Map+import qualified Data.Text                 as T+import qualified Data.Time                 as Time+import qualified Network.HTTP.Types        as HT+import           Network.HTTP.Types.Header (hHost)++import           Lib.Prelude++import           Network.Minio.Data+import           Network.Minio.Data.Time+import           Network.Minio.Errors+import           Network.Minio.Sign.V4++-- | Generate a presigned URL. This function allows for advanced usage+-- - for simple cases prefer the `presigned*Url` functions.+--+-- If region is Nothing, it is picked up from the connection+-- information (no check of bucket existence is performed).+--+-- All extra query parameters or headers are signed, and therefore are+-- required to be sent when the generated URL is actually used.+makePresignedUrl :: UrlExpiry -> HT.Method -> Maybe Bucket -> Maybe Object+                 -> Maybe Region -> HT.Query -> HT.RequestHeaders+                 -> Minio ByteString+makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do+  when (expiry > 7*24*3600 || expiry < 0) $+    throwM $ MErrVInvalidUrlExpiry expiry++  ci <- asks mcConnInfo++  let+    host = formatBS "{}:{}" (connectHost ci, connectPort ci)+    hostHeader = (hHost, host)+    ri = def { riMethod = method+             , riBucket = bucket+             , riObject = object+             , riQueryParams = extraQuery+             , riHeaders = hostHeader : extraHeaders+             , riRegion = Just $ maybe (connectRegion ci) identity region+             }++  signPairs <- liftIO $ signV4 ci ri (Just expiry)++  let+    qpToAdd = (fmap . fmap) Just signPairs+    queryStr = HT.renderQueryBuilder True (riQueryParams ri ++ qpToAdd)+    scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci++  return $ toS $ toLazyByteString $+    scheme <> byteString host <> byteString (getPathFromRI ri) <> queryStr++-- | Generate a URL with authentication signature to PUT (upload) an+-- object. Any extra headers if passed, are signed, and so they are+-- required when the URL is used to upload data. This could be used,+-- for example, to set user-metadata on the object.+--+-- For a list of possible headers to pass, please refer to the PUT+-- object REST API AWS S3 documentation.+presignedPutObjectUrl :: Bucket -> Object -> UrlExpiry -> HT.RequestHeaders+                      -> Minio ByteString+presignedPutObjectUrl bucket object expirySeconds extraHeaders =+  makePresignedUrl expirySeconds HT.methodPut+  (Just bucket) (Just object) Nothing [] extraHeaders++-- | Generate a URL with authentication signature to GET (download) an+-- object. All extra query parameters and headers passed here will be+-- signed and are required when the generated URL is used. Query+-- parameters could be used to change the response headers sent by the+-- server. Headers can be used to set Etag match conditions among+-- others.+--+-- For a list of possible request parameters and headers, please refer+-- to the GET object REST API AWS S3 documentation.+presignedGetObjectUrl :: Bucket -> Object -> UrlExpiry -> HT.Query+                      -> HT.RequestHeaders -> Minio ByteString+presignedGetObjectUrl bucket object expirySeconds extraQuery extraHeaders =+  makePresignedUrl expirySeconds HT.methodGet+  (Just bucket) (Just object) Nothing extraQuery extraHeaders++-- | Generate a URL with authentication signature to make a HEAD+-- request on an object. This is used to fetch metadata about an+-- object. All extra headers passed here will be signed and are+-- required when the generated URL is used.+--+-- For a list of possible headers to pass, please refer to the HEAD+-- object REST API AWS S3 documentation.+presignedHeadObjectUrl :: Bucket -> Object -> UrlExpiry+                       -> HT.RequestHeaders -> Minio ByteString+presignedHeadObjectUrl bucket object expirySeconds extraHeaders =+  makePresignedUrl expirySeconds HT.methodHead+  (Just bucket) (Just object) Nothing [] extraHeaders++-- | Represents individual conditions in a Post Policy document.+data PostPolicyCondition = PPCStartsWith Text Text+                         | PPCEquals Text Text+                         | PPCRange Text Int64 Int64+                         deriving (Show, Eq)++instance Json.ToJSON PostPolicyCondition where+  toJSON (PPCStartsWith k v) = Json.toJSON ["starts-with", k, v]+  toJSON (PPCEquals k v) = Json.object [k .= v]+  toJSON (PPCRange k minVal maxVal) =+    Json.toJSON [Json.toJSON k, Json.toJSON minVal, Json.toJSON maxVal]++  toEncoding (PPCStartsWith k v) = Json.foldable ["starts-with", k, v]+  toEncoding (PPCEquals k v) = Json.pairs (k .= v)+  toEncoding (PPCRange k minVal maxVal) =+    Json.foldable [Json.toJSON k, Json.toJSON minVal, Json.toJSON maxVal]++-- | A PostPolicy is required to perform uploads via browser forms.+data PostPolicy = PostPolicy {+    expiration :: UTCTime+  , conditions :: [PostPolicyCondition]+  } deriving (Show, Eq)++instance Json.ToJSON PostPolicy where+  toJSON (PostPolicy e c) =+    Json.object $ [ "expiration" .= iso8601TimeFormat e+                  , "conditions" .= c+                  ]+  toEncoding (PostPolicy e c) =+    Json.pairs ("expiration" .= iso8601TimeFormat e <> "conditions" .= c)++-- | Possible validation errors when creating a PostPolicy.+data PostPolicyError = PPEKeyNotSpecified+                     | PPEBucketNotSpecified+                     | PPEConditionKeyEmpty+                     | PPERangeInvalid+                     deriving (Eq, Show)++-- | Set the bucket name that the upload should use.+ppCondBucket :: Bucket -> PostPolicyCondition+ppCondBucket = PPCEquals "bucket"++-- | Set the content length range constraint with minimum and maximum+-- byte count values.+ppCondContentLengthRange :: Int64 -> Int64+                         -> PostPolicyCondition+ppCondContentLengthRange = PPCRange "content-length-range"++-- | Set the content-type header for the upload.+ppCondContentType :: Text -> PostPolicyCondition+ppCondContentType = PPCEquals "Content-Type"++-- | Set the object name constraint for the upload.+ppCondKey :: Object -> PostPolicyCondition+ppCondKey = PPCEquals "key"++-- | Set the object name prefix constraint for the upload.+ppCondKeyStartsWith :: Object -> PostPolicyCondition+ppCondKeyStartsWith = PPCStartsWith "key"++-- | Status code that the S3-server should send on a successful POST+-- upload+ppCondSuccessActionStatus :: Int -> PostPolicyCondition+ppCondSuccessActionStatus n =+  PPCEquals "success_action_status" (show n)++-- | This function creates a PostPolicy after validating its+-- arguments.+newPostPolicy :: UTCTime -> [PostPolicyCondition]+              -> Either PostPolicyError PostPolicy+newPostPolicy expirationTime conds+  -- object name condition must be present+  | not $ any (keyEquals "key") conds =+      Left PPEKeyNotSpecified++  -- bucket name condition must be present+  | not $ any (keyEquals "bucket") conds =+      Left PPEBucketNotSpecified++  -- a condition with an empty key is invalid+  | any (keyEquals "") conds || any isEmptyRangeKey conds =+      Left PPEConditionKeyEmpty++  -- invalid range check+  | any isInvalidRange conds =+      Left PPERangeInvalid++  -- all good!+  | otherwise =+      return $ PostPolicy expirationTime conds++  where+    keyEquals k' (PPCStartsWith k _) = k == k'+    keyEquals k' (PPCEquals k _)     = k == k'+    keyEquals _ _                    = False++    isEmptyRangeKey (PPCRange k _ _) = k == ""+    isEmptyRangeKey _                = False++    isInvalidRange (PPCRange _ mi ma) = mi < 0 || mi > ma+    isInvalidRange _                  = False++-- | Convert Post Policy to a string (e.g. for printing).+showPostPolicy :: PostPolicy -> ByteString+showPostPolicy = toS . Json.encode++-- | Generate a presigned URL and POST policy to upload files via a+-- browser. On success, this function returns a URL and POST+-- form-data.+presignedPostPolicy :: PostPolicy+                    -> Minio (ByteString, Map.Map Text ByteString)+presignedPostPolicy p = do+  ci <- asks mcConnInfo+  signTime <- liftIO $ Time.getCurrentTime++  let+    extraConditions =+      [ PPCEquals "x-amz-date" (toS $ awsTimeFormat signTime)+      , PPCEquals "x-amz-algorithm" "AWS4-HMAC-SHA256"+      , PPCEquals "x-amz-credential"+        (T.intercalate "/" [connectAccessKey ci,+                            decodeUtf8 $ mkScope signTime region])+      ]+    ppWithCreds = p {+      conditions = conditions p ++ extraConditions+      }+    signData = signV4PostPolicy (showPostPolicy ppWithCreds)+               signTime ci++    -- compute form-data+    mkPair (PPCStartsWith k v) = Just (k, v)+    mkPair (PPCEquals k v)     = Just (k, v)+    mkPair _                   = Nothing+    formFromPolicy = Map.map toS $ Map.fromList $ catMaybes $+                     mkPair <$> conditions ppWithCreds+    formData = formFromPolicy `Map.union` signData++    -- compute POST upload URL+    bucket = Map.findWithDefault "" "bucket" formData+    scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci+    host = formatBS "{}:{}" (connectHost ci, connectPort ci)+    region = connectRegion ci++    url = toS $ toLazyByteString $ scheme <> byteString host <>+          byteString "/" <> byteString (toS bucket) <> byteString "/"++  return (url, formData)

@@ -25,21 +25,16 @@   ) where  -import qualified Data.ByteString as B import qualified Data.Conduit as C-import           Data.Conduit.Binary (sourceHandleRange) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Combinators as CC import qualified Data.Conduit.List as CL import qualified Data.List as List-import qualified Data.Map.Strict as Map  import           Lib.Prelude  import           Network.Minio.Data-import           Network.Minio.Data.Crypto import           Network.Minio.Errors-import           Network.Minio.ListOps import           Network.Minio.S3API import           Network.Minio.Utils @@ -117,35 +112,17 @@       | 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 ObjectPartInfo-                  -> Minio (Maybe PartTuple)-checkUploadNeeded payload n pmap = do-  (md5hash, pSize) <- case payload of-    PayloadBS bs -> return (hashMD5 bs, fromIntegral $ B.length bs)-    PayloadH h off size -> fmap (, size) $-      hashMD5FromSource $ sourceHandleRange h (Just $ fromIntegral off)-      (Just $ fromIntegral size)-  case Map.lookup n pmap of-    Nothing -> return Nothing-    Just (ObjectPartInfo _ etag size _) -> return $-      bool Nothing (Just (n, etag)) $-      md5hash == encodeUtf8 etag && size == pSize- parallelMultipartUpload :: Bucket -> Object -> FilePath -> Int64                         -> Minio ETag parallelMultipartUpload b o filePath size = do-  (uidMay, pmap) <- getExistingUpload b o--  -- get a new upload id if needed.-  uploadId <- maybe (newMultipartUpload b o []) return uidMay+  -- get a new upload id.+  uploadId <- newMultipartUpload b o []    let partSizeInfo = selectPartSizes size    -- perform upload with 10 threads   uploadedPartsE <- limitedMapConcurrently 10-                    (uploadPart pmap uploadId) partSizeInfo+                    (uploadPart uploadId) partSizeInfo    -- if there were any errors, rethrow exception.   mapM_ throwM $ lefts uploadedPartsE@@ -153,22 +130,17 @@   -- if we get here, all parts were successfully uploaded.   completeMultipartUpload b o uploadId $ rights uploadedPartsE   where-    uploadPart pmap uploadId (partNum, offset, sz) =+    uploadPart uploadId (partNum, offset, sz) =       withNewHandle filePath $ \h -> do         let payload = PayloadH h offset sz-        pInfoMay <- checkUploadNeeded payload partNum pmap-        maybe-          (putObjectPart b o uploadId partNum [] payload)-          return pInfoMay+        putObjectPart b o uploadId partNum [] payload  -- | Upload multipart object from conduit source sequentially sequentialMultipartUpload :: Bucket -> Object -> Maybe Int64                           -> C.Producer Minio ByteString -> Minio ETag sequentialMultipartUpload b o sizeMay src = do-  (uidMay, pmap) <- getExistingUpload b o--  -- get a new upload id if needed.-  uploadId <- maybe (newMultipartUpload b o []) return uidMay+  -- get a new upload id.+  uploadId <- newMultipartUpload b o []    -- upload parts in loop   let partSizes = selectPartSizes $ maybe maxObjectSize identity sizeMay@@ -176,35 +148,21 @@   uploadedParts <- src               C..| chunkBSConduit sizes               C..| CL.map PayloadBS-              C..| checkAndUpload uploadId pmap pnums+              C..| uploadPart' uploadId pnums               C.$$ CC.sinkList    -- complete multipart upload   completeMultipartUpload b o uploadId uploadedParts    where-    checkAndUpload _ _ [] = return ()-    checkAndUpload uid pmap (pn:pns) = do+    uploadPart' _ [] = return ()+    uploadPart' uid (pn:pns) = do       payloadMay <- C.await       case payloadMay of         Nothing -> return ()-        Just payload -> do partMay <- lift $ checkUploadNeeded payload pn pmap-                           pinfo <- maybe-                                    (lift $ putObjectPart b o uid pn [] payload)-                                    return partMay+        Just payload -> do pinfo <- lift $ putObjectPart b o uid pn [] payload                            C.yield pinfo-                           checkAndUpload uid pmap pns---- | Looks for incomplete uploads for an object. Returns the first one--- if there are many.-getExistingUpload :: Bucket -> Object-                  -> Minio (Maybe UploadId, Map.Map PartNumber 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 -> (opiNumber p, p)) parts)+                           uploadPart' uid pns  -- | Copy an object using single or multipart copy strategy. copyObjectInternal :: Bucket -> Object -> CopyPartSource

@@ -26,10 +26,13 @@   -- * Listing objects   --------------------   , ListObjectsResult(..)+  , ListObjectsV1Result(..)   , listObjects'+  , listObjectsV1'    -- * Retrieving buckets   , headBucket+   -- * Retrieving objects   -----------------------   , getObject'@@ -64,6 +67,23 @@   , deleteBucket   , deleteObject +  -- * Presigned Operations+  -----------------------------+  , module Network.Minio.PresignedOperations++  -- * Bucket Notifications+  -------------------------+  , Notification(..)+  , NotificationConfig(..)+  , Arn+  , Event(..)+  , Filter(..)+  , FilterKey(..)+  , FilterRules(..)+  , FilterRule(..)+  , getBucketNotification+  , putBucketNotification+  , removeAllBucketNotification   ) where  import           Control.Monad.Catch (catches, Handler(..))@@ -81,6 +101,7 @@ import           Network.Minio.Utils import           Network.Minio.XmlGenerator import           Network.Minio.XmlParser+import           Network.Minio.PresignedOperations   -- | Fetch all buckets from the service.@@ -144,6 +165,24 @@     return etag  -- | List objects in a bucket matching prefix up to delimiter,+-- starting from nextMarker.+listObjectsV1' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int+            -> Minio ListObjectsV1Result+listObjectsV1' bucket prefix nextMarker delimiter maxKeys = do+  resp <- executeRequest $ def { riMethod = HT.methodGet+                               , riBucket = Just bucket+                               , riQueryParams = mkOptionalParams params+                               }+  parseListObjectsV1Response $ NC.responseBody resp+  where+    params = [+        ("marker", nextMarker)+      , ("prefix", prefix)+      , ("delimiter", delimiter)+      , ("max-keys", show <$> maxKeys)+      ]++-- | List objects in a bucket matching prefix up to delimiter, -- starting from nextToken. listObjects' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int             -> Minio ListObjectsResult@@ -358,3 +397,26 @@                                    , riBucket = Just bucket                                    }       return $ NC.responseStatus resp == HT.ok200++-- | Set the notification configuration on a bucket.+putBucketNotification :: Bucket -> Notification -> Minio ()+putBucketNotification bucket ncfg =+  void $ executeRequest $ def { riMethod = HT.methodPut+                              , riBucket = Just bucket+                              , riQueryParams = [("notification", Nothing)]+                              , riPayload = PayloadBS $+                                            mkPutNotificationRequest ncfg+                              }++-- | Retrieve the notification configuration on a bucket.+getBucketNotification :: Bucket -> Minio Notification+getBucketNotification bucket = do+  resp <- executeRequest $ def { riMethod = HT.methodGet+                               , riBucket = Just bucket+                               , riQueryParams = [("notification", Nothing)]+                               }+  parseNotification $ NC.responseBody resp++-- | Remove all notifications configured on a bucket.+removeAllBucketNotification :: Bucket -> Minio ()+removeAllBucketNotification = flip putBucketNotification def

@@ -18,21 +18,27 @@   (     signV4   , signV4AtTime-  , getScope+  , signV4PostPolicy+  , mkScope   , getHeadersToSign-  , getCanonicalRequest+  , mkCanonicalRequest+  , mkStringToSign+  , mkSigningKey+  , computeSignature   , SignV4Data(..)   , debugPrintSignV4Data   ) where  import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8-import           Data.ByteString.Char8 (pack) import           Data.CaseInsensitive (mk) import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Time as Time+import qualified Data.ByteString.Base64 as Base64+import qualified Data.Map.Strict as Map import           Network.HTTP.Types (Header)+import qualified Network.HTTP.Types.Header as H  import           Lib.Prelude import           Network.Minio.Data@@ -40,35 +46,35 @@ import           Network.Minio.Data.Crypto import           Network.Minio.Data.Time +-- these headers are not included in the string to sign when signing a+-- request ignoredHeaders :: Set ByteString-ignoredHeaders = Set.fromList $ map CI.foldedCase [-  mk "Authorization",-  mk "Content-Type",-  mk "Content-Length",-  mk "User-Agent"-  ]+ignoredHeaders = Set.fromList $ map CI.foldedCase+                 [ H.hAuthorization+                 , H.hContentType+                 , H.hContentLength+                 , H.hUserAgent+                 ]  data SignV4Data = SignV4Data {     sv4SignTime :: UTCTime   , sv4Scope :: ByteString   , sv4CanonicalRequest :: ByteString   , sv4HeadersToSign :: [(ByteString, ByteString)]-  , sv4InputHeaders :: [Header]-  , sv4OutputHeaders :: [Header]+  , sv4Output :: [(ByteString, ByteString)]   , sv4StringToSign :: ByteString   , sv4SigningKey :: ByteString   } deriving (Show)  debugPrintSignV4Data :: SignV4Data -> IO ()-debugPrintSignV4Data (SignV4Data t s cr h2s ih oh sts sk) = do+debugPrintSignV4Data (SignV4Data t s cr h2s o sts sk) = do   B8.putStrLn "SignV4Data:"   B8.putStr "Timestamp: " >> print t   B8.putStr "Scope: " >> B8.putStrLn s   B8.putStrLn "Canonical Request:"   B8.putStrLn cr   B8.putStr "Headers to Sign: " >> print h2s-  B8.putStr "Input headers: " >> print ih-  B8.putStr "Output headers: " >> print oh+  B8.putStr "Output: " >> print o   B8.putStr "StringToSign: " >> B8.putStrLn sts   B8.putStr "SigningKey: " >> printBytes sk   B8.putStrLn "END of SignV4Data ========="@@ -81,94 +87,161 @@ -- request path, headers, query params and payload hash, generates an -- updated set of headers, including the x-amz-date header and the -- Authorization header, which includes the signature.-signV4 :: ConnectInfo -> RequestInfo-       -> IO [Header]-signV4 ci ri = do+signV4 :: ConnectInfo -> RequestInfo -> Maybe Int+       -> IO [(ByteString, ByteString)]+signV4 !ci !ri !expiry = do   timestamp <- Time.getCurrentTime-  let signData = signV4AtTime timestamp ci ri+  let signData = signV4AtTime timestamp ci ri expiry   -- debugPrintSignV4Data signData-  return $ sv4OutputHeaders signData+  return $ sv4Output signData  -- | Takes a timestamp, server params and request params and generates--- an updated list of headers.-signV4AtTime :: UTCTime -> ConnectInfo -> RequestInfo -> SignV4Data-signV4AtTime ts ci ri =-  SignV4Data ts scope canonicalRequest headersToSign (riHeaders ri) outHeaders stringToSign signingKey-  where-    outHeaders = authHeader : headersWithDate-    timeBS = awsTimeFormatBS ts-    dateHeader = (mk "X-Amz-Date", timeBS)-    hostHeader = (mk "host", encodeUtf8 $ format "{}:{}"-                   [connectHost ci, show $ connectPort ci])--    headersWithDate = dateHeader : hostHeader : riHeaders ri--    authHeader = (mk "Authorization", authHeaderValue)-+-- AWS Sign V4 data. For normal requests (i.e. without an expiry+-- time), the output is the list of headers to add to authenticate the+-- request.+--+-- If `expiry` is not Nothing, it is assumed that a presigned request+-- is being created. The expiry is interpreted as an integer number of+-- seconds. The output will be the list of query-parameters to add to+-- the request.+signV4AtTime :: UTCTime -> ConnectInfo -> RequestInfo -> Maybe Int+             -> SignV4Data+signV4AtTime ts ci ri expiry =+  let     region = maybe (connectRegion ci) identity $ riRegion ri+    scope = mkScope ts region+    accessKey = toS $ connectAccessKey ci+    secretKey = toS $ connectSecretKey ci -    scope = getScope ts region+    -- headers to be added to the request+    datePair = ("X-Amz-Date", awsTimeFormatBS ts)+    computedHeaders = riHeaders ri +++                      if isJust expiry+                      then []+                      else [(\(x, y) -> (mk x, y)) datePair]+    headersToSign = getHeadersToSign computedHeaders+    signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign -    authHeaderValue = B.concat [-      "AWS4-HMAC-SHA256 Credential=",-      encodeUtf8 (connectAccessKey ci), "/", scope,-      ", SignedHeaders=", signedHeaders,-      ", Signature=", signature-      ]+    -- query-parameters to be added before signing for presigned URLs+    -- (i.e. when `isJust expiry`)+    authQP = [ ("X-Amz-Algorithm", "AWS4-HMAC-SHA256")+             , ("X-Amz-Credential", B.concat [accessKey, "/", scope])+             , datePair+             , ("X-Amz-Expires", maybe "" show expiry)+             , ("X-Amz-SignedHeaders", signedHeaderKeys)+             ]+    finalQP = riQueryParams ri +++              if isJust expiry+              then (fmap . fmap) Just authQP+              else [] -    headersToSign = getHeadersToSign headersWithDate+    -- 1. compute canonical request+    canonicalRequest = mkCanonicalRequest (ri {riQueryParams = finalQP})+                       headersToSign -    signedHeaders = B.intercalate ";" $ map fst headersToSign+    -- 2. compute string to sign+    stringToSign = mkStringToSign ts scope canonicalRequest -    signature = digestToBase16 $ hmacSHA256 stringToSign signingKey+    -- 3.1 compute signing key+    signingKey = mkSigningKey ts region secretKey -    signingKey = hmacSHA256RawBS "aws4_request"-               . hmacSHA256RawBS "s3"-               . hmacSHA256RawBS (encodeUtf8 region)-               . hmacSHA256RawBS (awsDateFormatBS ts)-               $ B.concat ["AWS4", encodeUtf8 $ connectSecretKey ci]+    -- 3.2 compute signature+    signature = computeSignature stringToSign signingKey -    stringToSign  = B.intercalate "\n"-      [ "AWS4-HMAC-SHA256"-      , timeBS+    -- 4. compute auth header+    authValue = B.concat+      [ "AWS4-HMAC-SHA256 Credential="+      , accessKey+      , "/"       , scope-      , hashSHA256 canonicalRequest+      , ", SignedHeaders="+      , signedHeaderKeys+      , ", Signature="+      , signature       ]+    authHeader = (H.hAuthorization, authValue) -    canonicalRequest = getCanonicalRequest ri headersToSign+    -- finally compute output pairs+    output = if isJust expiry+             then ("X-Amz-Signature", signature) : authQP+             else [(\(x, y) -> (CI.foldedCase x, y)) authHeader,+                   datePair] +  in+    SignV4Data ts scope canonicalRequest headersToSign output+    stringToSign signingKey -getScope :: UTCTime -> Region -> ByteString-getScope ts region = B.intercalate "/" [-  pack $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts,-  encodeUtf8 region, "s3", "aws4_request"++mkScope :: UTCTime -> Region -> ByteString+mkScope ts region = B.intercalate "/"+  [ toS $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts+  , toS region+  , "s3"+  , "aws4_request"   ]  getHeadersToSign :: [Header] -> [(ByteString, ByteString)]-getHeadersToSign h =-  sort $+getHeadersToSign !h =   filter (flip Set.notMember ignoredHeaders . fst) $   map (\(x, y) -> (CI.foldedCase x, stripBS y)) h -getCanonicalRequest :: RequestInfo -> [(ByteString, ByteString)] -> ByteString-getCanonicalRequest ri headersForSign = B.intercalate "\n" [-  riMethod ri,-  uriEncode False path,-  canonicalQueryString,-  canonicalHeaders,-  signedHeaders,-  riPayloadHash ri-  ]-  where-    path = getPathFromRI ri-+mkCanonicalRequest :: RequestInfo -> [(ByteString, ByteString)]+                    -> ByteString+mkCanonicalRequest !ri !headersForSign =+  let     canonicalQueryString = B.intercalate "&" $       map (\(x, y) -> B.concat [x, "=", y]) $       sort $ map (\(x, y) ->                     (uriEncode True x, maybe "" (uriEncode True) y)) $       riQueryParams ri +    sortedHeaders = sort headersForSign+     canonicalHeaders = B.concat $-      map (\(x, y) -> B.concat [x, ":", y, "\n"]) headersForSign+      map (\(x, y) -> B.concat [x, ":", y, "\n"]) sortedHeaders -    signedHeaders = B.intercalate ";" $ map fst headersForSign+    signedHeaders = B.intercalate ";" $ map fst sortedHeaders++  in+    B.intercalate "\n"+    [ riMethod ri+    , uriEncode False $ getPathFromRI ri+    , canonicalQueryString+    , canonicalHeaders+    , signedHeaders+    , maybe "UNSIGNED-PAYLOAD" identity $ riPayloadHash ri+    ]++mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString+mkStringToSign ts !scope !canonicalRequest = B.intercalate "\n"+                                             [ "AWS4-HMAC-SHA256"+                                             , awsTimeFormatBS ts+                                             , scope+                                             , hashSHA256 canonicalRequest+                                             ]++mkSigningKey :: UTCTime -> Region -> ByteString -> ByteString+mkSigningKey ts region !secretKey = hmacSHA256RawBS "aws4_request"+                                  . hmacSHA256RawBS "s3"+                                  . hmacSHA256RawBS (toS region)+                                  . hmacSHA256RawBS (awsDateFormatBS ts)+                                  $ B.concat ["AWS4", secretKey]++computeSignature :: ByteString -> ByteString -> ByteString+computeSignature !toSign !key = digestToBase16 $ hmacSHA256 toSign key++-- | Takes a validated Post Policy JSON bytestring, the signing time,+-- and ConnInfo and returns form-data for the POST upload containing+-- just the signature and the encoded post-policy.+signV4PostPolicy :: ByteString -> UTCTime -> ConnectInfo+                 -> Map.Map Text ByteString+signV4PostPolicy !postPolicyJSON !signTime !ci =+  let+    stringToSign = Base64.encode postPolicyJSON+    region = connectRegion ci+    signingKey = mkSigningKey signTime region $ toS $ connectSecretKey ci+    signature = computeSignature stringToSign signingKey+  in+    Map.fromList [ ("x-amz-signature", signature)+                 , ("policy", stringToSign)+                 ]

@@ -35,7 +35,9 @@ import qualified Network.HTTP.Types as HT import qualified Network.HTTP.Types.Header as Hdr import qualified System.IO as IO+import           Data.CaseInsensitive (mk) + import           Lib.Prelude  import           Network.Minio.XmlParser (parseErrResponse)@@ -87,6 +89,8 @@       R.release rkey       return resE +mkHeaderFromPairs :: [(ByteString, ByteString)] -> [HT.Header]+mkHeaderFromPairs = map ((\(x, y) -> (mk x, y)))  lookupHeader :: HT.HeaderName -> [HT.Header] -> Maybe ByteString lookupHeader hdr = headMay . map snd . filter (\(h, _) -> h == hdr)

@@ -17,12 +17,13 @@ module Network.Minio.XmlGenerator   ( mkCreateBucketConfig   , mkCompleteMultipartUploadRequest+  , mkPutNotificationRequest   ) where   import qualified Data.ByteString.Lazy as LBS-import qualified Data.Map as M-import qualified Data.Text as T+import qualified Data.Map             as M+import qualified Data.Text            as T import           Text.XML  import           Lib.Prelude@@ -55,3 +56,47 @@                                  [NodeContent etag]                                ]     cmur = Document (Prologue [] Nothing []) root []++-- Simplified XML representation without element attributes.+data XNode = XNode Text [XNode]+           | XLeaf Text Text+  deriving (Eq, Show)++toXML :: XNode -> ByteString+toXML node = LBS.toStrict $ renderLBS def $+  Document (Prologue [] Nothing []) (xmlNode node) []+  where+    xmlNode :: XNode -> Element+    xmlNode (XNode name nodes)   = Element (s3Name name) M.empty $+                                   map (NodeElement . xmlNode) nodes+    xmlNode (XLeaf name content) = Element (s3Name name) M.empty+                                   [NodeContent content]++class ToXNode a where+  toXNode :: a -> XNode++instance ToXNode Event where+  toXNode = XLeaf "Event" . show++instance ToXNode Notification where+  toXNode (Notification qc tc lc) = XNode "NotificationConfiguration" $+    map (toXNodesWithArnName "QueueConfiguration" "Queue") qc +++    map (toXNodesWithArnName "TopicConfiguration" "Topic") tc +++    map (toXNodesWithArnName "CloudFunctionConfiguration" "CloudFunction") lc++toXNodesWithArnName :: Text -> Text -> NotificationConfig -> XNode+toXNodesWithArnName eltName arnName (NotificationConfig id arn events fRule) =+  XNode eltName $ [XLeaf "Id" id, XLeaf arnName arn] ++ map toXNode events +++  [toXNode fRule]++instance ToXNode Filter where+  toXNode (Filter (FilterKey (FilterRules rules))) =+    XNode "Filter" [XNode "S3Key" (map getFRXNode rules)]++getFRXNode :: FilterRule -> XNode+getFRXNode (FilterRule n v) = XNode "FilterRule" [ XLeaf "Name" n+                                                 , XLeaf "Value" v+                                                 ]++mkPutNotificationRequest :: Notification -> ByteString+mkPutNotificationRequest = toXML . toXNode

@@ -21,18 +21,20 @@   , parseCompleteMultipartUploadResponse   , parseCopyObjectResponse   , parseListObjectsResponse+  , parseListObjectsV1Response   , parseListUploadsResponse   , parseListPartsResponse   , parseErrResponse+  , parseNotification   ) where  import           Control.Monad.Trans.Resource-import           Data.List (zip3, zip4)-import qualified Data.Text as T-import           Data.Text.Read (decimal)+import           Data.List                    (zip3, zip4)+import qualified Data.Text                    as T+import           Data.Text.Read               (decimal) import           Data.Time import           Text.XML-import           Text.XML.Cursor hiding (bool)+import           Text.XML.Cursor              hiding (bool)  import           Lib.Prelude @@ -55,7 +57,8 @@                . T.unpack  parseDecimal :: (MonadThrow m, Integral a) => Text -> m a-parseDecimal numStr = either (throwM . MErrVXmlParse . show) return $ fst <$> decimal numStr+parseDecimal numStr = either (throwM . MErrVXmlParse . show) return $+                      fst <$> decimal numStr  parseDecimals :: (MonadThrow m, Integral a) => [Text] -> m [a] parseDecimals numStr = forM numStr parseDecimal@@ -86,15 +89,13 @@   return $ bool "us-east-1" region $ region /= ""  -- | Parse the response XML of an newMultipartUpload call.-parseNewMultipartUpload :: (MonadThrow m)-                        => LByteString -> m UploadId+parseNewMultipartUpload :: (MonadThrow m) => LByteString -> m UploadId parseNewMultipartUpload xmldata = do   r <- parseRoot xmldata   return $ T.concat $ r $// s3Elem "UploadId" &/ content  -- | Parse the response XML of completeMultipartUpload call.-parseCompleteMultipartUploadResponse :: (MonadThrow m)-                                     => LByteString -> m ETag+parseCompleteMultipartUploadResponse :: (MonadThrow m) => LByteString -> m ETag parseCompleteMultipartUploadResponse xmldata = do   r <- parseRoot xmldata   return $ T.concat $ r $// s3Elem "ETag" &/ content@@ -109,9 +110,36 @@   mtime <- parseS3XMLTime mtimeStr   return (T.concat $ r $// s3Elem "ETag" &/ content, mtime) +-- | Parse the response XML of a list objects v1 call.+parseListObjectsV1Response :: (MonadThrow m)+                         => LByteString -> m ListObjectsV1Result+parseListObjectsV1Response xmldata = do+  r <- parseRoot xmldata+  let+    hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content)++    nextMarker = headMay $ r $/ s3Elem "NextMarker" &/ content++    prefixes = r $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ content++    keys = r $/ s3Elem "Contents" &/ s3Elem "Key" &/ content+    modTimeStr = r $/ s3Elem "Contents" &/ s3Elem "LastModified" &/ content+    etagsList = r $/ s3Elem "Contents" &/ s3Elem "ETag" &/ content+    -- if response xml contains empty etag response fill them with as+    -- many empty Text for the zip4 below to work as intended.+    etags = etagsList ++ repeat ""+    sizeStr = r $/ s3Elem "Contents" &/ s3Elem "Size" &/ content++  modTimes <- mapM parseS3XMLTime modTimeStr+  sizes <- parseDecimals sizeStr++  let+    objects = map (uncurry4 ObjectInfo) $ zip4 keys modTimes etags sizes++  return $ ListObjectsV1Result hasMore nextMarker objects prefixes+ -- | Parse the response XML of a list objects call.-parseListObjectsResponse :: (MonadThrow m)-                         => LByteString -> m ListObjectsResult+parseListObjectsResponse :: (MonadThrow m) => LByteString -> m ListObjectsResult parseListObjectsResponse xmldata = do   r <- parseRoot xmldata   let@@ -138,8 +166,7 @@   return $ ListObjectsResult hasMore nextToken objects prefixes  -- | Parse the response XML of a list incomplete multipart upload call.-parseListUploadsResponse :: (MonadThrow m)-                         => LByteString -> m ListUploadsResult+parseListUploadsResponse :: (MonadThrow m) => LByteString -> m ListUploadsResult parseListUploadsResponse xmldata = do   r <- parseRoot xmldata   let@@ -158,8 +185,7 @@    return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes -parseListPartsResponse :: (MonadThrow m)-                       => LByteString -> m ListPartsResult+parseListPartsResponse :: (MonadThrow m) => LByteString -> m ListPartsResult parseListPartsResponse xmldata = do   r <- parseRoot xmldata   let@@ -182,10 +208,35 @@   return $ ListPartsResult hasMore (listToMaybe nextPartNum) partInfos  -parseErrResponse :: (MonadThrow m)-                 => LByteString -> m ServiceErr+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++parseNotification :: (MonadThrow m) => LByteString -> m Notification+parseNotification xmldata = do+  r <- parseRoot xmldata+  let qcfg = map node $ r $/ s3Elem "QueueConfiguration"+      tcfg = map node $ r $/ s3Elem "TopicConfiguration"+      lcfg = map node $ r $/ s3Elem "CloudFunctionConfiguration"+  Notification <$> (mapM (parseNode "Queue") qcfg)+    <*> (mapM (parseNode "Topic") tcfg)+    <*> (mapM (parseNode "CloudFunction") lcfg)+  where++    getFilterRule c =+      let name = T.concat $ c $/ s3Elem "Name" &/ content+          value = T.concat $ c $/ s3Elem "Value" &/ content+      in FilterRule name value++    parseNode arnName nodeData = do+      let c = fromNode nodeData+          id = T.concat $ c $/ s3Elem "Id" &/ content+          arn = T.concat $ c $/ s3Elem arnName &/ content+          events = catMaybes $ map textToEvent $ c $/ s3Elem "Event" &/ content+          rules = c $/ s3Elem "Filter" &/ s3Elem "S3Key" &/+                  s3Elem "FilterRule" &| getFilterRule+      return $ NotificationConfig id arn events+        (Filter $ FilterKey $ FilterRules rules)

@@ -14,30 +14,34 @@ -- limitations under the License. -- -import qualified Test.QuickCheck as Q+import qualified Test.QuickCheck                       as Q import           Test.Tasty import           Test.Tasty.HUnit-import           Test.Tasty.QuickCheck as QC+import           Test.Tasty.QuickCheck                 as QC  import           Lib.Prelude -import           System.Directory (getTemporaryDirectory)-import qualified System.IO as SIO+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 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.Map.Strict                       as Map+import qualified Data.Text                             as T+import qualified Data.Time                             as Time+import qualified Network.HTTP.Client.MultipartFormData as Form+import qualified Network.HTTP.Conduit                  as NC+import qualified Network.HTTP.Types                    as HT+import           System.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@@ -92,76 +96,8 @@     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 @?= MErrVInvalidBucketName "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" $+lowLevelMultipartTest :: TestTree+lowLevelMultipartTest = funTestWithBucket "Low-level Multipart Test" $     \step bucket -> do       -- low-level multipart operation tests.       let object = "newmpupload"@@ -182,21 +118,24 @@       void $ completeMultipartUpload bucket object uid [partInfo]        destFile <- mkRandFile 0-      step $ "Retrieve the created object and check size"+      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"+      step  "Cleanup actions"       removeObject bucket object +putObjectNoSizeTest :: TestTree+putObjectNoSizeTest = funTestWithBucket "PutObject of conduit source with no size" $+  \step bucket -> do       -- putObject test (conduit source, no size specified)       let obj = "mpart"-          mb100 = 100 * 1024 * 1024+          mb70 = 70 * 1024 * 1024        step "Prepare for putObject with from source without providing size."-      rFile <- mkRandFile mb100+      rFile <- mkRandFile mb70        step "Upload multipart file."       putObject bucket obj (CB.sourceFile rFile) Nothing@@ -205,57 +144,103 @@       destFile <- mkRandFile 0       fGetObject bucket obj destFile       gotSize <- withNewHandle destFile getFileSize-      liftIO $ gotSize == Right (Just mb100) @?+      liftIO $ gotSize == Right (Just mb70) @?         "Wrong file size of put file after getting" -      step $ "Cleanup actions"+      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)+highLevelListingTest :: TestTree+highLevelListingTest = funTestWithBucket "High-level listObjects Test" $+  \step bucket -> do+      step "High-level listObjects Test"+      step "put 3 objects"+      let expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3"]+      forM_ expectedObjects $+        \obj -> fPutObject bucket obj "/etc/lsb-release" -      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 "High-level listing of objects"+      objects <- listObjects bucket Nothing True $$ sinkList -      step $ "Cleanup actions"-      removeObject bucket obj+      liftIO $ assertEqual "Objects match failed!" (sort expectedObjects)+        (map oiObject objects) -      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 "High-level listing of objects (version 1)"+      objects <- listObjectsV1 bucket Nothing True $$ sinkList +      step "Cleanup actions"+      forM_ expectedObjects $+        \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+      -- Minio server behaviour changed to list no incomplete uploads,+      -- so the check below reflects this; this test is expected to+      -- fail on AWS S3.+      liftIO $ length uploads @?= 0+       step "cleanup"-      removeObject bucket "big"+      forM_ uploads $ \(UploadInfo _ uid _ _) ->+                        abortMultipartUpload bucket object uid +      step "High-level listIncompleteParts Test"+      let mb5 = 5 * 1024 * 1024 -  , funTestWithBucket "Listing Test" $ \step bucket -> do+      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 mb5+      h <- liftIO $ SIO.openBinaryFile inputFile SIO.ReadMode+      forM_ [1..10] $ \pnum ->+        putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5++      step "fetch list parts"+      incompleteParts <- listIncompleteParts bucket object uid $$ sinkList+      liftIO $ length incompleteParts @?= 10++      step "cleanup"+      abortMultipartUpload bucket object uid++listingTest :: TestTree+listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do       step "listObjects' test"       step "put 10 objects"+      let objects = (\s ->T.concat ["lsb-release", T.pack (show s)]) <$> [1..10::Int]+       forM_ [1..10::Int] $ \s ->         fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release"        step "Simple list"       res <- listObjects' bucket Nothing Nothing Nothing Nothing+      let expectedObjects = sort objects+      liftIO $ assertEqual "Objects match failed!" expectedObjects+        (map oiObject $ lorObjects res)++      step "Simple list version 1"+      res <- listObjectsV1' bucket Nothing Nothing Nothing Nothing       let expected = sort $ map (T.concat .                           ("lsb-release":) .                           (\x -> [x]) .                           T.pack .                           show) [1..10::Int]       liftIO $ assertEqual "Objects match failed!" expected-        (map oiObject $ lorObjects res)+        (map oiObject $ lorObjects' res)        step "Cleanup actions"-      forM_ [1..10::Int] $ \s -> deleteObject bucket (T.concat ["lsb-release", T.pack (show s)])+      forM_ objects $ \obj -> deleteObject bucket obj        step "listIncompleteUploads' test"-      let object = "newmpupload"       step "create 10 multipart uploads"+      let object = "newmpupload"       forM_ [1..10::Int] $ \_ -> do         uid <- newMultipartUpload bucket object []         liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")@@ -273,87 +258,75 @@         \(_, uid, _) -> abortMultipartUpload bucket object uid        step "Basic listIncompleteParts Test"-      let-        object = "newmpupload"-        mb15 = 15 * 1024 * 1024+      let mb5 = 5 * 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+      inputFile <- mkRandFile mb5       h <- liftIO $ SIO.openBinaryFile inputFile SIO.ReadMode       forM_ [1..10] $ \pnum ->-        putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb15+        putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5        step "fetch list parts"       listPartsResult <- listIncompleteParts' bucket object uid Nothing Nothing-      -- Minio server behaviour changed to list no incomplete uploads,-      -- so the check below reflects this; this test is expected to-      -- fail on AWS S3.-      liftIO $ (length $ lprParts listPartsResult) @?= 0+      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)+liveServerUnitTests :: TestTree+liveServerUnitTests = testGroup "Unit tests against a live server"+  [ basicTests+  , listingTest+  , highLevelListingTest+  , lowLevelMultipartTest+  , putObjectNoSizeTest+  , funTestWithBucket "Multipart Tests" $+    \step bucket -> do+      step "Prepare for putObjectInternal with non-seekable file, with size."+      step "Upload multipart file."+      let mb80 = 80 * 1024 * 1024+          obj = "mpart" -      step "Cleanup actions"-      forM_ expected $-        \obj -> removeObject bucket obj+      void $ putObjectInternal bucket obj $ ODFile "/dev/zero" (Just mb80) -      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 "Retrieve and verify file size"+      destFile <- mkRandFile 0+      fGetObject bucket obj destFile+      gotSize <- withNewHandle destFile getFileSize+      liftIO $ gotSize == Right (Just mb80) @?+        "Wrong file size of put file after getting" -      step "High-level listing of incomplete multipart uploads"-      uploads <- (listIncompleteUploads bucket Nothing True) $$ sinkList-      -- Minio server behaviour changed to list no incomplete uploads,-      -- so the check below reflects this; this test is expected to-      -- fail on AWS S3.-      liftIO $ (length uploads) @?= 0+      step "Cleanup actions"+      removeObject bucket obj        step "cleanup"-      forM_ uploads $ \(UploadInfo _ uid _ _) ->-                        abortMultipartUpload bucket object uid+      removeObject bucket "big" -      step "High-level listIncompleteParts Test"-      let-        object = "newmpupload"-        mb15 = 15 * 1024 * 1024+      step "Prepare for removeIncompleteUpload"+      -- low-level multipart operation tests.+      let object = "newmpupload"+          kb5 = 5 * 1024 -      step "create a multipart upload"+      step "create new multipart upload"       uid <- newMultipartUpload bucket object []-      liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")+      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+      randFile <- mkRandFile kb5 -      step "fetch list parts"-      incompleteParts <- (listIncompleteParts bucket object uid) $$ sinkList-      -- Minio server behaviour changed to list no incomplete uploads,-      -- so the check below reflects this; this test is expected to-      -- fail on AWS S3.-      liftIO $ (length incompleteParts) @?= 0+      step "upload 2 parts"+      forM_ [1,2] $ \partNum -> do+        h <- liftIO $ SIO.openBinaryFile randFile SIO.ReadMode+        void $ putObjectPart bucket object uid partNum [] $ PayloadH h 0 kb5 -      step "cleanup"-      abortMultipartUpload bucket object uid+      step "remove ongoing upload"+      removeIncompleteUpload bucket object+      uploads <- listIncompleteUploads bucket (Just object) False C.$$ sinkList+      liftIO $ (null uploads) @? "removeIncompleteUploads didn't complete successfully" +   , funTestWithBucket "copyObject related tests" $ \step bucket -> do       step "copyObjectSingle basic tests"       let object = "xxx"@@ -392,25 +365,25 @@        step "create new multipart upload"       uid <- newMultipartUpload bucket copyObj []-      liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")+      liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."        step "put object parts 1-3"-      let cps = def {cpSource = format "/{}/{}" [bucket, srcObj]}+      let cps' = def {cpSource = format "/{}/{}" [bucket, srcObj]}       parts <- forM [1..3] $ \p -> do-        (etag, _) <- copyObjectPart bucket copyObj cps{+        (etag', _) <- copyObjectPart bucket copyObj cps'{           cpSourceRange = Just ((p-1)*mb5, (p-1)*mb5 + (mb5 - 1))           } uid (fromIntegral p) []-        return $ (fromIntegral p, etag)+        return (fromIntegral p, etag')        step "complete multipart"       void $ completeMultipartUpload bucket copyObj uid parts        step "verify copied object size"-      (ObjectInfo _ _ _ s) <- headObject bucket copyObj+      (ObjectInfo _ _ _ s') <- headObject bucket copyObj -      liftIO $ (s == mb15) @? "Size failed to match"+      liftIO $ (s' == mb15) @? "Size failed to match" -      step $ "Cleanup actions"+      step "Cleanup actions"       removeObject bucket srcObj       removeObject bucket copyObj @@ -428,15 +401,14 @@         copyObject bucket cp def{cpSource = format "/{}/{}" [bucket, src]}        step "verify uploaded objects"-      uploadedSizes <- fmap (fmap oiSize) $ forM copyObjs (headObject bucket)+      uploadedSizes <- fmap oiSize <$> forM copyObjs (headObject bucket)        liftIO $ (sizes == uploadedSizes) @? "Uploaded obj sizes failed to match" -      forM_ (concat [srcs, copyObjs]) (removeObject bucket)+      forM_ (srcs ++ copyObjs) (removeObject bucket)        step "copyObject with offset test "       let src = "XXX"-          copyObj = "XXXCopy"           size = 15 * 1024 * 1024        step "Prepare"@@ -454,4 +426,201 @@       liftIO $ (cSize == 10 * 1024 * 1024) @? "Uploaded obj size mismatched!"        forM_ [src, copyObj] (removeObject bucket)++  , presignedUrlFunTest+  , presignedPostPolicyFunTest   ]++basicTests :: TestTree+basicTests = 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 @?= MErrVInvalidBucketName "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++presignedUrlFunTest :: TestTree+presignedUrlFunTest = funTestWithBucket "presigned Url tests" $+  \step bucket -> do+    let obj = "mydir/myput"+        obj2 = "mydir1/myfile1"++    -- manager for http requests+    mgr <- liftIO $ NC.newManager NC.tlsManagerSettings++    step "PUT object presigned URL - makePresignedUrl"+    putUrl <- makePresignedUrl 3600 HT.methodPut (Just bucket)+           (Just obj) (Just "us-east-1") [] []++    let size1 = 1000 :: Int64+    inputFile <- mkRandFile size1++    -- attempt to upload using the presigned URL+    putResp <- putR size1 inputFile mgr putUrl+    liftIO $ (NC.responseStatus putResp == HT.status200) @?+      "presigned PUT failed"++    step "GET object presigned URL - makePresignedUrl"+    getUrl <- makePresignedUrl 3600 HT.methodGet (Just bucket)+           (Just obj) (Just "us-east-1") [] []++    getResp <- getR mgr getUrl+    liftIO $ (NC.responseStatus getResp == HT.status200) @?+      "presigned GET failed"++    -- read content from file to compare with response above+    bs <- CB.sourceFile inputFile $$ CB.sinkLbs+    liftIO $ (bs == NC.responseBody getResp) @?+      "presigned put and get got mismatched data"++    step "PUT object presigned - presignedPutObjectURL"+    putUrl2 <- presignedPutObjectUrl bucket obj2 3600 []++    let size2 = 1200+    testFile <- mkRandFile size2++    putResp2 <- putR size2 testFile mgr putUrl2+    liftIO $ (NC.responseStatus putResp2 == HT.status200) @?+      "presigned PUT failed (presignedPutObjectUrl)"++    step "HEAD object presigned URL - presignedHeadObjectUrl"+    headUrl <- presignedHeadObjectUrl bucket obj2 3600 []++    headResp <- do req <- NC.parseRequest $ toS headUrl+                   NC.httpLbs (req {NC.method = HT.methodHead}) mgr+    liftIO $ (NC.responseStatus headResp == HT.status200) @?+      "presigned HEAD failed (presignedHeadObjectUrl)"++    -- check that header info is accurate+    let h = Map.fromList $ NC.responseHeaders headResp+        cLen = Map.findWithDefault "0" HT.hContentLength h+    liftIO $ (cLen == show size2) @? "Head req returned bad content length"++    step "GET object presigned URL - presignedGetObjectUrl"+    getUrl2 <- presignedGetObjectUrl bucket obj2 3600 [] []++    getResp2 <- getR mgr getUrl2+    liftIO $ (NC.responseStatus getResp2 == HT.status200) @?+      "presigned GET failed (presignedGetObjectUrl)"++    -- read content from file to compare with response above+    bs2 <- CB.sourceFile testFile $$ CB.sinkLbs+    liftIO $ (bs2 == NC.responseBody getResp2) @?+      "presigned put and get got mismatched data (presigned*Url)"+++    mapM_ (removeObject bucket) [obj, obj2]+  where+    putR size filePath mgr url = do+      req <- NC.parseRequest $ toS url+      let req' = req { NC.method = HT.methodPut+                     , NC.requestBody = NC.requestBodySource size $+                                        CB.sourceFile filePath}+      NC.httpLbs req' mgr++    getR mgr url = do+      req <- NC.parseRequest $ toS url+      NC.httpLbs req mgr++presignedPostPolicyFunTest :: TestTree+presignedPostPolicyFunTest = funTestWithBucket "Presigned Post Policy tests" $+  \step bucket -> do++    step "presignedPostPolicy basic test"+    now <- liftIO $ Time.getCurrentTime++    let key = "presignedPostPolicyTest/myfile"+        policyConds = [ ppCondBucket bucket+                      , ppCondKey key+                      , ppCondContentLengthRange 1 1000+                      , ppCondContentType "application/octet-stream"+                      , ppCondSuccessActionStatus 200+                      ]++        expirationTime = Time.addUTCTime 3600 now+        postPolicyE = newPostPolicy expirationTime policyConds++        size = 1000 :: Int64++    inputFile <- mkRandFile size++    case postPolicyE of+      Left err -> liftIO $ assertFailure $ show err+      Right postPolicy -> do+        (url, formData) <- presignedPostPolicy postPolicy+        -- liftIO (print url) >> liftIO (print formData)+        result <- liftIO $ postForm url formData inputFile+        liftIO $ (NC.responseStatus result == HT.status200) @?+          "presigned POST failed"++    mapM_ (removeObject bucket) [key]+    where++      postForm url formData inputFile = do+        req <- NC.parseRequest $ toS url+        let parts = map (\(x, y) -> Form.partBS x y) $+                    Map.toList formData+            parts' = parts ++ [Form.partFile "file" inputFile]+        req' <- Form.formDataBody parts' req+        mgr <- NC.newManager NC.tlsManagerSettings+        NC.httpLbs req' mgr

@@ -18,17 +18,22 @@   ( xmlGeneratorTests   ) where -import Test.Tasty-import Test.Tasty.HUnit+import           Test.Tasty+import           Test.Tasty.HUnit -import Lib.Prelude+import           Lib.Prelude -import Network.Minio.XmlGenerator+import           Data.Default               (def) +import           Network.Minio.Data+import           Network.Minio.XmlGenerator+import           Network.Minio.XmlParser    (parseNotification)+ xmlGeneratorTests :: TestTree xmlGeneratorTests = testGroup "XML Generator Tests"   [ testCase "Test mkCreateBucketConfig" testMkCreateBucketConfig   , testCase "Test mkCompleteMultipartUploadRequest" testMkCompleteMultipartUploadRequest+  , testCase "Test mkPutNotificationRequest" testMkPutNotificationRequest   ]  testMkCreateBucketConfig :: Assertion@@ -52,3 +57,39 @@     \<PartNumber>1</PartNumber><ETag>abc</ETag>\     \</Part>\     \</CompleteMultipartUpload>"++testMkPutNotificationRequest :: Assertion+testMkPutNotificationRequest =+  forM_ cases $ \val -> do+    let result = toS $ mkPutNotificationRequest val+    ntf <- runExceptT $ parseNotification result+    either (\_ -> assertFailure "XML Parse Error!")+      (@?= val) ntf+  where+    cases = [ Notification []+              [ NotificationConfig+                "YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4"+                "arn:aws:sns:us-east-1:account-id:s3notificationtopic2"+                [ReducedRedundancyLostObject, ObjectCreated] def+              ]+              []+            , Notification+              [ NotificationConfig+                "1" "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue"+                [ObjectCreatedPut]+                (Filter $ FilterKey $ FilterRules+                  [ FilterRule "prefix" "images/"+                  , FilterRule "suffix" ".jpg"])+              , NotificationConfig+                "" "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue"+                [ObjectCreated] def+              ]+              [ NotificationConfig+                "" "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2"+                [ReducedRedundancyLostObject] def+              ]+              [ NotificationConfig+                "ObjectCreatedEvents" "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail"+                [ObjectCreated] def+              ]+            ]

@@ -19,13 +19,15 @@     xmlParserTests   ) where -import qualified Control.Monad.Catch as MC-import           Data.Time (fromGregorian)+import qualified Control.Monad.Catch     as MC+import           Data.Time               (fromGregorian) import           Test.Tasty import           Test.Tasty.HUnit  import           Lib.Prelude +import           Data.Default            (def)+ import           Network.Minio.Data import           Network.Minio.Errors import           Network.Minio.XmlParser@@ -35,10 +37,12 @@   [ testCase "Test parseLocation" testParseLocation   , testCase "Test parseNewMultipartUpload" testParseNewMultipartUpload   , testCase "Test parseListObjectsResponse" testParseListObjectsResult+  , testCase "Test parseListObjectsV1Response" testParseListObjectsV1Result   , testCase "Test parseListUploadsresponse" testParseListIncompleteUploads   , testCase "Test parseCompleteMultipartUploadResponse" testParseCompleteMultipartUploadResponse   , testCase "Test parseListPartsResponse" testParseListPartsResponse   , testCase "Test parseCopyObjectResponse" testParseCopyObjectResponse+  , testCase "Test parseNotification" testParseNotification   ]  tryValidationErr :: (MC.MonadCatch m) => m a -> m (Either MErrV a)@@ -48,7 +52,7 @@ assertValidtionErr e = assertFailure $ "Failed due to validation error => " ++ show e  eitherValidationErr :: Either MErrV a -> (a -> Assertion) -> Assertion-eitherValidationErr (Left e) _ = assertValidtionErr e+eitherValidationErr (Left e) _  = assertValidtionErr e eitherValidationErr (Right a) f = f a  testParseLocation :: Assertion@@ -108,9 +112,10 @@               \<ListBucketResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\               \<Name>bucket</Name>\               \<Prefix/>\-              \<KeyCount>205</KeyCount>\+              \<NextContinuationToken>opaque</NextContinuationToken>\+              \<KeyCount>1000</KeyCount>\               \<MaxKeys>1000</MaxKeys>\-              \<IsTruncated>false</IsTruncated>\+              \<IsTruncated>true</IsTruncated>\               \<Contents>\               \<Key>my-image.jpg</Key>\               \<LastModified>2009-10-12T17:50:30.000Z</LastModified>\@@ -120,13 +125,40 @@               \</Contents>\               \</ListBucketResult>" -    expectedListResult = ListObjectsResult False Nothing [object1] []+    expectedListResult = ListObjectsResult True (Just "opaque") [object1] []     object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234     modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12    parsedListObjectsResult <- tryValidationErr $ parseListObjectsResponse xmldata   eitherValidationErr parsedListObjectsResult (@?= expectedListResult) +testParseListObjectsV1Result :: Assertion+testParseListObjectsV1Result = do+  let+    xmldata = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\+              \<ListBucketResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+              \<Name>bucket</Name>\+              \<Prefix/>\+              \<NextMarker>my-image1.jpg</NextMarker>\+              \<KeyCount>1000</KeyCount>\+              \<MaxKeys>1000</MaxKeys>\+              \<IsTruncated>true</IsTruncated>\+              \<Contents>\+              \<Key>my-image.jpg</Key>\+              \<LastModified>2009-10-12T17:50:30.000Z</LastModified>\+              \<ETag>&quot;fba9dede5f27731c9771645a39863328&quot;</ETag>\+              \<Size>434234</Size>\+              \<StorageClass>STANDARD</StorageClass>\+              \</Contents>\+              \</ListBucketResult>"++    expectedListResult = ListObjectsV1Result True (Just "my-image1.jpg") [object1] []+    object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234+    modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12++  parsedListObjectsV1Result <- tryValidationErr $ parseListObjectsV1Response xmldata+  eitherValidationErr parsedListObjectsV1Result (@?= expectedListResult)+ testParseListIncompleteUploads :: Assertion testParseListIncompleteUploads = do   let@@ -250,3 +282,77 @@   forM_ cases $ \(xmldata, (etag, modTime)) -> do     parseResult <- runExceptT $ parseCopyObjectResponse xmldata     eitherValidationErr parseResult (@?= (etag, modTime))++testParseNotification :: Assertion+testParseNotification = do+  let+    cases = [ ("<NotificationConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+\  <TopicConfiguration>\+\    <Id>YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4</Id>\+\    <Topic>arn:aws:sns:us-east-1:account-id:s3notificationtopic2</Topic>\+\    <Event>s3:ReducedRedundancyLostObject</Event>\+\    <Event>s3:ObjectCreated:*</Event>\+\  </TopicConfiguration>\+\</NotificationConfiguration>",+               Notification []+                [ NotificationConfig+                  "YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4"+                  "arn:aws:sns:us-east-1:account-id:s3notificationtopic2"+                  [ReducedRedundancyLostObject, ObjectCreated] def+                ]+                [])+            , ("<NotificationConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+\  <CloudFunctionConfiguration>\+\    <Id>ObjectCreatedEvents</Id>\+\    <CloudFunction>arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail</CloudFunction>\+\    <Event>s3:ObjectCreated:*</Event>\+\  </CloudFunctionConfiguration>\+\  <QueueConfiguration>\+\      <Id>1</Id>\+\      <Filter>\+\          <S3Key>\+\              <FilterRule>\+\                  <Name>prefix</Name>\+\                  <Value>images/</Value>\+\              </FilterRule>\+\              <FilterRule>\+\                  <Name>suffix</Name>\+\                  <Value>.jpg</Value>\+\              </FilterRule>\+\          </S3Key>\+\     </Filter>\+\     <Queue>arn:aws:sqs:us-west-2:444455556666:s3notificationqueue</Queue>\+\     <Event>s3:ObjectCreated:Put</Event>\+\  </QueueConfiguration>\+\  <TopicConfiguration>\+\    <Topic>arn:aws:sns:us-east-1:356671443308:s3notificationtopic2</Topic>\+\    <Event>s3:ReducedRedundancyLostObject</Event>\+\  </TopicConfiguration>\+\  <QueueConfiguration>\+\    <Queue>arn:aws:sqs:us-east-1:356671443308:s3notificationqueue</Queue>\+\    <Event>s3:ObjectCreated:*</Event>\+\  </QueueConfiguration>)\+\</NotificationConfiguration>",+               Notification [ NotificationConfig+                              "1" "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue"+                              [ObjectCreatedPut]+                              (Filter $ FilterKey $ FilterRules+                               [FilterRule "prefix" "images/",+                                FilterRule "suffix" ".jpg"])+                            , NotificationConfig+                              "" "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue"+                              [ObjectCreated] def+                            ]+                            [ NotificationConfig+                              "" "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2"+                              [ReducedRedundancyLostObject] def+                            ]+                            [ NotificationConfig+                              "ObjectCreatedEvents" "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail"+                              [ObjectCreated] def+                            ])+            ]++  forM_ cases $ \(xmldata, val) -> do+    result <- runExceptT $ parseNotification xmldata+    eitherValidationErr result (@?= val)