diff --git a/.travis.yml b/.travis.yml index ad53513..4484279 100644 --- a/.travis.yml +++ b/.travis.yml @@ -37,4 +37,4 @@ install: script: # Build the package, its tests, and its docs and run the tests -- stack --no-terminal test --haddock --no-haddock-deps +- stack --no-terminal test --haddock --no-haddock-deps --test-arguments --num-threads=1 diff --git a/examples/PresignedPostPolicy.hs b/examples/PresignedPostPolicy.hs new file mode 100755 index 0000000..1d4a4c8 --- /dev/null +++ b/examples/PresignedPostPolicy.hs @@ -0,0 +1,84 @@ +#!/usr/bin/env stack +-- stack --resolver lts-9.1 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +{-# LANGUAGE OverloadedStrings #-} +import Network.Minio + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.Map.Strict as Map +import qualified Data.Text.Encoding as Enc +import qualified Data.Time as Time + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + now <- Time.getCurrentTime + let + bucket = "my-bucket" + object = "my-object" + + -- set an expiration time of 10 days + expireTime = Time.addUTCTime (3600 * 24 * 10) now + + -- create a policy with expiration time and conditions - since the + -- conditions are validated, newPostPolicy returns an Either value + policyE = newPostPolicy expireTime + [ -- set the object name condition + ppCondKey "photos/my-object" + -- set the bucket name condition + , ppCondBucket "my-bucket" + -- set the size range of object as 1B to 10MiB + , ppCondContentLengthRange 1 (10*1024*1024) + -- set content type as jpg image + , ppCondContentType "image/jpeg" + -- on success set the server response code to 200 + , ppCondSuccessActionStatus 200 + ] + + case policyE of + Left err -> putStrLn $ show err + Right policy -> do + res <- runMinio minioPlayCI $ do + (url, formData) <- presignedPostPolicy policy + + -- a curl command is output to demonstrate using the generated + -- URL and form-data + let + formFn (k, v) = B.concat ["-F ", Enc.encodeUtf8 k, "=", + "'", v, "'"] + formOptions = B.intercalate " " $ map formFn $ Map.toList formData + + + return $ B.intercalate " " $ + ["curl", formOptions, "-F file=@/tmp/photo.jpg", url] + + case res of + Left e -> putStrLn $ "post-policy error: " ++ (show e) + Right cmd -> do + putStrLn $ "Put a photo at /tmp/photo.jpg and run command:\n" + + -- print the generated curl command + Char8.putStrLn cmd diff --git a/minio-hs.cabal b/minio-hs.cabal index a7efa05..c3981dd 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -29,6 +29,7 @@ library , Network.Minio.Data.Time , Network.Minio.Errors , Network.Minio.ListOps + , Network.Minio.PresignedOperations , Network.Minio.PutObject , Network.Minio.Sign.V4 , Network.Minio.Utils @@ -36,7 +37,9 @@ library , Network.Minio.XmlParser build-depends: base >= 4.7 && < 5 , protolude >= 0.1.6 && < 0.2 + , aeson , async + , base64-bytestring , bytestring , case-insensitive , conduit @@ -61,6 +64,7 @@ library , time , transformers , transformers-base + , vector , xml-conduit default-language: Haskell2010 default-extensions: FlexibleContexts @@ -105,6 +109,7 @@ test-suite minio-hs-live-server-test , Network.Minio.Data.Time , Network.Minio.Errors , Network.Minio.ListOps + , Network.Minio.PresignedOperations , Network.Minio.PutObject , Network.Minio.S3API , Network.Minio.Sign.V4 @@ -118,7 +123,9 @@ test-suite minio-hs-live-server-test build-depends: base , minio-hs , protolude >= 0.1.6 && < 0.2 + , aeson , async + , base64-bytestring , bytestring , case-insensitive , conduit @@ -150,6 +157,7 @@ test-suite minio-hs-live-server-test , time , transformers , transformers-base + , vector , xml-conduit if !flag(live-test) buildable: False @@ -161,7 +169,9 @@ test-suite minio-hs-test build-depends: base , minio-hs , protolude >= 0.1.6 && < 0.2 + , aeson , async + , base64-bytestring , bytestring , case-insensitive , conduit @@ -193,6 +203,7 @@ test-suite minio-hs-test , time , transformers , transformers-base + , vector , xml-conduit ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 @@ -216,6 +227,7 @@ test-suite minio-hs-test , Network.Minio.Data.Time , Network.Minio.Errors , Network.Minio.ListOps + , Network.Minio.PresignedOperations , Network.Minio.PutObject , Network.Minio.S3API , Network.Minio.Sign.V4 diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index 46834f4..58e2b3d 100644 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -81,6 +81,20 @@ module Network.Minio , presignedPutObjectURL , presignedGetObjectURL , presignedHeadObjectURL + + , PostPolicyCondition + , ppCondBucket + , ppCondContentLengthRange + , ppCondContentType + , ppCondKey + , ppCondKeyStartsWith + , ppCondSuccessActionStatus + + , PostPolicy + , PostPolicyError(..) + , newPostPolicy + , presignedPostPolicy + , showPostPolicy ) where {- diff --git a/src/Network/Minio/Data/Time.hs b/src/Network/Minio/Data/Time.hs index f25d849..09abcb9 100644 --- a/src/Network/Minio/Data/Time.hs +++ b/src/Network/Minio/Data/Time.hs @@ -21,6 +21,7 @@ module Network.Minio.Data.Time , awsDateFormat , awsDateFormatBS , awsParseTime + , iso8601TimeFormat ) where @@ -43,3 +44,6 @@ awsDateFormatBS = pack . awsDateFormat awsParseTime :: [Char] -> Maybe UTCTime awsParseTime = Time.parseTimeM False Time.defaultTimeLocale "%Y%m%dT%H%M%SZ" + +iso8601TimeFormat :: UTCTime -> [Char] +iso8601TimeFormat = Time.formatTime Time.defaultTimeLocale (Time.iso8601DateFormat $ Just "%T%QZ") diff --git a/src/Network/Minio/PresignedOperations.hs b/src/Network/Minio/PresignedOperations.hs new file mode 100644 index 0000000..698790a --- /dev/null +++ b/src/Network/Minio/PresignedOperations.hs @@ -0,0 +1,281 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +module Network.Minio.PresignedOperations + ( UrlExpiry + , makePresignedURL + , presignedPutObjectURL + , presignedGetObjectURL + , presignedHeadObjectURL + + , PostPolicyCondition(..) + , ppCondBucket + , ppCondContentLengthRange + , ppCondContentType + , ppCondKey + , ppCondKeyStartsWith + , ppCondSuccessActionStatus + + , PostPolicy(..) + , PostPolicyError(..) + , newPostPolicy + , showPostPolicy + , presignedPostPolicy + ) where + +import Data.Aeson ((.=)) +import qualified Data.Aeson as Json +import Data.ByteString.Builder (byteString, toLazyByteString) +import Data.Default (def) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import qualified Data.Time as Time +import qualified Network.HTTP.Types as HT +import Network.HTTP.Types.Header (hHost) + +import Lib.Prelude + +import Network.Minio.Data +import Network.Minio.Data.Time +import Network.Minio.Errors +import Network.Minio.Sign.V4 + +-- | Generate a presigned URL. This function allows for advanced usage +-- - for simple cases prefer the `presigned*URL` functions. +-- +-- If region is Nothing, it is picked up from the connection +-- information (no check of bucket existence is performed). +-- +-- All extra query parameters or headers are signed, and therefore are +-- required to be sent when the generated URL is actually used. +makePresignedURL :: UrlExpiry -> HT.Method -> Maybe Bucket -> Maybe Object + -> Maybe Region -> HT.Query -> HT.RequestHeaders + -> Minio ByteString +makePresignedURL expiry method bucket object region extraQuery extraHeaders = do + when (expiry > 7*24*3600 || expiry < 0) $ + throwM $ MErrVInvalidUrlExpiry expiry + + ci <- asks mcConnInfo + + let + host = formatBS "{}:{}" (connectHost ci, connectPort ci) + hostHeader = (hHost, host) + ri = def { riMethod = method + , riBucket = bucket + , riObject = object + , riQueryParams = extraQuery + , riHeaders = hostHeader : extraHeaders + , riRegion = Just $ maybe (connectRegion ci) identity region + } + + signPairs <- liftIO $ signV4 ci ri (Just expiry) + + let + qpToAdd = (fmap . fmap) Just signPairs + queryStr = HT.renderQueryBuilder True (riQueryParams ri ++ qpToAdd) + scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci + + return $ toS $ toLazyByteString $ + scheme <> byteString host <> byteString (getPathFromRI ri) <> queryStr + +-- | Generate a URL with authentication signature to PUT (upload) an +-- object. Any extra headers if passed, are signed, and so they are +-- required when the URL is used to upload data. This could be used, +-- for example, to set user-metadata on the object. +-- +-- For a list of possible headers to pass, please refer to the PUT +-- object REST API AWS S3 documentation. +presignedPutObjectURL :: Bucket -> Object -> UrlExpiry -> HT.RequestHeaders + -> Minio ByteString +presignedPutObjectURL bucket object expirySeconds extraHeaders = + makePresignedURL expirySeconds HT.methodPut + (Just bucket) (Just object) Nothing [] extraHeaders + +-- | Generate a URL with authentication signature to GET (download) an +-- object. All extra query parameters and headers passed here will be +-- signed and are required when the generated URL is used. Query +-- parameters could be used to change the response headers sent by the +-- server. Headers can be used to set Etag match conditions among +-- others. +-- +-- For a list of possible request parameters and headers, please refer +-- to the GET object REST API AWS S3 documentation. +presignedGetObjectURL :: Bucket -> Object -> UrlExpiry -> HT.Query + -> HT.RequestHeaders -> Minio ByteString +presignedGetObjectURL bucket object expirySeconds extraQuery extraHeaders = + makePresignedURL expirySeconds HT.methodGet + (Just bucket) (Just object) Nothing extraQuery extraHeaders + +-- | Generate a URL with authentication signature to make a HEAD +-- request on an object. This is used to fetch metadata about an +-- object. All extra headers passed here will be signed and are +-- required when the generated URL is used. +-- +-- For a list of possible headers to pass, please refer to the HEAD +-- object REST API AWS S3 documentation. +presignedHeadObjectURL :: Bucket -> Object -> UrlExpiry + -> HT.RequestHeaders -> Minio ByteString +presignedHeadObjectURL bucket object expirySeconds extraHeaders = + makePresignedURL expirySeconds HT.methodHead + (Just bucket) (Just object) Nothing [] extraHeaders + +-- | Represents individual conditions in a Post Policy document. +data PostPolicyCondition = PPCStartsWith Text Text + | PPCEquals Text Text + | PPCRange Text Int64 Int64 + deriving (Show, Eq) + +instance Json.ToJSON PostPolicyCondition where + toJSON (PPCStartsWith k v) = Json.toJSON ["starts-with", k, v] + toJSON (PPCEquals k v) = Json.object [k .= v] + toJSON (PPCRange k minVal maxVal) = + Json.toJSON [Json.toJSON k, Json.toJSON minVal, Json.toJSON maxVal] + + toEncoding (PPCStartsWith k v) = Json.foldable ["starts-with", k, v] + toEncoding (PPCEquals k v) = Json.pairs (k .= v) + toEncoding (PPCRange k minVal maxVal) = + Json.foldable [Json.toJSON k, Json.toJSON minVal, Json.toJSON maxVal] + +-- | A PostPolicy is required to perform uploads via browser forms. +data PostPolicy = PostPolicy { + expiration :: UTCTime + , conditions :: [PostPolicyCondition] + } deriving (Show, Eq) + +instance Json.ToJSON PostPolicy where + toJSON (PostPolicy e c) = + Json.object $ [ "expiration" .= iso8601TimeFormat e + , "conditions" .= c + ] + toEncoding (PostPolicy e c) = + Json.pairs ("expiration" .= iso8601TimeFormat e <> "conditions" .= c) + +-- | Possible validation errors when creating a PostPolicy. +data PostPolicyError = PPEKeyNotSpecified + | PPEBucketNotSpecified + | PPEConditionKeyEmpty + | PPERangeInvalid + deriving (Eq, Show) + +-- | Set the bucket name that the upload should use. +ppCondBucket :: Bucket -> PostPolicyCondition +ppCondBucket = PPCEquals "bucket" + +-- | Set the content length range constraint with minimum and maximum +-- byte count values. +ppCondContentLengthRange :: Int64 -> Int64 + -> PostPolicyCondition +ppCondContentLengthRange = PPCRange "content-length-range" + +-- | Set the content-type header for the upload. +ppCondContentType :: Text -> PostPolicyCondition +ppCondContentType = PPCEquals "Content-Type" + +-- | Set the object name constraint for the upload. +ppCondKey :: Object -> PostPolicyCondition +ppCondKey = PPCEquals "key" + +-- | Set the object name prefix constraint for the upload. +ppCondKeyStartsWith :: Object -> PostPolicyCondition +ppCondKeyStartsWith = PPCStartsWith "key" + +-- | Status code that the S3-server should send on a successful POST +-- upload +ppCondSuccessActionStatus :: Int -> PostPolicyCondition +ppCondSuccessActionStatus n = + PPCEquals "success_action_status" (show n) + +-- | This function creates a PostPolicy after validating its +-- arguments. +newPostPolicy :: UTCTime -> [PostPolicyCondition] + -> Either PostPolicyError PostPolicy +newPostPolicy expirationTime conds + -- object name condition must be present + | not $ any (keyEquals "key") conds = + Left PPEKeyNotSpecified + + -- bucket name condition must be present + | not $ any (keyEquals "bucket") conds = + Left PPEBucketNotSpecified + + -- a condition with an empty key is invalid + | any (keyEquals "") conds || any isEmptyRangeKey conds = + Left PPEConditionKeyEmpty + + -- invalid range check + | any isInvalidRange conds = + Left PPERangeInvalid + + -- all good! + | otherwise = + return $ PostPolicy expirationTime conds + + where + keyEquals k' (PPCStartsWith k _) = k == k' + keyEquals k' (PPCEquals k _) = k == k' + keyEquals _ _ = False + + isEmptyRangeKey (PPCRange k _ _) = k == "" + isEmptyRangeKey _ = False + + isInvalidRange (PPCRange _ mi ma) = mi < 0 || mi > ma + isInvalidRange _ = False + +-- | Convert Post Policy to a string (e.g. for printing). +showPostPolicy :: PostPolicy -> ByteString +showPostPolicy = toS . Json.encode + +-- | Generate a presigned URL and POST policy to upload files via a +-- browser. On success, this function returns a URL and a POST +-- form-data. +presignedPostPolicy :: PostPolicy + -> Minio (ByteString, Map.Map Text ByteString) +presignedPostPolicy p = do + ci <- asks mcConnInfo + signTime <- liftIO $ Time.getCurrentTime + + let + extraConditions = + [ PPCEquals "x-amz-date" (toS $ awsTimeFormat signTime) + , PPCEquals "x-amz-algorithm" "AWS4-HMAC-SHA256" + , PPCEquals "x-amz-credential" + (T.intercalate "/" [connectAccessKey ci, + decodeUtf8 $ mkScope signTime region]) + ] + ppWithCreds = p { + conditions = conditions p ++ extraConditions + } + signData = signV4PostPolicy (showPostPolicy ppWithCreds) + signTime ci + + -- compute form-data + mkPair (PPCStartsWith k v) = Just (k, v) + mkPair (PPCEquals k v) = Just (k, v) + mkPair _ = Nothing + formFromPolicy = Map.map toS $ Map.fromList $ catMaybes $ + mkPair <$> conditions ppWithCreds + formData = formFromPolicy `Map.union` signData + + -- compute POST upload URL + bucket = Map.findWithDefault "" "bucket" formData + scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci + host = formatBS "{}:{}" (connectHost ci, connectPort ci) + region = connectRegion ci + + url = toS $ toLazyByteString $ scheme <> byteString host <> + byteString "/" <> byteString (toS bucket) <> byteString "/" + + return (url, formData) diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index 542dcb1..e8de594 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -64,33 +64,27 @@ module Network.Minio.S3API , deleteBucket , deleteObject - -- * Presigned URL Operations + -- * Presigned Operations ----------------------------- - , UrlExpiry - , makePresignedURL - , presignedPutObjectURL - , presignedGetObjectURL - , presignedHeadObjectURL + , module Network.Minio.PresignedOperations ) where import Control.Monad.Catch (catches, Handler(..)) import qualified Data.Conduit as C import Data.Default (def) -import Data.ByteString.Builder (toLazyByteString, byteString) import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Types as HT import Network.HTTP.Types.Status (status404) -import Network.HTTP.Types.Header (hHost) import Lib.Prelude hiding (catches) import Network.Minio.API import Network.Minio.Data -import Network.Minio.Sign.V4 import Network.Minio.Errors import Network.Minio.Utils import Network.Minio.XmlGenerator import Network.Minio.XmlParser +import Network.Minio.PresignedOperations -- | Fetch all buckets from the service. @@ -368,83 +362,3 @@ headBucket bucket = headBucketEx `catches` , riBucket = Just bucket } return $ NC.responseStatus resp == HT.ok200 - --- | Generate a presigned URL. This function allows for advanced usage --- - for simple cases prefer the `presigned*URL` functions. --- --- If region is Nothing, it is picked up from the connection --- information (no check of bucket existence is performed). --- --- All extra query parameters or headers are signed, and therefore are --- required to be sent when the generated URL is actually used. -makePresignedURL :: UrlExpiry -> HT.Method -> Maybe Bucket -> Maybe Object - -> Maybe Region -> HT.Query -> HT.RequestHeaders - -> Minio ByteString -makePresignedURL expiry method bucket object region extraQuery extraHeaders = do - when (expiry > 7*24*3600 || expiry < 0) $ - throwM $ MErrVInvalidUrlExpiry expiry - - - ci <- asks mcConnInfo - - let - host = formatBS "{}:{}" (connectHost ci, connectPort ci) - hostHeader = (hHost, host) - ri = def { riMethod = method - , riBucket = bucket - , riObject = object - , riQueryParams = extraQuery - , riHeaders = hostHeader : extraHeaders - , riRegion = Just $ maybe (connectRegion ci) identity region - } - - signPairs <- liftIO $ signV4 ci ri (Just expiry) - - let - qpToAdd = (fmap . fmap) Just signPairs - queryStr = HT.renderQueryBuilder True (riQueryParams ri ++ qpToAdd) - scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci - - return $ toS $ toLazyByteString $ - scheme <> byteString host <> byteString (getPathFromRI ri) <> queryStr - --- | Generate a URL with authentication signature to PUT (upload) an --- object. Any extra headers if passed, are signed, and so they are --- required when the URL is used to upload data. This could be used, --- for example, to set user-metadata on the object. --- --- For a list of possible headers to pass, please refer to the PUT --- object REST API AWS S3 documentation. -presignedPutObjectURL :: Bucket -> Object -> UrlExpiry -> HT.RequestHeaders - -> Minio ByteString -presignedPutObjectURL bucket object expirySeconds extraHeaders = - makePresignedURL expirySeconds HT.methodPut - (Just bucket) (Just object) Nothing [] extraHeaders - --- | Generate a URL with authentication signature to GET (download) an --- object. All extra query parameters and headers passed here will be --- signed and are required when the generated URL is used. Query --- parameters could be used to change the response headers sent by the --- server. Headers can be used to set Etag match conditions among --- others. --- --- For a list of possible request parameters and headers, please refer --- to the GET object REST API AWS S3 documentation. -presignedGetObjectURL :: Bucket -> Object -> UrlExpiry -> HT.Query - -> HT.RequestHeaders -> Minio ByteString -presignedGetObjectURL bucket object expirySeconds extraQuery extraHeaders = - makePresignedURL expirySeconds HT.methodGet - (Just bucket) (Just object) Nothing extraQuery extraHeaders - --- | Generate a URL with authentication signature to make a HEAD --- request on an object. This is used to fetch metadata about an --- object. All extra headers passed here will be signed and are --- required when the generated URL is used. --- --- For a list of possible headers to pass, please refer to the HEAD --- object REST API AWS S3 documentation. -presignedHeadObjectURL :: Bucket -> Object -> UrlExpiry - -> HT.RequestHeaders -> Minio ByteString -presignedHeadObjectURL bucket object expirySeconds extraHeaders = - makePresignedURL expirySeconds HT.methodHead - (Just bucket) (Just object) Nothing [] extraHeaders diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs index fdfcea8..44ef1b1 100644 --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -18,6 +18,7 @@ module Network.Minio.Sign.V4 ( signV4 , signV4AtTime + , signV4PostPolicy , mkScope , getHeadersToSign , mkCanonicalRequest @@ -34,6 +35,8 @@ import Data.CaseInsensitive (mk) import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Time as Time +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.Map.Strict as Map import Network.HTTP.Types (Header) import qualified Network.HTTP.Types.Header as H @@ -226,3 +229,19 @@ mkSigningKey ts region !secretKey = hmacSHA256RawBS "aws4_request" computeSignature :: ByteString -> ByteString -> ByteString computeSignature !toSign !key = digestToBase16 $ hmacSHA256 toSign key + +-- | Takes a validated Post Policy JSON bytestring, the signing time, +-- and ConnInfo and returns form-data for the POST upload containing +-- just the signature and the encoded post-policy. +signV4PostPolicy :: ByteString -> UTCTime -> ConnectInfo + -> Map.Map Text ByteString +signV4PostPolicy !postPolicyJSON !signTime !ci = + let + stringToSign = Base64.encode postPolicyJSON + region = connectRegion ci + signingKey = mkSigningKey signTime region $ toS $ connectSecretKey ci + signature = computeSignature stringToSign signingKey + in + Map.fromList [ ("x-amz-signature", signature) + , ("policy", stringToSign) + ] diff --git a/test/LiveServer.hs b/test/LiveServer.hs index 7c8ebad..0e96d20 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -14,30 +14,31 @@ -- limitations under the License. -- -import qualified Test.QuickCheck as Q +import qualified Test.QuickCheck as Q import Test.Tasty import Test.Tasty.HUnit -import Test.Tasty.QuickCheck as QC +import Test.Tasty.QuickCheck as QC import Lib.Prelude -import System.Directory (getTemporaryDirectory) -import qualified System.IO as SIO +import System.Directory (getTemporaryDirectory) +import qualified System.IO as SIO -import qualified Control.Monad.Catch as MC -import qualified Control.Monad.Trans.Resource as R -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LB -import Data.Conduit (($$), yield) -import qualified Data.Conduit as C -import qualified Data.Conduit.Binary as CB -import Data.Conduit.Combinators (sinkList) -import Data.Default (Default(..)) -import qualified Data.Map.Strict as Map -import qualified Data.Text as T -import System.Environment (lookupEnv) -import qualified Network.HTTP.Types as HT -import qualified Network.HTTP.Conduit as NC +import qualified Control.Monad.Catch as MC +import qualified Control.Monad.Trans.Resource as R +import qualified Data.ByteString as BS +import Data.Conduit (yield, ($$)) +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB +import Data.Conduit.Combinators (sinkList) +import Data.Default (Default (..)) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import qualified Data.Time as Time +import qualified Network.HTTP.Client.MultipartFormData as Form +import qualified Network.HTTP.Conduit as NC +import qualified Network.HTTP.Types as HT +import System.Environment (lookupEnv) import Network.Minio import Network.Minio.Data @@ -110,7 +111,7 @@ liveServerUnitTests = testGroup "Unit tests against a live server" mbE <- MC.try $ makeBucket bucket Nothing case mbE of Left exn -> liftIO $ exn @?= BucketAlreadyOwnedByYou - _ -> return () + _ -> return () step "makeBucket with an invalid bucket name and check for appropriate exception." invalidMBE <- MC.try $ makeBucket "invalidBucketName" Nothing @@ -129,7 +130,7 @@ liveServerUnitTests = testGroup "Unit tests against a live server" fpE <- MC.try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release" case fpE of Left exn -> liftIO $ exn @?= NoSuchBucket - _ -> return () + _ -> return () outFile <- mkRandFile 0 step "simple fGetObject works" @@ -139,7 +140,7 @@ liveServerUnitTests = testGroup "Unit tests against a live server" resE <- MC.try $ fGetObject bucket "noSuchKey" outFile case resE of Left exn -> liftIO $ exn @?= NoSuchKey - _ -> return () + _ -> return () step "create new multipart upload works" @@ -481,11 +482,12 @@ liveServerUnitTests = testGroup "Unit tests against a live server" forM_ [src, copyObj] (removeObject bucket) - , presignedFunTest + , presignedURLFunTest + , presignedPostPolicyFunTest ] -presignedFunTest :: TestTree -presignedFunTest = funTestWithBucket "presigned URL tests" $ +presignedURLFunTest :: TestTree +presignedURLFunTest = funTestWithBucket "presigned URL tests" $ \step bucket -> do let obj = "mydir/myput" obj2 = "mydir1/myfile1" @@ -566,3 +568,46 @@ presignedFunTest = funTestWithBucket "presigned URL tests" $ getR mgr url = do req <- NC.parseRequest $ toS url NC.httpLbs req mgr + +presignedPostPolicyFunTest :: TestTree +presignedPostPolicyFunTest = funTestWithBucket "presigned URL tests" $ + \step bucket -> do + + step "presignedPostPolicy basic test" + now <- liftIO $ Time.getCurrentTime + + let key = "presignedPostPolicyTest/myfile" + policyConds = [ ppCondBucket bucket + , ppCondKey key + , ppCondContentLengthRange 1 1000 + , ppCondContentType "application/octet-stream" + , ppCondSuccessActionStatus 200 + ] + + expirationTime = Time.addUTCTime 3600 now + postPolicyE = newPostPolicy expirationTime policyConds + + size = 1000 :: Int64 + + inputFile <- mkRandFile size + + case postPolicyE of + Left err -> liftIO $ assertFailure $ show err + Right postPolicy -> do + (url, formData) <- presignedPostPolicy postPolicy + -- liftIO (print url) >> liftIO (print formData) + result <- liftIO $ postForm url formData inputFile + liftIO $ (NC.responseStatus result == HT.status200) @? + "presigned POST failed" + + mapM_ (removeObject bucket) [key] + where + + postForm url formData inputFile = do + req <- NC.parseRequest $ toS url + let parts = map (\(x, y) -> Form.partBS x y) $ + Map.toList formData + parts' = parts ++ [Form.partFile "file" inputFile] + req' <- Form.formDataBody parts' req + mgr <- NC.newManager NC.tlsManagerSettings + NC.httpLbs req' mgr