Infer XML namespace using connectHost (#96)
While GCS is S3 v4 compatible, it uses a different xml namespace url than AWS (and Minio).
This commit is contained in:
Krishnan Parthasarathi
Harshavardhana
parent
d0ddd7f057
commit
7564cbd514
@ -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
|
||||
|
||||
@ -23,6 +23,7 @@ module Network.Minio
|
||||
---------------------------------
|
||||
ConnectInfo(..)
|
||||
, awsCI
|
||||
, gcsCI
|
||||
|
||||
-- ** Connection helpers
|
||||
------------------------
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
32
test/Network/Minio/TestHelpers.hs
Normal file
32
test/Network/Minio/TestHelpers.hs
Normal file
@ -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/"
|
||||
@ -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"
|
||||
|
||||
@ -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 = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
|
||||
\<CreateBucketConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
|
||||
@ -58,11 +60,13 @@ testMkCompleteMultipartUploadRequest =
|
||||
\</Part>\
|
||||
\</CompleteMultipartUpload>"
|
||||
|
||||
|
||||
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
|
||||
|
||||
@ -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
|
||||
\</CompleteMultipartUploadResult>"
|
||||
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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user