Restructure functional tests and remove executable from .cabal

app/Main.hs

@@ -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

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

src/Network/Minio.hs

@@ -20,6 +20,7 @@ module Network.Minio
   , D.Bucket
   , D.Object
   , D.BucketInfo(..)
+  , D.MultipartUpload(..)
 
   , S.getService
   , S.getLocation

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

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

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

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