aws-performance-tests (empty) → 0.1
raw patch · 9 files changed
+1161/−0 lines, 9 filesdep +Chartdep +Chart-cairodep +aesonbuild-type:Customsetup-changed
Dependencies added: Chart, Chart-cairo, aeson, async, aws, aws-performance-tests, base, colour, configuration-tools, containers, data-default, errors, http-client, lens, lifted-base, monad-control, mtl, resourcet, statistics, text, time, transformers, vector
Files
- CHANGELOG.md +4/−0
- LICENSE +20/−0
- README.md +87/−0
- Setup.hs +1/−0
- aws-performance-tests.cabal +112/−0
- constraints +134/−0
- src/Aws/Test/DynamoDb/Performance.hs +559/−0
- src/Aws/Test/DynamoDb/Utils.hs +143/−0
- src/Aws/Test/Utils.hs +101/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+0.1+===++First public version.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 AlephCloud Systems, Inc.++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,87 @@+[](https://travis-ci.org/alephcloud/hs-aws-performance-tests)++**By using the dynamo-performace application from this package with your AWS API+credentials costs will incure to your AWS account. Depending on the provisioned+test table read and write throughput these costs can be in the order of several+dollars per hour.**++**Also be aware that there is an option to keep the table after the tests are finished+(for example for usage with successive test runs). If you use that option you have to+make sure that you delete the table yourself when you don't need it any more.**++Installation+============++First make sure that you have at least version 1.20 of *Cabal*. You can upgrade+to a recent version via++~~~{.bash}+cabal install Cabal --constraint='cabal>=1.20'+~~~++It is important that you upgrade to a recent *Cabal* version *before* you+run one of the following commands.++For installation from [Hackage](http://hackage.haskell.org/package/aws-performance-tests)+you run:++~~~{.bash}+cabal install aws-performance-tests+~~~++For installation from the [GitHub repository](https://github.com/alephcloud/hs-aws-performance-tests)+can can use the following commands:++~~~{.bash}+git clone https://github.com/alephcloud/hs-aws-performance-tests+cd hs-aws-performance-tests+cabal install+~~~++Charts+------++Optionally the application can be compiled with support for generating charts. For+this you must install *cairo* and *gtk2hs-buildtools*. You also need recent versions+of *alex* and *happy*. On a Linux/Debian system you can install *cairo* as follows:++~~~{.bash}+sudo apt-get install libcairo2+~~~++The Haskell build-tools are installed via:++~~~+cabal install alex happy gtk2hs-buildtools+~~~++You then pass the flag '-fwith-chart' to the the installation commands:++~~~{.bash}+cabal install aws-performance-tests -fwith-chart+~~~++Or when compiling the sources from GitHub:++~~~{.bash}+git clone https://github.com/alephcloud/hs-aws-performance-tests+cd hs-aws-performance-tests+cabal install -fwith-chart+~~~++Usage+=====++After installing the package you'll find the executable 'dynamodb-performance' in the+default location where cabal is configured to install binaries.++In order to use the application you must put your AWS API credentials for+your AWS account in the file '~/.aws-keys' as described in the+[Documentation of the aws package](https://github.com/aristidb/aws#example-usage).++For help on available options you may call the executable with '--help':++~~~{.bash}+dynamodb-performance --help+~~~+
+ Setup.hs view
@@ -0,0 +1,1 @@+import Configuration.Utils.Setup
+ aws-performance-tests.cabal view
@@ -0,0 +1,112 @@+-- ------------------------------------------------------ --+-- Copyright © 2014 AlephCloud Systems, Inc.+-- ------------------------------------------------------ --++Name: aws-performance-tests+Version: 0.1+Synopsis: Performance Tests for the Haskell bindings for Amazon Web Services (AWS)+Description:+ Performance Tests for the Haskell bindings for+ <http://hackage.haskell.org/package/aws Amazon Web Services (AWS)>.+ .+ At the current stage this package only has tests for the DynamoDb+ bindings.+ .+ /IMPORTANT NOTE/+ .+ By using the dynamo-performace application from this package with your AWS API+ credentials costs will incure to your AWS account. Depending on the provisioned+ test table read and write throughput these costs can be in the order of several+ dollars per hour.+ .+ Also be aware that there is an option to keep the table after the tests are finished+ (for example for usage with successive test runs). If you use that option you have to+ make sure that you delete the table yourself when you don't need it any more.++Homepage: http://github.com/alephcloud/hs-aws-performance-tests+License: MIT+License-file: LICENSE+Author: Lars Kuhtz <lars@alephcloud.com>+Maintainer: Lars Kuhtz <lars@alephcloud.com>+Copyright: (c) 2014 AlephCloud, Inc.+Category: Network, Web, AWS, Cloud, Distributed Computing+Build-type: Custom++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-performance-tests.git++source-repository this+ type: git+ location: https://github.com/alephcloud/hs-aws-performance-tests.git+ tag: 0.1++Flag with-chart+ Description: Build applications with support for printing charts.+ Default: False+ Manual: True++Library+ default-language: Haskell2010+ hs-source-dirs: src++ exposed-modules:+ Aws.Test.Utils+ Aws.Test.DynamoDb.Utils++ build-depends:+ aeson >= 0.7,+ aws >= 0.10.3,+ base == 4.*,+ errors >= 1.4.7,+ lifted-base >= 0.2,+ monad-control >= 0.3,+ mtl >= 2.1,+ text >= 1.1,+ transformers >= 0.3++ ghc-options: -Wall++executable dynamodb-performance+ default-language: Haskell2010+ hs-source-dirs: src/Aws/Test/DynamoDb+ main-is: Performance.hs++ build-depends:+ async >= 2.0,+ aws >= 0.10.3,+ aws-performance-tests,+ base == 4.*,+ configuration-tools >= 0.2.4,+ containers >= 0.5,+ errors >= 1.4.7,+ http-client >= 0.3,+ lens >= 4.2,+ monad-control >= 0.3,+ resourcet >= 1.1,+ statistics >= 0.12,+ text >= 1.1,+ time >= 1.4,+ transformers >= 0.3,+ vector >= 0.10++ if flag(with-chart)+ build-depends:+ Chart >= 1.2,+ Chart-cairo >= 1.2,+ colour >= 2.3,+ data-default >= 0.5++ cpp-options: -DWITH_CHART++ ghc-options: -Wall -threaded -with-rtsopts=-N+
+ constraints view
@@ -0,0 +1,134 @@+constraints: Cabal ==1.20.0.1,+ MonadRandom ==0.1.13,+ abstract-deque ==0.3,+ abstract-par ==0.3.3,+ aeson ==0.7.0.6,+ ansi-terminal ==0.6.1.1,+ ansi-wl-pprint ==0.6.7.1,+ array ==0.5.0.0,+ asn1-encoding ==0.8.1.3,+ asn1-parse ==0.8.1,+ asn1-types ==0.2.3,+ async ==2.0.1.5,+ attoparsec ==0.12.1.0,+ attoparsec-conduit ==1.1.0,+ aws ==0.10.3,+ aws-performance-tests ==0.1,+ base ==4.7.0.1,+ base-unicode-symbols ==0.2.2.4,+ base16-bytestring ==0.1.1.6,+ base64-bytestring ==1.0.0.1,+ bifunctors ==4.1.1.1,+ binary ==0.7.1.0,+ 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,+ cipher-aes ==0.2.8,+ cipher-des ==0.0.6,+ cipher-rc4 ==0.1.4,+ comonad ==4.2,+ conduit ==1.1.6,+ conduit-extra ==1.1.1,+ configuration-tools ==0.2.4,+ connection ==0.2.1,+ containers ==0.5.5.1,+ contravariant ==0.6,+ 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,+ distributive ==0.4.4,+ dlist ==0.7.1,+ either ==4.3.0.1,+ erf ==2.0.0.0,+ errors ==1.4.7,+ exceptions ==0.6.1,+ filepath ==1.3.0.2,+ free ==4.9,+ 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,+ lens ==4.2,+ lifted-base ==0.2.3.0,+ math-functions ==0.1.5.2,+ mime-types ==0.1.0.4,+ mmorph ==1.0.3,+ monad-control ==0.3.3.0,+ monad-par ==0.3.4.6,+ monad-par-extras ==0.3.3,+ mtl ==2.1.3.1,+ mwc-random ==0.13.1.2,+ nats ==0.2,+ network ==2.5.0.0,+ old-locale ==1.0.0.6,+ optparse-applicative ==0.9.0,+ parallel ==3.2.0.4,+ parsec ==3.1.5,+ pem ==0.2.2,+ prelude-extras ==0.4,+ pretty ==1.1.1.1,+ primitive ==0.5.3.0,+ process ==1.2.0.0,+ profunctors ==4.0.4,+ publicsuffixlist ==0.1,+ random ==1.0.1.1,+ reflection ==1.4,+ resourcet ==1.1.2.2,+ rts ==1.0,+ safe ==0.3.6,+ scientific ==0.3.3.0,+ securemem ==0.1.3,+ semigroupoids ==4.0.2.1,+ semigroups ==0.15.1,+ socks ==0.5.4,+ split ==0.2.2,+ statistics ==0.12.0.0,+ stm ==2.4.3,+ streaming-commons ==0.1.3.1,+ syb ==0.4.2,+ system-filepath ==0.4.12,+ tagged ==0.7.2,+ template-haskell ==2.9.0.0,+ text ==1.1.1.3,+ time ==1.4.2,+ tls ==1.2.8,+ transformers ==0.3.0.0,+ transformers-base ==0.4.2,+ transformers-compat ==0.3.3.4,+ unix ==2.7.0.1,+ unordered-containers ==0.2.5.0,+ utf8-string ==0.3.8,+ vector ==0.10.11.0,+ vector-algorithms ==0.6.0.2,+ vector-binary-instances ==0.2.1.0,+ vector-th-unbox ==0.2.1.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,+ yaml ==0.8.8.4,+ zlib ==0.5.4.1
+ src/Aws/Test/DynamoDb/Performance.hs view
@@ -0,0 +1,559 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}++-- |+-- Module: Main+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- Performance tests for the Haskell bindings for Amazon DynamoDb+--+module Main+( main+) where++import Aws+import qualified Aws.DynamoDb as DY++import Aws.Test.Utils+import Aws.Test.DynamoDb.Utils++import Configuration.Utils++import Control.Concurrent.Async+import Control.Error+import Control.Exception+import Control.Lens hiding (act, (.=))+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 qualified Data.Map as M+import Data.Monoid+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.Lens as T+import qualified Data.Text.IO as T+import qualified Data.Text.Read as T+import Data.Time+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.Typeable+import qualified Data.Vector.Unboxed as V++import qualified Network.HTTP.Client as HTTP++import PkgInfo++import qualified Statistics.Function as ST+import qualified Statistics.Sample as ST++import System.IO+import System.Timeout++import Text.Printf++#ifdef WITH_CHART+-- Used for plotting+import Control.Arrow ((***))++import Data.Default+import Data.Colour+import Data.Colour.Names++import Graphics.Rendering.Chart hiding (label)+import Graphics.Rendering.Chart.Backend.Cairo++import qualified Statistics.Sample.KernelDensity as ST+#endif++-- -------------------------------------------------------------------------- --+-- Misc Utils++whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()+whenJust (Just x) = ($ x)+whenJust Nothing = const $ return ()++-- -------------------------------------------------------------------------- --+-- Time Measurment++getTime :: IO Double+getTime = realToFrac <$> getPOSIXTime++time :: IO a -> IO (NominalDiffTime, a)+time act = do+ start <- getTime+ result <- act+ end <- getTime+ let !delta = end - start+ return (realToFrac delta, result)++timeT :: MonadIO m => m a -> m (NominalDiffTime, a)+timeT act = do+ start <- liftIO getTime+ result <- act+ end <- liftIO getTime+ let !delta = end - start+ return (realToFrac delta, result)++timeoutT+ :: (MonadBaseControl IO m)+ => T.Text -- ^ label+ -> (T.Text -> b) -- ^ exception constructor+ -> NominalDiffTime -- ^ timeout+ -> EitherT b m a -- ^ action+ -> EitherT b m a+timeoutT label exConstr t a = do+ r <- liftBaseWith $ \runInBase ->+ timeout (round $ t * 1e6) (runInBase a)+ case r of+ Nothing -> left $ exConstr $ label <> " timed out after " <> sshow t+ Just x -> restoreM x++-- -------------------------------------------------------------------------- --+-- Statistics++data Stat = Stat+ { statFailure :: !Int+ , statSuccess :: !Int+ , statFailureLatency :: !ST.Sample -- ^ latency in milliseconds+ , statSuccessLatency :: !ST.Sample -- ^ latency in milliseconds+ , statFailureMessages :: !(S.Set T.Text)+ }+ deriving (Show, Eq, Ord, Typeable)++instance Monoid Stat where+ mempty = Stat 0 0 V.empty V.empty S.empty+ (Stat a0 a1 a2 a3 a4) `mappend` (Stat b0 b1 b2 b3 b4) = Stat+ (a0 + b0)+ (a1 + b1)+ (a2 <> b2)+ (a3 <> b3)+ (a4 <> b4)++successStat :: Double -> Stat+successStat l = Stat 0 1 V.empty (V.singleton l) S.empty++failStat :: Double -> T.Text -> Stat+failStat l e = Stat 1 0 (V.singleton l) V.empty (S.singleton e)++printResult+ :: T.Text+ -> NominalDiffTime+ -> Stat+ -> IO ()+printResult testName totalTime Stat{..} = do++ -- Overview+ printf "Test \"%v\" completed %v requests (%v successes, %v failures) in %.2fs\n\n"+ (T.unpack testName)+ (statSuccess + statFailure)+ statSuccess+ statFailure+ (realToFrac totalTime :: Double)++ -- Successes+ let (succMin, succMax) = ST.minMax statSuccessLatency+ succMean = ST.mean statSuccessLatency+ succStdDev = ST.stdDev statSuccessLatency+ printf "Success latencies\n"+ printf " min: %.2fms, max %.2fms\n" succMin succMax+ printf " mean: %.2fms, standard deviation: %.2fms\n\n" succMean succStdDev++ -- Failures+ unless (statFailure == 0) $ do+ let (failMin, failMax) = ST.minMax statFailureLatency+ failMean = ST.mean statFailureLatency+ failStdDev = ST.stdDev statFailureLatency+ printf "Failure latencies\n"+ printf " min: %.2fms, max %.2fms\n" failMin failMax+ printf " mean: %.2fms, standard deviation %.2fms\n\n" failMean failStdDev++ -- Failure Messages+ printf "Failure Messages:\n"+ forM_ (S.toList statFailureMessages) $ \e ->+ T.putStrLn $ " " <> sshow e+ printf "\n"++writeLatencyData+ :: String -- ^ file name prefix+ -> T.Text -- ^ test name+ -> Stat -- ^ results+ -> IO ()+writeLatencyData prefix testName Stat{..} = do+ writeSample (prefix <> "-" <> T.unpack testName <> "-success.txt") statSuccessLatency+ writeSample (prefix <> "-" <> T.unpack testName <> "-failure.txt") statFailureLatency++#ifdef WITH_CHART+-- -------------------------------------------------------------------------- --+-- Plotting++chart+ :: T.Text -- ^ title of the chart+ -> [(String, Colour Double, [(LogValue, Double)])] -- ^ title color and data for each plot+ -> Renderable ()+chart chartTitle dats = toRenderable layout+ where+ pl (title, color, results) = def+ & plot_points_title .~ title+ & plot_points_style . point_color .~ opaque color+ & plot_points_style . point_radius .~ 1+ & plot_points_values .~ results++ layout = def+ & layout_title .~ T.unpack chartTitle+ & layout_background .~ solidFillStyle (opaque white)+ & layout_left_axis_visibility . axis_show_ticks .~ False+ & setLayoutForeground (opaque black)+ & layout_plots .~ [ toPlot (pl d) | d <- dats ]++densityChart+ :: V.Vector Double+ -> V.Vector Double+ -> Renderable ()+densityChart successes failures = chart "Density" $+ if V.null successes then [] else [("success", blue, succDat)]+ <>+ if V.null failures then [] else [("failures", red, failDat)]+ where+ succDat,failDat :: [(LogValue, Double)]+ succDat = uncurry zip . (map LogValue . V.toList *** map (* 2048) . V.toList) $ ST.kde 2048 successes+ failDat = uncurry zip . (map LogValue . V.toList *** map (* 2048) . V.toList) $ ST.kde 2048 failures++writeChart+ :: String -- ^ file name prefix+ -> T.Text -- ^ test name+ -> Stat -- ^ results+ -> IO ()+writeChart prefix testName Stat{..} = renderableToPDFFile render 800 600 $+ prefix <> "-" <> T.unpack testName <> "-density.pdf"+ where+ render = densityChart statSuccessLatency statFailureLatency++#endif++-- -------------------------------------------------------------------------- --+-- Serialize latencies++writeSample+ :: FilePath+ -> ST.Sample+ -> IO ()+writeSample file sample = withFile file WriteMode $ \h ->+ V.forM_ sample $ T.hPutStrLn h . sshow++readSample+ :: FilePath+ -> IO ST.Sample+readSample file = withFile file ReadMode $ fmap V.fromList . go+ where+ go h = hIsEOF h >>= \x -> if x+ then return []+ else do+ r <- either error fst . T.double <$> T.hGetLine h+ (:) r <$> go h++-- -------------------------------------------------------------------------- --+-- Running Tests++testItems :: T.Text -> Int -> [DY.Item]+testItems prefix n = map (\i -> M.singleton "Id" (DY.DString $ prefix <> "-" <> sshow i)) [0..n-1]++testQueries :: T.Text -> Int -> [DY.PrimaryKey]+testQueries prefix n = map (\i -> DY.hk "Id" (DY.DString $ prefix <> "-" <> sshow i)) [0..n-1]++runThread+ :: (Transaction r x, ServiceConfiguration r ~ DY.DdbConfiguration)+ => Configuration+ -> HTTP.Manager+ -> [r]+ -> IO Stat+runThread cfg manager = flip foldM mempty $ \stat req -> do+ (t,response) <- time . runResourceT $ aws cfg dyConfiguration manager req+ case responseResult response of+ Right _ -> return $ stat <> successStat (realToFrac t * 1000)+ Left e -> return $ stat <> failStat (realToFrac t * 1000) (sshow e)++-- | Use a single Manager for all threads+--+runTestGlobalManager+ :: (Transaction r x, ServiceConfiguration r ~ DY.DdbConfiguration)+ => T.Text -- ^ test name+ -> TestParams -- ^ test parameters+ -> (Int -> [r]) -- ^ requests per thread+ -> IO ()+runTestGlobalManager testName TestParams{..} mkRequests = do+ T.putStrLn $ "Start test \"" <> testName <> "\""+ cfg <- baseConfiguration+ (t, stats) <- HTTP.withManager managerSettings $ \manager ->+ time $ mapConcurrently+ (runThread cfg manager)+ (map mkRequests [0.. _paramThreadCount - 1])++ -- report results+ let stat = mconcat stats+ printResult testName t stat+ whenJust _paramDataFilePrefix $ \prefix ->+ writeLatencyData prefix testName stat+#ifdef WITH_CHART+ whenJust _paramChartFilePrefix $ \prefix ->+ writeChart prefix testName stat+#endif+ where+ managerSettings = HTTP.defaultManagerSettings+ { HTTP.managerConnCount = _paramThreadCount + 5+ , HTTP.managerResponseTimeout = Just (1000 * 1000000) -- 1 second+ , HTTP.managerWrapIOException = id+#if MIN_VERSION_http_client(0,3,7)+ , HTTP.managerIdleConnectionCount = 512 -- this is the default+#endif+ }++-- | Use one 'Manager' per thread.+--+runTest+ :: (Transaction r x, ServiceConfiguration r ~ DY.DdbConfiguration)+ => T.Text -- ^ test name+ -> TestParams -- ^ test parameters+ -> (Int -> [r]) -- ^ requests per thread+ -> IO ()+runTest testName TestParams{..} mkRequests = do+ T.putStrLn $ "Start test \"" <> testName <> "\""+ cfg <- baseConfiguration+ (t, stats) <- time $ mapConcurrently+ (\r -> HTTP.withManager managerSettings $ \m -> runThread cfg m r)+ (map mkRequests [0.. _paramThreadCount - 1])++ -- report results+ let stat = mconcat stats+ printResult testName t stat+ whenJust _paramDataFilePrefix $ \prefix ->+ writeLatencyData prefix testName stat+#ifdef WITH_CHART+ whenJust _paramChartFilePrefix $ \prefix ->+ writeChart prefix testName stat+#endif+ where+ managerSettings = HTTP.defaultManagerSettings+ { HTTP.managerConnCount = 1+ , HTTP.managerResponseTimeout = Just (1000 * 1000000) -- 1 second+ , HTTP.managerWrapIOException = id+#if MIN_VERSION_http_client(0,3,7)+ , HTTP.managerIdleConnectionCount = 1+#endif+ }++-- -------------------------------------------------------------------------- --+-- Test Vectors++putItems+ :: T.Text -- ^ table name+ -> Int -- ^ number of items per thread+ -> Int -- ^ thread Id+ -> [DY.PutItem]+putItems tableName itemsPerThread threadId = map (DY.putItem tableName) $+ testItems (sshow threadId) itemsPerThread++getItems0+ :: T.Text -- ^ table name+ -> Int -- ^ number of items per thread+ -> Int -- ^ thread Id+ -> [DY.GetItem]+getItems0 tableName itemsPerThread _ = replicate itemsPerThread $+ DY.getItem tableName $ DY.hk "Id" (DY.DString "0-0")++getItems1+ :: T.Text -- ^ table name+ -> Int -- ^ number of items per thread+ -> Int -- ^ thread Id+ -> [DY.GetItem]+getItems1 tableName itemsPerThread threadId = replicate itemsPerThread $+ DY.getItem tableName $ DY.hk "Id" (DY.DString $ sshow threadId <> "-0")++getItems2+ :: T.Text -- ^ table name+ -> Int -- ^ number of items per thread+ -> Int -- ^ thread Id+ -> [DY.GetItem]+getItems2 tableName itemsPerThread threadId = map (DY.getItem tableName) $+ testQueries (sshow threadId) itemsPerThread++-- -------------------------------------------------------------------------- --+-- Parameters++data TestParams = TestParams+ { _paramThreadCount :: !Int+ , _paramRequestCount :: !Int+ , _paramReadCapacity :: !Int+ , _paramWriteCapacity :: !Int+ , _paramTableName :: !T.Text+ , _paramKeepTable :: !Bool+ , _paramDataFilePrefix :: !(Maybe String)+#ifdef WITH_CHART+ , _paramChartFilePrefix :: !(Maybe String)+#endif+ }+ deriving (Show, Read, Eq, Ord, Typeable)++defaultTestParams :: TestParams+defaultTestParams = TestParams+ { _paramThreadCount = 1+ , _paramRequestCount = 100+ , _paramReadCapacity = 5+ , _paramWriteCapacity = 5+ , _paramTableName = "__DYNAMODB_PERFORMANCE_TEST__"+ , _paramKeepTable = False+ , _paramDataFilePrefix = Nothing+#ifdef WITH_CHART+ , _paramChartFilePrefix = Nothing+#endif+ }++$(makeLenses ''TestParams)++instance ToJSON TestParams where+ toJSON TestParams{..} = object+ [ "ThreadsCount" .= _paramThreadCount+ , "RequestCount" .= _paramRequestCount+ , "ReadCapacity" .= _paramReadCapacity+ , "WriteCapacity" .= _paramWriteCapacity+ , "TableName" .= _paramTableName+ , "KeepTable" .= _paramKeepTable+ , "DataFilePrefix" .= _paramDataFilePrefix+#ifdef WITH_CHART+ , "ChartFilePrefix" .= _paramChartFilePrefix+#endif+ ]++instance FromJSON (TestParams -> TestParams) where+ parseJSON = withObject "TestParams" $ \o -> id+ <$< paramThreadCount ..: "ThreadCount" % o+ <*< paramRequestCount ..: "RequestCount" % o+ <*< paramReadCapacity ..: "ReadCapacity" % o+ <*< paramWriteCapacity ..: "WriteCapacity" % o+ <*< paramTableName ..: "TableName" % o+ <*< paramKeepTable ..: "KeepTable" % o+ <*< paramDataFilePrefix ..: "DataFilePrefix" % o+#ifdef WITH_CHART+ <*< paramChartFilePrefix ..: "ChartFilePrefix" % o+#endif++pTestParams :: MParser TestParams+pTestParams = id+ <$< paramThreadCount .:: option+ % long "thread-count"+ <> metavar "INT"+ <> help "number of request threads"+ <*< paramRequestCount .:: option+ % long "request-count"+ <> metavar "INT"+ <> help "number of requests PER THREAD"+ <*< paramReadCapacity .:: option+ % long "read-capacity"+ <> metavar "INT"+ <> help "minimum provisioned read capacity for the test table"+ <*< paramWriteCapacity .:: option+ % long "write-capacity"+ <> metavar "INT"+ <> help "minimum provisioned write capacity for the test table"+ <*< paramTableName . from T.packed .:: strOption+ % long "table-name"+ <> metavar "STRING"+ <> help "name oftabel that is used for the tests. If the table does not exit it is created"+ <*< paramKeepTable .:: switch+ % long "keep-table"+ <> help "don't delete table of the test. This is always true for pre-existing tables."+ <*< (paramDataFilePrefix .:: fmap Just % strOption+ % long "data-file-prefix"+ <> metavar "STRING"+ <> help "if present raw latency data is written to files with this prefix.")+#ifdef WITH_CHART+ <*< (paramChartFilePrefix .:: fmap Just % strOption+ % long "chart-file-prefix"+ <> metavar "STRING"+ <> help "if present latency density chargts are written to files with this prefix.")+#endif++-- -------------------------------------------------------------------------- --+-- Main++mainInfo :: ProgramInfo TestParams+mainInfo = programInfo "Dynamo Performace Test" pTestParams defaultTestParams+ & piHelpHeader .~ Just % L.intercalate "\n"+ [ "In order to use the application you must put your AWS API credentials for"+ , "your AWS account in the file '~/.aws-keys' as described in the"+ , "Documentation of the aws package (https://github.com/aristidb/aws#example-usage)."+ ]+ & piHelpFooter .~ Just % L.intercalate "\n"+ [ "IMPORTANT NOTE:"+ , ""+ , "By using the dynamo-performace application from this package with your AWS API"+ , "credentials costs will incure to your AWS account. Depending on the provisioned"+ , "test table read and write throughput these costs can be in the order of several"+ , "dollars per hour."+ , ""+ , "Also be aware that there is an option to keep the table after the tests are finished"+ , "(for example for usage with successive test runs). If you use that option you have to"+ , "make sure that you delete the table yourself when you don't need it any more."+ ]++main :: IO ()+main = runWithPkgInfoConfiguration mainInfo pkgInfo $ \params@TestParams{..} -> do++ -- Check if table exists+ tabDesc <- (Just <$> simpleDy (DY.DescribeTable _paramTableName)) `catch` \(e :: DY.DdbError) ->+ case DY.ddbErrCode e of+ DY.ResourceNotFoundException -> return Nothing+ _ -> error $ "unexpected exception when checking for existence of table: " <> show e++ -- Prepare table+ let getTable = case (tabDesc, _paramKeepTable) of++ (Nothing, False) -> withTable_ False _paramTableName _paramReadCapacity _paramWriteCapacity++ (Nothing, True) -> \f -> do+ r <- runEitherT $ do+ retryT 3 $ tryT $ createTestTable _paramTableName _paramReadCapacity _paramWriteCapacity+ retryT 6 $ do+ tableDesc <- simpleDyT $ DY.DescribeTable _paramTableName+ when (DY.rTableStatus tableDesc == "CREATING") $ left "Table not ready: status CREATING"+ return _paramTableName+ either (error . T.unpack) f r++ (Just DY.TableDescription{..}, _) -> \f -> do++ -- Check table+ let tableReadCapacity = DY.statusReadCapacityUnits rProvisionedThroughput+ let tableWriteCapacity = DY.statusWriteCapacityUnits rProvisionedThroughput++ unless (rTableStatus == "ACTIVE") . error $ "Table not ready: status " <> T.unpack rTableStatus++ when (tableReadCapacity < _paramReadCapacity) . error $+ "Read capacity of table " <> T.unpack _paramTableName <> " is not enough; requested "+ <> sshow _paramReadCapacity <> " provisioned: " <> sshow tableReadCapacity++ when (tableWriteCapacity < _paramWriteCapacity) . error $+ "Write capacity of table " <> T.unpack _paramTableName <> " is not enough; requested "+ <> sshow _paramWriteCapacity <> " provisioned: " <> sshow tableWriteCapacity++ -- return table+ f _paramTableName++ -- Initialize table and run tests+ getTable $ \tableName -> do+ runTest "put" params $ putItems tableName _paramRequestCount+ runTest "get0" params $ getItems0 tableName _paramRequestCount+ runTest "get1" params $ getItems1 tableName _paramRequestCount+ runTest "get2" params $ getItems2 tableName _paramRequestCount
+ src/Aws/Test/DynamoDb/Utils.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module: Aws.Test.DynamoDb.Utils+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- Utils for testing the Haskell bindings for Amazon DynamoDb+--++module Aws.Test.DynamoDb.Utils+(+-- * Static Parameters+ testProtocol+, testRegion+, defaultTableName++-- * Static Configuration+, dyConfiguration++-- * DynamoDb Utils+, simpleDy+, simpleDyT+, withTable+, withTable_+, createTestTable+) where++import Aws+import Aws.Core+import qualified Aws.DynamoDb as DY+import Aws.Test.Utils++import Control.Error+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Control++import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.IO as T++import System.IO++-- -------------------------------------------------------------------------- --+-- Static Test parameters+--+-- TODO make these configurable++testProtocol :: Protocol+testProtocol = HTTP++testRegion :: DY.Region+testRegion = DY.ddbUsWest2++defaultTableName :: T.Text+defaultTableName = "test-table"++-- -------------------------------------------------------------------------- --+-- Dynamo Utils++dyConfiguration :: DY.DdbConfiguration qt+dyConfiguration = DY.DdbConfiguration+ { DY.ddbcRegion = testRegion+ , DY.ddbcProtocol = testProtocol+ , DY.ddbcPort = Nothing+ }++simpleDy+ :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration, MonadIO m)+ => r+ -> m (MemoryResponse a)+simpleDy command = do+ c <- baseConfiguration+ simpleAws c dyConfiguration command++simpleDyT+ :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration, MonadBaseControl IO m, MonadIO m)+ => r+ -> EitherT T.Text m (MemoryResponse a)+simpleDyT = tryT . simpleDy++withTable+ :: T.Text -- ^ table Name+ -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)+ -> Int -- ^ write capacity (#writes * itemsize/1KB)+ -> (T.Text -> IO a) -- ^ test action+ -> IO a+withTable = withTable_ True++withTable_+ :: Bool -- ^ whether to prefix te table name+ -> T.Text -- ^ table Name+ -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)+ -> Int -- ^ write capacity (#writes * itemsize/1KB)+ -> (T.Text -> IO a) -- ^ test action+ -> IO a+withTable_ prefix tableName readCapacity writeCapacity f =+ bracket_ createTable deleteTable $ f tTableName+ where+ tTableName = if prefix then testData tableName else tableName+ deleteTable = do+ r <- runEitherT . retryT 6 $+ void (simpleDyT $ DY.DeleteTable tTableName) `catchT` \e ->+ liftIO . T.hPutStrLn stderr $ "attempt to delete table failed: " <> e+ either (error . T.unpack) (const $ return ()) r++ createTable = do+ r <- runEitherT $ do+ retryT 3 $ tryT $ createTestTable tTableName readCapacity writeCapacity+ retryT 6 $ do+ tableDesc <- simpleDyT $ DY.DescribeTable tTableName+ when (DY.rTableStatus tableDesc == "CREATING") $ left "Table not ready: status CREATING"+ either (error . T.unpack) return r++createTestTable+ :: T.Text -- ^ table Name+ -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)+ -> Int -- ^ write capacity (#writes * itemsize/1KB)+ -> IO ()+createTestTable tableName readCapacity writeCapacity = void . simpleDy $+ DY.createTable+ tableName+ attrs+ (DY.HashOnly keyName)+ throughPut+ where+ keyName = "Id"+ keyType = DY.AttrString+ attrs = [DY.AttributeDefinition keyName keyType]+ throughPut = DY.ProvisionedThroughput+ { DY.readCapacityUnits = readCapacity+ , DY.writeCapacityUnits = writeCapacity+ }++
+ src/Aws/Test/Utils.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module: Aws.Test.Utils+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- Utils for testing the Haskell bindings for Amazon Web Services (AWS)+--+module Aws.Test.Utils+(+-- * Parameters+ testDataPrefix++-- * General Utils+, sshow+, tryT+, retryT+, retryT_+, testData+) where++import Control.Applicative+import Control.Concurrent (threadDelay)+import qualified Control.Exception.Lifted as LE+import Control.Error hiding (syncIO)+import Control.Monad.IO.Class+import Control.Monad.Trans.Control++import Data.Dynamic (Dynamic)+import Data.Monoid+import Data.String+import qualified Data.Text as T++import System.Exit (ExitCode)++-- -------------------------------------------------------------------------- --+-- Static Test parameters+--++-- | 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++-- | Catches all exceptions except for asynchronous exceptions found in base.+--+tryT :: MonadBaseControl IO m => m a -> EitherT T.Text m a+tryT = fmapLT (T.pack . show) . syncIO++-- | Lifted Version of 'syncIO' form "Control.Error.Util".+--+syncIO :: MonadBaseControl IO m => m a -> EitherT LE.SomeException m a+syncIO a = EitherT $ LE.catches (Right <$> a)+ [ LE.Handler $ \e -> LE.throw (e :: LE.ArithException)+ , LE.Handler $ \e -> LE.throw (e :: LE.ArrayException)+ , LE.Handler $ \e -> LE.throw (e :: LE.AssertionFailed)+ , LE.Handler $ \e -> LE.throw (e :: LE.AsyncException)+ , LE.Handler $ \e -> LE.throw (e :: LE.BlockedIndefinitelyOnMVar)+ , LE.Handler $ \e -> LE.throw (e :: LE.BlockedIndefinitelyOnSTM)+ , LE.Handler $ \e -> LE.throw (e :: LE.Deadlock)+ , LE.Handler $ \e -> LE.throw (e :: Dynamic)+ , LE.Handler $ \e -> LE.throw (e :: LE.ErrorCall)+ , LE.Handler $ \e -> LE.throw (e :: ExitCode)+ , LE.Handler $ \e -> LE.throw (e :: LE.NestedAtomically)+ , LE.Handler $ \e -> LE.throw (e :: LE.NoMethodError)+ , LE.Handler $ \e -> LE.throw (e :: LE.NonTermination)+ , LE.Handler $ \e -> LE.throw (e :: LE.PatternMatchFail)+ , LE.Handler $ \e -> LE.throw (e :: LE.RecConError)+ , LE.Handler $ \e -> LE.throw (e :: LE.RecSelError)+ , LE.Handler $ \e -> LE.throw (e :: LE.RecUpdError)+ , LE.Handler $ return . Left+ ]++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 n f = snd <$> retryT_ n f++retryT_ :: MonadIO m => Int -> EitherT T.Text m a -> EitherT T.Text m (Int, a)+retryT_ n f = go 1+ where+ go x+ | x >= n = fmapLT (\e -> "error after " <> sshow x <> " retries: " <> e) ((x,) <$> f)+ | otherwise = ((x,) <$> f) `catchT` \_ -> do+ liftIO $ threadDelay (1000000 * min 60 (2^(x-1)))+ go (succ x)++sshow :: (Show a, IsString b) => a -> b+sshow = fromString . show+