diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index 59e7dfa..9a3e46b 100644 --- a/src/Network/Minio.hs +++ b/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 diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index f7f958e..40e4fc0 100644 --- a/src/Network/Minio/Data.hs +++ b/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", diff --git a/src/Network/Minio/Data/Crypto.hs b/src/Network/Minio/Data/Crypto.hs index b3d9283..a426725 100644 --- a/src/Network/Minio/Data/Crypto.hs +++ b/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 diff --git a/src/Network/Minio/Errors.hs b/src/Network/Minio/Errors.hs index 30d9719..983a332 100644 --- a/src/Network/Minio/Errors.hs +++ b/src/Network/Minio/Errors.hs @@ -41,6 +41,7 @@ data MErrV = MErrVSinglePUTSizeExceeded Int64 | MErrVJsonParse Text | MErrVInvalidHealPath | MErrVMissingCredentials + | MErrVInvalidEncryptionKeyLength deriving (Show, Eq) instance Exception MErrV diff --git a/test/LiveServer.hs b/test/LiveServer.hs index 139eea7..b79b75c 100644 --- a/test/LiveServer.hs +++ b/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" diff --git a/test/Spec.hs b/test/Spec.hs index cc33589..9e320e2 100644 --- a/test/Spec.hs +++ b/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