wrecker 1.2.4.0 → 1.3.0.0

raw patch · 6 files changed

+149/−135 lines, 6 filesdep +fast-loggerdep −unagi-chandep ~tdigestPVP ok

version bump matches the API change (PVP)

Dependencies added: fast-logger

Dependencies removed: unagi-chan

Dependency ranges changed: tdigest

API changes (from Hackage documentation)

Files

• src/Network/Wreq/Wrecker.hs +27/−3
• src/Wrecker/Logger.hs +71/−64
• src/Wrecker/Main.hs +23/−21
• src/Wrecker/Options.hs +14/−32
• src/Wrecker/Runner.hs +11/−12
• wrecker.cabal +3/−3

@@ -16,6 +16,12 @@     , withWreq     , withWreqNoCookies     , withWreqSettings+    -- * Logging functions+    , logDebug+    , logInfo+    , logWarn+    , logError+    , Logger.Logger     -- * HTTP Methods     , get     , post@@ -53,7 +59,9 @@ import qualified Network.Wreq as Wreq import qualified Network.Wreq.Session as Session import qualified Network.Wreq.Types as Wreq+import System.Log.FastLogger (ToLogStr) import Wrecker+import qualified Wrecker.Logger as Logger  {-| An opaque type created by 'withWreq', 'withWreqNoCookies',     or 'withWreqSettings'. All HTTP calls require a 'Session'.@@ -64,6 +72,8 @@     , sRecord :: forall a. Recorder -> String -> IO a -> IO a       -- ^ A custom function to record the time of of executing the IO action       --   By default, it will use 'Wrecker.Recorder.record'+    , sLogger :: Logger.Logger+      -- ^ A custom logger that can be used for logging messages from the test functions     }  {- | Create 'ManagerSettings' with no timeout using a shared TLS@@ -84,6 +94,7 @@ withWreq f env =     withWreqSettings         (recorder env)+        (logger env)         (Just (HTTP.createCookieJar []))         (defaultManagerSettings (context env))         f@@ -95,7 +106,7 @@ -- which typically do not use cookies. withWreqNoCookies :: (Session -> IO a) -> Environment -> IO a withWreqNoCookies f env =-    withWreqSettings (recorder env) Nothing (defaultManagerSettings (context env)) f+    withWreqSettings (recorder env) (logger env) Nothing (defaultManagerSettings (context env)) f  -- | Replaces the record function of the Session with the provided one. --@@ -107,15 +118,16 @@ -- | Create a session, using the given cookie jar and manager settings. withWreqSettings ::        Recorder+    -> Logger.Logger     -> Maybe HTTP.CookieJar                  -- ^ If 'Nothing' is specified, no cookie management                  -- will be performed.     -> HTTP.ManagerSettings     -> (Session -> IO a)     -> IO a-withWreqSettings recorder cookie settings f = do+withWreqSettings recorder logFunc cookie settings f = do     session <- Session.newSessionControl cookie settings-    f (Session session recorder record)+    f (Session session recorder record logFunc)  -- this records things. It's not ideal, but an more acurate -- implementation is harder. Pull requests welcome.@@ -216,6 +228,18 @@     -> IO (HTTP.Response b) putJSONWith opts =     withRecorder1 (\sess url body -> Session.putWith opts sess url body >>= fromJSON "PUT" url)++logDebug :: ToLogStr msg => Session -> msg -> IO ()+logDebug Session {..} = Logger.logDebug sLogger++logInfo :: ToLogStr msg => Session -> msg -> IO ()+logInfo Session {..} = Logger.logDebug sLogger++logWarn :: ToLogStr msg => Session -> msg -> IO ()+logWarn Session {..} = Logger.logDebug sLogger++logError :: ToLogStr msg => Session -> msg -> IO ()+logError Session {..} = Logger.logDebug sLogger  -- | 'Session'-specific version of 'Network.Wreq.deleteWith' that expects a JSON response. deleteJSONWith :: FromJSON a => Wreq.Options -> Session -> String -> IO (HTTP.Response a)

@@ -1,13 +1,13 @@ {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}  module Wrecker.Logger where -import Control.Concurrent-import qualified Control.Concurrent.Chan.Unagi.Bounded as U-import Data.Foldable (traverse_)-import Data.Function-import System.IO-import System.Timeout+import Control.Monad (when)+import Data.Aeson+import Data.Monoid ((<>))+import qualified Data.Text.Encoding as TE+import System.Log.FastLogger  data LogLevel     = LevelDebug@@ -16,74 +16,81 @@     | LevelError     deriving (Show, Eq, Ord, Read) +data LogFormat+    = PlainText+    | Json+    deriving (Eq, Show, Read)+ data Logger = Logger-    { thread :: ThreadId-    , inChan :: U.InChan (Maybe String)-    , wait :: IO ()-    , currentLevel :: LogLevel+    { currentLevel :: LogLevel+    , logFormat :: LogFormat+    , logFunc :: FastLogger+    , cleanup :: IO ()+    , timeFormatter :: IO FormattedTime     } -{- | 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-    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-    -- Block on the next elemen-    -- If it "Just" print it and loop-    -- Otherwise we are not with the loop-         -> do-            U.readChan chan >>=-                traverse_-                    (\msg -> do-                         hPutStrLn handle msg-                         next)-        putMVar lock ()+newStdErrLogger :: LogLevel -> LogFormat -> IO Logger+newStdErrLogger level format = do+    let timeFormat =+            if format == PlainText+                then "%FT%T"+                else "%s"+    timeCache <- newTimeCache timeFormat+    (logger, clean) <- newFastLogger (LogStderr defaultBufSize)+    return+        Logger+        { currentLevel = level+        , logFormat = format+        , logFunc = logger+        , cleanup = clean+        , timeFormatter = timeCache+        }  -- True if the write was successful or False otherwise-writeLogger :: Logger -> LogLevel -> String -> IO Bool+writeLogger :: Logger -> LogLevel -> LogStr -> IO () writeLogger Logger {..} messageLevel msg =-    if (currentLevel <= messageLevel)-        then U.tryWriteChan inChan $ Just msg-        else return False+    when (currentLevel <= messageLevel) $ do+        t <- timeFormatter+        logFunc (formatMsg logFormat messageLevel t msg) -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 ()+formatMsg :: LogFormat -> LogLevel -> FormattedTime -> LogStr -> LogStr+formatMsg PlainText level prettyTime msg =+    toLogStr ("[" <> prettyTime <> "] - ") <> formatLevel level <> msg <> "\n"+formatMsg Json level prettyTime msg = toLogStr (encode jsonMsg) <> "\n"+  where+    jsonMsg =+        object+            [ "level" .= toLevelCode level+            , "timestamp" .= TE.decodeUtf8 prettyTime+            , "full_message" .= TE.decodeUtf8 (fromLogStr msg)+            ] -forceShutdownLogger :: Logger -> IO ()-forceShutdownLogger Logger {..} = killThread thread+formatLevel :: LogLevel -> LogStr+formatLevel level = "[" <> lvl level <> "] - "+  where+    lvl LevelDebug = "DBUG"+    lvl LevelInfo = "INFO"+    lvl LevelWarn = "WARN"+    lvl LevelError = "ERRO" -logDebug :: Logger -> String -> IO Bool-logDebug logger = writeLogger logger LevelDebug+toLevelCode :: LogLevel -> Int+toLevelCode LevelDebug = 7+toLevelCode LevelInfo = 6+toLevelCode LevelWarn = 4+toLevelCode LevelError = 3 -logInfo :: Logger -> String -> IO Bool-logInfo logger = writeLogger logger LevelInfo+shutdownLogger :: Logger -> IO ()+shutdownLogger Logger {..} = cleanup -logWarn :: Logger -> String -> IO Bool-logWarn logger = writeLogger logger LevelWarn+logDebug :: ToLogStr msg => Logger -> msg -> IO ()+logDebug logger = writeLogger logger LevelDebug . toLogStr -logError :: Logger -> String -> IO Bool-logError logger = writeLogger logger LevelError+logInfo :: ToLogStr msg => Logger -> msg -> IO ()+logInfo logger = writeLogger logger LevelInfo . toLogStr++logWarn :: ToLogStr msg => Logger -> msg -> IO ()+logWarn logger = writeLogger logger LevelWarn . toLogStr++logError :: ToLogStr msg => Logger -> msg -> IO ()+logError logger = writeLogger logger LevelError . toLogStr

@@ -4,8 +4,7 @@  import Control.Monad (void) import Wrecker.Options (runParser)-import Wrecker.Runner (run)-import Wrecker.Runner (Environment)+import Wrecker.Runner (Environment, run)  {- | 'defaultMain' is typically the main entry point for 'wrecker' benchmarks.      'defaultMain' will parse all command line arguments and then call 'run'@@ -26,27 +25,30 @@ > > 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] [--record-query]->  Welcome to wrecker+> Usage: wreck [--concurrency ARG] [--bin-count ARG] ([--run-count ARG] |+>              [--run-timed ARG]) [--timeout-time ARG] ([--non-interactive] |+>              [--interactive]) [--log-level ARG] [--log-format ARG] [--match ARG]+>              [--request-name-size ARG] [--output-path ARG] [--silent]+>              ([--relative-url-display] | [--absolute-url-display])+>              [--record-query] [--list-test-groups]+>   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->  --record-query           Take in consideration the query string for the report-+>   -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+>   --log-level ARG          Log to stderr events of criticality greater than the+>                            LOG_LEVEL+>   --log-format ARG         Log format to use+>   --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+>   --record-query           Take in consideration the query string for the report+>   --list-test-groups       Shows the list of tests to run and exit -} defaultMain :: [(String, Environment -> IO ())] -> IO () defaultMain actions = void . flip run actions =<< runParser

@@ -47,7 +47,9 @@       -- ^ This controls the command line display. It can be either Interactive       --   of NonInteractive     , logLevel :: LogLevel-      -- ^+      -- ^ The log severity to shown in stderr+    , logFmt :: LogFormat+      -- ^ The log format to use in stderr (either Json or PlainText)     , match :: String       -- ^ Set this to filter the benchmarks using a pattern     , requestNameColumnSize :: Maybe Int@@ -75,6 +77,7 @@     , timeoutTime = 100000000     , displayMode = NonInteractive     , logLevel = LevelError+    , logFmt = Json     , match = ""     , requestNameColumnSize = Nothing     , outputFilePath = Nothing@@ -91,6 +94,7 @@     , mTimeoutTime :: Maybe Int     , mDisplayMode :: Maybe DisplayMode     , mLogLevel :: Maybe LogLevel+    , mLogFmt :: Maybe LogFormat     , mMatch :: Maybe String     , mRequestNameColumnSize :: Maybe Int     , mOutputFilePath :: Maybe FilePath@@ -109,6 +113,7 @@         , mTimeoutTime = Just $ timeoutTime defaultOptions         , mDisplayMode = Just $ displayMode defaultOptions         , mLogLevel = Just $ logLevel defaultOptions+        , mLogFmt = Just $ logFmt defaultOptions         , mMatch = Just $ match defaultOptions         , mRequestNameColumnSize = requestNameColumnSize defaultOptions         , mOutputFilePath = outputFilePath defaultOptions@@ -125,6 +130,7 @@         , mTimeoutTime = mTimeoutTime x <|> mTimeoutTime y         , mDisplayMode = mDisplayMode x <|> mDisplayMode y         , mLogLevel = mLogLevel x <|> mLogLevel y+        , mLogFmt = mLogFmt x <|> mLogFmt y         , mMatch = mMatch x <|> mMatch y         , mRequestNameColumnSize = mRequestNameColumnSize x <|> mRequestNameColumnSize y         , mOutputFilePath = mOutputFilePath x <|> mOutputFilePath y@@ -143,6 +149,7 @@                        , mTimeoutTime = Just timeoutTime                        , mDisplayMode = Just displayMode                        , mLogLevel = Just logLevel+                       , mLogFmt = Just logFmt                        , mMatch = Just match                        , mRequestNameColumnSize = requestNameColumnSize                        , mOutputFilePath = outputFilePath@@ -150,7 +157,7 @@                        , murlDisplay = Just urlDisplay                        , mRecordQuery = Just recordQuery                        , mListTestGroups = Just listTestGroups-                       } -> Just $ Options {..}+                       } -> Just Options {..}         _ -> Nothing  optionalOption :: Read a => Mod OptionFields a -> Parser (Maybe a)@@ -180,8 +187,12 @@          Interactive <$ switch (long "interactive")) <*>     --     optionalOption-        (long "log-level" <> help "Log to stderr events of criticality greater than the LOG_LEVEL") <*>+        (long "log-level" <>+         help+             "Log to stderr events of criticality greater than the LOG_LEVEL (LevelWarn | LevelError | LevelInfo | LevelDebug)") <*>     --+    optionalOption (long "log-format" <> help "Log format to use (Json | PlainText)") <*>+    --     optionalStrOption (long "match" <> help "Only run tests that match the glob") <*>     --     optionalOption (long "request-name-size" <> help "Request name size for the terminal display") <*>@@ -199,36 +210,7 @@     --     optionalSwitch (long "list-test-groups" <> help "Shows the list of tests to run and exit") --- {- | 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] [--record-query]->  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->  --record-query           Take in consideration the query string for the report->  --list-test-groups       Shows the list of tests to run and exit -} runParser :: IO Options runParser = do

@@ -43,6 +43,7 @@     , context :: ConnectionContext       -- ^ Provided as a convience, this is a shared TLS context to reuse for       --   better performance.+    , logger :: Logger     }  {- | Typically 'wrecker' will control benchmarking actions. However in some situations@@ -55,14 +56,13 @@ newStandaloneRecorder :: IO (NextRef AllStats, Immortal.Thread, Recorder) newStandaloneRecorder = do     recorder <- Recorder.newRecorder True 10000-    logger <- newStdErrLogger 1000 LevelError-    (ref, thread) <- sinkRecorder logger recorder+    (ref, thread) <- sinkRecorder recorder     return (ref, thread, recorder) -sinkRecorder :: Logger -> Recorder -> IO (NextRef AllStats, Immortal.Thread)-sinkRecorder logger recorder = do+sinkRecorder :: Recorder -> IO (NextRef AllStats, Immortal.Thread)+sinkRecorder recorder = do     ref <- newNextRef emptyAllStats-    immortal <- Immortal.createWithLabel "collectEvent" $ \_ -> collectEvent logger ref recorder+    immortal <- Immortal.createWithLabel "collectEvent" $ \_ -> collectEvent ref recorder     return (ref, immortal)  updateSampler :: NextRef AllStats -> Event -> IO AllStats@@ -71,13 +71,12 @@         let !new = stepAllStats x (eRunIndex event) (Recorder.name $ eResult event) (eResult event)         in (new, new) -collectEvent :: Logger -> NextRef AllStats -> Recorder -> IO ()-collectEvent logger ref recorder =+collectEvent :: NextRef AllStats -> Recorder -> IO ()+collectEvent ref recorder =     fix $ \next -> do         mevent <- Recorder.readEvent recorder         for_ mevent $ \event -> do-            sampler <- updateSampler ref event-            logDebug logger $ show sampler+            _ <- updateSampler ref event             next  runAction :: Logger -> Int -> Int -> RunType -> (Environment -> IO ()) -> Environment -> IO ()@@ -125,18 +124,18 @@     recorder <- Recorder.newRecorder recordQuery 100000     context <- Connection.initConnectionContext     sampler <- newNextRef emptyAllStats-    logger <- newStdErrLogger 100000 logLevel+    logger <- newStdErrLogger logLevel logFmt     -- Collect events and     forkIO $         handle (\(e :: SomeException) -> void $ logError logger $ show e) $-        collectEvent logger sampler recorder+        collectEvent sampler recorder     consumer sampler     logDebug logger "Starting Runs"     let env = Environment {..}     runAction logger timeoutTime concurrency runStyle action env `finally`         (do logDebug logger "Shutting Down"             Recorder.stopRecorder recorder-            shutdownLogger 1000000 logger+            shutdownLogger logger             final sampler)     readLast sampler 

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: ba28c486ce0f76d696c6aabcb155909519ce09949843c4bb1e3159edb06b09ac+-- hash: 1a942b8332864cd112ccea2578c97845dd6909f862d8c624f9383e8d42f88cec  name:           wrecker-version:        1.2.4.0+version:        1.3.0.0 synopsis:       An HTTP Performance Benchmarker description:    'wrecker' is a library and executable for creating HTTP benchmarks. It is designed for                 benchmarking a series of dependent requests.@@ -52,6 +52,7 @@     , data-default-class >=0.0.1     , deepseq >=1.3     , exceptions >=0.8+    , fast-logger >=2.4.10     , filepath >=1.3     , http-client >=0.5.5     , http-client-tls >=0.3.3@@ -76,7 +77,6 @@     , time >=1.4     , tls >=1.2     , transformers >=0.3-    , unagi-chan >=0.4.0     , unix >=2.7     , unordered-containers >=0.2.5     , vector >=0.10.12