diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index d42045e..d027424 100644 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -34,6 +34,7 @@ module Network.Minio -- with an object storage service. , MinioErr(..) , MErrV(..) + , ServiceErr(..) -- * Data Types ---------------- diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index b3c455c..bfa24aa 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -26,12 +26,12 @@ import qualified Data.ByteString as B import Data.Default (Default(..)) import qualified Data.Map as Map import qualified Data.Text as T +import Data.Time (formatTime, defaultTimeLocale) import Network.HTTP.Client (defaultManagerSettings) import qualified Network.HTTP.Conduit as NC import Network.HTTP.Types (Method, Header, Query) import qualified Network.HTTP.Types as HT import Network.Minio.Errors -import Network.Minio.Utils import Text.XML import Lib.Prelude @@ -361,3 +361,7 @@ runMinio ci m = do s3Name :: Text -> Name s3Name s = Name s (Just "http://s3.amazonaws.com/doc/2006-03-01/") Nothing + +-- | Format as per RFC 1123. +formatRFC1123 :: UTCTime -> T.Text +formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" diff --git a/src/Network/Minio/Errors.hs b/src/Network/Minio/Errors.hs index d8355cd..ac7a66f 100644 --- a/src/Network/Minio/Errors.hs +++ b/src/Network/Minio/Errors.hs @@ -41,11 +41,24 @@ instance Exception MErrV -- | Errors returned by S3 compatible service data ServiceErr = BucketAlreadyExists + | BucketAlreadyOwnedByYou | NoSuchBucket + | InvalidBucketName + | NoSuchKey + | ServiceErr Text Text deriving (Show, Eq) instance Exception ServiceErr +toServiceErr :: Text -> Text -> ServiceErr +toServiceErr "NoSuchKey" _ = NoSuchKey +toServiceErr "NoSuchBucket" _ = NoSuchBucket +toServiceErr "InvalidBucketName" _ = InvalidBucketName +toServiceErr "BucketAlreadyOwnedByYou" _ = BucketAlreadyOwnedByYou +toServiceErr "BucketAlreadyExists" _ = BucketAlreadyExists +toServiceErr code message = ServiceErr code message + + -- | Errors thrown by the library data MinioErr = MErrHTTP NC.HttpException | MErrIO IOException diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs index 8f34b9d..e6997d3 100644 --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -25,6 +25,7 @@ import qualified Control.Monad.Trans.Resource as R import qualified Data.ByteString as B import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB import Data.Default (Default(..)) import qualified Data.Text as T import Data.Text.Encoding.Error (lenientDecode) @@ -40,14 +41,7 @@ import qualified System.IO as IO import Lib.Prelude import Network.Minio.Errors - --- | Represent the time format string returned by S3 API calls. -s3TimeFormat :: [Char] -s3TimeFormat = iso8601DateFormat $ Just "%T%QZ" - --- | Format as per RFC 1123. -formatRFC1123 :: UTCTime -> T.Text -formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" +import Network.Minio.XmlParser (parseErrResponse) allocateReadFile :: (R.MonadResource m, R.MonadResourceBase m) => FilePath -> m (R.ReleaseKey, Handle) @@ -128,12 +122,20 @@ httpLbs req mgr = do respE <- liftIO $ tryHttpEx $ (NClient.httpLbs req mgr) resp <- either throwM return respE unless (isSuccessStatus $ NC.responseStatus resp) $ - throwM $ MErrHTTP $ NC.StatusCodeException (NC.responseStatus resp) [] def + case contentTypeMay resp of + Just "application/xml" -> do + sErr <- parseErrResponse $ NC.responseBody resp + throwM $ MErrService sErr + + _ -> throwM $ + MErrHTTP $ NC.StatusCodeException (NC.responseStatus resp) [] def + return resp where tryHttpEx :: (IO (NC.Response LByteString)) -> IO (Either NC.HttpException (NC.Response LByteString)) tryHttpEx = try + contentTypeMay resp = lookupHeader Hdr.hContentType $ NC.responseHeaders resp http :: (R.MonadResourceBase m, R.MonadResource m) => NC.Request -> NC.Manager @@ -141,13 +143,22 @@ http :: (R.MonadResourceBase m, R.MonadResource m) http req mgr = do respE <- tryHttpEx $ NC.http req mgr resp <- either throwM return respE - unless (isSuccessStatus $ NC.responseStatus resp) $ do - throwM $ MErrHTTP $ NC.StatusCodeException (NC.responseStatus resp) [] def + unless (isSuccessStatus $ NC.responseStatus resp) $ + case contentTypeMay resp of + Just "application/xml" -> do + respBody <- NC.responseBody resp C.$$+- CB.sinkLbs + sErr <- parseErrResponse $ respBody + throwM $ MErrService sErr + + _ -> throwM $ + MErrHTTP $ NC.StatusCodeException (NC.responseStatus resp) [] def + return resp where tryHttpEx :: (R.MonadResourceBase m) => (m a) -> m (Either MinioErr a) tryHttpEx = ExL.try + contentTypeMay resp = lookupHeader Hdr.hContentType $ NC.responseHeaders resp -- like mapConcurrently but with a limited number of concurrent -- threads. diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index 9c947e2..0989925 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -23,6 +23,7 @@ module Network.Minio.XmlParser , parseListObjectsResponse , parseListUploadsResponse , parseListPartsResponse + , parseErrResponse ) where import Control.Monad.Trans.Resource @@ -37,9 +38,12 @@ import Lib.Prelude import Network.Minio.Data import Network.Minio.Errors -import Network.Minio.Utils (s3TimeFormat) +-- | Represent the time format string returned by S3 API calls. +s3TimeFormat :: [Char] +s3TimeFormat = iso8601DateFormat $ Just "%T%QZ" + -- | Helper functions. uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e uncurry4 f (a, b, c, d) = f a b c d @@ -176,3 +180,12 @@ parseListPartsResponse xmldata = do zip4 partNumbers partETags partSizes partModTimes return $ ListPartsResult hasMore (listToMaybe nextPartNum) partInfos + + +parseErrResponse :: (MonadThrow m) + => LByteString -> m ServiceErr +parseErrResponse xmldata = do + r <- parseRoot xmldata + let code = T.concat $ r $/ element "Code" &/ content + message = T.concat $ r $/ element "Message" &/ content + return $ toServiceErr code message diff --git a/test/LiveServer.hs b/test/LiveServer.hs index ce161e2..1eba27d 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -24,6 +24,7 @@ import Lib.Prelude import System.Directory (getTemporaryDirectory) import qualified System.IO as SIO +import qualified Control.Monad.Catch as MC import qualified Control.Monad.Trans.Resource as R import qualified Data.ByteString as BS import Data.Conduit (($$), yield) @@ -36,6 +37,7 @@ import System.Environment (lookupEnv) import Network.Minio import Network.Minio.Data +import Network.Minio.Errors import Network.Minio.ListOps import Network.Minio.PutObject import Network.Minio.S3API @@ -98,6 +100,18 @@ liveServerUnitTests = testGroup "Unit tests against a live server" assertFailure ("The bucket " ++ show bucket ++ " was expected to exist.") + step "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised." + mbE <- MC.try $ makeBucket bucket Nothing + case mbE of + Left exn -> liftIO $ exn @?= (MErrService BucketAlreadyOwnedByYou) + _ -> return () + + step "makeBucket with an invalid bucket name and check for appropriate exception." + invalidMBE <- MC.try $ makeBucket "invalidBucketName" Nothing + case invalidMBE of + Left exn -> liftIO $ exn @?= (MErrService InvalidBucketName) + _ -> return () + step "getLocation works" region <- getLocation bucket liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region) @@ -105,10 +119,23 @@ liveServerUnitTests = testGroup "Unit tests against a live server" step "singlepart putObject works" fPutObject bucket "lsb-release" "/etc/lsb-release" + step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception" + fpE <- MC.try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release" + case fpE of + Left exn -> liftIO $ exn @?= (MErrService NoSuchBucket) + _ -> return () + outFile <- mkRandFile 0 step "simple fGetObject works" fGetObject bucket "lsb-release" outFile + step "fGetObject a non-existent object and check for NoSuchKey exception" + resE <- MC.try $ fGetObject bucket "noSuchKey" outFile + case resE of + Left exn -> liftIO $ exn @?= (MErrService NoSuchKey) + _ -> return () + + step "create new multipart upload works" uid <- newMultipartUpload bucket "newmpupload" [] liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")