{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Network.DO.Spaces.Request
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
-- Low-level implementations of Spaces REST transactions. You should not import
-- this module directly, but should instead use the higher-level interface exposed
-- by "Network.DO.Spaces.Actions" and its submodules
--
module Network.DO.Spaces.Request
    ( newSpacesRequest
    , mkSignature
    , mkStringToSign
    , mkAuthorization
    , finalize
    ) where

import           Control.Monad.Catch             ( MonadThrow )

import           Crypto.Hash                     ( SHA256, hashlazy )
import           Crypto.MAC.HMAC                 ( hmac )

import           Data.Bifunctor                  ( first )
import           Data.ByteArray                  ( convert )
import           Data.ByteString                 ( ByteString )
import qualified Data.ByteString.Base16          as B16
import qualified Data.ByteString.Char8           as C
import qualified Data.ByteString.Lazy            as LB
import qualified Data.CaseInsensitive            as CI
import           Data.Coerce                     ( coerce )
import           Data.Function                   ( (&) )
import           Data.Generics.Product           ( HasField(field) )
import           Data.Generics.Product.Positions ( HasPosition(position) )
import           Data.Generics.Wrapped
import           Data.List                       ( sort )
import           Data.Maybe                      ( fromMaybe )
import qualified Data.Text                       as T
import           Data.Time
                 ( UTCTime
                 , defaultTimeLocale
                 , formatTime
                 )

import           Lens.Micro                      ( (^.) )

import           Network.DO.Spaces.Types
import           Network.DO.Spaces.Utils
                 ( bodyLBS
                 , regionSlug
                 , toLowerBS
                 )
import           Network.HTTP.Client.Conduit     ( Request
                                                 , RequestBody(RequestBodyLBS)
                                                 )
import qualified Network.HTTP.Client.Conduit     as H
import           Network.HTTP.Types              ( Header, Query, QueryItem )
import qualified Network.HTTP.Types              as H

-- | Extract the 'Request' from a 'SpacesRequest' and set the requisite
-- @Authorization@ header
finalize :: SpacesRequest -> Authorization -> Request
finalize :: SpacesRequest -> Authorization -> Request
finalize SpacesRequest
sr Authorization
auth = Request
req { requestHeaders :: RequestHeaders
H.requestHeaders = (CI ByteString, ByteString)
authHeader (CI ByteString, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: RequestHeaders
reqHeaders }
  where
    authHeader :: (CI ByteString, ByteString)
authHeader = (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"authorization", Authorization -> ByteString
forall (a :: ComputedTag). Computed a -> ByteString
uncompute Authorization
auth)

    req :: Request
req        = SpacesRequest
sr SpacesRequest -> Getting Request SpacesRequest Request -> Request
forall s a. s -> Getting a s a -> a
^. forall s t a b. HasField "request" s t a b => Lens s t a b
forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"request"

    reqHeaders :: RequestHeaders
reqHeaders = Request
req Request -> (Request -> RequestHeaders) -> RequestHeaders
forall a b. a -> (a -> b) -> b
& Request -> RequestHeaders
H.requestHeaders

-- | Create a new 'SpacesRequest' from a 'SpacesRequestBuilder', performing the
-- necessary computations and setting the appropriate default headers
newSpacesRequest
    :: MonadThrow m => SpacesRequestBuilder -> UTCTime -> m SpacesRequest
newSpacesRequest :: SpacesRequestBuilder -> UTCTime -> m SpacesRequest
newSpacesRequest SpacesRequestBuilder { RequestHeaders
Maybe Query
Maybe RequestBody
Maybe Object
Maybe Bucket
Maybe Method
Maybe Region
Spaces
$sel:overrideRegion:SpacesRequestBuilder :: SpacesRequestBuilder -> Maybe Region
$sel:subresources:SpacesRequestBuilder :: SpacesRequestBuilder -> Maybe Query
$sel:queryString:SpacesRequestBuilder :: SpacesRequestBuilder -> Maybe Query
$sel:object:SpacesRequestBuilder :: SpacesRequestBuilder -> Maybe Object
$sel:bucket:SpacesRequestBuilder :: SpacesRequestBuilder -> Maybe Bucket
$sel:headers:SpacesRequestBuilder :: SpacesRequestBuilder -> RequestHeaders
$sel:method:SpacesRequestBuilder :: SpacesRequestBuilder -> Maybe Method
$sel:body:SpacesRequestBuilder :: SpacesRequestBuilder -> Maybe RequestBody
$sel:spaces:SpacesRequestBuilder :: SpacesRequestBuilder -> Spaces
overrideRegion :: Maybe Region
subresources :: Maybe Query
queryString :: Maybe Query
object :: Maybe Object
bucket :: Maybe Bucket
headers :: RequestHeaders
method :: Maybe Method
body :: Maybe RequestBody
spaces :: Spaces
.. } UTCTime
time = do
    Request
req <- String -> m Request
forall (m :: * -> *). MonadThrow m => String -> m Request
H.parseRequest
        (String -> m Request) -> String -> m Request
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat [ Method -> String
forall a. Show a => a -> String
show Method
reqMethod
                  , String
" "
                  , String
"https://"
                  , String -> (Bucket -> String) -> Maybe Bucket -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
forall a. Monoid a => a
mempty ((String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".") (String -> String) -> (Bucket -> String) -> Bucket -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (Bucket -> Text) -> Bucket -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bucket -> Text
coerce) Maybe Bucket
bucket
                  , Region -> String
forall a. IsString a => Region -> a
regionSlug
                    (Region -> String) -> Region -> String
forall a b. (a -> b) -> a -> b
$ Region -> Maybe Region -> Region
forall a. a -> Maybe a -> a
fromMaybe (Spaces
spaces Spaces -> Getting Region Spaces Region -> Region
forall s a. s -> Getting a s a -> a
^. forall s t a b. HasField "region" s t a b => Lens s t a b
forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"region") Maybe Region
overrideRegion
                  , String
"."
                  , String
"digitaloceanspaces.com/"
                  , String -> (Object -> String) -> Maybe Object -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
forall a. Monoid a => a
mempty (Text -> String
T.unpack (Text -> String) -> (Object -> Text) -> Object -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Text
coerce) Maybe Object
object
                  ]
    ByteString
payload <- RequestBody -> m ByteString
forall (m :: * -> *). MonadThrow m => RequestBody -> m ByteString
bodyLBS RequestBody
reqBody
    let payloadHash :: Hashed
payloadHash      = ByteString -> Hashed
hashHex ByteString
payload
        newHeaders :: RequestHeaders
newHeaders       = Request -> Hashed -> UTCTime -> RequestHeaders
overrideReqHeaders Request
req Hashed
payloadHash UTCTime
time
        request :: Request
request          = Request
req
            { requestHeaders :: RequestHeaders
H.requestHeaders = RequestHeaders
headers RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. Semigroup a => a -> a -> a
<> RequestHeaders
newHeaders
            , queryString :: ByteString
H.queryString    =
                  ByteString -> (Query -> ByteString) -> Maybe Query -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
forall a. Monoid a => a
mempty (Bool -> Query -> ByteString
H.renderQuery Bool
True) Maybe Query
subresources
                  ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> (Query -> ByteString) -> Maybe Query -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
forall a. Monoid a => a
mempty (Bool -> Query -> ByteString
H.renderQuery Bool
False) Maybe Query
queryString
            , requestBody :: RequestBody
H.requestBody    = RequestBody
reqBody
            }
        canonicalRequest :: Canonicalized Request
canonicalRequest = Query -> Query -> Request -> Hashed -> Canonicalized Request
mkCanonicalized (Query -> Maybe Query -> Query
forall a. a -> Maybe a -> a
fromMaybe Query
forall a. Monoid a => a
mempty Maybe Query
subresources)
                                           (Query -> Maybe Query -> Query
forall a. a -> Maybe a -> a
fromMaybe Query
forall a. Monoid a => a
mempty Maybe Query
queryString)
                                           Request
request
                                           Hashed
payloadHash
    SpacesRequest -> m SpacesRequest
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (SpacesRequest -> m SpacesRequest)
-> SpacesRequest -> m SpacesRequest
forall a b. (a -> b) -> a -> b
$ SpacesRequest :: Request
-> Spaces
-> RequestHeaders
-> Method
-> Hashed
-> Canonicalized Request
-> UTCTime
-> SpacesRequest
SpacesRequest
        { $sel:method:SpacesRequest :: Method
method = Method
reqMethod, $sel:headers:SpacesRequest :: RequestHeaders
headers = RequestHeaders
headers RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. Semigroup a => a -> a -> a
<> RequestHeaders
newHeaders, UTCTime
Request
Hashed
Canonicalized Request
Spaces
$sel:time:SpacesRequest :: UTCTime
$sel:canonicalRequest:SpacesRequest :: Canonicalized Request
$sel:payloadHash:SpacesRequest :: Hashed
$sel:spaces:SpacesRequest :: Spaces
$sel:request:SpacesRequest :: Request
canonicalRequest :: Canonicalized Request
request :: Request
payloadHash :: Hashed
time :: UTCTime
spaces :: Spaces
.. }
  where
    reqMethod :: Method
reqMethod = Method -> Maybe Method -> Method
forall a. a -> Maybe a -> a
fromMaybe Method
GET Maybe Method
method

    reqBody :: RequestBody
reqBody   = RequestBody -> Maybe RequestBody -> RequestBody
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> RequestBody
RequestBodyLBS ByteString
LB.empty) Maybe RequestBody
body

-- | Canonicalize a 'Request'
mkCanonicalized :: Query -- ^ Subresources
                -> Query  -- ^ Query string
                -> Request
                -> Hashed  -- ^ The hashed 'RequestBody'
                -> Canonicalized Request
mkCanonicalized :: Query -> Query -> Request -> Hashed -> Canonicalized Request
mkCanonicalized Query
subresources Query
query Request
request Hashed
payloadHash = ByteString -> Canonicalized Request
forall a. ByteString -> Canonicalized a
Canonicalized
    (ByteString -> Canonicalized Request)
-> ByteString -> Canonicalized Request
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> ByteString
C.intercalate ByteString
"\n"
                    [ Request
request Request -> (Request -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Request -> ByteString
H.method
                    , Request
request Request -> (Request -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Request -> ByteString
H.path
                    , Query -> ByteString
renderSubresources Query
subresources
                      ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Bool -> Query -> ByteString
H.renderQuery Bool
False Query
query
                    , Request
request
                      Request -> (Request -> RequestHeaders) -> RequestHeaders
forall a b. a -> (a -> b) -> b
& Request -> RequestHeaders
H.requestHeaders
                      RequestHeaders
-> (RequestHeaders -> Canonicalized RequestHeaders)
-> Canonicalized RequestHeaders
forall a b. a -> (a -> b) -> b
& RequestHeaders -> Canonicalized RequestHeaders
canonicalizeHeaders
                      Canonicalized RequestHeaders
-> (Canonicalized RequestHeaders -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Canonicalized RequestHeaders -> ByteString
forall s t a b. Wrapped s t a b => s -> a
wrappedTo
                    , Request
request Request -> (Request -> RequestHeaders) -> RequestHeaders
forall a b. a -> (a -> b) -> b
& Request -> RequestHeaders
H.requestHeaders RequestHeaders -> (RequestHeaders -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& RequestHeaders -> ByteString
joinHeaderNames
                    , Hashed -> ByteString
forall (a :: ComputedTag). Computed a -> ByteString
uncompute Hashed
payloadHash
                    ]

-- | This is required to encode the subresources query string correctly in the
-- canonical request. Empty query keys require a trailing @=@, which are not
-- included with 'H.renderQuery'
renderSubresources :: Query -> ByteString
renderSubresources :: Query -> ByteString
renderSubresources = ByteString -> [ByteString] -> ByteString
C.intercalate ByteString
"&" ([ByteString] -> ByteString)
-> (Query -> [ByteString]) -> Query -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QueryItem -> ByteString) -> Query -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap QueryItem -> ByteString
renderQueryItem (Query -> [ByteString])
-> (Query -> Query) -> Query -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query -> Query
forall a. Ord a => [a] -> [a]
sort
  where
    renderQueryItem :: QueryItem -> ByteString
    renderQueryItem :: QueryItem -> ByteString
renderQueryItem (ByteString
k, Maybe ByteString
Nothing) = ByteString
k ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"="
    renderQueryItem (ByteString
k, Just ByteString
v)  = ByteString
k ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
v

-- | Generate a t'StringToSign'
mkStringToSign :: SpacesRequest -> StringToSign
mkStringToSign :: SpacesRequest -> StringToSign
mkStringToSign req :: SpacesRequest
req@SpacesRequest { RequestHeaders
UTCTime
Request
Hashed
Canonicalized Request
Method
Spaces
time :: UTCTime
canonicalRequest :: Canonicalized Request
payloadHash :: Hashed
method :: Method
headers :: RequestHeaders
spaces :: Spaces
request :: Request
$sel:time:SpacesRequest :: SpacesRequest -> UTCTime
$sel:canonicalRequest:SpacesRequest :: SpacesRequest -> Canonicalized Request
$sel:payloadHash:SpacesRequest :: SpacesRequest -> Hashed
$sel:spaces:SpacesRequest :: SpacesRequest -> Spaces
$sel:request:SpacesRequest :: SpacesRequest -> Request
$sel:headers:SpacesRequest :: SpacesRequest -> RequestHeaders
$sel:method:SpacesRequest :: SpacesRequest -> Method
.. } = ByteString -> StringToSign
StringToSign
    (ByteString -> StringToSign) -> ByteString -> StringToSign
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> ByteString
C.intercalate ByteString
"\n"
                    [ ByteString
"AWS4-HMAC-SHA256"
                    , UTCTime -> ByteString
fmtAmzTime UTCTime
time
                    , SpacesRequest -> Credentials
mkCredentials SpacesRequest
req Credentials -> (Credentials -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Credentials -> ByteString
forall (a :: ComputedTag). Computed a -> ByteString
uncompute
                    , Canonicalized Request
canonicalRequest
                      Canonicalized Request
-> (Canonicalized Request -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Canonicalized Request -> ByteString
coerce
                      ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& ByteString -> ByteString
LB.fromStrict
                      ByteString -> (ByteString -> Hashed) -> Hashed
forall a b. a -> (a -> b) -> b
& ByteString -> Hashed
hashHex
                      Hashed -> (Hashed -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Hashed -> ByteString
forall (a :: ComputedTag). Computed a -> ByteString
uncompute
                    ]

-- | Generate a t'Signature'
mkSignature :: SpacesRequest -> StringToSign -> Signature
mkSignature :: SpacesRequest -> StringToSign -> Signature
mkSignature SpacesRequest { RequestHeaders
UTCTime
Request
Hashed
Canonicalized Request
Method
Spaces
time :: UTCTime
canonicalRequest :: Canonicalized Request
payloadHash :: Hashed
method :: Method
headers :: RequestHeaders
spaces :: Spaces
request :: Request
$sel:time:SpacesRequest :: SpacesRequest -> UTCTime
$sel:canonicalRequest:SpacesRequest :: SpacesRequest -> Canonicalized Request
$sel:payloadHash:SpacesRequest :: SpacesRequest -> Hashed
$sel:spaces:SpacesRequest :: SpacesRequest -> Spaces
$sel:request:SpacesRequest :: SpacesRequest -> Request
$sel:headers:SpacesRequest :: SpacesRequest -> RequestHeaders
$sel:method:SpacesRequest :: SpacesRequest -> Method
.. } StringToSign
str = ByteString -> Signature
Signature
    (ByteString -> Signature)
-> (ByteString -> ByteString) -> ByteString -> Signature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode
    (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
keyedHash (StringToSign -> ByteString
forall (a :: ComputedTag). Computed a -> ByteString
uncompute StringToSign
str)
    (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
keyedHash ByteString
"aws4_request"
    (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
keyedHash ByteString
"s3"
    (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
keyedHash (Spaces
spaces Spaces -> Getting Region Spaces Region -> Region
forall s a. s -> Getting a s a -> a
^. forall s t a b. HasField "region" s t a b => Lens s t a b
forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"region" Region -> (Region -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Region -> ByteString
forall a. IsString a => Region -> a
regionSlug)
    (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
keyedHash (UTCTime -> ByteString
fmtAmzDate UTCTime
time)
    (ByteString -> Signature) -> ByteString -> Signature
forall a b. (a -> b) -> a -> b
$ ByteString
"AWS4" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (Spaces
spaces Spaces -> Getting SecretKey Spaces SecretKey -> SecretKey
forall s a. s -> Getting a s a -> a
^. forall s t a b. HasField "secretKey" s t a b => Lens s t a b
forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"secretKey" SecretKey -> (SecretKey -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& SecretKey -> ByteString
coerce)

-- | Create an t'Authorization' corresponding to the required AWS v4
-- @Authorization@ header
mkAuthorization :: SpacesRequest -> StringToSign -> Authorization
mkAuthorization :: SpacesRequest -> StringToSign -> Authorization
mkAuthorization req :: SpacesRequest
req@SpacesRequest { RequestHeaders
UTCTime
Request
Hashed
Canonicalized Request
Method
Spaces
time :: UTCTime
canonicalRequest :: Canonicalized Request
payloadHash :: Hashed
method :: Method
headers :: RequestHeaders
spaces :: Spaces
request :: Request
$sel:time:SpacesRequest :: SpacesRequest -> UTCTime
$sel:canonicalRequest:SpacesRequest :: SpacesRequest -> Canonicalized Request
$sel:payloadHash:SpacesRequest :: SpacesRequest -> Hashed
$sel:spaces:SpacesRequest :: SpacesRequest -> Spaces
$sel:request:SpacesRequest :: SpacesRequest -> Request
$sel:headers:SpacesRequest :: SpacesRequest -> RequestHeaders
$sel:method:SpacesRequest :: SpacesRequest -> Method
.. } StringToSign
str = ByteString -> Authorization
Authorization
    (ByteString -> Authorization) -> ByteString -> Authorization
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
C.concat [ ByteString
"AWS4-HMAC-SHA256 Credential="
                 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Spaces
spaces Spaces -> Getting ByteString Spaces ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. forall s t a b. HasField "accessKey" s t a b => Lens s t a b
forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"accessKey" ((AccessKey -> Const ByteString AccessKey)
 -> Spaces -> Const ByteString Spaces)
-> ((ByteString -> Const ByteString ByteString)
    -> AccessKey -> Const ByteString AccessKey)
-> Getting ByteString Spaces ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. HasPosition 1 s t a b => Lens s t a b
forall (i :: Nat) s t a b. HasPosition i s t a b => Lens s t a b
position @1
                 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/"
                 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Credentials -> ByteString
forall (a :: ComputedTag). Computed a -> ByteString
uncompute Credentials
cred
               , ByteString
", SignedHeaders=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> RequestHeaders -> ByteString
joinHeaderNames RequestHeaders
headers
               , ByteString
", Signature=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Signature -> ByteString
forall (a :: ComputedTag). Computed a -> ByteString
uncompute Signature
sig
               ]
  where
    cred :: Credentials
cred = SpacesRequest -> Credentials
mkCredentials SpacesRequest
req

    sig :: Signature
sig  = SpacesRequest -> StringToSign -> Signature
mkSignature SpacesRequest
req StringToSign
str

-- | Create t'Credentials' containing your 'AccessKey' and the request 'Region'
mkCredentials :: SpacesRequest -> Credentials
mkCredentials :: SpacesRequest -> Credentials
mkCredentials SpacesRequest { RequestHeaders
UTCTime
Request
Hashed
Canonicalized Request
Method
Spaces
time :: UTCTime
canonicalRequest :: Canonicalized Request
payloadHash :: Hashed
method :: Method
headers :: RequestHeaders
spaces :: Spaces
request :: Request
$sel:time:SpacesRequest :: SpacesRequest -> UTCTime
$sel:canonicalRequest:SpacesRequest :: SpacesRequest -> Canonicalized Request
$sel:payloadHash:SpacesRequest :: SpacesRequest -> Hashed
$sel:spaces:SpacesRequest :: SpacesRequest -> Spaces
$sel:request:SpacesRequest :: SpacesRequest -> Request
$sel:headers:SpacesRequest :: SpacesRequest -> RequestHeaders
$sel:method:SpacesRequest :: SpacesRequest -> Method
.. } = ByteString -> Credentials
Credentials
    (ByteString -> Credentials) -> ByteString -> Credentials
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> ByteString
C.intercalate ByteString
"/"
                    [ UTCTime -> ByteString
fmtAmzDate UTCTime
time
                    , Spaces
spaces Spaces -> Getting Region Spaces Region -> Region
forall s a. s -> Getting a s a -> a
^. forall s t a b. HasField "region" s t a b => Lens s t a b
forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"region" Region -> (Region -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Region -> ByteString
forall a. IsString a => Region -> a
regionSlug
                    , ByteString
"s3"
                    , ByteString
"aws4_request"
                    ]

-- | Required to override @http-client@ automatically setting the Content-Length header and
-- setting obligatory headers for AWS v4 API requests
overrideReqHeaders
    :: Request
    -> Hashed   -- ^ The SHA256 hash of the request body; required in AWS v4
    -> UTCTime
    -> [Header]
overrideReqHeaders :: Request -> Hashed -> UTCTime -> RequestHeaders
overrideReqHeaders Request
req Hashed
hb UTCTime
time = (Request
req Request -> (Request -> RequestHeaders) -> RequestHeaders
forall a b. a -> (a -> b) -> b
& Request -> RequestHeaders
H.requestHeaders) RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. Semigroup a => a -> a -> a
<> RequestHeaders
newHeaders
  where
    newHeaders :: RequestHeaders
newHeaders = [ (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"host", Request
req Request -> (Request -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Request -> ByteString
H.host)
                 , (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"x-amz-content-sha256", Hashed -> ByteString
forall (a :: ComputedTag). Computed a -> ByteString
uncompute Hashed
hb)
                 , (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"x-amz-date", UTCTime -> ByteString
fmtAmzTime UTCTime
time)
                 ]

-- | Canonicalize @['Header']@s
canonicalizeHeaders :: [Header] -> Canonicalized [Header]
canonicalizeHeaders :: RequestHeaders -> Canonicalized RequestHeaders
canonicalizeHeaders = ByteString -> Canonicalized RequestHeaders
forall a. ByteString -> Canonicalized a
Canonicalized
    (ByteString -> Canonicalized RequestHeaders)
-> (RequestHeaders -> ByteString)
-> RequestHeaders
-> Canonicalized RequestHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
C.unlines
    ([ByteString] -> ByteString)
-> (RequestHeaders -> [ByteString]) -> RequestHeaders -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> ByteString)
-> [(ByteString, ByteString)] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ByteString
n, ByteString
v) -> ByteString
n ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
v)
    ([(ByteString, ByteString)] -> [ByteString])
-> (RequestHeaders -> [(ByteString, ByteString)])
-> RequestHeaders
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. Ord a => [a] -> [a]
sort
    ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> (RequestHeaders -> [(ByteString, ByteString)])
-> RequestHeaders
-> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CI ByteString, ByteString) -> (ByteString, ByteString))
-> RequestHeaders -> [(ByteString, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CI ByteString -> ByteString)
-> (CI ByteString, ByteString) -> (ByteString, ByteString)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ByteString -> ByteString
toLowerBS (ByteString -> ByteString)
-> (CI ByteString -> ByteString) -> CI ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> ByteString
forall s. CI s -> s
CI.original))

joinHeaderNames :: [Header] -> ByteString
joinHeaderNames :: RequestHeaders -> ByteString
joinHeaderNames =
    ByteString -> [ByteString] -> ByteString
C.intercalate ByteString
";" ([ByteString] -> ByteString)
-> (RequestHeaders -> [ByteString]) -> RequestHeaders -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> [ByteString]
forall a. Ord a => [a] -> [a]
sort ([ByteString] -> [ByteString])
-> (RequestHeaders -> [ByteString])
-> RequestHeaders
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CI ByteString, ByteString) -> ByteString)
-> RequestHeaders -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> ByteString
toLowerBS (ByteString -> ByteString)
-> ((CI ByteString, ByteString) -> ByteString)
-> (CI ByteString, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> ByteString
forall s. CI s -> s
CI.original (CI ByteString -> ByteString)
-> ((CI ByteString, ByteString) -> CI ByteString)
-> (CI ByteString, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CI ByteString, ByteString) -> CI ByteString
forall a b. (a, b) -> a
fst)

fmtAmzDate :: UTCTime -> ByteString
fmtAmzDate :: UTCTime -> ByteString
fmtAmzDate = String -> ByteString
C.pack (String -> ByteString)
-> (UTCTime -> String) -> UTCTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y%m%d"

fmtAmzTime :: UTCTime -> ByteString
fmtAmzTime :: UTCTime -> ByteString
fmtAmzTime = String -> ByteString
C.pack (String -> ByteString)
-> (UTCTime -> String) -> UTCTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y%m%dT%H%M%SZ"

keyedHash :: ByteString -> ByteString -> ByteString
keyedHash :: ByteString -> ByteString -> ByteString
keyedHash ByteString
bs ByteString
k = HMAC SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (HMAC SHA256 -> ByteString) -> HMAC SHA256 -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> HMAC SHA256
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
hmac @_ @_ @SHA256 ByteString
k ByteString
bs

hashHex :: LB.ByteString -> Hashed
hashHex :: ByteString -> Hashed
hashHex = ByteString -> Hashed
Hashed (ByteString -> Hashed)
-> (ByteString -> ByteString) -> ByteString -> Hashed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (Digest SHA256 -> ByteString)
-> (ByteString -> Digest SHA256) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashAlgorithm SHA256 => ByteString -> Digest SHA256
forall a. HashAlgorithm a => ByteString -> Digest a
hashlazy @SHA256