haskell/minio-hs
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Infer XML namespace using connectHost (#96)

Browse Source 
While GCS is S3 v4 compatible, it uses a different xml namespace url
than AWS (and Minio).
This commit is contained in:
Krishnan Parthasarathi 2018-06-07 18:28:59 -07:00 committed by Harshavardhana
parent d0ddd7f057
commit 7564cbd514
10 changed files with 192 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
minio-hs.cabal
View File

@ -120,6 +120,7 @@ test-suite minio-hs-live-server-test
, Network.Minio.PutObject , Network.Minio.PutObject
, Network.Minio.S3API , Network.Minio.S3API
, Network.Minio.Sign.V4 , Network.Minio.Sign.V4
, Network.Minio.TestHelpers
, Network.Minio.Utils , Network.Minio.Utils
, Network.Minio.Utils.Test , Network.Minio.Utils.Test
, Network.Minio.API.Test , Network.Minio.API.Test
@ -228,6 +229,7 @@ test-suite minio-hs-test
, Network.Minio.PutObject , Network.Minio.PutObject
, Network.Minio.S3API , Network.Minio.S3API
, Network.Minio.Sign.V4 , Network.Minio.Sign.V4
, Network.Minio.TestHelpers
, Network.Minio.Utils , Network.Minio.Utils
, Network.Minio.Utils.Test , Network.Minio.Utils.Test
, Network.Minio.API.Test , Network.Minio.API.Test

1
src/Network/Minio.hs
View File

@ -23,6 +23,7 @@ module Network.Minio
--------------------------------- ---------------------------------
ConnectInfo(..) ConnectInfo(..)
, awsCI , awsCI
, gcsCI
-- ** Connection helpers -- ** Connection helpers
------------------------ ------------------------

45
src/Network/Minio/Data.hs
View File

@ -91,6 +91,7 @@ data ConnectInfo = ConnectInfo {
, connectAutoDiscoverRegion :: Bool , connectAutoDiscoverRegion :: Bool
} deriving (Eq, Show) } deriving (Eq, Show)
-- | Connects to a Minio server located at @localhost:9000@ with access -- | Connects to a Minio server located at @localhost:9000@ with access
-- key /minio/ and secret key /minio123/. It is over __HTTP__ by -- key /minio/ and secret key /minio123/. It is over __HTTP__ by
-- default. -- default.
@ -98,9 +99,33 @@ instance Default ConnectInfo where
def = ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1" True def = ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1" True
getHostAddr :: ConnectInfo -> ByteString getHostAddr :: ConnectInfo -> ByteString
getHostAddr ci = toS $ T.concat [ connectHost ci, ":" getHostAddr ci = if | port == 80 || port == 443 -> toS host
, Lib.Prelude.show $ connectPort ci | 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 -- | Default AWS ConnectInfo. Connects to "us-east-1". Credentials
-- should be supplied before use, for e.g.: -- should be supplied before use, for e.g.:
@ -551,6 +576,16 @@ data MinioConn = MinioConn
, mcRegionMap :: MVar RegionMap , 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 -- | Takes connection information and returns a connection object to
-- be passed to 'runMinio' -- be passed to 'runMinio'
connect :: ConnectInfo -> IO MinioConn connect :: ConnectInfo -> IO MinioConn
@ -578,8 +613,8 @@ runMinio ci m = do
handlerFE = return . Left . MErrIO handlerFE = return . Left . MErrIO
handlerValidation = return . Left . MErrValidation handlerValidation = return . Left . MErrValidation
s3Name :: Text -> Name s3Name :: Text -> Text -> Name
s3Name s = Name s (Just "http://s3.amazonaws.com/doc/2006-03-01/") Nothing s3Name ns s = Name s (Just ns) Nothing
-- | Format as per RFC 1123. -- | Format as per RFC 1123.
formatRFC1123 :: UTCTime -> T.Text formatRFC1123 :: UTCTime -> T.Text

12
src/Network/Minio/S3API.hs
View File

@ -133,11 +133,12 @@ getObject' bucket object queryParams headers = do
-- | Creates a bucket via a PUT bucket call. -- | Creates a bucket via a PUT bucket call.
putBucket :: Bucket -> Region -> Minio () putBucket :: Bucket -> Region -> Minio ()
putBucket bucket location = void $ putBucket bucket location = do
executeRequest $ ns <- asks getSvcNamespace
void $ executeRequest $
def { riMethod = HT.methodPut def { riMethod = HT.methodPut
, riBucket = Just bucket , riBucket = Just bucket
, riPayload = PayloadBS $ mkCreateBucketConfig location , riPayload = PayloadBS $ mkCreateBucketConfig ns location
, riNeedsLocation = False , riNeedsLocation = False
} }
@ -445,12 +446,13 @@ headBucket bucket = headBucketEx `catches`
-- | Set the notification configuration on a bucket. -- | Set the notification configuration on a bucket.
putBucketNotification :: Bucket -> Notification -> Minio () putBucketNotification :: Bucket -> Notification -> Minio ()
putBucketNotification bucket ncfg = putBucketNotification bucket ncfg = do
ns <- asks getSvcNamespace
void $ executeRequest $ def { riMethod = HT.methodPut void $ executeRequest $ def { riMethod = HT.methodPut
, riBucket = Just bucket , riBucket = Just bucket
, riQueryParams = [("notification", Nothing)] , riQueryParams = [("notification", Nothing)]
, riPayload = PayloadBS $ , riPayload = PayloadBS $
mkPutNotificationRequest ncfg mkPutNotificationRequest ns ncfg
} }
-- | Retrieve the notification configuration on a bucket. -- | Retrieve the notification configuration on a bucket.

18
src/Network/Minio/XmlGenerator.hs
View File

@ -32,10 +32,10 @@ import Network.Minio.Data
-- | Create a bucketConfig request body XML -- | Create a bucketConfig request body XML
mkCreateBucketConfig :: Region -> ByteString mkCreateBucketConfig :: Text -> Region -> ByteString
mkCreateBucketConfig location = LBS.toStrict $ renderLBS def bucketConfig mkCreateBucketConfig ns location = LBS.toStrict $ renderLBS def bucketConfig
where where
s3Element n = Element (s3Name n) M.empty s3Element n = Element (s3Name ns n) M.empty
root = s3Element "CreateBucketConfiguration" root = s3Element "CreateBucketConfiguration"
[ NodeElement $ s3Element "LocationConstraint" [ NodeElement $ s3Element "LocationConstraint"
[ NodeContent location] [ NodeContent location]
@ -62,14 +62,14 @@ data XNode = XNode Text [XNode]
| XLeaf Text Text | XLeaf Text Text
deriving (Eq, Show) deriving (Eq, Show)
toXML :: XNode -> ByteString toXML :: Text -> XNode -> ByteString
toXML node = LBS.toStrict $ renderLBS def $ toXML ns node = LBS.toStrict $ renderLBS def $
Document (Prologue [] Nothing []) (xmlNode node) [] Document (Prologue [] Nothing []) (xmlNode node) []
where where
xmlNode :: XNode -> Element 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 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] [NodeContent content]
class ToXNode a where class ToXNode a where
@ -98,5 +98,5 @@ getFRXNode (FilterRule n v) = XNode "FilterRule" [ XLeaf "Name" n
, XLeaf "Value" v , XLeaf "Value" v
] ]
mkPutNotificationRequest :: Notification -> ByteString mkPutNotificationRequest :: Text -> Notification -> ByteString
mkPutNotificationRequest = toXML . toXNode mkPutNotificationRequest ns = toXML ns . toXNode

136
src/Network/Minio/XmlParser.hs
View File

@ -66,20 +66,22 @@ parseDecimal numStr = either (throwIO . MErrVXmlParse . show) return $
parseDecimals :: (MonadIO m, Integral a) => [Text] -> m [a] parseDecimals :: (MonadIO m, Integral a) => [Text] -> m [a]
parseDecimals numStr = forM numStr parseDecimal parseDecimals numStr = forM numStr parseDecimal
s3Elem :: Text -> Axis s3Elem :: Text -> Text -> Axis
s3Elem = element . s3Name s3Elem ns = element . s3Name ns
parseRoot :: (MonadIO m) => LByteString -> m Cursor parseRoot :: (MonadIO m) => LByteString -> m Cursor
parseRoot = either (throwIO . MErrVXmlParse . show) (return . fromDocument) parseRoot = either (throwIO . MErrVXmlParse . show) (return . fromDocument)
. parseLBS def . parseLBS def
-- | Parse the response XML of a list buckets call. -- | 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 parseListBuckets xmldata = do
r <- parseRoot xmldata r <- parseRoot xmldata
ns <- asks getSvcNamespace
let let
names = r $// s3Elem "Bucket" &// s3Elem "Name" &/ content s3Elem' = s3Elem ns
timeStrings = r $// s3Elem "Bucket" &// s3Elem "CreationDate" &/ content names = r $// s3Elem' "Bucket" &// s3Elem' "Name" &/ content
timeStrings = r $// s3Elem' "Bucket" &// s3Elem' "CreationDate" &/ content
times <- mapM parseS3XMLTime timeStrings times <- mapM parseS3XMLTime timeStrings
return $ zipWith BucketInfo names times return $ zipWith BucketInfo names times
@ -92,46 +94,54 @@ parseLocation xmldata = do
return $ bool "us-east-1" region $ region /= "" return $ bool "us-east-1" region $ region /= ""
-- | Parse the response XML of an newMultipartUpload call. -- | 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 parseNewMultipartUpload xmldata = do
r <- parseRoot xmldata 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. -- | 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 parseCompleteMultipartUploadResponse xmldata = do
r <- parseRoot xmldata 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 -- | 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 parseCopyObjectResponse xmldata = do
r <- parseRoot xmldata r <- parseRoot xmldata
ns <- asks getSvcNamespace
let let
mtimeStr = T.concat $ r $// s3Elem "LastModified" &/ content s3Elem' = s3Elem ns
mtimeStr = T.concat $ r $// s3Elem' "LastModified" &/ content
mtime <- parseS3XMLTime mtimeStr 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. -- | Parse the response XML of a list objects v1 call.
parseListObjectsV1Response :: (MonadIO m) parseListObjectsV1Response :: (MonadReader env m, HasSvcNamespace env, MonadIO m)
=> LByteString -> m ListObjectsV1Result => LByteString -> m ListObjectsV1Result
parseListObjectsV1Response xmldata = do parseListObjectsV1Response xmldata = do
r <- parseRoot xmldata r <- parseRoot xmldata
ns <- asks getSvcNamespace
let 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 keys = r $/ s3Elem' "Contents" &/ s3Elem' "Key" &/ content
modTimeStr = r $/ s3Elem "Contents" &/ s3Elem "LastModified" &/ content modTimeStr = r $/ s3Elem' "Contents" &/ s3Elem' "LastModified" &/ content
etagsList = r $/ s3Elem "Contents" &/ s3Elem "ETag" &/ content etagsList = r $/ s3Elem' "Contents" &/ s3Elem' "ETag" &/ content
-- if response xml contains empty etag response fill them with as -- if response xml contains empty etag response fill them with as
-- many empty Text for the zip4 below to work as intended. -- many empty Text for the zip4 below to work as intended.
etags = etagsList ++ repeat "" etags = etagsList ++ repeat ""
sizeStr = r $/ s3Elem "Contents" &/ s3Elem "Size" &/ content sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content
modTimes <- mapM parseS3XMLTime modTimeStr modTimes <- mapM parseS3XMLTime modTimeStr
sizes <- parseDecimals sizeStr sizes <- parseDecimals sizeStr
@ -142,23 +152,25 @@ parseListObjectsV1Response xmldata = do
return $ ListObjectsV1Result hasMore nextMarker objects prefixes return $ ListObjectsV1Result hasMore nextMarker objects prefixes
-- | Parse the response XML of a list objects call. -- | 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 parseListObjectsResponse xmldata = do
r <- parseRoot xmldata r <- parseRoot xmldata
ns <- asks getSvcNamespace
let 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 keys = r $/ s3Elem' "Contents" &/ s3Elem' "Key" &/ content
modTimeStr = r $/ s3Elem "Contents" &/ s3Elem "LastModified" &/ content modTimeStr = r $/ s3Elem' "Contents" &/ s3Elem' "LastModified" &/ content
etagsList = r $/ s3Elem "Contents" &/ s3Elem "ETag" &/ content etagsList = r $/ s3Elem' "Contents" &/ s3Elem' "ETag" &/ content
-- if response xml contains empty etag response fill them with as -- if response xml contains empty etag response fill them with as
-- many empty Text for the zip4 below to work as intended. -- many empty Text for the zip4 below to work as intended.
etags = etagsList ++ repeat "" etags = etagsList ++ repeat ""
sizeStr = r $/ s3Elem "Contents" &/ s3Elem "Size" &/ content sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content
modTimes <- mapM parseS3XMLTime modTimeStr modTimes <- mapM parseS3XMLTime modTimeStr
sizes <- parseDecimals sizeStr sizes <- parseDecimals sizeStr
@ -169,17 +181,19 @@ parseListObjectsResponse xmldata = do
return $ ListObjectsResult hasMore nextToken objects prefixes return $ ListObjectsResult hasMore nextToken objects prefixes
-- | Parse the response XML of a list incomplete multipart upload call. -- | 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 parseListUploadsResponse xmldata = do
r <- parseRoot xmldata r <- parseRoot xmldata
ns <- asks getSvcNamespace
let let
hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content) s3Elem' = s3Elem ns
prefixes = r $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ content hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)
nextKey = headMay $ r $/ s3Elem "NextKeyMarker" &/ content prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content
nextUpload = headMay $ r $/ s3Elem "NextUploadIdMarker" &/ content nextKey = headMay $ r $/ s3Elem' "NextKeyMarker" &/ content
uploadKeys = r $/ s3Elem "Upload" &/ s3Elem "Key" &/ content nextUpload = headMay $ r $/ s3Elem' "NextUploadIdMarker" &/ content
uploadIds = r $/ s3Elem "Upload" &/ s3Elem "UploadId" &/ content uploadKeys = r $/ s3Elem' "Upload" &/ s3Elem' "Key" &/ content
uploadInitTimeStr = r $/ s3Elem "Upload" &/ s3Elem "Initiated" &/ content uploadIds = r $/ s3Elem' "Upload" &/ s3Elem' "UploadId" &/ content
uploadInitTimeStr = r $/ s3Elem' "Upload" &/ s3Elem' "Initiated" &/ content
uploadInitTimes <- mapM parseS3XMLTime uploadInitTimeStr uploadInitTimes <- mapM parseS3XMLTime uploadInitTimeStr
@ -188,16 +202,18 @@ parseListUploadsResponse xmldata = do
return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes 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 parseListPartsResponse xmldata = do
r <- parseRoot xmldata r <- parseRoot xmldata
ns <- asks getSvcNamespace
let let
hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content) s3Elem' = s3Elem ns
nextPartNumStr = headMay $ r $/ s3Elem "NextPartNumberMarker" &/ content hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)
partNumberStr = r $/ s3Elem "Part" &/ s3Elem "PartNumber" &/ content nextPartNumStr = headMay $ r $/ s3Elem' "NextPartNumberMarker" &/ content
partModTimeStr = r $/ s3Elem "Part" &/ s3Elem "LastModified" &/ content partNumberStr = r $/ s3Elem' "Part" &/ s3Elem' "PartNumber" &/ content
partETags = r $/ s3Elem "Part" &/ s3Elem "ETag" &/ content partModTimeStr = r $/ s3Elem' "Part" &/ s3Elem' "LastModified" &/ content
partSizeStr = r $/ s3Elem "Part" &/ s3Elem "Size" &/ content partETags = r $/ s3Elem' "Part" &/ s3Elem' "ETag" &/ content
partSizeStr = r $/ s3Elem' "Part" &/ s3Elem' "Size" &/ content
partModTimes <- mapM parseS3XMLTime partModTimeStr partModTimes <- mapM parseS3XMLTime partModTimeStr
partSizes <- parseDecimals partSizeStr partSizes <- parseDecimals partSizeStr
@ -218,28 +234,30 @@ parseErrResponse xmldata = do
message = T.concat $ r $/ element "Message" &/ content message = T.concat $ r $/ element "Message" &/ content
return $ toServiceErr code message return $ toServiceErr code message
parseNotification :: (MonadIO m) => LByteString -> m Notification parseNotification :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m Notification
parseNotification xmldata = do parseNotification xmldata = do
r <- parseRoot xmldata r <- parseRoot xmldata
let qcfg = map node $ r $/ s3Elem "QueueConfiguration" ns <- asks getSvcNamespace
tcfg = map node $ r $/ s3Elem "TopicConfiguration" let s3Elem' = s3Elem ns
lcfg = map node $ r $/ s3Elem "CloudFunctionConfiguration" qcfg = map node $ r $/ s3Elem' "QueueConfiguration"
Notification <$> (mapM (parseNode "Queue") qcfg) tcfg = map node $ r $/ s3Elem' "TopicConfiguration"
<*> (mapM (parseNode "Topic") tcfg) lcfg = map node $ r $/ s3Elem' "CloudFunctionConfiguration"
<*> (mapM (parseNode "CloudFunction") lcfg) Notification <$> (mapM (parseNode ns "Queue") qcfg)
<*> (mapM (parseNode ns "Topic") tcfg)
<*> (mapM (parseNode ns "CloudFunction") lcfg)
where where
getFilterRule c = getFilterRule ns c =
let name = T.concat $ c $/ s3Elem "Name" &/ content let name = T.concat $ c $/ s3Elem ns "Name" &/ content
value = T.concat $ c $/ s3Elem "Value" &/ content value = T.concat $ c $/ s3Elem ns "Value" &/ content
in FilterRule name value in FilterRule name value
parseNode arnName nodeData = do parseNode ns arnName nodeData = do
let c = fromNode nodeData let c = fromNode nodeData
id = T.concat $ c $/ s3Elem "Id" &/ content id = T.concat $ c $/ s3Elem ns "Id" &/ content
arn = T.concat $ c $/ s3Elem arnName &/ content arn = T.concat $ c $/ s3Elem ns arnName &/ content
events = catMaybes $ map textToEvent $ c $/ s3Elem "Event" &/ content events = catMaybes $ map textToEvent $ c $/ s3Elem ns "Event" &/ content
rules = c $/ s3Elem "Filter" &/ s3Elem "S3Key" &/ rules = c $/ s3Elem ns "Filter" &/ s3Elem ns "S3Key" &/
s3Elem "FilterRule" &| getFilterRule s3Elem ns "FilterRule" &| getFilterRule ns
return $ NotificationConfig id arn events return $ NotificationConfig id arn events
(Filter $ FilterKey $ FilterRules rules) (Filter $ FilterKey $ FilterRules rules)

32
test/Network/Minio/TestHelpers.hs Normal file
View 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/"

10
test/Network/Minio/XmlGenerator/Test.hs
View File

@ -26,6 +26,7 @@ import Lib.Prelude
import Data.Default (def) import Data.Default (def)
import Network.Minio.Data import Network.Minio.Data
import Network.Minio.TestHelpers
import Network.Minio.XmlGenerator import Network.Minio.XmlGenerator
import Network.Minio.XmlParser (parseNotification) import Network.Minio.XmlParser (parseNotification)
@ -38,8 +39,9 @@ xmlGeneratorTests = testGroup "XML Generator Tests"
testMkCreateBucketConfig :: Assertion testMkCreateBucketConfig :: Assertion
testMkCreateBucketConfig = do testMkCreateBucketConfig = do
let ns = "http://s3.amazonaws.com/doc/2006-03-01/"
assertEqual "CreateBucketConfiguration xml should match: " expected $ assertEqual "CreateBucketConfiguration xml should match: " expected $
mkCreateBucketConfig "EU" mkCreateBucketConfig ns "EU"
where where
expected = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\ expected = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
\<CreateBucketConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\ \<CreateBucketConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
@ -58,11 +60,13 @@ testMkCompleteMultipartUploadRequest =
\</Part>\ \</Part>\
\</CompleteMultipartUpload>" \</CompleteMultipartUpload>"
testMkPutNotificationRequest :: Assertion testMkPutNotificationRequest :: Assertion
testMkPutNotificationRequest = testMkPutNotificationRequest =
forM_ cases $ \val -> do forM_ cases $ \val -> do
let result = toS $ mkPutNotificationRequest val let ns = "http://s3.amazonaws.com/doc/2006-03-01/"
ntf <- runExceptT $ parseNotification result result = toS $ mkPutNotificationRequest ns val
ntf <- runExceptT $ runTestNS $ parseNotification result
either (\_ -> assertFailure "XML Parse Error!") either (\_ -> assertFailure "XML Parse Error!")
(@?= val) ntf (@?= val) ntf
where where

17
test/Network/Minio/XmlParser/Test.hs
View File

@ -30,6 +30,7 @@ import Lib.Prelude
import Network.Minio.Data import Network.Minio.Data
import Network.Minio.Errors import Network.Minio.Errors
import Network.Minio.TestHelpers
import Network.Minio.XmlParser import Network.Minio.XmlParser
xmlParserTests :: TestTree xmlParserTests :: TestTree
@ -83,7 +84,7 @@ testParseLocation = do
testParseNewMultipartUpload :: Assertion testParseNewMultipartUpload :: Assertion
testParseNewMultipartUpload = do testParseNewMultipartUpload = do
forM_ cases $ \(xmldata, expectedUploadId) -> do forM_ cases $ \(xmldata, expectedUploadId) -> do
parsedUploadIdE <- tryValidationErr $ parseNewMultipartUpload xmldata parsedUploadIdE <- tryValidationErr $ runTestNS $ parseNewMultipartUpload xmldata
eitherValidationErr parsedUploadIdE (@?= expectedUploadId) eitherValidationErr parsedUploadIdE (@?= expectedUploadId)
where where
cases = [ cases = [
@ -129,7 +130,7 @@ testParseListObjectsResult = do
object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 Map.empty object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 Map.empty
modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12 modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12
parsedListObjectsResult <- tryValidationErr $ parseListObjectsResponse xmldata parsedListObjectsResult <- tryValidationErr $ runTestNS $ parseListObjectsResponse xmldata
eitherValidationErr parsedListObjectsResult (@?= expectedListResult) eitherValidationErr parsedListObjectsResult (@?= expectedListResult)
testParseListObjectsV1Result :: Assertion testParseListObjectsV1Result :: Assertion
@ -156,7 +157,7 @@ testParseListObjectsV1Result = do
object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 Map.empty object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 Map.empty
modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12 modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12
parsedListObjectsV1Result <- tryValidationErr $ parseListObjectsV1Response xmldata parsedListObjectsV1Result <- tryValidationErr $ runTestNS $ parseListObjectsV1Response xmldata
eitherValidationErr parsedListObjectsV1Result (@?= expectedListResult) eitherValidationErr parsedListObjectsV1Result (@?= expectedListResult)
testParseListIncompleteUploads :: Assertion testParseListIncompleteUploads :: Assertion
@ -198,7 +199,7 @@ testParseListIncompleteUploads = do
initTime = UTCTime (fromGregorian 2010 11 26) 69857 initTime = UTCTime (fromGregorian 2010 11 26) 69857
prefixes = ["photos/", "videos/"] prefixes = ["photos/", "videos/"]
parsedListUploadsResult <- tryValidationErr $ parseListUploadsResponse xmldata parsedListUploadsResult <- tryValidationErr $ runTestNS $ parseListUploadsResponse xmldata
eitherValidationErr parsedListUploadsResult (@?= expectedListResult) eitherValidationErr parsedListUploadsResult (@?= expectedListResult)
@ -214,7 +215,7 @@ testParseCompleteMultipartUploadResponse = do
\</CompleteMultipartUploadResult>" \</CompleteMultipartUploadResult>"
expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\"" expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\""
parsedETagE <- runExceptT $ parseCompleteMultipartUploadResponse xmldata parsedETagE <- runExceptT $ runTestNS $ parseCompleteMultipartUploadResponse xmldata
eitherValidationErr parsedETagE (@?= expectedETag) eitherValidationErr parsedETagE (@?= expectedETag)
testParseListPartsResponse :: Assertion testParseListPartsResponse :: Assertion
@ -258,7 +259,7 @@ testParseListPartsResponse = do
part2 = ObjectPartInfo 3 "\"aaaa18db4cc2f85cedef654fccc4a4x8\"" 10485760 modifiedTime2 part2 = ObjectPartInfo 3 "\"aaaa18db4cc2f85cedef654fccc4a4x8\"" 10485760 modifiedTime2
modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10 modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10
parsedListPartsResult <- runExceptT $ parseListPartsResponse xmldata parsedListPartsResult <- runExceptT $ runTestNS $ parseListPartsResponse xmldata
eitherValidationErr parsedListPartsResult (@?= expectedListResult) eitherValidationErr parsedListPartsResult (@?= expectedListResult)
testParseCopyObjectResponse :: Assertion testParseCopyObjectResponse :: Assertion
@ -280,7 +281,7 @@ testParseCopyObjectResponse = do
UTCTime (fromGregorian 2009 10 28) 81120))] UTCTime (fromGregorian 2009 10 28) 81120))]
forM_ cases $ \(xmldata, (etag, modTime)) -> do forM_ cases $ \(xmldata, (etag, modTime)) -> do
parseResult <- runExceptT $ parseCopyObjectResponse xmldata parseResult <- runExceptT $ runTestNS $ parseCopyObjectResponse xmldata
eitherValidationErr parseResult (@?= (etag, modTime)) eitherValidationErr parseResult (@?= (etag, modTime))
testParseNotification :: Assertion testParseNotification :: Assertion
@ -354,5 +355,5 @@ testParseNotification = do
] ]
forM_ cases $ \(xmldata, val) -> do forM_ cases $ \(xmldata, val) -> do
result <- runExceptT $ parseNotification xmldata result <- runExceptT $ runTestNS $ parseNotification xmldata
eitherValidationErr result (@?= val) eitherValidationErr result (@?= val)