-- |
-- Module      : Amazonka.Sign.V4.Chunked
-- Copyright   : (c) 2013-2023 Brendan Hay
-- License     : Mozilla Public License, v. 2.0.
-- Maintainer  : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
module Amazonka.Sign.V4.Chunked where

import qualified Amazonka.Bytes as Bytes
import Amazonka.Core.Lens.Internal ((^.))
import qualified Amazonka.Crypto as Crypto
import Amazonka.Data
import Amazonka.Prelude as Prelude
import Amazonka.Sign.V4.Base as V4 hiding (algorithm)
import Amazonka.Types
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as Build
import qualified Data.ByteString.Char8 as BS8
import Data.Conduit (ConduitM)
import qualified Data.Conduit as Conduit
import qualified Network.HTTP.Types as HTTP
import qualified Numeric

chunked :: ChunkedBody -> Algorithm a
chunked :: forall a. ChunkedBody -> Algorithm a
chunked
  c :: ChunkedBody
c@ChunkedBody {$sel:length:ChunkedBody :: ChunkedBody -> Integer
length = Integer
len}
  rq :: Request a
rq@Request {$sel:service:Request :: forall a. Request a -> Service
service = service :: Service
service@Service {Region -> Endpoint
endpoint :: Region -> Endpoint
$sel:endpoint:Service :: Service -> Region -> Endpoint
endpoint}}
  AuthEnv
a
  Region
region
  UTCTime
ts =
    V4 -> RequestBody -> (ClientRequest -> ClientRequest) -> Signed a
forall a.
V4 -> RequestBody -> (ClientRequest -> ClientRequest) -> Signed a
signRequest V4
meta (RequestBody -> RequestBody
toRequestBody RequestBody
body) ClientRequest -> ClientRequest
auth
    where
      (V4
meta, ClientRequest -> ClientRequest
auth) = Hash
-> Request a
-> AuthEnv
-> Region
-> UTCTime
-> (V4, ClientRequest -> ClientRequest)
forall a.
Hash
-> Request a
-> AuthEnv
-> Region
-> UTCTime
-> (V4, ClientRequest -> ClientRequest)
V4.base (ByteString -> Hash
forall (s :: Symbol) a. a -> Tag s a
Tag ByteString
digest) (Request a -> Request a
forall a. Request a -> Request a
prepare Request a
rq) AuthEnv
a Region
region UTCTime
ts

      -- Although https://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-streaming.html says to include
      -- `Content-Encoding: aws-chunked`, we don't. If it's the only header, S3 will remove
      -- `aws-chunked` leaving a blank header, and store `"ContentEncoding": ""` in the object's metadata.
      -- This breaks some CDNs and HTTP clients.
      --
      -- According to https://github.com/fog/fog-aws/pull/147 , AWS support have confirmed that the
      -- header is not strictly necessary, and S3 will figure out that it's a chunked body.
      prepare :: Request a -> Request a
      prepare :: forall a. Request a -> Request a
prepare r :: Request a
r@Request {[Header]
headers :: [Header]
$sel:headers:Request :: forall a. Request a -> [Header]
headers} =
        Request a
r
          { $sel:headers:Request :: [Header]
headers =
              [Header]
headers
                [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [ (HeaderName
hAMZDecodedContentLength, Integer -> ByteString
forall a. ToByteString a => a -> ByteString
toBS Integer
len),
                     (HeaderName
HTTP.hContentLength, Integer -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (ChunkedBody -> Integer
metadataLength ChunkedBody
c))
                   ]
          }

      body :: RequestBody
body = ChunkedBody -> RequestBody
Chunked (ChunkedBody
c ChunkedBody
-> ConduitM ByteString ByteString (ResourceT IO) () -> ChunkedBody
`fuseChunks` Signature -> ConduitM ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *).
Monad m =>
Signature -> ConduitM ByteString ByteString m ()
sign (V4 -> Signature
metaSignature V4
meta))

      sign :: Monad m => Signature -> ConduitM ByteString ByteString m ()
      sign :: forall (m :: * -> *).
Monad m =>
Signature -> ConduitM ByteString ByteString m ()
sign Signature
prev = do
        Maybe ByteString
mx <- ConduitT ByteString ByteString m (Maybe ByteString)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
Conduit.await

        let next :: Signature
next = Signature -> ByteString -> Signature
chunkSignature Signature
prev (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
forall a. Monoid a => a
mempty Maybe ByteString
mx)

        case Maybe ByteString
mx of
          Maybe ByteString
Nothing -> ByteString -> ConduitM ByteString ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
Conduit.yield (Signature -> ByteString -> ByteString
forall {a}. ToByteString a => a -> ByteString -> ByteString
chunkData Signature
next ByteString
forall a. Monoid a => a
mempty)
          Just ByteString
x -> ByteString -> ConduitM ByteString ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
Conduit.yield (Signature -> ByteString -> ByteString
forall {a}. ToByteString a => a -> ByteString -> ByteString
chunkData Signature
next ByteString
x) ConduitM ByteString ByteString m ()
-> ConduitM ByteString ByteString m ()
-> ConduitM ByteString ByteString m ()
forall a b.
ConduitT ByteString ByteString m a
-> ConduitT ByteString ByteString m b
-> ConduitT ByteString ByteString m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Signature -> ConduitM ByteString ByteString m ()
forall (m :: * -> *).
Monad m =>
Signature -> ConduitM ByteString ByteString m ()
sign Signature
next

      chunkData :: a -> ByteString -> ByteString
chunkData a
next ByteString
x =
        Builder -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
          Word64 -> Builder
Build.word64Hex (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
x))
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Build.byteString ByteString
chunkSignatureHeader
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Build.byteString (a -> ByteString
forall a. ToByteString a => a -> ByteString
toBS a
next)
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Build.byteString ByteString
crlf
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Build.byteString ByteString
x
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Build.byteString ByteString
crlf

      chunkSignature :: Signature -> ByteString -> Signature
chunkSignature Signature
prev ByteString
x =
        SecretKey -> CredentialScope -> StringToSign -> Signature
signature (AuthEnv -> Sensitive SecretKey
secretAccessKey AuthEnv
a Sensitive SecretKey
-> Getting SecretKey (Sensitive SecretKey) SecretKey -> SecretKey
forall s a. s -> Getting a s a -> a
^. Getting SecretKey (Sensitive SecretKey) SecretKey
forall a (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p a (f a) -> p (Sensitive a) (f (Sensitive a))
_Sensitive) CredentialScope
scope (Signature -> ByteString -> StringToSign
forall {a} {s :: Symbol}.
ToByteString a =>
a -> ByteString -> Tag s ByteString
chunkStringToSign Signature
prev ByteString
x)

      chunkStringToSign :: a -> ByteString -> Tag s ByteString
chunkStringToSign a
prev ByteString
x =
        ByteString -> Tag s ByteString
forall (s :: Symbol) a. a -> Tag s a
Tag (ByteString -> Tag s ByteString) -> ByteString -> Tag s ByteString
forall a b. (a -> b) -> a -> b
$
          ByteString -> [ByteString] -> ByteString
BS8.intercalate
            ByteString
"\n"
            [ ByteString
algorithm,
              ByteString
time,
              CredentialScope -> ByteString
forall a. ToByteString a => a -> ByteString
toBS CredentialScope
scope,
              a -> ByteString
forall a. ToByteString a => a -> ByteString
toBS a
prev,
              ByteString
sha256Empty,
              ByteString -> ByteString
sha256 ByteString
x
            ]

      time :: ByteString
      time :: ByteString
time = AWSTime -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (UTCTime -> AWSTime
forall (a :: Format). UTCTime -> Time a
Time UTCTime
ts :: AWSTime)

      scope :: CredentialScope
      scope :: CredentialScope
scope = Service -> Endpoint -> UTCTime -> CredentialScope
credentialScope Service
service Endpoint
end UTCTime
ts

      end :: Endpoint
      end :: Endpoint
end = Region -> Endpoint
endpoint Region
region

metadataLength :: ChunkedBody -> Integer
metadataLength :: ChunkedBody -> Integer
metadataLength ChunkedBody
c =
  -- Number of full sized chunks.
  ChunkedBody -> Integer
fullChunks ChunkedBody
c Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* ChunkSize -> Integer
forall a. Integral a => a -> Integer
chunkLength (ChunkedBody -> ChunkSize
size ChunkedBody
c)
    -- Non-full chunk preceeding the final chunk.
    Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> (Integer -> Integer) -> Maybe Integer -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
0 Integer -> Integer
forall a. Integral a => a -> Integer
chunkLength (ChunkedBody -> Maybe Integer
remainderBytes ChunkedBody
c)
    -- The final empty chunk.
    Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Integer
forall a. Integral a => a -> Integer
chunkLength (Integer
0 :: Integer)
  where
    chunkLength :: Integral a => a -> Integer
    chunkLength :: forall a. Integral a => a -> Integer
chunkLength (a -> Integer
forall a. Integral a => a -> Integer
toInteger -> Integer
n) =
      Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length (Integer -> ShowS
forall a. Integral a => a -> ShowS
Numeric.showHex Integer
n [Char]
""))
        Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
headerLength
        Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
signatureLength
        Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
crlfLength
        Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n
        Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
crlfLength

    headerLength :: Integer
headerLength = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (ByteString -> Int
BS.length ByteString
chunkSignatureHeader)
    crlfLength :: Integer
crlfLength = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (ByteString -> Int
BS.length ByteString
crlf)
    signatureLength :: Integer
signatureLength = Integer
64

sha256 :: ByteString -> ByteString
sha256 :: ByteString -> ByteString
sha256 = Digest SHA256 -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
Bytes.encodeBase16 (Digest SHA256 -> ByteString)
-> (ByteString -> Digest SHA256) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Digest SHA256
forall a. ByteArrayAccess a => a -> Digest SHA256
Crypto.hashSHA256

sha256Empty :: ByteString
sha256Empty :: ByteString
sha256Empty = ByteString
"e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"

algorithm :: ByteString
algorithm :: ByteString
algorithm = ByteString
"AWS4-HMAC-SHA256-PAYLOAD"

digest :: ByteString
digest :: ByteString
digest = ByteString
"STREAMING-AWS4-HMAC-SHA256-PAYLOAD"

chunkSignatureHeader :: ByteString
chunkSignatureHeader :: ByteString
chunkSignatureHeader = ByteString
";chunk-signature="

crlf :: ByteString
crlf :: ByteString
crlf = ByteString
"\r\n"