Make MinioErr flatter and make examples work. (#25)

examples/FileUploader.hs

@@ -62,7 +62,7 @@ main = do
     -- Make a bucket; catch bucket already exists exception if thrown.
     catch
       (makeBucket bucket Nothing)
-      (\(_ :: MError) -> liftIO $ putStrLn "Bucket already exists, proceeding with upload file.")
+      (\(_ :: MinioErr) -> liftIO $ putStrLn "Bucket already exists, proceeding with upload file.")
 
     -- Upload filepath to bucket; object is derived from filepath.
     fPutObject bucket object filepath

examples/HeadObject.hs

@@ -0,0 +1,43 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-6.27 runghc --package minio-hs
+
+--
+-- Minio Haskell SDK, (C) 2017 Minio, Inc.
+--
+-- Licensed under the Apache License, Version 2.0 (the "License");
+-- you may not use this file except in compliance with the License.
+-- You may obtain a copy of the License at
+--
+--     http://www.apache.org/licenses/LICENSE-2.0
+--
+-- Unless required by applicable law or agreed to in writing, software
+-- distributed under the License is distributed on an "AS IS" BASIS,
+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+-- See the License for the specific language governing permissions and
+-- limitations under the License.
+--
+
+{-# Language OverloadedStrings #-}
+import Network.Minio.S3API
+import Network.Minio
+
+import Prelude
+
+-- | The following example uses minio's play server at
+-- https://play.minio.io:9000.  The endpoint and associated
+-- credentials are provided via the libary constant,
+--
+-- > minioPlayCI :: ConnectInfo
+--
+
+main :: IO ()
+main = do
+  let
+      bucket = "test"
+      object = "passwd"
+  res <- runResourceT $ runMinio minioPlayCI $ do
+    headObject bucket object
+
+  case res of
+    Left e -> putStrLn $ "headObject failed." ++ (show e)
+    Right objInfo -> putStrLn $ "headObject succeeded." ++ (show objInfo)

examples/ListBuckets.hs

@@ -18,9 +18,10 @@
 --
 
 {-# Language OverloadedStrings #-}
-import           Network.Minio
+import Network.Minio
 
-import           Prelude
+import Control.Monad.IO.Class (liftIO)
+import Prelude
 
 -- | The following example uses minio's play server at
 -- https://play.minio.io:9000.  The endpoint and associated
@@ -34,6 +35,7 @@ import           Prelude
 main :: IO ()
 main = do
   firstRegionE <- runResourceT $ runMinio minioPlayCI $ do
-    buckets <- getService
+    buckets <- listBuckets
+    liftIO $ print $ "Top 5 buckets: " ++ (show $ take 5 buckets)
     getLocation $ biName $ head buckets
   print firstRegionE

examples/PutObject.hs

@@ -35,11 +35,12 @@ main = do
   let
       bucket = "test"
       object = "obj"
-      mb15 = 15 * 1024 * 1024
+      localFile = "/etc/lsb-release"
+      kb15 = 15 * 1024
 
   -- Eg 1. Upload a stream of repeating "a" using putObject.
   res1 <- runResourceT $ runMinio minioPlayCI $ do
-    putObject bucket object (CC.repeat "a") (Just mb15)
+    putObject bucket object (CC.repeat "a") (Just kb15)
   case res1 of
     Left e -> putStrLn $ "putObject failed." ++ (show e)
     Right () -> putStrLn "putObject succeeded."
@@ -47,7 +48,7 @@ main = do
 
   -- Eg 2. Upload a file using fPutObject.
   res2 <- runResourceT $ runMinio minioPlayCI $ do
-    fPutObject bucket object "path/to/local/file"
+    fPutObject bucket object localFile
   case res2 of
     Left e -> putStrLn $ "fPutObject failed." ++ (show e)
     Right () -> putStrLn "fPutObject succeeded."

src/Network/Minio.hs

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

src/Network/Minio/API.hs

@@ -110,21 +110,18 @@ buildRequest ri = do
     Nothing ->  return $ connectHost ci
     Just r -> if "amazonaws.com" `T.isSuffixOf` (connectHost ci)
               then maybe
-                   (throwM $ ME $ ValidationError $ MErrVRegionNotSupported r)
+                   (throwM $ MErrVRegionNotSupported r)
                    return
                    (Map.lookup r awsRegionMap)
               else return $ connectHost ci
 
 
   sha256Hash <- getPayloadSHA256Hash (riPayload ri)
-  let newRi = ri {
-          riPayloadHash = sha256Hash
-        , riHeaders = sha256Header sha256Hash : (riHeaders ri)
-        , riRegion = region
-        }
-      newCi = ci {
-        connectHost = regionHost
-        }
+  let newRi = ri { riPayloadHash = sha256Hash
+                 , riHeaders = sha256Header sha256Hash : (riHeaders ri)
+                 , riRegion = region
+                 }
+      newCi = ci { connectHost = regionHost }
 
   reqHeaders <- liftIO $ signV4 newCi newRi
 

src/Network/Minio/Data.hs

@@ -348,11 +348,16 @@ runMinio ci m = do
   conn <- liftIO $ connect ci
   flip evalStateT Map.empty . flip runReaderT conn . unMinio $
     (m >>= (return . Right)) `MC.catches`
-    [MC.Handler handlerME, MC.Handler handlerHE, MC.Handler handlerFE]
+    [ MC.Handler handlerServiceErr
+    , MC.Handler handlerHE
+    , MC.Handler handlerFE
+    , MC.Handler handlerValidation
+    ]
   where
-    handlerME = return . Left . ME
-    handlerHE = return . Left . MEHttp
-    handlerFE = return . Left . MEFile
+    handlerServiceErr = return . Left . MErrService
+    handlerHE = return . Left . MErrHTTP
+    handlerFE = return . Left . MErrIO
+    handlerValidation = return . Left . MErrValidation
 
 s3Name :: Text -> Name
 s3Name s = Name s (Just "http://s3.amazonaws.com/doc/2006-03-01/") Nothing

src/Network/Minio/Errors.hs

@@ -34,20 +34,33 @@ data MErrV = MErrVSinglePUTSizeExceeded Int64
            | MErrVInvalidSrcObjByteRange (Int64, Int64)
            | MErrVCopyObjSingleNoRangeAccepted
            | MErrVRegionNotSupported Text
+           | MErrXmlParse Text
   deriving (Show, Eq)
 
+instance Exception MErrV
+
+-- | Errors returned by S3 compatible service
+data ServiceErr = BucketAlreadyExists
+                | NoSuchBucket
+  deriving (Show, Eq)
+
+instance Exception ServiceErr
+
 -- | Errors thrown by the library
-data MinioErr = ME MError
-              | MEHttp NC.HttpException
-              | MEFile IOException
+data MinioErr = MErrHTTP NC.HttpException
+              | MErrIO IOException
+              | MErrService ServiceErr
+              | MErrValidation MErrV
   deriving (Show)
 
+instance Eq MinioErr where
+  MErrHTTP _       == MErrHTTP _        = True
+  MErrHTTP _       ==  _                = False
+  MErrIO _         == MErrIO _          = True
+  MErrIO _         == _                 = False
+  MErrService a    == MErrService b     = a == b
+  MErrService _    == _                 = False
+  MErrValidation a == MErrValidation b  = a == b
+  MErrValidation _ == _                 = False
+
 instance Exception MinioErr
-
--- | Library internal errors
-data MError = XMLParseError Text
-            | ResponseError (NC.Response LByteString)
-            | ValidationError MErrV
-  deriving (Show, Eq)
-
-instance Exception MError

src/Network/Minio/PutObject.hs

@@ -52,10 +52,6 @@ maxObjectSize = 5 * 1024 * 1024 * oneMiB
 minPartSize :: Int64
 minPartSize = 64 * oneMiB
 
--- | max part of an object size is 5GiB
-maxObjectPartSize :: Int64
-maxObjectPartSize = 5 * 1024 * oneMiB
-
 oneMiB :: Int64
 oneMiB = 1024 * 1024
 
@@ -99,8 +95,7 @@ putObjectInternal b o (ODFile fp sizeMay) = do
     Just size ->
       if | size <= 64 * oneMiB -> either throwM return =<<
            withNewHandle fp (\h -> putObjectSingle b o [] h 0 size)
-         | size > maxObjectSize -> throwM $ ValidationError $
-                                   MErrVPutSizeExceeded size
+         | size > maxObjectSize -> throwM $ MErrVPutSizeExceeded size
          | isSeekable -> parallelMultipartUpload b o fp size
          | otherwise -> sequentialMultipartUpload b o (Just size) $
                         CB.sourceFile fp
@@ -217,7 +212,7 @@ copyObjectInternal :: Bucket -> Object -> CopyPartSource
 copyObjectInternal b' o cps = do
   -- validate and extract the src bucket and object
   (srcBucket, srcObject) <- maybe
-    (throwM $ ValidationError $ MErrVInvalidSrcObjSpec $ cpSource cps)
+    (throwM $ MErrVInvalidSrcObjSpec $ cpSource cps)
     return $ cpsToObject cps
 
   -- get source object size with a head request
@@ -227,7 +222,7 @@ copyObjectInternal b' o cps = do
   when (isJust (cpSourceRange cps) &&
         or [fst range < 0, snd range < fst range,
             snd range >= fromIntegral srcSize]) $
-    throwM $ ValidationError $ MErrVInvalidSrcObjByteRange range
+    throwM $ MErrVInvalidSrcObjByteRange range
 
   -- 1. If sz > 64MiB (minPartSize) use multipart copy, OR
   -- 2. If startOffset /= 0 use multipart copy

src/Network/Minio/S3API.hs

@@ -122,7 +122,7 @@ putObjectSingle :: Bucket -> Object -> [HT.Header] -> Handle -> Int64
 putObjectSingle bucket object headers h offset size = do
   -- check length is within single PUT object size.
   when (size > maxSinglePutObjectSizeBytes) $
-    throwM $ ValidationError $ MErrVSinglePUTSizeExceeded size
+    throwM $ MErrVSinglePUTSizeExceeded size
 
   -- content-length header is automatically set by library.
   resp <- executeRequest $
@@ -136,7 +136,7 @@ putObjectSingle bucket object headers h offset size = do
   let rheaders = NC.responseHeaders resp
       etag = getETagHeader rheaders
   maybe
-    (throwM $ ValidationError MErrVETagHeaderNotFound)
+    (throwM MErrVETagHeaderNotFound)
     return etag
 
 -- | List objects in a bucket matching prefix up to delimiter,
@@ -200,7 +200,7 @@ putObjectPart bucket object uploadId partNumber headers payload = do
   let rheaders = NC.responseHeaders resp
       etag = getETagHeader rheaders
   maybe
-    (throwM $ ValidationError MErrVETagHeaderNotFound)
+    (throwM MErrVETagHeaderNotFound)
     (return . (partNumber, )) etag
   where
     params = [
@@ -236,7 +236,7 @@ copyObjectSingle :: Bucket -> Object -> CopyPartSource -> [HT.Header]
 copyObjectSingle bucket object cps headers = do
   -- validate that cpSourceRange is Nothing for this API.
   when (isJust $ cpSourceRange cps) $
-    throwM $ ValidationError $ MErrVCopyObjSingleNoRangeAccepted
+    throwM MErrVCopyObjSingleNoRangeAccepted
   resp <- executeRequest $
           def { riMethod = HT.methodPut
               , riBucket = Just bucket
@@ -323,5 +323,5 @@ headObject bucket object = do
     etag = getETagHeader headers
     size = getContentLength headers
 
-  maybe (throwM $ ValidationError MErrVInvalidObjectInfoResponse) return $
+  maybe (throwM MErrVInvalidObjectInfoResponse) return $
     ObjectInfo <$> Just object <*> modTime <*> etag <*> size

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           Data.Default (Default(..))
 import qualified Data.Text as T
 import           Data.Text.Encoding.Error (lenientDecode)
 import           Data.Text.Read (decimal)
@@ -52,7 +53,7 @@ allocateReadFile :: (R.MonadResource m, R.MonadResourceBase m)
                  => FilePath -> m (R.ReleaseKey, Handle)
 allocateReadFile fp = do
   (rk, hdlE) <- R.allocate (openReadFile fp) cleanup
-  either (throwM . MEFile) (return . (rk,)) hdlE
+  either (throwM . MErrIO) (return . (rk,)) hdlE
   where
     openReadFile f = ExL.try $ IO.openBinaryFile f IO.ReadMode
     cleanup = either (const $ return ()) IO.hClose
@@ -82,7 +83,7 @@ isHandleSeekable h = do
 -- returned - both during file handle allocation and when the action
 -- is run.
 withNewHandle :: (R.MonadResourceBase m, R.MonadResource m, MonadCatch m)
-              => FilePath -> (Handle -> m a) -> m (Either MError a)
+              => FilePath -> (Handle -> m a) -> m (Either MinioErr a)
 withNewHandle fp fileAction = do
   -- opening a handle can throw MError exception.
   handleE <- MC.try $ allocateReadFile fp
@@ -127,7 +128,7 @@ httpLbs req mgr = do
   respE <- liftIO $ tryHttpEx $ (NClient.httpLbs req mgr)
   resp <- either throwM return respE
   unless (isSuccessStatus $ NC.responseStatus resp) $
-    throwM $ ResponseError resp
+    throwM $ MErrHTTP $ NC.StatusCodeException (NC.responseStatus resp) [] def
   return resp
   where
     tryHttpEx :: (IO (NC.Response LByteString))
@@ -141,12 +142,11 @@ http req mgr = do
   respE <- tryHttpEx $ NC.http req mgr
   resp <- either throwM return respE
   unless (isSuccessStatus $ NC.responseStatus resp) $ do
-    lbsResp <- NC.lbsResponse resp
-    throwM $ ResponseError lbsResp
+    throwM $ MErrHTTP $ NC.StatusCodeException (NC.responseStatus resp) [] def
   return resp
   where
     tryHttpEx :: (R.MonadResourceBase m) => (m a)
-              -> m (Either NC.HttpException a)
+              -> m (Either MinioErr a)
     tryHttpEx = ExL.try
 
 -- like mapConcurrently but with a limited number of concurrent

src/Network/Minio/XmlParser.hs

@@ -46,12 +46,12 @@ uncurry4 f (a, b, c, d) = f a b c d
 
 -- | Parse time strings from XML
 parseS3XMLTime :: (MonadThrow m) => Text -> m UTCTime
-parseS3XMLTime = either (throwM . XMLParseError) return
+parseS3XMLTime = either (throwM . MErrXmlParse) return
                . parseTimeM True defaultTimeLocale s3TimeFormat
                . T.unpack
 
 parseDecimal :: (MonadThrow m, Integral a) => Text -> m a
-parseDecimal numStr = either (throwM . XMLParseError . show) return $ fst <$> decimal numStr
+parseDecimal numStr = either (throwM . MErrXmlParse . show) return $ fst <$> decimal numStr
 
 parseDecimals :: (MonadThrow m, Integral a) => [Text] -> m [a]
 parseDecimals numStr = forM numStr parseDecimal
@@ -60,7 +60,7 @@ s3Elem :: Text -> Axis
 s3Elem = element . s3Name
 
 parseRoot :: (MonadThrow m) => LByteString -> m Cursor
-parseRoot = either (throwM . XMLParseError . show) (return . fromDocument)
+parseRoot = either (throwM . MErrXmlParse . show) (return . fromDocument)
           . parseLBS def
 
 -- | Parse the response XML of a list buckets call.

test/Network/Minio/XmlParser/Test.hs

@@ -41,26 +41,26 @@ xmlParserTests = testGroup "XML Parser Tests"
   , testCase "Test parseCopyObjectResponse" testParseCopyObjectResponse
   ]
 
-tryMError :: (MC.MonadCatch m) => m a -> m (Either MError a)
-tryMError act = MC.try act
+tryValidationErr :: (MC.MonadCatch m) => m a -> m (Either MErrV a)
+tryValidationErr act = MC.try act
 
-assertMError :: MError -> Assertion
-assertMError e = assertFailure $ "Failed due to exception => " ++ show e
+assertValidtionErr :: MErrV -> Assertion
+assertValidtionErr e = assertFailure $ "Failed due to validation error => " ++ show e
 
-eitherMError :: Either MError a -> (a -> Assertion) -> Assertion
-eitherMError (Left e) _ = assertMError e
-eitherMError (Right a) f = f a
+eitherValidationErr :: Either MErrV a -> (a -> Assertion) -> Assertion
+eitherValidationErr (Left e) _ = assertValidtionErr e
+eitherValidationErr (Right a) f = f a
 
 testParseLocation :: Assertion
 testParseLocation = do
   -- 1. Test parsing of an invalid location constraint xml.
-  parseResE <- tryMError $ parseLocation "ClearlyInvalidXml"
+  parseResE <- tryValidationErr $ parseLocation "ClearlyInvalidXml"
   when (isRight parseResE) $
     assertFailure $ "Parsing should have failed => " ++ show parseResE
 
   forM_ cases $ \(xmldata, expectedLocation) -> do
-    parseLocE <- tryMError $ parseLocation xmldata
-    either assertMError (@?= expectedLocation) parseLocE
+    parseLocE <- tryValidationErr $ parseLocation xmldata
+    either assertValidtionErr (@?= expectedLocation) parseLocE
   where
     cases =  [
       -- 2. Test parsing of a valid location xml.
@@ -79,8 +79,8 @@ testParseLocation = do
 testParseNewMultipartUpload :: Assertion
 testParseNewMultipartUpload = do
   forM_ cases $ \(xmldata, expectedUploadId) -> do
-    parsedUploadIdE <- tryMError $ parseNewMultipartUpload xmldata
-    eitherMError parsedUploadIdE (@?= expectedUploadId)
+    parsedUploadIdE <- tryValidationErr $ parseNewMultipartUpload xmldata
+    eitherValidationErr parsedUploadIdE (@?= expectedUploadId)
   where
     cases = [
       ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
@@ -124,8 +124,8 @@ testParseListObjectsResult = do
     object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234
     modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12
 
-  parsedListObjectsResult <- tryMError $ parseListObjectsResponse xmldata
-  eitherMError parsedListObjectsResult (@?= expectedListResult)
+  parsedListObjectsResult <- tryValidationErr $ parseListObjectsResponse xmldata
+  eitherValidationErr parsedListObjectsResult (@?= expectedListResult)
 
 testParseListIncompleteUploads :: Assertion
 testParseListIncompleteUploads = do
@@ -166,8 +166,8 @@ testParseListIncompleteUploads = do
     initTime = UTCTime (fromGregorian 2010 11 26) 69857
     prefixes = ["photos/", "videos/"]
 
-  parsedListUploadsResult <- tryMError $ parseListUploadsResponse xmldata
-  eitherMError parsedListUploadsResult (@?= expectedListResult)
+  parsedListUploadsResult <- tryValidationErr $ parseListUploadsResponse xmldata
+  eitherValidationErr parsedListUploadsResult (@?= expectedListResult)
 
 
 testParseCompleteMultipartUploadResponse :: Assertion
@@ -183,7 +183,7 @@ testParseCompleteMultipartUploadResponse = do
     expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\""
 
   parsedETagE <- runExceptT $ parseCompleteMultipartUploadResponse xmldata
-  eitherMError parsedETagE (@?= expectedETag)
+  eitherValidationErr parsedETagE (@?= expectedETag)
 
 testParseListPartsResponse :: Assertion
 testParseListPartsResponse = do
@@ -227,7 +227,7 @@ testParseListPartsResponse = do
     modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10
 
   parsedListPartsResult <- runExceptT $ parseListPartsResponse xmldata
-  eitherMError parsedListPartsResult (@?= expectedListResult)
+  eitherValidationErr parsedListPartsResult (@?= expectedListResult)
 
 testParseCopyObjectResponse :: Assertion
 testParseCopyObjectResponse = do
@@ -249,4 +249,4 @@ testParseCopyObjectResponse = do
 
   forM_ cases $ \(xmldata, (etag, modTime)) -> do
     parseResult <- runExceptT $ parseCopyObjectResponse xmldata
-    eitherMError parseResult (@?= (etag, modTime))
+    eitherValidationErr parseResult (@?= (etag, modTime))