{-# 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)
ignoredHeaders :: Set.HashSet ByteString
=
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map
forall s. CI s -> s
CI.foldedCase
[ CI ByteString
H.hAuthorization,
CI ByteString
H.hContentType,
CI ByteString
H.hUserAgent
]
data Service = ServiceS3 | ServiceSTS
deriving stock (Service -> Service -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Service -> Service -> Bool
$c/= :: Service -> Service -> Bool
== :: Service -> Service -> Bool
$c== :: Service -> Service -> Bool
Eq, Int -> Service -> ShowS
[Service] -> ShowS
Service -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Service] -> ShowS
$cshowList :: [Service] -> ShowS
show :: Service -> String
$cshow :: Service -> String
showsPrec :: Int -> Service -> ShowS
$cshowsPrec :: Int -> Service -> ShowS
Show)
toByteString :: Service -> ByteString
toByteString :: Service -> ByteString
toByteString Service
ServiceS3 = ByteString
"s3"
toByteString Service
ServiceSTS = ByteString
"sts"
data SignParams = SignParams
{ SignParams -> Text
spAccessKey :: Text,
SignParams -> ScrubbedBytes
spSecretKey :: BA.ScrubbedBytes,
SignParams -> Maybe ScrubbedBytes
spSessionToken :: Maybe BA.ScrubbedBytes,
SignParams -> Service
spService :: Service,
SignParams -> UTCTime
spTimeStamp :: UTCTime,
SignParams -> Maybe Text
spRegion :: Maybe Text,
SignParams -> Maybe Int
spExpirySecs :: Maybe UrlExpiry,
SignParams -> Maybe ByteString
spPayloadHash :: Maybe ByteString
}
deriving stock (Int -> SignParams -> ShowS
[SignParams] -> ShowS
SignParams -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SignParams] -> ShowS
$cshowList :: [SignParams] -> ShowS
show :: SignParams -> String
$cshow :: SignParams -> String
showsPrec :: Int -> SignParams -> ShowS
$cshowsPrec :: Int -> SignParams -> ShowS
Show)
mkAuthHeader :: Text -> ByteString -> ByteString -> ByteString -> H.Header
Text
accessKey ByteString
scope ByteString
signedHeaderKeys ByteString
sign =
let authValue :: ByteString
authValue =
[ByteString] -> ByteString
B.concat
[ ByteString
"AWS4-HMAC-SHA256 Credential=",
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
accessKey,
ByteString
"/",
ByteString
scope,
ByteString
", SignedHeaders=",
ByteString
signedHeaderKeys,
ByteString
", Signature=",
ByteString
sign
]
in (CI ByteString
H.hAuthorization, ByteString
authValue)
data IsStreaming = IsStreamingLength Int64 | NotStreaming
deriving stock (IsStreaming -> IsStreaming -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IsStreaming -> IsStreaming -> Bool
$c/= :: IsStreaming -> IsStreaming -> Bool
== :: IsStreaming -> IsStreaming -> Bool
$c== :: IsStreaming -> IsStreaming -> Bool
Eq, Int -> IsStreaming -> ShowS
[IsStreaming] -> ShowS
IsStreaming -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IsStreaming] -> ShowS
$cshowList :: [IsStreaming] -> ShowS
show :: IsStreaming -> String
$cshow :: IsStreaming -> String
showsPrec :: Int -> IsStreaming -> ShowS
$cshowsPrec :: Int -> IsStreaming -> ShowS
Show)
amzSecurityToken :: ByteString
amzSecurityToken :: ByteString
amzSecurityToken = ByteString
"X-Amz-Security-Token"
signV4QueryParams :: SignParams -> NC.Request -> SimpleQuery
signV4QueryParams :: SignParams -> Request -> SimpleQuery
signV4QueryParams !SignParams
sp !Request
req =
let scope :: ByteString
scope = SignParams -> ByteString
credentialScope SignParams
sp
expiry :: Maybe Int
expiry = SignParams -> Maybe Int
spExpirySecs SignParams
sp
headersToSign :: SimpleQuery
headersToSign = [Header] -> SimpleQuery
getHeadersToSign forall a b. (a -> b) -> a -> b
$ Request -> [Header]
NC.requestHeaders Request
req
signedHeaderKeys :: ByteString
signedHeaderKeys = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
";" forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst SimpleQuery
headersToSign
authQP :: SimpleQuery
authQP =
[ (ByteString
"X-Amz-Algorithm", ByteString
"AWS4-HMAC-SHA256"),
(ByteString
"X-Amz-Credential", [ByteString] -> ByteString
B.concat [forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall a b. (a -> b) -> a -> b
$ SignParams -> Text
spAccessKey SignParams
sp, ByteString
"/", ByteString
scope]),
(ByteString
"X-Amz-Date", UTCTime -> ByteString
awsTimeFormatBS forall a b. (a -> b) -> a -> b
$ SignParams -> UTCTime
spTimeStamp SignParams
sp),
(ByteString
"X-Amz-Expires", forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" forall a. Show a => a -> ByteString
showBS Maybe Int
expiry),
(ByteString
"X-Amz-SignedHeaders", ByteString
signedHeaderKeys)
]
forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList ((ByteString
amzSecurityToken,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SignParams -> Maybe ScrubbedBytes
spSessionToken SignParams
sp)
finalQP :: [QueryItem]
finalQP =
ByteString -> [QueryItem]
parseQuery (Request -> ByteString
NC.queryString Request
req)
forall a. [a] -> [a] -> [a]
++ if forall a. Maybe a -> Bool
isJust Maybe Int
expiry
then (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) forall a. a -> Maybe a
Just SimpleQuery
authQP
else []
canonicalRequest :: ByteString
canonicalRequest =
Bool -> SignParams -> Request -> SimpleQuery -> ByteString
mkCanonicalRequest
Bool
False
SignParams
sp
([QueryItem] -> Request -> Request
NC.setQueryString [QueryItem]
finalQP Request
req)
SimpleQuery
headersToSign
stringToSign :: ByteString
stringToSign = UTCTime -> ByteString -> ByteString -> ByteString
mkStringToSign (SignParams -> UTCTime
spTimeStamp SignParams
sp) ByteString
scope ByteString
canonicalRequest
signingKey :: ByteString
signingKey = SignParams -> ByteString
getSigningKey SignParams
sp
signature :: ByteString
signature = ByteString -> ByteString -> ByteString
computeSignature ByteString
stringToSign ByteString
signingKey
in (ByteString
"X-Amz-Signature", ByteString
signature) forall a. a -> [a] -> [a]
: SimpleQuery
authQP
signV4 :: SignParams -> NC.Request -> [Header]
signV4 :: SignParams -> Request -> [Header]
signV4 !SignParams
sp !Request
req =
let scope :: ByteString
scope = SignParams -> ByteString
credentialScope SignParams
sp
extraHeaders :: [Header]
extraHeaders =
(CI ByteString
"X-Amz-Date", UTCTime -> ByteString
awsTimeFormatBS forall a b. (a -> b) -> a -> b
$ SignParams -> UTCTime
spTimeStamp SignParams
sp)
forall a. a -> [a] -> [a]
: (
[ ( CI ByteString
"x-amz-content-sha256",
forall a. a -> Maybe a -> a
fromMaybe ByteString
"UNSIGNED-PAYLOAD" forall a b. (a -> b) -> a -> b
$ SignParams -> Maybe ByteString
spPayloadHash SignParams
sp
)
| SignParams -> Service
spService SignParams
sp forall a. Eq a => a -> a -> Bool
== Service
ServiceS3
]
)
forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList ((forall s. FoldCase s => s -> CI s
mk ByteString
amzSecurityToken,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SignParams -> Maybe ScrubbedBytes
spSessionToken SignParams
sp)
reqHeaders :: [Header]
reqHeaders = Request -> [Header]
NC.requestHeaders Request
req forall a. [a] -> [a] -> [a]
++ [Header]
extraHeaders
(ByteString
canonicalRequest, ByteString
signedHeaderKeys) =
IsStreaming
-> SignParams -> Request -> [Header] -> (ByteString, ByteString)
getCanonicalRequestAndSignedHeaders
IsStreaming
NotStreaming
SignParams
sp
Request
req
[Header]
reqHeaders
stringToSign :: ByteString
stringToSign = UTCTime -> ByteString -> ByteString -> ByteString
mkStringToSign (SignParams -> UTCTime
spTimeStamp SignParams
sp) ByteString
scope ByteString
canonicalRequest
signingKey :: ByteString
signingKey = SignParams -> ByteString
getSigningKey SignParams
sp
signature :: ByteString
signature = ByteString -> ByteString -> ByteString
computeSignature ByteString
stringToSign ByteString
signingKey
authHeader :: Header
authHeader = Text -> ByteString -> ByteString -> ByteString -> Header
mkAuthHeader (SignParams -> Text
spAccessKey SignParams
sp) ByteString
scope ByteString
signedHeaderKeys ByteString
signature
in Header
authHeader forall a. a -> [a] -> [a]
: [Header]
extraHeaders
credentialScope :: SignParams -> ByteString
credentialScope :: SignParams -> ByteString
credentialScope SignParams
sp =
let region :: Text
region = forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$ SignParams -> Maybe Text
spRegion SignParams
sp
in ByteString -> [ByteString] -> ByteString
B.intercalate
ByteString
"/"
[ forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
Time.defaultTimeLocale String
"%Y%m%d" forall a b. (a -> b) -> a -> b
$ SignParams -> UTCTime
spTimeStamp SignParams
sp,
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
region,
Service -> ByteString
toByteString forall a b. (a -> b) -> a -> b
$ SignParams -> Service
spService SignParams
sp,
ByteString
"aws4_request"
]
getHeadersToSign :: [Header] -> [(ByteString, ByteString)]
![Header]
h =
forall a. (a -> Bool) -> [a] -> [a]
filter ((\ByteString
hdr -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
Set.member ByteString
hdr HashSet ByteString
ignoredHeaders) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall s. CI s -> s
CI.foldedCase ByteString -> ByteString
stripBS) [Header]
h
getCanonicalHeaders :: NonEmpty Header -> (ByteString, ByteString)
NonEmpty Header
h =
let
headersToSign :: SimpleQuery
headersToSign =
forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy (\(ByteString, ByteString)
a (ByteString, ByteString)
b -> forall a. Ord a => a -> a -> Ordering
compare (forall a b. (a, b) -> a
fst (ByteString, ByteString)
a) (forall a b. (a, b) -> a
fst (ByteString, ByteString)
b)) forall a b. (a -> b) -> a -> b
$
forall a. [a] -> NonEmpty a
NE.fromList forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter ((\ByteString
hdr -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
Set.member ByteString
hdr HashSet ByteString
ignoredHeaders) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall s. CI s -> s
CI.foldedCase ByteString -> ByteString
stripBS) NonEmpty Header
h
canonicalHeaders :: ByteString
canonicalHeaders = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
a, ByteString
b) -> ByteString
a forall a. Semigroup a => a -> a -> a
<> ByteString
":" forall a. Semigroup a => a -> a -> a
<> ByteString
b forall a. Semigroup a => a -> a -> a
<> ByteString
"\n") SimpleQuery
headersToSign
signedHeaderKeys :: ByteString
signedHeaderKeys = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
";" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst SimpleQuery
headersToSign
in (ByteString
canonicalHeaders, ByteString
signedHeaderKeys)
getCanonicalRequestAndSignedHeaders ::
IsStreaming ->
SignParams ->
NC.Request ->
[Header] ->
(ByteString, ByteString)
getCanonicalRequestAndSignedHeaders :: IsStreaming
-> SignParams -> Request -> [Header] -> (ByteString, ByteString)
getCanonicalRequestAndSignedHeaders IsStreaming
isStreaming SignParams
sp Request
req [Header]
requestHeaders =
let httpMethod :: ByteString
httpMethod = Request -> ByteString
NC.method Request
req
canonicalUri :: ByteString
canonicalUri = forall s. UriEncodable s => Bool -> s -> ByteString
uriEncode Bool
False forall a b. (a -> b) -> a -> b
$ Request -> ByteString
NC.path Request
req
canonicalQueryString :: ByteString
canonicalQueryString =
ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"&" forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
x, ByteString
y) -> [ByteString] -> ByteString
B.concat [ByteString
x, ByteString
"=", ByteString
y]) forall a b. (a -> b) -> a -> b
$
forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map
( forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall s. UriEncodable s => Bool -> s -> ByteString
uriEncode Bool
True) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (forall s. UriEncodable s => Bool -> s -> ByteString
uriEncode Bool
True))
)
(ByteString -> [QueryItem]
parseQuery forall a b. (a -> b) -> a -> b
$ Request -> ByteString
NC.queryString Request
req)
(ByteString
canonicalHeaders, ByteString
signedHeaderKeys) = NonEmpty Header -> (ByteString, ByteString)
getCanonicalHeaders forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList [Header]
requestHeaders
payloadHashStr :: ByteString
payloadHashStr =
case IsStreaming
isStreaming of
IsStreamingLength Int64
_ -> ByteString
"STREAMING-AWS4-HMAC-SHA256-PAYLOAD"
IsStreaming
NotStreaming -> forall a. a -> Maybe a -> a
fromMaybe ByteString
"UNSIGNED-PAYLOAD" forall a b. (a -> b) -> a -> b
$ SignParams -> Maybe ByteString
spPayloadHash SignParams
sp
canonicalRequest :: ByteString
canonicalRequest =
ByteString -> [ByteString] -> ByteString
B.intercalate
ByteString
"\n"
[ ByteString
httpMethod,
ByteString
canonicalUri,
ByteString
canonicalQueryString,
ByteString
canonicalHeaders,
ByteString
signedHeaderKeys,
ByteString
payloadHashStr
]
in (ByteString
canonicalRequest, ByteString
signedHeaderKeys)
mkCanonicalRequest ::
Bool ->
SignParams ->
NC.Request ->
[(ByteString, ByteString)] ->
ByteString
mkCanonicalRequest :: Bool -> SignParams -> Request -> SimpleQuery -> ByteString
mkCanonicalRequest !Bool
isStreaming !SignParams
sp !Request
req !SimpleQuery
headersForSign =
let httpMethod :: ByteString
httpMethod = Request -> ByteString
NC.method Request
req
canonicalUri :: ByteString
canonicalUri = forall s. UriEncodable s => Bool -> s -> ByteString
uriEncode Bool
False forall a b. (a -> b) -> a -> b
$ Request -> ByteString
NC.path Request
req
canonicalQueryString :: ByteString
canonicalQueryString =
ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"&" forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
x, ByteString
y) -> [ByteString] -> ByteString
B.concat [ByteString
x, ByteString
"=", ByteString
y]) forall a b. (a -> b) -> a -> b
$
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(ByteString, ByteString)
a (ByteString, ByteString)
b -> forall a. Ord a => a -> a -> Ordering
compare (forall a b. (a, b) -> a
fst (ByteString, ByteString)
a) (forall a b. (a, b) -> a
fst (ByteString, ByteString)
b)) forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map
( forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall s. UriEncodable s => Bool -> s -> ByteString
uriEncode Bool
True) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (forall s. UriEncodable s => Bool -> s -> ByteString
uriEncode Bool
True))
)
(ByteString -> [QueryItem]
parseQuery forall a b. (a -> b) -> a -> b
$ Request -> ByteString
NC.queryString Request
req)
sortedHeaders :: SimpleQuery
sortedHeaders = forall a. Ord a => [a] -> [a]
sort SimpleQuery
headersForSign
canonicalHeaders :: ByteString
canonicalHeaders =
[ByteString] -> ByteString
B.concat forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
x, ByteString
y) -> [ByteString] -> ByteString
B.concat [ByteString
x, ByteString
":", ByteString
y, ByteString
"\n"]) SimpleQuery
sortedHeaders
signedHeaders :: ByteString
signedHeaders = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
";" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst SimpleQuery
sortedHeaders
payloadHashStr :: ByteString
payloadHashStr =
if Bool
isStreaming
then ByteString
"STREAMING-AWS4-HMAC-SHA256-PAYLOAD"
else forall a. a -> Maybe a -> a
fromMaybe ByteString
"UNSIGNED-PAYLOAD" forall a b. (a -> b) -> a -> b
$ SignParams -> Maybe ByteString
spPayloadHash SignParams
sp
in ByteString -> [ByteString] -> ByteString
B.intercalate
ByteString
"\n"
[ ByteString
httpMethod,
ByteString
canonicalUri,
ByteString
canonicalQueryString,
ByteString
canonicalHeaders,
ByteString
signedHeaders,
ByteString
payloadHashStr
]
mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString
mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString
mkStringToSign UTCTime
ts !ByteString
scope !ByteString
canonicalRequest =
ByteString -> [ByteString] -> ByteString
B.intercalate
ByteString
"\n"
[ ByteString
"AWS4-HMAC-SHA256",
UTCTime -> ByteString
awsTimeFormatBS UTCTime
ts,
ByteString
scope,
ByteString -> ByteString
hashSHA256 ByteString
canonicalRequest
]
getSigningKey :: SignParams -> ByteString
getSigningKey :: SignParams -> ByteString
getSigningKey SignParams
sp =
ByteString -> ByteString -> ByteString
hmacSHA256RawBS ByteString
"aws4_request"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
hmacSHA256RawBS (Service -> ByteString
toByteString forall a b. (a -> b) -> a -> b
$ SignParams -> Service
spService SignParams
sp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
hmacSHA256RawBS (forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$ SignParams -> Maybe Text
spRegion SignParams
sp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
hmacSHA256RawBS (UTCTime -> ByteString
awsDateFormatBS forall a b. (a -> b) -> a -> b
$ SignParams -> UTCTime
spTimeStamp SignParams
sp)
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat [ByteString
"AWS4", forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall a b. (a -> b) -> a -> b
$ SignParams -> ScrubbedBytes
spSecretKey SignParams
sp]
computeSignature :: ByteString -> ByteString -> ByteString
computeSignature :: ByteString -> ByteString -> ByteString
computeSignature !ByteString
toSign !ByteString
key = forall a. ByteArrayAccess a => a -> ByteString
digestToBase16 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> HMAC SHA256
hmacSHA256 ByteString
toSign ByteString
key
signV4PostPolicy ::
ByteString ->
SignParams ->
Map.HashMap Text ByteString
signV4PostPolicy :: ByteString -> SignParams -> HashMap Text ByteString
signV4PostPolicy !ByteString
postPolicyJSON !SignParams
sp =
let stringToSign :: ByteString
stringToSign = ByteString -> ByteString
Base64.encode ByteString
postPolicyJSON
signingKey :: ByteString
signingKey = SignParams -> ByteString
getSigningKey SignParams
sp
signature :: ByteString
signature = ByteString -> ByteString -> ByteString
computeSignature ByteString
stringToSign ByteString
signingKey
in forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList forall a b. (a -> b) -> a -> b
$
[ (Text
"x-amz-signature", ByteString
signature),
(Text
"policy", ByteString
stringToSign)
]
forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList ((forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
amzSecurityToken,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SignParams -> Maybe ScrubbedBytes
spSessionToken SignParams
sp)
chunkSizeConstant :: Int
chunkSizeConstant :: Int
chunkSizeConstant = Int
64 forall a. Num a => a -> a -> a
* Int
1024
base16Len :: (Integral a) => a -> Int
base16Len :: forall a. Integral a => a -> Int
base16Len a
n
| a
n forall a. Eq a => a -> a -> Bool
== a
0 = Int
0
| Bool
otherwise = Int
1 forall a. Num a => a -> a -> a
+ forall a. Integral a => a -> Int
base16Len (a
n forall a. Integral a => a -> a -> a
`div` a
16)
signedStreamLength :: Int64 -> Int64
signedStreamLength :: Int64 -> Int64
signedStreamLength Int64
dataLen =
let chunkSzInt :: Int64
chunkSzInt = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
chunkSizeConstant
(Int64
numChunks, Int64
lastChunkLen) = forall a. Integral a => a -> a -> (a, a)
quotRem Int64
dataLen Int64
chunkSzInt
encodedChunkLen :: a -> a
encodedChunkLen a
csz = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Integral a => a -> Int
base16Len a
csz) forall a. Num a => a -> a -> a
+ a
17 forall a. Num a => a -> a -> a
+ a
64 forall a. Num a => a -> a -> a
+ a
2 forall a. Num a => a -> a -> a
+ a
csz forall a. Num a => a -> a -> a
+ a
2
fullChunkSize :: Int64
fullChunkSize = forall {a}. Integral a => a -> a
encodedChunkLen Int64
chunkSzInt
lastChunkSize :: Int64
lastChunkSize = forall a. a -> a -> Bool -> a
bool Int64
0 (forall {a}. Integral a => a -> a
encodedChunkLen Int64
lastChunkLen) forall a b. (a -> b) -> a -> b
$ Int64
lastChunkLen forall a. Ord a => a -> a -> Bool
> Int64
0
finalChunkSize :: Int64
finalChunkSize = Int64
1 forall a. Num a => a -> a -> a
+ Int64
17 forall a. Num a => a -> a -> a
+ Int64
64 forall a. Num a => a -> a -> a
+ Int64
2 forall a. Num a => a -> a -> a
+ Int64
2
in Int64
numChunks forall a. Num a => a -> a -> a
* Int64
fullChunkSize forall a. Num a => a -> a -> a
+ Int64
lastChunkSize forall a. Num a => a -> a -> a
+ Int64
finalChunkSize
addContentEncoding :: [Header] -> [Header]
addContentEncoding :: [Header] -> [Header]
addContentEncoding [Header]
hs =
let ([Header]
ceHdrs, [Header]
others) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Eq a => a -> a -> Bool
== CI ByteString
hContentEncoding) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [Header]
hs
in forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(CI ByteString
hContentEncoding, ByteString
"aws-chunked")
(\(CI ByteString
k, ByteString
v) -> (CI ByteString
k, ByteString
v forall a. Semigroup a => a -> a -> a
<> ByteString
",aws-chunked"))
(forall a. [a] -> Maybe a
listToMaybe [Header]
ceHdrs)
forall a. a -> [a] -> [a]
: [Header]
others
signV4Stream ::
Int64 ->
SignParams ->
NC.Request ->
(C.ConduitT () ByteString (C.ResourceT IO) () -> NC.Request)
signV4Stream :: Int64
-> SignParams
-> Request
-> ConduitT () ByteString (ResourceT IO) ()
-> Request
signV4Stream !Int64
payloadLength !SignParams
sp !Request
req =
let ts :: UTCTime
ts = SignParams -> UTCTime
spTimeStamp SignParams
sp
signedContentLength :: Int64
signedContentLength = Int64 -> Int64
signedStreamLength Int64
payloadLength
extraHeaders :: [Header]
extraHeaders =
[ (CI ByteString
"X-Amz-Date", UTCTime -> ByteString
awsTimeFormatBS forall a b. (a -> b) -> a -> b
$ SignParams -> UTCTime
spTimeStamp SignParams
sp),
(CI ByteString
"x-amz-decoded-content-length", forall a. Show a => a -> ByteString
showBS Int64
payloadLength),
(CI ByteString
"content-length", forall a. Show a => a -> ByteString
showBS Int64
signedContentLength),
(CI ByteString
"x-amz-content-sha256", ByteString
"STREAMING-AWS4-HMAC-SHA256-PAYLOAD")
]
forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList ((forall s. FoldCase s => s -> CI s
mk ByteString
amzSecurityToken,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SignParams -> Maybe ScrubbedBytes
spSessionToken SignParams
sp)
requestHeaders :: [Header]
requestHeaders =
[Header] -> [Header]
addContentEncoding forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Header -> [Header] -> [Header]
setHeader (Request -> [Header]
NC.requestHeaders Request
req) [Header]
extraHeaders
(ByteString
canonicalReq, ByteString
signedHeaderKeys) =
IsStreaming
-> SignParams -> Request -> [Header] -> (ByteString, ByteString)
getCanonicalRequestAndSignedHeaders
(Int64 -> IsStreaming
IsStreamingLength Int64
payloadLength)
SignParams
sp
Request
req
[Header]
requestHeaders
scope :: ByteString
scope = SignParams -> ByteString
credentialScope SignParams
sp
accessKey :: Text
accessKey = SignParams -> Text
spAccessKey SignParams
sp
stringToSign :: ByteString
stringToSign = UTCTime -> ByteString -> ByteString -> ByteString
mkStringToSign UTCTime
ts ByteString
scope ByteString
canonicalReq
signingKey :: ByteString
signingKey = SignParams -> ByteString
getSigningKey SignParams
sp
seedSignature :: ByteString
seedSignature = ByteString -> ByteString -> ByteString
computeSignature ByteString
stringToSign ByteString
signingKey
authHeader :: Header
authHeader = Text -> ByteString -> ByteString -> ByteString -> Header
mkAuthHeader Text
accessKey ByteString
scope ByteString
signedHeaderKeys ByteString
seedSignature
finalReqHeaders :: [Header]
finalReqHeaders = Header
authHeader forall a. a -> [a] -> [a]
: [Header]
requestHeaders
toHexStr :: t -> ByteString
toHexStr t
n = String -> ByteString
B8.pack forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"%x" t
n
(Int64
numParts, Int64
lastPSize) = Int64
payloadLength forall a. Integral a => a -> a -> (a, a)
`quotRem` forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
chunkSizeConstant
chunkStrToSign :: ByteString -> ByteString -> ByteString
chunkStrToSign ByteString
prevSign ByteString
currChunkHash =
ByteString -> [ByteString] -> ByteString
B.intercalate
ByteString
"\n"
[ ByteString
"AWS4-HMAC-SHA256-PAYLOAD",
UTCTime -> ByteString
awsTimeFormatBS UTCTime
ts,
ByteString
scope,
ByteString
prevSign,
ByteString -> ByteString
hashSHA256 ByteString
"",
ByteString
currChunkHash
]
mustTakeN :: Int -> ConduitT ByteString c m ByteString
mustTakeN Int
n = do
ByteString
bs <- ByteString -> ByteString
LB.toStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
C.takeCE Int
n forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
C.sinkLazy)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
bs forall a. Eq a => a -> a -> Bool
/= Int
n) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO MErrV
MErrVStreamingBodyUnexpectedEOF
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
signerConduit :: t -> a -> ByteString -> ConduitT ByteString ByteString m ()
signerConduit t
n a
lps ByteString
prevSign =
if
| t
n forall a. Ord a => a -> a -> Bool
> t
0 -> do
ByteString
bs <- forall {m :: * -> *} {c}.
MonadIO m =>
Int -> ConduitT ByteString c m ByteString
mustTakeN Int
chunkSizeConstant
let strToSign :: ByteString
strToSign = ByteString -> ByteString -> ByteString
chunkStrToSign ByteString
prevSign (ByteString -> ByteString
hashSHA256 ByteString
bs)
nextSign :: ByteString
nextSign = ByteString -> ByteString -> ByteString
computeSignature ByteString
strToSign ByteString
signingKey
chunkBS :: ByteString
chunkBS =
forall {t}. PrintfArg t => t -> ByteString
toHexStr Int
chunkSizeConstant
forall a. Semigroup a => a -> a -> a
<> ByteString
";chunk-signature="
forall a. Semigroup a => a -> a -> a
<> ByteString
nextSign
forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n"
forall a. Semigroup a => a -> a -> a
<> ByteString
bs
forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n"
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield ByteString
chunkBS
t -> a -> ByteString -> ConduitT ByteString ByteString m ()
signerConduit (t
n forall a. Num a => a -> a -> a
- t
1) a
lps ByteString
nextSign
| a
lps forall a. Ord a => a -> a -> Bool
> a
0 -> do
ByteString
bs <- forall {m :: * -> *} {c}.
MonadIO m =>
Int -> ConduitT ByteString c m ByteString
mustTakeN forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
lps
let strToSign :: ByteString
strToSign = ByteString -> ByteString -> ByteString
chunkStrToSign ByteString
prevSign (ByteString -> ByteString
hashSHA256 ByteString
bs)
nextSign :: ByteString
nextSign = ByteString -> ByteString -> ByteString
computeSignature ByteString
strToSign ByteString
signingKey
chunkBS :: ByteString
chunkBS =
forall {t}. PrintfArg t => t -> ByteString
toHexStr a
lps
forall a. Semigroup a => a -> a -> a
<> ByteString
";chunk-signature="
forall a. Semigroup a => a -> a -> a
<> ByteString
nextSign
forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n"
forall a. Semigroup a => a -> a -> a
<> ByteString
bs
forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n"
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield ByteString
chunkBS
t -> a -> ByteString -> ConduitT ByteString ByteString m ()
signerConduit t
0 a
0 ByteString
nextSign
| Bool
otherwise -> do
let strToSign :: ByteString
strToSign = ByteString -> ByteString -> ByteString
chunkStrToSign ByteString
prevSign (ByteString -> ByteString
hashSHA256 ByteString
"")
nextSign :: ByteString
nextSign = ByteString -> ByteString -> ByteString
computeSignature ByteString
strToSign ByteString
signingKey
lastChunkBS :: ByteString
lastChunkBS = ByteString
"0;chunk-signature=" forall a. Semigroup a => a -> a -> a
<> ByteString
nextSign forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n\r\n"
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield ByteString
lastChunkBS
in \ConduitT () ByteString (ResourceT IO) ()
src ->
Request
req
{ requestHeaders :: [Header]
NC.requestHeaders = [Header]
finalReqHeaders,
requestBody :: RequestBody
NC.requestBody =
Int64 -> ConduitT () ByteString (ResourceT IO) () -> RequestBody
NC.requestBodySource Int64
signedContentLength forall a b. (a -> b) -> a -> b
$
ConduitT () ByteString (ResourceT IO) ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| forall {m :: * -> *} {t} {a}.
(MonadIO m, Ord t, Num t, Integral a, PrintfArg a) =>
t -> a -> ByteString -> ConduitT ByteString ByteString m ()
signerConduit Int64
numParts Int64
lastPSize ByteString
seedSignature
}
setHeader :: Header -> RequestHeaders -> RequestHeaders
Header
hdr [Header]
r =
let r' :: [Header]
r' = forall a. (a -> Bool) -> [a] -> [a]
filter (\(CI ByteString
name, ByteString
_) -> CI ByteString
name forall a. Eq a => a -> a -> Bool
/= forall a b. (a, b) -> a
fst Header
hdr) [Header]
r
in Header
hdr forall a. a -> [a] -> [a]
: [Header]
r'