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,87 @@ +[![Build Status](https://travis-ci.org/alephcloud/hs-aws-performance-tests.svg?branch=master)](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 +~~~ + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,1 @@ +import Configuration.Utils.Setup diff --git a/aws-performance-tests.cabal b/aws-performance-tests.cabal new file mode 100644 --- /dev/null +++ b/aws-performance-tests.cabal @@ -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 + . + . + 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 +Maintainer: Lars Kuhtz +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 + diff --git a/constraints b/constraints new file mode 100644 --- /dev/null +++ b/constraints @@ -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 diff --git a/src/Aws/Test/DynamoDb/Performance.hs b/src/Aws/Test/DynamoDb/Performance.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Test/DynamoDb/Performance.hs @@ -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 +-- 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 diff --git a/src/Aws/Test/DynamoDb/Utils.hs b/src/Aws/Test/DynamoDb/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Test/DynamoDb/Utils.hs @@ -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 +-- 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 + } + + diff --git a/src/Aws/Test/Utils.hs b/src/Aws/Test/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Aws/Test/Utils.hs @@ -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 +-- 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 +