fa62ed599a
This change adds support for requesting temporary object storage credentials using the STS API. Some breaking changes are introduced to enable this support: - `Credentials` type has been removed. Use the `CredentialValue` type instead. Corresponding to this the type signature for `setCreds` has changed, though the functionality is the same. - The type alias `Provider` has been renamed to `CredentialLoader` to avoid naming confusion.
231 lines
9.3 KiB
Haskell
231 lines
9.3 KiB
Haskell
--
|
|
-- MinIO Haskell SDK, (C) 2017-2023 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.XmlParser
|
|
( parseListBuckets,
|
|
parseLocation,
|
|
parseNewMultipartUpload,
|
|
parseCompleteMultipartUploadResponse,
|
|
parseCopyObjectResponse,
|
|
parseListObjectsResponse,
|
|
parseListObjectsV1Response,
|
|
parseListUploadsResponse,
|
|
parseListPartsResponse,
|
|
parseErrResponse,
|
|
parseNotification,
|
|
parseSelectProgress,
|
|
)
|
|
where
|
|
|
|
import qualified Data.ByteString.Lazy as LB
|
|
import qualified Data.HashMap.Strict as H
|
|
import Data.List (zip4, zip6)
|
|
import qualified Data.Text as T
|
|
import Data.Time
|
|
import Network.Minio.Data
|
|
import Network.Minio.XmlCommon
|
|
import Text.XML.Cursor hiding (bool)
|
|
|
|
-- | Parse the response XML of a list buckets call.
|
|
parseListBuckets :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m [BucketInfo]
|
|
parseListBuckets xmldata = do
|
|
r <- parseRoot xmldata
|
|
ns <- asks getSvcNamespace
|
|
let 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
|
|
|
|
-- | Parse the response XML of a location request.
|
|
parseLocation :: (MonadIO m) => LByteString -> m Region
|
|
parseLocation xmldata = do
|
|
r <- parseRoot xmldata
|
|
let region = T.concat $ r $/ content
|
|
return $ bool "us-east-1" region $ region /= ""
|
|
|
|
-- | Parse the response XML of an newMultipartUpload call.
|
|
parseNewMultipartUpload :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m UploadId
|
|
parseNewMultipartUpload xmldata = do
|
|
r <- parseRoot xmldata
|
|
ns <- asks getSvcNamespace
|
|
let s3Elem' = s3Elem ns
|
|
return $ T.concat $ r $// s3Elem' "UploadId" &/ content
|
|
|
|
-- | Parse the response XML of completeMultipartUpload call.
|
|
parseCompleteMultipartUploadResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ETag
|
|
parseCompleteMultipartUploadResponse xmldata = do
|
|
r <- parseRoot xmldata
|
|
ns <- asks getSvcNamespace
|
|
let s3Elem' = s3Elem ns
|
|
return $ T.concat $ r $// s3Elem' "ETag" &/ content
|
|
|
|
-- | Parse the response XML of copyObject and copyObjectPart
|
|
parseCopyObjectResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m (ETag, UTCTime)
|
|
parseCopyObjectResponse xmldata = do
|
|
r <- parseRoot xmldata
|
|
ns <- asks getSvcNamespace
|
|
let s3Elem' = s3Elem ns
|
|
mtimeStr = T.concat $ r $// s3Elem' "LastModified" &/ content
|
|
|
|
mtime <- parseS3XMLTime mtimeStr
|
|
return (T.concat $ r $// s3Elem' "ETag" &/ content, mtime)
|
|
|
|
-- | Parse the response XML of a list objects v1 call.
|
|
parseListObjectsV1Response ::
|
|
(MonadReader env m, HasSvcNamespace env, MonadIO m) =>
|
|
LByteString ->
|
|
m ListObjectsV1Result
|
|
parseListObjectsV1Response xmldata = do
|
|
r <- parseRoot xmldata
|
|
ns <- asks getSvcNamespace
|
|
let s3Elem' = s3Elem ns
|
|
hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)
|
|
nextMarker = listToMaybe $ r $/ s3Elem' "NextMarker" &/ content
|
|
prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content
|
|
keys = r $/ s3Elem' "Contents" &/ s3Elem' "Key" &/ content
|
|
modTimeStr = r $/ s3Elem' "Contents" &/ s3Elem' "LastModified" &/ content
|
|
etagsList = r $/ s3Elem' "Contents" &/ s3Elem' "ETag" &/ content
|
|
-- if response xml contains empty etag response fill them with as
|
|
-- many empty Text for the zip4 below to work as intended.
|
|
etags = etagsList ++ repeat ""
|
|
sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content
|
|
|
|
modTimes <- mapM parseS3XMLTime modTimeStr
|
|
sizes <- parseDecimals sizeStr
|
|
|
|
let objects =
|
|
map (uncurry6 ObjectInfo) $
|
|
zip6 keys modTimes etags sizes (repeat H.empty) (repeat H.empty)
|
|
|
|
return $ ListObjectsV1Result hasMore nextMarker objects prefixes
|
|
|
|
-- | Parse the response XML of a list objects call.
|
|
parseListObjectsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListObjectsResult
|
|
parseListObjectsResponse xmldata = do
|
|
r <- parseRoot xmldata
|
|
ns <- asks getSvcNamespace
|
|
let s3Elem' = s3Elem ns
|
|
hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)
|
|
nextToken = listToMaybe $ r $/ s3Elem' "NextContinuationToken" &/ content
|
|
prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content
|
|
keys = r $/ s3Elem' "Contents" &/ s3Elem' "Key" &/ content
|
|
modTimeStr = r $/ s3Elem' "Contents" &/ s3Elem' "LastModified" &/ content
|
|
etagsList = r $/ s3Elem' "Contents" &/ s3Elem' "ETag" &/ content
|
|
-- if response xml contains empty etag response fill them with as
|
|
-- many empty Text for the zip4 below to work as intended.
|
|
etags = etagsList ++ repeat ""
|
|
sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content
|
|
|
|
modTimes <- mapM parseS3XMLTime modTimeStr
|
|
sizes <- parseDecimals sizeStr
|
|
|
|
let objects =
|
|
map (uncurry6 ObjectInfo) $
|
|
zip6 keys modTimes etags sizes (repeat H.empty) (repeat H.empty)
|
|
|
|
return $ ListObjectsResult hasMore nextToken objects prefixes
|
|
|
|
-- | Parse the response XML of a list incomplete multipart upload call.
|
|
parseListUploadsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListUploadsResult
|
|
parseListUploadsResponse xmldata = do
|
|
r <- parseRoot xmldata
|
|
ns <- asks getSvcNamespace
|
|
let s3Elem' = s3Elem ns
|
|
hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)
|
|
prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content
|
|
nextKey = listToMaybe $ r $/ s3Elem' "NextKeyMarker" &/ content
|
|
nextUpload = listToMaybe $ 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
|
|
|
|
let uploads = zip3 uploadKeys uploadIds uploadInitTimes
|
|
|
|
return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes
|
|
|
|
parseListPartsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListPartsResult
|
|
parseListPartsResponse xmldata = do
|
|
r <- parseRoot xmldata
|
|
ns <- asks getSvcNamespace
|
|
let s3Elem' = s3Elem ns
|
|
hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)
|
|
nextPartNumStr = listToMaybe $ 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
|
|
partNumbers <- parseDecimals partNumberStr
|
|
nextPartNum <- parseDecimals $ maybeToList nextPartNumStr
|
|
|
|
let partInfos =
|
|
map (uncurry4 ObjectPartInfo) $
|
|
zip4 partNumbers partETags partSizes partModTimes
|
|
|
|
return $ ListPartsResult hasMore (listToMaybe nextPartNum) partInfos
|
|
|
|
parseNotification :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m Notification
|
|
parseNotification xmldata = do
|
|
r <- parseRoot xmldata
|
|
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 ns c =
|
|
let name = T.concat $ c $/ s3Elem ns "Name" &/ content
|
|
value = T.concat $ c $/ s3Elem ns "Value" &/ content
|
|
in FilterRule name value
|
|
parseNode ns arnName nodeData = do
|
|
let c = fromNode nodeData
|
|
itemId = T.concat $ c $/ s3Elem ns "Id" &/ content
|
|
arn = T.concat $ c $/ s3Elem ns arnName &/ content
|
|
events = mapMaybe textToEvent (c $/ s3Elem ns "Event" &/ content)
|
|
rules =
|
|
c
|
|
$/ s3Elem ns "Filter"
|
|
&/ s3Elem ns "S3Key"
|
|
&/ s3Elem ns "FilterRule"
|
|
&| getFilterRule ns
|
|
return $
|
|
NotificationConfig
|
|
itemId
|
|
arn
|
|
events
|
|
(Filter $ FilterKey $ FilterRules rules)
|
|
|
|
parseSelectProgress :: MonadIO m => ByteString -> m Progress
|
|
parseSelectProgress xmldata = do
|
|
r <- parseRoot $ LB.fromStrict xmldata
|
|
let bScanned = T.concat $ r $/ element "BytesScanned" &/ content
|
|
bProcessed = T.concat $ r $/ element "BytesProcessed" &/ content
|
|
bReturned = T.concat $ r $/ element "BytesReturned" &/ content
|
|
Progress
|
|
<$> parseDecimal bScanned
|
|
<*> parseDecimal bProcessed
|
|
<*> parseDecimal bReturned
|