Catch file opening errors

minio-hs.cabal

@@ -25,6 +25,7 @@ library
                      , Network.Minio.Data.Time
                      , Network.Minio.Sign.V4
                      , Network.Minio.API
+                     , Network.Minio.Utils
                      , Network.Minio.XmlParser
                      , Network.Minio.XmlGenerator
   build-depends:       base >= 4.7 && < 5
@@ -37,7 +38,6 @@ library
                      , containers
                      , cryptonite
                      , cryptonite-conduit
-                     , errors
                      , filepath
                      , http-client
                      , http-conduit
@@ -57,6 +57,7 @@ library
                      , MultiParamTypeClasses
                      , MultiWayIf
                      , RankNTypes
+                     , TupleSections
 
 executable minio-hs-exe
   hs-source-dirs:      app
@@ -87,7 +88,6 @@ test-suite minio-hs-test
                      , containers
                      , cryptonite
                      , cryptonite-conduit
-                     , errors
                      , filepath
                      , http-client
                      , http-conduit
@@ -112,6 +112,7 @@ test-suite minio-hs-test
                      , MultiParamTypeClasses
                      , MultiWayIf
                      , RankNTypes
+                     , TupleSections
   other-modules:       Lib.Prelude
                      , Network.Minio
                      , Network.Minio.API
@@ -121,6 +122,7 @@ test-suite minio-hs-test
                      , Network.Minio.Data.Time
                      , Network.Minio.S3API
                      , Network.Minio.Sign.V4
+                     , Network.Minio.Utils
                      , Network.Minio.XmlGenerator
                      , Network.Minio.XmlParser
                      , XmlTests

src/Network/Minio.hs

@@ -32,6 +32,7 @@ import Lib.Prelude
 
 import Network.Minio.Data
 import Network.Minio.S3API
+import Network.Minio.Utils
 
 fGetObject :: Bucket -> Object -> FilePath -> Minio ()
 fGetObject bucket object fp = do
@@ -40,10 +41,7 @@ fGetObject bucket object fp = do
 
 fPutObject :: Bucket -> Object -> FilePath -> Minio ()
 fPutObject bucket object fp = do
-  -- allocate file handle and register cleanup action
+  (releaseKey, h) <- allocateReadFile fp
-  (releaseKey, h) <- R.allocate
-    (IO.openBinaryFile fp IO.ReadMode)
-    IO.hClose
 
   size <- liftIO $ IO.hFileSize h
   putObject bucket object [] 0 (fromIntegral size) h

src/Network/Minio/Data.hs

@@ -90,6 +90,7 @@ data MinioErr = MErrMsg ByteString -- generic
               | 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 {

src/Network/Minio/Utils.hs

@@ -0,0 +1,17 @@
+module Network.Minio.Utils where
+
+import qualified Control.Monad.Trans.Resource as R
+import qualified System.IO as IO
+
+import Lib.Prelude
+
+import Network.Minio.Data
+
+allocateReadFile :: (R.MonadResource m, MonadError MinioErr m)
+                 => FilePath -> m (R.ReleaseKey, Handle)
+allocateReadFile fp = do
+  (rk, hdlE) <- R.allocate (openReadFile fp) cleanup
+  either (throwError . MErrIO) (return . (rk,)) hdlE
+  where
+    openReadFile f = runExceptT $ tryIO $ IO.openBinaryFile f IO.ReadMode
+    cleanup = either (const $ return ()) IO.hClose

src/Network/Minio/XmlParser.hs

@@ -7,7 +7,6 @@ import Text.XML
 import Text.XML.Cursor
 import qualified Data.Text as T
 import Data.Time
-import Control.Error
 
 import           Lib.Prelude
 

test/Spec.hs

@@ -64,10 +64,17 @@ unitTests = testGroup "Unit tests"
       step "Running test.."
       ret <- runResourceT $ runMinio mc $
              fPutObject "testbucket" "lsb-release" "/etc/lsb-release"
-      -- h <- SIO.openBinaryFile "/etc/lsb-release" SIO.ReadMode
-      -- ret <- runResourceT $ runMinio mc $
-      --        putObject "testbucket" "lsb-release" [] 0 105 h
       isRight ret @? ("putObject failure => " ++ show ret)
 
+  , testCaseSteps "Simple putObject fails with non-existent file" $ \step -> do
+      step "Preparing..."
+
+      mc <- connect defaultConnectInfo
+
+      step "Running test.."
+      ret <- runResourceT $ runMinio mc $
+             fPutObject "testbucket" "lsb-release" "/etc/lsb-releaseXXX"
+      isLeft ret @? ("putObject unexpected success => " ++ show ret)
+
   , testCase "Test mkCreateBucketConfig." testMkCreateBucketConfig
   ]