Moves from Signature V2 to Signature V4 for S3

Aws/Aws.hs

@@ -239,6 +239,7 @@ unsafeAwsRef cfg info manager metadataRef request = do
   logDebug $ "Host: " ++ show (HTTP.host httpRequest)
   logDebug $ "Path: " ++ show (HTTP.path httpRequest)
   logDebug $ "Query string: " ++ show (HTTP.queryString httpRequest)
+  logDebug $ "Header: " ++ show (HTTP.requestHeaders httpRequest)
   case HTTP.requestBody httpRequest of
     HTTP.RequestBodyLBS lbs -> logDebug $ "Body: " ++ show (L.take 1000 lbs)
     HTTP.RequestBodyBS bs -> logDebug $ "Body: " ++ show (B.take 1000 bs)

Aws/Core.hs

@@ -50,7 +50,10 @@ module Aws.Core
 , AuthorizationHash(..)
 , amzHash
 , signature
+, credentialV4
 , authorizationV4
+, authorizationV4'
+, signatureV4
   -- ** Query construction helpers
 , queryList
 , awsBool
@@ -601,6 +604,23 @@ signature cr ah input = Base64.encode sig
       computeSig :: HashAlgorithm a => a -> ByteString
       computeSig t = toBytes (hmacAlg t (secretAccessKey cr) input)
 
+-- | Generates the Credential string, required for V4 signatures.
+credentialV4 :: SignatureData
+             -> B.ByteString -- ^ region, e.g. us-east-1
+             -> B.ByteString -- ^ service, e.g. dynamodb
+             -> B.ByteString
+credentialV4 sd region service =
+  B.concat [ accessKeyID (signatureCredentials sd)
+           , "/"
+           , date
+           , "/"
+           , region
+           , "/"
+           , service
+           , "/aws4_request"
+           ]
+  where date = fmtTime "%Y%m%d" $ signatureTime sd
+
 -- | Use this to create the Authorization header to set into 'sqAuthorization'.
 -- See <http://docs.aws.amazon.com/general/latest/gr/signature-version-4.html>: you must create the
 -- canonical request as explained by Step 1 and this function takes care of Steps 2 and 3.
@@ -663,20 +683,80 @@ authorizationV4 sd ah region service headers canonicalRequest = do
     -- finally, return the header
     return $ B.concat [ alg
                       , " Credential="
-                      , accessKeyID (signatureCredentials sd)
-                      , "/"
-                      , date
-                      , "/"
-                      , region
-                      , "/"
-                      , service
-                      , "/aws4_request,"
-                      , "SignedHeaders="
+                      , credentialV4 sd region service
+                      , ",SignedHeaders="
                       , headers
                       , ",Signature="
                       , sig
                       ]
 
+-- | Compute the signature for V4
+signatureV4 :: SignatureData
+            -> AuthorizationHash
+            -> B.ByteString -- ^ region, e.g. us-east-1
+            -> B.ByteString -- ^ service, e.g. dynamodb
+            -> B.ByteString -- ^ canonicalRequest (before hashing)
+            -> B.ByteString
+signatureV4 sd ah region service canonicalRequest = do
+    let date = fmtTime "%Y%m%d" $ signatureTime sd
+        mkHmac k i = case ah of
+                        HmacSHA1 -> toBytes (hmac k i :: HMAC SHA1)
+                        HmacSHA256 -> toBytes (hmac k i :: HMAC SHA256)
+        mkHash i = case ah of
+                        HmacSHA1 -> toBytes (hash i :: Digest SHA1)
+                        HmacSHA256 -> toBytes (hash i :: Digest SHA256)
+        alg = case ah of
+                    HmacSHA1 -> "AWS4-HMAC-SHA1"
+                    HmacSHA256 -> "AWS4-HMAC-SHA256"
+
+    -- create a new signing key
+    let key = let secretKey = secretAccessKey $ signatureCredentials sd
+                  kDate = mkHmac ("AWS4" <> secretKey) date
+                  kRegion = mkHmac kDate region
+                  kService = mkHmac kRegion service
+                  kSigning = mkHmac kService "aws4_request"
+               in kSigning
+
+    -- now do the signature
+    let canonicalRequestHash = Base16.encode $ mkHash canonicalRequest
+        stringToSign = B.concat [ alg
+                                , "\n"
+                                , fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime sd
+                                , "\n"
+                                , date
+                                , "/"
+                                , region
+                                , "/"
+                                , service
+                                , "/aws4_request\n"
+                                , canonicalRequestHash
+                                ]
+    Base16.encode $ mkHmac key stringToSign
+
+-- | IO free version of @authorizationV4@, us this if you need
+-- to compute the signature outside of IO.
+authorizationV4' :: SignatureData
+                 -> AuthorizationHash
+                 -> B.ByteString -- ^ region, e.g. us-east-1
+                 -> B.ByteString -- ^ service, e.g. dynamodb
+                 -> B.ByteString -- ^ SignedHeaders, e.g. content-type;host;x-amz-date;x-amz-target
+                 -> B.ByteString -- ^ canonicalRequest (before hashing)
+                 -> B.ByteString
+authorizationV4' sd ah region service headers canonicalRequest = do
+    let alg = case ah of
+                    HmacSHA1 -> "AWS4-HMAC-SHA1"
+                    HmacSHA256 -> "AWS4-HMAC-SHA256"
+
+    -- finally, return the header
+    B.concat [ alg
+             , " Credential="
+             , credentialV4 sd region service
+             , ",SignedHeaders="
+             , headers
+             , ",Signature="
+             , signatureV4 sd ah region service canonicalRequest
+             ]
+
 -- | Default configuration for a specific service.
 class DefaultServiceConfiguration config where
     -- | Default service configuration.

Aws/S3/Commands/PutObject.hs

@@ -7,6 +7,8 @@ import           Aws.S3.Core
 import           Control.Applicative
 import           Control.Arrow         (second)
 import           Crypto.Hash
+import           Data.Byteable
+import qualified Data.ByteString.Base16 as Base16
 import           Data.ByteString.Char8 ({- IsString -})
 import           Data.Maybe
 import qualified Data.ByteString.Char8 as B
@@ -23,6 +25,7 @@ data PutObject = PutObject {
   poContentDisposition :: Maybe T.Text,
   poContentEncoding :: Maybe T.Text,
   poContentMD5 :: Maybe (Digest MD5),
+  poContentSHA256 :: Maybe (Digest SHA256),
   poExpires :: Maybe Int,
   poAcl :: Maybe CannedAcl,
   poStorageClass :: Maybe StorageClass,
@@ -43,7 +46,7 @@ putObject :: Bucket -> T.Text -> HTTP.RequestBody -> PutObject
 #else
 putObject :: Bucket -> T.Text -> HTTP.RequestBody (C.ResourceT IO) -> PutObject
 #endif
-putObject bucket obj body = PutObject obj bucket Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing body [] False False
+putObject bucket obj body = PutObject obj bucket Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing body [] False False
 
 data PutObjectResponse
   = PutObjectResponse {
@@ -61,13 +64,13 @@ instance SignQuery PutObject where
                                , s3QQuery = []
                                , s3QContentType = poContentType
                                , s3QContentMd5 = poContentMD5
-                               , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [
+                               , s3QAmzHeaders = sha256Header:(map (second T.encodeUtf8) $ catMaybes [
                                               ("x-amz-acl",) <$> writeCannedAcl <$> poAcl
                                             , ("x-amz-storage-class",) <$> writeStorageClass <$> poStorageClass
                                             , ("x-amz-website-redirect-location",) <$> poWebsiteRedirectLocation
                                             , ("x-amz-server-side-encryption",) <$> writeServerSideEncryption <$> poServerSideEncryption
 					    , if poAutoMakeBucket then Just ("x-amz-auto-make-bucket", "1")  else Nothing
-                                            ] ++ map( \x -> (CI.mk . T.encodeUtf8 $ T.concat ["x-amz-meta-", fst x], snd x)) poMetadata
+                                            ] ++ map( \x -> (CI.mk . T.encodeUtf8 $ T.concat ["x-amz-meta-", fst x], snd x)) poMetadata)
                                , s3QOtherHeaders = map (second T.encodeUtf8) $ catMaybes [
                                               ("Expires",) . T.pack . show <$> poExpires
                                             , ("Cache-Control",) <$> poCacheControl
@@ -80,6 +83,7 @@ instance SignQuery PutObject where
                                , s3QRequestBody = Just poRequestBody
                                , s3QObject = Just $ T.encodeUtf8 poObjectName
                                }
+      where sha256Header = (hAmzContentSha256, fromMaybe "UNSIGNED-PAYLOAD" (Base16.encode . toBytes <$> poContentSHA256))
 
 instance ResponseConsumer PutObject PutObjectResponse where
     type ResponseMetadata PutObjectResponse = S3Metadata