{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE GADTs #-}

{-# LANGUAGE CPP #-}

-- |

module Main

( main

) where

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 :: IO ()

main = do

args <- getArgs

runMain args $ map (second tail . span (/= '=')) args

where

runMain :: [String] -> [(String,String)] -> IO ()

runMain args argsMap

| any (`elem` helpArgs) args = defaultMain (tests "")

| "--run-with-aws-credentials" `elem` args =

case lookup "--test-email" argsMap of

Nothing -> do

hPutStrLn stderr "Command line option --test-email=<email> is missing"

hPutStrLn stderr help

exitFailure

Just email ->

withArgs (tastyArgs args) . defaultMain $ tests (T.pack email)

| otherwise = putStrLn help >> exitFailure

helpArgs = ["--help", "-h"]

mainArgs =

[ "--run-with-aws-credentials"

, "--test-email"

]

tastyArgs args = flip filter args $ \x -> not

$ any (`L.isPrefixOf` x) mainArgs

help :: String

help = L.intercalate "\n"

[ ""

, "NOTE"

, ""

, "This test suite accesses the AWS account that is associated with"

, "the default credentials from the credential file ~/.aws-keys."

, ""

, "By running the tests in this test-suite costs for usage of AWS"

, "services may incur."

, ""

, "In order to actually excute the tests in this test-suite you must"

, "provide the command line options:"

, ""

, " --test-email=<email-address>"

, " --run-with-aws-credentials"

, ""

, "When running this test-suite through cabal you may use the following"

, "command:"

, ""

, " cabal test SNS-tests --test-option=--run-with-aws-credentials \\"

, " --test-option=--test-email=<email-address>"

, ""

]

tests

:: T.Text -- email address

-> TestTree

tests email = testGroup "SNS Tests"

[ test_createTopic

, test_topic1 email

, test_topicSqs

]

testProtocol :: Protocol

testProtocol = HTTP

-- | SQS endpoint

testSqsEndpoint :: SQS.Endpoint

testSqsEndpoint = SQS.sqsEndpointUsWest2

defaultTopicName :: T.Text

defaultTopicName = "test-topic"

defaultQueueName :: T.Text

defaultQueueName = "test-queue"

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

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

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 ->

f $ do

url <- getQueueUrl

return (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))

-- | Set queue policy attribute that allows an SNS Topic

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

}

test_createTopic :: TestTree

test_createTopic = testGroup "Topic creation"

[ eitherTOnceTest1 "create list delete topic" prop_topicCreateListDelete

]

-- |

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)

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

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(0,10,0)

let numRetry = 3

let numRetry = 6

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(0,10,0)

, SQS.rmUserMessageAttributes = []

, SQS.rmWaitTimeSeconds = Just 20

}

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"