{-# LANGUAGE BangPatterns #-}
module Network.Minio.Sign.V4 where
import qualified Conduit as C
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 qualified Data.Time as Time
import Lib.Prelude
import qualified Network.HTTP.Conduit as NC
import Network.HTTP.Types (Header, parseQuery)
import qualified Network.HTTP.Types as H
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
=
[ByteString] -> HashSet ByteString
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([ByteString] -> HashSet ByteString)
-> [ByteString] -> HashSet ByteString
forall a b. (a -> b) -> a -> b
$
(CI ByteString -> ByteString) -> [CI ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map
CI ByteString -> ByteString
forall s. CI s -> s
CI.foldedCase
[ CI ByteString
H.hAuthorization,
CI ByteString
H.hContentType,
CI ByteString
H.hUserAgent
]
data SignV4Data = SignV4Data
{ SignV4Data -> UTCTime
sv4SignTime :: UTCTime,
SignV4Data -> ByteString
sv4Scope :: ByteString,
SignV4Data -> ByteString
sv4CanonicalRequest :: ByteString,
:: [(ByteString, ByteString)],
SignV4Data -> [(ByteString, ByteString)]
sv4Output :: [(ByteString, ByteString)],
SignV4Data -> ByteString
sv4StringToSign :: ByteString,
SignV4Data -> ByteString
sv4SigningKey :: ByteString
}
deriving stock (Int -> SignV4Data -> ShowS
[SignV4Data] -> ShowS
SignV4Data -> String
(Int -> SignV4Data -> ShowS)
-> (SignV4Data -> String)
-> ([SignV4Data] -> ShowS)
-> Show SignV4Data
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SignV4Data] -> ShowS
$cshowList :: [SignV4Data] -> ShowS
show :: SignV4Data -> String
$cshow :: SignV4Data -> String
showsPrec :: Int -> SignV4Data -> ShowS
$cshowsPrec :: Int -> SignV4Data -> ShowS
Show)
data SignParams = SignParams
{ SignParams -> Text
spAccessKey :: Text,
SignParams -> Text
spSecretKey :: Text,
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
(Int -> SignParams -> ShowS)
-> (SignParams -> String)
-> ([SignParams] -> ShowS)
-> Show SignParams
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)
debugPrintSignV4Data :: SignV4Data -> IO ()
debugPrintSignV4Data :: SignV4Data -> IO ()
debugPrintSignV4Data (SignV4Data UTCTime
t ByteString
s ByteString
cr [(ByteString, ByteString)]
h2s [(ByteString, ByteString)]
o ByteString
sts ByteString
sk) = do
ByteString -> IO ()
B8.putStrLn ByteString
"SignV4Data:"
ByteString -> IO ()
B8.putStr ByteString
"Timestamp: " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UTCTime -> IO ()
forall a (m :: * -> *). (MonadIO m, Show a) => a -> m ()
print UTCTime
t
ByteString -> IO ()
B8.putStr ByteString
"Scope: " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> IO ()
B8.putStrLn ByteString
s
ByteString -> IO ()
B8.putStrLn ByteString
"Canonical Request:"
ByteString -> IO ()
B8.putStrLn ByteString
cr
ByteString -> IO ()
B8.putStr ByteString
"Headers to Sign: " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(ByteString, ByteString)] -> IO ()
forall a (m :: * -> *). (MonadIO m, Show a) => a -> m ()
print [(ByteString, ByteString)]
h2s
ByteString -> IO ()
B8.putStr ByteString
"Output: " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(ByteString, ByteString)] -> IO ()
forall a (m :: * -> *). (MonadIO m, Show a) => a -> m ()
print [(ByteString, ByteString)]
o
ByteString -> IO ()
B8.putStr ByteString
"StringToSign: " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> IO ()
B8.putStrLn ByteString
sts
ByteString -> IO ()
B8.putStr ByteString
"SigningKey: " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> IO ()
printBytes ByteString
sk
ByteString -> IO ()
B8.putStrLn ByteString
"END of SignV4Data ========="
where
printBytes :: ByteString -> IO ()
printBytes ByteString
b = do
(Word8 -> IO ()) -> [Word8] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Word8
x -> ByteString -> IO ()
B.putStr (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString
B.singleton Word8
x ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" ") ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
B.unpack ByteString
b
ByteString -> IO ()
B8.putStrLn ByteString
""
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=",
Text -> ByteString
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)
signV4 :: SignParams -> NC.Request -> [(ByteString, ByteString)]
signV4 :: SignParams -> Request -> [(ByteString, ByteString)]
signV4 !SignParams
sp !Request
req =
let region :: Text
region = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ SignParams -> Maybe Text
spRegion SignParams
sp
ts :: UTCTime
ts = SignParams -> UTCTime
spTimeStamp SignParams
sp
scope :: ByteString
scope = UTCTime -> Text -> ByteString
mkScope UTCTime
ts Text
region
accessKey :: ByteString
accessKey = Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ SignParams -> Text
spAccessKey SignParams
sp
secretKey :: ByteString
secretKey = Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ SignParams -> Text
spSecretKey SignParams
sp
expiry :: Maybe Int
expiry = SignParams -> Maybe Int
spExpirySecs SignParams
sp
sha256Hdr :: (ByteString, ByteString)
sha256Hdr =
( ByteString
"x-amz-content-sha256",
ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"UNSIGNED-PAYLOAD" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ SignParams -> Maybe ByteString
spPayloadHash SignParams
sp
)
datePair :: (ByteString, ByteString)
datePair = (ByteString
"X-Amz-Date", UTCTime -> ByteString
awsTimeFormatBS UTCTime
ts)
computedHeaders :: [Header]
computedHeaders =
Request -> [Header]
NC.requestHeaders Request
req
[Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ if Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
expiry
then []
else ((ByteString, ByteString) -> Header)
-> [(ByteString, ByteString)] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> CI ByteString) -> (ByteString, ByteString) -> Header
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk) [(ByteString, ByteString)
datePair, (ByteString, ByteString)
sha256Hdr]
headersToSign :: [(ByteString, ByteString)]
headersToSign = [Header] -> [(ByteString, ByteString)]
getHeadersToSign [Header]
computedHeaders
signedHeaderKeys :: ByteString
signedHeaderKeys = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
";" ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. Ord a => [a] -> [a]
sort ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> ByteString)
-> [(ByteString, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst [(ByteString, ByteString)]
headersToSign
authQP :: [(ByteString, ByteString)]
authQP =
[ (ByteString
"X-Amz-Algorithm", ByteString
"AWS4-HMAC-SHA256"),
(ByteString
"X-Amz-Credential", [ByteString] -> ByteString
B.concat [ByteString
accessKey, ByteString
"/", ByteString
scope]),
(ByteString, ByteString)
datePair,
(ByteString
"X-Amz-Expires", ByteString -> (Int -> ByteString) -> Maybe Int -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" Int -> ByteString
forall a. Show a => a -> ByteString
showBS Maybe Int
expiry),
(ByteString
"X-Amz-SignedHeaders", ByteString
signedHeaderKeys)
]
finalQP :: [QueryItem]
finalQP =
ByteString -> [QueryItem]
parseQuery (Request -> ByteString
NC.queryString Request
req)
[QueryItem] -> [QueryItem] -> [QueryItem]
forall a. [a] -> [a] -> [a]
++ if Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
expiry
then (((ByteString, ByteString) -> QueryItem)
-> [(ByteString, ByteString)] -> [QueryItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ByteString, ByteString) -> QueryItem)
-> [(ByteString, ByteString)] -> [QueryItem])
-> ((ByteString -> Maybe ByteString)
-> (ByteString, ByteString) -> QueryItem)
-> (ByteString -> Maybe ByteString)
-> [(ByteString, ByteString)]
-> [QueryItem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Maybe ByteString)
-> (ByteString, ByteString) -> QueryItem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just [(ByteString, ByteString)]
authQP
else []
canonicalRequest :: ByteString
canonicalRequest =
Bool
-> SignParams
-> Request
-> [(ByteString, ByteString)]
-> ByteString
mkCanonicalRequest
Bool
False
SignParams
sp
([QueryItem] -> Request -> Request
NC.setQueryString [QueryItem]
finalQP Request
req)
[(ByteString, ByteString)]
headersToSign
stringToSign :: ByteString
stringToSign = UTCTime -> ByteString -> ByteString -> ByteString
mkStringToSign UTCTime
ts ByteString
scope ByteString
canonicalRequest
signingKey :: ByteString
signingKey = UTCTime -> Text -> ByteString -> ByteString
mkSigningKey UTCTime
ts Text
region ByteString
secretKey
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
output :: [(ByteString, ByteString)]
output =
if Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
expiry
then (ByteString
"X-Amz-Signature", ByteString
signature) (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: [(ByteString, ByteString)]
authQP
else
[ (CI ByteString -> ByteString) -> Header -> (ByteString, ByteString)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CI ByteString -> ByteString
forall s. CI s -> s
CI.foldedCase Header
authHeader,
(ByteString, ByteString)
datePair,
(ByteString, ByteString)
sha256Hdr
]
in [(ByteString, ByteString)]
output
mkScope :: UTCTime -> Text -> ByteString
mkScope :: UTCTime -> Text -> ByteString
mkScope UTCTime
ts Text
region =
ByteString -> [ByteString] -> ByteString
B.intercalate
ByteString
"/"
[ String -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
Time.defaultTimeLocale String
"%Y%m%d" UTCTime
ts,
Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
region,
ByteString
"s3",
ByteString
"aws4_request"
]
getHeadersToSign :: [Header] -> [(ByteString, ByteString)]
![Header]
h =
((ByteString, ByteString) -> Bool)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((\ByteString
hdr -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> HashSet ByteString -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
Set.member ByteString
hdr HashSet ByteString
ignoredHeaders) (ByteString -> Bool)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst) ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$
(Header -> (ByteString, ByteString))
-> [Header] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((CI ByteString -> ByteString)
-> (ByteString -> ByteString) -> Header -> (ByteString, ByteString)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap CI ByteString -> ByteString
forall s. CI s -> s
CI.foldedCase ByteString -> ByteString
stripBS) [Header]
h
mkCanonicalRequest ::
Bool ->
SignParams ->
NC.Request ->
[(ByteString, ByteString)] ->
ByteString
mkCanonicalRequest :: Bool
-> SignParams
-> Request
-> [(ByteString, ByteString)]
-> ByteString
mkCanonicalRequest !Bool
isStreaming !SignParams
sp !Request
req ![(ByteString, ByteString)]
headersForSign =
let canonicalQueryString :: ByteString
canonicalQueryString =
ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"&" ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
((ByteString, ByteString) -> ByteString)
-> [(ByteString, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
x, ByteString
y) -> [ByteString] -> ByteString
B.concat [ByteString
x, ByteString
"=", ByteString
y]) ([(ByteString, ByteString)] -> [ByteString])
-> [(ByteString, ByteString)] -> [ByteString]
forall a b. (a -> b) -> a -> b
$
[(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. Ord a => [a] -> [a]
sort ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$
(QueryItem -> (ByteString, ByteString))
-> [QueryItem] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map
( (ByteString -> ByteString)
-> (Maybe ByteString -> ByteString)
-> QueryItem
-> (ByteString, ByteString)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Bool -> ByteString -> ByteString
forall s. UriEncodable s => Bool -> s -> ByteString
uriEncode Bool
True) (ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (Bool -> ByteString -> ByteString
forall s. UriEncodable s => Bool -> s -> ByteString
uriEncode Bool
True))
)
(ByteString -> [QueryItem]
parseQuery (ByteString -> [QueryItem]) -> ByteString -> [QueryItem]
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
NC.queryString Request
req)
sortedHeaders :: [(ByteString, ByteString)]
sortedHeaders = [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. Ord a => [a] -> [a]
sort [(ByteString, ByteString)]
headersForSign
canonicalHeaders :: ByteString
canonicalHeaders =
[ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
((ByteString, ByteString) -> ByteString)
-> [(ByteString, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
x, ByteString
y) -> [ByteString] -> ByteString
B.concat [ByteString
x, ByteString
":", ByteString
y, ByteString
"\n"]) [(ByteString, ByteString)]
sortedHeaders
signedHeaders :: ByteString
signedHeaders = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
";" ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> ByteString)
-> [(ByteString, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst [(ByteString, ByteString)]
sortedHeaders
payloadHashStr :: ByteString
payloadHashStr =
if Bool
isStreaming
then ByteString
"STREAMING-AWS4-HMAC-SHA256-PAYLOAD"
else ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"UNSIGNED-PAYLOAD" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ SignParams -> Maybe ByteString
spPayloadHash SignParams
sp
in ByteString -> [ByteString] -> ByteString
B.intercalate
ByteString
"\n"
[ Request -> ByteString
NC.method Request
req,
Bool -> ByteString -> ByteString
forall s. UriEncodable s => Bool -> s -> ByteString
uriEncode Bool
False (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
NC.path Request
req,
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
]
mkSigningKey :: UTCTime -> Text -> ByteString -> ByteString
mkSigningKey :: UTCTime -> Text -> ByteString -> ByteString
mkSigningKey UTCTime
ts Text
region !ByteString
secretKey =
ByteString -> ByteString -> ByteString
hmacSHA256RawBS ByteString
"aws4_request"
(ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
hmacSHA256RawBS ByteString
"s3"
(ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
hmacSHA256RawBS (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
region)
(ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
hmacSHA256RawBS (UTCTime -> ByteString
awsDateFormatBS UTCTime
ts)
(ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat [ByteString
"AWS4", ByteString
secretKey]
computeSignature :: ByteString -> ByteString -> ByteString
computeSignature :: ByteString -> ByteString -> ByteString
computeSignature !ByteString
toSign !ByteString
key = HMAC SHA256 -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
digestToBase16 (HMAC SHA256 -> ByteString) -> HMAC SHA256 -> ByteString
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
region :: Text
region = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ SignParams -> Maybe Text
spRegion SignParams
sp
signingKey :: ByteString
signingKey = UTCTime -> Text -> ByteString -> ByteString
mkSigningKey (SignParams -> UTCTime
spTimeStamp SignParams
sp) Text
region (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ SignParams -> Text
spSecretKey SignParams
sp
signature :: ByteString
signature = ByteString -> ByteString -> ByteString
computeSignature ByteString
stringToSign ByteString
signingKey
in [(Text, ByteString)] -> HashMap Text ByteString
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList
[ (Text
"x-amz-signature", ByteString
signature),
(Text
"policy", ByteString
stringToSign)
]
chunkSizeConstant :: Int
chunkSizeConstant :: Int
chunkSizeConstant = Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024
base16Len :: Integral a => a -> Int
base16Len :: a -> Int
base16Len a
n
| a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = Int
0
| Bool
otherwise = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> Int
forall a. Integral a => a -> Int
base16Len (a
n a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
16)
signedStreamLength :: Int64 -> Int64
signedStreamLength :: Int64 -> Int64
signedStreamLength Int64
dataLen =
let chunkSzInt :: Int64
chunkSzInt = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
chunkSizeConstant
(Int64
numChunks, Int64
lastChunkLen) = Int64 -> Int64 -> (Int64, Int64)
forall a. Integral a => a -> a -> (a, a)
quotRem Int64
dataLen Int64
chunkSzInt
encodedChunkLen :: a -> a
encodedChunkLen a
csz = Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int
forall a. Integral a => a -> Int
base16Len a
csz) a -> a -> a
forall a. Num a => a -> a -> a
+ a
17 a -> a -> a
forall a. Num a => a -> a -> a
+ a
64 a -> a -> a
forall a. Num a => a -> a -> a
+ a
2 a -> a -> a
forall a. Num a => a -> a -> a
+ a
csz a -> a -> a
forall a. Num a => a -> a -> a
+ a
2
fullChunkSize :: Int64
fullChunkSize = Int64 -> Int64
forall a. Integral a => a -> a
encodedChunkLen Int64
chunkSzInt
lastChunkSize :: Int64
lastChunkSize = Int64 -> Int64 -> Bool -> Int64
forall a. a -> a -> Bool -> a
bool Int64
0 (Int64 -> Int64
forall a. Integral a => a -> a
encodedChunkLen Int64
lastChunkLen) (Bool -> Int64) -> Bool -> Int64
forall a b. (a -> b) -> a -> b
$ Int64
lastChunkLen Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0
finalChunkSize :: Int64
finalChunkSize = Int64
1 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
17 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
64 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2
in Int64
numChunks Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
fullChunkSize Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
lastChunkSize Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
finalChunkSize
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
addContentEncoding :: [(a, b)] -> [(a, b)]
addContentEncoding [(a, b)]
hs =
let ceMay :: Maybe (a, b)
ceMay = ((a, b) -> Bool) -> [(a, b)] -> Maybe (a, b)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(a
x, b
_) -> a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"content-encoding") [(a, b)]
hs
in case Maybe (a, b)
ceMay of
Maybe (a, b)
Nothing -> (a
"content-encoding", b
"aws-chunked") (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
hs
Just (a
_, b
ce) ->
(a
"content-encoding", b
ce b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
",aws-chunked")
(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: ((a, b) -> Bool) -> [(a, b)] -> [(a, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
x, b
_) -> a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
"content-encoding") [(a, b)]
hs
datePair :: Header
datePair = (CI ByteString
"X-Amz-Date", UTCTime -> ByteString
awsTimeFormatBS UTCTime
ts)
computedHeaders :: [Header]
computedHeaders =
[Header] -> [Header]
forall a b.
(Eq a, IsString a, IsString b, Semigroup b) =>
[(a, b)] -> [(a, b)]
addContentEncoding ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$
Header
datePair Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: Request -> [Header]
NC.requestHeaders Request
req
signedContentLength :: Int64
signedContentLength = Int64 -> Int64
signedStreamLength Int64
payloadLength
streamingHeaders :: [Header]
streamingHeaders :: [Header]
streamingHeaders =
[ (CI ByteString
"x-amz-decoded-content-length", Int64 -> ByteString
forall a. Show a => a -> ByteString
showBS Int64
payloadLength),
(CI ByteString
"content-length", Int64 -> ByteString
forall a. Show a => a -> ByteString
showBS Int64
signedContentLength),
(CI ByteString
"x-amz-content-sha256", ByteString
"STREAMING-AWS4-HMAC-SHA256-PAYLOAD")
]
headersToSign :: [(ByteString, ByteString)]
headersToSign = [Header] -> [(ByteString, ByteString)]
getHeadersToSign ([Header] -> [(ByteString, ByteString)])
-> [Header] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ [Header]
computedHeaders [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header]
streamingHeaders
signedHeaderKeys :: ByteString
signedHeaderKeys = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
";" ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. Ord a => [a] -> [a]
sort ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> ByteString)
-> [(ByteString, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst [(ByteString, ByteString)]
headersToSign
finalQP :: [QueryItem]
finalQP = ByteString -> [QueryItem]
parseQuery (Request -> ByteString
NC.queryString Request
req)
canonicalReq :: ByteString
canonicalReq =
Bool
-> SignParams
-> Request
-> [(ByteString, ByteString)]
-> ByteString
mkCanonicalRequest
Bool
True
SignParams
sp
([QueryItem] -> Request -> Request
NC.setQueryString [QueryItem]
finalQP Request
req)
[(ByteString, ByteString)]
headersToSign
region :: Text
region = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ SignParams -> Maybe Text
spRegion SignParams
sp
scope :: ByteString
scope = UTCTime -> Text -> ByteString
mkScope UTCTime
ts Text
region
accessKey :: Text
accessKey = SignParams -> Text
spAccessKey SignParams
sp
secretKey :: Text
secretKey = SignParams -> Text
spSecretKey SignParams
sp
stringToSign :: ByteString
stringToSign = UTCTime -> ByteString -> ByteString -> ByteString
mkStringToSign UTCTime
ts ByteString
scope ByteString
canonicalReq
signingKey :: ByteString
signingKey = UTCTime -> Text -> ByteString -> ByteString
mkSigningKey UTCTime
ts Text
region (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
secretKey
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 Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: ([Header]
computedHeaders [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header]
streamingHeaders)
toHexStr :: t -> ByteString
toHexStr t
n = String -> ByteString
B8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> t -> String
forall r. PrintfType r => String -> r
printf String
"%x" t
n
(Int64
numParts, Int64
lastPSize) = Int64
payloadLength Int64 -> Int64 -> (Int64, Int64)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int -> Int64
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 (ByteString -> ByteString)
-> ConduitT ByteString c m ByteString
-> ConduitT ByteString c m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Index ByteString -> ConduitT ByteString ByteString m ()
forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
C.takeCE Int
Index ByteString
n ConduitT ByteString ByteString m ()
-> ConduitT ByteString c m ByteString
-> ConduitT ByteString c m ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
C..| ConduitT ByteString c m ByteString
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
C.sinkLazy)
Bool -> ConduitT ByteString c m () -> ConduitT ByteString c m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n) (ConduitT ByteString c m () -> ConduitT ByteString c m ())
-> ConduitT ByteString c m () -> ConduitT ByteString c m ()
forall a b. (a -> b) -> a -> b
$
MErrV -> ConduitT ByteString c m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO MErrV
MErrVStreamingBodyUnexpectedEOF
ByteString -> ConduitT ByteString c m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
signerConduit :: Int64
-> Int64
-> ByteString
-> ConduitT ByteString ByteString (ResourceT IO) ()
signerConduit Int64
n Int64
lps ByteString
prevSign =
if
| Int64
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0 -> do
ByteString
bs <- Int -> ConduitT ByteString ByteString (ResourceT IO) ByteString
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 =
Int -> ByteString
forall t. PrintfArg t => t -> ByteString
toHexStr Int
chunkSizeConstant
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
";chunk-signature="
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
nextSign
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n"
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
bs
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n"
ByteString -> ConduitT ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield ByteString
chunkBS
Int64
-> Int64
-> ByteString
-> ConduitT ByteString ByteString (ResourceT IO) ()
signerConduit (Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
1) Int64
lps ByteString
nextSign
| Int64
lps Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0 -> do
ByteString
bs <- Int -> ConduitT ByteString ByteString (ResourceT IO) ByteString
forall (m :: * -> *) c.
MonadIO m =>
Int -> ConduitT ByteString c m ByteString
mustTakeN (Int -> ConduitT ByteString ByteString (ResourceT IO) ByteString)
-> Int -> ConduitT ByteString ByteString (ResourceT IO) ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
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 =
Int64 -> ByteString
forall t. PrintfArg t => t -> ByteString
toHexStr Int64
lps
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
";chunk-signature="
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
nextSign
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n"
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
bs
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n"
ByteString -> ConduitT ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield ByteString
chunkBS
Int64
-> Int64
-> ByteString
-> ConduitT ByteString ByteString (ResourceT IO) ()
signerConduit Int64
0 Int64
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=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
nextSign ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n\r\n"
ByteString -> ConduitT ByteString ByteString (ResourceT IO) ()
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 (ConduitT () ByteString (ResourceT IO) () -> RequestBody)
-> ConduitT () ByteString (ResourceT IO) () -> RequestBody
forall a b. (a -> b) -> a -> b
$
ConduitT () ByteString (ResourceT IO) ()
src ConduitT () ByteString (ResourceT IO) ()
-> ConduitT ByteString ByteString (ResourceT IO) ()
-> ConduitT () ByteString (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
C..| Int64
-> Int64
-> ByteString
-> ConduitT ByteString ByteString (ResourceT IO) ()
signerConduit Int64
numParts Int64
lastPSize ByteString
seedSignature
}