diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +0.1 +=== + +First public version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 AlephCloud Systems, Inc. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,73 @@ +[![Build Status](https://travis-ci.org/alephcloud/hs-aws-sns.svg?branch=master)](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= +~~~ + +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). + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/aws-sns.cabal b/aws-sns.cabal new file mode 100644 --- /dev/null +++ b/aws-sns.cabal @@ -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/ + . + + +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 +Maintainer: Lars Kuhtz +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 + + + + + diff --git a/constraints b/constraints new file mode 100644 --- /dev/null +++ b/constraints @@ -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 diff --git a/src/Aws/Sns.hs b/src/Aws/Sns.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Sns.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: Aws.Sns +-- Copyright: Copyright © 2014 AlephCloud Systems, Inc. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- /API Version: 2013-03-31/ +-- +-- +-- +-- The types and functions of this package are supposed to be +-- use with the machinery from the +-- . +-- +-- 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 + diff --git a/src/Aws/Sns/Commands/ConfirmSubscription.hs b/src/Aws/Sns/Commands/ConfirmSubscription.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Sns/Commands/ConfirmSubscription.hs @@ -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 +-- 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". +-- +-- +-- +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) + + diff --git a/src/Aws/Sns/Commands/CreateTopic.hs b/src/Aws/Sns/Commands/CreateTopic.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Sns/Commands/CreateTopic.hs @@ -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 +-- 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 . 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. +-- +-- +-- +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) + diff --git a/src/Aws/Sns/Commands/DeleteTopic.hs b/src/Aws/Sns/Commands/DeleteTopic.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Sns/Commands/DeleteTopic.hs @@ -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 +-- 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. +-- +-- +-- +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) + diff --git a/src/Aws/Sns/Commands/GetSubscriptionAttributes.hs b/src/Aws/Sns/Commands/GetSubscriptionAttributes.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Sns/Commands/GetSubscriptionAttributes.hs @@ -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 +-- Stability: experimental +-- +-- /API Version: 2013-03-31/ +-- +-- Returns all of the properties of a subscription. +-- +-- +-- +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 +-- +-- +-- +-- 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) + diff --git a/src/Aws/Sns/Commands/ListSubscriptionsByTopic.hs b/src/Aws/Sns/Commands/ListSubscriptionsByTopic.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Sns/Commands/ListSubscriptionsByTopic.hs @@ -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 +-- 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. +-- +-- +-- +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. +-- +-- +-- +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) + + + diff --git a/src/Aws/Sns/Commands/ListTopics.hs b/src/Aws/Sns/Commands/ListTopics.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Sns/Commands/ListTopics.hs @@ -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 +-- 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. +-- +-- +-- +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) + + diff --git a/src/Aws/Sns/Commands/Publish.hs b/src/Aws/Sns/Commands/Publish.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Sns/Commands/Publish.hs @@ -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 +-- 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. +-- +-- +-- +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 +-- +-- +-- +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) + + diff --git a/src/Aws/Sns/Commands/Subscribe.hs b/src/Aws/Sns/Commands/Subscribe.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Sns/Commands/Subscribe.hs @@ -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 +-- 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. +-- +-- +-- +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) + + diff --git a/src/Aws/Sns/Commands/Unsubscribe.hs b/src/Aws/Sns/Commands/Unsubscribe.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Sns/Commands/Unsubscribe.hs @@ -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 +-- 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. +-- +-- +-- +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) + diff --git a/src/Aws/Sns/Core.hs b/src/Aws/Sns/Core.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Sns/Core.hs @@ -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 +-- Stability: experimental +-- +-- /API Version: 2013-03-31/ +-- +-- +-- +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 +-- +-- +-- +-- 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 "" rid + <> ", x-amz-id-2=" <> fromMaybe "" 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 +-- +-- +-- +-- 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. +-- +-- +-- +type SnsEndpoint = T.Text + +-- -------------------------------------------------------------------------- -- +-- Common Parameters + +-- | Common SNS Parameters +-- +-- +-- +-- 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. + } + diff --git a/src/Aws/Sns/Internal.hs b/src/Aws/Sns/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Sns/Internal.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: Aws.Sns.Internal +-- Copyright: Copyright © 2014 AlephCloud Systems, Inc. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 +-- 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= 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=" + , " --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=" + , "" + ] + +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" + diff --git a/tests/Utils.hs b/tests/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Utils.hs @@ -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 +-- 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] +