Add encryption options to GetObjectOptions and PutObjectOptions (#111)
This commit is contained in:
Aditya Manthramurthy
GitHub
parent
b1a11de8b3
commit
82bb60153f
@ -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
|
||||
|
||||
@ -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",
|
||||
|
||||
@ -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
|
||||
|
||||
@ -41,6 +41,7 @@ data MErrV = MErrVSinglePUTSizeExceeded Int64
|
||||
| MErrVJsonParse Text
|
||||
| MErrVInvalidHealPath
|
||||
| MErrVMissingCredentials
|
||||
| MErrVInvalidEncryptionKeyLength
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance Exception MErrV
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user