{-# 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.Data
import Network.Minio.Data.Time
import Network.Minio.Errors
import Network.Minio.Sign.V4
import Network.URI (uriToString)
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as A
#endif
makePresignedUrl ::
UrlExpiry ->
HT.Method ->
Maybe Bucket ->
Maybe Object ->
Maybe Region ->
HT.Query ->
HT.RequestHeaders ->
Minio ByteString
makePresignedUrl :: UrlExpiry
-> Method
-> Maybe Bucket
-> Maybe Bucket
-> Maybe Bucket
-> Query
-> RequestHeaders
-> Minio Method
makePresignedUrl UrlExpiry
expiry Method
method Maybe Bucket
bucket Maybe Bucket
object Maybe Bucket
region Query
extraQuery RequestHeaders
extraHeaders = do
Bool -> Minio () -> Minio ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UrlExpiry
expiry UrlExpiry -> UrlExpiry -> Bool
forall a. Ord a => a -> a -> Bool
> UrlExpiry
7 UrlExpiry -> UrlExpiry -> UrlExpiry
forall a. Num a => a -> a -> a
* UrlExpiry
24 UrlExpiry -> UrlExpiry -> UrlExpiry
forall a. Num a => a -> a -> a
* UrlExpiry
3600 Bool -> Bool -> Bool
|| UrlExpiry
expiry UrlExpiry -> UrlExpiry -> Bool
forall a. Ord a => a -> a -> Bool
< UrlExpiry
0) (Minio () -> Minio ()) -> Minio () -> Minio ()
forall a b. (a -> b) -> a -> b
$
MErrV -> Minio ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (MErrV -> Minio ()) -> MErrV -> Minio ()
forall a b. (a -> b) -> a -> b
$
UrlExpiry -> MErrV
MErrVInvalidUrlExpiry UrlExpiry
expiry
let s3ri :: S3ReqInfo
s3ri =
S3ReqInfo
defaultS3ReqInfo
{ riPresignExpirySecs :: Maybe UrlExpiry
riPresignExpirySecs = UrlExpiry -> Maybe UrlExpiry
forall a. a -> Maybe a
Just UrlExpiry
expiry,
riMethod :: Method
riMethod = Method
method,
riBucket :: Maybe Bucket
riBucket = Maybe Bucket
bucket,
riObject :: Maybe Bucket
riObject = Maybe Bucket
object,
riRegion :: Maybe Bucket
riRegion = Maybe Bucket
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 String -> String
forall a. a -> a
identity URI
uri String
""
Method -> Minio Method
forall (m :: * -> *) a. Monad m => a -> m a
return (Method -> Minio Method) -> Method -> Minio Method
forall a b. (a -> b) -> a -> b
$ String -> Method
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 String
uriString
presignedPutObjectUrl ::
Bucket ->
Object ->
UrlExpiry ->
HT.RequestHeaders ->
Minio ByteString
presignedPutObjectUrl :: Bucket -> Bucket -> UrlExpiry -> RequestHeaders -> Minio Method
presignedPutObjectUrl Bucket
bucket Bucket
object UrlExpiry
expirySeconds RequestHeaders
extraHeaders = do
Maybe Bucket
region <- (MinioConn -> Maybe Bucket) -> Minio (Maybe Bucket)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just (Bucket -> Maybe Bucket)
-> (MinioConn -> Bucket) -> MinioConn -> Maybe Bucket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectInfo -> Bucket
connectRegion (ConnectInfo -> Bucket)
-> (MinioConn -> ConnectInfo) -> MinioConn -> Bucket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MinioConn -> ConnectInfo
mcConnInfo)
UrlExpiry
-> Method
-> Maybe Bucket
-> Maybe Bucket
-> Maybe Bucket
-> Query
-> RequestHeaders
-> Minio Method
makePresignedUrl
UrlExpiry
expirySeconds
Method
HT.methodPut
(Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just Bucket
bucket)
(Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just Bucket
object)
Maybe Bucket
region
[]
RequestHeaders
extraHeaders
presignedGetObjectUrl ::
Bucket ->
Object ->
UrlExpiry ->
HT.Query ->
HT.RequestHeaders ->
Minio ByteString
presignedGetObjectUrl :: Bucket
-> Bucket -> UrlExpiry -> Query -> RequestHeaders -> Minio Method
presignedGetObjectUrl Bucket
bucket Bucket
object UrlExpiry
expirySeconds Query
extraQuery RequestHeaders
extraHeaders = do
Maybe Bucket
region <- (MinioConn -> Maybe Bucket) -> Minio (Maybe Bucket)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just (Bucket -> Maybe Bucket)
-> (MinioConn -> Bucket) -> MinioConn -> Maybe Bucket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectInfo -> Bucket
connectRegion (ConnectInfo -> Bucket)
-> (MinioConn -> ConnectInfo) -> MinioConn -> Bucket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MinioConn -> ConnectInfo
mcConnInfo)
UrlExpiry
-> Method
-> Maybe Bucket
-> Maybe Bucket
-> Maybe Bucket
-> Query
-> RequestHeaders
-> Minio Method
makePresignedUrl
UrlExpiry
expirySeconds
Method
HT.methodGet
(Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just Bucket
bucket)
(Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just Bucket
object)
Maybe Bucket
region
Query
extraQuery
RequestHeaders
extraHeaders
presignedHeadObjectUrl ::
Bucket ->
Object ->
UrlExpiry ->
HT.RequestHeaders ->
Minio ByteString
presignedHeadObjectUrl :: Bucket -> Bucket -> UrlExpiry -> RequestHeaders -> Minio Method
presignedHeadObjectUrl Bucket
bucket Bucket
object UrlExpiry
expirySeconds RequestHeaders
extraHeaders = do
Maybe Bucket
region <- (MinioConn -> Maybe Bucket) -> Minio (Maybe Bucket)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just (Bucket -> Maybe Bucket)
-> (MinioConn -> Bucket) -> MinioConn -> Maybe Bucket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectInfo -> Bucket
connectRegion (ConnectInfo -> Bucket)
-> (MinioConn -> ConnectInfo) -> MinioConn -> Bucket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MinioConn -> ConnectInfo
mcConnInfo)
UrlExpiry
-> Method
-> Maybe Bucket
-> Maybe Bucket
-> Maybe Bucket
-> Query
-> RequestHeaders
-> Minio Method
makePresignedUrl
UrlExpiry
expirySeconds
Method
HT.methodHead
(Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just Bucket
bucket)
(Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just Bucket
object)
Maybe Bucket
region
[]
RequestHeaders
extraHeaders
data PostPolicyCondition
= PPCStartsWith Text Text
| PPCEquals Text Text
| PPCRange Text Int64 Int64
deriving stock (UrlExpiry -> PostPolicyCondition -> String -> String
[PostPolicyCondition] -> String -> String
PostPolicyCondition -> String
(UrlExpiry -> PostPolicyCondition -> String -> String)
-> (PostPolicyCondition -> String)
-> ([PostPolicyCondition] -> String -> String)
-> Show PostPolicyCondition
forall a.
(UrlExpiry -> 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 :: UrlExpiry -> PostPolicyCondition -> String -> String
$cshowsPrec :: UrlExpiry -> PostPolicyCondition -> String -> String
Show, PostPolicyCondition -> PostPolicyCondition -> Bool
(PostPolicyCondition -> PostPolicyCondition -> Bool)
-> (PostPolicyCondition -> PostPolicyCondition -> Bool)
-> Eq PostPolicyCondition
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)
instance Json.ToJSON PostPolicyCondition where
toJSON :: PostPolicyCondition -> Value
toJSON (PPCStartsWith Bucket
k Bucket
v) = [Bucket] -> Value
forall a. ToJSON a => a -> Value
Json.toJSON [Bucket
"starts-with", Bucket
k, Bucket
v]
#if MIN_VERSION_aeson(2,0,0)
toJSON (PPCEquals Bucket
k Bucket
v) = [Pair] -> Value
Json.object [(Bucket -> Key
A.fromText Bucket
k) Key -> Bucket -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bucket
v]
#else
toJSON (PPCEquals k v) = Json.object [k .= v]
#endif
toJSON (PPCRange Bucket
k Int64
minVal Int64
maxVal) =
[Value] -> Value
forall a. ToJSON a => a -> Value
Json.toJSON [Bucket -> Value
forall a. ToJSON a => a -> Value
Json.toJSON Bucket
k, Int64 -> Value
forall a. ToJSON a => a -> Value
Json.toJSON Int64
minVal, Int64 -> Value
forall a. ToJSON a => a -> Value
Json.toJSON Int64
maxVal]
toEncoding :: PostPolicyCondition -> Encoding
toEncoding (PPCStartsWith Bucket
k Bucket
v) = [Bucket] -> Encoding
forall (t :: * -> *) a. (Foldable t, ToJSON a) => t a -> Encoding
Json.foldable [Bucket
"starts-with", Bucket
k, Bucket
v]
#if MIN_VERSION_aeson(2,0,0)
toEncoding (PPCEquals Bucket
k Bucket
v) = Series -> Encoding
Json.pairs ((Bucket -> Key
A.fromText Bucket
k) Key -> Bucket -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bucket
v)
#else
toEncoding (PPCEquals k v) = Json.pairs (k .= v)
#endif
toEncoding (PPCRange Bucket
k Int64
minVal Int64
maxVal) =
[Value] -> Encoding
forall (t :: * -> *) a. (Foldable t, ToJSON a) => t a -> Encoding
Json.foldable [Bucket -> Value
forall a. ToJSON a => a -> Value
Json.toJSON Bucket
k, Int64 -> Value
forall a. ToJSON a => a -> Value
Json.toJSON Int64
minVal, Int64 -> Value
forall a. ToJSON a => a -> Value
Json.toJSON Int64
maxVal]
data PostPolicy = PostPolicy
{ PostPolicy -> UTCTime
expiration :: UTCTime,
PostPolicy -> [PostPolicyCondition]
conditions :: [PostPolicyCondition]
}
deriving stock (UrlExpiry -> PostPolicy -> String -> String
[PostPolicy] -> String -> String
PostPolicy -> String
(UrlExpiry -> PostPolicy -> String -> String)
-> (PostPolicy -> String)
-> ([PostPolicy] -> String -> String)
-> Show PostPolicy
forall a.
(UrlExpiry -> 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 :: UrlExpiry -> PostPolicy -> String -> String
$cshowsPrec :: UrlExpiry -> PostPolicy -> String -> String
Show, PostPolicy -> PostPolicy -> Bool
(PostPolicy -> PostPolicy -> Bool)
-> (PostPolicy -> PostPolicy -> Bool) -> Eq PostPolicy
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" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UTCTime -> String
iso8601TimeFormat UTCTime
e,
Key
"conditions" Key -> [PostPolicyCondition] -> Pair
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" Key -> String -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UTCTime -> String
iso8601TimeFormat UTCTime
e Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"conditions" Key -> [PostPolicyCondition] -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [PostPolicyCondition]
c)
data PostPolicyError
= PPEKeyNotSpecified
| PPEBucketNotSpecified
| PPEConditionKeyEmpty
| PPERangeInvalid
deriving stock (UrlExpiry -> PostPolicyError -> String -> String
[PostPolicyError] -> String -> String
PostPolicyError -> String
(UrlExpiry -> PostPolicyError -> String -> String)
-> (PostPolicyError -> String)
-> ([PostPolicyError] -> String -> String)
-> Show PostPolicyError
forall a.
(UrlExpiry -> 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 :: UrlExpiry -> PostPolicyError -> String -> String
$cshowsPrec :: UrlExpiry -> PostPolicyError -> String -> String
Show, PostPolicyError -> PostPolicyError -> Bool
(PostPolicyError -> PostPolicyError -> Bool)
-> (PostPolicyError -> PostPolicyError -> Bool)
-> Eq PostPolicyError
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)
ppCondBucket :: Bucket -> PostPolicyCondition
ppCondBucket :: Bucket -> PostPolicyCondition
ppCondBucket = Bucket -> Bucket -> PostPolicyCondition
PPCEquals Bucket
"bucket"
ppCondContentLengthRange ::
Int64 ->
Int64 ->
PostPolicyCondition
ppCondContentLengthRange :: Int64 -> Int64 -> PostPolicyCondition
ppCondContentLengthRange = Bucket -> Int64 -> Int64 -> PostPolicyCondition
PPCRange Bucket
"content-length-range"
ppCondContentType :: Text -> PostPolicyCondition
ppCondContentType :: Bucket -> PostPolicyCondition
ppCondContentType = Bucket -> Bucket -> PostPolicyCondition
PPCEquals Bucket
"Content-Type"
ppCondKey :: Object -> PostPolicyCondition
ppCondKey :: Bucket -> PostPolicyCondition
ppCondKey = Bucket -> Bucket -> PostPolicyCondition
PPCEquals Bucket
"key"
ppCondKeyStartsWith :: Object -> PostPolicyCondition
ppCondKeyStartsWith :: Bucket -> PostPolicyCondition
ppCondKeyStartsWith = Bucket -> Bucket -> PostPolicyCondition
PPCStartsWith Bucket
"key"
ppCondSuccessActionStatus :: Int -> PostPolicyCondition
ppCondSuccessActionStatus :: UrlExpiry -> PostPolicyCondition
ppCondSuccessActionStatus UrlExpiry
n =
Bucket -> Bucket -> PostPolicyCondition
PPCEquals Bucket
"success_action_status" (UrlExpiry -> Bucket
forall b a. (Show a, IsString b) => a -> b
show UrlExpiry
n)
newPostPolicy ::
UTCTime ->
[PostPolicyCondition] ->
Either PostPolicyError PostPolicy
newPostPolicy :: UTCTime
-> [PostPolicyCondition] -> Either PostPolicyError PostPolicy
newPostPolicy UTCTime
expirationTime [PostPolicyCondition]
conds
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (PostPolicyCondition -> Bool) -> [PostPolicyCondition] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bucket -> PostPolicyCondition -> Bool
keyEquals Bucket
"key") [PostPolicyCondition]
conds =
PostPolicyError -> Either PostPolicyError PostPolicy
forall a b. a -> Either a b
Left PostPolicyError
PPEKeyNotSpecified
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (PostPolicyCondition -> Bool) -> [PostPolicyCondition] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bucket -> PostPolicyCondition -> Bool
keyEquals Bucket
"bucket") [PostPolicyCondition]
conds =
PostPolicyError -> Either PostPolicyError PostPolicy
forall a b. a -> Either a b
Left PostPolicyError
PPEBucketNotSpecified
| (PostPolicyCondition -> Bool) -> [PostPolicyCondition] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bucket -> PostPolicyCondition -> Bool
keyEquals Bucket
"") [PostPolicyCondition]
conds Bool -> Bool -> Bool
|| (PostPolicyCondition -> Bool) -> [PostPolicyCondition] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PostPolicyCondition -> Bool
isEmptyRangeKey [PostPolicyCondition]
conds =
PostPolicyError -> Either PostPolicyError PostPolicy
forall a b. a -> Either a b
Left PostPolicyError
PPEConditionKeyEmpty
| (PostPolicyCondition -> Bool) -> [PostPolicyCondition] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PostPolicyCondition -> Bool
isInvalidRange [PostPolicyCondition]
conds =
PostPolicyError -> Either PostPolicyError PostPolicy
forall a b. a -> Either a b
Left PostPolicyError
PPERangeInvalid
| Bool
otherwise =
PostPolicy -> Either PostPolicyError PostPolicy
forall (m :: * -> *) a. Monad m => a -> m a
return (PostPolicy -> Either PostPolicyError PostPolicy)
-> PostPolicy -> Either PostPolicyError PostPolicy
forall a b. (a -> b) -> a -> b
$ UTCTime -> [PostPolicyCondition] -> PostPolicy
PostPolicy UTCTime
expirationTime [PostPolicyCondition]
conds
where
keyEquals :: Bucket -> PostPolicyCondition -> Bool
keyEquals Bucket
k' (PPCStartsWith Bucket
k Bucket
_) = Bucket
k Bucket -> Bucket -> Bool
forall a. Eq a => a -> a -> Bool
== Bucket
k'
keyEquals Bucket
k' (PPCEquals Bucket
k Bucket
_) = Bucket
k Bucket -> Bucket -> Bool
forall a. Eq a => a -> a -> Bool
== Bucket
k'
keyEquals Bucket
_ PostPolicyCondition
_ = Bool
False
isEmptyRangeKey :: PostPolicyCondition -> Bool
isEmptyRangeKey (PPCRange Bucket
k Int64
_ Int64
_) = Bucket
k Bucket -> Bucket -> Bool
forall a. Eq a => a -> a -> Bool
== Bucket
""
isEmptyRangeKey PostPolicyCondition
_ = Bool
False
isInvalidRange :: PostPolicyCondition -> Bool
isInvalidRange (PPCRange Bucket
_ Int64
mi Int64
ma) = Int64
mi Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
0 Bool -> Bool -> Bool
|| Int64
mi Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
ma
isInvalidRange PostPolicyCondition
_ = Bool
False
showPostPolicy :: PostPolicy -> ByteString
showPostPolicy :: PostPolicy -> Method
showPostPolicy = LByteString -> Method
toStrictBS (LByteString -> Method)
-> (PostPolicy -> LByteString) -> PostPolicy -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PostPolicy -> LByteString
forall a. ToJSON a => a -> LByteString
Json.encode
presignedPostPolicy ::
PostPolicy ->
Minio (ByteString, H.HashMap Text ByteString)
presignedPostPolicy :: PostPolicy -> Minio (Method, HashMap Bucket Method)
presignedPostPolicy PostPolicy
p = do
ConnectInfo
ci <- (MinioConn -> ConnectInfo) -> Minio ConnectInfo
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> ConnectInfo
mcConnInfo
UTCTime
signTime <- IO UTCTime -> Minio UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Time.getCurrentTime
let extraConditions :: [PostPolicyCondition]
extraConditions =
[ Bucket -> Bucket -> PostPolicyCondition
PPCEquals Bucket
"x-amz-date" (String -> Bucket
forall a. ToText a => a -> Bucket
toText (String -> Bucket) -> String -> Bucket
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
awsTimeFormat UTCTime
signTime),
Bucket -> Bucket -> PostPolicyCondition
PPCEquals Bucket
"x-amz-algorithm" Bucket
"AWS4-HMAC-SHA256",
Bucket -> Bucket -> PostPolicyCondition
PPCEquals
Bucket
"x-amz-credential"
( Bucket -> [Bucket] -> Bucket
T.intercalate
Bucket
"/"
[ ConnectInfo -> Bucket
connectAccessKey ConnectInfo
ci,
Method -> Bucket
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Method -> Bucket) -> Method -> Bucket
forall a b. (a -> b) -> a -> b
$ UTCTime -> Bucket -> Method
mkScope UTCTime
signTime Bucket
region
]
)
]
ppWithCreds :: PostPolicy
ppWithCreds =
PostPolicy
p
{ conditions :: [PostPolicyCondition]
conditions = PostPolicy -> [PostPolicyCondition]
conditions PostPolicy
p [PostPolicyCondition]
-> [PostPolicyCondition] -> [PostPolicyCondition]
forall a. [a] -> [a] -> [a]
++ [PostPolicyCondition]
extraConditions
}
sp :: SignParams
sp =
Bucket
-> Bucket
-> UTCTime
-> Maybe Bucket
-> Maybe UrlExpiry
-> Maybe Method
-> SignParams
SignParams
(ConnectInfo -> Bucket
connectAccessKey ConnectInfo
ci)
(ConnectInfo -> Bucket
connectSecretKey ConnectInfo
ci)
UTCTime
signTime
(Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just (Bucket -> Maybe Bucket) -> Bucket -> Maybe Bucket
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Bucket
connectRegion ConnectInfo
ci)
Maybe UrlExpiry
forall a. Maybe a
Nothing
Maybe Method
forall a. Maybe a
Nothing
signData :: HashMap Bucket Method
signData = Method -> SignParams -> HashMap Bucket Method
signV4PostPolicy (PostPolicy -> Method
showPostPolicy PostPolicy
ppWithCreds) SignParams
sp
mkPair :: PostPolicyCondition -> Maybe (Bucket, Bucket)
mkPair (PPCStartsWith Bucket
k Bucket
v) = (Bucket, Bucket) -> Maybe (Bucket, Bucket)
forall a. a -> Maybe a
Just (Bucket
k, Bucket
v)
mkPair (PPCEquals Bucket
k Bucket
v) = (Bucket, Bucket) -> Maybe (Bucket, Bucket)
forall a. a -> Maybe a
Just (Bucket
k, Bucket
v)
mkPair PostPolicyCondition
_ = Maybe (Bucket, Bucket)
forall a. Maybe a
Nothing
formFromPolicy :: HashMap Bucket Method
formFromPolicy =
(Bucket -> Method)
-> HashMap Bucket Bucket -> HashMap Bucket Method
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
H.map Bucket -> Method
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (HashMap Bucket Bucket -> HashMap Bucket Method)
-> HashMap Bucket Bucket -> HashMap Bucket Method
forall a b. (a -> b) -> a -> b
$
[(Bucket, Bucket)] -> HashMap Bucket Bucket
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList ([(Bucket, Bucket)] -> HashMap Bucket Bucket)
-> [(Bucket, Bucket)] -> HashMap Bucket Bucket
forall a b. (a -> b) -> a -> b
$
(PostPolicyCondition -> Maybe (Bucket, Bucket))
-> [PostPolicyCondition] -> [(Bucket, Bucket)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
PostPolicyCondition -> Maybe (Bucket, Bucket)
mkPair
(PostPolicy -> [PostPolicyCondition]
conditions PostPolicy
ppWithCreds)
formData :: HashMap Bucket Method
formData = HashMap Bucket Method
formFromPolicy HashMap Bucket Method
-> HashMap Bucket Method -> HashMap Bucket Method
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`H.union` HashMap Bucket Method
signData
bucket :: Method
bucket = Method -> Bucket -> HashMap Bucket Method -> Method
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
H.lookupDefault Method
"" Bucket
"bucket" HashMap Bucket Method
formData
scheme :: Builder
scheme = Method -> Builder
byteString (Method -> Builder) -> Method -> Builder
forall a b. (a -> b) -> a -> b
$ Method -> Method -> Bool -> Method
forall a. a -> a -> Bool -> a
bool Method
"http://" Method
"https://" (Bool -> Method) -> Bool -> Method
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Bool
connectIsSecure ConnectInfo
ci
region :: Bucket
region = ConnectInfo -> Bucket
connectRegion ConnectInfo
ci
url :: Method
url =
LByteString -> Method
toStrictBS (LByteString -> Method) -> LByteString -> Method
forall a b. (a -> b) -> a -> b
$
Builder -> LByteString
toLazyByteString (Builder -> LByteString) -> Builder -> LByteString
forall a b. (a -> b) -> a -> b
$
Builder
scheme
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Method -> Builder
byteString (ConnectInfo -> Method
getHostAddr ConnectInfo
ci)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Method -> Builder
byteString Method
"/"
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Method -> Builder
byteString Method
bucket
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Method -> Builder
byteString Method
"/"
(Method, HashMap Bucket Method)
-> Minio (Method, HashMap Bucket Method)
forall (m :: * -> *) a. Monad m => a -> m a
return (Method
url, HashMap Bucket Method
formData)