From 7564cbd514b914f7fa2e5000eb7dbaa72dfcec7e Mon Sep 17 00:00:00 2001 From: Krishnan Parthasarathi Date: Thu, 7 Jun 2018 18:28:59 -0700 Subject: [PATCH] Infer XML namespace using connectHost (#96) While GCS is S3 v4 compatible, it uses a different xml namespace url than AWS (and Minio). --- minio-hs.cabal | 2 + src/Network/Minio.hs | 1 + src/Network/Minio/Data.hs | 45 +++++++- src/Network/Minio/S3API.hs | 12 ++- src/Network/Minio/XmlGenerator.hs | 18 ++-- src/Network/Minio/XmlParser.hs | 136 ++++++++++++++---------- test/Network/Minio/TestHelpers.hs | 32 ++++++ test/Network/Minio/Utils/Test.hs | 8 +- test/Network/Minio/XmlGenerator/Test.hs | 10 +- test/Network/Minio/XmlParser/Test.hs | 25 ++--- 10 files changed, 192 insertions(+), 97 deletions(-) create mode 100644 test/Network/Minio/TestHelpers.hs diff --git a/minio-hs.cabal b/minio-hs.cabal index 3b3c907..f75460f 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -120,6 +120,7 @@ test-suite minio-hs-live-server-test , Network.Minio.PutObject , Network.Minio.S3API , Network.Minio.Sign.V4 + , Network.Minio.TestHelpers , Network.Minio.Utils , Network.Minio.Utils.Test , Network.Minio.API.Test @@ -228,6 +229,7 @@ test-suite minio-hs-test , Network.Minio.PutObject , Network.Minio.S3API , Network.Minio.Sign.V4 + , Network.Minio.TestHelpers , Network.Minio.Utils , Network.Minio.Utils.Test , Network.Minio.API.Test diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index c47f5c0..4b8ecba 100644 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -23,6 +23,7 @@ module Network.Minio --------------------------------- ConnectInfo(..) , awsCI + , gcsCI -- ** Connection helpers ------------------------ diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 62671bb..23a35e2 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -91,6 +91,7 @@ data ConnectInfo = ConnectInfo { , connectAutoDiscoverRegion :: Bool } deriving (Eq, Show) + -- | Connects to a Minio server located at @localhost:9000@ with access -- key /minio/ and secret key /minio123/. It is over __HTTP__ by -- default. @@ -98,9 +99,33 @@ instance Default ConnectInfo where def = ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1" True getHostAddr :: ConnectInfo -> ByteString -getHostAddr ci = toS $ T.concat [ connectHost ci, ":" - , Lib.Prelude.show $ connectPort ci - ] +getHostAddr ci = if | port == 80 || port == 443 -> toS host + | otherwise -> toS $ + T.concat [ host, ":" , Lib.Prelude.show port] + where + port = connectPort ci + host = connectHost ci + + +-- | Default GCS ConnectInfo. Works only for "Simple Migration" +-- use-case with interoperability mode enabled on GCP console. For +-- more information - https://cloud.google.com/storage/docs/migrating +-- Credentials should be supplied before use, for e.g.: +-- +-- > gcsCI { +-- > connectAccessKey = "my-access-key" +-- > , connectSecretKey = "my-secret-key" +-- > } + +gcsCI :: ConnectInfo +gcsCI = def { + connectHost = "storage.googleapis.com" + , connectPort = 443 + , connectAccessKey = "" + , connectSecretKey = "" + , connectIsSecure = True + , connectAutoDiscoverRegion = False + } -- | Default AWS ConnectInfo. Connects to "us-east-1". Credentials -- should be supplied before use, for e.g.: @@ -551,6 +576,16 @@ data MinioConn = MinioConn , mcRegionMap :: MVar RegionMap } +class HasSvcNamespace env where + getSvcNamespace :: env -> Text + +instance HasSvcNamespace MinioConn where + getSvcNamespace env = let host = connectHost $ mcConnInfo env + in if | host == "storage.googleapis.com" -> + "http://doc.s3.amazonaws.com/2006-03-01" + | otherwise -> + "http://s3.amazonaws.com/doc/2006-03-01/" + -- | Takes connection information and returns a connection object to -- be passed to 'runMinio' connect :: ConnectInfo -> IO MinioConn @@ -578,8 +613,8 @@ runMinio ci m = do handlerFE = return . Left . MErrIO handlerValidation = return . Left . MErrValidation -s3Name :: Text -> Name -s3Name s = Name s (Just "http://s3.amazonaws.com/doc/2006-03-01/") Nothing +s3Name :: Text -> Text -> Name +s3Name ns s = Name s (Just ns) Nothing -- | Format as per RFC 1123. formatRFC1123 :: UTCTime -> T.Text diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index 7692dae..b7f3190 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -133,11 +133,12 @@ getObject' bucket object queryParams headers = do -- | Creates a bucket via a PUT bucket call. putBucket :: Bucket -> Region -> Minio () -putBucket bucket location = void $ - executeRequest $ +putBucket bucket location = do + ns <- asks getSvcNamespace + void $ executeRequest $ def { riMethod = HT.methodPut , riBucket = Just bucket - , riPayload = PayloadBS $ mkCreateBucketConfig location + , riPayload = PayloadBS $ mkCreateBucketConfig ns location , riNeedsLocation = False } @@ -445,12 +446,13 @@ headBucket bucket = headBucketEx `catches` -- | Set the notification configuration on a bucket. putBucketNotification :: Bucket -> Notification -> Minio () -putBucketNotification bucket ncfg = +putBucketNotification bucket ncfg = do + ns <- asks getSvcNamespace void $ executeRequest $ def { riMethod = HT.methodPut , riBucket = Just bucket , riQueryParams = [("notification", Nothing)] , riPayload = PayloadBS $ - mkPutNotificationRequest ncfg + mkPutNotificationRequest ns ncfg } -- | Retrieve the notification configuration on a bucket. diff --git a/src/Network/Minio/XmlGenerator.hs b/src/Network/Minio/XmlGenerator.hs index 0de27ff..602fb5e 100644 --- a/src/Network/Minio/XmlGenerator.hs +++ b/src/Network/Minio/XmlGenerator.hs @@ -32,10 +32,10 @@ import Network.Minio.Data -- | Create a bucketConfig request body XML -mkCreateBucketConfig :: Region -> ByteString -mkCreateBucketConfig location = LBS.toStrict $ renderLBS def bucketConfig +mkCreateBucketConfig :: Text -> Region -> ByteString +mkCreateBucketConfig ns location = LBS.toStrict $ renderLBS def bucketConfig where - s3Element n = Element (s3Name n) M.empty + s3Element n = Element (s3Name ns n) M.empty root = s3Element "CreateBucketConfiguration" [ NodeElement $ s3Element "LocationConstraint" [ NodeContent location] @@ -62,14 +62,14 @@ data XNode = XNode Text [XNode] | XLeaf Text Text deriving (Eq, Show) -toXML :: XNode -> ByteString -toXML node = LBS.toStrict $ renderLBS def $ +toXML :: Text -> XNode -> ByteString +toXML ns node = LBS.toStrict $ renderLBS def $ Document (Prologue [] Nothing []) (xmlNode node) [] where xmlNode :: XNode -> Element - xmlNode (XNode name nodes) = Element (s3Name name) M.empty $ + xmlNode (XNode name nodes) = Element (s3Name ns name) M.empty $ map (NodeElement . xmlNode) nodes - xmlNode (XLeaf name content) = Element (s3Name name) M.empty + xmlNode (XLeaf name content) = Element (s3Name ns name) M.empty [NodeContent content] class ToXNode a where @@ -98,5 +98,5 @@ getFRXNode (FilterRule n v) = XNode "FilterRule" [ XLeaf "Name" n , XLeaf "Value" v ] -mkPutNotificationRequest :: Notification -> ByteString -mkPutNotificationRequest = toXML . toXNode +mkPutNotificationRequest :: Text -> Notification -> ByteString +mkPutNotificationRequest ns = toXML ns . toXNode diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index 69332cb..bf1c036 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -66,20 +66,22 @@ parseDecimal numStr = either (throwIO . MErrVXmlParse . show) return $ parseDecimals :: (MonadIO m, Integral a) => [Text] -> m [a] parseDecimals numStr = forM numStr parseDecimal -s3Elem :: Text -> Axis -s3Elem = element . s3Name +s3Elem :: Text -> Text -> Axis +s3Elem ns = element . s3Name ns parseRoot :: (MonadIO m) => LByteString -> m Cursor parseRoot = either (throwIO . MErrVXmlParse . show) (return . fromDocument) . parseLBS def -- | Parse the response XML of a list buckets call. -parseListBuckets :: (MonadIO m) => LByteString -> m [BucketInfo] +parseListBuckets :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m [BucketInfo] parseListBuckets xmldata = do r <- parseRoot xmldata + ns <- asks getSvcNamespace let - names = r $// s3Elem "Bucket" &// s3Elem "Name" &/ content - timeStrings = r $// s3Elem "Bucket" &// s3Elem "CreationDate" &/ content + s3Elem' = s3Elem ns + names = r $// s3Elem' "Bucket" &// s3Elem' "Name" &/ content + timeStrings = r $// s3Elem' "Bucket" &// s3Elem' "CreationDate" &/ content times <- mapM parseS3XMLTime timeStrings return $ zipWith BucketInfo names times @@ -92,46 +94,54 @@ parseLocation xmldata = do return $ bool "us-east-1" region $ region /= "" -- | Parse the response XML of an newMultipartUpload call. -parseNewMultipartUpload :: (MonadIO m) => LByteString -> m UploadId +parseNewMultipartUpload :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m UploadId parseNewMultipartUpload xmldata = do r <- parseRoot xmldata - return $ T.concat $ r $// s3Elem "UploadId" &/ content + ns <- asks getSvcNamespace + let s3Elem' = s3Elem ns + return $ T.concat $ r $// s3Elem' "UploadId" &/ content -- | Parse the response XML of completeMultipartUpload call. -parseCompleteMultipartUploadResponse :: (MonadIO m) => LByteString -> m ETag +parseCompleteMultipartUploadResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ETag parseCompleteMultipartUploadResponse xmldata = do r <- parseRoot xmldata - return $ T.concat $ r $// s3Elem "ETag" &/ content + ns <- asks getSvcNamespace + let s3Elem' = s3Elem ns + return $ T.concat $ r $// s3Elem' "ETag" &/ content -- | Parse the response XML of copyObject and copyObjectPart -parseCopyObjectResponse :: (MonadIO m) => LByteString -> m (ETag, UTCTime) +parseCopyObjectResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m (ETag, UTCTime) parseCopyObjectResponse xmldata = do r <- parseRoot xmldata + ns <- asks getSvcNamespace let - mtimeStr = T.concat $ r $// s3Elem "LastModified" &/ content + s3Elem' = s3Elem ns + mtimeStr = T.concat $ r $// s3Elem' "LastModified" &/ content mtime <- parseS3XMLTime mtimeStr - return (T.concat $ r $// s3Elem "ETag" &/ content, mtime) + return (T.concat $ r $// s3Elem' "ETag" &/ content, mtime) -- | Parse the response XML of a list objects v1 call. -parseListObjectsV1Response :: (MonadIO m) +parseListObjectsV1Response :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListObjectsV1Result parseListObjectsV1Response xmldata = do r <- parseRoot xmldata + ns <- asks getSvcNamespace let - hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content) + s3Elem' = s3Elem ns + hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content) - nextMarker = headMay $ r $/ s3Elem "NextMarker" &/ content + nextMarker = headMay $ r $/ s3Elem' "NextMarker" &/ content - prefixes = r $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ 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 + 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 + sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content modTimes <- mapM parseS3XMLTime modTimeStr sizes <- parseDecimals sizeStr @@ -142,23 +152,25 @@ parseListObjectsV1Response xmldata = do return $ ListObjectsV1Result hasMore nextMarker objects prefixes -- | Parse the response XML of a list objects call. -parseListObjectsResponse :: (MonadIO m) => LByteString -> m ListObjectsResult +parseListObjectsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListObjectsResult parseListObjectsResponse xmldata = do r <- parseRoot xmldata + ns <- asks getSvcNamespace let - hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content) + s3Elem' = s3Elem ns + hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content) - nextToken = headMay $ r $/ s3Elem "NextContinuationToken" &/ content + nextToken = headMay $ r $/ s3Elem' "NextContinuationToken" &/ content - prefixes = r $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ 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 + 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 + sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content modTimes <- mapM parseS3XMLTime modTimeStr sizes <- parseDecimals sizeStr @@ -169,17 +181,19 @@ parseListObjectsResponse xmldata = do return $ ListObjectsResult hasMore nextToken objects prefixes -- | Parse the response XML of a list incomplete multipart upload call. -parseListUploadsResponse :: (MonadIO m) => LByteString -> m ListUploadsResult +parseListUploadsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListUploadsResult parseListUploadsResponse xmldata = do r <- parseRoot xmldata + ns <- asks getSvcNamespace let - hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content) - prefixes = r $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ content - nextKey = headMay $ r $/ s3Elem "NextKeyMarker" &/ content - nextUpload = headMay $ r $/ s3Elem "NextUploadIdMarker" &/ content - uploadKeys = r $/ s3Elem "Upload" &/ s3Elem "Key" &/ content - uploadIds = r $/ s3Elem "Upload" &/ s3Elem "UploadId" &/ content - uploadInitTimeStr = r $/ s3Elem "Upload" &/ s3Elem "Initiated" &/ content + s3Elem' = s3Elem ns + hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content) + prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content + nextKey = headMay $ r $/ s3Elem' "NextKeyMarker" &/ content + nextUpload = headMay $ r $/ s3Elem' "NextUploadIdMarker" &/ content + uploadKeys = r $/ s3Elem' "Upload" &/ s3Elem' "Key" &/ content + uploadIds = r $/ s3Elem' "Upload" &/ s3Elem' "UploadId" &/ content + uploadInitTimeStr = r $/ s3Elem' "Upload" &/ s3Elem' "Initiated" &/ content uploadInitTimes <- mapM parseS3XMLTime uploadInitTimeStr @@ -188,16 +202,18 @@ parseListUploadsResponse xmldata = do return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes -parseListPartsResponse :: (MonadIO m) => LByteString -> m ListPartsResult +parseListPartsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListPartsResult parseListPartsResponse xmldata = do r <- parseRoot xmldata + ns <- asks getSvcNamespace let - hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content) - nextPartNumStr = headMay $ r $/ s3Elem "NextPartNumberMarker" &/ content - partNumberStr = r $/ s3Elem "Part" &/ s3Elem "PartNumber" &/ content - partModTimeStr = r $/ s3Elem "Part" &/ s3Elem "LastModified" &/ content - partETags = r $/ s3Elem "Part" &/ s3Elem "ETag" &/ content - partSizeStr = r $/ s3Elem "Part" &/ s3Elem "Size" &/ content + s3Elem' = s3Elem ns + hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content) + nextPartNumStr = headMay $ r $/ s3Elem' "NextPartNumberMarker" &/ content + partNumberStr = r $/ s3Elem' "Part" &/ s3Elem' "PartNumber" &/ content + partModTimeStr = r $/ s3Elem' "Part" &/ s3Elem' "LastModified" &/ content + partETags = r $/ s3Elem' "Part" &/ s3Elem' "ETag" &/ content + partSizeStr = r $/ s3Elem' "Part" &/ s3Elem' "Size" &/ content partModTimes <- mapM parseS3XMLTime partModTimeStr partSizes <- parseDecimals partSizeStr @@ -218,28 +234,30 @@ parseErrResponse xmldata = do message = T.concat $ r $/ element "Message" &/ content return $ toServiceErr code message -parseNotification :: (MonadIO m) => LByteString -> m Notification +parseNotification :: (MonadReader env m, HasSvcNamespace env, MonadIO 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) + ns <- asks getSvcNamespace + let s3Elem' = s3Elem ns + qcfg = map node $ r $/ s3Elem' "QueueConfiguration" + tcfg = map node $ r $/ s3Elem' "TopicConfiguration" + lcfg = map node $ r $/ s3Elem' "CloudFunctionConfiguration" + Notification <$> (mapM (parseNode ns "Queue") qcfg) + <*> (mapM (parseNode ns "Topic") tcfg) + <*> (mapM (parseNode ns "CloudFunction") lcfg) where - getFilterRule c = - let name = T.concat $ c $/ s3Elem "Name" &/ content - value = T.concat $ c $/ s3Elem "Value" &/ content + getFilterRule ns c = + let name = T.concat $ c $/ s3Elem ns "Name" &/ content + value = T.concat $ c $/ s3Elem ns "Value" &/ content in FilterRule name value - parseNode arnName nodeData = do + parseNode ns 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 + id = T.concat $ c $/ s3Elem ns "Id" &/ content + arn = T.concat $ c $/ s3Elem ns arnName &/ content + events = catMaybes $ map textToEvent $ c $/ s3Elem ns "Event" &/ content + rules = c $/ s3Elem ns "Filter" &/ s3Elem ns "S3Key" &/ + s3Elem ns "FilterRule" &| getFilterRule ns return $ NotificationConfig id arn events (Filter $ FilterKey $ FilterRules rules) diff --git a/test/Network/Minio/TestHelpers.hs b/test/Network/Minio/TestHelpers.hs new file mode 100644 index 0000000..f7cf7cf --- /dev/null +++ b/test/Network/Minio/TestHelpers.hs @@ -0,0 +1,32 @@ +-- +-- Minio Haskell SDK, (C) 2018 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- 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.TestHelpers + ( runTestNS + ) where + +import Network.Minio.Data + +import Lib.Prelude + +newtype TestNS = TestNS { testNamespace :: Text } + +instance HasSvcNamespace TestNS where + getSvcNamespace = testNamespace + +runTestNS :: ReaderT TestNS m a -> m a +runTestNS = flip runReaderT $ + TestNS "http://s3.amazonaws.com/doc/2006-03-01/" diff --git a/test/Network/Minio/Utils/Test.hs b/test/Network/Minio/Utils/Test.hs index fd8edd3..1dc04d7 100644 --- a/test/Network/Minio/Utils/Test.hs +++ b/test/Network/Minio/Utils/Test.hs @@ -19,12 +19,12 @@ module Network.Minio.Utils.Test limitedMapConcurrentlyTests ) where -import Test.Tasty -import Test.Tasty.HUnit +import Test.Tasty +import Test.Tasty.HUnit -import Lib.Prelude +import Lib.Prelude -import Network.Minio.Utils +import Network.Minio.Utils limitedMapConcurrentlyTests :: TestTree limitedMapConcurrentlyTests = testGroup "limitedMapConcurrently Tests" diff --git a/test/Network/Minio/XmlGenerator/Test.hs b/test/Network/Minio/XmlGenerator/Test.hs index b691308..ffac7ff 100644 --- a/test/Network/Minio/XmlGenerator/Test.hs +++ b/test/Network/Minio/XmlGenerator/Test.hs @@ -26,6 +26,7 @@ import Lib.Prelude import Data.Default (def) import Network.Minio.Data +import Network.Minio.TestHelpers import Network.Minio.XmlGenerator import Network.Minio.XmlParser (parseNotification) @@ -38,8 +39,9 @@ xmlGeneratorTests = testGroup "XML Generator Tests" testMkCreateBucketConfig :: Assertion testMkCreateBucketConfig = do + let ns = "http://s3.amazonaws.com/doc/2006-03-01/" assertEqual "CreateBucketConfiguration xml should match: " expected $ - mkCreateBucketConfig "EU" + mkCreateBucketConfig ns "EU" where expected = "\ \\ @@ -58,11 +60,13 @@ testMkCompleteMultipartUploadRequest = \\ \" + testMkPutNotificationRequest :: Assertion testMkPutNotificationRequest = forM_ cases $ \val -> do - let result = toS $ mkPutNotificationRequest val - ntf <- runExceptT $ parseNotification result + let ns = "http://s3.amazonaws.com/doc/2006-03-01/" + result = toS $ mkPutNotificationRequest ns val + ntf <- runExceptT $ runTestNS $ parseNotification result either (\_ -> assertFailure "XML Parse Error!") (@?= val) ntf where diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs index bb89051..4a705e4 100644 --- a/test/Network/Minio/XmlParser/Test.hs +++ b/test/Network/Minio/XmlParser/Test.hs @@ -19,17 +19,18 @@ module Network.Minio.XmlParser.Test xmlParserTests ) where -import Data.Default (def) -import qualified Data.Map as Map -import Data.Time (fromGregorian) +import Data.Default (def) +import qualified Data.Map as Map +import Data.Time (fromGregorian) import Test.Tasty import Test.Tasty.HUnit -import UnliftIO (MonadUnliftIO) +import UnliftIO (MonadUnliftIO) import Lib.Prelude import Network.Minio.Data import Network.Minio.Errors +import Network.Minio.TestHelpers import Network.Minio.XmlParser xmlParserTests :: TestTree @@ -83,7 +84,7 @@ testParseLocation = do testParseNewMultipartUpload :: Assertion testParseNewMultipartUpload = do forM_ cases $ \(xmldata, expectedUploadId) -> do - parsedUploadIdE <- tryValidationErr $ parseNewMultipartUpload xmldata + parsedUploadIdE <- tryValidationErr $ runTestNS $ parseNewMultipartUpload xmldata eitherValidationErr parsedUploadIdE (@?= expectedUploadId) where cases = [ @@ -129,7 +130,7 @@ testParseListObjectsResult = do object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 Map.empty modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12 - parsedListObjectsResult <- tryValidationErr $ parseListObjectsResponse xmldata + parsedListObjectsResult <- tryValidationErr $ runTestNS $ parseListObjectsResponse xmldata eitherValidationErr parsedListObjectsResult (@?= expectedListResult) testParseListObjectsV1Result :: Assertion @@ -156,7 +157,7 @@ testParseListObjectsV1Result = do object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 Map.empty modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12 - parsedListObjectsV1Result <- tryValidationErr $ parseListObjectsV1Response xmldata + parsedListObjectsV1Result <- tryValidationErr $ runTestNS $ parseListObjectsV1Response xmldata eitherValidationErr parsedListObjectsV1Result (@?= expectedListResult) testParseListIncompleteUploads :: Assertion @@ -198,7 +199,7 @@ testParseListIncompleteUploads = do initTime = UTCTime (fromGregorian 2010 11 26) 69857 prefixes = ["photos/", "videos/"] - parsedListUploadsResult <- tryValidationErr $ parseListUploadsResponse xmldata + parsedListUploadsResult <- tryValidationErr $ runTestNS $ parseListUploadsResponse xmldata eitherValidationErr parsedListUploadsResult (@?= expectedListResult) @@ -214,7 +215,7 @@ testParseCompleteMultipartUploadResponse = do \" expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\"" - parsedETagE <- runExceptT $ parseCompleteMultipartUploadResponse xmldata + parsedETagE <- runExceptT $ runTestNS $ parseCompleteMultipartUploadResponse xmldata eitherValidationErr parsedETagE (@?= expectedETag) testParseListPartsResponse :: Assertion @@ -258,7 +259,7 @@ testParseListPartsResponse = do part2 = ObjectPartInfo 3 "\"aaaa18db4cc2f85cedef654fccc4a4x8\"" 10485760 modifiedTime2 modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10 - parsedListPartsResult <- runExceptT $ parseListPartsResponse xmldata + parsedListPartsResult <- runExceptT $ runTestNS $ parseListPartsResponse xmldata eitherValidationErr parsedListPartsResult (@?= expectedListResult) testParseCopyObjectResponse :: Assertion @@ -280,7 +281,7 @@ testParseCopyObjectResponse = do UTCTime (fromGregorian 2009 10 28) 81120))] forM_ cases $ \(xmldata, (etag, modTime)) -> do - parseResult <- runExceptT $ parseCopyObjectResponse xmldata + parseResult <- runExceptT $ runTestNS $ parseCopyObjectResponse xmldata eitherValidationErr parseResult (@?= (etag, modTime)) testParseNotification :: Assertion @@ -354,5 +355,5 @@ testParseNotification = do ] forM_ cases $ \(xmldata, val) -> do - result <- runExceptT $ parseNotification xmldata + result <- runExceptT $ runTestNS $ parseNotification xmldata eitherValidationErr result (@?= val)