content: --
  -- 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 BangPatterns #-}
  
  module Network.Minio.Sign.V4
    ( SignParams (..),
      signV4QueryParams,
      signV4,
      signV4PostPolicy,
      signV4Stream,
      Service (..),
      credentialScope,
    )
  where
  
  import qualified Conduit as C
  import qualified Data.ByteArray as BA
  import qualified Data.ByteString as B
  import qualified Data.ByteString.Base64 as Base64
  import qualified Data.ByteString.Char8 as B8
  import qualified Data.ByteString.Lazy as LB
  import Data.CaseInsensitive (mk)
  import qualified Data.CaseInsensitive as CI
  import qualified Data.HashMap.Strict as Map
  import qualified Data.HashSet as Set
  import Data.List (partition)
  import qualified Data.List.NonEmpty as NE
  import qualified Data.Time as Time
  import Lib.Prelude
  import qualified Network.HTTP.Conduit as NC
  import Network.HTTP.Types (Header, SimpleQuery, hContentEncoding, parseQuery)
  import qualified Network.HTTP.Types as H
  import Network.HTTP.Types.Header (RequestHeaders)
  import Network.Minio.Data.ByteString
  import Network.Minio.Data.Crypto
  import Network.Minio.Data.Time
  import Network.Minio.Errors
  import Text.Printf (printf)
  
  -- these headers are not included in the string to sign when signing a
  -- request
  ignoredHeaders :: Set.HashSet ByteString
  ignoredHeaders =
    Set.fromList $
      map
        CI.foldedCase
        [ H.hAuthorization,
          H.hContentType,
          H.hUserAgent
        ]
  
  data Service = ServiceS3 | ServiceSTS
    deriving stock (Eq, Show)
  
  toByteString :: Service -> ByteString
  toByteString ServiceS3 = "s3"
  toByteString ServiceSTS = "sts"
  
  data SignParams = SignParams
    { spAccessKey :: Text,
      spSecretKey :: BA.ScrubbedBytes,
      spSessionToken :: Maybe BA.ScrubbedBytes,
      spService :: Service,
      spTimeStamp :: UTCTime,
      spRegion :: Maybe Text,
      spExpirySecs :: Maybe UrlExpiry,
      spPayloadHash :: Maybe ByteString
    }
    deriving stock (Show)
  
  mkAuthHeader :: Text -> ByteString -> ByteString -> ByteString -> H.Header
  mkAuthHeader accessKey scope signedHeaderKeys sign =
    let authValue =
          B.concat
            [ "AWS4-HMAC-SHA256 Credential=",
              encodeUtf8 accessKey,
              "/",
              scope,
              ", SignedHeaders=",
              signedHeaderKeys,
              ", Signature=",
              sign
            ]
     in (H.hAuthorization, authValue)
  
  data IsStreaming = IsStreamingLength Int64 | NotStreaming
    deriving stock (Eq, Show)
  
  amzSecurityToken :: ByteString
  amzSecurityToken = "X-Amz-Security-Token"
  
  -- | Given SignParams and request details, including request method,
  -- request path, headers, query params and payload hash, generates an
  -- updated set of headers, including the x-amz-date header and the
  -- Authorization header, which includes the signature.
  --
  -- For normal requests (i.e. without an expiry time), the output is
  -- the list of headers to add to authenticate the request.
  --
  -- If `expiry` is not Nothing, it is assumed that a presigned request
  -- is being created. The expiry is interpreted as an integer number of
  -- seconds. The output will be the list of query-parameters to add to
  -- the request.
  signV4QueryParams :: SignParams -> NC.Request -> SimpleQuery
  signV4QueryParams !sp !req =
    let scope = credentialScope sp
        expiry = spExpirySecs sp
  
        headersToSign = getHeadersToSign $ NC.requestHeaders req
        signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign
        -- query-parameters to be added before signing for presigned URLs
        -- (i.e. when `isJust expiry`)
        authQP =
          [ ("X-Amz-Algorithm", "AWS4-HMAC-SHA256"),
            ("X-Amz-Credential", B.concat [encodeUtf8 $ spAccessKey sp, "/", scope]),
            ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp),
            ("X-Amz-Expires", maybe "" showBS expiry),
            ("X-Amz-SignedHeaders", signedHeaderKeys)
          ]
            ++ maybeToList ((amzSecurityToken,) . BA.convert <$> spSessionToken sp)
        finalQP =
          parseQuery (NC.queryString req)
            ++ if isJust expiry
              then (fmap . fmap) Just authQP
              else []
        -- 1. compute canonical request
        canonicalRequest =
          mkCanonicalRequest
            False
            sp
            (NC.setQueryString finalQP req)
            headersToSign
  
        -- 2. compute string to sign
        stringToSign = mkStringToSign (spTimeStamp sp) scope canonicalRequest
        -- 3.1 compute signing key
        signingKey = getSigningKey sp
        -- 3.2 compute signature
        signature = computeSignature stringToSign signingKey
     in ("X-Amz-Signature", signature) : authQP
  
  -- | Given SignParams and request details, including request method, request
  -- path, headers, query params and payload hash, generates an updated set of
  -- headers, including the x-amz-date header and the Authorization header, which
  -- includes the signature.
  --
  -- The output is the list of headers to be added to authenticate the request.
  signV4 :: SignParams -> NC.Request -> [Header]
  signV4 !sp !req =
    let scope = credentialScope sp
  
        -- extra headers to be added for signing purposes.
        extraHeaders =
          ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp)
            : ( -- payload hash is only used for S3 (not STS)
                [ ( "x-amz-content-sha256",
                    fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp
                  )
                  | spService sp == ServiceS3
                ]
              )
            ++ maybeToList ((mk amzSecurityToken,) . BA.convert <$> spSessionToken sp)
  
        -- 1. compute canonical request
        reqHeaders = NC.requestHeaders req ++ extraHeaders
        (canonicalRequest, signedHeaderKeys) =
          getCanonicalRequestAndSignedHeaders
            NotStreaming
            sp
            req
            reqHeaders
  
        -- 2. compute string to sign
        stringToSign = mkStringToSign (spTimeStamp sp) scope canonicalRequest
        -- 3.1 compute signing key
        signingKey = getSigningKey sp
        -- 3.2 compute signature
        signature = computeSignature stringToSign signingKey
        -- 4. compute auth header
        authHeader = mkAuthHeader (spAccessKey sp) scope signedHeaderKeys signature
     in authHeader : extraHeaders
  
  credentialScope :: SignParams -> ByteString
  credentialScope sp =
    let region = fromMaybe "" $ spRegion sp
     in B.intercalate
          "/"
          [ encodeUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" $ spTimeStamp sp,
            encodeUtf8 region,
            toByteString $ spService sp,
            "aws4_request"
          ]
  
  -- Folds header name, trims whitespace in header values, skips ignored headers
  -- and sorts headers.
  getHeadersToSign :: [Header] -> [(ByteString, ByteString)]
  getHeadersToSign !h =
    filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $
      map (bimap CI.foldedCase stripBS) h
  
  -- | Given the list of headers in the request, computes the canonical headers
  -- and the signed headers strings.
  getCanonicalHeaders :: NonEmpty Header -> (ByteString, ByteString)
  getCanonicalHeaders h =
    let -- Folds header name, trims spaces in header values, skips ignored
        -- headers and sorts headers by name (we must not re-order multi-valued
        -- headers).
        headersToSign =
          NE.toList $
            NE.sortBy (\a b -> compare (fst a) (fst b)) $
              NE.fromList $
                NE.filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $
                  NE.map (bimap CI.foldedCase stripBS) h
  
        canonicalHeaders = mconcat $ map (\(a, b) -> a <> ":" <> b <> "\n") headersToSign
        signedHeaderKeys = B.intercalate ";" $ map fst headersToSign
     in (canonicalHeaders, signedHeaderKeys)
  
  getCanonicalRequestAndSignedHeaders ::
    IsStreaming ->
    SignParams ->
    NC.Request ->
    [Header] ->
    (ByteString, ByteString)
  getCanonicalRequestAndSignedHeaders isStreaming sp req requestHeaders =
    let httpMethod = NC.method req
  
        canonicalUri = uriEncode False $ NC.path req
  
        canonicalQueryString =
          B.intercalate "&" $
            map (\(x, y) -> B.concat [x, "=", y]) $
              sort $
                map
                  ( bimap (uriEncode True) (maybe "" (uriEncode True))
                  )
                  (parseQuery $ NC.queryString req)
  
        (canonicalHeaders, signedHeaderKeys) = getCanonicalHeaders $ NE.fromList requestHeaders
        payloadHashStr =
          case isStreaming of
            IsStreamingLength _ -> "STREAMING-AWS4-HMAC-SHA256-PAYLOAD"
            NotStreaming -> fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp
  
        canonicalRequest =
          B.intercalate
            "\n"
            [ httpMethod,
              canonicalUri,
              canonicalQueryString,
              canonicalHeaders,
              signedHeaderKeys,
              payloadHashStr
            ]
     in (canonicalRequest, signedHeaderKeys)
  
  mkCanonicalRequest ::
    Bool ->
    SignParams ->
    NC.Request ->
    [(ByteString, ByteString)] ->
    ByteString
  mkCanonicalRequest !isStreaming !sp !req !headersForSign =
    let httpMethod = NC.method req
        canonicalUri = uriEncode False $ NC.path req
        canonicalQueryString =
          B.intercalate "&" $
            map (\(x, y) -> B.concat [x, "=", y]) $
              sortBy (\a b -> compare (fst a) (fst b)) $
                map
                  ( bimap (uriEncode True) (maybe "" (uriEncode True))
                  )
                  (parseQuery $ NC.queryString req)
        sortedHeaders = sort headersForSign
        canonicalHeaders =
          B.concat $
            map (\(x, y) -> B.concat [x, ":", y, "\n"]) sortedHeaders
        signedHeaders = B.intercalate ";" $ map fst sortedHeaders
        payloadHashStr =
          if isStreaming
            then "STREAMING-AWS4-HMAC-SHA256-PAYLOAD"
            else fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp
     in B.intercalate
          "\n"
          [ httpMethod,
            canonicalUri,
            canonicalQueryString,
            canonicalHeaders,
            signedHeaders,
            payloadHashStr
          ]
  
  mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString
  mkStringToSign ts !scope !canonicalRequest =
    B.intercalate
      "\n"
      [ "AWS4-HMAC-SHA256",
        awsTimeFormatBS ts,
        scope,
        hashSHA256 canonicalRequest
      ]
  
  getSigningKey :: SignParams -> ByteString
  getSigningKey sp =
    hmacSHA256RawBS "aws4_request"
      . hmacSHA256RawBS (toByteString $ spService sp)
      . hmacSHA256RawBS (encodeUtf8 $ fromMaybe "" $ spRegion sp)
      . hmacSHA256RawBS (awsDateFormatBS $ spTimeStamp sp)
      $ B.concat ["AWS4", BA.convert $ spSecretKey sp]
  
  computeSignature :: ByteString -> ByteString -> ByteString
  computeSignature !toSign !key = digestToBase16 $ hmacSHA256 toSign key
  
  -- | Takes a validated Post Policy JSON bytestring, the signing time,
  -- and ConnInfo and returns form-data for the POST upload containing
  -- just the signature and the encoded post-policy.
  signV4PostPolicy ::
    ByteString ->
    SignParams ->
    Map.HashMap Text ByteString
  signV4PostPolicy !postPolicyJSON !sp =
    let stringToSign = Base64.encode postPolicyJSON
        signingKey = getSigningKey sp
        signature = computeSignature stringToSign signingKey
     in Map.fromList $
          [ ("x-amz-signature", signature),
            ("policy", stringToSign)
          ]
            ++ maybeToList ((decodeUtf8 amzSecurityToken,) . BA.convert <$> spSessionToken sp)
  
  chunkSizeConstant :: Int
  chunkSizeConstant = 64 * 1024
  
  -- base16Len computes the number of bytes required to represent @n (> 0)@ in
  -- hexadecimal.
  base16Len :: (Integral a) => a -> Int
  base16Len n
    | n == 0 = 0
    | otherwise = 1 + base16Len (n `div` 16)
  
  signedStreamLength :: Int64 -> Int64
  signedStreamLength dataLen =
    let chunkSzInt = fromIntegral chunkSizeConstant
        (numChunks, lastChunkLen) = quotRem dataLen chunkSzInt
        -- Structure of a chunk:
        --   string(IntHexBase(chunk-size)) + ";chunk-signature=" + signature + \r\n + chunk-data + \r\n
        encodedChunkLen csz = fromIntegral (base16Len csz) + 17 + 64 + 2 + csz + 2
        fullChunkSize = encodedChunkLen chunkSzInt
        lastChunkSize = bool 0 (encodedChunkLen lastChunkLen) $ lastChunkLen > 0
        finalChunkSize = 1 + 17 + 64 + 2 + 2
     in numChunks * fullChunkSize + lastChunkSize + finalChunkSize
  
  -- For streaming S3, we need to update the content-encoding header.
  addContentEncoding :: [Header] -> [Header]
  addContentEncoding hs =
    -- assume there is at most one content-encoding header.
    let (ceHdrs, others) = partition ((== hContentEncoding) . fst) hs
     in maybe
          (hContentEncoding, "aws-chunked")
          (\(k, v) -> (k, v <> ",aws-chunked"))
          (listToMaybe ceHdrs)
          : others
  
  signV4Stream ::
    Int64 ->
    SignParams ->
    NC.Request ->
    (C.ConduitT () ByteString (C.ResourceT IO) () -> NC.Request)
  signV4Stream !payloadLength !sp !req =
    let ts = spTimeStamp sp
  
        -- compute the updated list of headers to be added for signing purposes.
        signedContentLength = signedStreamLength payloadLength
        extraHeaders =
          [ ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp),
            ("x-amz-decoded-content-length", showBS payloadLength),
            ("content-length", showBS signedContentLength),
            ("x-amz-content-sha256", "STREAMING-AWS4-HMAC-SHA256-PAYLOAD")
          ]
            ++ maybeToList ((mk amzSecurityToken,) . BA.convert <$> spSessionToken sp)
        requestHeaders =
          addContentEncoding $
            foldr setHeader (NC.requestHeaders req) extraHeaders
  
        -- 1. Compute Seed Signature
        -- 1.1 Canonical Request
        (canonicalReq, signedHeaderKeys) =
          getCanonicalRequestAndSignedHeaders
            (IsStreamingLength payloadLength)
            sp
            req
            requestHeaders
  
        scope = credentialScope sp
        accessKey = spAccessKey sp
        -- 1.2 String toSign
        stringToSign = mkStringToSign ts scope canonicalReq
        -- 1.3 Compute signature
        -- 1.3.1 compute signing key
        signingKey = getSigningKey sp
        -- 1.3.2 Compute signature
        seedSignature = computeSignature stringToSign signingKey
        -- 1.3.3 Compute Auth Header
        authHeader = mkAuthHeader accessKey scope signedHeaderKeys seedSignature
        -- 1.4 Updated headers for the request
        finalReqHeaders = authHeader : requestHeaders
        -- headersToAdd = authHeader : datePair : streamingHeaders
  
        toHexStr n = B8.pack $ printf "%x" n
        (numParts, lastPSize) = payloadLength `quotRem` fromIntegral chunkSizeConstant
        -- Function to compute string to sign for each chunk.
        chunkStrToSign prevSign currChunkHash =
          B.intercalate
            "\n"
            [ "AWS4-HMAC-SHA256-PAYLOAD",
              awsTimeFormatBS ts,
              scope,
              prevSign,
              hashSHA256 "",
              currChunkHash
            ]
        -- Read n byte from upstream and return a strict bytestring.
        mustTakeN n = do
          bs <- LB.toStrict <$> (C.takeCE n C..| C.sinkLazy)
          when (B.length bs /= n) $
            throwIO MErrVStreamingBodyUnexpectedEOF
          return bs
        signerConduit n lps prevSign =
          -- First case encodes a full chunk of length
          -- 'chunkSizeConstant'.
          if
              | n > 0 -> do
                  bs <- mustTakeN chunkSizeConstant
                  let strToSign = chunkStrToSign prevSign (hashSHA256 bs)
                      nextSign = computeSignature strToSign signingKey
                      chunkBS =
                        toHexStr chunkSizeConstant
                          <> ";chunk-signature="
                          <> nextSign
                          <> "\r\n"
                          <> bs
                          <> "\r\n"
                  C.yield chunkBS
                  signerConduit (n - 1) lps nextSign
  
              -- Second case encodes the last chunk which is smaller than
              -- 'chunkSizeConstant'
              | lps > 0 -> do
                  bs <- mustTakeN $ fromIntegral lps
                  let strToSign = chunkStrToSign prevSign (hashSHA256 bs)
                      nextSign = computeSignature strToSign signingKey
                      chunkBS =
                        toHexStr lps
                          <> ";chunk-signature="
                          <> nextSign
                          <> "\r\n"
                          <> bs
                          <> "\r\n"
                  C.yield chunkBS
                  signerConduit 0 0 nextSign
  
              -- Last case encodes the final signature chunk that has no
              -- data.
              | otherwise -> do
                  let strToSign = chunkStrToSign prevSign (hashSHA256 "")
                      nextSign = computeSignature strToSign signingKey
                      lastChunkBS = "0;chunk-signature=" <> nextSign <> "\r\n\r\n"
                  C.yield lastChunkBS
     in \src ->
          req
            { NC.requestHeaders = finalReqHeaders,
              NC.requestBody =
                NC.requestBodySource signedContentLength $
                  src C..| signerConduit numParts lastPSize seedSignature
            }
  
  -- "setHeader r hdr" adds the hdr to r, replacing it in r if it already exists.
  setHeader :: Header -> RequestHeaders -> RequestHeaders
  setHeader hdr r =
    let r' = filter (\(name, _) -> name /= fst hdr) r
     in hdr : r'
  