Merge pull request brendanhay#246 from brendanhay/feature/issue-241

Conditional ToElement Serialisation for Root XML Elements
arbor · Nov 13, 2015 · 6edbabf · 6edbabf
2 parents 3a16ef3 + 0cd0466
commit 6edbabf
Show file tree

Hide file tree

Showing 7 changed files with 54 additions and 4 deletions.
diff --git a/amazonka-s3/fixture/PutObjectACLWithBody.yaml b/amazonka-s3/fixture/PutObjectACLWithBody.yaml
@@ -0,0 +1,10 @@
+---
+method: PUT
+path: /bucket-body/key-body
+query: ?acl=
+headers:
+  Authorization: AWS4-HMAC-SHA256 Credential=access/20091028/us-east-1/s3/aws4_request, SignedHeaders=host;x-amz-content-sha256;x-amz-date, Signature=da48913e8c9c160827cf36c4de3d3e414f946dcde4311926a7bbf7a6ef5cdd7a
+  Host: s3.amazonaws.com
+  X-Amz-Date: 20091028T223200Z
+  X-Amz-Content-SHA256: d4c88048f8806fddc4b32ec5901ba6c1f390cb13f65ce695d30da0905d47fc98
+body: "<?xml version=\"1.0\" encoding=\"UTF-8\"?><AccessControlPolicy xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"><AccessControlList><Grant><Permission>WRITE</Permission></Grant></AccessControlList><Owner><ID>foo-oid</ID></Owner></AccessControlPolicy>"
diff --git a/amazonka-s3/fixture/PutObjectACLWithHeaders.yaml b/amazonka-s3/fixture/PutObjectACLWithHeaders.yaml
@@ -0,0 +1,10 @@
+---
+method: PUT
+path: /bucket-headers/key-headers
+query: ?acl=
+headers:
+  Authorization: AWS4-HMAC-SHA256 Credential=access/20091028/us-east-1/s3/aws4_request, SignedHeaders=host;x-amz-acl;x-amz-content-sha256;x-amz-date, Signature=1a314ae21378ddf88489174a6f73a72506621bda8016520fa9e8efb24c6be9c2
+  Host: s3.amazonaws.com
+  X-Amz-Date: 20091028T223200Z
+  X-Amz-Content-SHA256: e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855
+  X-Amz-ACL: bucket-owner-read
diff --git a/amazonka-s3/test/Test/AWS/S3.hs b/amazonka-s3/test/Test/AWS/S3.hs
@@ -20,7 +20,6 @@ import           Network.AWS.S3
 import           Test.AWS.Gen.S3
 import           Test.AWS.Prelude
 import           Test.AWS.S3.Internal
-import           Test.Tasty
 
 tests :: [TestTree]
 tests =
@@ -39,6 +38,18 @@ fixtures =
 
         , testListMultipartUploads $
             listMultipartUploads "foo-bucket" & lmuMaxUploads ?~ 3
+
+        , testPutObjectACLWithBody $
+            putObjectACL "bucket-body" "key-body"
+                & poaAccessControlPolicy ?~
+                    ( accessControlPolicy
+                        & acpGrants .~ [grant & gPermission ?~ PWrite]
+                        & acpOwner  ?~ (owner & oId         ?~ "foo-oid")
+                    )
+
+        , testPutObjectACLWithHeaders $
+            putObjectACL "bucket-headers" "key-headers"
+                & poaACL ?~ OBucketOwnerRead
         ]
 
     , testGroup "response"

diff --git a/amazonka-s3/test/Test/AWS/S3/Internal.hs b/amazonka-s3/test/Test/AWS/S3/Internal.hs
@@ -13,8 +13,10 @@
 
 module Test.AWS.S3.Internal where
 
+import           Data.Time
 import           Network.AWS.Prelude
 import           Network.AWS.S3
+import           Test.AWS.Fixture
 import           Test.AWS.Prelude
 import           Test.Tasty
 import           Test.Tasty.HUnit
@@ -43,3 +45,13 @@ objectKeyTests = testGroup "object key"
   where
     enc :: ObjectKey -> ByteString
     enc = toBS . escapePath . rawPath
+
+testPutObjectACLWithBody :: PutObjectACL -> TestTree
+testPutObjectACLWithBody = req
+    "PutObjectACLWithBody"
+    "fixture/PutObjectACLWithBody.yaml"
+
+testPutObjectACLWithHeaders :: PutObjectACL -> TestTree
+testPutObjectACLWithHeaders = req
+    "PutObjectACLWithHeaders"
+    "fixture/PutObjectACLWithHeaders.yaml"
diff --git a/core/src/Network/AWS/Data/Body.hs b/core/src/Network/AWS/Data/Body.hs
@@ -51,8 +51,7 @@ default (Builder)
 -- | A streaming, exception safe response body.
 newtype RsBody = RsBody
     { _streamBody :: ResumableSource (ResourceT IO) ByteString
-    }
--- newtype for show/orhpan instance purposes.
+    } -- newtype for show/orhpan instance purposes.
 
 instance Show RsBody where
     show = const "RsBody { ResumableSource (ResourceT IO) ByteString }"

diff --git a/core/src/Network/AWS/Data/XML.hs b/core/src/Network/AWS/Data/XML.hs
@@ -119,6 +119,14 @@ class ToElement a where
 instance ToElement Element where
     toElement = id
 
+-- | Convert to an 'Element', only if the resulting element contains @> 0@ nodes.
+maybeElement :: ToElement a => a -> Maybe Element
+maybeElement x =
+    case toElement x of
+        e@(Element _ _ ns)
+            | null ns   -> Nothing
+            | otherwise -> Just e
+
 -- | Provides a way to make the operators for ToXML instance
 -- declaration be consistent WRT to single nodes or lists of nodes.
 data XML

diff --git a/core/src/Network/AWS/Request.hs b/core/src/Network/AWS/Request.hs
@@ -102,7 +102,7 @@ postBody s x = putBody s x & rqMethod .~ POST
 putXML :: (ToRequest a, ToElement a) => Service -> a -> Request a
 putXML s x = defaultRequest s x
     & rqMethod .~ PUT
-    & rqBody   .~ toBody (toElement x)
+    & rqBody   .~ maybe "" toBody (maybeElement x)
 
 putJSON :: (ToRequest a, ToJSON a) => Service -> a -> Request a
 putJSON s x = defaultRequest s x