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/"

8
test/Network/Minio/Utils/Test.hs
View File

@ -19,12 +19,12 @@ module Network.Minio.Utils.Test
limitedMapConcurrentlyTests limitedMapConcurrentlyTests
) where ) where
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
import Lib.Prelude import Lib.Prelude
import Network.Minio.Utils import Network.Minio.Utils
limitedMapConcurrentlyTests :: TestTree limitedMapConcurrentlyTests :: TestTree
limitedMapConcurrentlyTests = testGroup "limitedMapConcurrently Tests" limitedMapConcurrentlyTests = testGroup "limitedMapConcurrently Tests"

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

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

@ -19,17 +19,18 @@ module Network.Minio.XmlParser.Test
xmlParserTests xmlParserTests
) where ) where
import Data.Default (def) import Data.Default (def)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Time (fromGregorian) import Data.Time (fromGregorian)
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
import UnliftIO (MonadUnliftIO) import UnliftIO (MonadUnliftIO)
import Lib.Prelude 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)