diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +0.1 +=== + +First public version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 AlephCloud Systems, Inc. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,40 @@ +[![Build Status](https://travis-ci.org/alephcloud/hs-aws-general.svg?branch=master)](https://travis-ci.org/alephcloud/hs-aws-general) + + +Haskell Bindings for Amazon AWS General API +=========================================== + +*API Version 0.1* + +[Amazon AWS General API Reference](http://docs.aws.amazon.com/general/latest/gr/) + +Installation +============ + +Assuming that the Haskell compiler *GHC* and the Haskell build tool *cabal* is +already installed run the following command from the shell: + +~~~{.sh} +cabal install --enable-tests +~~~ + +Running Tests +============= + +~~~{.sh} +cabal test +~~~ + +Normalization of the date header breaks the AWS test suite, since the tests in +that test suite use an invalid date. + +Date normalization is enabled by default but can be turned of via the cabal +(compiletime) flag `normalize-signature-v4-date`. When date normalization is +enabled the official AWS Signature V4 test-suite is skipped excluded from the +tests. In order to include this test-suite run the following shell commands: + +~~~{.sh} +cabal configure --enable-tests -f-normalize-signature-v4-date +cabal test +~~~ + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/aws-general.cabal b/aws-general.cabal new file mode 100644 --- /dev/null +++ b/aws-general.cabal @@ -0,0 +1,119 @@ +-- ------------------------------------------------------ -- +-- Copyright © 2014 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +Name: aws-general +Version: 0.1 +Synopsis: Bindings for AWS General API Version 0.1 +description: + Bindings for AWS General API including AWS Signature V4. + . + /API Version: 1.0/ + . + + +Homepage: https://github.com/alephcloud/hs-aws-general +Bug-reports: https://github.com/alephcloud/hs-aws-general/issues +License: MIT +License-file: LICENSE +Author: Lars Kuhtz +Maintainer: Lars Kuhtz +Copyright: Copyright (c) 2014 AlephCloud, Inc. +Category: Network, Web, AWS, Cloud, Distributed Computing +Build-type: Simple + +cabal-version: >= 1.18 + +extra-doc-files: + README.md, + CHANGELOG.md + +extra-source-files: + constraints + +source-repository head + type: git + location: https://github.com/alephcloud/hs-aws-general.git + +source-repository this + type: git + location: https://github.com/alephcloud/hs-aws-general.git + tag: 0.1 + +flag normalize-signature-v4-date + Description: + Normalize the date according to the AWS SignatureV4 specification. + . + Using this flags breaks the AWS SignatureV4 test suite, + since the tests in that test suite use an invalid date. + default: True + +Library + default-language: Haskell2010 + hs-source-dirs: src + + exposed-modules: + Aws.General + Aws.SignatureV4 + + build-depends: + QuickCheck >= 2.7, + aeson >= 0.7, + attoparsec >= 0.12, + base >= 4.6 && < 5.0, + base16-bytestring >= 0.1, + blaze-builder >= 0.3, + byteable >= 0.1, + bytestring >= 0.10.0.2, + case-insensitive >= 1.2, + cryptohash >= 0.11, + hashable >= 1.2, + http-types >= 0.8, + old-locale >= 1.0, + parsers >= 0.11, + quickcheck-instances >= 0.3, + text >= 1.1, + time >= 1.4, + transformers >= 0.3 + + ghc-options: -Wall + + if flag(normalize-signature-v4-date) + cpp-options: -DSIGN_V4_NORMALIZE_DATE + +test-suite signature-v4 + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: tests + + other-modules: + SignatureV4 + General + + build-depends: + base == 4.*, + aws >= 0.9, + aws-general, + bytestring >= 0.10, + QuickCheck, + quickcheck-instances, + parsers >= 0.12, + charset >= 0.3, + errors >= 1.4.7, + either >= 4.3.0, + transformers >= 0.3, + directory >= 1.2, + attoparsec >= 0.12, + http-types >= 0.8, + case-insensitive >= 1.2, + tasty >= 0.8, + tasty-quickcheck >= 0.8, + text >= 1.1, + time >= 1.4, + tagged >= 0.7 + + ghc-options: -Wall -threaded + + + diff --git a/constraints b/constraints new file mode 100644 --- /dev/null +++ b/constraints @@ -0,0 +1,41 @@ +constraints: QuickCheck ==2.7.5, + aeson ==0.7.0.6, + array ==0.5.0.0, + attoparsec ==0.12.1.0, + aws-general ==0.1, + base ==4.7.0.1, + base16-bytestring ==0.1.1.6, + blaze-builder ==0.3.3.2, + byteable ==0.1.1, + bytestring ==0.10.4.0, + case-insensitive ==1.2.0.0, + charset ==0.3.7, + containers ==0.5.5.1, + cryptohash ==0.11.6, + deepseq ==1.3.0.2, + dlist ==0.7.1, + ghc-prim ==0.3.1.0, + hashable ==1.2.2.0, + http-types ==0.8.5, + integer-gmp ==0.5.1.0, + mtl ==2.1.3.1, + nats ==0.2, + old-locale ==1.0.0.6, + old-time ==1.1.0.2, + parsec ==3.1.5, + parsers ==0.12, + pretty ==1.1.1.1, + primitive ==0.5.3.0, + quickcheck-instances ==0.3.8, + random ==1.0.1.1, + rts ==1.0, + scientific ==0.3.3.0, + semigroups ==0.15.1, + syb ==0.4.2, + template-haskell ==2.9.0.0, + text ==1.1.1.3, + tf-random ==0.5, + time ==1.4.2, + transformers ==0.3.0.0, + unordered-containers ==0.2.5.0, + vector ==0.10.11.0 diff --git a/src/Aws/General.hs b/src/Aws/General.hs new file mode 100644 --- /dev/null +++ b/src/Aws/General.hs @@ -0,0 +1,453 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: Aws.General +-- Copyright: Copyright © 2014 AlephCloud Systems, Inc. +-- License: BSD3 +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- Bindings for AWS General Reference +-- +-- /API Version: 1.0/ +-- +-- +-- +module Aws.General +( AwsType(..) + +-- * AWS General Version +, GeneralVersion(..) +, generalVersionToText +, parseGeneralVersion + +-- * SignatureVersion +, SignatureVersion(..) +, signatureVersionToText +, parseSignatureVersion + +-- * SignatureMethod +, SignatureMethod(..) +, signatureMethodToText +, parseSignatureMethod + +-- * AWS Region +, Region(..) +, regionToText +, parseRegion + +-- * AWS Account ID +, AccountId(..) +, accountIdToText +, parseAccountId + +-- * AWS Canonical User ID +, CanonicalUserId(..) +, canonicalUserIdToText +, parseCanonicalUserId + +-- * AWS Service Namespace +, ServiceNamespace(..) +, serviceNamespaceToText +, parseServiceNamespace + +-- * AWS ARN +, Arn(..) +, arnToText +, parseArn +) where + +import Control.Applicative +import Control.Monad + +import Data.Aeson (ToJSON(..), FromJSON(..), withText) +import qualified Data.Attoparsec.Text as AP +import Data.Hashable (Hashable, hashWithSalt, hashUsing) +import Data.Monoid +import Data.String +import qualified Data.Text as T +import Data.Typeable + +import qualified Test.QuickCheck as Q +import Test.QuickCheck.Instances () + +import qualified Text.Parser.Char as P +import qualified Text.Parser.Combinators as P +import Text.Parser.Combinators (()) +import Text.Printf + +-- -------------------------------------------------------------------------- -- +-- AWS Type + +class AwsType a where + toText :: (IsString b, Monoid b) => a -> b + parse :: (Monad m, P.CharParsing m) => m a + + fromText :: T.Text -> Either String a + fromText = AP.parseOnly $ parse <* P.eof + +-- -------------------------------------------------------------------------- -- +-- General API Version + +data GeneralVersion + = GeneralVersion_1_0 + deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable) + +generalVersionToText :: (IsString a) => GeneralVersion -> a +generalVersionToText GeneralVersion_1_0 = "1.0" + +parseGeneralVersion :: P.CharParsing m => m GeneralVersion +parseGeneralVersion = GeneralVersion_1_0 <$ P.text "1.0" + "General Version" + +instance AwsType GeneralVersion where + toText = generalVersionToText + parse = parseGeneralVersion + +instance Q.Arbitrary GeneralVersion where + arbitrary = Q.elements [minBound..maxBound] + +-- -------------------------------------------------------------------------- -- +-- Signature Version + +data SignatureVersion + = SignatureVersion2 + | SignatureVersion4 + deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable) + +signatureVersionToText :: IsString a => SignatureVersion -> a +signatureVersionToText SignatureVersion2 = "2" +signatureVersionToText SignatureVersion4 = "4" + +parseSignatureVersion :: P.CharParsing m => m SignatureVersion +parseSignatureVersion = + SignatureVersion2 <$ P.text "2" + <|> SignatureVersion4 <$ P.text "4" + "SignatureVersion" + +instance AwsType SignatureVersion where + toText = signatureVersionToText + parse = parseSignatureVersion + +instance Q.Arbitrary SignatureVersion where + arbitrary = Q.elements [minBound..maxBound] + +-- -------------------------------------------------------------------------- -- +-- Signature Method + +data SignatureMethod + = SignatureMethodSha1 + | SignatureMethodSha256 + deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable) + +signatureMethodToText :: IsString a => SignatureMethod -> a +signatureMethodToText SignatureMethodSha1 = "HmacSHA1" +signatureMethodToText SignatureMethodSha256 = "HmacSHA256" + +parseSignatureMethod :: P.CharParsing m => m SignatureMethod +parseSignatureMethod = + SignatureMethodSha1 <$ P.text "HmacSHA1" + <|> SignatureMethodSha256 <$ P.text "HmacSHA256" + "SignatureMethod" + +instance AwsType SignatureMethod where + toText = signatureMethodToText + parse = parseSignatureMethod + +instance Q.Arbitrary SignatureMethod where + arbitrary = Q.elements [minBound..maxBound] + +-- -------------------------------------------------------------------------- -- +-- AWS Region + +-- | Region +-- +-- +-- +-- The relation between regions and service endpoints is not bijective for all +-- AWS services. Not all AWS services support all regions. Some services don't +-- use the concept of region at all. +-- +data Region + = ApNortheast1 + | ApSoutheast1 + | ApSoutheast2 + | EuWest1 + | SaEast1 + | UsEast1 + | UsWest1 + | UsWest2 + deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable) + +regionToText :: IsString a => Region -> a +regionToText ApNortheast1 = "ap-northeast-1" +regionToText ApSoutheast1 = "ap-southeast-1" +regionToText ApSoutheast2 = "ap-southeast-2" +regionToText EuWest1 = "eu-west-1" +regionToText SaEast1 = "sa-east-1" +regionToText UsEast1 = "us-east-1" +regionToText UsWest1 = "us-west-1" +regionToText UsWest2 = "us-west-2" + +parseRegion :: P.CharParsing m => m Region +parseRegion = + ApNortheast1 <$ P.text "ap-northeast-1" + <|> ApSoutheast1 <$ P.text "ap-southeast-1" + <|> ApSoutheast2 <$ P.text "ap-southeast-2" + <|> EuWest1 <$ P.text "eu-west-1" + <|> SaEast1 <$ P.text "sa-east-1" + <|> UsEast1 <$ P.text "us-east-1" + <|> UsWest1 <$ P.text "us-west-1" + <|> UsWest2 <$ P.text "us-west-2" + "Region" + +instance AwsType Region where + toText = regionToText + parse = parseRegion + +{- +instance FromJSON Ec2Region where + parseJSON = withText "Ec2Region" $ either fail return ∘ readEither ∘ T.unpack + +instance ToJSON Ec2Region where + toJSON = toJSON ∘ show +-} + +instance Hashable Region where + hashWithSalt = hashUsing fromEnum + +instance Q.Arbitrary Region where + arbitrary = Q.elements [minBound..maxBound] + +-- -------------------------------------------------------------------------- -- +-- AWS Account Id + +-- | AWS Account Id +-- +-- . +-- +-- This is actually a 12 digit number. +-- +newtype AccountId = AccountId T.Text + deriving (Show, Read, Eq, Ord, IsString, Typeable) + +accountIdToText :: (IsString a) => AccountId -> a +accountIdToText (AccountId t) = fromString $ T.unpack t + +parseAccountId :: P.CharParsing m => m AccountId +parseAccountId = AccountId . T.pack + <$> P.count 12 P.digit + "Account ID" + +instance AwsType AccountId where + toText = accountIdToText + parse = parseAccountId + +instance Q.Arbitrary AccountId where + arbitrary = AccountId . T.pack . printf "%012d" <$> Q.choose (0::Integer, 999999999999) + +-- -------------------------------------------------------------------------- -- +-- AWS Canonical User ID + +-- | AWS Canonical User ID +-- +-- . +-- +-- This is actually a long hexadecimal number +-- +newtype CanonicalUserId = CanonicalUserId T.Text + deriving (Show, Read, Eq, Ord, IsString, Typeable) + +canonicalUserIdToText :: (IsString a) => CanonicalUserId -> a +canonicalUserIdToText (CanonicalUserId t) = fromString $ T.unpack t + +parseCanonicalUserId :: P.CharParsing m => m CanonicalUserId +parseCanonicalUserId = CanonicalUserId . T.pack + <$> some P.hexDigit + "Canonical User ID" + +instance AwsType CanonicalUserId where + toText = canonicalUserIdToText + parse = parseCanonicalUserId + +instance Q.Arbitrary CanonicalUserId where + arbitrary = CanonicalUserId . T.pack <$> do + i <- Q.choose (32,128) + replicateM i (Q.elements $ ['0'..'9'] <> ['a'..'f']) + +-- -------------------------------------------------------------------------- -- +-- Service Namespace + +-- | AWS Service Namespaces +-- +-- +-- +data ServiceNamespace + = ServiceNamespaceAwsPortal + | ServiceNamespaceAutoscaling + | ServiceNamespaceCloudformation + | ServiceNamespaceCloudfront + | ServiceNamespaceCloudwatch + | ServiceNamespaceDynamodb + | ServiceNamespaceEc2 + -- ^ Amazon EC2 and Amazon VPC + | ServiceNamespaceElasticbeanstalk + | ServiceNamespaceElasticloadbalancing + | ServiceNamespaceElasticmapreduce + | ServiceNamespaceElasticache + | ServiceNamespaceGlacier + | ServiceNamespaceIam + | ServiceNamespaceKinesis + | ServiceNamespaceAwsMarketplaceManagement + | ServiceNamespaceOpsworks + | ServiceNamespaceRds + | ServiceNamespaceRedshift + | ServiceNamespaceRoute53 + | ServiceNamespaceS3 + | ServiceNamespaceSes + | ServiceNamespaceSdb + | ServiceNamespaceSqs + | ServiceNamespaceSns + | ServiceNamespaceStoragegateway + | ServiceNamespaceSts + | ServiceNamespaceSupport + | ServiceNamespaceSwf + | ServiceNamespaceHost + -- ^ For testing purposes (see ) + deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable) + +serviceNamespaceToText :: IsString a => ServiceNamespace -> a +serviceNamespaceToText ServiceNamespaceAwsPortal = "aws-portal" +serviceNamespaceToText ServiceNamespaceAutoscaling = "autoscaling" +serviceNamespaceToText ServiceNamespaceCloudformation = "cloudformation" +serviceNamespaceToText ServiceNamespaceCloudfront = "cloudfront" +serviceNamespaceToText ServiceNamespaceCloudwatch = "cloudwatch" +serviceNamespaceToText ServiceNamespaceDynamodb = "dynamodb" +serviceNamespaceToText ServiceNamespaceEc2 = "ec2" +serviceNamespaceToText ServiceNamespaceElasticbeanstalk = "elasticbeanstalk" +serviceNamespaceToText ServiceNamespaceElasticloadbalancing = "elasticloadbalancing" +serviceNamespaceToText ServiceNamespaceElasticmapreduce = "elasticmapreduce" +serviceNamespaceToText ServiceNamespaceElasticache = "elasticache" +serviceNamespaceToText ServiceNamespaceGlacier = "glacier" +serviceNamespaceToText ServiceNamespaceIam = "iam" +serviceNamespaceToText ServiceNamespaceKinesis = "kinesis" +serviceNamespaceToText ServiceNamespaceAwsMarketplaceManagement = "aws-marketplace-management" +serviceNamespaceToText ServiceNamespaceOpsworks = "opsworks" +serviceNamespaceToText ServiceNamespaceRds = "rds" +serviceNamespaceToText ServiceNamespaceRedshift = "redshift" +serviceNamespaceToText ServiceNamespaceRoute53 = "route53" +serviceNamespaceToText ServiceNamespaceS3 = "s3" +serviceNamespaceToText ServiceNamespaceSes = "ses" +serviceNamespaceToText ServiceNamespaceSdb = "sdb" +serviceNamespaceToText ServiceNamespaceSqs = "sqs" +serviceNamespaceToText ServiceNamespaceSns = "sns" +serviceNamespaceToText ServiceNamespaceStoragegateway = "storagegateway" +serviceNamespaceToText ServiceNamespaceSts = "sts" +serviceNamespaceToText ServiceNamespaceSupport = "support" +serviceNamespaceToText ServiceNamespaceSwf = "swf" +serviceNamespaceToText ServiceNamespaceHost = "host" + +parseServiceNamespace :: P.CharParsing m => m ServiceNamespace +parseServiceNamespace = + ServiceNamespaceAwsPortal <$ P.text "aws-portal" + <|> ServiceNamespaceAutoscaling <$ P.text "autoscaling" + <|> ServiceNamespaceCloudformation <$ P.text "cloudformation" + <|> ServiceNamespaceCloudfront <$ P.text "cloudfront" + <|> ServiceNamespaceCloudwatch <$ P.text "cloudwatch" + <|> ServiceNamespaceDynamodb <$ P.text "dynamodb" + <|> ServiceNamespaceEc2 <$ P.text "ec2" + <|> ServiceNamespaceElasticbeanstalk <$ P.text "elasticbeanstalk" + <|> ServiceNamespaceElasticloadbalancing <$ P.text "elasticloadbalancing" + <|> ServiceNamespaceElasticmapreduce <$ P.text "elasticmapreduce" + <|> ServiceNamespaceElasticache <$ P.text "elasticache" + <|> ServiceNamespaceGlacier <$ P.text "glacier" + <|> ServiceNamespaceIam <$ P.text "iam" + <|> ServiceNamespaceKinesis <$ P.text "kinesis" + <|> ServiceNamespaceAwsMarketplaceManagement <$ P.text "aws-marketplace-management" + <|> ServiceNamespaceOpsworks <$ P.text "opsworks" + <|> ServiceNamespaceRds <$ P.text "rds" + <|> ServiceNamespaceRedshift <$ P.text "redshift" + <|> ServiceNamespaceRoute53 <$ P.text "route53" + <|> ServiceNamespaceS3 <$ P.text "s3" + <|> ServiceNamespaceSes <$ P.text "ses" + <|> ServiceNamespaceSdb <$ P.text "sdb" + <|> ServiceNamespaceSqs <$ P.text "sqs" + <|> ServiceNamespaceSns <$ P.text "sns" + <|> ServiceNamespaceStoragegateway <$ P.text "storagegateway" + <|> ServiceNamespaceSts <$ P.text "sts" + <|> ServiceNamespaceSupport <$ P.text "support" + <|> ServiceNamespaceSwf <$ P.text "swf" + <|> ServiceNamespaceHost <$ P.text "host" + "Service Namespace" + +instance AwsType ServiceNamespace where + toText = serviceNamespaceToText + parse = parseServiceNamespace + +instance Hashable ServiceNamespace where + hashWithSalt = hashUsing fromEnum + +instance Q.Arbitrary ServiceNamespace where + arbitrary = Q.elements [minBound..maxBound] + +-- -------------------------------------------------------------------------- -- +-- ARN + +-- | Amazon Resource Names +-- +-- +-- +-- From the specification it is not clear if elements of 'arnResource' +-- can be empty. Though examples given in the specification do not inlcude +-- such a case, our parser allows it. +-- +data Arn = Arn + { arnService :: ServiceNamespace + , arnRegion :: Maybe Region + , arnAccount :: Maybe AccountId + , arnResource :: [T.Text] + -- ^ expected to be non-empty. Elements are separated by only @:@. + -- @/@ is not treated specially. + } + deriving (Show, Read, Eq, Ord, Typeable) + +arnToText :: (IsString a, Monoid a) => Arn -> a +arnToText arn = "arn:aws" + <> ":" <> serviceNamespaceToText (arnService arn) + <> ":" <> maybe "" regionToText (arnRegion arn) + <> ":" <> maybe "" accountIdToText (arnAccount arn) + <> ":" <> (fromString . T.unpack) (T.intercalate ":" (arnResource arn)) + +parseArn :: P.CharParsing m => m Arn +parseArn = P.text "arn:aws" *> p "ARN" + where + p = Arn + <$> (P.char ':' *> parseServiceNamespace) + <*> (P.char ':' *> P.optional parseRegion) + <*> (P.char ':' *> P.optional parseAccountId) + <*> (P.char ':' *> P.sepBy1 (T.pack <$> many (P.notChar ':')) (P.char ':')) + +instance AwsType Arn where + toText = arnToText + parse = parseArn + +instance ToJSON Arn where + toJSON = toJSON . (arnToText :: Arn -> T.Text) + +instance FromJSON Arn where + parseJSON = withText "Arn" $ either fail return . fromText + +-- | This instance if for general testing of the syntax of ARNs. For service +-- specific ARNs you should use a newtype wrapper and define an 'Arbitrary' +-- instance the satisfies the constraints of that particular services. +-- +instance Q.Arbitrary Arn where + arbitrary = Arn + <$> Q.arbitrary + <*> Q.arbitrary + <*> Q.arbitrary + <*> (map (T.filter (/= ':')) . Q.getNonEmpty <$> Q.arbitrary) + diff --git a/src/Aws/SignatureV4.hs b/src/Aws/SignatureV4.hs new file mode 100644 --- /dev/null +++ b/src/Aws/SignatureV4.hs @@ -0,0 +1,883 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} + +-- | +-- Module: Aws.SignatureV4 +-- Copyright: Copyright © 2014 AlephCloud Systems, Inc. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- AWS Signature Version 4 +-- +-- /API Version: 1.0/ +-- +-- +-- +module Aws.SignatureV4 +( + +-- * AWS General API Version + GeneralVersion(..) +, generalVersionToText +, parseGeneralVersion + +-- * Signature Version +, signatureVersion + +-- * AWS Credentials +, SignatureV4Credentials(..) +, newCredentials + +-- $requesttypes + +-- * Pure signing +, signPostRequest +, signGetRequest + +-- * Signing With Cached Key +, signPostRequestIO +, signGetRequestIO + +-- * Authorization Info +, AuthorizationInfo(..) +, authorizationInfo +, authorizationInfoQuery +, authorizationInfoHeader + +-- * Internal + +, dateNormalizationEnabled + +-- ** Constants +, signingAlgorithm + +-- ** Canoncial URI +, UriPath +, UriQuery +, normalizeUriPath +, normalizeUriQuery +, CanonicalUri(..) +, canonicalUri + +-- ** Canonical Headers +, CanonicalHeaders(..) +, canonicalHeaders + +-- ** SignedHeaders +, SignedHeaders +, signedHeaders + +-- ** Canonical Request +, CanonicalRequest(..) +, canonicalRequest +, HashedCanonicalRequest +, hashedCanonicalRequest + +-- ** Credenital Scope +, CredentialScope(..) +, credentialScopeToText + +-- ** String to Sign +, StringToSign(..) +, stringToSign + +-- ** Signing Key +, SigningKey(..) +, signingKey + +-- * Signature +, Signature(..) + +-- ** Low level signing function +, requestSignature +) where + +-- import Aws.Core +import Aws.General + +import Control.Applicative +import Control.Arrow hiding (left) +import Control.Monad.IO.Class + +import Crypto.Hash + +import Data.Byteable +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Blaze.ByteString.Builder as BB +import qualified Blaze.ByteString.Builder.Char8 as BB8 +import qualified Data.ByteString.Base16 as B16 +import Data.Char +import qualified Data.CaseInsensitive as CI +import Data.IORef +import qualified Data.List as L +import Data.Monoid +import Data.String +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time.Clock (UTCTime, getCurrentTime, utctDay) +import Data.Time.Format (formatTime, parseTime) +import Data.Typeable + +import qualified Test.QuickCheck as Q +import Test.QuickCheck.Instances () + +import qualified Text.Parser.Char as P +import qualified Text.Parser.Combinators as P + +import System.Locale + +import qualified Network.HTTP.Types as HTTP + +-- -------------------------------------------------------------------------- -- +-- Constants + +-- | We only support SHA256 since SHA1 has been deprecated +-- +signingAlgorithm :: IsString a => a +signingAlgorithm = "AWS4-HMAC-SHA256" + +signingHash :: B.ByteString -> B.ByteString +signingHash i = toBytes (hash i :: Digest SHA256) + +signingHash16 :: B.ByteString -> B8.ByteString +signingHash16 = B16.encode . signingHash + +signingHmac :: B.ByteString -> B.ByteString -> B.ByteString +signingHmac k i = toBytes (hmac k i :: HMAC SHA256) + +-- -------------------------------------------------------------------------- -- +-- Version + +signatureVersion :: IsString a => a +signatureVersion = "4" + +-- -------------------------------------------------------------------------- -- +-- Signature V4 Credentials + +type SigV4Key = ((B.ByteString,B.ByteString),(B.ByteString,B.ByteString)) + +-- | AWS access credentials. +-- +-- This type is isomorphic to the 'Credential' type from the +-- . You may +-- use the following function to get a 'SignatureV4Credential' +-- from a 'Credential': +-- +-- > cred2credv4 :: Credential -> SignatureV4Credential +-- > cred2credv4 (Credential a b c) = SignatureV4Credential a b c +-- +data SignatureV4Credentials = SignatureV4Credentials + { sigV4AccessKeyId :: B.ByteString + , sigV4SecretAccessKey :: B.ByteString + , sigV4SigningKeys :: IORef [SigV4Key] + -- ^ used internally for caching the singing key + } + deriving (Typeable) + +newCredentials + :: (Functor m, MonadIO m) + => B.ByteString -- ^ Access Key ID + -> B.ByteString -- ^ Secret Access Key + -> m SignatureV4Credentials +newCredentials accessKeyId secretAccessKey = + SignatureV4Credentials accessKeyId secretAccessKey <$> liftIO (newIORef []) + +-- -------------------------------------------------------------------------- -- +-- Canonical URI + +type UriPath = [T.Text] +type UriQuery = HTTP.QueryText + +newtype CanonicalUri = CanonicalUri B8.ByteString + deriving (Show, Read, Eq, Ord, Typeable) + +-- | Compute canonical URI +-- +-- +-- +-- The input is assumed to be an absolute URI. If the first segment is @..@ it +-- is kept as is. Most likely such an URI is invalid. +-- +canonicalUri + :: UriPath + -> UriQuery + -> CanonicalUri +canonicalUri path query = CanonicalUri . BB.toByteString + $ HTTP.encodePathSegments normalizedPath + <> BB.copyByteString "\n" + <> HTTP.renderQueryText False normalizedQuery + where + normalizedPath = case normalizeUriPath path of + [] -> [""] + a -> a + normalizedQuery = L.sort + . map (second $ maybe (Just "") Just) + $ normalizeUriQuery query + +-- | Normalize URI Path according to RFC 3986 (6.2.2) +-- +normalizeUriPath :: UriPath -> UriPath +normalizeUriPath = + -- normalize case and percent encoding + HTTP.decodePathSegments . BB.toByteString . HTTP.encodePathSegments + -- remove all "." segments + -- remove all inner and trailing ".." segments (ignore leading ".." segments) + . reverse . L.foldl' f [] + where + f [] ".." = [".."] + f (_:t) ".." = t + f l "." = l + f ("":t) a = a:t + f l a = a:l + +-- | Normalize URI Query according to RFC 3986 (6.2.2) +-- +normalizeUriQuery :: UriQuery -> UriQuery +normalizeUriQuery = + -- normalize case and percent encoding + HTTP.parseQueryText . BB.toByteString . HTTP.renderQueryText False + +-- -------------------------------------------------------------------------- -- +-- Canonical Headers + +newtype CanonicalHeaders = CanonicalHeaders B8.ByteString + deriving (Show, Read, Eq, Ord, Typeable) + +-- | Compute canonical HTTP headers +-- +-- +-- +-- It is assumed (and not checked) that the header values comform with the +-- definitions in RFC 2661. In particular non-comformant usage of quotation +-- characters may lead to invalid results. +-- +canonicalHeaders :: HTTP.RequestHeaders -> CanonicalHeaders +canonicalHeaders = CanonicalHeaders + . foldHeaders + . L.sort -- Note this /must/ be a stable sorting algorithm! + + -- The following breaks the AWS test suite, since the tests in that + -- test suite use an invalid date! + -- +#ifdef SIGN_V4_NORMALIZE_DATE + . map canonicalDate +#endif + where + +#ifdef SIGN_V4_NORMALIZE_DATE + canonicalDate :: HTTP.Header -> HTTP.Header + canonicalDate ("date", d) = ("date", formatDate) + where + formatDate = case parseHttpDate (B8.unpack d) of + Nothing -> d + Just utc -> B8.pack $ fTime canonicalDateHeaderFormat utc + canonicalDate a = a +#endif + + -- fold headers with the same name into a single HTTP header with + -- comma separated values. Make all header names lower-case and + -- terminate all headers by a new-line character. + foldHeaders :: HTTP.RequestHeaders -> B8.ByteString + foldHeaders [] = "" + foldHeaders ((h0,v0):t) = BB.toByteString $ snd run <> bChar '\n' + where + run = L.foldl' f (h0, bBS (CI.foldedCase h0) <> bChar ':' <> trimWs v0) t + f (ch, a) (h,v) = if ch == h + then (h, a <> bChar ',' <> trimWs v) + else (h, a <> bChar '\n' <> bBS (CI.foldedCase h) <> bChar ':' <> trimWs v) + + trimWs = (\(_,_,c) -> c) + -- This strips all leading whitespace and collapses inner unquoted whitespace + . B8.foldl' f (False, ' ', bBS "") + -- This strips all trailing whitespace + . fst . B8.spanEnd isSpace + where + -- escaping (we assume that we are withing quote but don't check!) + f (s, '\\', b) x = (s, x, b <> bChar x) + + -- an unescaped quote toggles the quoting mode + f (s, _, b) '"' = (not s, '"', b <> bChar '"') + + -- white space outside of quotation + f (False, ' ', b) x + | isSpace x = (False, ' ', b) + f (False, _, b) x + | isSpace x = (False, ' ', b <> bChar ' ') + + -- nothing special here + f (s, _, b) x = (s, x, b <> bChar x) + + bChar = BB8.fromChar + bBS = BB.copyByteString + +#ifdef SIGN_V4_NORMALIZE_DATE +canonicalDateHeaderFormat :: String +canonicalDateHeaderFormat = "%a, %d %b %Y %H:%M:%S GMT" + +-- | Parse HTTP-date according to section 3.3.1 of RFC 2616 +-- +-- the implementation is copie from the module "Aws.Core" +-- of the . +-- +parseHttpDate :: String -> Maybe UTCTime +parseHttpDate s = + p "%a, %d %b %Y %H:%M:%S GMT" s -- rfc1123-date + <|> p "%A, %d-%b-%y %H:%M:%S GMT" s -- rfc850-date + <|> p "%a %b %_d %H:%M:%S %Y" s -- asctime-date + <|> p "%Y-%m-%dT%H:%M:%S%QZ" s -- iso 8601 + <|> p "%Y-%m-%dT%H:%M:%S%Q%Z" s -- iso 8601 + where + p = parseTime defaultTimeLocale +#endif + +-- | Normalization of the date header breaks the AWS test suite, since the +-- tests in that test suite use an invalid date. +-- +-- Date normalization is enabled by default but can be turned of via the cabal +-- (compiletime) flag @normalize-signature-v4-date@. +-- +dateNormalizationEnabled :: Bool +#ifdef SIGN_V4_NORMALIZE_DATE +dateNormalizationEnabled = True +#else +dateNormalizationEnabled = False +#endif + +-- -------------------------------------------------------------------------- -- +-- Signed Headers + +newtype SignedHeaders = SignedHeaders B8.ByteString + deriving (Show, Read, Eq, Ord, Typeable) + +-- | Compute signed headers +-- +-- +-- +signedHeaders :: HTTP.RequestHeaders -> SignedHeaders +signedHeaders = SignedHeaders + . B8.intercalate ";" + . L.nub + . L.sort + . map (CI.foldedCase . fst) + +-- -------------------------------------------------------------------------- -- +-- Canonical Request + +newtype CanonicalRequest = CanonicalRequest B8.ByteString + deriving (Show, Read, Eq, Ord, Typeable) + +-- | Create Canonical Request for AWS Signature Version 4 +-- +-- +-- +-- This functions performs normalization of the URI and the Headers which is +-- expensive. We should consider providing an alternate version of this +-- function that bypasses these steps and simply assumes that the input is +-- already canonical. +-- +canonicalRequest + :: HTTP.Method -- ^ HTTP method of request + -> UriPath -- ^ canonical URI Path of request + -> UriQuery -- ^ canonical URI Query of request + -> HTTP.RequestHeaders -- ^ canonical request headers + -> B.ByteString -- ^ Request payload + -> CanonicalRequest +canonicalRequest method path query headers payload = + CanonicalRequest $ B8.intercalate "\n" + [ method + , cUri + , cHeaders + , sHeaders + , signingHash16 payload + ] + where + CanonicalUri cUri = canonicalUri path query + CanonicalHeaders cHeaders = canonicalHeaders headers + SignedHeaders sHeaders = signedHeaders headers + +-- The hash is stored hex encoded +-- +newtype HashedCanonicalRequest = HashedCanonicalRequest B8.ByteString + deriving (Show, Read, Eq, Ord, Typeable) + +hashedCanonicalRequest :: CanonicalRequest -> HashedCanonicalRequest +hashedCanonicalRequest (CanonicalRequest r) = HashedCanonicalRequest + $ signingHash16 r + +-- -------------------------------------------------------------------------- -- +-- Credential Scope + +data CredentialScope = CredentialScope + { credentialScopeDate :: !UTCTime + , credentialScopeRegion :: !Region + , credentialScopeService :: !ServiceNamespace + } + deriving (Show, Read, Typeable) + +instance Eq CredentialScope where + CredentialScope a0 b0 c0 == CredentialScope a1 b1 c1 = + utctDay a0 == utctDay a1 + && b0 == b1 + && c0 == c1 + +credentialScopeToText :: (IsString a, Monoid a) => CredentialScope -> a +credentialScopeToText s = + credentialScopeDateText s + <> "/" <> toText (credentialScopeRegion s) + <> "/" <> toText (credentialScopeService s) + <> "/" <> terminationString + +parseCredentialScope :: (Monad m, P.CharParsing m) => m CredentialScope +parseCredentialScope = CredentialScope + <$> time + <*> (P.char '/' *> parseRegion) + <*> (P.char '/' *> parseServiceNamespace) + <* (P.char '/' *> P.text terminationString) + where + time = do + str <- P.count 8 P.digit + case parseTime defaultTimeLocale credentialScopeDateFormat str of + Nothing -> fail $ "failed to parse credential scope date: " <> str + Just t -> return t + +terminationString :: IsString a => a +terminationString = "aws4_request" + +credentialScopeDateFormat :: IsString a => a +credentialScopeDateFormat = "%Y%m%d" + +credentialScopeDateText :: IsString a => CredentialScope -> a +credentialScopeDateText s = fTime credentialScopeDateFormat (credentialScopeDate s) + +instance AwsType CredentialScope where + toText = credentialScopeToText + parse = parseCredentialScope + +instance Q.Arbitrary CredentialScope where + arbitrary = CredentialScope + <$> Q.arbitrary + <*> Q.arbitrary + <*> Q.arbitrary + +-- -------------------------------------------------------------------------- -- +-- String to Sign + +newtype StringToSign = StringToSign B8.ByteString + deriving (Show, Read, Eq, Ord, Typeable) + +-- | Create the String to Sign for AWS Signature Version 4 +-- +-- +-- +stringToSign + :: UTCTime -- ^ request date + -> CredentialScope -- ^ credential scope for the request + -> CanonicalRequest -- ^ canonical request + -> StringToSign +stringToSign date credentialScope request = StringToSign $ B8.intercalate "\n" + [ signingAlgorithm + , fTime signingStringDateFormat date + , T.encodeUtf8 $ credentialScopeToText credentialScope + , hashedRequest + ] + where + HashedCanonicalRequest hashedRequest = hashedCanonicalRequest request + +signingStringDateFormat :: IsString a => a +signingStringDateFormat = "%Y%m%dT%H%M%SZ" + +-- -------------------------------------------------------------------------- -- +-- Derivation of Signing Key + +-- | This key can be computed once and cached. It is valid for all requests +-- to the same service and the region till 00:00:00 UTC time. +-- +newtype SigningKey = SigningKey B.ByteString + deriving (Show, Read, Eq, Ord, Typeable) + +-- | Derive the signing key +-- +-- +-- +signingKey :: SignatureV4Credentials -> CredentialScope -> SigningKey +signingKey credentials s = SigningKey kSigning + where + kSecret = sigV4SecretAccessKey credentials + kDate = signingHmac (signingKeyPrefix <> kSecret) dateStr + kRegion = signingHmac kDate regionStr + kService = signingHmac kRegion serviceStr + kSigning = signingHmac kService terminationString + + dateStr = T.encodeUtf8 $ credentialScopeDateText s + regionStr = T.encodeUtf8 . toText $ credentialScopeRegion s + serviceStr = T.encodeUtf8 . toText $ credentialScopeService s + +signingKeyPrefix :: IsString a => a +signingKeyPrefix = "AWS4" + +-- -------------------------------------------------------------------------- -- +-- Request Signature + +newtype Signature = Signature B8.ByteString + deriving (Show, Read, Eq, Ord, Typeable) + +-- | Compute an AWS Signature Version 4 +-- +-- +-- +requestSignature + :: SigningKey + -> StringToSign + -> Signature +requestSignature (SigningKey key) (StringToSign str) = + Signature . B16.encode $ signingHmac key str + +-- -------------------------------------------------------------------------- -- +-- Authorization Info + +authorizationCredential + :: (IsString a, Monoid a) + => SignatureV4Credentials + -> CredentialScope + -> a +authorizationCredential creds credScope = + (fromString . B8.unpack . sigV4AccessKeyId) creds <> "/" <> toText credScope + +data AuthorizationInfo = AuthorizationInfo + { authzInfoAlgorithm :: !B8.ByteString + , authzInfoCredential :: !B8.ByteString + , authzInfoSignedHeaders :: !B8.ByteString + , authzInfoDate :: !UTCTime + , authzInfoSignature :: !B8.ByteString + } + +authorizationInfo + :: SignatureV4Credentials + -> CredentialScope + -> SignedHeaders + -> UTCTime + -> Signature + -> AuthorizationInfo +authorizationInfo creds credScope (SignedHeaders hdrs) date (Signature sig) = AuthorizationInfo + { authzInfoAlgorithm = signingAlgorithm + , authzInfoCredential = authorizationCredential creds credScope + , authzInfoSignedHeaders = hdrs + , authzInfoDate = date + , authzInfoSignature = sig + } + +authorizationInfoQuery :: AuthorizationInfo -> UriQuery +authorizationInfoQuery authz = + [ ("X-Amz-Signature", Just . T.decodeUtf8 $ authzInfoSignature authz) + ] + +authorizationInfoHeader + :: AuthorizationInfo + -> HTTP.RequestHeaders +authorizationInfoHeader authz = [ ("Authorization", authzInfo) ] + where + authzInfo = authzInfoAlgorithm authz + <> " Credential=" <> authzInfoCredential authz + <> ", SignedHeaders=" <> authzInfoSignedHeaders authz + <> ", Signature=" <> authzInfoSignature authz + +-- -------------------------------------------------------------------------- -- +-- Signing Function + +-- $requesttypes +-- = AWS Signature 4 Request Types +-- +-- There are two types of version 4 signed requests for GET and for POST +-- requests +-- +-- +-- +-- == Common Parameters +-- +-- Both request types must include the following information in some way +-- +-- +-- +-- * Host +-- * Action +-- * Date +-- * Authorization parameters: +-- +-- * Algorithm +-- * Credential +-- * Signed headers +-- * signature +-- +-- == POST Request +-- +-- Computed by 'signPostRequest' or 'signPostRequestIO'. +-- +-- Headers: +-- +-- * @host@, +-- * @x-amz-date@ (or @date@), +-- * @authorization@ (containing all authorization parameters), and +-- * @content-type: application/x-www-form-urlencoded. charset=utf-8@. +-- +-- The query parameters (including @Action@ and @Version@) are placed in the body. +-- +-- == GET Request +-- +-- Computed with 'signGetRequest' or 'signGetRequestIO'. +-- +-- Headers: +-- +-- * @host@ +-- +-- TODO why is this @content-type@ required? +-- +-- Query: +-- +-- * @Action@, +-- * @Version@, +-- * @X-Amz-Algorithm@, +-- * @X-Amz-Credential@, +-- * Authorization parameters: +-- +-- * @X-Amz-Date@, +-- * @X-Amz-SignedHeaders@, +-- * @X-Amz-Signature@, +-- * @SignedHeaders@, +-- * @Signature@. +-- +-- (NOTE that the AWS specification considers @X-Amz-Date@ an authorization parameter +-- only for URI requests. So for URI requests there are five authorization parameters +-- whereas otherwise there are just four.) +-- +-- Somewhat surprisingly (and covered neither by the AWS Signature V4 test suite +-- nor by the AWS API reference) the canonical request includes all authorization +-- parameters except for the signature. +-- +-- TODO: is it possible to do a POST with this style and place the query in the body? +-- + +-- | Compute an AWS Signature Version 4 +-- +-- This version computes the derivied signing key each time it is invoked +-- +-- The request headers /must/ include the @host@ header. +-- The query /must/ include the @Action@ parameter. +-- +signGetRequest + :: SignatureV4Credentials -- ^ AWS credentials + -> Region -- ^ request region + -> ServiceNamespace -- ^ service of the request + -> UTCTime -- ^ request time + -> HTTP.Method -- ^ HTTP method of request + -> UriPath -- ^ URI Path of request + -> UriQuery -- ^ URI Query of request + -> HTTP.RequestHeaders -- ^ request headers + -> B.ByteString -- ^ request payload + -> Either String UriQuery +signGetRequest credentials region service date = signGetRequest_ key credentials region service date + where + key = signingKey credentials CredentialScope + { credentialScopeDate = date + , credentialScopeRegion = region + , credentialScopeService = service + } + +signGetRequest_ + :: SigningKey + -> SignatureV4Credentials -- ^ AWS credentials + -> Region -- ^ request region + -> ServiceNamespace -- ^ service of the request + -> UTCTime -- ^ request time + -> HTTP.Method -- ^ HTTP method of request + -> UriPath -- ^ URI Path of request + -> UriQuery -- ^ URI Query of request + -> HTTP.RequestHeaders -- ^ request headers + -> B.ByteString -- ^ request payload + -> Either String UriQuery +signGetRequest_ key credentials region service date method path query headers payload = do + case lookup "host" headers of + Nothing -> Left "Failed to sign request with Signature V4: host header is missing" + Just _ -> return () + case lookup "Action" query of + Nothing -> Left "Failed to sign request with Signature V4: Action parameter is missing" + Just _ -> return () + return $ queryToSign <> authorizationInfoQuery authz + where + queryToSign = query <> + [ ("X-Amz-Algorithm", Just signingAlgorithm) + , ("X-Amz-Credential", Just $ authorizationCredential credentials credentialScope) + , ("X-Amz-Date", Just $ fTime signingStringDateFormat date) + , ("X-Amz-SignedHeaders", let SignedHeaders h = shdrs in Just (T.decodeUtf8 h)) + ] + authz = authorizationInfo credentials credentialScope shdrs date sig + sig = requestSignature key str + shdrs = signedHeaders headers + request = canonicalRequest method path queryToSign headers payload + str = stringToSign date credentialScope request + credentialScope = CredentialScope + { credentialScopeDate = date + , credentialScopeRegion = region + , credentialScopeService = service + } + +-- | Compute an AWS Signature Version 4 +-- +-- This version computes the derivied signing key each time it is invoked +-- +-- The request headers /must/ include the @host@ header. +-- The query /must/ include the @Action@ parameter. +-- +-- The @x-amz-date@ header is generated by the code. A possibly existing +-- @x-amz-date@ header or @date@ header is replaced. +-- +signPostRequest + :: SignatureV4Credentials -- ^ AWS credentials + -> Region -- ^ request region + -> ServiceNamespace -- ^ service of the request + -> UTCTime -- ^ request time + -> HTTP.Method -- ^ HTTP method of request + -> UriPath -- ^ URI Path of request + -> UriQuery -- ^ URI Query of request + -> HTTP.RequestHeaders -- ^ request headers + -> B.ByteString -- ^ request payload + -> Either String HTTP.RequestHeaders +signPostRequest credentials region service date = signPostRequest_ key credentials region service date + where + key = signingKey credentials CredentialScope + { credentialScopeDate = date + , credentialScopeRegion = region + , credentialScopeService = service + } + +signPostRequest_ + :: SigningKey + -> SignatureV4Credentials -- ^ AWS credentials + -> Region -- ^ request region + -> ServiceNamespace -- ^ service of the request + -> UTCTime -- ^ request time + -> HTTP.Method -- ^ HTTP method of request + -> UriPath -- ^ URI Path of request + -> UriQuery -- ^ URI Query of request + -> HTTP.RequestHeaders -- ^ request headers + -> B.ByteString -- ^ request payload + -> Either String HTTP.RequestHeaders -- ^ the updated HTTP headers +signPostRequest_ key credentials region service date method path query headers payload = do + case lookup "host" headers of + Nothing -> Left "Failed to sign request with Signature V4: host header is missing" + Just _ -> return () + + -- In the post case can be in the body... + -- case lookup "Action" query of + -- Nothing -> Left "Failed to sign request with Signature V4: Action parameter is missing" + -- Just _ -> return () + return $ headersWithDate <> authorizationInfoHeader authz + + where + authz = authorizationInfo credentials credentialScope shdrs date sig + sig = requestSignature key str + shdrs = signedHeaders headersWithDate + request = canonicalRequest method path query headersWithDate payload + str = stringToSign date credentialScope request + credentialScope = CredentialScope + { credentialScopeDate = date + , credentialScopeRegion = region + , credentialScopeService = service + } + headersWithDate = ("x-amz-date", fTime signingStringDateFormat date) + : filter (\x -> fst x /= "date" && fst x /= "x-amz-date") headers + +-- -------------------------------------------------------------------------- -- +-- Sign Request in IO + +-- | +-- The request headers /must/ include the @host@ header. +-- The query /must/ include the @Action@ parameter. +-- +signGetRequestIO + :: SignatureV4Credentials -- ^ AWS credentials + -> Region + -> ServiceNamespace + -> UTCTime + -> HTTP.Method -- ^ HTTP method of request + -> UriPath -- ^ URI Path of request + -> UriQuery -- ^ URI Query of request + -> HTTP.RequestHeaders -- ^ request headers + -> B.ByteString -- ^ request payload + -> IO (Either String UriQuery) +signGetRequestIO credentials region service date method path query headers payload = do + key <- getSigningKey credentials region service + return $ signGetRequest_ key credentials region service date method path query headers payload + +-- | +-- The request headers /must/ include the @host@ header. +-- The query /must/ include the @Action@ parameter. +-- +-- The @x-amz-date@ header is generated by the code. A possibly existing +-- @x-amz-date@ header or @date@ header is replaced. +-- +signPostRequestIO + :: SignatureV4Credentials -- ^ AWS credentials + -> Region + -> ServiceNamespace + -> UTCTime + -> HTTP.Method -- ^ HTTP method of request + -> UriPath -- ^ URI Path of request + -> UriQuery -- ^ URI Query of request + -> HTTP.RequestHeaders -- ^ request headers + -> B.ByteString -- ^ request payload + -> IO (Either String HTTP.RequestHeaders) +signPostRequestIO credentials region service date method path query headers payload = do + key <- getSigningKey credentials region service + return $ signPostRequest_ key credentials region service date method path query headers payload + +-- | Get cached signing key +-- +-- This should be improved: +-- +-- 1. use an MVar instead of an IORef (for thread safety) +-- +-- 2. use a better cache data structure (either a dense vector of MVars or +-- a hashmap. +-- +-- 3. use more efficient value representations: +-- +-- * Hashable instance for the index (or use a Int directly) +-- * represent dates as number of days or seconds (e.g. since epoche) +-- +getSigningKey + :: SignatureV4Credentials -- ^ AWS credentials + -> Region + -> ServiceNamespace + -> IO SigningKey +getSigningKey credentials region service = do + date <- getCurrentTime + let dateStr = fTime credentialScopeDateFormat date + + k <- atomicModifyIORef' (sigV4SigningKeys credentials) $ \cache -> + case L.lookup idx cache of + Just (d,k) -> if d /= dateStr + then newKey date dateStr cache + else (cache,k) + Nothing -> newKey date dateStr cache + + return $ SigningKey k + where + idx = ((T.encodeUtf8 . toText) region, (T.encodeUtf8 . toText) service) + newKey date dateStr c = + let SigningKey key = signingKey credentials CredentialScope + { credentialScopeDate = date + , credentialScopeRegion = region + , credentialScopeService = service + } + c_ = (idx, (dateStr,key)):c + in key `seq` c_ `seq` (c_, key) + +-- -------------------------------------------------------------------------- -- +-- Utils + +fTime :: IsString a => String -> UTCTime -> a +fTime format time = fromString $ formatTime defaultTimeLocale format time + diff --git a/tests/General.hs b/tests/General.hs new file mode 100644 --- /dev/null +++ b/tests/General.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module: General +-- Copyright: Copyright © 2014 AlephCloud Systems, Inc. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- Unit tests for "Aws.General" +-- +module General +( tests + +-- * Test properties +, prop_textRoundtrip +, prop_textRoundtrips +) where + +import Aws.General + +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = testGroup "AWS General" + [ prop_textRoundtrips + ] + +-- -------------------------------------------------------------------------- -- +-- Test properties + +prop_textRoundtrip :: forall a . (Eq a, AwsType a) => a -> Bool +prop_textRoundtrip a = either (const False) (\(b :: a) -> a == b) $ + fromText . toText $ a + +prop_textRoundtrips :: TestTree +prop_textRoundtrips = testGroup "Text encoding roundtrips" + [ testProperty "Text roundtrip for GeneralVersion" (prop_textRoundtrip :: GeneralVersion -> Bool) + , testProperty "Text roundtrip for SignatureVersion" (prop_textRoundtrip :: SignatureVersion -> Bool) + , testProperty "Text roundtrip for SignatureMethod" (prop_textRoundtrip :: SignatureMethod -> Bool) + , testProperty "Text roundtrip for Region" (prop_textRoundtrip :: Region -> Bool) + , testProperty "Text roundtrip for AccountId" (prop_textRoundtrip :: AccountId -> Bool) + , testProperty "Text roundtrip for CanonicalUserId" (prop_textRoundtrip :: CanonicalUserId -> Bool) + , testProperty "Text roundtrip for ServiceNamespace" (prop_textRoundtrip :: ServiceNamespace -> Bool) + , testProperty "Text roundtrip for Arn" (prop_textRoundtrip :: Arn -> Bool) + ] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module: Main +-- Copyright: Copyright © 2014 AlephCloud Systems, Inc. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental + +-- -------------------------------------------------------------------------- -- +-- Main + +import Test.Tasty + +import qualified General as General +import qualified SignatureV4 as SigV4 + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "AWS Tests" + [ SigV4.tests + , General.tests + ] + diff --git a/tests/SignatureV4.hs b/tests/SignatureV4.hs new file mode 100644 --- /dev/null +++ b/tests/SignatureV4.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- Module: SignatureV4 +-- Copyright: Copyright © 2014 AlephCloud Systems, Inc. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- Unit tests for "Aws.SignatureV4" +-- +module SignatureV4 +( tests + +-- * Test Properties +, prop_canonicalHeaders +, allTests + +) where + +import General (prop_textRoundtrip) + +import Aws.Core +import Aws.General +import Aws.SignatureV4 + +import Control.Applicative +import Control.Error.Util +import Control.Error (initSafe) +import Control.Exception +import Control.Monad +import Control.Monad.Trans.Either +import Control.Monad.IO.Class + +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.CaseInsensitive as CI +import Data.Function (on) +import qualified Data.List as L +import Data.Maybe +import Data.Monoid +import Data.String +import qualified Data.Text.Encoding as T +import Data.Time.Clock (UTCTime) +import Data.Tagged + +import qualified Network.HTTP.Types as HTTP + +import qualified Test.QuickCheck as Q +import Test.QuickCheck.Instances () + +import qualified Text.Parser.Char as P +import qualified Text.Parser.Combinators as P + +import System.Directory +import System.IO.Unsafe (unsafePerformIO) + +import Test.Tasty.QuickCheck +import Test.Tasty +import Test.Tasty.Providers + +tests :: TestTree +tests = testGroup "SignatureV4" + $ quickCheckTests + : if dateNormalizationEnabled then [] else [awsSignatureV4TestSuite] + +-- -------------------------------------------------------------------------- -- +-- QuickCheck Properties + +quickCheckTests :: TestTree +quickCheckTests = testGroup "quick queck tests" + [ testProperty "canonical headers" prop_canonicalHeaders + , testProperty "text roundtrip for CredentialScope" + (prop_textRoundtrip :: CredentialScope -> Bool) + ] + +instance Q.Arbitrary (CI.CI B.ByteString) where + arbitrary = CI.mk . T.encodeUtf8 <$> Q.arbitrary + +prop_canonicalHeaders :: HTTP.RequestHeaders -> Bool +prop_canonicalHeaders h = let x = canonicalHeaders h in x `seq` True + +-- -------------------------------------------------------------------------- -- +-- AWS Signature V4 Test Suite +-- +-- +-- +-- TODO use machinery from tasty-golden to run these tests +-- + +instance IsTest (IO Bool) where + run _ t _ = t >>= \x -> return $ if x + then testPassed "" + else testFailed "" + testOptions = Tagged [] + +simpleIOTest :: String -> IO Bool -> TestTree +simpleIOTest = singleTest + +-- + +awsSignatureV4TestSuite :: TestTree +awsSignatureV4TestSuite = simpleIOTest "AWS Signature V4 Test Suite" allTests + +baseDir :: String +baseDir = "./tests/signature-v4/aws4_testsuite" + +testFileBase :: String -> String +testFileBase name = baseDir <> "/" <> name + +readFileNormalized :: String -> IO B8.ByteString +readFileNormalized f = B8.filter (/= '\r') <$> B8.readFile f + +amz_credentialScope :: CredentialScope +amz_credentialScope = either error id + $ fromText "20110909/us-east-1/host/aws4_request" + +amz_credentialsIO :: IO SignatureV4Credentials +amz_credentialsIO = newCredentials "AKIDEXAMPLE" "wJalrXUtnFEMI/K7MDENG+bPxRfiCYEXAMPLEKEY" + +amz_credentials :: SignatureV4Credentials +amz_credentials = unsafePerformIO $ amz_credentialsIO +{-# NOINLINE amz_credentials #-} + +-- | Note that the input is an invalid date. The day 2011-09-09 was a +-- a Friday in the Gregorian calendar. +-- +amz_testDateStr :: IsString a => a +amz_testDateStr = "Mon, 09 Sep 2011 23:36:00 GMT" + +amz_testDate :: UTCTime +amz_testDate = fromMaybe (error "failed to parse test date") + $ parseHttpDate amz_testDateStr + +-- | Test Parameters +-- +data TestRequest = TestRequest + { testRequestMethod :: !HTTP.Method + , testRequestPath :: !UriPath + , testRequestQuery :: !UriQuery + , testRequestHeaders :: !HTTP.RequestHeaders + , testRequestPayload :: !B.ByteString + } + deriving (Show, Eq) + +parseRequest :: forall m . (Monad m, P.CharParsing m) => m TestRequest +parseRequest = uncurry <$> (TestRequest <$> word) + <*> parseTestUri + <*> many parseTestHeader + <*> (fromString <$> ((line :: m String) *> P.manyTill P.anyChar P.eof)) + P. "TestRequest" + +parseTestUri :: forall m . P.CharParsing m => m (UriPath, UriQuery) +parseTestUri = fmap HTTP.queryToQueryText . HTTP.decodePath . B8.pack + <$> word <* (line :: m String) + +parseTestHeader :: P.CharParsing m => m HTTP.Header +parseTestHeader = (,) + <$> (fromString <$> P.manyTill P.anyChar (P.char ':')) + <*> line + +word :: (P.CharParsing m, IsString a) => m a +word = fromString <$> P.manyTill P.anyChar (some P.space) P. "word" + +line :: (P.CharParsing m, IsString a) => m a +line = fromString + <$> P.manyTill P.anyChar (P.newline *> P.notFollowedBy (P.char ' ')) + P. "line" + +-- ** Test Methods + +testCanonicalRequest + :: String + -> TestRequest + -> EitherT String IO CanonicalRequest +testCanonicalRequest name r = do + creq_ <- liftIO $ readFileNormalized f + if creq == creq_ + then return result + else left $ "test " <> name <> " failed to compute canonical request: " + <> "\n expected:" <> show creq_ + <> "\n computed:" <> show creq + where + f = testFileBase name <> ".creq" + result@(CanonicalRequest creq) = canonicalRequest + (testRequestMethod r) + (testRequestPath r) + (testRequestQuery r) + (testRequestHeaders r) + (testRequestPayload r) + +testStringToSign + :: String + -> TestRequest + -> CanonicalRequest + -> EitherT String IO StringToSign +testStringToSign name _req creq = do + sts_ <- liftIO $ readFileNormalized f + if sts == sts_ + then return result + else left $ "test " <> name <> " failed compute string to sgin: " + <> "\n expected:" <> show sts_ + <> "\n computed:" <> show sts + where + f = testFileBase name <> ".sts" + result@(StringToSign sts) = stringToSign + amz_testDate + amz_credentialScope + creq + +testSignature :: String -> TestRequest -> StringToSign -> EitherT String IO Signature +testSignature name _req str = do + sig_ <- liftIO $ getSignature <$> readFileNormalized f + if sig == sig_ + then return result + else left $ "test " <> name <> " failed to compute signature: " + <> "\n expected:" <> show sig_ + <> "\n computed:" <> show sig + where + f = testFileBase name <> ".authz" + key = signingKey amz_credentials amz_credentialScope + result@(Signature sig) = requestSignature key str + getSignature = snd . B8.spanEnd (/= '=') + +testAuthorization :: String -> TestRequest -> Signature -> EitherT String IO B8.ByteString +testAuthorization name req sig = do + authz_ <- liftIO $ readFileNormalized f + authz <- result + if authz == authz_ + then return authz + else left $ "test " <> name <> " failed to compute authorization info: " + <> "\n expected:" <> show authz_ + <> "\n computed:" <> show authz + where + f = testFileBase name <> ".authz" + result = failWith "authorization header is missing" + . lookup "authorization" + . authorizationInfoHeader + $ authorizationInfo + amz_credentials + amz_credentialScope + (signedHeaders $ testRequestHeaders req) + amz_testDate + sig + +-- | Run a single Test +-- +testMain :: String -> IO Bool +testMain name = do + testRequest <- readFileNormalized reqFile >>= \x -> case A8.parseOnly parseRequest x of + Left e -> error $ "failed to parse test request file " <> reqFile <> ": " <> e + Right r -> return r + eitherT (\e -> putStrLn e >> return False) (const $ return True) $ do + creq <- testCanonicalRequest name testRequest + sts <- testStringToSign name testRequest creq + sig <- testSignature name testRequest sts + _authz <- testAuthorization name testRequest sig + return True + where + reqFile = testFileBase name <> ".req" + +-- | Run all Tests +-- +allTests :: IO Bool +allTests = do + testFiles <- filter isNotBlackListed + . filter (L.isSuffixOf ".req") + . concat . filter checkGroup . group + <$> getDirectoryContents baseDir + let sigtests = map (\x -> L.take (L.length x - 4) x) testFiles + results <- forM sigtests $ \n -> + testMain n `catch` \(e :: IOError) -> do + putStrLn $ "test " <> n <> " failed with: " <> show e + return False + return $ and results + where + -- the Amazon AWS SignatureV4 test-suite seems incomplete. + -- In particular the files with the results for + -- /get-header-value-multiline.req/ seem to be missing. + testExtensions = ["req", "creq", "sreq", "authz", "sts"] + checkGroup g = L.intersect testExtensions (map fext g) == testExtensions + group = L.groupBy ((==) `on` fbase) + fbase = initSafe . L.dropWhileEnd (/= '.') + fext = takeEndWhile (/= '.') + takeEndWhile f = reverse . takeWhile f . reverse + + -- the test *post-vanilla-query-nonunreserved* of the + -- Amazon AWS SignatureV4 testsuite uses an inconsistent request + -- format that can not be represented with the URI query + -- type of the *http-types* package. Also the given result + -- itself seems suspicious. We skip this test + + testBlackList = + [ "post-vanilla-query-nonunreserved" + ] + testName = takeEndWhile (/= '/') . fbase + isNotBlackListed = not . flip elem testBlackList . testName +