wrecker 0.1.1.0 → 0.1.1.1
raw patch · 8 files changed
+227/−127 lines, 8 files
Files
- src/Wrecker.hs +6/−6
- src/Wrecker/Logger.hs +24/−16
- src/Wrecker/Main.hs +27/−0
- src/Wrecker/Options.hs +36/−0
- src/Wrecker/Recorder.hs +34/−34
- src/Wrecker/Runner.hs +15/−8
- src/Wrecker/Statistics.hs +84/−62
- wrecker.cabal +1/−1
src/Wrecker.hs view
@@ -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 (..)
src/Wrecker/Logger.hs view
@@ -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-
src/Wrecker/Main.hs view
@@ -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
src/Wrecker/Options.hs view
@@ -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)
src/Wrecker/Recorder.hs view
@@ -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
src/Wrecker/Runner.hs view
@@ -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
src/Wrecker/Statistics.hs view
@@ -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 )
wrecker.cabal view
@@ -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