Parse S3 service errors and return ServiceErr values (#28)

src/Network/Minio.hs

@@ -34,6 +34,7 @@ module Network.Minio
   -- with an object storage service.
   , MinioErr(..)
   , MErrV(..)
+  , ServiceErr(..)
 
   -- * Data Types
   ----------------

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"

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

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
-
+import           Network.Minio.XmlParser (parseErrResponse)
--- | 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"
 
 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
+  unless (isSuccessStatus $ NC.responseStatus resp) $
-    throwM $ MErrHTTP $ NC.StatusCodeException (NC.responseStatus resp) [] def
+    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.

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

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.")