diff --git a/minio-hs.cabal b/minio-hs.cabal index 523eb73..cc1f8e2 100644 --- a/minio-hs.cabal +++ b/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 diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index 6122d9c..73cfaf0 100644 --- a/src/Network/Minio.hs +++ b/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) <- R.allocate - (IO.openBinaryFile fp IO.ReadMode) - IO.hClose + (releaseKey, h) <- allocateReadFile fp size <- liftIO $ IO.hFileSize h putObject bucket object [] 0 (fromIntegral size) h diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index d51c0f0..02e5dd5 100644 --- a/src/Network/Minio/Data.hs +++ b/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 { diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs new file mode 100644 index 0000000..94c0ad8 --- /dev/null +++ b/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 diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index a3ad309..854f22c 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/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 diff --git a/test/Spec.hs b/test/Spec.hs index 22f5f36..a318a66 100644 --- a/test/Spec.hs +++ b/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 ]