--
-- MinIO Haskell SDK, (C) 2017-2023 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 CPP #-}

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 qualified Data.HashMap.Strict as H
import qualified Data.Text as T
import qualified Data.Time as Time
import Lib.Prelude
import qualified Network.HTTP.Client as NClient
import qualified Network.HTTP.Types as HT
import Network.Minio.API (buildRequest)
import Network.Minio.Credentials
import Network.Minio.Data
import Network.Minio.Data.Time
import Network.Minio.Errors
import Network.Minio.Sign.V4
import Network.URI (uriToString)

{- ORMOLU_DISABLE -}
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as A
#endif
{- ORMOLU_ENABLE -}

-- | 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 :: Int
-> ByteString
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Query
-> RequestHeaders
-> Minio ByteString
makePresignedUrl Int
expiry ByteString
method Maybe Text
bucket Maybe Text
object Maybe Text
region Query
extraQuery RequestHeaders
extraHeaders = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
expiry forall a. Ord a => a -> a -> Bool
> Int
7 forall a. Num a => a -> a -> a
* Int
24 forall a. Num a => a -> a -> a
* Int
3600 Bool -> Bool -> Bool
|| Int
expiry forall a. Ord a => a -> a -> Bool
< Int
0) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$
      Int -> MErrV
MErrVInvalidUrlExpiry Int
expiry

  let s3ri :: S3ReqInfo
s3ri =
        S3ReqInfo
defaultS3ReqInfo
          { riPresignExpirySecs :: Maybe Int
riPresignExpirySecs = forall a. a -> Maybe a
Just Int
expiry,
            riMethod :: ByteString
riMethod = ByteString
method,
            riBucket :: Maybe Text
riBucket = Maybe Text
bucket,
            riObject :: Maybe Text
riObject = Maybe Text
object,
            riRegion :: Maybe Text
riRegion = Maybe Text
region,
            riQueryParams :: Query
riQueryParams = Query
extraQuery,
            riHeaders :: RequestHeaders
riHeaders = RequestHeaders
extraHeaders
          }

  Request
req <- S3ReqInfo -> Minio Request
buildRequest S3ReqInfo
s3ri
  let uri :: URI
uri = Request -> URI
NClient.getUri Request
req
      uriString :: String
uriString = (String -> String) -> URI -> String -> String
uriToString forall a. a -> a
identity URI
uri String
""

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 String
uriString

-- | 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 :: Text -> Text -> Int -> RequestHeaders -> Minio ByteString
presignedPutObjectUrl Text
bucket Text
object Int
expirySeconds RequestHeaders
extraHeaders = do
  Maybe Text
region <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectInfo -> Text
connectRegion forall b c a. (b -> c) -> (a -> b) -> a -> c
. MinioConn -> ConnectInfo
mcConnInfo)
  Int
-> ByteString
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Query
-> RequestHeaders
-> Minio ByteString
makePresignedUrl
    Int
expirySeconds
    ByteString
HT.methodPut
    (forall a. a -> Maybe a
Just Text
bucket)
    (forall a. a -> Maybe a
Just Text
object)
    Maybe Text
region
    []
    RequestHeaders
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 :: Text -> Text -> Int -> Query -> RequestHeaders -> Minio ByteString
presignedGetObjectUrl Text
bucket Text
object Int
expirySeconds Query
extraQuery RequestHeaders
extraHeaders = do
  Maybe Text
region <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectInfo -> Text
connectRegion forall b c a. (b -> c) -> (a -> b) -> a -> c
. MinioConn -> ConnectInfo
mcConnInfo)
  Int
-> ByteString
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Query
-> RequestHeaders
-> Minio ByteString
makePresignedUrl
    Int
expirySeconds
    ByteString
HT.methodGet
    (forall a. a -> Maybe a
Just Text
bucket)
    (forall a. a -> Maybe a
Just Text
object)
    Maybe Text
region
    Query
extraQuery
    RequestHeaders
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 :: Text -> Text -> Int -> RequestHeaders -> Minio ByteString
presignedHeadObjectUrl Text
bucket Text
object Int
expirySeconds RequestHeaders
extraHeaders = do
  Maybe Text
region <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectInfo -> Text
connectRegion forall b c a. (b -> c) -> (a -> b) -> a -> c
. MinioConn -> ConnectInfo
mcConnInfo)
  Int
-> ByteString
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Query
-> RequestHeaders
-> Minio ByteString
makePresignedUrl
    Int
expirySeconds
    ByteString
HT.methodHead
    (forall a. a -> Maybe a
Just Text
bucket)
    (forall a. a -> Maybe a
Just Text
object)
    Maybe Text
region
    []
    RequestHeaders
extraHeaders

-- | Represents individual conditions in a Post Policy document.
data PostPolicyCondition
  = PPCStartsWith Text Text
  | PPCEquals Text Text
  | PPCRange Text Int64 Int64
  deriving stock (Int -> PostPolicyCondition -> String -> String
[PostPolicyCondition] -> String -> String
PostPolicyCondition -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [PostPolicyCondition] -> String -> String
$cshowList :: [PostPolicyCondition] -> String -> String
show :: PostPolicyCondition -> String
$cshow :: PostPolicyCondition -> String
showsPrec :: Int -> PostPolicyCondition -> String -> String
$cshowsPrec :: Int -> PostPolicyCondition -> String -> String
Show, PostPolicyCondition -> PostPolicyCondition -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PostPolicyCondition -> PostPolicyCondition -> Bool
$c/= :: PostPolicyCondition -> PostPolicyCondition -> Bool
== :: PostPolicyCondition -> PostPolicyCondition -> Bool
$c== :: PostPolicyCondition -> PostPolicyCondition -> Bool
Eq)

{- ORMOLU_DISABLE -}
instance Json.ToJSON PostPolicyCondition where
  toJSON :: PostPolicyCondition -> Value
toJSON (PPCStartsWith Text
k Text
v) = forall a. ToJSON a => a -> Value
Json.toJSON [Text
"starts-with", Text
k, Text
v]
#if MIN_VERSION_aeson(2,0,0)
  toJSON (PPCEquals Text
k Text
v) = [Pair] -> Value
Json.object [(Text -> Key
A.fromText Text
k) forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
v]
#else
  toJSON (PPCEquals k v) = Json.object [k .= v]
#endif
  toJSON (PPCRange Text
k Int64
minVal Int64
maxVal) =
    forall a. ToJSON a => a -> Value
Json.toJSON [forall a. ToJSON a => a -> Value
Json.toJSON Text
k, forall a. ToJSON a => a -> Value
Json.toJSON Int64
minVal, forall a. ToJSON a => a -> Value
Json.toJSON Int64
maxVal]

  toEncoding :: PostPolicyCondition -> Encoding
toEncoding (PPCStartsWith Text
k Text
v) = forall (t :: * -> *) a. (Foldable t, ToJSON a) => t a -> Encoding
Json.foldable [Text
"starts-with", Text
k, Text
v]
#if MIN_VERSION_aeson(2,0,0)
  toEncoding (PPCEquals Text
k Text
v) = Series -> Encoding
Json.pairs ((Text -> Key
A.fromText Text
k) forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
v)
#else
  toEncoding (PPCEquals k v) = Json.pairs (k .= v)
#endif
  toEncoding (PPCRange Text
k Int64
minVal Int64
maxVal) =
    forall (t :: * -> *) a. (Foldable t, ToJSON a) => t a -> Encoding
Json.foldable [forall a. ToJSON a => a -> Value
Json.toJSON Text
k, forall a. ToJSON a => a -> Value
Json.toJSON Int64
minVal, forall a. ToJSON a => a -> Value
Json.toJSON Int64
maxVal]
{- ORMOLU_ENABLE -}

-- | A PostPolicy is required to perform uploads via browser forms.
data PostPolicy = PostPolicy
  { PostPolicy -> UTCTime
expiration :: UTCTime,
    PostPolicy -> [PostPolicyCondition]
conditions :: [PostPolicyCondition]
  }
  deriving stock (Int -> PostPolicy -> String -> String
[PostPolicy] -> String -> String
PostPolicy -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [PostPolicy] -> String -> String
$cshowList :: [PostPolicy] -> String -> String
show :: PostPolicy -> String
$cshow :: PostPolicy -> String
showsPrec :: Int -> PostPolicy -> String -> String
$cshowsPrec :: Int -> PostPolicy -> String -> String
Show, PostPolicy -> PostPolicy -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PostPolicy -> PostPolicy -> Bool
$c/= :: PostPolicy -> PostPolicy -> Bool
== :: PostPolicy -> PostPolicy -> Bool
$c== :: PostPolicy -> PostPolicy -> Bool
Eq)

instance Json.ToJSON PostPolicy where
  toJSON :: PostPolicy -> Value
toJSON (PostPolicy UTCTime
e [PostPolicyCondition]
c) =
    [Pair] -> Value
Json.object
      [ Key
"expiration" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UTCTime -> String
iso8601TimeFormat UTCTime
e,
        Key
"conditions" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [PostPolicyCondition]
c
      ]
  toEncoding :: PostPolicy -> Encoding
toEncoding (PostPolicy UTCTime
e [PostPolicyCondition]
c) =
    Series -> Encoding
Json.pairs (Key
"expiration" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UTCTime -> String
iso8601TimeFormat UTCTime
e forall a. Semigroup a => a -> a -> a
<> Key
"conditions" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [PostPolicyCondition]
c)

-- | Possible validation errors when creating a PostPolicy.
data PostPolicyError
  = PPEKeyNotSpecified
  | PPEBucketNotSpecified
  | PPEConditionKeyEmpty
  | PPERangeInvalid
  deriving stock (Int -> PostPolicyError -> String -> String
[PostPolicyError] -> String -> String
PostPolicyError -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [PostPolicyError] -> String -> String
$cshowList :: [PostPolicyError] -> String -> String
show :: PostPolicyError -> String
$cshow :: PostPolicyError -> String
showsPrec :: Int -> PostPolicyError -> String -> String
$cshowsPrec :: Int -> PostPolicyError -> String -> String
Show, PostPolicyError -> PostPolicyError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PostPolicyError -> PostPolicyError -> Bool
$c/= :: PostPolicyError -> PostPolicyError -> Bool
== :: PostPolicyError -> PostPolicyError -> Bool
$c== :: PostPolicyError -> PostPolicyError -> Bool
Eq)

-- | Set the bucket name that the upload should use.
ppCondBucket :: Bucket -> PostPolicyCondition
ppCondBucket :: Text -> PostPolicyCondition
ppCondBucket = Text -> Text -> PostPolicyCondition
PPCEquals Text
"bucket"

-- | Set the content length range constraint with minimum and maximum
-- byte count values.
ppCondContentLengthRange ::
  Int64 ->
  Int64 ->
  PostPolicyCondition
ppCondContentLengthRange :: Int64 -> Int64 -> PostPolicyCondition
ppCondContentLengthRange = Text -> Int64 -> Int64 -> PostPolicyCondition
PPCRange Text
"content-length-range"

-- | Set the content-type header for the upload.
ppCondContentType :: Text -> PostPolicyCondition
ppCondContentType :: Text -> PostPolicyCondition
ppCondContentType = Text -> Text -> PostPolicyCondition
PPCEquals Text
"Content-Type"

-- | Set the object name constraint for the upload.
ppCondKey :: Object -> PostPolicyCondition
ppCondKey :: Text -> PostPolicyCondition
ppCondKey = Text -> Text -> PostPolicyCondition
PPCEquals Text
"key"

-- | Set the object name prefix constraint for the upload.
ppCondKeyStartsWith :: Object -> PostPolicyCondition
ppCondKeyStartsWith :: Text -> PostPolicyCondition
ppCondKeyStartsWith = Text -> Text -> PostPolicyCondition
PPCStartsWith Text
"key"

-- | Status code that the S3-server should send on a successful POST
-- upload
ppCondSuccessActionStatus :: Int -> PostPolicyCondition
ppCondSuccessActionStatus :: Int -> PostPolicyCondition
ppCondSuccessActionStatus Int
n =
  Text -> Text -> PostPolicyCondition
PPCEquals Text
"success_action_status" (forall b a. (Show a, IsString b) => a -> b
show Int
n)

-- | This function creates a PostPolicy after validating its
-- arguments.
newPostPolicy ::
  UTCTime ->
  [PostPolicyCondition] ->
  Either PostPolicyError PostPolicy
newPostPolicy :: UTCTime
-> [PostPolicyCondition] -> Either PostPolicyError PostPolicy
newPostPolicy UTCTime
expirationTime [PostPolicyCondition]
conds
  -- object name condition must be present
  | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> PostPolicyCondition -> Bool
keyEquals Text
"key") [PostPolicyCondition]
conds =
      forall a b. a -> Either a b
Left PostPolicyError
PPEKeyNotSpecified
  -- bucket name condition must be present
  | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> PostPolicyCondition -> Bool
keyEquals Text
"bucket") [PostPolicyCondition]
conds =
      forall a b. a -> Either a b
Left PostPolicyError
PPEBucketNotSpecified
  -- a condition with an empty key is invalid
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> PostPolicyCondition -> Bool
keyEquals Text
"") [PostPolicyCondition]
conds Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PostPolicyCondition -> Bool
isEmptyRangeKey [PostPolicyCondition]
conds =
      forall a b. a -> Either a b
Left PostPolicyError
PPEConditionKeyEmpty
  -- invalid range check
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PostPolicyCondition -> Bool
isInvalidRange [PostPolicyCondition]
conds =
      forall a b. a -> Either a b
Left PostPolicyError
PPERangeInvalid
  -- all good!
  | Bool
otherwise =
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ UTCTime -> [PostPolicyCondition] -> PostPolicy
PostPolicy UTCTime
expirationTime [PostPolicyCondition]
conds
  where
    keyEquals :: Text -> PostPolicyCondition -> Bool
keyEquals Text
k' (PPCStartsWith Text
k Text
_) = Text
k forall a. Eq a => a -> a -> Bool
== Text
k'
    keyEquals Text
k' (PPCEquals Text
k Text
_) = Text
k forall a. Eq a => a -> a -> Bool
== Text
k'
    keyEquals Text
_ PostPolicyCondition
_ = Bool
False
    isEmptyRangeKey :: PostPolicyCondition -> Bool
isEmptyRangeKey (PPCRange Text
k Int64
_ Int64
_) = Text
k forall a. Eq a => a -> a -> Bool
== Text
""
    isEmptyRangeKey PostPolicyCondition
_ = Bool
False
    isInvalidRange :: PostPolicyCondition -> Bool
isInvalidRange (PPCRange Text
_ Int64
mi Int64
ma) = Int64
mi forall a. Ord a => a -> a -> Bool
< Int64
0 Bool -> Bool -> Bool
|| Int64
mi forall a. Ord a => a -> a -> Bool
> Int64
ma
    isInvalidRange PostPolicyCondition
_ = Bool
False

-- | Convert Post Policy to a string (e.g. for printing).
showPostPolicy :: PostPolicy -> ByteString
showPostPolicy :: PostPolicy -> ByteString
showPostPolicy = LByteString -> ByteString
toStrictBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> LByteString
Json.encode

-- | Generate a presigned URL and POST policy to upload files via a
-- browser. On success, this function returns a URL and POST
-- form-data.
presignedPostPolicy ::
  PostPolicy ->
  Minio (ByteString, H.HashMap Text ByteString)
presignedPostPolicy :: PostPolicy -> Minio (ByteString, HashMap Text ByteString)
presignedPostPolicy PostPolicy
p = do
  ConnectInfo
ci <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> ConnectInfo
mcConnInfo
  UTCTime
signTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Time.getCurrentTime
  Manager
mgr <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> Manager
mcConnManager
  CredentialValue
cv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Creds -> Endpoint -> Manager -> IO CredentialValue
getCredential (ConnectInfo -> Creds
connectCreds ConnectInfo
ci) (ConnectInfo -> Endpoint
getEndpoint ConnectInfo
ci) Manager
mgr

  let extraConditions :: SignParams -> [PostPolicyCondition]
extraConditions SignParams
signParams =
        [ Text -> Text -> PostPolicyCondition
PPCEquals Text
"x-amz-date" (forall a. ToText a => a -> Text
toText forall a b. (a -> b) -> a -> b
$ UTCTime -> String
awsTimeFormat UTCTime
signTime),
          Text -> Text -> PostPolicyCondition
PPCEquals Text
"x-amz-algorithm" Text
"AWS4-HMAC-SHA256",
          Text -> Text -> PostPolicyCondition
PPCEquals
            Text
"x-amz-credential"
            ( Text -> [Text] -> Text
T.intercalate
                Text
"/"
                [ coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ CredentialValue -> AccessKey
cvAccessKey CredentialValue
cv,
                  forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 forall a b. (a -> b) -> a -> b
$ SignParams -> ByteString
credentialScope SignParams
signParams
                ]
            )
        ]
      ppWithCreds :: SignParams -> PostPolicy
ppWithCreds SignParams
signParams =
        PostPolicy
p
          { conditions :: [PostPolicyCondition]
conditions = PostPolicy -> [PostPolicyCondition]
conditions PostPolicy
p forall a. [a] -> [a] -> [a]
++ SignParams -> [PostPolicyCondition]
extraConditions SignParams
signParams
          }
      sp :: SignParams
sp =
        Text
-> ScrubbedBytes
-> Maybe ScrubbedBytes
-> Service
-> UTCTime
-> Maybe Text
-> Maybe Int
-> Maybe ByteString
-> SignParams
SignParams
          (coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ CredentialValue -> AccessKey
cvAccessKey CredentialValue
cv)
          (coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ CredentialValue -> SecretKey
cvSecretKey CredentialValue
cv)
          (coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ CredentialValue -> Maybe SessionToken
cvSessionToken CredentialValue
cv)
          Service
ServiceS3
          UTCTime
signTime
          (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Text
connectRegion ConnectInfo
ci)
          forall a. Maybe a
Nothing
          forall a. Maybe a
Nothing
      signData :: HashMap Text ByteString
signData = ByteString -> SignParams -> HashMap Text ByteString
signV4PostPolicy (PostPolicy -> ByteString
showPostPolicy forall a b. (a -> b) -> a -> b
$ SignParams -> PostPolicy
ppWithCreds SignParams
sp) SignParams
sp
      -- compute form-data
      mkPair :: PostPolicyCondition -> Maybe (Text, Text)
mkPair (PPCStartsWith Text
k Text
v) = forall a. a -> Maybe a
Just (Text
k, Text
v)
      mkPair (PPCEquals Text
k Text
v) = forall a. a -> Maybe a
Just (Text
k, Text
v)
      mkPair PostPolicyCondition
_ = forall a. Maybe a
Nothing
      formFromPolicy :: HashMap Text ByteString
formFromPolicy =
        forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
H.map forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall a b. (a -> b) -> a -> b
$
          forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList forall a b. (a -> b) -> a -> b
$
            forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
              PostPolicyCondition -> Maybe (Text, Text)
mkPair
              (PostPolicy -> [PostPolicyCondition]
conditions forall a b. (a -> b) -> a -> b
$ SignParams -> PostPolicy
ppWithCreds SignParams
sp)
      formData :: HashMap Text ByteString
formData = HashMap Text ByteString
formFromPolicy forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`H.union` HashMap Text ByteString
signData
      -- compute POST upload URL
      bucket :: ByteString
bucket = forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
H.lookupDefault ByteString
"" Text
"bucket" HashMap Text ByteString
formData
      scheme :: Builder
scheme = ByteString -> Builder
byteString forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Bool -> a
bool ByteString
"http://" ByteString
"https://" forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Bool
connectIsSecure ConnectInfo
ci
      url :: ByteString
url =
        LByteString -> ByteString
toStrictBS forall a b. (a -> b) -> a -> b
$
          Builder -> LByteString
toLazyByteString forall a b. (a -> b) -> a -> b
$
            Builder
scheme
              forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString (ConnectInfo -> ByteString
getHostAddr ConnectInfo
ci)
              forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
"/"
              forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
bucket
              forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
"/"

  forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
url, HashMap Text ByteString
formData)