From 3dcb89d8ba0eb744b848686a6f1000ac27f79932 Mon Sep 17 00:00:00 2001
From: Aditya Manthramurthy <aditya.mmy@gmail.com>
Date: Thu, 19 Jan 2017 16:32:27 +0530
Subject: [PATCH] Add abort multipart

---
 src/Network/Minio.hs           |  4 +++-
 src/Network/Minio/Data.hs      |  6 +-----
 src/Network/Minio/S3API.hs     | 35 +++++++++++++++++++++++++++++++---
 src/Network/Minio/XmlParser.hs |  9 +++------
 test/Spec.hs                   |  6 ++----
 5 files changed, 41 insertions(+), 19 deletions(-)

diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs
index 94bc679..c34dcff 100644
--- a/src/Network/Minio.hs
+++ b/src/Network/Minio.hs
@@ -20,8 +20,10 @@ module Network.Minio
   , D.Bucket
   , D.Object
   , D.BucketInfo(..)
-  , D.MultipartUpload(..)
+  , D.UploadId
 
+  -- * Bucket and Object Operations
+  ---------------------------------
   , S.getService
   , S.getLocation
 
diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs
index ead1c74..fe9c4d2 100644
--- a/src/Network/Minio/Data.hs
+++ b/src/Network/Minio/Data.hs
@@ -7,7 +7,7 @@ module Network.Minio.Data
   , Object
   , Region
   , BucketInfo(..)
-  , MultipartUpload(..)
+  , UploadId
   , getPathFromRI
   , getRegionFromRI
   , Minio
@@ -71,10 +71,6 @@ data BucketInfo = BucketInfo {
 -- | 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 ed696ee..87a3085 100644
--- a/src/Network/Minio/S3API.hs
+++ b/src/Network/Minio/S3API.hs
@@ -1,12 +1,30 @@
 module Network.Minio.S3API
-  ( getService
-  , getLocation
+  (
+    getLocation
+
+  -- * Listing buckets
+  --------------------
+  , getService
+
+
+  -- * Retrieving objects
+  -----------------------
   , getObject
+
+  -- * Creating buckets and objects
+  ---------------------------------
   , putBucket
   , putObject
+
+  -- * Deletion APIs
+  --------------------------
   , deleteBucket
   , deleteObject
+
+  -- * Multipart Upload APIs
+  --------------------------
   , newMultipartUpload
+  , abortMultipartUpload
   ) where
 
 import qualified Network.HTTP.Types as HT
@@ -97,7 +115,8 @@ deleteObject bucket object = do
         , riObject = Just object
         }
 
-newMultipartUpload :: Bucket -> Object -> [HT.Header] -> Minio MultipartUpload
+-- | Create a new multipart upload.
+newMultipartUpload :: Bucket -> Object -> [HT.Header] -> Minio UploadId
 newMultipartUpload bucket object headers = do
   resp <- executeRequest $ def { riMethod = HT.methodPost
                                , riBucket = Just bucket
@@ -106,3 +125,13 @@ newMultipartUpload bucket object headers = do
                                , riHeaders = headers
                                }
   parseNewMultipartUpload $ NC.responseBody resp
+
+-- | Abort a multipart upload.
+abortMultipartUpload :: Bucket -> Object -> UploadId -> Minio ()
+abortMultipartUpload bucket object uploadId = do
+  void $ executeRequest $ def { riMethod = HT.methodDelete
+                              , riBucket = Just bucket
+                              , riObject = Just object
+                              , riQueryParams = [("uploadId",
+                                                  Just $ encodeUtf8 uploadId)]
+                              }
diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs
index 630be27..be5ffd9 100644
--- a/src/Network/Minio/XmlParser.hs
+++ b/src/Network/Minio/XmlParser.hs
@@ -39,11 +39,8 @@ parseLocation xmldata = do
 
 -- | Parse the response XML of an newMultipartUpload call.
 parseNewMultipartUpload :: (MonadError MinioErr m)
-                        => LByteString -> m MultipartUpload
+                        => LByteString -> m UploadId
 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
+  return $ T.concat $ fromDocument doc
+    $// element (s3Name "UploadId") &/ content
diff --git a/test/Spec.hs b/test/Spec.hs
index b368a10..e259f3e 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -72,10 +72,8 @@ liveServerUnitTests = testGroup "Unit tests against a live server"
         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)
+        uid <- newMultipartUpload "testbucket" "newmpupload" []
+        liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
 
         liftIO $ step "abort a new multipart upload works"
         abortMultipartUpload "testbucket" "newmpupload" uid