haskell/minio-hs
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add presigned Post Policy API (#58)

Browse Source 
- Also force tests to run in serial on travis (otherwise it times out)
This commit is contained in:
Aditya Manthramurthy 2017-09-26 21:32:39 +05:30 committed by Krishnan Parthasarathi
parent 02170778da
commit d3353bb35a
9 changed files with 487 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.travis.yml
View File

@ -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

84
examples/PresignedPostPolicy.hs Executable file
View File

@ -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

12
minio-hs.cabal
View File

@ -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

14
src/Network/Minio.hs
View File

@ -81,6 +81,20 @@ module Network.Minio
, presignedPutObjectURL
, presignedGetObjectURL
, presignedHeadObjectURL
, PostPolicyCondition
, ppCondBucket
, ppCondContentLengthRange
, ppCondContentType
, ppCondKey
, ppCondKeyStartsWith
, ppCondSuccessActionStatus
, PostPolicy
, PostPolicyError(..)
, newPostPolicy
, presignedPostPolicy
, showPostPolicy
) where
{-

4
src/Network/Minio/Data/Time.hs
View File

@ -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")

281
src/Network/Minio/PresignedOperations.hs Normal file
View File

@ -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)

92
src/Network/Minio/S3API.hs
View File

@ -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

19
src/Network/Minio/Sign/V4.hs
View File

@ -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)
]

93
test/LiveServer.hs
View File

@ -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