aws-sns (empty) → 0.1
raw patch · 20 files changed
+2997/−0 lines, 20 filesdep +QuickCheckdep +aesondep +awssetup-changed
Dependencies added: QuickCheck, aeson, aws, aws-general, aws-sns, base, blaze-builder, bytestring, conduit, containers, errors, http-conduit, http-types, mtl, parsers, resourcet, tagged, tasty, tasty-quickcheck, text, time, transformers, xml-conduit
Files
- CHANGELOG.md +4/−0
- LICENSE +20/−0
- README.md +73/−0
- Setup.hs +2/−0
- aws-sns.cabal +112/−0
- constraints +102/−0
- src/Aws/Sns.hs +57/−0
- src/Aws/Sns/Commands/ConfirmSubscription.hs +153/−0
- src/Aws/Sns/Commands/CreateTopic.hs +118/−0
- src/Aws/Sns/Commands/DeleteTopic.hs +96/−0
- src/Aws/Sns/Commands/GetSubscriptionAttributes.hs +147/−0
- src/Aws/Sns/Commands/ListSubscriptionsByTopic.hs +194/−0
- src/Aws/Sns/Commands/ListTopics.hs +141/−0
- src/Aws/Sns/Commands/Publish.hs +254/−0
- src/Aws/Sns/Commands/Subscribe.hs +138/−0
- src/Aws/Sns/Commands/Unsubscribe.hs +99/−0
- src/Aws/Sns/Core.hs +662/−0
- src/Aws/Sns/Internal.hs +45/−0
- tests/Main.hs +426/−0
- tests/Utils.hs +154/−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,73 @@+[](https://travis-ci.org/alephcloud/hs-aws-sns)+++Haskell Bindings for AWS SNS+============================++*API Version 2013-03-31*++[Amazon AWS SNS API Reference](http://docs.aws.amazon.com/sns/2010-03-31/APIReference/Welcome.html)++This package depends on the [aws-general](https://github.com/alephcloud/hs-aws-general) package+and the [aws](https://github.com/aristidb/aws) package. From the latter the it borrows the+machinery for [managing AWS credentials](https://hackage.haskell.org/package/aws-0.9/docs/Aws.html#g:17)+and [making requests](https://hackage.haskell.org/package/aws-0.9/docs/Aws.html). There+is also some documentation, including an usage example, in the+[README of the aws package](https://github.com/aristidb/aws/blob/master/README.org)+++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+=============++There are few test cases included in the package. These tests require an AWS account+and AWS credentials stored in the file `~/.aws-keys` in the format described in the+[documentation of the aws package](https://hackage.haskell.org/package/aws-0.9/docs/Aws.html#g:17).++When running these tests some (low) costs may incur for usage of the AWS services.+Therefor the user must explicitly consent to the usage of the AWS credentials by+passing the commandline options `--run-with-aws-credentials` to the test application.+In addition the tests require an email address that must be provided with the+command line option `--test-email`.++~~~{.sh}+cabal test --test-option=--run-with-aws-credentials --test-option=--test-email=<email-address>+~~~++where email address must be replaced with an actual email address.++Example Usage+=============++Here is a very simple example for making a single request to AWS SNS. For more ellaborate+usage refer to the [documentation of the AWS package](https://hackage.haskell.org/package/aws).++~~~{.haskell}+import Aws+import Aws.Core+import Aws.General+import Aws.Sns+import Data.IORef++cfg <- Aws.baseConfiguration+creds <- Credentials "access-key-id" "secret-access-key" `fmap` newIORef []+let snsCfg = SnsConfiguration HTTPS UsWest2+simpleAws cfg snsCfg $ ListTopics Nothing+~~~++In order to run the example you must replace `"access-key-id"` and+`"secret-access-key"` with the respective values for your AWS account.++You may also take a look at the test examples in+[tests/Main.hs](https://github.com/alephcloud/hs-aws-sns/blob/master/tests/Main.hs).++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ aws-sns.cabal view
@@ -0,0 +1,112 @@+-- ------------------------------------------------------ --+-- Copyright © 2014 AlephCloud Systems, Inc.+-- ------------------------------------------------------ --++Name: aws-sns+Version: 0.1+Synopsis: Bindings for AWS SNS Version 2013-03-31+description:+ Bindings for AWS SNS+ .+ /API Version: 2013-03-31/+ .+ <http://docs.aws.amazon.com/sns/2010-03-31/APIReference/Welcome.html>++Homepage: https://github.com/alephcloud/hs-aws-sns+Bug-reports: https://github.com/alephcloud/hs-aws-sns/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.16++extra-doc-files:+ README.md,+ CHANGELOG.md++extra-source-files:+ constraints++source-repository head+ type: git+ location: https://github.com/alephcloud/hs-aws-sns.git++source-repository this+ type: git+ location: https://github.com/alephcloud/hs-aws-sns.git+ tag: 0.1++Library+ default-language: Haskell2010+ hs-source-dirs: src++ exposed-modules:+ Aws.Sns+ Aws.Sns.Internal+ Aws.Sns.Core+ Aws.Sns.Commands.CreateTopic+ Aws.Sns.Commands.DeleteTopic+ Aws.Sns.Commands.ListTopics+ Aws.Sns.Commands.Subscribe+ Aws.Sns.Commands.Unsubscribe+ Aws.Sns.Commands.Publish+ Aws.Sns.Commands.ConfirmSubscription+ Aws.Sns.Commands.ListSubscriptionsByTopic+ Aws.Sns.Commands.GetSubscriptionAttributes++ build-depends:+ QuickCheck >= 2.7,+ aeson >= 0.7,+ aws >= 0.9,+ aws-general >= 0.1,+ base == 4.*,+ blaze-builder >= 0.3,+ bytestring >= 0.10,+ conduit >= 1.1,+ containers >= 0.5,+ http-conduit >= 2.1,+ http-types >= 0.8,+ parsers >= 0.11,+ resourcet >= 1.1,+ text >= 1.1,+ time >= 1.4,+ transformers >= 0.3,+ xml-conduit >= 1.2++ ghc-options: -Wall++test-suite SNS-tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: tests+ main-is: Main.hs++ other-modules:+ Utils++ build-depends:+ QuickCheck >= 2.7,+ aeson >= 0.7,+ aws >= 0.9,+ aws-general >= 0.1,+ aws-sns,+ base == 4.*,+ bytestring >= 0.10,+ errors >= 1.4.7,+ mtl >= 2.1,+ tagged >= 0.7,+ tasty >= 0.8,+ tasty-quickcheck >= 0.8,+ text >= 1.1,+ transformers >= 0.3++ ghc-options: -Wall -threaded+++++
+ constraints view
@@ -0,0 +1,102 @@+constraints: QuickCheck ==2.7.5,+ aeson ==0.7.0.6,+ array ==0.5.0.0,+ asn1-encoding ==0.8.1.3,+ asn1-parse ==0.8.1,+ asn1-types ==0.2.3,+ attoparsec ==0.12.1.0,+ attoparsec-conduit ==1.1.0,+ aws ==0.9.2,+ aws-general ==0.1.1,+ aws-sns ==0.1,+ base ==4.7.0.1,+ base16-bytestring ==0.1.1.6,+ base64-bytestring ==1.0.0.1,+ blaze-builder ==0.3.3.2,+ blaze-builder-conduit ==1.1.0,+ blaze-html ==0.7.0.2,+ blaze-markup ==0.6.1.0,+ byteable ==0.1.1,+ bytestring ==0.10.4.0,+ case-insensitive ==1.2.0.0,+ cereal ==0.4.0.1,+ charset ==0.3.7,+ cipher-aes ==0.2.8,+ cipher-des ==0.0.6,+ cipher-rc4 ==0.1.4,+ conduit ==1.1.6,+ conduit-extra ==1.1.1,+ connection ==0.2.1,+ containers ==0.5.5.1,+ cookie ==0.4.1.1,+ cprng-aes ==0.5.2,+ crypto-cipher-types ==0.0.9,+ crypto-numbers ==0.2.3,+ crypto-pubkey ==0.2.4,+ crypto-pubkey-types ==0.4.2.2,+ crypto-random ==0.0.7,+ cryptohash ==0.11.6,+ data-default ==0.5.3,+ data-default-class ==0.0.1,+ data-default-instances-base ==0.0.1,+ data-default-instances-containers ==0.0.1,+ data-default-instances-dlist ==0.0.1,+ data-default-instances-old-locale ==0.0.1,+ deepseq ==1.3.0.2,+ directory ==1.2.1.0,+ dlist ==0.7.1,+ exceptions ==0.6.1,+ filepath ==1.3.0.2,+ ghc-prim ==0.3.1.0,+ hashable ==1.2.2.0,+ http-client ==0.3.4,+ http-client-tls ==0.2.1.2,+ http-conduit ==2.1.2.3,+ http-types ==0.8.5,+ integer-gmp ==0.5.1.0,+ lifted-base ==0.2.3.0,+ mime-types ==0.1.0.4,+ mmorph ==1.0.3,+ monad-control ==0.3.3.0,+ mtl ==2.1.3.1,+ nats ==0.2,+ network ==2.5.0.0,+ old-locale ==1.0.0.6,+ old-time ==1.1.0.2,+ parsec ==3.1.5,+ parsers ==0.12,+ pem ==0.2.2,+ pretty ==1.1.1.1,+ primitive ==0.5.3.0,+ process ==1.2.0.0,+ publicsuffixlist ==0.1,+ quickcheck-instances ==0.3.8,+ random ==1.0.1.1,+ resourcet ==1.1.2.2,+ rts ==1.0,+ scientific ==0.3.3.0,+ securemem ==0.1.3,+ semigroups ==0.15.1,+ socks ==0.5.4,+ streaming-commons ==0.1.3.1,+ syb ==0.4.2,+ system-filepath ==0.4.12,+ template-haskell ==2.9.0.0,+ text ==1.1.1.3,+ tf-random ==0.5,+ time ==1.4.2,+ tls ==1.2.8,+ transformers ==0.3.0.0,+ transformers-base ==0.4.2,+ unix ==2.7.0.1,+ unordered-containers ==0.2.5.0,+ utf8-string ==0.3.8,+ vector ==0.10.11.0,+ void ==0.6.1,+ x509 ==1.4.11,+ x509-store ==1.4.4,+ x509-system ==1.4.5,+ x509-validation ==1.5.0,+ xml-conduit ==1.2.0.3,+ xml-types ==0.3.4,+ zlib ==0.5.4.1
+ src/Aws/Sns.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: Aws.Sns+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- /API Version: 2013-03-31/+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/APIReference/Welcome.html>+--+-- The types and functions of this package are supposed to be+-- use with the machinery from the+-- <https://hackage.haskell.org/package/aws aws package>.+--+-- Here is a very simple example for making a single request to AWS SNS.+--+-- > import Aws+-- > import Aws.Core+-- > import Aws.General+-- > import Aws.Sns+-- > import Data.IORef+-- >+-- > cfg <- Aws.baseConfiguration+-- > creds <- Credentials "access-key-id" "secret-access-key" `fmap` newIORef []+-- > let snsCfg = SnsConfiguration HTTPS UsWest2+-- > simpleAws cfg snsCfg $ ListTopics Nothing+--+-- In order to run the example you must replace @"access-key-id"@ and+-- @"secret-access-key"@ with the respective values for your AWS account.+--+module Aws.Sns+( module Aws.Sns.Core+, module Aws.Sns.Commands.CreateTopic+, module Aws.Sns.Commands.DeleteTopic+, module Aws.Sns.Commands.ListTopics+, module Aws.Sns.Commands.Subscribe+, module Aws.Sns.Commands.Unsubscribe+, module Aws.Sns.Commands.Publish+, module Aws.Sns.Commands.ConfirmSubscription+, module Aws.Sns.Commands.ListSubscriptionsByTopic+, module Aws.Sns.Commands.GetSubscriptionAttributes+) where++import Aws.Sns.Core+import Aws.Sns.Commands.CreateTopic+import Aws.Sns.Commands.DeleteTopic+import Aws.Sns.Commands.ListTopics+import Aws.Sns.Commands.Subscribe+import Aws.Sns.Commands.Unsubscribe+import Aws.Sns.Commands.Publish+import Aws.Sns.Commands.ConfirmSubscription+import Aws.Sns.Commands.ListSubscriptionsByTopic+import Aws.Sns.Commands.GetSubscriptionAttributes+
+ src/Aws/Sns/Commands/ConfirmSubscription.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- |+-- Module: Aws.Sns.Commands.ConfirmSubscription+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- /API Version: 2013-03-31/+--+-- Verifies an endpoint owner's intent to receive messages by validating the+-- token sent to the endpoint by an earlier Subscribe action. If the token is+-- valid, the action creates a new subscription and returns its Amazon Resource+-- Name (ARN). This call requires an AWS signature only when the+-- AuthenticateOnUnsubscribe flag is set to "true".+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/APIReference/API_ConfirmSubscription.html>+--+module Aws.Sns.Commands.ConfirmSubscription+( ConfirmSubscription(..)+, ConfirmSubscriptionResponse(..)+, ConfirmSubscriptionErrors(..)+) where++import Aws.Core+import Aws.General+import Aws.Sns.Core++import Control.Applicative+import Control.Monad.Trans.Resource (throwM)++import Data.Monoid+import Data.String+import qualified Data.Text as T+import Data.Typeable++import Text.XML.Cursor (($//), (&/))+import qualified Text.XML.Cursor as CU++confirmSubscriptionAction :: SnsAction+confirmSubscriptionAction = SnsActionConfirmSubscription++-- -------------------------------------------------------------------------- --+-- Subscription Confirmation Token++newtype SubscriptionConfirmationToken = SubscriptionConfirmationToken+ { subscriptionConfirmationTokenText :: T.Text+ }+ deriving (Show, Read, Eq, Ord, Monoid, IsString, Typeable)++-- -------------------------------------------------------------------------- --+-- Confirm Subscription++data ConfirmSubscription = ConfirmSubscription+ { confirmSubscriptionAuthenticateOnUnsubscribe:: !Bool+ -- ^ Disallows unauthenticated unsubscribes of the subscription. If the+ -- value of this parameter is true and the request has an AWS signature,+ -- then only the topic owner and the subscription owner can unsubscribe the+ -- endpoint. The unsubscribe action requires AWS authentication.++ , confirmSubscriptionToken :: !SubscriptionConfirmationToken+ -- ^ Short-lived token sent to an endpoint during the Subscribe action.++ , confirmSubscriptionTopicArn :: Arn+ -- ^ The ARN of the topic for which you wish to confirm a subscription.+ }+ deriving (Show, Read, Eq, Ord, Typeable)++data ConfirmSubscriptionResponse = ConfirmSubscriptionResponse+ { confirmSubscriptionResSubscriptionArn :: !Arn+ -- ^ The ARN of the created subscription.+ }+ deriving (Show, Read, Eq, Ord, Typeable)++instance ResponseConsumer r ConfirmSubscriptionResponse where+ type ResponseMetadata ConfirmSubscriptionResponse = SnsMetadata+ responseConsumer _ = snsXmlResponseConsumer p+ where+ p el = ConfirmSubscriptionResponse <$> arn el+ arn el = do+ t <- force "Missing topic ARN" $ el+ $// CU.laxElement "ConfirmSubscriptionResult"+ &/ CU.laxElement "SubscriptionArn"+ &/ CU.content+ case fromText t of+ Right a -> return a+ Left e -> throwM $ SnsResponseDecodeError $+ "failed to parse subscription ARN (" <> t <> "): " <> (T.pack . show) e++instance SignQuery ConfirmSubscription where+ type ServiceConfiguration ConfirmSubscription = SnsConfiguration+ signQuery ConfirmSubscription{..} = snsSignQuery SnsQuery+ { snsQueryMethod = Get+ , snsQueryAction = confirmSubscriptionAction+ , snsQueryParameters = authOnUnsubscribe <>+ [ ("Token", Just $ subscriptionConfirmationTokenText confirmSubscriptionToken)+ , ("TopicArn", Just $ toText confirmSubscriptionTopicArn)+ ]+ , snsQueryBody = Nothing+ }+ where+ authOnUnsubscribe = if confirmSubscriptionAuthenticateOnUnsubscribe+ then [ ("AuthenticateOnUnsubscribe", Just "true") ]+ else []++instance Transaction ConfirmSubscription ConfirmSubscriptionResponse++instance AsMemoryResponse ConfirmSubscriptionResponse where+ type MemoryResponse ConfirmSubscriptionResponse = ConfirmSubscriptionResponse+ loadToMemory = return++-- -------------------------------------------------------------------------- --+-- Errors+--+-- Currently not used for requests. It's included for future usage+-- and as reference.++data ConfirmSubscriptionErrors+ = ConfirmSubscriptionAuthorizationError+ -- ^ Indicates that the user has been denied access to the requested resource.+ --+ -- /Code 403/++ | ConfirmSubscriptionInternalError+ -- ^ Indicates an internal service error.+ --+ -- /Code 500/++ | ConfirmSubscriptionInvalidParameter+ -- ^ Indicates that a request parameter does not comply with the associated constraints.+ --+ -- /Code 400/++ | ConfirmSubscriptionNotFound+ -- ^ Indicates that the requested resource does not exist.+ --+ -- /Code 404/++ | ConfirmSubscriptionSubscriptionLimitExceeded+ -- ^ Indicates that the customer already owns the maximum allowed number of subscriptions.+ --+ -- /Code 403/++ deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)++
+ src/Aws/Sns/Commands/CreateTopic.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- |+-- Module: Aws.Sns.Commands.CreateTopic+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- /API Version: 2013-03-31/+--+-- Creates a topic to which notifications can be published. Users can create at+-- most 3000 topics. For more information, see <http://aws.amazon.com/sns>. This+-- action is idempotent, so if the requester already owns a topic with the+-- specified name, that topic's ARN is returned without creating a new topic.+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/APIReference/API_CreateTopic.html>+--+module Aws.Sns.Commands.CreateTopic+( CreateTopic(..)+, CreateTopicResponse(..)+, CreateTopicErrors(..)+) where++import Aws.Core+import Aws.General+import Aws.Sns.Core++import Control.Applicative+import Control.Monad.Trans.Resource (throwM)++import Data.Monoid+import qualified Data.Text as T+import Data.Typeable++import Text.XML.Cursor (($//), (&/))+import qualified Text.XML.Cursor as CU++createTopicAction :: SnsAction+createTopicAction = SnsActionCreateTopic++data CreateTopic = CreateTopic+ { createTopicName :: !T.Text+ -- ^ The name of the topic you want to create. Topic names must be made up+ -- of only uppercase and lowercase ASCII letters, numbers, underscores, and+ -- hyphens, and must be between 1 and 256 characters long+ }+ deriving (Show, Read, Eq, Ord, Typeable)++data CreateTopicResponse = CreateTopicResponse+ { createTopicResTopicArn :: !Arn+ -- ^ The Amazon Resource Name (ARN) assigned to the created topic.+ }+ deriving (Show, Read, Eq, Ord, Typeable)++instance ResponseConsumer r CreateTopicResponse where+ type ResponseMetadata CreateTopicResponse = SnsMetadata+ responseConsumer _ = snsXmlResponseConsumer p+ where+ p el = CreateTopicResponse <$> arn el+ arn el = do+ t <- force "Missing topic ARN" $ el+ $// CU.laxElement "CreateTopicResult"+ &/ CU.laxElement "TopicArn"+ &/ CU.content+ case fromText t of+ Right a -> return a+ Left e -> throwM $ SnsResponseDecodeError $+ "failed to parse topic ARN (" <> t <> "): " <> (T.pack . show) e++instance SignQuery CreateTopic where+ type ServiceConfiguration CreateTopic = SnsConfiguration+ signQuery CreateTopic{..} = snsSignQuery SnsQuery+ { snsQueryMethod = Get+ , snsQueryAction = createTopicAction+ , snsQueryParameters = [("Name", Just createTopicName)]+ , snsQueryBody = Nothing+ }++instance Transaction CreateTopic CreateTopicResponse++instance AsMemoryResponse CreateTopicResponse where+ type MemoryResponse CreateTopicResponse = CreateTopicResponse+ loadToMemory = return++-- -------------------------------------------------------------------------- --+-- Errors+--+-- Currently not used for requests. It's included for future usage+-- and as reference.++data CreateTopicErrors+ = CreateTopicAuthorizationError+ -- ^ Indicates that the user has been denied access to the requested resource.+ --+ -- /Code 403/++ | CreateTopicInternalError+ -- ^ Indicates an internal service error.+ --+ -- /Code 500/++ | CreateTopicInvalidParameter+ -- ^ Indicates that a request parameter does not comply with the associated constraints.+ --+ -- /Code 400/++ | CreateTopicTopicLimitExceeded+ -- ^ Indicates that the customer already owns the maximum allowed number of topics.+ --+ -- /Code 403/+ deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)+
+ src/Aws/Sns/Commands/DeleteTopic.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- |+-- Module: Aws.Sns.Commands.DeleteTopic+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- /API Version: 2013-03-31/+--+-- Deletes a topic and all its subscriptions. Deleting a topic might prevent+-- some messages previously sent to the topic from being delivered to+-- subscribers. This action is idempotent, so deleting a topic that does not+-- exist does not result in an error.+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/APIReference/API_DeleteTopic.html>+--+module Aws.Sns.Commands.DeleteTopic+( DeleteTopic(..)+, DeleteTopicResponse(..)+, DeleteTopicErrors(..)+) where++import Aws.Core+import Aws.General+import Aws.Sns.Core++import Data.Typeable++deleteTopicAction :: SnsAction+deleteTopicAction = SnsActionDeleteTopic++data DeleteTopic = DeleteTopic+ { deleteTopicArn :: !Arn+ -- ^ The ARN of the topic you want to delete.+ }+ deriving (Show, Read, Eq, Ord, Typeable)++data DeleteTopicResponse = DeleteTopicResponse+ {}+ deriving (Show, Read, Eq, Ord, Typeable)++instance ResponseConsumer r DeleteTopicResponse where+ type ResponseMetadata DeleteTopicResponse = SnsMetadata+ responseConsumer _ = snsXmlResponseConsumer $ \_ ->+ return DeleteTopicResponse++instance SignQuery DeleteTopic where+ type ServiceConfiguration DeleteTopic = SnsConfiguration+ signQuery DeleteTopic{..} = snsSignQuery SnsQuery+ { snsQueryMethod = Get+ , snsQueryAction = deleteTopicAction+ , snsQueryParameters = [("TopicArn", Just $ toText deleteTopicArn)]+ , snsQueryBody = Nothing+ }++instance Transaction DeleteTopic DeleteTopicResponse++instance AsMemoryResponse DeleteTopicResponse where+ type MemoryResponse DeleteTopicResponse = DeleteTopicResponse+ loadToMemory = return++-- -------------------------------------------------------------------------- --+-- Errors+--+-- Currently not used for requests. It's included for future usage+-- and as reference.++data DeleteTopicErrors+ = DeleteTopicAuthorizationError+ -- ^ Indicates that the user has been denied access to the requested resource.+ --+ -- /Code 403/++ | DeleteTopicInternalError+ -- ^ Indicates an internal service error.+ --+ -- /Code 500/++ | DeleteTopicInvalidParameter+ -- ^ Indicates that a request parameter does not comply with the associated constraints.+ --+ -- /Code 400/++ | DeleteTopicTopicNotFound+ -- ^ Indicates that the requested resource does not exist.+ --+ -- /Code 404/+ deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)+
+ src/Aws/Sns/Commands/GetSubscriptionAttributes.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: Aws.Sns.Commands.GetSubscriptionAttributes+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- /API Version: 2013-03-31/+--+-- Returns all of the properties of a subscription.+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/api/API_GetSubscriptionAttributes.html>+--+module Aws.Sns.Commands.GetSubscriptionAttributes+( SubscriptionAttributes(..)+, GetSubscriptionAttributes(..)+, GetSubscriptionAttributesResponse(..)+, GetSubscriptionAttributesErrors(..)+) where++import Aws.Core+import Aws.General+import Aws.Sns.Internal+import Aws.Sns.Core++import Control.Applicative+import Control.Exception+import Control.Monad.Trans.Resource (throwM)++import qualified Data.Text as T+import qualified Data.Traversable as TR+import Data.Typeable++import Text.XML.Cursor (($//), (&/))+import qualified Text.XML.Cursor as CU++type DeliveryPolicy = T.Text++-- | Subscription Attributes+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/api/API_GetSubscriptionAttributes.html>+--+-- TODO find out which of the fields in the structure are optional and+-- which are required.+--+data SubscriptionAttributes = SubscriptionAttributes+ { subscriptionAttrSubscriptionArn :: !(Maybe Arn)+ -- ^ the subscription's ARN+ , subscriptionAttrTopicArn :: !(Maybe Arn)+ -- ^ the topic ARN that the subscription is associated with+ , subscriptionAttrOwner :: !(Maybe AccountId)+ -- ^ the AWS account ID of the subscription's owner+ , subscriptionAttrConfirmationWasAuthenticated :: !Bool+ -- ^ 'True' if the subscription confirmation request was authenticated+ , subscriptionAttrDeliveryPolicy :: !(Maybe DeliveryPolicy)+ -- ^ the JSON serialization of the subscription's delivery policy+ , subscriptionAttrEffectiveDeliveryPolicy :: !(Maybe DeliveryPolicy)+ -- ^ the JSON serialization of the effective delivery policy that takes into+ -- account the topic delivery policy and account system defaults+ }+ deriving (Show, Read, Eq, Ord, Typeable)++-- -------------------------------------------------------------------------- --+-- GetSubscriptionAttributes++getSubscriptionAttributesAction :: SnsAction+getSubscriptionAttributesAction = SnsActionGetSubscriptionAttributes++data GetSubscriptionAttributes = GetSubscriptionAttributes+ { getSubscriptionAttributesSubscriptionArn :: !Arn+ -- ^ The ARN of the subscription whose properties you want to get.+ }+ deriving (Show, Read, Eq, Ord, Typeable)++data GetSubscriptionAttributesResponse = GetSubscriptionAttributesResponse+ { getSubscriptionAttributesResAttributes :: !SubscriptionAttributes+ }+ deriving (Show, Read, Eq, Ord, Typeable)++instance ResponseConsumer r GetSubscriptionAttributesResponse where+ type ResponseMetadata GetSubscriptionAttributesResponse = SnsMetadata+ responseConsumer _ = snsXmlResponseConsumer p+ where+ p :: CU.Cursor -> Response (ResponseMetadata GetSubscriptionAttributesResponse) GetSubscriptionAttributesResponse+ p el = either throwM return $ do+ entries <- fmap parseXmlEntryMap $ force "Missing Attributes" $ el+ $// CU.laxElement "GetSubscriptionAttributesResult"+ &/ CU.laxElement "Attributes"+ fmapL (toException . XmlException) . fmap GetSubscriptionAttributesResponse $ SubscriptionAttributes+ <$> TR.mapM fromText (lookup "SubscriptionArn" entries)+ <*> TR.mapM fromText (lookup "TopicArn" entries)+ <*> (pure $ fmap AccountId (lookup "Owner" entries))+ <*> pure (maybe False (== "true") (lookup "ConfirmationWasAuthenticated" entries))+ <*> pure (lookup "DeliveryPolicy" entries)+ <*> pure (lookup "EffectiveDeliveryPolicy" entries)++instance SignQuery GetSubscriptionAttributes where+ type ServiceConfiguration GetSubscriptionAttributes = SnsConfiguration+ signQuery GetSubscriptionAttributes{..} = snsSignQuery SnsQuery+ { snsQueryMethod = Get+ , snsQueryAction = getSubscriptionAttributesAction+ , snsQueryParameters = [("SubscriptionArn", Just $ toText getSubscriptionAttributesSubscriptionArn)]+ , snsQueryBody = Nothing+ }++instance Transaction GetSubscriptionAttributes GetSubscriptionAttributesResponse++instance AsMemoryResponse GetSubscriptionAttributesResponse where+ type MemoryResponse GetSubscriptionAttributesResponse = GetSubscriptionAttributesResponse+ loadToMemory = return++-- -------------------------------------------------------------------------- --+-- Errors+--+-- Currently not used for requests. It's included for future usage+-- and as reference.++data GetSubscriptionAttributesErrors+ = GetSubscriptionAttributesAuthorizationError+ -- ^ Indicates that the user has been denied access to the requested resource.+ --+ -- /Code 403/++ | GetSubscriptionAttributesInternalError+ -- ^ Indicates an internal service error.+ --+ -- /Code 500/++ | GetSubscriptionAttributesInvalidParameter+ -- ^ Indicates that a request parameter does not comply with the associated constraints.+ --+ -- /Code 400/++ | GetSubscriptionAttributesNotFound+ -- ^ Indicates that the requested resource does not exist.+ --+ -- /Code 404/++ deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)+
+ src/Aws/Sns/Commands/ListSubscriptionsByTopic.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- |+-- Module: Aws.Sns.Commands.ListSubscriptionsByTopic+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- /API Version: 2013-03-31/+--+-- Returns a list of the subscriptions to a specific topic. Each call returns a+-- limited list of subscriptions, up to 100. If there are more subscriptions, a+-- NextToken is also returned. Use the NextToken parameter in a new+-- ListSubscriptionsByTopic call to get further results.+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/APIReference/API_ListSubscriptionsByTopic.html>+--+module Aws.Sns.Commands.ListSubscriptionsByTopic+( Subscription(..)+, ListSubscriptionsByTopicNextToken+, ListSubscriptionsByTopic(..)+, ListSubscriptionsByTopicResponse(..)+, ListSubscriptionsByTopicErrors(..)+) where++import Aws.Core+import Aws.General+import Aws.Sns.Core++import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Resource (throwM)++import Data.Maybe+import Data.Monoid+import Data.String+import qualified Data.Text as T+import qualified Data.Traversable as TR+import Data.Typeable++import Text.XML.Cursor (($//), ($/), (&/), (&|))+import qualified Text.XML.Cursor as CU++-- -------------------------------------------------------------------------- --+-- Subscription++-- | A wrapper type for the attributes of an Amazon SNS subscription.+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/APIReference/API_Subscription.html>+--+data Subscription = Subscription+ { subscriptionEndpoint :: !(Maybe SnsEndpoint)+ -- ^ The subscription's endpoint (format depends on the protocol).+ , subscriptionOwner :: !(Maybe T.Text) -- FIXME I think this is actually an account ID+ -- ^ The subscription's owner.+ , subscriptionProtocol :: !(Maybe SnsProtocol)+ -- ^ The subscription's protocol.+ , subscriptionSubscriptionArn :: !(Maybe Arn)+ -- ^ The subscription's ARN.+ , subscriptionTopicArn :: !(Maybe Arn)+ -- ^ The ARN of the subscription's topic.+ }+ deriving (Show, Read, Eq, Ord)++subscriptionParseXml :: CU.Cursor -> Either String Subscription+subscriptionParseXml el = Subscription+ <$> (pure . listToMaybe $ el $/ CU.laxElement "Endpoint" &/ CU.content)+ <*> (pure . listToMaybe $ el $/ CU.laxElement "Owner" &/ CU.content)+ <*> (TR.mapM fromText . listToMaybe $ el $/ CU.laxElement "Protocol" &/ CU.content)+ <*> (subArnFromText . listToMaybe $ el $/ CU.laxElement "SubscriptionArn" &/ CU.content)+ <*> (TR.mapM fromText . listToMaybe $ el $/ CU.laxElement "TopicArn" &/ CU.content)+ where+ subArnFromText :: Maybe T.Text -> Either String (Maybe Arn)+ subArnFromText (Just "PendingConfirmation") = Right Nothing+ subArnFromText t = TR.mapM fromText t++-- -------------------------------------------------------------------------- --+-- List Subscriptions By Topic++listSubscriptionsByTopicAction :: SnsAction+listSubscriptionsByTopicAction = SnsActionListSubscriptionsByTopic++newtype ListSubscriptionsByTopicNextToken = ListSubscriptionsByTopicNextToken+ { listSubscriptionsByTopicNextTokenText :: T.Text+ }+ deriving (Show, Read, Eq, Ord, Monoid, IsString)++data ListSubscriptionsByTopic = ListSubscriptionsByTopic+ { listSubscriptionsByTopicNextToken :: !(Maybe ListSubscriptionsByTopicNextToken)+ -- ^ Token returned by the previous 'ListSubscriptionsByTopic' request.+ , listSubscriptionsByTopicArn :: !Arn+ }+ deriving (Show, Read, Eq, Ord, Typeable)++data ListSubscriptionsByTopicResponse = ListSubscriptionsByTopicResponse+ { listSubscriptionsByTopicResponseNextToken :: !(Maybe ListSubscriptionsByTopicNextToken)+ -- ^ Token to pass along to the next ListSubscriptionsByTopic request. This element is+ -- returned if there are additional topics to retrieve.++ , listSubscriptionsByTopicResponseSubscriptions :: ![Subscription]+ -- ^ A list of topic ARNs.+ }+ deriving (Show, Read, Eq, Ord, Typeable)++instance ResponseConsumer r ListSubscriptionsByTopicResponse where+ type ResponseMetadata ListSubscriptionsByTopicResponse = SnsMetadata+ responseConsumer _ = snsXmlResponseConsumer p+ where+ p el = ListSubscriptionsByTopicResponse (nextToken el) <$> subs el+ subs el = do+ let t = el+ $// CU.laxElement "ListSubscriptionsByTopicResult"+ &/ CU.laxElement "Subscriptions"+ &/ CU.laxElement "member"+ &| subscriptionParseXml+ forM t $ \i -> case i of+ Right a -> return a+ Left e -> throwM $ SnsResponseDecodeError+ $ "failed to parse subscriptions: " <> T.pack e+ nextToken el = fmap ListSubscriptionsByTopicNextToken . listToMaybe $ el+ $// CU.laxElement "ListSubscriptionsByTopicResult"+ &/ CU.laxElement "NextToken"+ &/ CU.content++instance SignQuery ListSubscriptionsByTopic where+ type ServiceConfiguration ListSubscriptionsByTopic = SnsConfiguration+ signQuery ListSubscriptionsByTopic{..} = snsSignQuery SnsQuery+ { snsQueryMethod = Get+ , snsQueryAction = listSubscriptionsByTopicAction+ , snsQueryParameters = nextToken <>+ [ ("TopicArn", Just $ toText listSubscriptionsByTopicArn)+ ]+ , snsQueryBody = Nothing+ }+ where+ nextToken = case listSubscriptionsByTopicNextToken of+ Nothing -> []+ Just _ -> [("NextToken", tokParam)]+ tokParam = listSubscriptionsByTopicNextTokenText <$> listSubscriptionsByTopicNextToken++instance Transaction ListSubscriptionsByTopic ListSubscriptionsByTopicResponse++instance AsMemoryResponse ListSubscriptionsByTopicResponse where+ type MemoryResponse ListSubscriptionsByTopicResponse = ListSubscriptionsByTopicResponse+ loadToMemory = return++instance ListResponse ListSubscriptionsByTopicResponse Subscription where+ listResponse (ListSubscriptionsByTopicResponse _ subs) = subs++instance IteratedTransaction ListSubscriptionsByTopic ListSubscriptionsByTopicResponse where+ nextIteratedRequest query ListSubscriptionsByTopicResponse{..} =+ query+ { listSubscriptionsByTopicNextToken = listSubscriptionsByTopicResponseNextToken+ }+ <$ listSubscriptionsByTopicResponseNextToken++-- -------------------------------------------------------------------------- --+-- Errors+--+-- Currently not used for requests. It's included for future usage+-- and as reference.++data ListSubscriptionsByTopicErrors+ = ListSubscriptionsByTopicAuthorizationError+ -- ^ Indicates that the user has been denied access to the requested resource.+ --+ -- /Code 403/++ | ListSubscriptionsByTopicInternalError+ -- ^ Indicates an internal service error.+ --+ -- /Code 500/++ | ListSubscriptionsByTopicInvalidParameter+ -- ^ Indicates that a request parameter does not comply with the associated constraints.+ --+ -- /Code 400/++ | ListSubscriptionsByTopicNotFound+ -- ^ Indicates that the requested resource does not exist.+ --+ -- /Code 404/++ deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)+++
+ src/Aws/Sns/Commands/ListTopics.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- |+-- Module: Aws.Sns.Commands.ListTopics+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- /API Version: 2013-03-31/+--+-- Returns a list of the requester's topics. Each call returns a limited list+-- of topics, up to 100. If there are more topics, a NextToken is also+-- returned. Use the NextToken parameter in a new ListTopics call to get+-- further results.+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/APIReference/API_ListTopics.html>+--+module Aws.Sns.Commands.ListTopics+( ListTopicsNextToken+, ListTopics(..)+, ListTopicsResponse(..)+, ListTopicsErrors(..)+) where++import Aws.Core+import Aws.General+import Aws.Sns.Core++import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Resource (throwM)++import Data.Maybe+import Data.Monoid+import Data.String+import qualified Data.Text as T+import Data.Typeable++import Text.XML.Cursor (($//), (&/))+import qualified Text.XML.Cursor as CU++listTopicsAction :: SnsAction+listTopicsAction = SnsActionListTopics++newtype ListTopicsNextToken = ListTopicsNextToken { listTopicsNextTokenText :: T.Text }+ deriving (Show, Read, Eq, Ord, Monoid, IsString)++data ListTopics = ListTopics+ { listTopicsNextToken :: !(Maybe ListTopicsNextToken)+ -- ^ Token returned by the previous 'ListTopics' request.+ }+ deriving (Show, Read, Eq, Ord, Typeable)++data ListTopicsResponse = ListTopicsResponse+ { listTopicsResponseNextToken :: !(Maybe ListTopicsNextToken)+ -- ^ Token to pass along to the next ListTopics request. This element is+ -- returned if there are additional topics to retrieve.+ --++ , listTopicsResponseTopics :: ![Arn]+ -- ^ A list of topic ARNs.+ }+ deriving (Show, Read, Eq, Ord, Typeable)++instance ResponseConsumer r ListTopicsResponse where+ type ResponseMetadata ListTopicsResponse = SnsMetadata+ responseConsumer _ = snsXmlResponseConsumer p+ where+ p el = ListTopicsResponse (nextToken el) <$> arns el+ arns el = do+ let t = el+ $// CU.laxElement "ListTopicsResult"+ &/ CU.laxElement "Topics"+ &/ CU.laxElement "member"+ &/ CU.laxElement "TopicArn"+ &/ CU.content+ forM t $ \i -> case fromText i of+ Right a -> return a+ Left e -> throwM $ SnsResponseDecodeError+ $ "failed to parse topic ARN (" <> i <> "): " <> (T.pack . show) e+ nextToken el = fmap ListTopicsNextToken . listToMaybe $ el+ $// CU.laxElement "ListTopicsResult"+ &/ CU.laxElement "NextToken"+ &/ CU.content++instance SignQuery ListTopics where+ type ServiceConfiguration ListTopics = SnsConfiguration+ signQuery ListTopics{..} = snsSignQuery SnsQuery+ { snsQueryMethod = Get+ , snsQueryAction = listTopicsAction+ , snsQueryParameters = case listTopicsNextToken of+ Nothing -> []+ Just _ -> [("NextToken", listTopicsNextTokenText <$> listTopicsNextToken)]+ , snsQueryBody = Nothing+ }++instance Transaction ListTopics ListTopicsResponse++instance AsMemoryResponse ListTopicsResponse where+ type MemoryResponse ListTopicsResponse = ListTopicsResponse+ loadToMemory = return++instance ListResponse ListTopicsResponse Arn where+ listResponse (ListTopicsResponse _ arns) = arns++instance IteratedTransaction ListTopics ListTopicsResponse where+ nextIteratedRequest _ ListTopicsResponse{..} =+ ListTopics listTopicsResponseNextToken <$ listTopicsResponseNextToken++-- -------------------------------------------------------------------------- --+-- Errors+--+-- Currently not used for requests. It's included for future usage+-- and as reference.++data ListTopicsErrors+ = ListTopicsAuthorizationError+ -- ^ Indicates that the user has been denied access to the requested resource.+ --+ -- /Code 403/++ | ListTopicsInternalError+ -- ^ Indicates an internal service error.+ --+ -- /Code 500/++ | ListTopicsInvalidParameter+ -- ^ Indicates that a request parameter does not comply with the associated constraints.+ --+ -- /Code 400/++ deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)++
+ src/Aws/Sns/Commands/Publish.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- |+-- Module: Aws.Sns.Commands.Publish+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- /API Version: 2013-03-31/+--+-- Sends a message to all of a topic's subscribed endpoints. When a messageId+-- is returned, the message has been saved and Amazon SNS will attempt to+-- deliver it to the topic's subscribers shortly. The format of the outgoing+-- message to each subscribed endpoint depends on the notification protocol+-- selected.+--+-- To use the Publish action for sending a message to a mobile endpoint, such+-- as an app on a Kindle device or mobile phone, you must specify the+-- EndpointArn. The EndpointArn is returned when making a call with the+-- CreatePlatformEndpoint action. The second example below shows a request and+-- response for publishing to a mobile endpoint.+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/APIReference/API_Publish.html>+--+module Aws.Sns.Commands.Publish+( SnsMessage(..)+, MessageId(..)+, snsMessage+, SqsNotification(..)+, Publish(..)+, PublishResponse(..)+, PublishErrors(..)+) where++import Aws.Core+import Aws.General+import Aws.Sns.Core+import Aws.Sns.Internal++import Control.Applicative++import Data.Aeson (ToJSON(..), FromJSON(..), (.:), withObject, encode)+import qualified Data.ByteString.Lazy as LB+import qualified Data.Map as M+import Data.Monoid+import Data.String+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time.Clock+import Data.Typeable++import qualified Network.HTTP.Types as HTTP++import Text.XML.Cursor (($//), (&/))+import qualified Text.XML.Cursor as CU++publishAction :: SnsAction+publishAction = SnsActionPublish++-- -------------------------------------------------------------------------- --+-- SNS Messages++data SnsMessage = SnsMessage+ { snsMessageDefault :: !T.Text+ , snsMessageMap :: !(M.Map SnsProtocol T.Text)+ }+ deriving (Show, Read, Eq, Ord, Typeable)++snsMessageParameters :: SnsMessage -> (Method, HTTP.QueryText)+snsMessageParameters SnsMessage{..} = if M.null snsMessageMap+ then (Get,)+ [ ("Message", Just snsMessageDefault)+ ]+ else (PostQuery,)+ [ ("MessageStructure", Just "json")+ , ("Message", (Just . T.decodeUtf8 . LB.toStrict) msg)+ ]+ where+ msg = encode+ . M.insert "default" snsMessageDefault+ . M.mapKeys (toText :: SnsProtocol -> String)+ $ snsMessageMap++snsMessage :: T.Text -> SnsMessage+snsMessage t = SnsMessage t M.empty++-- | Unique identifier assigned to a published message.+--+-- Length Constraint: Maximum 100 characters+--+newtype MessageId = MessageId { messageIdText :: T.Text }+ deriving (Show, Read, Eq, Ord, Monoid, IsString, Typeable, FromJSON, ToJSON)++-- -------------------------------------------------------------------------- --+-- SQS Notification Message++-- | The format of messages used with 'SnsProtocolSqs'+--+-- The format is described informally at+--+-- <http://docs.aws.amazon.com/sns/latest/dg/SendMessageToSQS.html>+--+data SqsNotification = SqsNotification+ { sqsNotificationMessageId :: !MessageId+ , sqsNotificationTopicArn :: !Arn+ , sqsNotificationSubject :: !(Maybe T.Text)+ , sqsNotificationMessage :: !T.Text+ , sqsNotificationTimestamp :: !UTCTime+ , sqsNotificationSignatureVersion :: !T.Text+ , sqsNotificationSignature :: !T.Text+ , sqsNotificationSigningCertURL :: !T.Text+ , sqsNotificationUnsubscribeURL :: !T.Text+ }+ deriving (Show, Read, Eq, Ord, Typeable)++instance FromJSON SqsNotification where+ parseJSON = withObject "SqsNotification" $ \o -> SqsNotification+ <$> o .: "MessageId"+ <*> o .: "TopicArn"+ <*> o .: "Subject"+ <*> o .: "Message"+ <*> o .: "Timestamp"+ <*> o .: "SignatureVersion"+ <*> o .: "Signature"+ <*> o .: "SigningCertURL"+ <*> o .: "UnsubscribeURL"+ <* (o .: "Type" >>= expectValue ("Notification" :: T.Text))++-- -------------------------------------------------------------------------- --+-- Publish++data Publish = Publish+ { publishMessage :: !SnsMessage+ -- ^ The message you want to send to the topic.+ --+ -- If you want to send the same message to all transport protocols, include+ -- the text of the message as a String value.+ --+ -- If you want to send different messages for each transport protocol add+ -- these to the 'snsMessageMap' map.+ --+ -- Constraints: Messages must be UTF-8 encoded strings at most 256 KB in+ -- size (262144 bytes, not 262144 characters).+ --++ , publishMessageAttributes_entry_N :: Maybe () -- TODO what's that?+ -- ^ Message attributes for Publish action.++ , publishSubject :: !(Maybe T.Text)+ -- ^ Optional parameter to be used as the "Subject" line when the message+ -- is delivered to email endpoints. This field will also be included, if+ -- present, in the standard JSON messages delivered to other endpoints.+ --+ -- Constraints: Subjects must be ASCII text that begins with a letter,+ -- number, or punctuation mark; must not include line breaks or control+ -- characters; and must be less than 100 characters long.+ --++ , publishArn :: !(Either Arn Arn)+ -- ^ Either TopicArn (left) or EndpointArn (right).++ }+ deriving (Show, Read, Eq, Ord, Typeable)++data PublishResponse = PublishResponse+ { publishMessageId :: !MessageId+ -- ^ Unique identifier assigned to the published message.+ }+ deriving (Show, Read, Eq, Ord, Typeable)++instance ResponseConsumer r PublishResponse where+ type ResponseMetadata PublishResponse = SnsMetadata+ responseConsumer _ = snsXmlResponseConsumer p+ where+ p el = PublishResponse . MessageId <$> arn el+ arn el = force "Missing Message Id" $ el+ $// CU.laxElement "PublishResult"+ &/ CU.laxElement "MessageId"+ &/ CU.content++instance SignQuery Publish where+ type ServiceConfiguration Publish = SnsConfiguration+ signQuery Publish{..} = snsSignQuery SnsQuery+ { snsQueryMethod = method+ , snsQueryAction = publishAction+ , snsQueryParameters = msgQuery <> subject <> arn <> entry+ , snsQueryBody = Nothing+ }+ where+ (method, msgQuery) = snsMessageParameters publishMessage+ subject = maybe [] (\x -> [("Subject", Just x)]) publishSubject+ arn = case publishArn of+ Left a -> [("TopicArn", Just $ toText a)]+ Right a -> [("TargetArn", Just $ toText a)]+ entry = [] -- TODO++instance Transaction Publish PublishResponse++instance AsMemoryResponse PublishResponse where+ type MemoryResponse PublishResponse = PublishResponse+ loadToMemory = return++-- -------------------------------------------------------------------------- --+-- Errors+--+-- Currently not used for requests. It's included for future usage+-- and as reference.++data PublishErrors+ = PublishAuthorizationError+ -- ^ Indicates that the user has been denied access to the requested resource.+ --+ -- /Code 403/++ | PublishInternalError+ -- ^ Indicates an internal service error.+ --+ -- /Code 500/++ | PublishInvalidParameter+ -- ^ Indicates that a request parameter does not comply with the associated constraints.+ --+ -- /Code 400/++ | PublishEndpointDisabled+ -- ^ Exception error indicating endpoint disabled.+ --+ -- /Code 400/++ | PublishInvalidParameterValue+ -- ^ Indicates that a request parameter does not comply with the associated constraints.+ --+ -- /Code 400/++ | PublishNotFound+ -- ^ Indicates that the requested resource does not exist.+ --+ -- /Code 404/++ | PublishApplicationDisabled+ -- ^ Exception error indicating platform application disabled.+ --+ -- /Code 400/+ deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)++
+ src/Aws/Sns/Commands/Subscribe.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- |+-- Module: Aws.Sns.Commands.Subscribe+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- /API Version: 2013-03-31/+--+-- Prepares to subscribe an endpoint by sending the endpoint a confirmation+-- message. To actually create a subscription, the endpoint owner must call the+-- ConfirmSubscription action with the token from the confirmation message.+-- Confirmation tokens are valid for three days.+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/APIReference/API_Subscribe.html>+--+module Aws.Sns.Commands.Subscribe+( Subscribe(..)+, SubscribeResponse(..)+, SubscribeErrors(..)+) where++import Aws.Core+import Aws.General+import Aws.Sns.Core++import Data.Traversable as TR+import Control.Applicative+import Control.Monad.Trans.Resource (throwM)++import Data.Maybe+import Data.Monoid+import qualified Data.Text as T+import Data.Typeable++import Text.XML.Cursor (($//), (&/))+import qualified Text.XML.Cursor as CU++subscribeAction :: SnsAction+subscribeAction = SnsActionSubscribe++data Subscribe = Subscribe+ { subscribeEndpoint :: !(Maybe SnsEndpoint)+ -- ^ The endpoint that you want to receive notifications.+ -- This must match with the corresponding protocol+ -- (see 'SnsEndPoint' for details).++ , subscribeProtocol :: !SnsProtocol+ -- ^ The protocol you want to use.++ , subscribeTopicArn :: !Arn+ -- ^ The ARN of the topic you want to subscribe to.+ }+ deriving (Show, Read, Eq, Ord, Typeable)++data SubscribeResponse = SubscribeResponse+ { subscribeResSubscriptionArn :: !(Maybe Arn)+ -- ^ The ARN of the subscription, if the service was able to create a+ -- subscription immediately (without requiring endpoint owner confirmation).+ }+ deriving (Show, Read, Eq, Ord, Typeable)++instance ResponseConsumer r SubscribeResponse where+ type ResponseMetadata SubscribeResponse = SnsMetadata+ responseConsumer _ = snsXmlResponseConsumer p+ where+ p el = SubscribeResponse <$> arn el+ arn el = do+ let t = listToMaybe . filter (/= "pending confirmation") $ el+ $// CU.laxElement "SubscribeResult"+ &/ CU.laxElement "SubscriptionArn"+ &/ CU.content+ TR.forM t $ \t_ -> case fromText t_ of+ Right a -> return a+ Left e -> throwM $ SnsResponseDecodeError $+ "failed to parse subscription ARN (" <> t_ <> "): " <> (T.pack . show) e++instance SignQuery Subscribe where+ type ServiceConfiguration Subscribe = SnsConfiguration+ signQuery Subscribe{..} = snsSignQuery SnsQuery+ { snsQueryMethod = Get+ , snsQueryAction = subscribeAction+ , snsQueryParameters = catMaybes+ [ ("Endpoint",) . Just <$> subscribeEndpoint+ , Just ("Protocol", Just . toText $ subscribeProtocol)+ , Just ("TopicArn", Just . toText $ subscribeTopicArn)+ ]+ , snsQueryBody = Nothing+ }++instance Transaction Subscribe SubscribeResponse++instance AsMemoryResponse SubscribeResponse where+ type MemoryResponse SubscribeResponse = SubscribeResponse+ loadToMemory = return++-- -------------------------------------------------------------------------- --+-- Errors+--+-- Currently not used for requests. It's included for future usage+-- and as reference.++data SubscribeErrors+ = SubscribeAuthorizationError+ -- ^ Indicates that the user has been denied access to the requested resource.+ --+ -- /Code 403/++ | SubscribeInternalError+ -- ^ Indicates an internal service error.+ --+ -- /Code 500/++ | SubscribeInvalidParameter+ -- ^ Indicates that a request parameter does not comply with the associated constraints.+ --+ -- /Code 400/++ | SubscribeNotFound+ -- ^ Indicates that the requested resource does not exist.+ --+ -- /Code 404/++ | SubscribeTopicLimitExceeded+ -- ^ Indicates that the customer already owns the maximum allowed number of subscriptions.+ --+ -- /Code 403/+ deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)++
+ src/Aws/Sns/Commands/Unsubscribe.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- |+-- Module: Aws.Sns.Commands.Unsubscribe+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- /API Version: 2013-03-31/+--+-- Deletes a subscription. If the subscription requires authentication for+-- deletion, only the owner of the subscription or the topic's owner can+-- unsubscribe, and an AWS signature is required. If the Unsubscribe call does+-- not require authentication and the requester is not the subscription owner,+-- a final cancellation message is delivered to the endpoint, so that the+-- endpoint owner can easily resubscribe to the topic if the Unsubscribe+-- request was unintended.+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/APIReference/API_Unsubscribe.html>+--+module Aws.Sns.Commands.Unsubscribe+( Unsubscribe(..)+, UnsubscribeResponse(..)+, UnsubscribeErrors(..)+) where++import Aws.Core+import Aws.General+import Aws.Sns.Core++import Data.Typeable++unsubscribeAction :: SnsAction+unsubscribeAction = SnsActionUnsubscribe++data Unsubscribe = Unsubscribe+ { unsubscribeSubscriptionArn :: !Arn+ -- ^ The ARN of the subscription to be deleted.+ }+ deriving (Show, Read, Eq, Ord, Typeable)++data UnsubscribeResponse = UnsubscribeResponse+ {}+ deriving (Show, Read, Eq, Ord, Typeable)++instance ResponseConsumer r UnsubscribeResponse where+ type ResponseMetadata UnsubscribeResponse = SnsMetadata+ responseConsumer _ = snsXmlResponseConsumer $ \_ ->+ return UnsubscribeResponse++instance SignQuery Unsubscribe where+ type ServiceConfiguration Unsubscribe = SnsConfiguration+ signQuery Unsubscribe{..} = snsSignQuery SnsQuery+ { snsQueryMethod = Get+ , snsQueryAction = unsubscribeAction+ , snsQueryParameters = [("SubscriptionArn", Just $ toText unsubscribeSubscriptionArn)]+ , snsQueryBody = Nothing+ }++instance Transaction Unsubscribe UnsubscribeResponse++instance AsMemoryResponse UnsubscribeResponse where+ type MemoryResponse UnsubscribeResponse = UnsubscribeResponse+ loadToMemory = return++-- -------------------------------------------------------------------------- --+-- Errors+--+-- Currently not used for requests. It's included for future usage+-- and as reference.++data UnsubscribeErrors+ = UnsubscribeAuthorizationError+ -- ^ Indicates that the user has been denied access to the requested resource.+ --+ -- /Code 403/++ | UnsubscribeInternalError+ -- ^ Indicates an internal service error.+ --+ -- /Code 500/++ | UnsubscribeInvalidParameter+ -- ^ Indicates that a request parameter does not comply with the associated constraints.+ --+ -- /Code 400/++ | UnsubscribeNotFound+ -- ^ Indicates that the requested resource does not exist.+ --+ -- /Code 403/+ deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)+
+ src/Aws/Sns/Core.hs view
@@ -0,0 +1,662 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++-- |+-- Module: Aws.Sns.Core+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- /API Version: 2013-03-31/+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/APIReference/Welcome.html>+--+module Aws.Sns.Core+(+ SnsVersion(..)++-- * SNS Client Configuration+, SnsConfiguration(..)++-- * SNS Client Metadata+, SnsMetadata(..)++-- * SNS Exceptions+, SnsErrorResponse(..)++-- * SNS Subscription Protocols+, SnsProtocol(..)+, snsProtocolToText+, parseSnsProtocol++-- * SNS Subscription Endpoints+, SnsEndpoint++-- * Internal++-- ** SNS Actions+, SnsAction(..)+, snsActionToText+, parseSnsAction++-- ** SNS AWS Service Endpoints+, snsServiceEndpoint++-- ** SNS Queries+, SnsQuery(..)+, snsSignQuery++-- ** SNS Response Consumers+, snsResponseConsumer+, snsXmlResponseConsumer+, snsErrorResponseConsumer++-- ** SNS Errors and Common Parameters+, SnsError(..)+, SnsCommonParameters(..)+, SnsCommonError(..)+) where++import Aws.Core+import Aws.General+import Aws.SignatureV4++import qualified Blaze.ByteString.Builder as BB++import Control.Applicative+import Control.Exception+import Control.Monad.IO.Class+import Control.Monad.Trans.Resource (throwM)++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import Data.Conduit (($$+-))+import Data.IORef+import Data.Maybe+import Data.Monoid+import Data.String+import Data.Time.Clock+import Data.Typeable+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++import qualified Network.HTTP.Types as HTTP+import qualified Network.HTTP.Conduit as HTTP++import qualified Test.QuickCheck as Q++import qualified Text.Parser.Char as P+import Text.Parser.Combinators ((<?>))+import qualified Text.XML as XML+import qualified Text.XML.Cursor as CU+import Text.XML.Cursor (($//))++data SnsVersion+ = SnsVersion_2013_03_31++-- -------------------------------------------------------------------------- --+-- SNS Actions++data SnsAction+ = SnsActionAddPermission+ | SnsActionConfirmSubscription+ | SnsActionCreatePlatformApplication+ | SnsActionCreatePlatformEndpoint+ | SnsActionCreateTopic+ | SnsActionDeleteEndPoint+ | SnsActionDeletePlatformApplication+ | SnsActionDeleteTopic+ | SnsActionGetEndpointAttributes+ | SnsActionGetPlatformApplicationAttribute+ | SnsActionGetSubscriptionAttributes+ | SnsActionGetTopicAttributes+ | SnsActionListEndpointsByPlatformApplication+ | SnsActionListPlatformApplications+ | SnsActionListSubscriptions+ | SnsActionListSubscriptionsByTopic+ | SnsActionListTopics+ | SnsActionPublish+ | SnsActionRemovePermission+ | SnsActionSetEndpointAttributes+ | SnsActionSetPlatformApplicationAttributes+ | SnsActionSetSubscriptionAttributes+ | SnsActionSetTopicAttributes+ | SnsActionSubscribe+ | SnsActionUnsubscribe+ deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)++snsActionToText :: IsString a => SnsAction -> a+snsActionToText SnsActionAddPermission = "AddPermission"+snsActionToText SnsActionConfirmSubscription = "ConfirmSubscription"+snsActionToText SnsActionCreatePlatformApplication = "CreatePlatformApplication"+snsActionToText SnsActionCreatePlatformEndpoint = "CreatePlatformEndpoint"+snsActionToText SnsActionCreateTopic = "CreateTopic"+snsActionToText SnsActionDeleteEndPoint = "DeleteEndPoint"+snsActionToText SnsActionDeletePlatformApplication = "DeletePlatformApplication"+snsActionToText SnsActionDeleteTopic = "DeleteTopic"+snsActionToText SnsActionGetEndpointAttributes = "GetEndpointAttributes"+snsActionToText SnsActionGetPlatformApplicationAttribute = "GetPlatformApplicationAttribute"+snsActionToText SnsActionGetSubscriptionAttributes = "GetSubscriptionAttributes"+snsActionToText SnsActionGetTopicAttributes = "GetTopicAttributes"+snsActionToText SnsActionListEndpointsByPlatformApplication = "ListEndpointsByPlatformApplication"+snsActionToText SnsActionListPlatformApplications = "ListPlatformApplications"+snsActionToText SnsActionListSubscriptions = "ListSubscriptions"+snsActionToText SnsActionListSubscriptionsByTopic = "ListSubscriptionsByTopic"+snsActionToText SnsActionListTopics = "ListTopics"+snsActionToText SnsActionPublish = "Publish"+snsActionToText SnsActionRemovePermission = "RemovePermission"+snsActionToText SnsActionSetEndpointAttributes = "SetEndpointAttributes"+snsActionToText SnsActionSetPlatformApplicationAttributes = "SetPlatformApplicationAttributes"+snsActionToText SnsActionSetSubscriptionAttributes = "SetSubscriptionAttributes"+snsActionToText SnsActionSetTopicAttributes = "SetTopicAttributes"+snsActionToText SnsActionSubscribe = "Subscribe"+snsActionToText SnsActionUnsubscribe = "Unsubscribe"++parseSnsAction :: P.CharParsing m => m SnsAction+parseSnsAction =+ SnsActionAddPermission <$ P.text "AddPermission"+ <|> SnsActionConfirmSubscription <$ P.text "ConfirmSubscription"+ <|> SnsActionCreatePlatformApplication <$ P.text "CreatePlatformApplication"+ <|> SnsActionCreatePlatformEndpoint <$ P.text "CreatePlatformEndpoint"+ <|> SnsActionCreateTopic <$ P.text "CreateTopic"+ <|> SnsActionDeleteEndPoint <$ P.text "DeleteEndPoint"+ <|> SnsActionDeletePlatformApplication <$ P.text "DeletePlatformApplication"+ <|> SnsActionDeleteTopic <$ P.text "DeleteTopic"+ <|> SnsActionGetEndpointAttributes <$ P.text "GetEndpointAttributes"+ <|> SnsActionGetPlatformApplicationAttribute <$ P.text "GetPlatformApplicationAttribute"+ <|> SnsActionGetSubscriptionAttributes <$ P.text "GetSubscriptionAttributes"+ <|> SnsActionGetTopicAttributes <$ P.text "GetTopicAttributes"+ <|> SnsActionListEndpointsByPlatformApplication <$ P.text "ListEndpointsByPlatformApplication"+ <|> SnsActionListPlatformApplications <$ P.text "ListPlatformApplications"+ <|> SnsActionListSubscriptions <$ P.text "ListSubscriptions"+ <|> SnsActionListSubscriptionsByTopic <$ P.text "ListSubscriptionsByTopic"+ <|> SnsActionListTopics <$ P.text "ListTopics"+ <|> SnsActionPublish <$ P.text "Publish"+ <|> SnsActionRemovePermission <$ P.text "RemovePermission"+ <|> SnsActionSetEndpointAttributes <$ P.text "SetEndpointAttributes"+ <|> SnsActionSetPlatformApplicationAttributes <$ P.text "SetPlatformApplicationAttributes"+ <|> SnsActionSetSubscriptionAttributes <$ P.text "SetSubscriptionAttributes"+ <|> SnsActionSetTopicAttributes <$ P.text "SetTopicAttributes"+ <|> SnsActionSubscribe <$ P.text "Subscribe"+ <|> SnsActionUnsubscribe <$ P.text "Unsubscribe"+ <?> "SnsAction"++instance AwsType SnsAction where+ toText = snsActionToText+ parse = parseSnsAction++instance Q.Arbitrary SnsAction where+ arbitrary = Q.elements [minBound..maxBound]++-- -------------------------------------------------------------------------- --+-- SNS AWS Service Endpoints++-- | SNS Endpoints as specified in AWS General API version 0.1+--+-- <http://docs.aws.amazon.com/general/1.0/gr/rande.html#sns_region>+--+-- This are the endpoints of the AWS SNS Service. This must not be+-- confused with an SNS endpoint that is a client that subscribes+-- to receive SNS notifications (see 'SnsEndpoint').+--+snsServiceEndpoint :: Region -> B8.ByteString+snsServiceEndpoint ApNortheast1 = "sns.ap-northeast-1.amazonaws.com"+snsServiceEndpoint ApSoutheast1 = "sns.ap-southeast-1.amazonaws.com"+snsServiceEndpoint ApSoutheast2 = "sns.ap-southeast-2.amazonaws.com"+snsServiceEndpoint EuWest1 = "sns.eu-west-1.amazonaws.com"+snsServiceEndpoint SaEast1 = "sns.sa-east-1.amazonaws.com"+snsServiceEndpoint UsEast1 = "sns.us-east-1.amazonaws.com"+snsServiceEndpoint UsWest1 = "sns.us-west-1.amazonaws.com"+snsServiceEndpoint UsWest2 = "sns.us-west-2.amazonaws.com"++-- -------------------------------------------------------------------------- --+-- SNS Metadata++data SnsMetadata = SnsMetadata+ { snsMAmzId2 :: Maybe T.Text+ , snsMRequestId :: Maybe T.Text+ }+ deriving (Show)++instance Loggable SnsMetadata where+ toLogText (SnsMetadata rid id2) =+ "SNS: request ID=" <> fromMaybe "<none>" rid+ <> ", x-amz-id-2=" <> fromMaybe "<none>" id2++instance Monoid SnsMetadata where+ mempty = SnsMetadata Nothing Nothing+ SnsMetadata id1 r1 `mappend` SnsMetadata id2 r2 = SnsMetadata (id1 <|> id2) (r1 <|> r2)++-- -------------------------------------------------------------------------- --+-- SNS Configuration++data SnsConfiguration qt = SnsConfiguration+ { snsConfProtocol :: Protocol+ , snsConfRegion :: Region+ }+ deriving (Show)++-- -------------------------------------------------------------------------- --+-- SNS Query++data SnsQuery = SnsQuery+ { snsQueryMethod :: !Method+ , snsQueryAction :: !SnsAction+ , snsQueryParameters :: !HTTP.QueryText+ , snsQueryBody :: !(Maybe B.ByteString)+ }+ deriving (Show, Eq)++-- | Creates a signed query.+--+-- Uses AWS Signature V4. All requests expect for publish+-- are GET requests with the signature embedded into the URI.+--+-- FIXME eliminate usage of 'error'. Either statically elimintate+-- possibility of failures or change type to Either.+--+snsSignQuery :: SnsQuery -> SnsConfiguration qt -> SignatureData -> SignedQuery+snsSignQuery query conf sigData = SignedQuery+ { sqMethod = method+ , sqProtocol = snsConfProtocol conf+ , sqHost = host+ , sqPort = port+ , sqPath = BB.toByteString $ HTTP.encodePathSegments path+ , sqQuery = HTTP.queryTextToQuery signedQuery+ , sqDate = Nothing+ , sqAuthorization = authorization+ , sqContentType = contentType+ , sqContentMd5 = Nothing+ , sqAmzHeaders = amzHeaders+ , sqOtherHeaders = [] -- headers -- we put everything into amzHeaders+ , sqBody = HTTP.RequestBodyBS <$> body+ , sqStringToSign = mempty -- Let me know if you really need this...+ }+ where+ -- values that don't depend on the signature+ action = snsQueryAction query+ path = []+ host = snsServiceEndpoint $ snsConfRegion conf+ headers = [("host", host)]+ port = case snsConfProtocol conf of+ HTTP -> 80+ HTTPS -> 443+ contentType = case snsQueryMethod query of+ Post -> Just "application/json"+ Get -> Nothing+ PostQuery -> Just "application/x-www-form-urlencoded; charset=utf-8"+ -- The following cases are currently not supported+ Put -> Just "application/json"+ Delete -> Nothing+ Head -> Nothing++ -- The following is somewhat hacky for dealing with method PostQuery+ -- TODO it may be better to have the commands take care of this...+ --+ -- Alternatively we may have the signing function decide what to do+ -- based on the method and always return the updated query and headers.+ --+ method = case snsQueryMethod query of+ PostQuery -> Post+ x -> x++ body = case snsQueryMethod query of+ PostQuery -> Just $ BB.toByteString $ HTTP.renderQueryText False+ $ ("Action", Just . toText $ action) : snsQueryParameters query+ _ -> snsQueryBody query++ unsignedQuery = case snsQueryMethod query of+ PostQuery -> []+ _ -> ("Action", Just . toText $ action) : snsQueryParameters query++ -- Values that depend on the signature+ (signedQuery, amzHeaders, authorization) = case method of+ Get -> (getQuery, getAmzHeaders, getAuthorization)+ Head -> (getQuery, getAmzHeaders, getAuthorization)+ Delete -> (getQuery, getAmzHeaders, getAuthorization)+ Post -> (postQuery, postAmzHeaders, postAuthorization)+ PostQuery -> (postQuery, postAmzHeaders, postAuthorization)+ Put -> (postQuery, postAmzHeaders, postAuthorization)++ -- signatue dependend values for POST request+ postAmzHeaders = filter ((/= "Authorization") . fst) postSignature+ postAuthorization = return <$> lookup "authorization" postSignature+ postQuery = unsignedQuery+ postSignature = either error id $ signPostRequest+ (cred2cred $ signatureCredentials sigData)+ (snsConfRegion conf)+ ServiceNamespaceSns+ (signatureTime sigData)+ (httpMethod method)+ path+ unsignedQuery+ headers+ (fromMaybe "" body)++ -- signature dependend values for GET request+ getAmzHeaders = headers+ getAuthorization = Nothing+ getQuery = getSignature+ getSignature = either error id $ signGetRequest+ (cred2cred $ signatureCredentials sigData)+ (snsConfRegion conf)+ ServiceNamespaceSns+ (signatureTime sigData)+ (httpMethod method)+ path+ unsignedQuery+ headers+ (fromMaybe "" body)++#if MIN_VERSION_aws(0,9,2)+ cred2cred (Credentials a b c _) = SignatureV4Credentials a b c+#else+ cred2cred (Credentials a b c) = SignatureV4Credentials a b c+#endif++-- -------------------------------------------------------------------------- --+-- SNS Response Consumer++snsResponseConsumer+ :: HTTPResponseConsumer a+ -> IORef SnsMetadata+ -> HTTPResponseConsumer a+snsResponseConsumer inner metadata resp = do++ let headerString = fmap T.decodeUtf8 . flip lookup (HTTP.responseHeaders resp)+ amzId2 = headerString "x-amz-id-2"+ requestId = headerString "x-amz-request-id"+ m = SnsMetadata { snsMAmzId2 = amzId2, snsMRequestId = requestId }++ liftIO $ tellMetadataRef metadata m++ if HTTP.responseStatus resp >= HTTP.status400+ then snsErrorResponseConsumer resp+ else inner resp++-- | Parse XML Responses+--+snsXmlResponseConsumer+ :: (CU.Cursor -> Response SnsMetadata a)+ -> IORef SnsMetadata+ -> HTTPResponseConsumer a+snsXmlResponseConsumer p metadataRef =+ snsResponseConsumer (xmlCursorConsumer p metadataRef) metadataRef++-- | Parse Error Responses+--+snsErrorResponseConsumer :: HTTPResponseConsumer a+snsErrorResponseConsumer resp = do+ doc <- HTTP.responseBody resp $$+- XML.sinkDoc XML.def+ case parseError (CU.fromDocument doc) of+ Right err -> liftIO $ throwM err+ Left otherErr -> do+ -- doc <- HTTP.responseBody resp $$+- consume+ -- liftIO $ print $ B8.concat $ doc+ liftIO $ throwM otherErr+ where+ parseError root = SnsErrorResponse+ <$> pure (HTTP.responseStatus resp)+ <*> (force "Missing error Code" $ root $// elContent "Code")+ <*> (force "Missing error Message" $ root $// elContent "Message")+ <*> pure (listToMaybe $ root $// elContent "Resource")+ <*> pure (listToMaybe $ root $// elContent "HostId")+ <*> pure (listToMaybe $ root $// elContent "AWSAccessKeyId")+ <*> (pure $ do+ unprocessed <- listToMaybe $ root $// elCont "StringToSignBytes"+ B.pack <$> mapM readHex2 (words unprocessed))++-- -------------------------------------------------------------------------- --+-- SNS Errors++-- |+--+data SnsError a+ = SnsErrorCommon SnsCommonError+ | SnsErrorCommand a+ deriving (Show, Read, Eq, Ord, Typeable)++-- | TODO use type SnsError for snsErrorCode.+--+data SnsErrorResponse+ = SnsErrorResponse+ { snsErrorStatusCode :: !HTTP.Status+ , snsErrorCode :: !T.Text+ , snsErrorMessage :: !T.Text+ , snsErrorResource :: !(Maybe T.Text)+ , snsErrorHostId :: !(Maybe T.Text)+ , snsErrorAccessKeyId :: !(Maybe T.Text)+ , snsErrorStringToSign :: !(Maybe B.ByteString)+ }+ | SnsResponseDecodeError T.Text+ deriving (Show, Eq, Ord, Typeable)++instance Exception SnsErrorResponse++-- | Common SNS Errors+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/APIReference/CommonErrors.html>+--+-- TODO add function to provide info about the error (content of haddock comments)+--+data SnsCommonError++ -- | The request signature does not conform to AWS standards. /Code 400/+ --+ = ErrorIncompleteSignature++ -- | The request processing has failed because of an unknown error,+ -- exception or failure.+ --+ -- /Code 500/+ --+ | ErrorInternalFailure++ -- | The action or operation requested is invalid. Verify that the action+ -- is typed correctly.+ --+ -- /Code 400/+ --+ | ErrorInvalidAction++ -- | The X.509 certificate or AWS access key ID provided does not exist in+ -- our records.+ --+ -- /Code 403/+ --+ | ErrorInvalidClientTokenId++ -- | Parameters that must not be used together were used together.+ --+ -- /Code 400/+ --+ | ErrorInvalidParameterCombination++ -- | An invalid or out-of-range value was supplied for the input parameter.+ --+ -- /Code 400/+ --+ | ErrorInvalidParameterValue++ -- | The AWS query string is malformed or does not adhere to AWS standards.+ --+ -- /Code 400/+ --+ | ErrorInvalidQueryParamter++ -- | The query string contains a syntax error.+ --+ -- /Code 404/+ --+ | ErrorMalformedQueryString++ -- | The request is missing an action or a required parameter.+ --+ -- /Code 400/+ --+ | ErrorMissingAction++ -- | The request must contain either a valid (registered) AWS access key ID+ -- or X.509 certificate.+ --+ -- /Code 403/+ --+ | ErrorMissingAuthenticationToken++ -- | A required parameter for the specified action is not supplied.+ --+ -- /Code 400/+ --+ | ErrorMissingParameter++ -- | The AWS access key ID needs a subscription for the service.+ --+ -- /Code 403/+ --+ | ErrorOptInRequired++ -- | The request reached the service more than 15 minutes after the date+ -- stamp on the request or more than 15 minutes after the request+ -- expiration date (such as for pre-signed URLs), or the date stamp on the+ -- request is more than 15 minutes in the future.+ --+ -- /Code 400/+ --+ | ErrorRequestExpired++ -- | The request has failed due to a temporary failure of the server.+ --+ -- /Code 503/+ --+ | ErrorServiceUnavailable++ -- | The request was denied due to request throttling.+ --+ -- /Code 400/+ --+ | ErrorThrottling++ -- | The input fails to satisfy the constraints specified by an AWS+ -- service.+ --+ -- /Code 400/+ --+ | ErrorValidationError+ deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)++-- -------------------------------------------------------------------------- --+-- SNS Protocols++data SnsProtocol+ = SnsProtocolHttp+ | SnsProtocolHttps+ | SnsProtocolEmail+ | SnsProtocolEmailJson+ | SnsProtocolSms+ | SnsProtocolSqs+ | SnsProtocolApplication+ deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)++snsProtocolToText :: IsString a => SnsProtocol -> a+snsProtocolToText SnsProtocolHttp = "http"+snsProtocolToText SnsProtocolHttps = "https"+snsProtocolToText SnsProtocolEmail = "email"+snsProtocolToText SnsProtocolEmailJson = "email-json"+snsProtocolToText SnsProtocolSms = "sms"+snsProtocolToText SnsProtocolSqs = "sqs"+snsProtocolToText SnsProtocolApplication = "application"++parseSnsProtocol :: P.CharParsing m => m SnsProtocol+parseSnsProtocol =+ SnsProtocolHttp <$ P.text "http"+ <|> SnsProtocolHttps <$ P.text "https"+ <|> SnsProtocolEmail <$ P.text "email"+ <|> SnsProtocolEmailJson <$ P.text "email-json"+ <|> SnsProtocolSms <$ P.text "sms"+ <|> SnsProtocolSqs <$ P.text "sqs"+ <|> SnsProtocolApplication <$ P.text "application"+ <?> "SnsProtocol"++instance AwsType SnsProtocol where+ toText = snsProtocolToText+ parse = parseSnsProtocol++instance Q.Arbitrary SnsProtocol where+ arbitrary = Q.elements [minBound..maxBound]++-- | An SNS endpoint is a client that subscribes to receive notifications+-- through the SNS service.+--+-- This must not be confused with the SNS AWS Service endpoints that are+-- the domain names to which API requests are made (see 'snsServiceEndpoint').+--+-- Endpoints vary by protocol:+--+-- * For the http protocol, the endpoint is an URL beginning with "http://"+-- * For the https protocol, the endpoint is a URL beginning with "https://"+-- * For the email protocol, the endpoint is an email address+-- * For the email-json protocol, the endpoint is an email address+-- * For the sms protocol, the endpoint is a phone number of an SMS-enabled device+-- * For the sqs protocol, the endpoint is the ARN of an Amazon SQS queue+-- * For the application protocol, the endpoint is the EndpointArn of a mobile app and device.+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/APIReference/API_Subscribe.html>+--+type SnsEndpoint = T.Text++-- -------------------------------------------------------------------------- --+-- Common Parameters++-- | Common SNS Parameters+--+-- <http://docs.aws.amazon.com/sns/2010-03-31/APIReference/CommonParameters.html>+--+-- The user of this API hardy needs to deal with the data type directly.+--+-- This API supports only signature version 4 with signature method @AWS4-HMAC-SHA256@.+--+-- /This is not currently used for computing the requests, but serves as+-- documentation and reference for the implementation of yet missing features./+--+data SnsCommonParameters = SnsCommonParameters+ { snsAction :: !SnsAction+ -- ^ The action to be performed.++ , snsParams :: () -- !(Maybe ConditionalRequestAuthParameters)+ -- ^ The parameters that are required to authenticate a Conditional request.++ , snsAWSAccessKeyId :: !B8.ByteString+ -- ^ The access key ID that corresponds to the secret access key that you used to sign the request.++ , snsExpires :: !UTCTime+ -- ^ The date and time when the request signature expires.+ -- Precisely one of snsExpires or snsTimestamp must be present.+ --+ -- format: @YYYY-MM-DDThh:mm:ssZ@ (ISO 8601)++ , snsTimestamp :: !UTCTime+ -- ^ The date and time of the request.+ -- Precisely one of snsExpires or snsTimestamp must be present.+ --+ -- format: @YYYY-MM-DDThh:mm:ssZ@ (ISO 8601)++ , snsSecurityToken :: () -- !(Maybe SecurityToken)+ -- ^ TODO++ , snsSignature :: !Signature+ -- ^ The digital signature that you created for the request. For+ -- information about generating a signature, go to the service's developer+ -- documentation.++ , snsSignatureMethod :: !SignatureMethod+ -- ^ The hash algorithm that you used to create the request signature.++ , snsSignatureVersion :: !SignatureVersion+ -- ^ The signature version you use to sign the request. Set this to the value that is recommended for your service.++ , snsVersion :: SnsVersion+ -- ^ The API version that the request is written for.+ }+
+ src/Aws/Sns/Internal.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: Aws.Sns.Internal+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+module Aws.Sns.Internal+( parseXmlEntryMap+, forceE+, fmapL+, expectValue+) where++import Control.Applicative+import Control.Exception++import Control.Monad+import Data.Monoid+import qualified Data.Text as T++import Text.XML.Cursor ((&/), ($/), (&|))+import qualified Text.XML.Cursor as CU++parseXmlEntryMap :: CU.Cursor -> [(T.Text, T.Text)]+parseXmlEntryMap cur = concat $ cur+ $/ CU.laxElement "entry"+ &| \c -> (,)+ <$> (c $/ CU.laxElement "key" &/ CU.content)+ <*> (c $/ CU.laxElement "value" &/ CU.content)++forceE :: (Exception e) => e -> [a] -> Either e a+forceE e [] = Left e+forceE _ (x:_) = Right x++fmapL :: (a -> b) -> Either a c -> Either b c+fmapL f (Left e) = Left (f e)+fmapL _ (Right a) = Right a++expectValue :: (Monad m, Eq a, Show a) => a -> a -> m ()+expectValue expected got = when (got /= expected) . fail+ $ "unexpected value; got " <> show got <> "; expected " <> show expected+
+ tests/Main.hs view
@@ -0,0 +1,426 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP #-}++-- |+-- Module: Main+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- Tests for Haskell SNS bindings+--++import Aws+import Aws.Core+import Aws.General+import Aws.Sns+import qualified Aws.Sqs as SQS++import Control.Arrow (second)+import Control.Concurrent (threadDelay)+import Control.Error+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class++import Data.Aeson (encode, object, (.=), eitherDecode)+import qualified Data.ByteString.Lazy as LB+import qualified Data.List as L+import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++import Test.Tasty++import System.Environment+import System.Exit+import System.IO++import Utils++-- -------------------------------------------------------------------------- --+-- Main++main :: IO ()+main = do+ args <- getArgs+ runMain args $ map (second tail . span (/= '=')) args+ where+ runMain :: [String] -> [(String,String)] -> IO ()+ runMain args argsMap+ | any (`elem` helpArgs) args = defaultMain (tests "")+ | "--run-with-aws-credentials" `elem` args =+ case lookup "--test-email" argsMap of+ Nothing -> do+ hPutStrLn stderr "Command line option --test-email=<email> is missing"+ hPutStrLn stderr help+ exitFailure+ Just email ->+ withArgs (tastyArgs args) . defaultMain $ tests (T.pack email)+ | otherwise = putStrLn help >> exitFailure++ helpArgs = ["--help", "-h"]+ mainArgs =+ [ "--run-with-aws-credentials"+ , "--test-email"+ ]+ tastyArgs args = flip filter args $ \x -> not+ $ any (`L.isPrefixOf` x) mainArgs+++help :: String+help = L.intercalate "\n"+ [ ""+ , "NOTE"+ , ""+ , "This test suite accesses the AWS account that is associated with"+ , "the default credentials from the credential file ~/.aws-keys."+ , ""+ , "By running the tests in this test-suite costs for usage of AWS"+ , "services may incur."+ , ""+ , "In order to actually excute the tests in this test-suite you must"+ , "provide the command line options:"+ , ""+ , " --test-email=<email-address>"+ , " --run-with-aws-credentials"+ , ""+ , "When running this test-suite through cabal you may use the following"+ , "command:"+ , ""+ , " cabal test SNS-tests --test-option=--run-with-aws-credentials \\"+ , " --test-option=--test-email=<email-address>"+ , ""+ ]++tests+ :: T.Text -- email address+ -> TestTree+tests email = testGroup "SNS Tests"+ [ test_createTopic+ , test_topic1 email+ , test_topicSqs+ ]++-- -------------------------------------------------------------------------- --+-- Static Test parameters+--+-- TODO make these configurable++testProtocol :: Protocol+testProtocol = HTTP++-- | SQS endpoint+testSqsEndpoint :: SQS.Endpoint+testSqsEndpoint = SQS.sqsEndpointUsWest2++defaultTopicName :: T.Text+defaultTopicName = "test-topic"++defaultQueueName :: T.Text+defaultQueueName = "test-queue"++-- -------------------------------------------------------------------------- --+-- SNS Utils++snsConfiguration :: SnsConfiguration qt+snsConfiguration = SnsConfiguration testProtocol testRegion++simpleSns+ :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SnsConfiguration, MonadIO m)+ => r+ -> m (MemoryResponse a)+simpleSns command = do+ c <- baseConfiguration+ simpleAws c snsConfiguration command++simpleSnsT+ :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SnsConfiguration, MonadIO m)+ => r+ -> EitherT T.Text m (MemoryResponse a)+simpleSnsT = tryT . simpleSns++-- |+--+withTopic+ :: T.Text -- ^ Topic name+ -> (Arn -> IO a) -- ^ test function+ -> IO a+withTopic topicName = bracket createTopic deleteTopic+ where+ createTopic = do+ CreateTopicResponse arn <- simpleSns $ CreateTopic topicName+ return arn+ deleteTopic arn = simpleSns (DeleteTopic arn) >> return ()++withTopicTest+ :: T.Text -- ^ Topic name+ -> (IO Arn -> TestTree) -- ^ test tree+ -> TestTree+withTopicTest topic = withResource createTopic deleteTopic+ where+ createTopic = do+ CreateTopicResponse arn <- simpleSns $ CreateTopic tTopic+ return arn+ deleteTopic arn = void . simpleSns $ DeleteTopic arn+ tTopic = testData topic++-- -------------------------------------------------------------------------- --+-- SQS Utils++sqsArn+ :: Region+ -> AccountId+ -> T.Text -- ^ Queue Name+ -> Arn+sqsArn region accountId queueName = Arn+ { arnService = ServiceNamespaceSqs+ , arnRegion = Just region+ , arnAccount = Just accountId+ , arnResource = [queueName]+ }++testSqsArn :: T.Text -> Arn+testSqsArn url = Arn+ { arnService = ServiceNamespaceSqs+ , arnRegion = Just testRegion+ , arnAccount = Just $ AccountId (sqsAccountIdText url)+ , arnResource = [sqsQueueNameText url]+ }++sqsQueueName :: T.Text -> SQS.QueueName+sqsQueueName url = SQS.QueueName (sqsQueueNameText url) (sqsAccountIdText url)++sqsQueueNameText :: T.Text -> T.Text+sqsQueueNameText url = T.split (== '/') url !! 4++sqsAccountIdText :: T.Text -> T.Text+sqsAccountIdText url = T.split (== '/') url !! 3++sqsConfiguration :: SQS.SqsConfiguration qt+sqsConfiguration = SQS.SqsConfiguration+ { SQS.sqsProtocol = testProtocol+ , SQS.sqsEndpoint = testSqsEndpoint+ , SQS.sqsPort = 80+ , SQS.sqsUseUri = False+ , SQS.sqsDefaultExpiry = 180+ }++simpleSqs+ :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration, MonadIO m)+ => r+ -> m (MemoryResponse a)+simpleSqs command = do+ c <- baseConfiguration+ simpleAws c sqsConfiguration command++simpleSqsT+ :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration, MonadIO m)+ => r+ -> EitherT T.Text m (MemoryResponse a)+simpleSqsT = tryT . simpleSqs++-- |+--+-- Throws an exception if the URL returned by 'CreateQueue' doesn't+-- include the HTTP protocol or the account ID as first path component.+--+withSqsQueue+ :: T.Text+ -- ^ queue name+ -> (T.Text -> SQS.QueueName -> Arn -> IO a)+ -- ^ the first argument is the queue URL,+ -- the second is the 'SQS.QueueName', and+ -- the third the queue 'Arn'.+ -> IO a+withSqsQueue queueName f = bracket createQueue deleteQueue $ \url ->+ f url (sqsQueueName url) (testSqsArn url)+ where+ createQueue = do+ SQS.CreateQueueResponse url <- simpleSqs $ SQS.CreateQueue Nothing queueName+ return url+ deleteQueue url = void $ simpleSqs (SQS.DeleteQueue (sqsQueueName url))++withQueueTest+ :: T.Text -- ^ Queue name+ -> (IO (T.Text, SQS.QueueName, Arn) -> TestTree) -- ^ test tree+ -> TestTree+withQueueTest queueName f = withResource createQueue deleteQueue $ \getQueueUrl -> do+ let getQueueParams = do+ url <- getQueueUrl+ return (url, sqsQueueName url, testSqsArn url)+ f getQueueParams+ where+ createQueue = do+ SQS.CreateQueueResponse url <- simpleSqs $ SQS.CreateQueue Nothing queueName+ return url+ deleteQueue url = void $ simpleSqs (SQS.DeleteQueue (sqsQueueName url))++-- | Set queue policy attribute that allows an SNS Topic+-- to send notification to an SQS queue.+--+sqsAllowTopicAttribute+ :: Arn -- ^ Queue ARN+ -> T.Text -- ^ policy ID+ -> Arn -- ^ topic ARN+ -> SQS.SetQueueAttributes+sqsAllowTopicAttribute queueArn policyId topicArn = SQS.SetQueueAttributes+ { SQS.sqaAttribute = SQS.Policy+ , SQS.sqaValue = T.decodeUtf8 . LB.toStrict . encode $ object+ [ "Version" .= ("2012-10-17" :: T.Text)+ , "Statement" .= [object+ [ "Resource" .= queueArn+ , "Sid" .= policyId+ , "Effect" .= ("Allow" :: T.Text)+ , "Principal" .= object [ "AWS" .= ("*" :: T.Text) ]+ , "Action" .= ("sqs:SendMessage" :: T.Text)+ , "Condition" .= object+ [ "ArnEquals" .= object [ "aws:SourceArn" .= topicArn ]+ ]+ ]]+ ]+ , SQS.sqaQueueName = queueId+ }+ where+ queueId = SQS.QueueName+ { SQS.qAccountNumber = case arnAccount queueArn of+ Nothing -> error $ "Malformed SQS queue ARN: " <> toText queueArn+ Just (AccountId t) -> t+ , SQS.qName = if length (arnResource queueArn) /= 1+ then error $ "Malformed SQS queue ARN: " <> toText queueArn+ else head $ arnResource queueArn+ }++-- -------------------------------------------------------------------------- --+-- Topic Creation Tests++test_createTopic :: TestTree+test_createTopic = testGroup "Topic creation"+ [ eitherTOnceTest1 "create list delete topic" prop_topicCreateListDelete+ ]++-- |+--+-- TODO:+--+-- * use 'awsIteratedList' for parsing the topics list+--+prop_topicCreateListDelete+ :: T.Text -- ^ topic name+ -> EitherT T.Text IO ()+prop_topicCreateListDelete topicName = do+ CreateTopicResponse topicArn <- simpleSnsT $ CreateTopic tTopicName+ handleT (\e -> deleteTopic topicArn >> left e) $ do+ ListTopicsResponse _ allTopics <- simpleSnsT (ListTopics Nothing)+ unless (topicArn `elem` allTopics)+ . left $ "topic " <> toText topicArn <> " not listed"+ deleteTopic topicArn+ where+ tTopicName = testData topicName+ deleteTopic arn = void $ simpleSnsT (DeleteTopic arn)++-- -------------------------------------------------------------------------- --+-- Topic Tests++test_topic1+ :: T.Text -- ^ email address+ -> TestTree+test_topic1 email = withTopicTest defaultTopicName $ \getTopicArn ->+ testGroup "Perform a series of tests on a single topic"+ [ eitherTOnceTest0 "email subscribe"+ $ liftIO getTopicArn >>= \t -> prop_emailSubscribe t email+ ]++-- | Subscribe an email endpoint (don't wait for confirmation).+--+prop_emailSubscribe+ :: Arn -- ^ topic arn+ -> SnsEndpoint -- ^ email addresss+ -> EitherT T.Text IO ()+prop_emailSubscribe topicArn email = do+ SubscribeResponse maybeSubArn <- simpleSnsT $ Subscribe (Just email) SnsProtocolEmail topicArn+ case maybeSubArn of+ Nothing -> return ()+ Just subArn -> do+ let e = "unexpected subscription arn when 'confirmation pending' is expected"+ void . handleT (\e2 -> left (e <> " and " <> e2))+ . simpleSnsT $ Unsubscribe subArn+ left e++-- -------------------------------------------------------------------------- --+-- SQS Integration Tests++test_topicSqs :: TestTree+test_topicSqs = withTopicTest defaultTopicName $ \getTopicArn ->+ withQueueTest defaultQueueName $ \getQueueParams -> testGroup "SQS Integration Tests"+ [ eitherTOnceTest0 "SQS subscribe publish unsubscribe" $ do+ topicArn <- liftIO getTopicArn+ (_, queueId, queueArn) <- liftIO getQueueParams+ prop_sqsSubscribePublishUnsubscribe topicArn queueId queueArn+ ]++-- | Subscribe an SQS queue to an SNS topic+--+prop_sqsSubscribePublishUnsubscribe+ :: Arn -- ^ topic arn+ -> SQS.QueueName -- ^ queue id+ -> Arn -- queue Arn+ -> EitherT T.Text IO ()+prop_sqsSubscribePublishUnsubscribe topicArn queueId queueArn = do++ -- Add permission to send messages from SNS topic (identified by ARN) to queue+ void . simpleSqsT $ sqsAllowTopicAttribute queueArn sqsPermissionId topicArn++ -- subscribe Queue to SNS topci+ SubscribeResponse maybeSubArn <- simpleSnsT $ Subscribe (Just $ toText queueArn) SnsProtocolSqs topicArn+ subArn <- maybeSubArn ?? "Subscription failed: subscription Arn is missing probably because the confirmation is yet pending"++ -- Let's wait 5 seconds, just be on the safe side ...+ liftIO $ threadDelay (5*1000000)++ -- publish to topic+ PublishResponse msgId0 <- simpleSnsT $ Publish msg Nothing (Just subj) (Left topicArn)++ -- receive messages+#if MIN_VERSION_aws(100,0,0)+ let numRetry = 3+#else+ let numRetry = 6+#endif+ sqsMsg <- retryT numRetry $ do+ SQS.ReceiveMessageResponse msgs <- simpleSqsT $ SQS.ReceiveMessage+ { SQS.rmVisibilityTimeout = Nothing+ , SQS.rmAttributes = []+ , SQS.rmMaxNumberOfMessages = Just 1+ , SQS.rmQueueName = queueId+#if MIN_VERSION_aws(100,0,0)+ , SQS.rmWaitTimeSeconds = Just 20+#endif+ }+ when (length msgs < 1) $ left+ $ "unexpected number of messages in queue; expected 1, got " <> sshow (length msgs)+ return $ head msgs++ -- parse notification+ notification :: SqsNotification <- fmapLT T.pack . hoistEither+ . eitherDecode . LB.fromStrict . T.encodeUtf8 $ SQS.mBody sqsMsg++ -- check result+ when (sqsNotificationMessageId notification /= msgId0) $ left+ $ "message IDs don't match; epxected " <> q (messageIdText msgId0)+ <> ", got " <> q (messageIdText $ sqsNotificationMessageId notification)+ when (sqsNotificationMessage notification /= snsMessageDefault msg) $ left+ $ "messages don't match; expected " <> q (snsMessageDefault msg)+ <> ", got " <> q (sqsNotificationMessage notification)++ -- unsubscribe queue+ void $ simpleSnsT $ Unsubscribe subArn+ where+ q t = "\"" <> t <> "\""+ sqsPermissionId = testData . head . arnResource $ topicArn+ msg = snsMessage "message abc"+ subj = "subject abc"+
+ tests/Utils.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP #-}++-- |+-- Module: Utils+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- Utils for Tests for Haskell AWS bindints+--+module Utils+(+-- * Parameters+ testRegion+, testDataPrefix++-- * General Utils+, sshow+, tryT+, retryT+, testData++, evalTestT+, evalTestTM+, eitherTOnceTest0+, eitherTOnceTest1+, eitherTOnceTest2++-- * Generic Tests+, test_jsonRoundtrip+, prop_jsonRoundtrip+) where++import Aws.General++import Control.Concurrent (threadDelay)+import Control.Error+import Control.Monad+import Control.Monad.Identity+import Control.Monad.IO.Class++import Data.Aeson (FromJSON, ToJSON, encode, eitherDecode)+import Data.Monoid+import Data.Proxy+import Data.String+import qualified Data.Text as T+import Data.Typeable++import Test.QuickCheck.Property+import Test.QuickCheck.Monadic+import Test.Tasty+import Test.Tasty.QuickCheck++import System.IO++-- -------------------------------------------------------------------------- --+-- Static Test parameters+--+-- TODO make these configurable++testRegion :: Region+testRegion = UsWest2++-- | This prefix is used for the IDs and names of all entities that are+-- created in the AWS account.+--+testDataPrefix :: IsString a => a+testDataPrefix = "__TEST_AWSHASKELLBINDINGS__"++-- -------------------------------------------------------------------------- --+-- General Utils++tryT :: MonadIO m => IO a -> EitherT T.Text m a+tryT = fmapLT (T.pack . show) . syncIO++testData :: (IsString a, Monoid a) => a -> a+testData a = testDataPrefix <> a++retryT :: MonadIO m => Int -> EitherT T.Text m a -> EitherT T.Text m a+retryT i f = go 1+ where+ go x+ | x >= i = fmapLT (\e -> "error after " <> sshow x <> " retries: " <> e) f+ | otherwise = f `catchT` \_ -> do+ liftIO $ threadDelay (1000000 * min 60 (2^(x-1)))+ go (succ x)++sshow :: (Show a, IsString b) => a -> b+sshow = fromString . show++evalTestTM+ :: Functor f+ => String -- ^ test name+ -> f (EitherT T.Text IO a) -- ^ test+ -> f (IO Bool)+evalTestTM name = fmap $+ runEitherT >=> \r -> case r of+ Left e -> do+ hPutStrLn stderr $ "failed to run stream test \"" <> name <> "\": " <> show e+ return False+ Right _ -> return True++evalTestT+ :: String -- ^ test name+ -> EitherT T.Text IO a -- ^ test+ -> IO Bool+evalTestT name = runIdentity . evalTestTM name . Identity++eitherTOnceTest0+ :: String -- ^ test name+ -> EitherT T.Text IO a -- ^ test+ -> TestTree+eitherTOnceTest0 name = testProperty name . once . ioProperty . evalTestT name++eitherTOnceTest1+ :: (Arbitrary a, Show a)+ => String -- ^ test name+ -> (a -> EitherT T.Text IO b)+ -> TestTree+eitherTOnceTest1 name test = testProperty name . once $ monadicIO . liftIO+ . evalTestTM name test++eitherTOnceTest2+ :: (Arbitrary a, Show a, Arbitrary b, Show b)+ => String -- ^ test name+ -> (a -> b -> EitherT T.Text IO c)+ -> TestTree+eitherTOnceTest2 name test = testProperty name . once $ \a b -> monadicIO . liftIO+ $ (evalTestTM name $ uncurry test) (a, b)++-- -------------------------------------------------------------------------- --+-- Generic Tests++test_jsonRoundtrip+ :: forall a . (Eq a, Show a, FromJSON a, ToJSON a, Typeable a, Arbitrary a)+ => Proxy a+ -> TestTree+test_jsonRoundtrip proxy = testProperty msg (prop_jsonRoundtrip :: a -> Property)+ where+ msg = "JSON roundtrip for " <> show typ+#if MIN_VERSION_base(4,7,0)+ typ = typeRep proxy+#else+ typ = typeOf (undefined :: a)+#endif++prop_jsonRoundtrip :: forall a . (Eq a, Show a, FromJSON a, ToJSON a) => a -> Property+prop_jsonRoundtrip a = either (const $ property False) (\(b :: [a]) -> [a] === b) $+ eitherDecode $ encode [a]+