Add encryption options to GetObjectOptions and PutObjectOptions (#111)

src/Network/Minio.hs

@@ -120,7 +120,6 @@ module Network.Minio
 
   -- ** Conduit-based streaming operations
   , putObject
-  -- | Input data type represents PutObject options.
   , PutObjectOptions
   , defaultPutObjectOptions
   , pooContentType
@@ -131,9 +130,9 @@ module Network.Minio
   , pooStorageClass
   , pooUserMetadata
   , pooNumThreads
+  , pooSSE
 
   , getObject
-  -- | Input data type represents GetObject options.
   , GetObjectOptions
   , defaultGetObjectOptions
   , gooRange
@@ -141,6 +140,7 @@ module Network.Minio
   , gooIfNoneMatch
   , gooIfModifiedSince
   , gooIfUnmodifiedSince
+  , gooSSECKey
 
   -- ** Server-side copying
   , copyObject
@@ -168,6 +168,13 @@ module Network.Minio
   -- ** Select Object Content with SQL
   , module Network.Minio.SelectAPI
 
+  -- * Server-Size Encryption Helpers
+  -----------------------------------
+  , SSECKey
+  , mkSSECKey
+  , SSE(..)
+
+
   -- * Presigned Operations
   -------------------------
   , UrlExpiry

src/Network/Minio/Data.hs

@@ -15,6 +15,7 @@
 --
 
 {-# LANGUAGE CPP                        #-}
+{-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TypeFamilies               #-}
 module Network.Minio.Data where
@@ -24,6 +25,8 @@ import qualified Control.Concurrent.MVar      as M
 import           Control.Monad.IO.Unlift      (MonadUnliftIO, UnliftIO (..),
                                                askUnliftIO, withUnliftIO)
 import           Control.Monad.Trans.Resource
+import qualified Data.Aeson                   as A
+import qualified Data.ByteArray               as BA
 import qualified Data.ByteString              as B
 import           Data.CaseInsensitive         (mk)
 import qualified Data.HashMap.Strict          as H
@@ -47,6 +50,7 @@ import           Text.XML
 import qualified UnliftIO                     as U
 
 import           Lib.Prelude
+import           Network.Minio.Data.Crypto
 
 -- | max obj size is 5TiB
 maxObjectSize :: Int64
@@ -231,6 +235,56 @@ type Region = Text
 -- | A type alias to represent an Entity-Tag returned by S3-compatible APIs.
 type ETag = Text
 
+-- | Data type to represent an object encryption key. Create one using
+-- the `mkSSECKey` function.
+newtype SSECKey = SSECKey BA.ScrubbedBytes
+                deriving (Eq, Show)
+
+-- | Validates that the given ByteString is 32 bytes long and creates
+-- an encryption key.
+mkSSECKey :: MonadThrow m => ByteString -> m SSECKey
+mkSSECKey keyBytes | B.length keyBytes /= 32 =
+                         throwM MErrVInvalidEncryptionKeyLength
+                   | otherwise =
+                         return $ SSECKey $ BA.convert keyBytes
+
+-- | Data type to represent Server-Side-Encryption settings
+data SSE where
+    -- | Specifies SSE S3 encryption - server manages encryption keys
+    SSE :: SSE
+    -- | Specifies that KMS service should be used. The first argument
+    -- to the constructor is the Key Id to be used by the server (if
+    -- not specified, the default KMS key id is used). The second
+    -- argument is the optional KMS context that must have a
+    -- `A.ToJSON` instance - please refer to the AWS S3 documentation
+    -- for detailed information.
+    SSEKMS :: A.ToJSON a => Maybe ByteString -> Maybe a -> SSE
+    -- | Specifies server-side encryption with customer provided
+    -- key. The argument is the encryption key to be used.
+    SSEC :: SSECKey -> SSE
+
+toPutObjectHeaders :: SSE -> [HT.Header]
+toPutObjectHeaders sseArg =
+    let sseHeader = "x-amz-server-side-encryption"
+        sseKmsIdHeader = sseHeader <> "-aws-kms-key-id"
+        sseKmsContextHeader = sseHeader <> "-context"
+        ssecAlgo = sseHeader <> "-customer-algorithm"
+        ssecKey = sseHeader <> "-customer-key"
+        ssecKeyMD5 = ssecKey <> "-MD5"
+
+    in case sseArg of
+      SSE -> [(sseHeader, "AES256")]
+
+      SSEKMS keyIdMay ctxMay ->
+          [(sseHeader, "aws:kms")] ++
+          maybe [] (\k -> [(sseKmsIdHeader, k)]) keyIdMay ++
+          maybe [] (\k -> [(sseKmsContextHeader, toS $ A.encode k)]) ctxMay
+
+      SSEC (SSECKey sb) ->
+          [(ssecAlgo, "AES256"),
+           (ssecKey, encodeToBase64 sb),
+           (ssecKeyMD5, hashMD5ToBase64 sb)]
+
 -- | Data type for options in PutObject call.  Start with the empty
 -- `defaultPutObjectOptions` and use various the various poo*
 -- accessors.
@@ -256,11 +310,13 @@ data PutObjectOptions = PutObjectOptions {
   , pooUserMetadata       :: [(Text, Text)]
   -- | Set number of worker threads used to upload an object.
   , pooNumThreads         :: Maybe Word
-  } deriving (Show, Eq)
+  -- | Set object encryption parameters for the request.
+  , pooSSE                :: Maybe SSE
+  }
 
 -- | Provide default `PutObjectOptions`.
 defaultPutObjectOptions :: PutObjectOptions
-defaultPutObjectOptions = PutObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing
+defaultPutObjectOptions = PutObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing Nothing
 
 addXAmzMetaPrefix :: Text -> Text
 addXAmzMetaPrefix s = do
@@ -274,6 +330,7 @@ mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix $ T.
 pooToHeaders :: PutObjectOptions -> [HT.Header]
 pooToHeaders poo = userMetadata
                    ++ (catMaybes $ map tupToMaybe (zipWith (,) names values))
+                   ++ maybe [] toPutObjectHeaders (pooSSE poo)
   where
     tupToMaybe (k, Just v)  = Just (k, v)
     tupToMaybe (_, Nothing) = Nothing
@@ -424,14 +481,18 @@ data GetObjectOptions = GetObjectOptions {
   , gooIfUnmodifiedSince :: Maybe UTCTime
     -- | Set object modified condition, GetObject modified since given time.
   , gooIfModifiedSince   :: Maybe UTCTime
-  } deriving (Show, Eq)
+    -- | Specify SSE-C key
+  , gooSSECKey           :: Maybe SSECKey
+  }
 
 -- | Provide default  `GetObjectOptions`.
 defaultGetObjectOptions :: GetObjectOptions
-defaultGetObjectOptions = GetObjectOptions Nothing Nothing Nothing Nothing Nothing
+defaultGetObjectOptions =
+    GetObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing
 
 gooToHeaders :: GetObjectOptions -> [HT.Header]
 gooToHeaders goo = rangeHdr ++ zip names values
+                   ++ maybe [] (toPutObjectHeaders . SSEC) (gooSSECKey goo)
   where
     names = ["If-Match",
              "If-None-Match",

src/Network/Minio/Data/Crypto.hs

@@ -20,12 +20,15 @@ module Network.Minio.Data.Crypto
   , hashSHA256FromSource
 
   , hashMD5
+  , hashMD5ToBase64
   , hashMD5FromSource
 
   , hmacSHA256
   , hmacSHA256RawBS
   , digestToBS
   , digestToBase16
+
+  , encodeToBase64
   ) where
 
 import           Crypto.Hash             (Digest, MD5 (..), SHA256 (..),
@@ -33,7 +36,7 @@ import           Crypto.Hash             (Digest, MD5 (..), SHA256 (..),
 import           Crypto.Hash.Conduit     (sinkHash)
 import           Crypto.MAC.HMAC         (HMAC, hmac)
 import           Data.ByteArray          (ByteArrayAccess, convert)
-import           Data.ByteArray.Encoding (Base (Base16), convertToBase)
+import           Data.ByteArray.Encoding (Base (Base16, Base64), convertToBase)
 import qualified Data.Conduit            as C
 
 import           Lib.Prelude
@@ -50,6 +53,7 @@ hashSHA256FromSource src = do
     sinkSHA256Hash :: Monad m => C.ConduitM ByteString Void m (Digest SHA256)
     sinkSHA256Hash = sinkHash
 
+-- Returns MD5 hash hex encoded.
 hashMD5 :: ByteString -> ByteString
 hashMD5 = digestToBase16 . hashWith MD5
 
@@ -73,3 +77,10 @@ digestToBS = convert
 
 digestToBase16 :: ByteArrayAccess a => a -> ByteString
 digestToBase16 = convertToBase Base16
+
+-- Returns MD5 hash base 64 encoded.
+hashMD5ToBase64 :: ByteArrayAccess a => a -> ByteString
+hashMD5ToBase64 = convertToBase Base64 . hashWith MD5
+
+encodeToBase64 :: ByteArrayAccess a => a -> ByteString
+encodeToBase64 = convertToBase Base64

src/Network/Minio/Errors.hs

@@ -41,6 +41,7 @@ data MErrV = MErrVSinglePUTSizeExceeded Int64
            | MErrVJsonParse Text
            | MErrVInvalidHealPath
            | MErrVMissingCredentials
+           | MErrVInvalidEncryptionKeyLength
   deriving (Show, Eq)
 
 instance Exception MErrV

test/LiveServer.hs

@@ -96,6 +96,123 @@ funTestWithBucket t minioTest = testCaseSteps t $ \step -> do
     deleteBucket b
   isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret)
 
+liveServerUnitTests :: TestTree
+liveServerUnitTests = testGroup "Unit tests against a live server"
+  [ basicTests
+  , listingTest
+  , highLevelListingTest
+  , lowLevelMultipartTest
+  , putObjectSizeTest
+  , putObjectNoSizeTest
+  , multipartTest
+  , putObjectContentTypeTest
+  , putObjectContentLanguageTest
+  , putObjectStorageClassTest
+  , copyObjectTests
+  , presignedUrlFunTest
+  , presignedPostPolicyFunTest
+  , bucketPolicyFunTest
+  , getNPutSSECTest
+  ]
+
+basicTests :: TestTree
+basicTests = funTestWithBucket "Basic tests" $
+  \step bucket -> do
+    step "getService works and contains the test bucket."
+    buckets <- getService
+    unless (length (filter (== bucket) $ map biName buckets) == 1) $
+      liftIO $
+      assertFailure ("The bucket " ++ show bucket ++
+                     " was expected to exist.")
+
+    step "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised."
+    mbE <- try $ makeBucket bucket Nothing
+    case mbE of
+      Left exn -> liftIO $ exn @?= BucketAlreadyOwnedByYou
+      _        -> return ()
+
+    step "makeBucket with an invalid bucket name and check for appropriate exception."
+    invalidMBE <- try $ makeBucket "invalidBucketName" Nothing
+    case invalidMBE of
+      Left exn -> liftIO $ exn @?= MErrVInvalidBucketName "invalidBucketName"
+      _        -> return ()
+
+    step "getLocation works"
+    region <- getLocation bucket
+    liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region)
+
+    step "singlepart putObject works"
+    fPutObject bucket "lsb-release" "/etc/lsb-release" defaultPutObjectOptions
+
+    step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception"
+    fpE <- try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release" defaultPutObjectOptions
+    case fpE of
+      Left exn -> liftIO $ exn @?= NoSuchBucket
+      _        -> return ()
+
+    outFile <- mkRandFile 0
+    step "simple fGetObject works"
+    fGetObject bucket "lsb-release" outFile defaultGetObjectOptions
+
+    let unmodifiedTime = UTCTime (fromGregorian 2010 11 26) 69857
+    step "fGetObject an object which is modified now but requesting as un-modified in past, check for exception"
+    resE <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions {
+      gooIfUnmodifiedSince = (Just unmodifiedTime)
+      }
+    case resE of
+      Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold"
+      _        -> return ()
+
+    step "fGetObject an object with no matching etag, check for exception"
+    resE1 <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions {
+      gooIfMatch = (Just "invalid-etag")
+      }
+    case resE1 of
+      Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold"
+      _        -> return ()
+
+    step "fGetObject an object with no valid range, check for exception"
+    resE2 <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions {
+      gooRange = (Just $ HT.ByteRangeFromTo 100 200)
+      }
+    case resE2 of
+        Left exn -> liftIO $ exn @?= ServiceErr "InvalidRange" "The requested range is not satisfiable"
+        _        -> return ()
+
+    step "fGetObject on object with a valid range"
+    fGetObject bucket "lsb-release" outFile defaultGetObjectOptions {
+      gooRange = (Just $ HT.ByteRangeFrom 1)
+      }
+
+    step "fGetObject a non-existent object and check for NoSuchKey exception"
+    resE3 <- try $ fGetObject bucket "noSuchKey" outFile defaultGetObjectOptions
+    case resE3 of
+      Left exn -> liftIO $ exn @?= NoSuchKey
+      _        -> return ()
+
+    step "create new multipart upload works"
+    uid <- newMultipartUpload bucket "newmpupload" []
+    liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
+
+    step "abort a new multipart upload works"
+    abortMultipartUpload bucket "newmpupload" uid
+
+    step "delete object works"
+    deleteObject bucket "lsb-release"
+
+    step "statObject test"
+    let object = "sample"
+    step "create an object"
+    inputFile <- mkRandFile 0
+    fPutObject bucket object inputFile defaultPutObjectOptions
+
+    step "get metadata of the object"
+    res <- statObject bucket object
+    liftIO $ (oiSize res) @?= 0
+
+    step "delete object"
+    deleteObject bucket object
+
 lowLevelMultipartTest :: TestTree
 lowLevelMultipartTest = funTestWithBucket "Low-level Multipart Test" $
     \step bucket -> do
@@ -299,123 +416,6 @@ listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do
       liftIO $ (length $ lprParts listPartsResult) @?= 10
       abortMultipartUpload bucket object uid
 
-
-liveServerUnitTests :: TestTree
-liveServerUnitTests = testGroup "Unit tests against a live server"
-  [ basicTests
-  , listingTest
-  , highLevelListingTest
-  , lowLevelMultipartTest
-  , putObjectSizeTest
-  , putObjectNoSizeTest
-  , multipartTest
-  , putObjectContentTypeTest
-  , putObjectContentLanguageTest
-  , putObjectStorageClassTest
-  , copyObjectTests
-  , presignedUrlFunTest
-  , presignedPostPolicyFunTest
-  , bucketPolicyFunTest
-  ]
-
-basicTests :: TestTree
-basicTests = funTestWithBucket "Basic tests" $
-  \step bucket -> do
-    step "getService works and contains the test bucket."
-    buckets <- getService
-    unless (length (filter (== bucket) $ map biName buckets) == 1) $
-      liftIO $
-      assertFailure ("The bucket " ++ show bucket ++
-                     " was expected to exist.")
-
-    step "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised."
-    mbE <- try $ makeBucket bucket Nothing
-    case mbE of
-      Left exn -> liftIO $ exn @?= BucketAlreadyOwnedByYou
-      _        -> return ()
-
-    step "makeBucket with an invalid bucket name and check for appropriate exception."
-    invalidMBE <- try $ makeBucket "invalidBucketName" Nothing
-    case invalidMBE of
-      Left exn -> liftIO $ exn @?= MErrVInvalidBucketName "invalidBucketName"
-      _        -> return ()
-
-    step "getLocation works"
-    region <- getLocation bucket
-    liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region)
-
-    step "singlepart putObject works"
-    fPutObject bucket "lsb-release" "/etc/lsb-release" defaultPutObjectOptions
-
-    step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception"
-    fpE <- try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release" defaultPutObjectOptions
-    case fpE of
-      Left exn -> liftIO $ exn @?= NoSuchBucket
-      _        -> return ()
-
-    outFile <- mkRandFile 0
-    step "simple fGetObject works"
-    fGetObject bucket "lsb-release" outFile defaultGetObjectOptions
-
-    let unmodifiedTime = UTCTime (fromGregorian 2010 11 26) 69857
-    step "fGetObject an object which is modified now but requesting as un-modified in past, check for exception"
-    resE <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions {
-      gooIfUnmodifiedSince = (Just unmodifiedTime)
-      }
-    case resE of
-      Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold"
-      _        -> return ()
-
-    step "fGetObject an object with no matching etag, check for exception"
-    resE1 <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions {
-      gooIfMatch = (Just "invalid-etag")
-      }
-    case resE1 of
-      Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold"
-      _        -> return ()
-
-    step "fGetObject an object with no valid range, check for exception"
-    resE2 <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions {
-      gooRange = (Just $ HT.ByteRangeFromTo 100 200)
-      }
-    case resE2 of
-        Left exn -> liftIO $ exn @?= ServiceErr "InvalidRange" "The requested range is not satisfiable"
-        _        -> return ()
-
-    step "fGetObject on object with a valid range"
-    fGetObject bucket "lsb-release" outFile defaultGetObjectOptions {
-      gooRange = (Just $ HT.ByteRangeFrom 1)
-      }
-
-    step "fGetObject a non-existent object and check for NoSuchKey exception"
-    resE3 <- try $ fGetObject bucket "noSuchKey" outFile defaultGetObjectOptions
-    case resE3 of
-      Left exn -> liftIO $ exn @?= NoSuchKey
-      _        -> return ()
-
-    step "create new multipart upload works"
-    uid <- newMultipartUpload bucket "newmpupload" []
-    liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
-
-    step "abort a new multipart upload works"
-    abortMultipartUpload bucket "newmpupload" uid
-
-    step "delete object works"
-    deleteObject bucket "lsb-release"
-
-    step "statObject test"
-    let object = "sample"
-    step "create an object"
-    inputFile <- mkRandFile 0
-    fPutObject bucket object inputFile defaultPutObjectOptions
-
-    step "get metadata of the object"
-    res <- statObject bucket object
-    liftIO $ (oiSize res) @?= 0
-
-    step "delete object"
-    deleteObject bucket object
-
 presignedUrlFunTest :: TestTree
 presignedUrlFunTest = funTestWithBucket "presigned Url tests" $
   \step bucket -> do
@@ -849,3 +849,45 @@ copyObjectTests = funTestWithBucket "copyObject related tests" $
     liftIO $ (cSize == 10 * 1024 * 1024) @? "Uploaded obj size mismatched!"
 
     forM_ [src, copyObj] (removeObject bucket)
+
+getNPutSSECTest :: TestTree
+getNPutSSECTest =
+    funTestWithBucket "Get and Put SSE-C Test" $ \step bucket -> do
+       -- Skip this test if the server is not using TLS as encryption is
+       -- disabled anyway.
+       isTLSConn <- asks (connectIsSecure . mcConnInfo)
+       if isTLSConn
+           then do step "Make an encryption key"
+                   key <- case mkSSECKey $ BS.pack [0..31] of
+                            Nothing -> liftIO $ assertFailure "This should not happen"
+                            Just k  -> return k
+
+                   let mb1 = 1024*1024
+                       obj = "1"
+                   step "Upload an object using the encryption key"
+                   rFile <- mkRandFile mb1
+                   let putOpts = defaultPutObjectOptions { pooSSE = Just $ SSEC key }
+                   fPutObject bucket obj rFile putOpts
+
+                   step "Stat object without key - should fail"
+                   headRes <- try $ statObject bucket obj
+                   case headRes of
+                     Right _ -> liftIO $ assertFailure "Cannot perform head object on encrypted object without specifying key"
+                     Left ex@(NC.HttpExceptionRequest _ (NC.StatusCodeException rsp _))
+                         | NC.responseStatus rsp == HT.status400 -> return ()
+                         | otherwise -> liftIO $ assertFailure $ "Unexpected err: " ++ show ex
+                     Left ex -> liftIO $ assertFailure $ "Unexpected err: " ++ show ex
+
+                   step "Get file and check length"
+                   dstFile <- mkRandFile 0
+                   let getOpts = defaultGetObjectOptions { gooSSECKey = Just key }
+                   fGetObject bucket obj dstFile getOpts
+
+                   gotSize <- withNewHandle dstFile getFileSize
+                   liftIO $ gotSize == Right (Just mb1) @?
+                       "Wrong file size of object when getting"
+
+                   step "Cleanup"
+                   deleteObject bucket obj
+
+           else step "Skipping encryption test as server is not using TLS"

test/Spec.hs

@@ -17,6 +17,7 @@
 import           Test.Tasty
 import           Test.Tasty.QuickCheck           as QC
 
+import qualified Data.ByteString                 as B
 import qualified Data.List                       as L
 
 import           Lib.Prelude
@@ -111,6 +112,13 @@ qcProps = testGroup "(checked by QuickCheck)"
 
       in start < 0 || start > end ||
          (isLastPartOk && isFirstPartOk && isPartSizesOk && isContParts)
+
+  , QC.testProperty "mkSSECKey:" $
+    \w8s -> let bs = B.pack w8s
+                r = mkSSECKey bs
+            in case r of
+                Just _  -> B.length bs == 32
+                Nothing -> B.length bs /= 32
   ]
 
 unitTests :: TestTree