diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 index 0f95769..0000000 --- a/app/Main.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Main where - -import Protolude - -import Network.Minio -import Network.Minio.S3API - --- import Network.Minio.S3API -import Control.Monad.Trans.Resource (runResourceT) --- import qualified Data.Conduit as C --- import qualified Data.Conduit.List as CL --- import qualified Network.HTTP.Conduit as NC - -main :: IO () -main = do - t <- runResourceT $ runMinio defaultConnectInfo $ do - res <- getService - print res - -- case res of - -- Left e -> print e - -- Right res1 -> mapM_ print res1 - -- liftIO $ print $ NC.responseStatus res - -- liftIO $ print $ NC.responseHeaders res - -- liftIO print $ NC.responseHeaders <$> res - -- let bodyE = NC.responseBody <$> res - -- case bodyE of - -- Left x -> print x - -- Right body -> body C.$$+- CL.mapM_ putStrLn - -- body <- NC.responseBody <$> res - -- NC.responseBody res C.$$+- CL.mapM_ putStrLn - - res <- putBucket "test2" "us-east-1" - print res - - res <- getLocation "test1" - print res - - fGetObject "test1" "passwd" "/tmp/passwd" - res <- deleteObject "test1" "passwd" - print res - - res <- deleteBucket "test2" - print res - - print "After runResourceT" - print t diff --git a/minio-hs.cabal b/minio-hs.cabal index d0fca26..f4112a1 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -62,20 +62,6 @@ library , RankNTypes , TupleSections -executable minio-hs-exe - hs-source-dirs: app - main-is: Main.hs - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - build-depends: base - , conduit - , minio-hs - , protolude >= 0.1.6 && < 0.2 - , http-conduit - , http-types - , resourcet - default-language: Haskell2010 - default-extensions: OverloadedStrings, NoImplicitPrelude - test-suite minio-hs-test type: exitcode-stdio-1.0 hs-source-dirs: test, src diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index ac973af..94bc679 100644 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -20,6 +20,7 @@ module Network.Minio , D.Bucket , D.Object , D.BucketInfo(..) + , D.MultipartUpload(..) , S.getService , S.getLocation diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index a49e873..ead1c74 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -7,6 +7,7 @@ module Network.Minio.Data , Object , Region , BucketInfo(..) + , MultipartUpload(..) , getPathFromRI , getRegionFromRI , Minio @@ -66,6 +67,14 @@ data BucketInfo = BucketInfo { , biCreationDate :: UTCTime } deriving (Show, Eq) + +-- | A type alias to represent an upload-id for multipart upload +type UploadId = Text + +-- | Info about a multipart upload +data MultipartUpload = MultipartUpload Bucket Object UploadId + deriving (Show, Eq) + data Payload = PayloadBS ByteString | PayloadH Handle Int64 -- offset diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index 3fdfefb..ed696ee 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -6,6 +6,7 @@ module Network.Minio.S3API , putObject , deleteBucket , deleteObject + , newMultipartUpload ) where import qualified Network.HTTP.Types as HT @@ -95,3 +96,13 @@ deleteObject bucket object = do , riBucket = Just bucket , riObject = Just object } + +newMultipartUpload :: Bucket -> Object -> [HT.Header] -> Minio MultipartUpload +newMultipartUpload bucket object headers = do + resp <- executeRequest $ def { riMethod = HT.methodPost + , riBucket = Just bucket + , riObject = Just object + , riQueryParams = [("uploads", Nothing)] + , riHeaders = headers + } + parseNewMultipartUpload $ NC.responseBody resp diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index 9a56f4f..630be27 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -1,6 +1,7 @@ module Network.Minio.XmlParser ( parseListBuckets , parseLocation + , parseNewMultipartUpload ) where import Text.XML @@ -12,9 +13,11 @@ import Lib.Prelude import Network.Minio.Data +-- | Represent the time format string returned by S3 API calls. s3TimeFormat :: [Char] s3TimeFormat = iso8601DateFormat $ Just "%T%QZ" +-- | Parse the response XML of a list buckets call. parseListBuckets :: (MonadError MinioErr m) => LByteString -> m [BucketInfo] parseListBuckets xmldata = do doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata @@ -28,7 +31,19 @@ parseListBuckets xmldata = do timeStrings return $ map (\(n, t) -> BucketInfo n t) $ zip names times -parseLocation :: (MonadError MinioErr m) => LByteString -> m Text +-- | Parse the response XML of a location request. +parseLocation :: (MonadError MinioErr m) => LByteString -> m Region parseLocation xmldata = do doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata return $ T.concat $ fromDocument doc $/ content + +-- | Parse the response XML of an newMultipartUpload call. +parseNewMultipartUpload :: (MonadError MinioErr m) + => LByteString -> m MultipartUpload +parseNewMultipartUpload xmldata = do + doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata + let cursor = fromDocument doc + bucket = T.concat $ cursor $// element (s3Name "Bucket") &/ content + object = T.concat $ cursor $// element (s3Name "Key") &/ content + upId = T.concat $ cursor $// element (s3Name "UploadId") &/ content + return $ MultipartUpload bucket object upId diff --git a/test/Spec.hs b/test/Spec.hs index 2660b80..78cf0e5 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -6,12 +6,12 @@ import Test.Tasty.HUnit -- import qualified System.IO as SIO import Control.Monad.Trans.Resource (runResourceT) - +import qualified Data.Text as T -- import qualified Conduit as C -- import Data.Conduit.Binary import Network.Minio --- import Network.Minio.S3API +import Network.Minio.S3API import Network.Minio.XmlGenerator.Test import Network.Minio.XmlParser.Test @@ -49,24 +49,42 @@ properties = testGroup "Properties" [] -- [scProps, qcProps] liveServerUnitTests :: TestTree liveServerUnitTests = testGroup "Unit tests against a live server" - [ testCase "Check getService returns without exception" $ do - ret <- runResourceT $ runMinio defaultConnectInfo $ getService - isRight ret @? ("getService failure => " ++ show ret) + [ testCaseSteps "Various functional tests" $ \step -> do - , testCase "Simple fGetObject works" $ do - ret <- runResourceT $ runMinio defaultConnectInfo $ - fGetObject "testbucket" "lsb-release" "/tmp/out" - isRight ret @? ("fGetObject failure => " ++ show ret) + ret <- runResourceT $ runMinio defaultConnectInfo $ do - , testCase "Simple putObject works" $ do - ret <- runResourceT $ runMinio defaultConnectInfo $ - fPutObject "testbucket" "lsb-release" "/etc/lsb-release" - isRight ret @? ("putObject failure => " ++ show ret) + liftIO $ step "getService works and returns no buckets in the beginning." + buckets <- getService + liftIO $ (length buckets == 0) @? + ("Live server must have no buckets at beginning.") + + liftIO $ step "putBucket works" + putBucket "testbucket" "us-east-1" + + liftIO $ step "getLocation works" + region <- getLocation "testbucket" + liftIO $ region == "" @? ("Got unexpected region => " ++ show region) + + liftIO $ step "singlepart putObject works" + fPutObject "testbucket" "lsb-release" "/etc/lsb-release" + + liftIO $ step "simple getObject works" + fGetObject "testbucket" "lsb-release" "/tmp/out" + + liftIO $ step "create new multipart upload works" + mp@(MultipartUpload _ _ uid) <- newMultipartUpload "testbucket" + "newmpupload" [] + liftIO $ (T.length uid > 0) @? + ("Got an empty newMultipartUpload Id => " ++ show mp) + + liftIO $ step "delete object works" + deleteObject "testbucket" "lsb-release" + + liftIO $ step "delete bucket works" + deleteBucket "testbucket" + + isRight ret @? ("Functional test failure => " ++ show ret) - , testCase "Simple putObject fails with non-existent file" $ do - ret <- runResourceT $ runMinio defaultConnectInfo $ - fPutObject "testbucket" "lsb-release" "/etc/lsb-releaseXXX" - isLeft ret @? ("putObject unexpected success => " ++ show ret) ] unitTests :: TestTree