PresignedOperations.hs

--
-- 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 expiry method bucket object region extraQuery extraHeaders = do
  when (expiry > 7 * 24 * 3600 || expiry < 0) $
    throwIO $
      MErrVInvalidUrlExpiry expiry

  let s3ri =
        defaultS3ReqInfo
          { riPresignExpirySecs = Just expiry,
            riMethod = method,
            riBucket = bucket,
            riObject = object,
            riRegion = region,
            riQueryParams = extraQuery,
            riHeaders = extraHeaders
          }

  req <- buildRequest s3ri
  let uri = NClient.getUri req
      uriString = uriToString identity uri ""

  return $ encodeUtf8 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 object expirySeconds extraHeaders = do
  region <- asks (Just . connectRegion . mcConnInfo)
  makePresignedUrl
    expirySeconds
    HT.methodPut
    (Just bucket)
    (Just object)
    region
    []
    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 = do
  region <- asks (Just . connectRegion . mcConnInfo)
  makePresignedUrl
    expirySeconds
    HT.methodGet
    (Just bucket)
    (Just object)
    region
    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 = do
  region <- asks (Just . connectRegion . mcConnInfo)
  makePresignedUrl
    expirySeconds
    HT.methodHead
    (Just bucket)
    (Just object)
    region
    []
    extraHeaders

-- | Represents individual conditions in a Post Policy document.
data PostPolicyCondition
  = PPCStartsWith Text Text
  | PPCEquals Text Text
  | PPCRange Text Int64 Int64
  deriving stock (Show, Eq)

{- ORMOLU_DISABLE -}
instance Json.ToJSON PostPolicyCondition where
  toJSON (PPCStartsWith k v) = Json.toJSON ["starts-with", k, v]
#if MIN_VERSION_aeson(2,0,0)
  toJSON (PPCEquals k v) = Json.object [(A.fromText k) .= v]
#else
  toJSON (PPCEquals k v) = Json.object [k .= v]
#endif
  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]
#if MIN_VERSION_aeson(2,0,0)
  toEncoding (PPCEquals k v) = Json.pairs ((A.fromText k) .= v)
#else
  toEncoding (PPCEquals k v) = Json.pairs (k .= v)
#endif
  toEncoding (PPCRange k minVal maxVal) =
    Json.foldable [Json.toJSON k, Json.toJSON minVal, Json.toJSON maxVal]
{- ORMOLU_ENABLE -}

-- | A PostPolicy is required to perform uploads via browser forms.
data PostPolicy = PostPolicy
  { expiration :: UTCTime,
    conditions :: [PostPolicyCondition]
  }
  deriving stock (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 stock (Show, Eq)

-- | 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 = toStrictBS . 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 p = do
  ci <- asks mcConnInfo
  signTime <- liftIO Time.getCurrentTime
  mgr <- asks mcConnManager
  cv <- liftIO $ getCredential (connectCreds ci) (getEndpoint ci) mgr

  let extraConditions signParams =
        [ PPCEquals "x-amz-date" (toText $ awsTimeFormat signTime),
          PPCEquals "x-amz-algorithm" "AWS4-HMAC-SHA256",
          PPCEquals
            "x-amz-credential"
            ( T.intercalate
                "/"
                [ coerce $ cvAccessKey cv,
                  decodeUtf8 $ credentialScope signParams
                ]
            )
        ]
      ppWithCreds signParams =
        p
          { conditions = conditions p ++ extraConditions signParams
          }
      sp =
        SignParams
          (coerce $ cvAccessKey cv)
          (coerce $ cvSecretKey cv)
          (coerce $ cvSessionToken cv)
          ServiceS3
          signTime
          (Just $ connectRegion ci)
          Nothing
          Nothing
      signData = signV4PostPolicy (showPostPolicy $ ppWithCreds sp) sp
      -- compute form-data
      mkPair (PPCStartsWith k v) = Just (k, v)
      mkPair (PPCEquals k v) = Just (k, v)
      mkPair _ = Nothing
      formFromPolicy =
        H.map encodeUtf8 $
          H.fromList $
            mapMaybe
              mkPair
              (conditions $ ppWithCreds sp)
      formData = formFromPolicy `H.union` signData
      -- compute POST upload URL
      bucket = H.lookupDefault "" "bucket" formData
      scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci
      url =
        toStrictBS $
          toLazyByteString $
            scheme
              <> byteString (getHostAddr ci)
              <> byteString "/"
              <> byteString bucket
              <> byteString "/"

  return (url, formData)