aws-general (empty) → 0.1
raw patch · 11 files changed
+1938/−0 lines, 11 filesdep +QuickCheckdep +aesondep +attoparsecsetup-changed
Dependencies added: QuickCheck, aeson, attoparsec, aws, aws-general, base, base16-bytestring, blaze-builder, byteable, bytestring, case-insensitive, charset, cryptohash, directory, either, errors, hashable, http-types, old-locale, parsers, quickcheck-instances, tagged, tasty, tasty-quickcheck, text, time, transformers
Files
- CHANGELOG.md +4/−0
- LICENSE +20/−0
- README.md +40/−0
- Setup.hs +2/−0
- aws-general.cabal +119/−0
- constraints +41/−0
- src/Aws/General.hs +453/−0
- src/Aws/SignatureV4.hs +883/−0
- tests/General.hs +48/−0
- tests/Main.hs +27/−0
- tests/SignatureV4.hs +301/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+0.1+===++First public version.
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,40 @@+[](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+~~~+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ aws-general.cabal view
@@ -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/+ .+ <http://docs.aws.amazon.com/general/latest/gr/>++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 <lars@alephcloud.com>+Maintainer: Lars Kuhtz <lars@alephcloud.com>+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+++
+ constraints view
@@ -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
+ src/Aws/General.hs view
@@ -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 <lars@alephcloud.com>+-- Stability: experimental+--+-- Bindings for AWS General Reference+--+-- /API Version: 1.0/+--+-- <http://docs.aws.amazon.com/general/latest/gr/>+--+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+--+-- <http://docs.aws.amazon.com/general/1.0/gr/rande.html>+--+-- 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+--+-- <http://docs.aws.amazon.com/general/1.0/gr/acct-identifiers.html>.+--+-- 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+--+-- <http://docs.aws.amazon.com/general/latest/gr/acct-identifiers.html>.+--+-- 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+--+-- <http://docs.aws.amazon.com/general/1.0/gr/aws-arns-and-namespaces.html#genref-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 <http://docs.aws.amazon.com/general/1.0/gr/signature-v4-test-suite.html>)+ 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+--+-- <http://docs.aws.amazon.com/general/1.0/gr/aws-arns-and-namespaces.html>+--+-- 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)+
+ src/Aws/SignatureV4.hs view
@@ -0,0 +1,883 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}++-- |+-- Module: Aws.SignatureV4+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- AWS Signature Version 4+--+-- /API Version: 1.0/+--+-- <http://docs.aws.amazon.com/general/1.0/gr/signature-version-4.html>+--+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+-- <https://hackage.haskell.org/package/aws aws package>. 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+--+-- <http://docs.aws.amazon.com/general/1.0/gr/sigv4-create-canonical-request.html>+--+-- 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+--+-- <http://docs.aws.amazon.com/general/1.0/gr/sigv4-create-canonical-request.html>+--+-- 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 <https://hackage.haskell.org/package/aws aws package>.+--+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+--+-- <http://docs.aws.amazon.com/general/1.0/gr/sigv4-create-canonical-request.html>+--+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+--+-- <http://docs.aws.amazon.com/general/1.0/gr/sigv4-create-canonical-request.html>+--+-- 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+--+-- <http://docs.aws.amazon.com/general/1.0/gr/sigv4-create-string-to-sign.html>+--+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+--+-- <http://docs.aws.amazon.com/general/1.0/gr/sigv4-calculate-signature.html>+--+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+--+-- <http://docs.aws.amazon.com/general/1.0/gr/sigv4-calculate-signature.html>+--+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+--+-- <http://docs.aws.amazon.com/general/1.0/gr/sigv4-signed-request-examples.html>+--+-- == Common Parameters+--+-- Both request types must include the following information in some way+--+-- <http://docs.aws.amazon.com/general/latest/gr/signature-version-4.html>+--+-- * 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+
+ tests/General.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module: General+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- 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)+ ]
+ tests/Main.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module: Main+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- 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+ ]+
+ tests/SignatureV4.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module: SignatureV4+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- 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+--+-- <http://docs.aws.amazon.com/general/1.0/gr/samples/aws4_testsuite.zip>+--+-- 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+