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

Refactor error types returned by the library

Browse Source
This commit is contained in:
Aditya Manthramurthy 2017-01-31 13:05:13 +05:30
parent 5f1ee7fc67
commit f26fbc82a7
7 changed files with 118 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
minio-hs.cabal
View File

@ -41,6 +41,7 @@ library
, cryptonite , cryptonite
, cryptonite-conduit , cryptonite-conduit
, data-default , data-default
, exceptions
, filepath , filepath
, http-client , http-client
, http-conduit , http-conduit
@ -83,6 +84,7 @@ test-suite minio-hs-test
, cryptonite , cryptonite
, cryptonite-conduit , cryptonite-conduit
, data-default , data-default
, exceptions
, filepath , filepath
, http-client , http-client
, http-conduit , http-conduit
@ -110,6 +112,7 @@ test-suite minio-hs-test
, NoImplicitPrelude , NoImplicitPrelude
, MultiParamTypeClasses , MultiParamTypeClasses
, MultiWayIf , MultiWayIf
, ScopedTypeVariables
, RankNTypes , RankNTypes
, TupleSections , TupleSections
, TypeFamilies , TypeFamilies

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

@ -2,6 +2,7 @@
module Network.Minio.Data where module Network.Minio.Data where
import Control.Monad.Base import Control.Monad.Base
import qualified Control.Monad.Catch as MC
import Control.Monad.Trans.Control import Control.Monad.Trans.Control
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import qualified Data.ByteString as B import qualified Data.ByteString as B
@ -149,25 +150,8 @@ getPathFromRI ri = B.concat $ parts
getRegionFromRI :: RequestInfo -> Text getRegionFromRI :: RequestInfo -> Text
getRegionFromRI ri = maybe "us-east-1" identity (riRegion ri) getRegionFromRI ri = maybe "us-east-1" identity (riRegion ri)
-- | Various validation errors
data MErrV = MErrVSinglePUTSizeExceeded Int64
| MErrVPutSizeExceeded Int64
| MErrVETagHeaderNotFound
deriving (Show)
-- |
-- Minio Error data type for various errors/exceptions caught and
-- returned.
data MinioErr = MErrMsg ByteString -- generic
| MErrHttp HttpException -- http exceptions
| MErrXml ByteString -- XML parsing/generation errors
| MErrService ByteString -- error response from service
| MErrValidation MErrV -- client-side validation errors
| MErrIO IOException -- exceptions while working with files
deriving (Show)
newtype Minio a = Minio { newtype Minio a = Minio {
unMinio :: ReaderT MinioConn (ExceptT MinioErr (ResourceT IO)) a unMinio :: ReaderT MinioConn (ResourceT IO) a
} }
deriving ( deriving (
Functor Functor
@ -175,14 +159,14 @@ newtype Minio a = Minio {
, Monad , Monad
, MonadIO , MonadIO
, MonadReader MinioConn , MonadReader MinioConn
, MonadError MinioErr
, MonadThrow , MonadThrow
, MC.MonadCatch
, MonadBase IO , MonadBase IO
, MonadResource , MonadResource
) )
instance MonadBaseControl IO Minio where instance MonadBaseControl IO Minio where
type StM Minio a = Either MinioErr a type StM Minio a = a
liftBaseWith f = Minio $ liftBaseWith $ \q -> f (q . unMinio) liftBaseWith f = Minio $ liftBaseWith $ \q -> f (q . unMinio)
restoreM = Minio . restoreM restoreM = Minio . restoreM
@ -203,7 +187,42 @@ connect ci = do
runMinio :: ConnectInfo -> Minio a -> ResourceT IO (Either MinioErr a) runMinio :: ConnectInfo -> Minio a -> ResourceT IO (Either MinioErr a)
runMinio ci m = do runMinio ci m = do
conn <- liftIO $ connect ci conn <- liftIO $ connect ci
runExceptT . flip runReaderT conn . unMinio $ m flip runReaderT conn . unMinio $
(m >>= (return . Right))
`MC.catch` handlerME
`MC.catch` handlerHE
`MC.catch` handlerFE
where
handlerME = return . Left . ME
handlerHE = return . Left . MEHttp
handlerFE = return . Left . MEFile
s3Name :: Text -> Name s3Name :: Text -> Name
s3Name s = Name s (Just "http://s3.amazonaws.com/doc/2006-03-01/") Nothing s3Name s = Name s (Just "http://s3.amazonaws.com/doc/2006-03-01/") Nothing
---------------------------------
-- Errors
---------------------------------
-- | Various validation errors
data MErrV = MErrVSinglePUTSizeExceeded Int64
| MErrVPutSizeExceeded Int64
| MErrVETagHeaderNotFound
deriving (Show, Eq)
-- | Errors thrown by the library
data MinioErr = ME MError
| MEHttp HttpException
| MEFile IOException
deriving (Show)
instance Exception MinioErr
-- | Library internal errors
data MError = XMLParseError Text
| ResponseError (NC.Response LByteString)
| ValidationError MErrV
deriving (Show, Eq)
instance Exception MError

2
src/Network/Minio/PutObject.hs
View File

@ -66,7 +66,7 @@ putObject b o (ODFile fp sizeMay) = do
etag <- putObjectSingle b o [] h 0 size etag <- putObjectSingle b o [] h 0 size
R.release rKey R.release rKey
return etag return etag
| size > maxObjectSize -> throwError $ MErrValidation $ | size > maxObjectSize -> R.throwM $ ValidationError $
MErrVPutSizeExceeded size MErrVPutSizeExceeded size
| isSeekable -> parallelMultipartUpload b o fp size | isSeekable -> parallelMultipartUpload b o fp size
| otherwise -> sequentialMultipartUpload b o (Just size) $ | otherwise -> sequentialMultipartUpload b o (Just size) $

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

@ -35,6 +35,7 @@ module Network.Minio.S3API
) where ) where
import Control.Monad.Trans.Resource
import qualified Data.Conduit as C import qualified Data.Conduit as C
import Data.Default (def) import Data.Default (def)
import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Conduit as NC
@ -96,7 +97,7 @@ putObjectSingle :: Bucket -> Object -> [HT.Header] -> Handle -> Int64
putObjectSingle bucket object headers h offset size = do putObjectSingle bucket object headers h offset size = do
-- check length is within single PUT object size. -- check length is within single PUT object size.
when (size > maxSinglePutObjectSizeBytes) $ when (size > maxSinglePutObjectSizeBytes) $
throwError $ MErrValidation $ MErrVSinglePUTSizeExceeded size throwM $ ValidationError $ MErrVSinglePUTSizeExceeded size
-- content-length header is automatically set by library. -- content-length header is automatically set by library.
resp <- executeRequest $ resp <- executeRequest $
@ -110,7 +111,7 @@ putObjectSingle bucket object headers h offset size = do
let rheaders = NC.responseHeaders resp let rheaders = NC.responseHeaders resp
etag = getETagHeader rheaders etag = getETagHeader rheaders
maybe maybe
(throwError $ MErrValidation MErrVETagHeaderNotFound) (throwM $ ValidationError MErrVETagHeaderNotFound)
return etag return etag
@ -176,7 +177,7 @@ putObjectPart bucket object uploadId partNumber headers payload = do
let rheaders = NC.responseHeaders resp let rheaders = NC.responseHeaders resp
etag = getETagHeader rheaders etag = getETagHeader rheaders
maybe maybe
(throwError $ MErrValidation MErrVETagHeaderNotFound) (throwM $ ValidationError MErrVETagHeaderNotFound)
(return . PartInfo partNumber) etag (return . PartInfo partNumber) etag
where where
params = [ params = [

44
src/Network/Minio/Utils.hs
View File

@ -3,9 +3,10 @@ module Network.Minio.Utils where
import qualified Control.Concurrent.Async.Lifted as A import qualified Control.Concurrent.Async.Lifted as A
import qualified Control.Concurrent.QSem as Q import qualified Control.Concurrent.QSem as Q
import qualified Control.Exception.Lifted as ExL import qualified Control.Exception.Lifted as ExL
import Control.Monad.Catch (throwM)
import qualified Control.Monad.Catch as MC
import Control.Monad.Trans.Control (liftBaseOp_, StM) import Control.Monad.Trans.Control (liftBaseOp_, StM)
import qualified Control.Monad.Trans.Resource as R import qualified Control.Monad.Trans.Resource as R
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Conduit as C import qualified Data.Conduit as C
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import qualified Network.HTTP.Client as NClient import qualified Network.HTTP.Client as NClient
@ -18,26 +19,27 @@ import Lib.Prelude
import Network.Minio.Data import Network.Minio.Data
allocateReadFile :: (R.MonadResource m, MonadError MinioErr m) allocateReadFile :: (R.MonadResource m, R.MonadResourceBase m)
=> FilePath -> m (R.ReleaseKey, Handle) => FilePath -> m (R.ReleaseKey, Handle)
allocateReadFile fp = do allocateReadFile fp = do
(rk, hdlE) <- R.allocate (openReadFile fp) cleanup (rk, hdlE) <- R.allocate (openReadFile fp) cleanup
either (throwError . MErrIO) (return . (rk,)) hdlE either (MC.throwM . MEFile) (return . (rk,)) hdlE
where where
openReadFile f = ExL.try $ IO.openBinaryFile f IO.ReadMode openReadFile f = ExL.try $ IO.openBinaryFile f IO.ReadMode
cleanup = either (const $ return ()) IO.hClose cleanup = either (const $ return ()) IO.hClose
getFileSize :: (R.MonadResourceBase m, R.MonadResource m, MonadError MinioErr m) getFileSize :: (R.MonadResourceBase m, R.MonadResource m)
=> Handle -> m (Either IOException Int64) => Handle -> m (Either IOException Int64)
getFileSize h = ExL.try $ liftIO $ fromIntegral <$> IO.hFileSize h getFileSize h = ExL.try $ liftIO $ fromIntegral <$> IO.hFileSize h
isFileSeekable :: (R.MonadResource m, MonadError MinioErr m) isFileSeekable :: (R.MonadResource m, R.MonadResourceBase m)
=> FilePath -> m Bool => FilePath -> m Bool
isFileSeekable fp = do isFileSeekable fp = do
(rKey, h) <- allocateReadFile fp (rKey, h) <- allocateReadFile fp
isSeekable <- liftIO $ IO.hIsSeekable h resE <- liftIO $ try $ IO.hIsSeekable h
R.release rKey R.release rKey
return isSeekable either (MC.throwM . MEFile) return resE
lookupHeader :: HT.HeaderName -> [HT.Header] -> Maybe ByteString lookupHeader :: HT.HeaderName -> [HT.Header] -> Maybe ByteString
lookupHeader hdr = headMay . map snd . filter (\(h, _) -> h == hdr) lookupHeader hdr = headMay . map snd . filter (\(h, _) -> h == hdr)
@ -52,30 +54,34 @@ isSuccessStatus :: HT.Status -> Bool
isSuccessStatus sts = let s = HT.statusCode sts isSuccessStatus sts = let s = HT.statusCode sts
in (s >= 200 && s < 300) in (s >= 200 && s < 300)
checkEither :: (Monad m, MonadError MinioErr m) httpLbs :: (R.MonadThrow m, MonadIO m)
=> (e -> MinioErr) -> (Either e a) -> m a
checkEither f = either (throwError . f) return
httpLbs :: (MonadError MinioErr m, MonadIO m)
=> NC.Request -> NC.Manager => NC.Request -> NC.Manager
-> m (NC.Response LByteString) -> m (NC.Response LByteString)
httpLbs req mgr = do httpLbs req mgr = do
respE <- liftIO $ try $ NClient.httpLbs req mgr respE <- liftIO $ tryHttpEx $ (NClient.httpLbs req mgr)
resp <- checkEither MErrHttp respE resp <- either throwM return respE
unless (isSuccessStatus $ NC.responseStatus resp) $ unless (isSuccessStatus $ NC.responseStatus resp) $
throwError $ MErrService $ LBS.toStrict $ NC.responseBody resp throwM $ ResponseError resp
return resp return resp
where
tryHttpEx :: (IO (NC.Response LByteString))
-> IO (Either NC.HttpException (NC.Response LByteString))
tryHttpEx = try
http :: (MonadError MinioErr m, R.MonadResourceBase m, R.MonadResource m) http :: (R.MonadResourceBase m, R.MonadResource m)
=> NC.Request -> NC.Manager => NC.Request -> NC.Manager
-> m (Response (C.ResumableSource m ByteString)) -> m (Response (C.ResumableSource m ByteString))
http req mgr = do http req mgr = do
respE <- ExL.try $ NC.http req mgr respE <- tryHttpEx $ NC.http req mgr
resp <- checkEither MErrHttp respE resp <- either throwM return respE
unless (isSuccessStatus $ NC.responseStatus resp) $ do unless (isSuccessStatus $ NC.responseStatus resp) $ do
lbsResp <- NC.lbsResponse resp lbsResp <- NC.lbsResponse resp
throwError $ MErrService $ LBS.toStrict $ NC.responseBody lbsResp throwM $ ResponseError lbsResp
return resp return resp
where
tryHttpEx :: (R.MonadResourceBase m) => (m a)
-> m (Either NC.HttpException a)
tryHttpEx = ExL.try
-- like mapConcurrently but with a limited number of concurrent -- like mapConcurrently but with a limited number of concurrent
-- threads. -- threads.

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

@ -8,7 +8,8 @@ module Network.Minio.XmlParser
, parseListPartsResponse , parseListPartsResponse
) where ) where
import Data.List (zip3, zip4) import Control.Monad.Trans.Resource
import Data.List (zip3, zip4)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Read (decimal) import Data.Text.Read (decimal)
import Data.Time import Data.Time
@ -32,24 +33,24 @@ s3TimeFormat :: [Char]
s3TimeFormat = iso8601DateFormat $ Just "%T%QZ" s3TimeFormat = iso8601DateFormat $ Just "%T%QZ"
-- | Parse time strings from XML -- | Parse time strings from XML
parseS3XMLTime :: (MonadError MinioErr m) => Text -> m UTCTime parseS3XMLTime :: (MonadThrow m) => Text -> m UTCTime
parseS3XMLTime = either (throwError . MErrXml) return parseS3XMLTime = either (throwM . XMLParseError) return
. parseTimeM True defaultTimeLocale s3TimeFormat . parseTimeM True defaultTimeLocale s3TimeFormat
. T.unpack . T.unpack
parseDecimals :: (MonadError MinioErr m, Integral a) => [Text] -> m [a] parseDecimals :: (MonadThrow m, Integral a) => [Text] -> m [a]
parseDecimals numStr = forM numStr $ \str -> parseDecimals numStr = forM numStr $ \str ->
either (throwError . MErrXml . show) return $ fst <$> decimal str either (throwM . XMLParseError . show) return $ fst <$> decimal str
s3Elem :: Text -> Axis s3Elem :: Text -> Axis
s3Elem = element . s3Name s3Elem = element . s3Name
parseRoot :: (MonadError MinioErr m) => LByteString -> m Cursor parseRoot :: (MonadThrow m) => LByteString -> m Cursor
parseRoot = either (throwError . MErrXml . show) (return . fromDocument) parseRoot = either (throwM . XMLParseError . 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 :: (MonadError MinioErr m) => LByteString -> m [BucketInfo] parseListBuckets :: (MonadThrow m) => LByteString -> m [BucketInfo]
parseListBuckets xmldata = do parseListBuckets xmldata = do
r <- parseRoot xmldata r <- parseRoot xmldata
let let
@ -60,27 +61,27 @@ parseListBuckets xmldata = do
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 :: (MonadThrow m) => LByteString -> m Region
parseLocation xmldata = do parseLocation xmldata = do
r <- parseRoot xmldata r <- parseRoot xmldata
return $ T.concat $ r $/ 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 :: (MonadThrow m)
=> LByteString -> m UploadId => LByteString -> m UploadId
parseNewMultipartUpload xmldata = do parseNewMultipartUpload xmldata = do
r <- parseRoot xmldata r <- parseRoot xmldata
return $ T.concat $ r $// element (s3Name "UploadId") &/ content return $ T.concat $ r $// element (s3Name "UploadId") &/ content
-- | Parse the response XML of completeMultipartUpload call. -- | Parse the response XML of completeMultipartUpload call.
parseCompleteMultipartUploadResponse :: (MonadError MinioErr m) parseCompleteMultipartUploadResponse :: (MonadThrow m)
=> LByteString -> m ETag => LByteString -> m ETag
parseCompleteMultipartUploadResponse xmldata = do parseCompleteMultipartUploadResponse xmldata = do
r <- parseRoot xmldata r <- parseRoot xmldata
return $ T.concat $ r $// s3Elem "ETag" &/ content return $ T.concat $ r $// s3Elem "ETag" &/ content
-- | Parse the response XML of a list objects call. -- | Parse the response XML of a list objects call.
parseListObjectsResponse :: (MonadError MinioErr m) parseListObjectsResponse :: (MonadThrow m)
=> LByteString -> m ListObjectsResult => LByteString -> m ListObjectsResult
parseListObjectsResponse xmldata = do parseListObjectsResponse xmldata = do
r <- parseRoot xmldata r <- parseRoot xmldata
@ -106,7 +107,7 @@ 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 :: (MonadError MinioErr m) parseListUploadsResponse :: (MonadThrow m)
=> LByteString -> m ListUploadsResult => LByteString -> m ListUploadsResult
parseListUploadsResponse xmldata = do parseListUploadsResponse xmldata = do
r <- parseRoot xmldata r <- parseRoot xmldata
@ -126,7 +127,7 @@ parseListUploadsResponse xmldata = do
return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes
parseListPartsResponse :: (MonadError MinioErr m) parseListPartsResponse :: (MonadThrow m)
=> LByteString -> m ListPartsResult => LByteString -> m ListPartsResult
parseListPartsResponse xmldata = do parseListPartsResponse xmldata = do
r <- parseRoot xmldata r <- parseRoot xmldata

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

@ -3,14 +3,15 @@ module Network.Minio.XmlParser.Test
xmlParserTests xmlParserTests
) where ) where
import Test.Tasty import qualified Control.Monad.Catch as MC
import Test.Tasty.HUnit import Data.Time (fromGregorian, UTCTime(..))
import Data.Time (fromGregorian, UTCTime(..)) import Test.Tasty
import Test.Tasty.HUnit
import Lib.Prelude import Lib.Prelude
import Network.Minio.Data import Network.Minio.Data
import Network.Minio.XmlParser import Network.Minio.XmlParser
xmlParserTests :: TestTree xmlParserTests :: TestTree
xmlParserTests = testGroup "XML Parser Tests" xmlParserTests = testGroup "XML Parser Tests"
@ -22,19 +23,26 @@ xmlParserTests = testGroup "XML Parser Tests"
, testCase "Test parseListPartsResponse" testParseListPartsResponse , testCase "Test parseListPartsResponse" testParseListPartsResponse
] ]
tryMError :: (MC.MonadCatch m) => m a -> m (Either MError a)
tryMError act = MC.try act
assertMError :: MError -> Assertion
assertMError e = assertFailure $ "Failed due to exception => " ++ show e
eitherMError :: Either MError a -> (a -> Assertion) -> Assertion
eitherMError (Left e) _ = assertMError e
eitherMError (Right a) f = f a
testParseLocation :: Assertion testParseLocation :: Assertion
testParseLocation = do testParseLocation = do
-- 1. Test parsing of an invalid location constraint xml. -- 1. Test parsing of an invalid location constraint xml.
parsedLocationE <- runExceptT $ parseLocation "ClearlyInvalidXml" parseResE <- tryMError $ parseLocation "ClearlyInvalidXml"
case parsedLocationE of when (isRight parseResE) $
Right _ -> assertFailure $ "Parsing should have failed => " ++ show parsedLocationE assertFailure $ "Parsing should have failed => " ++ show parseResE
Left _ -> return ()
forM_ cases $ \(xmldata, expectedLocation) -> do forM_ cases $ \(xmldata, expectedLocation) -> do
parsedLocationE1 <- runExceptT $ parseLocation xmldata parseLocE <- tryMError $ parseLocation xmldata
case parsedLocationE1 of either assertMError (@?= expectedLocation) parseLocE
Right parsedLocation -> parsedLocation @?= expectedLocation
_ -> assertFailure $ "Parsing failed => " ++ show parsedLocationE1
where where
cases = [ cases = [
-- 2. Test parsing of a valid location xml. -- 2. Test parsing of a valid location xml.
@ -53,10 +61,8 @@ testParseLocation = do
testParseNewMultipartUpload :: Assertion testParseNewMultipartUpload :: Assertion
testParseNewMultipartUpload = do testParseNewMultipartUpload = do
forM_ cases $ \(xmldata, expectedUploadId) -> do forM_ cases $ \(xmldata, expectedUploadId) -> do
parsedUploadIdE <- runExceptT $ parseNewMultipartUpload xmldata parsedUploadIdE <- tryMError $ parseNewMultipartUpload xmldata
case parsedUploadIdE of eitherMError parsedUploadIdE (@?= expectedUploadId)
Right upId -> upId @?= expectedUploadId
_ -> assertFailure $ "Parsing failed => " ++ show parsedUploadIdE
where where
cases = [ cases = [
("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\ ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
@ -100,10 +106,8 @@ testParseListObjectsResult = do
object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234
modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12 modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12
parsedListObjectsResult <- runExceptT $ parseListObjectsResponse xmldata parsedListObjectsResult <- tryMError $ parseListObjectsResponse xmldata
case parsedListObjectsResult of eitherMError parsedListObjectsResult (@?= expectedListResult)
Right listObjectsResult -> listObjectsResult @?= expectedListResult
_ -> assertFailure $ "Parsing failed => " ++ show parsedListObjectsResult
testParseListIncompleteUploads :: Assertion testParseListIncompleteUploads :: Assertion
testParseListIncompleteUploads = do testParseListIncompleteUploads = do
@ -144,10 +148,8 @@ testParseListIncompleteUploads = do
initTime = UTCTime (fromGregorian 2010 11 26) 69857 initTime = UTCTime (fromGregorian 2010 11 26) 69857
prefixes = ["photos/", "videos/"] prefixes = ["photos/", "videos/"]
parsedListUploadsResult <- runExceptT $ parseListUploadsResponse xmldata parsedListUploadsResult <- tryMError $ parseListUploadsResponse xmldata
case parsedListUploadsResult of eitherMError parsedListUploadsResult (@?= expectedListResult)
Right listUploadsResult -> listUploadsResult @?= expectedListResult
_ -> assertFailure $ "Parsing failed => " ++ show parsedListUploadsResult
testParseCompleteMultipartUploadResponse :: Assertion testParseCompleteMultipartUploadResponse :: Assertion
@ -163,9 +165,7 @@ testParseCompleteMultipartUploadResponse = do
expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\"" expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\""
parsedETagE <- runExceptT $ parseCompleteMultipartUploadResponse xmldata parsedETagE <- runExceptT $ parseCompleteMultipartUploadResponse xmldata
case parsedETagE of eitherMError parsedETagE (@?= expectedETag)
Right actualETag -> actualETag @?= expectedETag
_ -> assertFailure $ "Parsing failed => " ++ show parsedETagE
testParseListPartsResponse :: Assertion testParseListPartsResponse :: Assertion
testParseListPartsResponse = do testParseListPartsResponse = do
@ -209,6 +209,4 @@ testParseListPartsResponse = do
modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10 modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10
parsedListPartsResult <- runExceptT $ parseListPartsResponse xmldata parsedListPartsResult <- runExceptT $ parseListPartsResponse xmldata
case parsedListPartsResult of eitherMError parsedListPartsResult (@?= expectedListResult)
Right listPartsResult -> listPartsResult @?= expectedListResult
_ -> assertFailure $ "Parsing failed => " ++ show parsedListPartsResult