--
-- 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.Map.Strict           as Map
import qualified Data.Text                 as T
import qualified Data.Time                 as Time
import qualified Network.HTTP.Conduit      as NC
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) $
    throwIO $ MErrVInvalidUrlExpiry expiry

  ci <- asks mcConnInfo

  let
    hostHeader = (hHost, getHostAddr ci)
    req = NC.defaultRequest {
          NC.method = method
        , NC.secure = connectIsSecure ci
        , NC.host = encodeUtf8 $ connectHost ci
        , NC.port = connectPort ci
        , NC.path = getS3Path bucket object
        , NC.requestHeaders = hostHeader : extraHeaders
        , NC.queryString = HT.renderQuery True extraQuery
        }
  ts <- liftIO Time.getCurrentTime

  let sp = SignParams (connectAccessKey ci) (connectSecretKey ci)
           ts region (Just expiry) Nothing

      signPairs = signV4 sp req

      qpToAdd = (fmap . fmap) Just signPairs
      queryStr = HT.renderQueryBuilder True
                 ((HT.parseQuery $ NC.queryString req) ++ qpToAdd)
      scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci

  return $ toS $ toLazyByteString $ scheme
     <> byteString (getHostAddr ci)
     <> byteString (getS3Path bucket object)
     <> 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 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
      }
    sp = SignParams (connectAccessKey ci) (connectSecretKey ci)
         signTime (Just $ connectRegion ci) Nothing Nothing
    signData = signV4PostPolicy (showPostPolicy ppWithCreds) sp


    -- 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
    region = connectRegion ci

    url = toS $ toLazyByteString $ scheme <> byteString (getHostAddr ci) <>
          byteString "/" <> byteString (toS bucket) <> byteString "/"

  return (url, formData)