Add presigned Post Policy API (#58)

- Also force tests to run in serial on travis (otherwise it times out)

.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

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

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

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

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

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)

src/Network/Minio/S3API.hs

@@ -64,33 +64,27 @@ module Network.Minio.S3API
   , deleteBucket
   , deleteObject
 
-  -- * Presigned URL Operations
+  -- * Presigned Operations
   -----------------------------
-  , UrlExpiry
+  , module Network.Minio.PresignedOperations
-  , makePresignedURL
-  , presignedPutObjectURL
-  , presignedGetObjectURL
-  , presignedHeadObjectURL
   ) 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

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

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           System.Directory                      (getTemporaryDirectory)
-import qualified System.IO as SIO
+import qualified System.IO                             as SIO
 
-import qualified Control.Monad.Catch as MC
+import qualified Control.Monad.Catch                   as MC
-import qualified Control.Monad.Trans.Resource as R
+import qualified Control.Monad.Trans.Resource          as R
-import qualified Data.ByteString as BS
+import qualified Data.ByteString                       as BS
-import qualified Data.ByteString.Lazy as LB
+import           Data.Conduit                          (yield, ($$))
-import           Data.Conduit (($$), yield)
+import qualified Data.Conduit                          as C
-import qualified Data.Conduit as C
+import qualified Data.Conduit.Binary                   as CB
-import qualified Data.Conduit.Binary as CB
+import           Data.Conduit.Combinators              (sinkList)
-import           Data.Conduit.Combinators (sinkList)
+import           Data.Default                          (Default (..))
-import           Data.Default (Default(..))
+import qualified Data.Map.Strict                       as Map
-import qualified Data.Map.Strict as Map
+import qualified Data.Text                             as T
-import qualified Data.Text as T
+import qualified Data.Time                             as Time
-import           System.Environment (lookupEnv)
+import qualified Network.HTTP.Client.MultipartFormData as Form
-import qualified Network.HTTP.Types as HT
+import qualified Network.HTTP.Conduit                  as NC
-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
+presignedURLFunTest :: TestTree
-presignedFunTest = funTestWithBucket "presigned URL tests" $
+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