From e96347003d254354e51389c249c3cda81b4ba506 Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Tue, 26 Aug 2014 16:02:07 -0700 Subject: [PATCH 1/6] tests/Utils.hs: add function 'mustFail' --- tests/Utils.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/tests/Utils.hs b/tests/Utils.hs index 788d5ede..72636881 100644 --- a/tests/Utils.hs +++ b/tests/Utils.hs @@ -21,6 +21,7 @@ module Utils -- * General Utils , sshow +, mustFail , tryT , retryT , retryT_ @@ -128,6 +129,11 @@ retryT_ n f = go 1 sshow :: (Show a, IsString b) => a -> b sshow = fromString . show +mustFail :: Monad m => EitherT e m a -> EitherT T.Text m () +mustFail = EitherT . eitherT + (const . return $ Right ()) + (const . return $ Left "operation succeeded when a failure was expected") + evalTestTM :: Functor f => String -- ^ test name From 11b65eb743b5ffb1f96e655f77cb117c31b30e6e Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Tue, 26 Aug 2014 16:23:36 -0700 Subject: [PATCH 2/6] tests/Sqs/Main.hs: add function SqsT to run requests with a given manager and base configuration --- aws.cabal | 2 ++ tests/Sqs/Main.hs | 13 +++++++++++++ 2 files changed, 15 insertions(+) diff --git a/aws.cabal b/aws.cabal index 0e36b22c..3bda4e44 100644 --- a/aws.cabal +++ b/aws.cabal @@ -269,10 +269,12 @@ test-suite sqs-tests base == 4.*, bytestring >= 0.10, errors >= 1.4.7, + http-client >= 0.3, lifted-base >= 0.2, monad-control >= 0.3, mtl >= 2.1, quickcheck-instances >= 0.3, + resourcet >= 1.1, tagged >= 0.7, tasty >= 0.8, tasty-quickcheck >= 0.8, diff --git a/tests/Sqs/Main.hs b/tests/Sqs/Main.hs index 04848639..f21cfcae 100644 --- a/tests/Sqs/Main.hs +++ b/tests/Sqs/Main.hs @@ -31,11 +31,14 @@ import Control.Error import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Control +import Control.Monad.Trans.Resource import qualified Data.List as L import Data.Monoid import qualified Data.Text as T +import qualified Network.HTTP.Client as HTTP + import Test.Tasty import Test.QuickCheck.Instances () @@ -131,6 +134,16 @@ sqsConfiguration = SQS.SqsConfiguration , SQS.sqsDefaultExpiry = 180 } +sqsT + :: (Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration) + => Configuration + -> HTTP.Manager + -> r + -> EitherT T.Text IO a +sqsT cfg manager req = do + Response _ r <- liftIO . runResourceT $ aws cfg sqsConfiguration manager req + hoistEither $ fmapL sshow r + simpleSqs :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration, MonadIO m) => r From f6f7b726ca4d1fcfa5124925e0db48f4b726e27f Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Tue, 26 Aug 2014 16:25:29 -0700 Subject: [PATCH 3/6] tests/DynamoDb/Utils.hs: add function dyT to run requests with a given manager and base configuration --- tests/DynamoDb/Utils.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/tests/DynamoDb/Utils.hs b/tests/DynamoDb/Utils.hs index 7293a2fc..0c786bf0 100644 --- a/tests/DynamoDb/Utils.hs +++ b/tests/DynamoDb/Utils.hs @@ -31,6 +31,7 @@ module DynamoDb.Utils -- * DynamoDb Utils , simpleDy , simpleDyT +, dyT , withTable , withTable_ , createTestTable @@ -45,11 +46,14 @@ import Control.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Control +import Control.Monad.Trans.Resource import Data.Monoid import qualified Data.Text as T import qualified Data.Text.IO as T +import qualified Network.HTTP.Client as HTTP + import Test.Tasty import Test.QuickCheck.Instances () @@ -95,6 +99,16 @@ simpleDyT -> EitherT T.Text m (MemoryResponse a) simpleDyT = tryT . simpleDy +dyT + :: (Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration) + => Configuration + -> HTTP.Manager + -> r + -> EitherT T.Text IO a +dyT cfg manager req = do + Response _ r <- liftIO . runResourceT $ aws cfg dyConfiguration manager req + hoistEither $ fmapL sshow r + withTable :: T.Text -- ^ table Name -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB) From db0b3dea911e9802791adbdd85c2d562c7250226 Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Tue, 26 Aug 2014 16:26:31 -0700 Subject: [PATCH 4/6] tests/DynamoDb: add test case for reuse of TCP connections --- tests/DynamoDb/Main.hs | 41 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) diff --git a/tests/DynamoDb/Main.hs b/tests/DynamoDb/Main.hs index 0111960c..030ef9cc 100644 --- a/tests/DynamoDb/Main.hs +++ b/tests/DynamoDb/Main.hs @@ -22,15 +22,20 @@ module Main ( main ) where +import Aws import qualified Aws.DynamoDb as DY import Control.Arrow (second) import Control.Error import Control.Monad +import Control.Monad.IO.Class +import Data.IORef import qualified Data.List as L import qualified Data.Text as T +import qualified Network.HTTP.Client as HTTP + import Test.Tasty import Test.QuickCheck.Instances () @@ -90,6 +95,7 @@ tests :: TestTree tests = testGroup "DynamoDb Tests" [ test_table -- , test_message + , test_core ] -- -------------------------------------------------------------------------- -- @@ -114,3 +120,38 @@ prop_createDescribeDeleteTable readCapacity writeCapacity tableName = do handleT (\e -> deleteTable >> left e) $ do retryT 6 . void . simpleDyT $ DY.DescribeTable tTableName deleteTable + +-- -------------------------------------------------------------------------- -- +-- Test core functionality + +test_core :: TestTree +test_core = testGroup "Core Tests" + [ eitherTOnceTest0 "connectionReuse" prop_connectionReuse + ] + +prop_connectionReuse + :: EitherT T.Text IO () +prop_connectionReuse = do + c <- liftIO $ do + cfg <- baseConfiguration + + -- counts the number of TCP connections + ref <- newIORef (0 :: Int) + + void . HTTP.withManager (managerSettings ref) $ \manager -> runEitherT $ + handleT (error . T.unpack) . replicateM_ 3 $ do + void $ dyT cfg manager DY.ListTables + mustFail . dyT cfg manager $ DY.DescribeTable "____" + + readIORef ref + unless (c == 1) $ + left "The TCP connection has not been reused" + where + managerSettings ref = HTTP.defaultManagerSettings + { HTTP.managerRawConnection = do + mkConn <- HTTP.managerRawConnection HTTP.defaultManagerSettings + return $ \a b c -> do + atomicModifyIORef ref $ \i -> (succ i, ()) + mkConn a b c + } + From 877ae655a4235b061d29a0df45f5d9d6d9b02a30 Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Tue, 26 Aug 2014 16:26:57 -0700 Subject: [PATCH 5/6] tests/Sqs: add test case for reuse of TCP connections --- tests/Sqs/Main.hs | 78 ++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 63 insertions(+), 15 deletions(-) diff --git a/tests/Sqs/Main.hs b/tests/Sqs/Main.hs index f21cfcae..eace26d6 100644 --- a/tests/Sqs/Main.hs +++ b/tests/Sqs/Main.hs @@ -33,6 +33,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Control import Control.Monad.Trans.Resource +import Data.IORef import qualified Data.List as L import Data.Monoid import qualified Data.Text as T @@ -94,9 +95,10 @@ help = L.intercalate "\n" ] tests :: TestTree -tests = testGroup "SQS Tests" +tests = withQueueTest defaultQueueName $ \getQueueParams -> testGroup "SQS Tests" [ test_queue - , test_message + , test_message getQueueParams + , test_core getQueueParams ] -- -------------------------------------------------------------------------- -- @@ -201,19 +203,18 @@ prop_createListDeleteQueue queueName = do -- -------------------------------------------------------------------------- -- -- Message Tests -test_message :: TestTree -test_message = - withQueueTest defaultQueueName $ \getQueueParams -> testGroup "Queue Tests" - [ eitherTOnceTest0 "SendReceiveDeleteMessage" $ do - (_, queue) <- liftIO getQueueParams - prop_sendReceiveDeleteMessage queue - , eitherTOnceTest0 "SendReceiveDeleteMessageLongPolling" $ do - (_, queue) <- liftIO getQueueParams - prop_sendReceiveDeleteMessageLongPolling queue - , eitherTOnceTest0 "SendReceiveDeleteMessageLongPolling1" $ do - (_, queue) <- liftIO getQueueParams - prop_sendReceiveDeleteMessageLongPolling1 queue - ] +test_message :: IO (T.Text, SQS.QueueName) -> TestTree +test_message getQueueParams = testGroup "Queue Tests" + [ eitherTOnceTest0 "SendReceiveDeleteMessage" $ do + (_, queue) <- liftIO getQueueParams + prop_sendReceiveDeleteMessage queue + , eitherTOnceTest0 "SendReceiveDeleteMessageLongPolling" $ do + (_, queue) <- liftIO getQueueParams + prop_sendReceiveDeleteMessageLongPolling queue + , eitherTOnceTest0 "SendReceiveDeleteMessageLongPolling1" $ do + (_, queue) <- liftIO getQueueParams + prop_sendReceiveDeleteMessageLongPolling1 queue + ] -- | Simple send and short-polling receive. First sends all messages -- and receives messages thereafter one by one. @@ -329,3 +330,50 @@ prop_sendReceiveDeleteMessageLongPolling1 queue = do unless (sent == recv) $ left $ "received messages don't match send messages; sent: " <> sshow sent <> "; got: " <> sshow recv + + +-- -------------------------------------------------------------------------- -- +-- Test core functionality + +test_core :: IO (T.Text, SQS.QueueName) -> TestTree +test_core getQueueParams = testGroup "Core Tests" + [ eitherTOnceTest0 "connectionReuse" $ do + (_, queue) <- liftIO getQueueParams + prop_connectionReuse queue + ] + +prop_connectionReuse + :: SQS.QueueName + -> EitherT T.Text IO () +prop_connectionReuse queue = do + c <- liftIO $ do + cfg <- baseConfiguration + + -- used for counting the number of TCP connections + ref <- newIORef (0 :: Int) + + -- Use a single manager for all HTTP requests + void . HTTP.withManager (managerSettings ref) $ \manager -> runEitherT $ + + handleT (error . T.unpack) . replicateM_ 3 $ do + void . sqsT cfg manager $ SQS.ListQueues Nothing + mustFail . sqsT cfg manager $ + SQS.SendMessage "" (SQS.QueueName "" "") [] Nothing + void . sqsT cfg manager $ + SQS.SendMessage "test-message" queue [] Nothing + void . sqsT cfg manager $ + SQS.ReceiveMessage Nothing [] Nothing [] queue (Just 20) + + readIORef ref + unless (c == 1) $ + left "The TCP connection has not been reused" + where + + managerSettings ref = HTTP.defaultManagerSettings + { HTTP.managerRawConnection = do + mkConn <- HTTP.managerRawConnection HTTP.defaultManagerSettings + return $ \a b c -> do + atomicModifyIORef ref $ \i -> (succ i, ()) + mkConn a b c + } + From c5fb3191f002c4f2ef81993f2e58fa1b5201a10a Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Mon, 25 Aug 2014 20:25:05 -0700 Subject: [PATCH 6/6] DynamoDb: trigger reuse of TCP connection by forcing endOfInput in ResponseConsumer --- Aws/DynamoDb/Core.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Aws/DynamoDb/Core.hs b/Aws/DynamoDb/Core.hs index b20dada2..2492758d 100644 --- a/Aws/DynamoDb/Core.hs +++ b/Aws/DynamoDb/Core.hs @@ -114,6 +114,7 @@ import Data.Aeson import qualified Data.Aeson as A import Data.Aeson.Types (Pair, parseEither) import qualified Data.Aeson.Types as A +import qualified Data.Attoparsec.ByteString as AttoB (endOfInput) import qualified Data.Attoparsec.Text as Atto import Data.Byteable import qualified Data.ByteString.Base16 as Base16 @@ -826,7 +827,7 @@ instance FromJSON AmazonError where ------------------------------------------------------------------------------- ddbResponseConsumer :: A.FromJSON a => IORef DdbResponse -> HTTPResponseConsumer a ddbResponseConsumer ref resp = do - val <- HTTP.responseBody resp $$+- sinkParser A.json' + val <- HTTP.responseBody resp $$+- sinkParser (A.json' <* AttoB.endOfInput) case statusCode of 200 -> rSuccess val _ -> rError val