wrecker (empty) → 0.1.0.0
raw patch · 11 files changed
+1040/−0 lines, 11 filesdep +aesondep +aeson-qqdep +ansi-terminalsetup-changed
Dependencies added: aeson, aeson-qq, ansi-terminal, ansigraph, base, bytestring, clock, clock-extras, deepseq, hspec, hspec-discovery, http-client, http-types, next-ref, optparse-applicative, statistics, stm, stm-chans, tabular, text, threads, threads-extras, time, unagi-chan, unix, unordered-containers, vector, vty, wrecker
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Wrecker.hs +23/−0
- src/Wrecker/Logger.hs +78/−0
- src/Wrecker/Main.hs +20/−0
- src/Wrecker/Options.hs +188/−0
- src/Wrecker/Recorder.hs +136/−0
- src/Wrecker/Runner.hs +204/−0
- src/Wrecker/Statistics.hs +281/−0
- test/Spec.hs +1/−0
- wrecker.cabal +77/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author skedge.me (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Wrecker.hs view
@@ -0,0 +1,23 @@+{-| 'wrecker' is a library for creating HTTP benchmarks. It is designed for+ benchmarking a series of HTTP request were the output of previous requests+ are used as inputs to the next request. This is useful for complex API + profiling situations. ++ 'wrecker' does not provide any mechanism for making HTTP calls. It works+ with any HTTP client that produces a 'HttpException' during failure (so + http-client and wreq will work out of the box).+ + See the documentation for examples of how to use 'wrecker' with + benchmarking scripts.+-}+module Wrecker ( Recorder+ , defaultMain + , record+ , run+ , Options (..)+ , defaultOptions+ ) where+import Wrecker.Recorder+import Wrecker.Main+import Wrecker.Options+import Wrecker.Runner
+ src/Wrecker/Logger.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE RecordWildCards #-}+module Wrecker.Logger where+import qualified Control.Concurrent.Chan.Unagi.Bounded as U+import System.IO+import System.Timeout+import Data.Foldable (traverse_)+import Control.Concurrent.MVar+import Control.Concurrent+import Data.Function++data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError+ deriving (Show, Eq, Ord, Read)++data Logger = Logger + { thread :: ThreadId+ , inChan :: U.InChan (Maybe String)+ , wait :: IO ()+ , currentLevel :: LogLevel+ }++newLogger :: Handle -> Int -> LogLevel -> IO Logger+newLogger handle maxSize currentLevel = do + (inChan, outChan) <- U.newChan maxSize+ lock <- newEmptyMVar + thread <- readLoop handle outChan lock+ + let wait = takeMVar lock+ + return Logger {..}++newStdErrLogger :: Int -> LogLevel -> IO Logger+newStdErrLogger = newLogger stderr++readLoop :: Handle -> U.OutChan (Maybe String) -> MVar () -> IO ThreadId+readLoop handle chan lock = forkIO $ do + fix $ \next -> do + -- Block on the next elemen+ -- If it "Just" print it and loop+ -- Otherwise we are not with the loop+ U.readChan chan >>= traverse_ (\msg -> do+ hPutStrLn handle msg+ next+ )++ putMVar lock ()++-- True if the write was successful or False otherwise+writeLogger :: Logger -> LogLevel -> String -> IO Bool+writeLogger Logger {..} messageLevel msg = + if (currentLevel <= messageLevel) then+ U.tryWriteChan inChan $ Just msg+ else+ return False+ + +shutdownLogger :: Int -> Logger -> IO ()+shutdownLogger waitTime logger@(Logger {..}) = do + U.writeChan inChan Nothing+ mtimedOut <- timeout waitTime wait + case mtimedOut of+ Nothing -> forceShutdownLogger logger+ Just () -> return ()++forceShutdownLogger :: Logger -> IO ()+forceShutdownLogger Logger {..} = killThread thread++logDebug :: Logger -> String -> IO Bool+logDebug logger = writeLogger logger LevelDebug++logInfo :: Logger -> String -> IO Bool+logInfo logger = writeLogger logger LevelInfo++logWarn :: Logger -> String -> IO Bool+logWarn logger = writeLogger logger LevelWarn++logError :: Logger -> String -> IO Bool+logError logger = writeLogger logger LevelError+
+ src/Wrecker/Main.hs view
@@ -0,0 +1,20 @@+module Wrecker.Main (defaultMain) where+import Wrecker.Runner (run)+import Wrecker.Options (runParser)+import Wrecker.Recorder (Recorder)++{- | 'defaultMain' is typically the main entry point for 'wrecker' benchmarks.+ 'defaultMain' will parse all command line arguments and then call 'run'+ with the correct 'Options'. ++> import Wrecker +> import Your.Performance.Scripts (landingPage, purchase)+> +> main :: IO ()+> main = defaultMain +> [ ("loginReshare", loginReshare)+> , ("purchase" , purchase )+> ]+-}+defaultMain :: [(String, Recorder -> IO ())] -> IO ()+defaultMain actions = flip run actions =<< runParser
+ src/Wrecker/Options.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE RecordWildCards, CPP #-}+module Wrecker.Options where+import Options.Applicative.Builder+import Options.Applicative+import Control.Exception+import Wrecker.Logger+#if __GLASGOW_HASKELL__ == 710+import Data.Monoid+#endif++data RunType = RunCount Int | RunTimed Int+ deriving (Show, Eq)+ +data DisplayMode = Interactive | NonInteractive + deriving (Show, Eq, Read)+ +data Options = Options+ { concurrency :: Int+ -- ^ The number of simulatanous connections+ , binCount :: Int+ -- ^ The number of bins for the histogram+ , runStyle :: RunType+ -- ^ runStyle determines if the 'wrecker' runs for a specified+ -- time period or for a specified number of runs.+ , timeoutTime :: Int+ -- ^ How long to wait after the first benchmark for the other threads + -- to finish+ , displayMode :: DisplayMode+ -- ^ This controls the command line display. It can be either Interactive+ -- of NonInteractive+ , logLevel :: LogLevel+ -- ^ + , match :: String+ -- ^ Set this to filter the benchmarks using a pattern+ , requestNameColumnSize :: Maybe Int+ -- ^ Limit the request name column to the given size+ , outputFilePath :: Maybe FilePath+ -- ^ Dump the results to JSON file+ , silent :: Bool+ -- ^ Set 'silent' to true to disable all output.+ } deriving (Show, Eq)++-- | 'defaultOptions' provides sensible default for the 'Options' +-- types+defaultOptions :: Options+defaultOptions = Options + { concurrency = 1+ , binCount = 20+ , runStyle = RunCount 1+ , timeoutTime = 100000000+ , displayMode = NonInteractive+ , logLevel = LevelError+ , match = ""+ , requestNameColumnSize = Nothing+ , outputFilePath = Nothing+ , silent = False+ } ++data PartialOptions = PartialOptions + { mConcurrency :: Maybe Int+ , mBinCount :: Maybe Int+ , mRunStyle :: Maybe RunType+ , mTimeoutTime :: Maybe Int+ , mDisplayMode :: Maybe DisplayMode+ , mLogLevel :: Maybe LogLevel+ , mMatch :: Maybe String+ , mRequestNameColumnSize :: Maybe Int+ , mOutputFilePath :: Maybe FilePath+ , mSilent :: Maybe Bool+ } deriving (Show, Eq)+ +instance Monoid PartialOptions where+ mempty = PartialOptions + { mConcurrency = Just $ concurrency defaultOptions + , mBinCount = Just $ binCount defaultOptions+ , mRunStyle = Just $ runStyle defaultOptions+ , mTimeoutTime = Just $ timeoutTime defaultOptions+ , mDisplayMode = Just $ displayMode defaultOptions+ , mLogLevel = Just $ logLevel defaultOptions+ , mMatch = Just $ match defaultOptions+ , mRequestNameColumnSize = requestNameColumnSize defaultOptions+ , mOutputFilePath = outputFilePath defaultOptions+ , mSilent = Just $ silent defaultOptions+ }+ mappend x y = PartialOptions + { mConcurrency = mConcurrency x <|> mConcurrency y+ , mBinCount = mBinCount x <|> mBinCount y+ , mRunStyle = mRunStyle x <|> mRunStyle y+ , mTimeoutTime = mTimeoutTime x <|> mTimeoutTime y+ , mDisplayMode = mDisplayMode x <|> mDisplayMode y+ , mLogLevel = mLogLevel x <|> mLogLevel y+ , mMatch = mMatch x <|> mMatch y+ , mRequestNameColumnSize = mRequestNameColumnSize x + <|> mRequestNameColumnSize y+ , mOutputFilePath = mOutputFilePath x + <|> mOutputFilePath y+ , mSilent = mSilent x <|> mSilent y+ }++completeOptions :: PartialOptions -> Maybe Options+completeOptions options = + case options <> mempty of+ PartialOptions + { mConcurrency = Just concurrency+ , mBinCount = Just binCount+ , mRunStyle = Just runStyle+ , mTimeoutTime = Just timeoutTime+ , mDisplayMode = Just displayMode+ , mLogLevel = Just logLevel+ , mMatch = Just match+ , mRequestNameColumnSize = requestNameColumnSize+ , mOutputFilePath = outputFilePath+ , mSilent = Just silent+ } -> Just $ Options {..}+ _ -> Nothing + +optionalOption :: Read a => Mod OptionFields a -> Parser (Maybe a)+optionalOption = optional . option auto++optionalStrOption :: Mod OptionFields String -> Parser (Maybe String)+optionalStrOption = optional . strOption++optionalSwitch :: Mod FlagFields Bool -> Parser (Maybe Bool)+optionalSwitch = optional . switch++pPartialOptions :: Parser PartialOptions +pPartialOptions+ = PartialOptions+ <$> optionalOption + ( long "concurrency"+ <> help "Number of threads for concurrent requests"+ )+ <*> optionalOption + ( long "bin-count"+ <> help "Number of bins for latency histogram"+ )+ <*> optional + ( RunCount <$> option auto+ ( long "run-count"+ <> help "number of times to repeat "+ )+ <|> RunTimed <$> option auto+ ( long "run-timed"+ <> help "number of seconds to repeat "+ )+ )+ <*> optionalOption+ ( long "timeout-time"+ <> help "How long to wait for all requests to finish"+ )+ <*> optionalOption + ( long "display-mode"+ <> help "Display results interactively"+ )+ <*> optionalOption + ( long "log-level"+ <> help "Display results interactively"+ )+ <*> optionalStrOption+ ( long "match"+ <> help "Only run tests that match the glob"+ )+ <*> optionalOption + ( long "request-name-size"+ <> help "Request name size for the terminal display"+ )+ <*> optionalStrOption + ( long "output-path"+ <> help "Save a JSON file of the the statistics to given path"+ )+ <*> optionalSwitch + ( long "silent"+ <> help "Disable all output"+ )++runParser :: IO Options+runParser = do + let opts = info (helper <*> pPartialOptions)+ ( fullDesc+ <> progDesc "Welcome to wrecker"+ <> header "wrecker - HTTP stress tester and benchmarker" + )+ + partialOptions <- execParser opts + case completeOptions partialOptions of+ Nothing -> throwIO $ userError ""+ Just x -> return x+
+ src/Wrecker/Recorder.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass, CPP #-}+module Wrecker.Recorder where+import Control.Concurrent.STM+import Control.Concurrent.STM.TBMQueue+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types as HTTP+import System.Clock+import Control.Exception+import System.Clock.TimeIt++data RunResult + = Success { resultTime :: !Double + , name :: !String+ }+ | ErrorStatus { resultTime :: !Double + , errorCode :: !Int+ , name :: !String+ }+ | Error { resultTime :: !Double+ , exception :: !SomeException+ , name :: !String+ }+ | End + deriving (Show)++data Event = Event + { eRunIndex :: !Int+ , result :: !RunResult+ } deriving (Show)++-- | An opaque type for recording actions for profiling. +-- No means are provided for creating a 'Recorder' directly.+-- To obtain a 'Recorder' use either 'run' or 'defaultMain'.+data Recorder = Recorder + { rRunIndex :: !Int+ , rQueue :: !(TBMQueue Event)+ }+ +-- The bound here should be configurable+split :: Recorder -> Recorder+split Recorder {..} = Recorder (rRunIndex + 1) rQueue++newRecorder :: Int -> IO Recorder +newRecorder maxSize = Recorder 0 <$> newTBMQueueIO maxSize++stopRecorder :: Recorder -> IO ()+stopRecorder = atomically . closeTBMQueue . rQueue++addEvent :: Recorder -> RunResult -> IO ()+addEvent (Recorder runIndex queue) runResult = + atomically $ writeTBMQueue queue $ Event runIndex runResult+ +readEvent :: Recorder -> IO (Maybe Event)+readEvent = atomically . readTBMQueue . rQueue++{- | 'record' is how HTTP actions are profiled. Wrap each action of + interest in a call to record.++> import Network.Wreq.Session+> import Data.Aeson+> +> loginReshare :: Recorder -> IO ()+> loginReshare recorder = withSession $ \session -> do+> let rc = record recorder+> +> userId <- rc "login" +> $ asJSON+> =<< ( post session "https://somesite.com/login" +> $ object [ "email" .= "example@example.com"+> , "password" .= "12345678"+> ]+> )+>+> itemRef : _ <- rc "get feed" +> $ asJSON+> =<< ( post session userId +> $ object [ "email" .= "example@example.com"+> , "password" .= "12345678"+> ]+> )+> rc "reshare" $ post session "https://somesite.com/share" +> $ object [ "type" : "reshare"+> , "ref" : itemRef+> ]++ In this case the 'loginReshare' script would record three actions: "login", + "get feed" and "reshare".++ 'record' measures the elapsed time of the call, and catches + 'HttpException' in the case of failure. This means failures+ must be thrown if they are to be properly recorded. +-}+record :: forall a. Recorder -> String -> IO a -> IO a+record recorder key action = do+ startTime <- getTime Monotonic+ + let recordAction :: IO a+ recordAction = do+ r <- action+ endTime <- getTime Monotonic+ addEvent recorder $ Success + { resultTime = diffSeconds endTime startTime+ , name = key+ }+ return r+ + recordException :: HTTP.HttpException -> IO a+ recordException e = do+ endTime <- getTime Monotonic+ case e of +#if MIN_VERSION_http_client(0,5,0)+ HTTP.HttpExceptionRequest _ (HTTP.StatusCodeException resp _) -> do+ let code = HTTP.statusCode $ HTTP.responseStatus resp+#else+ HTTP.StatusCodeException stat _ _ -> do+ let code = HTTP.statusCode stat+#endif+ ++ addEvent recorder $ ErrorStatus+ { resultTime = diffSeconds endTime startTime + , errorCode = code + , name = key+ }+ + _ -> addEvent recorder $ Error + { resultTime = diffSeconds endTime startTime+ , exception = toException e+ , name = key+ }+ -- rethrow no matter what+ throwIO e+ + handle recordException recordAction
+ src/Wrecker/Runner.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, LambdaCase, BangPatterns #-}+module Wrecker.Runner where+import Wrecker.Logger+import System.Posix.Signals+import Data.Function+import qualified Control.Concurrent.Thread.BoundedThreadGroup as BoundedThreadGroup+import Control.Concurrent+import Control.Exception+import Wrecker.Recorder+import Wrecker.Statistics+import Control.Monad+import Data.Foldable (for_)+import System.Timeout+import qualified Graphics.Vty as VTY+import Control.Concurrent.NextRef+import Wrecker.Options+import Data.IORef+import System.IO+import Control.Concurrent.STM.TChan+import Control.Concurrent.STM+import Data.List (isInfixOf)+import Data.Aeson (encode)+import qualified Data.ByteString.Lazy as BSL+-- TODO configure whether errors are used in times or not+ +updateSampler :: NextRef AllStats -> Event -> IO AllStats+updateSampler !ref !event = modifyNextRef ref + $ \x -> let !new = stepAllStats x + (eRunIndex event) + (name $ result event) + (result event) + in (new, new)+ +collectEvent :: Logger -> NextRef AllStats -> Recorder -> IO ()+collectEvent logger ref recorder = fix $ \next -> do + mevent <- readEvent recorder+ for_ mevent $ \event -> do+ sampler <- updateSampler ref event+ logDebug logger $ show sampler+ next ++runAction :: Logger + -> Int + -> Int + -> RunType + -> (Recorder -> IO ()) + -> Recorder -> IO ()+runAction logger timeoutTime concurrency runStyle action recorder = do+ threadLimit <- BoundedThreadGroup.new concurrency+ recorderRef <- newIORef recorder+ + let takeRecorder = atomicModifyIORef' recorderRef $ \x -> (split x, x)+ actionThread = void + $ BoundedThreadGroup.forkIO threadLimit $ do + rec <- takeRecorder+ handle (\(e :: SomeException) -> do + logWarn logger $ show e+ addEvent recorder $ Error + { resultTime = 0+ , exception = e+ , name = "__UNKNOWN__"+ }+ addEvent rec End+ )+ $ do + action rec+ addEvent rec End+ + + case runStyle of+ RunCount count -> replicateM_ (count * concurrency) actionThread + RunTimed time -> void $ timeout time $ forever actionThread+ + mtimeout <- timeout timeoutTime $ BoundedThreadGroup.wait threadLimit+ case mtimeout of+ Nothing -> void + $ logError logger + $ "Timed out waiting for all "+ ++ "threads to complete"+ Just () -> return ()++------------------------------------------------------------------------------+--- Generic Run Function+-------------------------------------------------------------------------------+runWithNextVar :: Options + -> (NextRef AllStats -> IO ())+ -> (NextRef AllStats -> IO ())+ -> (Recorder -> IO ())+ -> IO ()+runWithNextVar (Options {..}) consumer final action = do+ recorder <- newRecorder 100000+ sampler <- newNextRef emptyAllStats+ logger <- newStdErrLogger 100000 logLevel + -- Collect events and + forkIO $ handle (\(e :: SomeException) -> void $ logError logger $ show e) + $ collectEvent logger sampler recorder+ + consumer sampler+ + logDebug logger "Starting Runs"+ runAction logger timeoutTime concurrency runStyle action recorder `finally` + (do logDebug logger "Shutting Down"+ stopRecorder recorder + shutdownLogger 1000000 logger + final sampler+ )+-------------------------------------------------------------------------------+--- Non-interactive Rendering+-------------------------------------------------------------------------------+printLastSamples :: Options -> NextRef AllStats -> IO ()+printLastSamples options sampler = printStats options =<< readLast sampler++runNonInteractive :: Options -> (Recorder -> IO ()) -> IO ()+runNonInteractive options action = do + let shutdown sampler = do+ putStrLn ""+ hFlush stdout+ hSetBuffering stdout (BlockBuffering (Just 100000000)) + printLastSamples options sampler+ hFlush stdout+ for_ (outputFilePath options) $ \filePath ->+ BSL.writeFile filePath . encode =<< readLast sampler++ runWithNextVar options (const $ return ()) shutdown action+-------------------------------------------------------------------------------+--- Interactive Rendering+-------------------------------------------------------------------------------+printLoop :: Options + -> VTY.DisplayContext + -> VTY.Vty + -> NextRef AllStats+ -> IO ()+printLoop options context vty sampler + = fix $ \next -> takeNextRef sampler >>= \case+ Nothing -> return ()+ Just allStats -> do+ updateUI (requestNameColumnSize options) context allStats+ VTY.refresh vty+ next+ +processInputForCtrlC :: TChan VTY.Event -> IO ThreadId+processInputForCtrlC chan = forkIO $ forever $ do+ event <- atomically $ readTChan chan+ case event of+ VTY.EvKey (VTY.KChar 'c') [VTY.MCtrl] -> raiseSignal sigINT+ _ -> return ()++updateUI :: Maybe Int -> VTY.DisplayContext -> AllStats -> IO ()+updateUI nameSize displayContext stats + = VTY.outputPicture displayContext + $ VTY.picForImage + $ VTY.vertCat + $ map (VTY.string VTY.defAttr)+ $ lines + $ pprStats nameSize stats++runInteractive :: Options -> (Recorder -> IO ()) -> IO ()+runInteractive options action = do + vtyConfig <- VTY.standardIOConfig + vty <- VTY.mkVty vtyConfig+ let output = VTY.outputIface vty+ (width, height) <- VTY.displayBounds output+ displayContext <- VTY.displayContext output (width, height)+ inputThread <- processInputForCtrlC $ VTY._eventChannel $ VTY.inputIface vty+ + let shutdown sampler = do+ killThread inputThread+ VTY.shutdown vty+ putStrLn ""+ hSetBuffering stdout (BlockBuffering (Just 100000000)) + printLastSamples options sampler+ hFlush stdout+ for_ (outputFilePath options) $ \filePath ->+ BSL.writeFile filePath . encode =<< readLast sampler++ runWithNextVar options (\sampler -> void + $ forkIO (printLoop options+ displayContext+ vty+ sampler+ )+ ) + shutdown + action+-------------------------------------------------------------------------------+--- Main Entry Point+-------------------------------------------------------------------------------+-- | 'run' is the a lower level entry point, compared to 'defaultMain'. Unlike+-- 'defaultMain' no command line argument parsing is performed. Instead, +-- 'Options' are directly passed in. 'defaultOptions' can be used as a +-- default argument for 'run'. +-- +-- Like 'defaultMain', 'run' creates a 'Recorder' and passes it each+-- benchmark.+run :: Options -> [(String, Recorder -> IO ())] -> IO ()+run options actions = do + hSetBuffering stderr LineBuffering+ + forM_ actions $ \(groupName, action) -> do + when (match options `isInfixOf` groupName) $ do+ putStrLn groupName+ case displayMode options of+ NonInteractive -> runNonInteractive options action+ Interactive -> runInteractive options action
+ src/Wrecker/Statistics.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE RecordWildCards, BangPatterns, LambdaCase, OverloadedStrings #-}+module Wrecker.Statistics where+import qualified Data.HashMap.Strict as H+import Data.HashMap.Strict (HashMap)+import Wrecker.Recorder +import Wrecker.Options+import qualified Text.Tabular.AsciiArt as AsciiArt+import Text.Tabular+import Text.Printf+import System.Console.Ansigraph.Core+import qualified Data.Text as T+-- import Data.Monoid+import qualified Data.Vector.Unboxed as U+import Data.Aeson (object, ToJSON (..), (.=), Value (..))+import Data.List (sortBy)+import Data.Function++data Histogram = Histogram+ deriving (Show, Eq, Ord)+ +data VarianceAndMean = VarianceAndMean+ { var :: {-# UNPACK #-} !Double + , varMeanDiff :: {-# UNPACK #-} !Double + , varMean :: {-# UNPACK #-} !Double+ , varCount :: {-# UNPACK #-} !Double + } deriving (Show, Eq, Ord)++emptyVarianceAndMean :: VarianceAndMean+emptyVarianceAndMean = VarianceAndMean+ { var = 0+ , varMeanDiff = 0+ , varMean = 0+ , varCount = 0+ }++stableVarianceStep :: VarianceAndMean -> Double -> VarianceAndMean+stableVarianceStep VarianceAndMean {..} !newValue = + let !newCount = varCount + 1+ !newMean = varMean + ((newValue - varMean) / newCount)+ !newMeanDiff = varMeanDiff + ((newValue - varMean)*(newValue - newMean))+ in VarianceAndMean (newMeanDiff / newCount) newMeanDiff newMean newCount++insertHist :: Histogram -> Double -> Histogram+insertHist h _ = h++data Statistics = Statistics + { sVarMean :: !VarianceAndMean+ , sMax :: !Double+ , sMin :: !Double+ , sHistogram :: !Histogram+ , sTotal :: !Double+ } deriving (Show, Eq, Ord)++mean :: Statistics -> Double+mean = varMean . sVarMean++variance :: Statistics -> Double+variance = var . sVarMean++statsCount :: Statistics -> Int+statsCount = floor . (+ 0.1) . varCount . sVarMean++emptyStatistics :: Statistics+emptyStatistics = Statistics+ { sVarMean = emptyVarianceAndMean+ , sMax = 0+ , sMin = 1e32 -- i don't know ... maxBound won't work+ , sHistogram = Histogram+ , sTotal = 0+ }++stepStatistics :: Statistics -> Double -> Statistics+stepStatistics stats value = stats + { sVarMean = stableVarianceStep (sVarMean stats) value+ , sMax = max (sMax stats) value+ , sMin = min (sMin stats) value+ , sHistogram = insertHist (sHistogram stats) value + , sTotal = sTotal stats + value+ }++data ResultStatistics = ResultStatistics + { rs2xx :: !Statistics+ , rs4xx :: !Statistics+ , rs5xx :: !Statistics+ , rsFailed :: !Statistics+ , rsRollup :: !Statistics + } deriving (Show, Eq, Ord)+ +emptyResultStatistics :: ResultStatistics +emptyResultStatistics = ResultStatistics+ { rs2xx = emptyStatistics+ , rs4xx = emptyStatistics+ , rs5xx = emptyStatistics+ , rsFailed = emptyStatistics+ , rsRollup = emptyStatistics+ }+ +stepResultStatistics :: ResultStatistics -> RunResult -> ResultStatistics+stepResultStatistics stats = \case+ Success { .. } -> stats { rs2xx = stepStatistics (rs2xx stats) + resultTime + , rsRollup = stepStatistics (rsRollup stats) + resultTime + }+ ErrorStatus { .. } + | is4xx errorCode -> stats { rs4xx = stepStatistics (rs4xx stats) + resultTime + , rsRollup = stepStatistics (rsRollup stats) + resultTime + }+ | otherwise -> stats { rs5xx = stepStatistics (rs5xx stats) + resultTime+ , rsRollup = stepStatistics (rsRollup stats) + resultTime + }+ Error { .. } -> stats { rsFailed = stepStatistics (rsFailed stats) + resultTime+ , rsRollup = stepStatistics (rsRollup stats)+ resultTime+ }+ End -> stats++count2xx :: ResultStatistics -> Int+count2xx = statsCount . rs2xx++count4xx :: ResultStatistics -> Int+count4xx = statsCount . rs4xx++count5xx :: ResultStatistics -> Int+count5xx = statsCount . rs5xx++countFailed :: ResultStatistics -> Int+countFailed = statsCount . rsFailed++errorRate :: ResultStatistics -> Double+errorRate x+ = fromIntegral (count4xx x + count5xx x + countFailed x) + / fromIntegral (count2xx x + count4xx x + count5xx x + countFailed x)++isEntirelySuccessful :: ResultStatistics -> Bool+isEntirelySuccessful x = (count4xx x + count5xx x + countFailed x) == 0++successfulToResult :: Statistics -> ResultStatistics+successfulToResult x = emptyResultStatistics { rs2xx = x }+ +data AllStats = AllStats + { aRollup :: !ResultStatistics+ , aCompleteRuns :: !ResultStatistics+ , aRuns :: !(HashMap Int ResultStatistics)+ , aPerUrl :: !(HashMap String ResultStatistics)+ } deriving (Show, Eq)++emptyAllStats :: AllStats+emptyAllStats = AllStats+ { aRollup = emptyResultStatistics+ , aCompleteRuns = emptyResultStatistics+ , aRuns = H.empty+ , aPerUrl = H.empty+ }++is4xx :: Int -> Bool+is4xx x = x > 399 && x < 500 ++stepAllStats :: AllStats -> Int -> String -> RunResult -> AllStats+stepAllStats allStats index key result = + case result of + End -> let mRunStats = H.lookup index $ aRuns allStats+ in case mRunStats of+ Nothing -> allStats+ Just stats + | errorRate stats == 0 -> + let runTime = sTotal $ rs2xx stats+ in allStats { aCompleteRuns = stepResultStatistics + (aCompleteRuns allStats) + (Success runTime "") + , aRuns = H.delete index + $ aRuns allStats+ }+ | otherwise -> allStats { aRuns = H.delete index + $ aRuns allStats+ }+ _ -> allStats + { aRollup = stepResultStatistics (aRollup allStats) result+ , aRuns = H.insertWith (\_ x -> stepResultStatistics x result) + index + (stepResultStatistics + emptyResultStatistics + result+ )+ $ aRuns allStats + , aPerUrl = H.insertWith (\_ x -> stepResultStatistics x result) + key + (stepResultStatistics + emptyResultStatistics + result+ )+ $ aPerUrl allStats+ }+-------------------------------------------------------------------------------+-- Rendering+-------------------------------------------------------------------------------+renderHistogram :: U.Vector Int -> String+renderHistogram bins = renderPV $ U.toList powers where+ total = fromIntegral $ U.sum bins+ powers = U.map (\x -> fromIntegral x / total) bins++statToRow :: ResultStatistics -> [String]+statToRow x + = [ printf "%.4f" $ mean $ rs2xx x+ , printf "%.4f" $ variance $ rs2xx x+ , printf "%.4f" $ sMax $ rs2xx x+ , printf "%.4f" $ sMin $ rs2xx x+ , show $ count2xx x+ , show $ count4xx x+ , show $ count5xx x+ , show $ countFailed x+ , printf "%.4f" $ errorRate x+ , renderHistogram $ mempty+ ]++pprStats :: Maybe Int -> AllStats -> String+pprStats nameSize stats = AsciiArt.render id id id $ statsTable nameSize stats++statsTable :: Maybe Int -> AllStats -> Table String String String+statsTable nameSize AllStats {..} + = let sortedPerUrl = sortBy (compare `on` fst) $ H.toList aPerUrl+ in Table (Group SingleLine + $ map (Header . maybe id take nameSize . fst) sortedPerUrl+ )+ (Group SingleLine [ Header "mean"+ , Header "variance"+ , Header "max"+ , Header "min"+ , Header "Successful Count"+ , Header "4xx Count"+ , Header "5xx Count"+ , Header "Failure Count"+ , Header "Error Rate"+ , Header "Histogram"+ ]+ )+ (map (statToRow . snd) sortedPerUrl)+ +====+ SemiTable (Group SingleLine [Header "All"]) (statToRow aRollup)+ +====+ SemiTable (Group SingleLine [Header "Successful Runs"]) + (statToRow aCompleteRuns)+ +printStats :: Options -> AllStats -> IO ()+printStats options sampler + = putStrLn $ pprStats (requestNameColumnSize options) sampler+------------------------------------------------------------------------------+-- JSON Serialization+------------------------------------------------------------------------------+instance ToJSON Statistics where+ toJSON x = object + [ "mean" .= mean x+ , "variance" .= variance x+ , "max" .= sMax x+ , "min" .= sMin x+ , "total" .= sTotal x+ , "count" .= statsCount x+ ]++instance ToJSON ResultStatistics where+ toJSON ResultStatistics {..} = object + [ "2xx" .= rs2xx+ , "4xx" .= rs4xx+ , "5xx" .= rs5xx+ , "failed" .= rsFailed+ , "rollup" .= rsRollup+ ]++instance ToJSON AllStats where+ toJSON AllStats {..} = object + [ "per-request" .= Object + ( H.fromList + $ map (\(k, v) -> (T.pack k, toJSON v))+ $ H.toList aPerUrl+ )+ , "runs" .= aCompleteRuns+ , "rollup" .= aRollup+ ]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ wrecker.cabal view
@@ -0,0 +1,77 @@+name: wrecker+version: 0.1.0.0+synopsis: An HTTP Performance Benchmarker+description: + 'wrecker' is a library for creating HTTP benchmarks. It is designed for+ benchmarking a series of HTTP request were the output of previous requests+ are used as inputs to the next request. This is useful for complex API + profiling situations.+ + + 'wrecker' does not provide any mechanism for making HTTP calls. It works+ with any HTTP client that produces a 'HttpException' during failure (so + http-client and wreq will work out of the box).+ + + See the documentation for examples of how to use 'wrecker' with + benchmarking scripts.+homepage: https://github.com/skedgeme/wrecker#readme+license: BSD3+license-file: LICENSE+author: Jonathan Fischoff+maintainer: jonathangfischoff@gmail.com+copyright: 2016 skedge.me+category: Web+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Wrecker+ , Wrecker.Recorder+ , Wrecker.Runner+ , Wrecker.Main+ , Wrecker.Options+ , Wrecker.Statistics+ , Wrecker.Logger+ build-depends: base >= 4.7 && < 5+ , stm+ , stm-chans+ , aeson-qq+ , statistics+ , vector+ , bytestring+ , aeson+ , unix+ , ansigraph+ , time+ , clock+ , text+ , http-client >= 0.5 && < 0.6+ , http-types+ , tabular+ , deepseq+ , unordered-containers+ , threads+ , vty+ , threads-extras+ , clock-extras+ , optparse-applicative+ , stm-chans+ , ansi-terminal+ , unagi-chan+ , next-ref+ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-unused-do-bind++test-suite wrecker-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , wrecker+ , hspec+ , hspec-discovery+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010