{-# LANGUAGE CPP #-}

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

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

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

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

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

-- | Represents individual conditions in a Post Policy document.
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)

{- ORMOLU_DISABLE -}
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]
{- 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 (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)

-- | Possible validation errors when creating a PostPolicy.
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)

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

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

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

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

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

-- | Status code that the S3-server should send on a successful POST
-- upload
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)

-- | 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 (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
  -- bucket name condition must be present
  | 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
  -- a condition with an empty key is invalid
  | (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
  -- invalid range check
  | (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
  -- all good!
  | 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

-- | Convert Post Policy to a string (e.g. for printing).
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

-- | 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 (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
      -- compute form-data
      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
      -- compute POST upload URL
      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)