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

Clean up with better combinators

Browse Source
This commit is contained in:
Aditya Manthramurthy 2017-01-22 21:31:22 +05:30
parent a12fa8a077
commit dafa01d7db
1 changed files with 34 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -21,65 +21,67 @@ import Network.Minio.Data
s3TimeFormat :: [Char] s3TimeFormat :: [Char]
s3TimeFormat = iso8601DateFormat $ Just "%T%QZ" s3TimeFormat = iso8601DateFormat $ Just "%T%QZ"
-- | Parse time strings from XML
parseS3XMLTime :: (MonadError MinioErr m) => Text -> m UTCTime
parseS3XMLTime = either (throwError . MErrXml) return
. parseTimeM True defaultTimeLocale s3TimeFormat
. T.unpack
s3Elem :: Text -> Axis
s3Elem = element . s3Name
parseRoot :: (MonadError MinioErr m) => LByteString -> m Cursor
parseRoot = either (throwError . MErrXml . show) (return . fromDocument)
. parseLBS def
-- | Parse the response XML of a list buckets call. -- | Parse the response XML of a list buckets call.
parseListBuckets :: (MonadError MinioErr m) => LByteString -> m [BucketInfo] parseListBuckets :: (MonadError MinioErr m) => LByteString -> m [BucketInfo]
parseListBuckets xmldata = do parseListBuckets xmldata = do
doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata r <- parseRoot xmldata
let cursor = fromDocument doc let
names = cursor $// element (s3Name "Bucket") &// names = r $// s3Elem "Bucket" &// s3Elem "Name" &/ content
element (s3Name "Name") &/ content timeStrings = r $// s3Elem "Bucket" &// s3Elem "CreationDate" &/ content
timeStrings = cursor $// element (s3Name "Bucket") &//
element (s3Name "CreationDate") &/ content times <- mapM parseS3XMLTime timeStrings
times <- either (throwError . MErrXml) return $
mapM (parseTimeM True defaultTimeLocale s3TimeFormat . T.unpack)
timeStrings
return $ map (\(n, t) -> BucketInfo n t) $ zip names times return $ map (\(n, t) -> BucketInfo n t) $ zip names times
-- | Parse the response XML of a location request. -- | Parse the response XML of a location request.
parseLocation :: (MonadError MinioErr m) => LByteString -> m Region parseLocation :: (MonadError MinioErr m) => LByteString -> m Region
parseLocation xmldata = do parseLocation xmldata = do
doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata r <- parseRoot xmldata
return $ T.concat $ fromDocument doc $/ content return $ T.concat $ r $/ content
-- | Parse the response XML of an newMultipartUpload call. -- | Parse the response XML of an newMultipartUpload call.
parseNewMultipartUpload :: (MonadError MinioErr m) parseNewMultipartUpload :: (MonadError MinioErr m)
=> LByteString -> m UploadId => LByteString -> m UploadId
parseNewMultipartUpload xmldata = do parseNewMultipartUpload xmldata = do
doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata r <- parseRoot xmldata
return $ T.concat $ fromDocument doc return $ T.concat $ r $// element (s3Name "UploadId") &/ content
$// element (s3Name "UploadId") &/ content
-- | Parse the response XML of completeMultipartUpload call. -- | Parse the response XML of completeMultipartUpload call.
parseCompleteMultipartUploadResponse :: (MonadError MinioErr m) parseCompleteMultipartUploadResponse :: (MonadError MinioErr m)
=> LByteString -> m ETag => LByteString -> m ETag
parseCompleteMultipartUploadResponse xmldata = do parseCompleteMultipartUploadResponse xmldata = do
doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata r <- parseRoot xmldata
return $ T.concat $ fromDocument doc return $ T.concat $ r $// s3Elem "ETag" &/ content
$// element (s3Name "ETag") &/ content
parseListObjectsResponse :: (MonadError MinioErr m) parseListObjectsResponse :: (MonadError MinioErr m)
=> LByteString -> m ListObjectsResult => LByteString -> m ListObjectsResult
parseListObjectsResponse xmldata = do parseListObjectsResponse xmldata = do
doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata r <- parseRoot xmldata
let let
root = fromDocument doc hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content)
s3Elem = element . s3Name
hasMore = ["true"] == (root $/ s3Elem "IsTruncated" &/ content) nextToken = headMay $ r $/ s3Elem "NextContinuationToken" &/ content
nextToken = headMay $ root $/ s3Elem "NextContinuationToken" &/ content prefixes = r $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ content
prefixes = root $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ content keys = r $/ s3Elem "Contents" &/ s3Elem "Key" &/ content
modTimeStr = r $/ s3Elem "Contents" &/ s3Elem "LastModified" &/ content
etags = r $/ s3Elem "Contents" &/ s3Elem "ETag" &/ content
sizeStr = r $/ s3Elem "Contents" &/ s3Elem "Size" &/ content
keys = root $/ s3Elem "Contents" &/ s3Elem "Key" &/ content modTimes <- mapM parseS3XMLTime modTimeStr
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 -> sizes <- forM sizeStr $ \str ->
either (throwError . MErrXml . show) return $ fst <$> decimal str either (throwError . MErrXml . show) return $ fst <$> decimal str