Fix user-metadata extraction (#133)

src/Network/Minio/Data.hs

@@ -335,17 +335,19 @@ data PutObjectOptions = PutObjectOptions {
 defaultPutObjectOptions :: PutObjectOptions
 defaultPutObjectOptions = PutObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing Nothing
 
-isUserMetadataHeaderName :: Text -> Bool
-isUserMetadataHeaderName k =
+-- | If the given header name has the @X-Amz-Meta-@ prefix, it is
+-- stripped and a Just is returned.
+userMetadataHeaderNameMaybe :: Text -> Maybe Text
+userMetadataHeaderNameMaybe k =
     let prefix = T.toCaseFold "X-Amz-Meta-"
         n = T.length prefix
-    in T.toCaseFold (T.take n k) == prefix
+    in if T.toCaseFold (T.take n k) == prefix
+       then Just (T.drop n k)
+       else Nothing
 
 addXAmzMetaPrefix :: Text -> Text
-addXAmzMetaPrefix s =
-    if isUserMetadataHeaderName s
-    then s
-    else "X-Amz-Meta-" <> s
+addXAmzMetaPrefix s | isJust (userMetadataHeaderNameMaybe s) = s
+                    | otherwise = "X-Amz-Meta-" <> s
 
 mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header]
 mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix $ x, encodeUtf8 y))

src/Network/Minio/Utils.hs

@@ -108,14 +108,12 @@ getMetadata =
 
 toMaybeMetadataHeader :: (Text, Text) -> Maybe (Text, Text)
 toMaybeMetadataHeader (k, v) =
-    let checkPrefix t = bool Nothing (Just t) $
-                        isUserMetadataHeaderName t
-    in (, v) <$> checkPrefix k
+    (, v) <$> userMetadataHeaderNameMaybe k
 
 getNonUserMetadataMap :: [(Text, Text)] -> H.HashMap Text Text
 getNonUserMetadataMap = H.fromList
-                      . filter ( not
-                               . isUserMetadataHeaderName
+                      . filter ( isNothing
+                               . userMetadataHeaderNameMaybe
                                . fst
                                )
 

test/LiveServer.hs

@@ -108,6 +108,7 @@ liveServerUnitTests = testGroup "Unit tests against a live server"
   , putObjectContentTypeTest
   , putObjectContentLanguageTest
   , putObjectStorageClassTest
+  , putObjectUserMetadataTest
   , copyObjectTests
   , presignedUrlFunTest
   , presignedPostPolicyFunTest
@@ -740,6 +741,36 @@ putObjectContentLanguageTest = funTestWithBucket "putObject contentLanguage test
 
     removeObject bucket object
 
+putObjectUserMetadataTest :: TestTree
+putObjectUserMetadataTest = funTestWithBucket "putObject user-metadata test" $
+  \step bucket -> do
+    step "putObject user-metadata test"
+    let object = "object-with-metadata"
+        size1 = 100 :: Int64
+
+    step "create server object with usermetdata"
+    inputFile <- mkRandFile size1
+
+    fPutObject bucket object inputFile defaultPutObjectOptions {
+      pooUserMetadata = [ ("x-Amz-meta-mykey1", "myval1")
+                        , ("mykey2", "myval2")
+                        ]
+      }
+
+    step "Validate user-metadata"
+    -- retrieve obj info to check
+    oi <- headObject bucket object []
+    let m = oiUserMetadata oi
+        -- need to do a case-insensitive comparison
+        sortedMeta = sort $ map (\(k, v) -> (T.toLower k, T.toLower v)) $
+                     H.toList m
+        ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")]
+
+    liftIO $ (sortedMeta == ref) @? "Metadata mismatch!"
+
+    step "Cleanup actions"
+    removeObject bucket object
+
 putObjectStorageClassTest :: TestTree
 putObjectStorageClassTest = funTestWithBucket "putObject storageClass tests" $
   \step bucket -> do