diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Wrecker.hs b/src/Wrecker.hs new file mode 100644 --- /dev/null +++ b/src/Wrecker.hs @@ -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 diff --git a/src/Wrecker/Logger.hs b/src/Wrecker/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Wrecker/Logger.hs @@ -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 + diff --git a/src/Wrecker/Main.hs b/src/Wrecker/Main.hs new file mode 100644 --- /dev/null +++ b/src/Wrecker/Main.hs @@ -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 diff --git a/src/Wrecker/Options.hs b/src/Wrecker/Options.hs new file mode 100644 --- /dev/null +++ b/src/Wrecker/Options.hs @@ -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 + diff --git a/src/Wrecker/Recorder.hs b/src/Wrecker/Recorder.hs new file mode 100644 --- /dev/null +++ b/src/Wrecker/Recorder.hs @@ -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 diff --git a/src/Wrecker/Runner.hs b/src/Wrecker/Runner.hs new file mode 100644 --- /dev/null +++ b/src/Wrecker/Runner.hs @@ -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 diff --git a/src/Wrecker/Statistics.hs b/src/Wrecker/Statistics.hs new file mode 100644 --- /dev/null +++ b/src/Wrecker/Statistics.hs @@ -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 + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/wrecker.cabal b/wrecker.cabal new file mode 100644 --- /dev/null +++ b/wrecker.cabal @@ -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