94 lines
3.5 KiB
Haskell
94 lines
3.5 KiB
Haskell
module Network.Minio.XmlParser
|
|
( parseListBuckets
|
|
, parseLocation
|
|
, parseNewMultipartUpload
|
|
, parseCompleteMultipartUploadResponse
|
|
, parseListObjectsResponse
|
|
) where
|
|
|
|
import Data.List (zip4)
|
|
import qualified Data.Text as T
|
|
import Data.Text.Read (decimal)
|
|
import Data.Time
|
|
import Text.XML
|
|
import Text.XML.Cursor
|
|
|
|
import Lib.Prelude
|
|
|
|
import Network.Minio.Data
|
|
|
|
-- | Represent the time format string returned by S3 API calls.
|
|
s3TimeFormat :: [Char]
|
|
s3TimeFormat = iso8601DateFormat $ Just "%T%QZ"
|
|
|
|
-- | Parse the response XML of a list buckets call.
|
|
parseListBuckets :: (MonadError MinioErr m) => LByteString -> m [BucketInfo]
|
|
parseListBuckets xmldata = do
|
|
doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata
|
|
let cursor = fromDocument doc
|
|
names = cursor $// element (s3Name "Bucket") &//
|
|
element (s3Name "Name") &/ content
|
|
timeStrings = cursor $// element (s3Name "Bucket") &//
|
|
element (s3Name "CreationDate") &/ content
|
|
times <- either (throwError . MErrXml) return $
|
|
mapM (parseTimeM True defaultTimeLocale s3TimeFormat . T.unpack)
|
|
timeStrings
|
|
return $ map (\(n, t) -> BucketInfo n t) $ zip names times
|
|
|
|
-- | Parse the response XML of a location request.
|
|
parseLocation :: (MonadError MinioErr m) => LByteString -> m Region
|
|
parseLocation xmldata = do
|
|
doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata
|
|
return $ T.concat $ fromDocument doc $/ content
|
|
|
|
-- | Parse the response XML of an newMultipartUpload call.
|
|
parseNewMultipartUpload :: (MonadError MinioErr m)
|
|
=> LByteString -> m UploadId
|
|
parseNewMultipartUpload xmldata = do
|
|
doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata
|
|
return $ T.concat $ fromDocument doc
|
|
$// element (s3Name "UploadId") &/ content
|
|
|
|
-- | Parse the response XML of completeMultipartUpload call.
|
|
parseCompleteMultipartUploadResponse :: (MonadError MinioErr m)
|
|
=> LByteString -> m ETag
|
|
parseCompleteMultipartUploadResponse xmldata = do
|
|
doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata
|
|
return $ T.concat $ fromDocument doc
|
|
$// element (s3Name "ETag") &/ content
|
|
|
|
parseListObjectsResponse :: (MonadError MinioErr m)
|
|
=> LByteString -> m ListObjectsResult
|
|
parseListObjectsResponse xmldata = do
|
|
doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata
|
|
|
|
let
|
|
root = fromDocument doc
|
|
s3Elem = element . s3Name
|
|
|
|
hasMore = ["true"] == (root $/ s3Elem "IsTruncated" &/ content)
|
|
|
|
nextToken = headMay $ root $/ s3Elem "NextContinuationToken" &/ content
|
|
|
|
prefixes = root $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ content
|
|
|
|
keys = root $/ s3Elem "Contents" &/ s3Elem "Key" &/ content
|
|
modTimeStr = root $/ s3Elem "Contents" &/ s3Elem "LastModified" &/ content
|
|
etags = root $/ s3Elem "Contents" &/ s3Elem "ETag" &/ content
|
|
sizeStr = root $/ s3Elem "Contents" &/ s3Elem "Size" &/ content
|
|
|
|
modTimes <- either (throwError . MErrXml) return $
|
|
mapM (parseTimeM True defaultTimeLocale s3TimeFormat . T.unpack) $
|
|
modTimeStr
|
|
|
|
sizes <- forM sizeStr $ \str ->
|
|
either (throwError . MErrXml . show) return $ fst <$> decimal str
|
|
|
|
let
|
|
uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
|
|
uncurry4 f (a, b, c, d) = f a b c d
|
|
|
|
objects = map (uncurry4 ObjectInfo) $ zip4 keys modTimes etags sizes
|
|
|
|
return $ ListObjectsResult hasMore nextToken objects prefixes
|