diff --git a/src/Wrecker.hs b/src/Wrecker.hs --- a/src/Wrecker.hs +++ b/src/Wrecker.hs @@ -1,17 +1,17 @@ {-| '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. + 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 + 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 + + See the documentation for examples of how to use 'wrecker' with benchmarking scripts. -} module Wrecker ( Recorder - , defaultMain + , defaultMain , record , run , Options (..) diff --git a/src/Wrecker/Logger.hs b/src/Wrecker/Logger.hs --- a/src/Wrecker/Logger.hs +++ b/src/Wrecker/Logger.hs @@ -11,31 +11,40 @@ data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError deriving (Show, Eq, Ord, Read) -data Logger = Logger +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 +{- | Create a 'Logger' with the given 'Handle' and max buffer size. + The logger will drop messages if it is unable to keep up and it's message buffer + goes over the max size. +-} +newLogger :: Handle + -- ^ The 'Handle' to log to. + -> Int + -- ^ Max buffer size + -> LogLevel + -- ^ Minimum log level to log. + -> IO Logger +newLogger handle maxSize currentLevel = do (inChan, outChan) <- U.newChan maxSize - lock <- newEmptyMVar + lock <- newEmptyMVar thread <- readLoop handle outChan lock - + let wait = takeMVar lock - + return Logger {..} +-- | Create a logger using stderr. This is the typical way a logger is created. 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 +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 @@ -48,17 +57,17 @@ -- True if the write was successful or False otherwise writeLogger :: Logger -> LogLevel -> String -> IO Bool -writeLogger Logger {..} messageLevel msg = +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 +shutdownLogger waitTime logger@(Logger {..}) = do U.writeChan inChan Nothing - mtimedOut <- timeout waitTime wait + mtimedOut <- timeout waitTime wait case mtimedOut of Nothing -> forceShutdownLogger logger Just () -> return () @@ -77,4 +86,3 @@ logError :: Logger -> String -> IO Bool logError logger = writeLogger logger LevelError - diff --git a/src/Wrecker/Main.hs b/src/Wrecker/Main.hs --- a/src/Wrecker/Main.hs +++ b/src/Wrecker/Main.hs @@ -16,6 +16,33 @@ > [ ("loginReshare", loginReshare) > , ("purchase" , purchase ) > ] + +To see the options defaultMain can parse call `--help` + +> $ wrecker-based-app --help +> +> wrecker - HTTP stress tester and benchmarker +> +> Usage: example [--concurrency ARG] [--bin-count ARG] ([--run-count ARG] | +> [--run-timed ARG]) [--timeout-time ARG] [--display-mode ARG] +> [--log-level ARG] [--match ARG] [--request-name-size ARG] +> [--output-path ARG] [--silent] +> Welcome to wrecker +> +> Available options: +> -h,--help Show this help text +> --concurrency ARG Number of threads for concurrent requests +> --bin-count ARG Number of bins for latency histogram +> --run-count ARG number of times to repeat +> --run-timed ARG number of seconds to repeat +> --timeout-time ARG How long to wait for all requests to finish +> --display-mode ARG Display results interactively +> --log-level ARG Display results interactively +> --match ARG Only run tests that match the glob +> --request-name-size ARG Request name size for the terminal display +> --output-path ARG Save a JSON file of the the statistics to given path +> --silent Disable all output + -} defaultMain :: [(String, Recorder -> IO ())] -> IO () defaultMain actions = void . flip run actions =<< runParser diff --git a/src/Wrecker/Options.hs b/src/Wrecker/Options.hs --- a/src/Wrecker/Options.hs +++ b/src/Wrecker/Options.hs @@ -6,9 +6,17 @@ import Wrecker.Logger import Data.Monoid +{- | There are two typical ways to invoke 'wrecker'. 'RunCount' will execute + each a script 'n' times, where 'n' is the parameter for 'RunCount'. + Alternatively, 'wrecker' can run for specified time with 'RunTimed'. +-} data RunType = RunCount Int | RunTimed Int deriving (Show, Eq) +{- | 'DisplayMode' controls how results are displayed in the console. The +default is 'NonInterative' which returns the final results at the end of the +program. 'Interactive' will show partial results as the program updates. +-} data DisplayMode = Interactive | NonInteractive deriving (Show, Eq, Read) @@ -171,6 +179,34 @@ <> help "Disable all output" ) +{- | Run the command line parse and return the 'Options' + +'runParser' can parse the following options + +> $ wrecker-based-app --help +> +> wrecker - HTTP stress tester and benchmarker +> +> Usage: example [--concurrency ARG] [--bin-count ARG] ([--run-count ARG] | +> [--run-timed ARG]) [--timeout-time ARG] [--display-mode ARG] +> [--log-level ARG] [--match ARG] [--request-name-size ARG] +> [--output-path ARG] [--silent] +> Welcome to wrecker +> +> Available options: +> -h,--help Show this help text +> --concurrency ARG Number of threads for concurrent requests +> --bin-count ARG Number of bins for latency histogram +> --run-count ARG number of times to repeat +> --run-timed ARG number of seconds to repeat +> --timeout-time ARG How long to wait for all requests to finish +> --display-mode ARG Display results interactively +> --log-level ARG Display results interactively +> --match ARG Only run tests that match the glob +> --request-name-size ARG Request name size for the terminal display +> --output-path ARG Save a JSON file of the the statistics to given path +> --silent Disable all output +-} runParser :: IO Options runParser = do let opts = info (helper <*> pPartialOptions) diff --git a/src/Wrecker/Recorder.hs b/src/Wrecker/Recorder.hs --- a/src/Wrecker/Recorder.hs +++ b/src/Wrecker/Recorder.hs @@ -10,11 +10,11 @@ import Control.Exception import System.Clock.TimeIt -data RunResult - = Success { resultTime :: !Double +data RunResult + = Success { resultTime :: !Double , name :: !String } - | ErrorStatus { resultTime :: !Double + | ErrorStatus { resultTime :: !Double , errorCode :: !Int , name :: !String } @@ -22,94 +22,94 @@ , exception :: !SomeException , name :: !String } - | End + | End deriving (Show) -data Event = Event +data Event = Event { eRunIndex :: !Int - , result :: !RunResult + , eResult :: !RunResult } deriving (Show) --- | An opaque type for recording actions for profiling. +-- | 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 +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 :: 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 = +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 +{- | '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 -> -> Object user <- rc "login" +> +> Object user <- rc "login" > $ asJSON -> =<< ( post session "https://somesite.com/login" +> =<< ( post session "https://somesite.com/login" > $ object [ "email" .= "example@example.com" > , "password" .= "12345678" > ] > ) -> let Just feedUrl = H.lookup "feed" user -> itemRef : _ <- rc "get feed" +> let Just feedUrl = H.lookup "feed" user +> itemRef : _ <- rc "get feed" > $ asJSON -> =<< ( post session feedUrl +> =<< ( post session feedUrl > $ object [ "email" .= "example@example.com" > , "password" .= "12345678" > ] > ) -> rc "reshare" $ post session "https://somesite.com/share" +> rc "reshare" $ post session "https://somesite.com/share" > $ object [ "type" : "reshare" > , "ref" : itemRef > ] - In this case the 'loginReshare' script would record three actions: "login", + 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 + '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. + 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 + 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 + case e of #if MIN_VERSION_http_client(0,5,0) HTTP.HttpExceptionRequest _ (HTTP.StatusCodeException resp _) -> do let code = HTTP.statusCode $ HTTP.responseStatus resp @@ -117,20 +117,20 @@ HTTP.StatusCodeException stat _ _ -> do let code = HTTP.statusCode stat #endif - + addEvent recorder $ ErrorStatus - { resultTime = diffSeconds endTime startTime - , errorCode = code + { resultTime = diffSeconds endTime startTime + , errorCode = code , name = key } - - _ -> addEvent recorder $ Error + + _ -> 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 --- a/src/Wrecker/Runner.hs +++ b/src/Wrecker/Runner.hs @@ -27,28 +27,35 @@ import qualified Control.Immortal as Immortal -- TODO configure whether errors are used in times or not +{- | Typically 'wrecker' will control benchmarking actions. Howeve,r in some situations + a benchmark might require more control. + + To facilitate more complex scenarios 'wrecker' provide 'newStandaloneRecorder' + which provides a 'Recorder' and 'Thread' that processes the events, and a + reference to the current stats. +-} newStandaloneRecorder :: IO (NextRef AllStats, Immortal.Thread, Recorder) newStandaloneRecorder = do recorder <- newRecorder 10000 - logger <- newStdErrLogger 1000 LevelError + logger <- newStdErrLogger 1000 LevelError (ref, thread) <- sinkRecorder logger recorder return (ref, thread, recorder) sinkRecorder :: Logger -> Recorder -> IO (NextRef AllStats, Immortal.Thread) -sinkRecorder logger recorder = do +sinkRecorder logger recorder = do ref <- newNextRef emptyAllStats - - immortal <- Immortal.createWithLabel "collectEvent" + + immortal <- Immortal.createWithLabel "collectEvent" $ \_ -> collectEvent logger ref recorder - + return (ref, immortal) updateSampler :: NextRef AllStats -> Event -> IO AllStats updateSampler !ref !event = modifyNextRef ref $ \x -> let !new = stepAllStats x (eRunIndex event) - (name $ result event) - (result event) + (name $ eResult event) + (eResult event) in (new, new) collectEvent :: Logger -> NextRef AllStats -> Recorder -> IO () @@ -220,7 +227,7 @@ fmap H.fromList . forM actions $ \(groupName, action) -> do if (match options `isInfixOf` groupName) then do putStrLn groupName - (groupName, ) <$> case displayMode options of + (groupName, ) <$> case displayMode options of NonInteractive -> runNonInteractive options action Interactive -> runInteractive options action else diff --git a/src/Wrecker/Statistics.hs b/src/Wrecker/Statistics.hs --- a/src/Wrecker/Statistics.hs +++ b/src/Wrecker/Statistics.hs @@ -2,14 +2,13 @@ module Wrecker.Statistics where import qualified Data.HashMap.Strict as H import Data.HashMap.Strict (HashMap) -import Wrecker.Recorder +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) @@ -17,12 +16,12 @@ data Histogram = Histogram deriving (Show, Eq, Ord) - + data VarianceAndMean = VarianceAndMean - { var :: {-# UNPACK #-} !Double - , varMeanDiff :: {-# UNPACK #-} !Double + { var :: {-# UNPACK #-} !Double + , varMeanDiff :: {-# UNPACK #-} !Double , varMean :: {-# UNPACK #-} !Double - , varCount :: {-# UNPACK #-} !Double + , varCount :: {-# UNPACK #-} !Double } deriving (Show, Eq, Ord) emptyVarianceAndMean :: VarianceAndMean @@ -34,7 +33,7 @@ } stableVarianceStep :: VarianceAndMean -> Double -> VarianceAndMean -stableVarianceStep VarianceAndMean {..} !newValue = +stableVarianceStep VarianceAndMean {..} !newValue = let !newCount = varCount + 1 !newMean = varMean + ((newValue - varMean) / newCount) !newMeanDiff = varMeanDiff + ((newValue - varMean)*(newValue - newMean)) @@ -43,17 +42,27 @@ insertHist :: Histogram -> Double -> Histogram insertHist h _ = h -data Statistics = Statistics +-- | These are the +data Statistics = Statistics { sVarMean :: !VarianceAndMean + -- ^ Combined variance and mean. This type contains information useful for + -- incremental computation of the variance and mean. To get the individual + -- components use 'variance' and 'mean'. , sMax :: !Double + -- ^ The maximum time , sMin :: !Double + -- ^ The maximum time , sHistogram :: !Histogram + -- ^ A histogram of times , sTotal :: !Double + -- ^ The total time } deriving (Show, Eq, Ord) +-- | Extract the mean mean :: Statistics -> Double mean = varMean . sVarMean +-- | Extract the variance variance :: Statistics -> Double variance = var . sVarMean @@ -70,23 +79,27 @@ } stepStatistics :: Statistics -> Double -> Statistics -stepStatistics stats value = stats +stepStatistics stats value = stats { sVarMean = stableVarianceStep (sVarMean stats) value , sMax = max (sMax stats) value , sMin = min (sMin stats) value - , sHistogram = insertHist (sHistogram stats) value + , sHistogram = insertHist (sHistogram stats) value , sTotal = sTotal stats + value } -data ResultStatistics = ResultStatistics +{- | This type includes statistics for all of the result values we can detect. + This type is used by AllStats to compute per key (URL) statistics among + other uses. +-} +data ResultStatistics = ResultStatistics { rs2xx :: !Statistics , rs4xx :: !Statistics , rs5xx :: !Statistics , rsFailed :: !Statistics - , rsRollup :: !Statistics + , rsRollup :: !Statistics } deriving (Show, Eq, Ord) - -emptyResultStatistics :: ResultStatistics + +emptyResultStatistics :: ResultStatistics emptyResultStatistics = ResultStatistics { rs2xx = emptyStatistics , rs4xx = emptyStatistics @@ -94,26 +107,26 @@ , rsFailed = emptyStatistics , rsRollup = emptyStatistics } - + stepResultStatistics :: ResultStatistics -> RunResult -> ResultStatistics stepResultStatistics stats = \case - Success { .. } -> stats { rs2xx = stepStatistics (rs2xx stats) - resultTime - , rsRollup = stepStatistics (rsRollup stats) - resultTime + 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 + ErrorStatus { .. } + | is4xx errorCode -> stats { rs4xx = stepStatistics (rs4xx stats) + resultTime + , rsRollup = stepStatistics (rsRollup stats) + resultTime } - | otherwise -> stats { rs5xx = stepStatistics (rs5xx stats) + | otherwise -> stats { rs5xx = stepStatistics (rs5xx stats) resultTime - , rsRollup = stepStatistics (rsRollup stats) - resultTime + , rsRollup = stepStatistics (rsRollup stats) + resultTime } - Error { .. } -> stats { rsFailed = stepStatistics (rsFailed stats) + Error { .. } -> stats { rsFailed = stepStatistics (rsFailed stats) resultTime , rsRollup = stepStatistics (rsRollup stats) resultTime @@ -134,7 +147,7 @@ errorRate :: ResultStatistics -> Double errorRate x - = fromIntegral (count4xx x + count5xx x + countFailed x) + = fromIntegral (count4xx x + count5xx x + countFailed x) / fromIntegral (count2xx x + count4xx x + count5xx x + countFailed x) isEntirelySuccessful :: ResultStatistics -> Bool @@ -142,12 +155,21 @@ successfulToResult :: Statistics -> ResultStatistics successfulToResult x = emptyResultStatistics { rs2xx = x } - -data AllStats = AllStats + +{- | AllStats has all of the ... stats. This type stores all of the information + 'wrecker' uses to display metrics to the user. +-} +data AllStats = AllStats { aRollup :: !ResultStatistics + -- ^ The "total" stats. This computes things like total 2xx and average time + -- Across all requests. , aCompleteRuns :: !ResultStatistics + -- ^ This contains statistic for actions that completed entirely successfully. + -- Useful for knowing if a complex action is under some desired total time. , aRuns :: !(HashMap Int ResultStatistics) + -- ^ This is an intermediate holding spot for scripts that are still executing. , aPerUrl :: !(HashMap String ResultStatistics) + -- ^ This is the per key (URL) statistics. } deriving (Show, Eq) emptyAllStats :: AllStats @@ -159,39 +181,39 @@ } is4xx :: Int -> Bool -is4xx x = x > 399 && x < 500 +is4xx x = x > 399 && x < 500 stepAllStats :: AllStats -> Int -> String -> RunResult -> AllStats -stepAllStats allStats index key result = - case result of +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 -> + Just stats + | errorRate stats == 0 -> let runTime = sTotal $ rs2xx stats - in allStats { aCompleteRuns = stepResultStatistics - (aCompleteRuns allStats) - (Success runTime "") - , aRuns = H.delete index + in allStats { aCompleteRuns = stepResultStatistics + (aCompleteRuns allStats) + (Success runTime "") + , aRuns = H.delete index $ aRuns allStats } - | otherwise -> allStats { aRuns = H.delete index + | otherwise -> allStats { aRuns = H.delete index $ aRuns allStats } - _ -> allStats + _ -> allStats { aRollup = stepResultStatistics (aRollup allStats) result - , aRuns = H.insertWith (\_ x -> stepResultStatistics x result) - index - (stepResultStatistics - emptyResultStatistics + , aRuns = H.insertWith (\_ x -> stepResultStatistics x result) + index + (stepResultStatistics + emptyResultStatistics result ) - $ aRuns allStats - , aPerUrl = H.insertWith (\_ x -> stepResultStatistics x result) - key - (stepResultStatistics - emptyResultStatistics + $ aRuns allStats + , aPerUrl = H.insertWith (\_ x -> stepResultStatistics x result) + key + (stepResultStatistics + emptyResultStatistics result ) $ aPerUrl allStats @@ -205,7 +227,7 @@ powers = U.map (\x -> fromIntegral x / total) bins statToRow :: ResultStatistics -> [String] -statToRow x +statToRow x = [ printf "%.4f" $ mean $ rs2xx x , printf "%.8f" $ variance $ rs2xx x , printf "%.4f" $ sMax $ rs2xx x @@ -222,9 +244,9 @@ pprStats nameSize stats = AsciiArt.render id id id $ statsTable nameSize stats statsTable :: Maybe Int -> AllStats -> Table String String String -statsTable nameSize AllStats {..} +statsTable nameSize AllStats {..} = let sortedPerUrl = sortBy (compare `on` fst) $ H.toList aPerUrl - in Table (Group SingleLine + in Table (Group SingleLine $ map (Header . maybe id take nameSize . fst) sortedPerUrl ) (Group SingleLine [ Header "mean" @@ -241,17 +263,17 @@ ) (map (statToRow . snd) sortedPerUrl) +====+ SemiTable (Group SingleLine [Header "All"]) (statToRow aRollup) - +====+ SemiTable (Group SingleLine [Header "Successful Runs"]) + +====+ SemiTable (Group SingleLine [Header "Successful Runs"]) (statToRow aCompleteRuns) - + printStats :: Options -> AllStats -> IO () -printStats options sampler +printStats options sampler = putStrLn $ pprStats (requestNameColumnSize options) sampler ------------------------------------------------------------------------------ -- JSON Serialization ------------------------------------------------------------------------------ instance ToJSON Statistics where - toJSON x = object + toJSON x = object [ "mean" .= mean x , "variance" .= variance x , "max" .= sMax x @@ -261,7 +283,7 @@ ] instance ToJSON ResultStatistics where - toJSON ResultStatistics {..} = object + toJSON ResultStatistics {..} = object [ "2xx" .= rs2xx , "4xx" .= rs4xx , "5xx" .= rs5xx @@ -270,9 +292,9 @@ ] instance ToJSON AllStats where - toJSON AllStats {..} = object - [ "per-request" .= Object - ( H.fromList + toJSON AllStats {..} = object + [ "per-request" .= Object + ( H.fromList $ map (\(k, v) -> (T.pack k, toJSON v)) $ H.toList aPerUrl ) diff --git a/wrecker.cabal b/wrecker.cabal --- a/wrecker.cabal +++ b/wrecker.cabal @@ -1,5 +1,5 @@ name: wrecker -version: 0.1.1.0 +version: 0.1.1.1 synopsis: A HTTP Performance Benchmarker description: 'wrecker' is a library for creating HTTP benchmarks. It is designed for