wrecker 0.1.0.1 → 0.1.1.0
raw patch · 11 files changed
+915/−138 lines, 11 filesdep +connectiondep +hspec-discoverdep +immortaldep −hspec-discoverydep ~basedep ~http-clientnew-component:exe:examplenew-component:exe:example-clientnew-component:exe:example-server
Dependencies added: connection, hspec-discover, immortal, markdown-unlit, network, scotty, wai, warp, wreq
Dependencies removed: hspec-discovery
Dependency ranges changed: base, http-client
Files
- examples/Client.lhs +353/−0
- examples/Main.lhs +98/−0
- examples/Server.hs +227/−0
- src/Wrecker.hs +8/−1
- src/Wrecker/Logger.hs +2/−0
- src/Wrecker/Main.hs +6/−5
- src/Wrecker/Options.hs +33/−36
- src/Wrecker/Recorder.hs +9/−9
- src/Wrecker/Runner.hs +89/−66
- src/Wrecker/Statistics.hs +1/−1
- wrecker.cabal +89/−20
+ examples/Client.lhs view
@@ -0,0 +1,353 @@+# Building a API client for profiling with `wrecker`++Unlike most HTTP benchmarking applications, `wrecker` is intended to benchmark+HTTP calls inline with other forms of processing. This allows for complex+interactions necessary to benchmark certain API endpoints.++## TL;DR++`wrecker` let's you build elegant API clients that you can use for profiling++Here is the example we will build.++ testScript :: Int -> Recorder -> IO ()+ testScript port recorder = do+ Root { products+ , login+ , checkout+ } <- get recorder "root" (rootRef port)+ firstProduct : _ <- get recorder "products" products+ userRef <- rpc recorder "login" login+ ( Credentials+ { userName = "a@example.com"+ , password = "password"+ }+ )+ User { usersCart } <- get recorder "user" userRef+ Cart { items } <- get recorder "cart" usersCart++ insert "items" items firstProduct+ rpc "checkout" checkout cart++If this doesn't make sense on inspection, that is okay. This file builds up all+the necessary utilities and documents every line.++Most of the code in this file is "generic". It is the type of boilerplate you+make once for an API client.++You don't need to make a polish API client to use `wrecker`, just look at+TODO_MAKE_AESON_LENS_EXAMPLE to see how to use `record` with less setup.++## Boring Haskell Prelude++This is Haskell, so first we turn on the extensions we would like to use.++```haskell+{-# LANGUAGE NamedFieldPuns+ , DeriveAnyClass+ , DeriveGeneric+ , OverloadedStrings+ , DuplicateRecordFields+ , CPP+#-}+```++- `NamedFieldPuns` will let us destructure records conveniently. +- `DeriveAnyClass` and `DeriveGeneric` are used turned on so the compiler+ can generate the JSON conversion functions for us automatically.+- `OverloadedStrings` is a here so redditors don't yell at me for using `String` instead of `Text`+- `DuplicateRecordFields` let's us use the `username` field in two records ... welcome to the future.++```haskell+#ifndef _CLIENT_IS_MAIN_+module Client where+#endif+```+Not the drones ...+++### The Essence of `wrecker` is `record`++Introducing `wrecker`++```haskell+import Wrecker (record, defaultMain, Recorder)+```++- `record` is the primary function from `wrecker`. It has the signature+ ```+ record :: Recorder -> String -> IO a -> IO a+ ```++ `record` takes a `Recorder` and key in the form of a `String` and wraps some+ `IO` action. `record` runs the passed in `IO a` and um ... records information+ about such as the elapsed time and whether it succeeded or failed.+- `defaultMain` is one of two entry points `wrecker` provides (the other is+ `run`). `defaultMain` performs command line argument parsing for us, and+ runs the benchmarks with the provided options.+- `Recorder` is an opaque type we can call `record` with. `defaultMain` and `run`+ create a `Recorder` that is used by all the benchmark scripts.++```haskell+import Data.Aeson+```+We need JSON so of course we are using `aeson`.++```haskell+import qualified Network.Wreq as Wreq+```+`wrecker` does not provide any means for making HTTP calls. It records data,+computes statistics, controls concurrency and provides a convenient UI.+We leverage `wreq` to do the actual HTTP calls.++Here we wrap `wreq`'s `get` and `post` calls and make new functions which take+a `Recorder` so we can benchmark the times.++#### Other packages you can mostly ignore+```haskell+import GHC.Generics+import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)+import Data.Text as T+import Network.HTTP.Client (responseBody)+```++## Make a Somewhat Generic JSON API++`wreq` is pretty easy to use for JSON APIs but it could be easier. Here we make+a quick wrapper around `wreq` specialized to JSON and we utilize `record`++### The Envelope++We wrap all JSON in sent to and from the server in an envelope,+mainly so we can also serialize a json object as opposed to an array.++```haskell+data Envelope a = Envelope { value :: a } -- <=> -- {"value" : toJSON a}+ deriving (Show, Eq, Generic, FromJSON, ToJSON)+```++The `Envelope` only exists to transmit data between the server and the browser.+- We wrap values going to the server in an `Envelope`++ ```haskell+ toEnvelope :: ToJSON a => a -> Value+ toEnvelope = toJSON . Envelope+ ```++- We unwrap values coming from the server in `Envelope`.++ ```haskell+ fromEnvelope :: FromJSON a => IO (Wreq.Response ByteString) -> IO a+ fromEnvelope x = fmap (value . responseBody) . Wreq.asJSON =<< x+ ```++- If we wrap inputs and unwrap outputs we can wrap a whole function.++ ```haskell+ liftEnvelope :: (ToJSON a, FromJSON b)+ => (Value -> IO (Wreq.Response ByteString))+ -> (a -> IO b )+ liftEnvelope f = fromEnvelope . f . toEnvelope+ ```++### Wrap HTTP Calls with `record`++Not only do we want to wrap and unwrap types from our `Envelope`, we also need to wrap api calls with `record`.++```haskell+jsonGet :: FromJSON a => Recorder -> String -> Text -> IO a+jsonGet recorder key url = fromEnvelope $ record recorder key $ Wreq.get (T.unpack url)++jsonPost :: (ToJSON a, FromJSON b) => Recorder -> String -> Text -> a -> IO b+jsonPost recorder key url = liftEnvelope $ record recorder key . Wreq.post (T.unpack url)+```++## Make a Somewhat Generic REST API++### Resource References++We represent resource urls using the type `Ref`+```haskell+data Ref a = Ref { unRef :: Text }+ deriving (Show, Eq)+```++`Ref` is nothing more than a `Text` wrapper (the value there is the URL). `Ref`+has polymorphic `a` so we can talk about different types of resources.++A `FromJSON` instance which wraps a `Text` value, assuming the JSON is `Text`.++```haskell+instance FromJSON (Ref a) where+ parseJSON = withText "FromJSON (Ref a)" (return . Ref)+```++The `ToJSON` is just the reverse.++```haskell+instance ToJSON (Ref a) where+ toJSON (Ref x) = toJSON x+```++In addition to resources our API has ad-hoc RPC calls. RPC calls are also+represented as a URL.++### Adhoc RPC++```haskell+data RPC a b = RPC Text+ deriving (Show, Eq)++instance FromJSON (RPC a b) where+ parseJSON = withText "FromJSON (Ref a)" (return . RPC)+```++### REST API Actions++We utilize our `jsonGet` and `jsonPost` functions and make specialized versions+for our more specific REST and RPC calls.++- `get` takes a `Ref a` and returns an `a`. The `a` could be something+ like `Cart` or it could be a list like `[Ref a]`.++ ```haskell+ get :: FromJSON a => Recorder -> String -> Ref a -> IO a+ get recorder key (Ref url) = jsonGet recorder key url+ ```+- `insert` takes a `Ref` to a list and appends an item to it. It returns the+ reference that you passed in because why not.++ ```haskell+ insert :: ToJSON a => Recorder -> String -> Ref [a] -> a -> IO (Ref [a])+ insert recorder key (Ref url) = jsonPost recorder key url+ ```+- `rpc` unpacks the URL for the RPC endpoint and `POST`s the input, returning the output.++ ```haskell+ rpc :: (ToJSON a, FromJSON b) => Recorder -> String -> RPC a b -> a -> IO b+ rpc recorder key (RPC url) = jsonPost recorder key url+ ```++## The Example API++The API requires an initial call to the "/root" to obtain the URLs for+subsequent calls++```haskell+rootRef :: Int -> Ref Root+rootRef port = Ref $ T.pack $ "http://localhost:" ++ show port ++ "/root"+```++### API Response types++ Calling `GET` on "/root" returns the following JSON ----------+ |+ Represented here -- |+ | |+ v v+```haskell +data Root = Root + { products :: Ref [Ref Product] -- -- { "products" : "http://localhost:3000/products"+ , carts :: Ref [Ref Cart ] -- <=> -- , "carts" : "http://localhost:3000/carts"+ , users :: Ref [Ref User ] -- -- , "users" : "http://localhost:3000/users"+ , login :: RPC Credentials (Ref User) -- -- , "login" : "http://localhost:3000/login"+ , checkout :: RPC (Ref Cart) () -- -- , "checkout" : "http://localhost:3000/checkout"+ } deriving (Eq, Show, Generic, FromJSON) -- -- }+```++Since the JSON is so uniform, we can use `aeson`s generic instances.++Calling `GET` on a `Ref Product` or "/products/:id" gives++```haskell+data Product = Product -- --+ { summary :: Text -- <=> -- { "summary" : "shirt" }+ } deriving (Eq, Show, Generic, FromJSON) -- --+```++Calling `GET` on a `Ref Cart` or "/carts/:id" gives++```haskell+data Cart = Cart -- --+ { items :: Ref [Ref Product] -- <=> -- { "items" : ["http://localhost:3000/products/0"] }+ } deriving (Eq, Show, Generic, FromJSON) -- --+```++Calling `GET` on a `Ref User` or "/users/:id" gives++```haskell+data User = User -- -- + { cart :: Ref Cart -- <=> -- { "cart" : "http://localhost:3000/carts/0"+ , username :: Text -- -- , "username" : "example"+ } deriving (Eq, Show, Generic, FromJSON) -- -- }+```++## RPC Types++The only additional type that we need is the input for the `login` RPC, mainly the `Credentials` type.++```haskell+data Credentials = Credentials -- --+ { password :: Text -- <=> -- { "password" : "password"+ , username :: Text -- -- , "username" : "a@example.com"+ } deriving (Eq, Show, Generic, ToJSON) -- -- }+```++## Profiling Script++We can now easily write our first script!++```haskell+testScript :: Int -> Recorder -> IO ()+testScript port recorder = do+```+Bootstrap the script and get all the URLs for the endpoints. Unpack+`products`, `login` and `checkout` for use later down.++```haskell+ Root { products+ , login+ , checkout+ } <- get recorder "root" (rootRef port)+```+We get all products and name the first one+```haskell+ firstProduct : _ <- get recorder "products" products+```++Login and get the user's ref.+```haskell+ userRef <- rpc recorder "login" login+ ( Credentials+ { username = "a@example.com"+ , password = "password"+ }+ )+```+Get the user and unpack the user's cart.+```haskell+ User { cart } <- get recorder "user" userRef+```+Get the cart unpack the items.+```haskell+ Cart { items } <- get recorder "cart" cart+```+Add the first product to the user's cart's items.+```haskell+ insert recorder "items" items firstProduct+```+Checkout.+```haskell+ rpc recorder "checkout" checkout cart+```++Port is hard coded to 3000 for this example++```haskell+benchmarks :: Int -> [(String, Recorder -> IO ())]+benchmarks port = [("test0", testScript port)]++main :: IO ()+main = defaultMain $ benchmarks 3000+```
+ examples/Main.lhs view
@@ -0,0 +1,98 @@+## Running the Examples++- To run whole benchmark example `cabal run example`+- Just the client `cabal run example-client `+- Just the server `cabal run example-server`++Additionally the examples take the standard `wrecker` command line arguments, which can be viewed with++ cabal run example -- --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 Log to stderr events of criticality greater than the LOG_LEVEL+ --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+```++Below is the source for `example` which creates a client and server.++```haskell+{-# LANGUAGE ScopedTypeVariables #-}+import qualified Client as Client+import qualified Server as Server+import Wrecker (run, runParser)+import Data.Function (fix)+import Control.Exception (handle, IOException)+import Control.Concurrent ( threadDelay+ , forkIO+ , newEmptyMVar+ , takeMVar+ , putMVar+ )+import Network.Connection ( connectTo+ , connectionClose+ , ConnectionParams (..)+ , initConnectionContext+ )+```++A little utility function which loops until a port is ready for connections.++```haskell+waitFor :: Int -> IO ()+waitFor port = do+ cxt <- initConnectionContext+ fix $ \next -> do+ handle (\(_ :: IOException) -> threadDelay 100000 >> next)+ (do+ connection <- connectTo cxt+ $ ConnectionParams "localhost"+ (fromIntegral port)+ Nothing+ Nothing+ connectionClose connection+ )+```++Entry point++```haskell+main :: IO ()+main = do+ -- Start the server on it's own thread+ forkIO $ Server.main++ -- The examples use port 3000 by default+ let port = 3000++ options <- runParser+ -- wait for the server to be ready+ waitFor port++ -- Start the client and close an MVar to signal when the thread has finished+ end <- newEmptyMVar+ forkIO $ do+ run options $ Client.benchmarks port+ putMVar end ()++ -- Wait for the client thread to finish and then return+ takeMVar end+```
+ examples/Server.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE ScopedTypeVariables+ , TypeOperators+ , OverloadedStrings+ , DeriveGeneric+ , FlexibleInstances+ , QuasiQuotes+ , DeriveAnyClass+ , CPP+ , FlexibleContexts+ , UndecidableInstances+ , RecordWildCards+ , DeriveFunctor+ , LambdaCase+ , RecursiveDo+ , OverloadedStrings+ , TupleSections+#-}++#ifndef _SERVER_IS_MAIN_+module Server where+#endif++import Web.Scotty (ScottyM, ActionM, json)+import Control.Concurrent+import Data.Aeson.QQ+import Control.Monad.IO.Class+import Network.Wai.Handler.Warp+ ( defaultSettings+ , openFreePort+ , Port+ )+-- import Data.Default ()+import GHC.Generics+import Data.Aeson hiding (json)+import Data.Text (Text)+import qualified Web.Scotty as Scotty+import qualified Data.Text as T+import Data.Monoid+import Wrecker+import Control.Concurrent.NextRef (NextRef)+import qualified Control.Concurrent.NextRef as NextRef+import qualified Control.Immortal as Immortal+import qualified Wrecker.Statistics as Wrecker+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai as Wai+import Network.Socket (Socket)+import qualified Network.Socket as N++newtype Envelope a = Envelope { value :: a }+ deriving (Show, Eq, Generic, ToJSON)++rootRef :: Int -> Text+rootRef port = T.pack $ "http://localhost:" ++ show port++jsonE :: ToJSON a => a -> ActionM ()+jsonE = json . Envelope++data Root a = Root+ { root :: a+ , products :: a+ , cartsIndex :: a+ , cartsIndexItems :: a+ , usersIndex :: a+ , login :: a+ , checkout :: a+ } deriving (Show, Eq, Functor)++type RootInt = Root Int++instance Applicative Root where+ pure x = Root+ { root = x+ , products = x+ , login = x+ , usersIndex = x+ , cartsIndex = x+ , cartsIndexItems = x+ , checkout = x+ }++ f <*> x = Root+ { root = root f $ root x+ , products = products f $ products x+ , login = login f $ login x+ , usersIndex = usersIndex f $ usersIndex x+ , cartsIndex = cartsIndex f $ cartsIndex x+ , cartsIndexItems = cartsIndexItems f $ cartsIndexItems x+ , checkout = checkout f $ checkout x++ }++app :: RootInt -> Port -> ScottyM ()+app Root {..} port = do+ let host = rootRef port+ Scotty.get "/root" $ do+ liftIO $ threadDelay root+ jsonE [aesonQQ|+ { "products" : #{host <> "/products" }+ , "carts" : #{host <> "/carts" }+ , "users" : #{host <> "/users" }+ , "login" : #{host <> "/login" }+ , "checkout" : #{host <> "/checkout" }+ }+ |]++ Scotty.get "/products" $ do+ liftIO $ threadDelay products+ jsonE [aesonQQ|+ [ #{host <> "/products/0"}+ ]+ |]++ Scotty.get "/product/:id" $ do+ liftIO $ threadDelay products+ jsonE [aesonQQ|+ { "summary" : "shirt" }+ |]++ Scotty.get "/carts" $ do+ -- sleepDist gen carts+ jsonE [aesonQQ|+ [ #{host <> "/carts/0"}+ ]+ |]++ Scotty.get "/carts/:id" $ do+ liftIO $ threadDelay cartsIndex+ jsonE [aesonQQ|+ { "items" : #{host <> "/carts/0/items"}+ }+ |]++ Scotty.post "/carts/:id/items" $ do+ liftIO $ threadDelay cartsIndexItems+ jsonE [aesonQQ|+ #{host <> "/carts/0/items"}+ |]++ Scotty.get "/users" $ do+ --sleepDist gen users+ jsonE [aesonQQ|+ [ #{host <> "/users/0"}+ ]+ |]++ Scotty.get "/users/:id" $ do+ liftIO $ threadDelay usersIndex+ jsonE [aesonQQ|+ { "cart" : #{host <> "/carts/0"}+ , "username" : "example"+ }+ |]++ Scotty.post "/login" $ do+ liftIO $ threadDelay login+ jsonE [aesonQQ|+ #{host <> "/users/0"}+ |]++ Scotty.post "/checkout" $ do+ liftIO $ threadDelay checkout+ jsonE ()++run :: RootInt -> IO (Port, Immortal.Thread, ThreadId, NextRef AllStats)+run = start Nothing++stop :: (Port, ThreadId, NextRef AllStats) -> IO AllStats+stop (_, threadId, ref) = do+ killThread threadId+ NextRef.readLast ref++toKey :: Wai.Request -> String+toKey x = case Wai.pathInfo x of+ ["root"] -> "root"+ ["products"] -> "products"+ "carts" : _ : "items" : _ -> "items"+ "carts" : _ : _ -> "cart"+ "users" : _ -> "user"+ ["login"] -> "login"+ ["checkout"] -> "checkout"+ _ -> error "FAIL! UNKNOWN REQUEST FOR EXAMPLE!"++recordMiddleware :: Recorder -> Wai.Application -> Wai.Application+recordMiddleware recorder waiApp req sendResponse+ = record recorder (toKey req) $! waiApp req $ \res -> sendResponse res++getASocket :: Maybe Port -> IO (Port, Socket)+getASocket = \case+ Just port -> do s <- N.socket N.AF_INET N.Stream N.defaultProtocol+ localhost <- N.inet_addr "127.0.0.1"+ N.bind s (N.SockAddrInet (fromIntegral port) localhost)+ N.listen s 1+ return (port, s)++ Nothing -> openFreePort++start :: Maybe Port -> RootInt -> IO ( Port+ , Immortal.Thread+ , ThreadId+ , NextRef AllStats+ )+start mport dist = do+ (port, socket) <- getASocket mport++ (ref, recorderThread, recorder) <- newStandaloneRecorder+ scottyApp <- Scotty.scottyApp $ app dist port+ threadId <- flip forkFinally (\_ -> N.close socket)+ $ Warp.runSettingsSocket defaultSettings socket+ $ recordMiddleware recorder+ $ scottyApp++ return (port, recorderThread, threadId, ref)++main :: IO ()+main = do+ (port, socket) <- getASocket $ Just 3000++ (ref, recorderThread, recorder) <- newStandaloneRecorder+ scottyApp <- Scotty.scottyApp $ app (pure 0) port++ Warp.runSettingsSocket defaultSettings socket+ $ recordMiddleware recorder+ $ scottyApp+ N.close socket+ Immortal.stop recorderThread+ allStats <- NextRef.readLast ref+ putStrLn $ Wrecker.pprStats Nothing allStats
src/Wrecker.hs view
@@ -14,10 +14,17 @@ , defaultMain , record , run- , Options (..)+ , Options (..)+ , RunType (..)+ , DisplayMode (..) , defaultOptions+ , runParser+ , AllStats (..)+ , ResultStatistics (..)+ , newStandaloneRecorder ) where import Wrecker.Recorder import Wrecker.Main import Wrecker.Options import Wrecker.Runner+import Wrecker.Statistics
src/Wrecker/Logger.hs view
@@ -18,6 +18,8 @@ , currentLevel :: LogLevel } ++ newLogger :: Handle -> Int -> LogLevel -> IO Logger newLogger handle maxSize currentLevel = do (inChan, outChan) <- U.newChan maxSize
src/Wrecker/Main.hs view
@@ -2,19 +2,20 @@ import Wrecker.Runner (run) import Wrecker.Options (runParser) import Wrecker.Recorder (Recorder)+import Control.Monad (void) {- | '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'. + with the correct 'Options'. -> import Wrecker +> import Wrecker > import Your.Performance.Scripts (landingPage, purchase)-> +> > main :: IO ()-> main = defaultMain +> main = defaultMain > [ ("loginReshare", loginReshare) > , ("purchase" , purchase ) > ] -} defaultMain :: [(String, Recorder -> IO ())] -> IO ()-defaultMain actions = flip run actions =<< runParser+defaultMain actions = void . flip run actions =<< runParser
src/Wrecker/Options.hs view
@@ -4,16 +4,14 @@ 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 ++data DisplayMode = Interactive | NonInteractive deriving (Show, Eq, Read)- + data Options = Options { concurrency :: Int -- ^ The number of simulatanous connections@@ -23,13 +21,13 @@ -- ^ 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 + -- ^ 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@@ -40,10 +38,10 @@ -- ^ Set 'silent' to true to disable all output. } deriving (Show, Eq) --- | 'defaultOptions' provides sensible default for the 'Options' +-- | 'defaultOptions' provides sensible default for the 'Options' -- types defaultOptions :: Options-defaultOptions = Options +defaultOptions = Options { concurrency = 1 , binCount = 20 , runStyle = RunCount 1@@ -54,9 +52,9 @@ , requestNameColumnSize = Nothing , outputFilePath = Nothing , silent = False- } + } -data PartialOptions = PartialOptions +data PartialOptions = PartialOptions { mConcurrency :: Maybe Int , mBinCount :: Maybe Int , mRunStyle :: Maybe RunType@@ -68,10 +66,10 @@ , mOutputFilePath :: Maybe FilePath , mSilent :: Maybe Bool } deriving (Show, Eq)- + instance Monoid PartialOptions where- mempty = PartialOptions - { mConcurrency = Just $ concurrency defaultOptions + mempty = PartialOptions+ { mConcurrency = Just $ concurrency defaultOptions , mBinCount = Just $ binCount defaultOptions , mRunStyle = Just $ runStyle defaultOptions , mTimeoutTime = Just $ timeoutTime defaultOptions@@ -82,7 +80,7 @@ , mOutputFilePath = outputFilePath defaultOptions , mSilent = Just $ silent defaultOptions }- mappend x y = PartialOptions + mappend x y = PartialOptions { mConcurrency = mConcurrency x <|> mConcurrency y , mBinCount = mBinCount x <|> mBinCount y , mRunStyle = mRunStyle x <|> mRunStyle y@@ -90,17 +88,17 @@ , mDisplayMode = mDisplayMode x <|> mDisplayMode y , mLogLevel = mLogLevel x <|> mLogLevel y , mMatch = mMatch x <|> mMatch y- , mRequestNameColumnSize = mRequestNameColumnSize x + , mRequestNameColumnSize = mRequestNameColumnSize x <|> mRequestNameColumnSize y- , mOutputFilePath = mOutputFilePath x + , mOutputFilePath = mOutputFilePath x <|> mOutputFilePath y , mSilent = mSilent x <|> mSilent y } completeOptions :: PartialOptions -> Maybe Options-completeOptions options = +completeOptions options = case options <> mempty of- PartialOptions + PartialOptions { mConcurrency = Just concurrency , mBinCount = Just binCount , mRunStyle = Just runStyle@@ -112,8 +110,8 @@ , mOutputFilePath = outputFilePath , mSilent = Just silent } -> Just $ Options {..}- _ -> Nothing - + _ -> Nothing+ optionalOption :: Read a => Mod OptionFields a -> Parser (Maybe a) optionalOption = optional . option auto @@ -123,18 +121,18 @@ optionalSwitch :: Mod FlagFields Bool -> Parser (Maybe Bool) optionalSwitch = optional . switch -pPartialOptions :: Parser PartialOptions +pPartialOptions :: Parser PartialOptions pPartialOptions = PartialOptions- <$> optionalOption + <$> optionalOption ( long "concurrency" <> help "Number of threads for concurrent requests" )- <*> optionalOption + <*> optionalOption ( long "bin-count" <> help "Number of bins for latency histogram" )- <*> optional + <*> optional ( RunCount <$> option auto ( long "run-count" <> help "number of times to repeat "@@ -148,41 +146,40 @@ ( long "timeout-time" <> help "How long to wait for all requests to finish" )- <*> optionalOption + <*> optionalOption ( long "display-mode" <> help "Display results interactively" )- <*> optionalOption + <*> optionalOption ( long "log-level"- <> help "Display results interactively"+ <> help "Log to stderr events of criticality greater than the LOG_LEVEL" ) <*> optionalStrOption ( long "match" <> help "Only run tests that match the glob" )- <*> optionalOption + <*> optionalOption ( long "request-name-size" <> help "Request name size for the terminal display" )- <*> optionalStrOption + <*> optionalStrOption ( long "output-path" <> help "Save a JSON file of the the statistics to given path" )- <*> optionalSwitch + <*> optionalSwitch ( long "silent" <> help "Disable all output" ) runParser :: IO Options-runParser = do +runParser = do let opts = info (helper <*> pPartialOptions) ( fullDesc <> progDesc "Welcome to wrecker"- <> header "wrecker - HTTP stress tester and benchmarker" + <> header "wrecker - HTTP stress tester and benchmarker" )- - partialOptions <- execParser opts ++ partialOptions <- execParser opts case completeOptions partialOptions of Nothing -> throwIO $ userError "" Just x -> return x-
src/Wrecker/Recorder.hs view
@@ -65,17 +65,17 @@ > 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"-> ]-> )->+> Object user <- rc "login" +> $ asJSON+> =<< ( post session "https://somesite.com/login" +> $ object [ "email" .= "example@example.com"+> , "password" .= "12345678"+> ]+> )+> let Just feedUrl = H.lookup "feed" user > itemRef : _ <- rc "get feed" > $ asJSON-> =<< ( post session userId +> =<< ( post session feedUrl > $ object [ "email" .= "example@example.com" > , "password" .= "12345678" > ]
src/Wrecker/Runner.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards, ScopedTypeVariables, LambdaCase, BangPatterns #-}+{-# LANGUAGE TupleSections #-} module Wrecker.Runner where import Wrecker.Logger import System.Posix.Signals@@ -21,60 +22,79 @@ import Data.List (isInfixOf) import Data.Aeson (encode) import qualified Data.ByteString.Lazy as BSL+import qualified Data.HashMap.Strict as H+import Data.HashMap.Strict (HashMap)+import qualified Control.Immortal as Immortal -- TODO configure whether errors are used in times or not++newStandaloneRecorder :: IO (NextRef AllStats, Immortal.Thread, Recorder)+newStandaloneRecorder = do+ recorder <- newRecorder 10000+ 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 + ref <- newNextRef emptyAllStats + 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) +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 +collectEvent logger ref recorder = fix $ \next -> do mevent <- readEvent recorder for_ mevent $ \event -> do sampler <- updateSampler ref event logDebug logger $ show sampler- next + next -runAction :: Logger - -> Int - -> Int - -> RunType - -> (Recorder -> IO ()) +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 + actionThread = void+ $ BoundedThreadGroup.forkIO threadLimit $ do rec <- takeRecorder- handle (\(e :: SomeException) -> do + handle (\(e :: SomeException) -> do logWarn logger $ show e- addEvent recorder $ Error + addEvent recorder $ Error { resultTime = 0 , exception = e , name = "__UNKNOWN__" } addEvent rec End )- $ do + $ do action rec addEvent rec End- - ++ case runStyle of- RunCount count -> replicateM_ (count * concurrency) actionThread + 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 + Nothing -> void+ $ logError logger $ "Timed out waiting for all " ++ "threads to complete" Just () -> return ()@@ -82,40 +102,41 @@ ------------------------------------------------------------------------------ --- Generic Run Function --------------------------------------------------------------------------------runWithNextVar :: Options +runWithNextVar :: Options -> (NextRef AllStats -> IO ()) -> (NextRef AllStats -> IO ()) -> (Recorder -> IO ())- -> IO ()+ -> IO AllStats 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) + 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` + runAction logger timeoutTime concurrency runStyle action recorder `finally` (do logDebug logger "Shutting Down"- stopRecorder recorder - shutdownLogger 1000000 logger + stopRecorder recorder+ shutdownLogger 1000000 logger final sampler )+ readLast 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 +runNonInteractive :: Options -> (Recorder -> IO ()) -> IO AllStats+runNonInteractive options action = do let shutdown sampler = do putStrLn "" hFlush stdout- hSetBuffering stdout (BlockBuffering (Just 100000000)) + hSetBuffering stdout (BlockBuffering (Just 100000000)) printLastSamples options sampler hFlush stdout for_ (outputFilePath options) $ \filePath ->@@ -125,19 +146,19 @@ ------------------------------------------------------------------------------- --- Interactive Rendering --------------------------------------------------------------------------------printLoop :: Options - -> VTY.DisplayContext - -> VTY.Vty +printLoop :: Options+ -> VTY.DisplayContext+ -> VTY.Vty -> NextRef AllStats -> IO ()-printLoop options context vty sampler +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@@ -146,59 +167,61 @@ _ -> return () updateUI :: Maybe Int -> VTY.DisplayContext -> AllStats -> IO ()-updateUI nameSize displayContext stats - = VTY.outputPicture displayContext - $ VTY.picForImage - $ VTY.vertCat +updateUI nameSize displayContext stats+ = VTY.outputPicture displayContext+ $ VTY.picForImage+ $ VTY.vertCat $ map (VTY.string VTY.defAttr)- $ lines + $ lines $ pprStats nameSize stats -runInteractive :: Options -> (Recorder -> IO ()) -> IO ()-runInteractive options action = do - vtyConfig <- VTY.standardIOConfig +runInteractive :: Options -> (Recorder -> IO ()) -> IO AllStats+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)) + hSetBuffering stdout (BlockBuffering (Just 100000000)) printLastSamples options sampler hFlush stdout for_ (outputFilePath options) $ \filePath -> BSL.writeFile filePath . encode =<< readLast sampler - runWithNextVar options (\sampler -> void + runWithNextVar options (\sampler -> void $ forkIO (printLoop options displayContext vty sampler )- ) - shutdown + )+ 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'. --- +-- '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 +run :: Options -> [(String, Recorder -> IO ())] -> IO (HashMap String AllStats)+run options actions = do hSetBuffering stderr LineBuffering- - forM_ actions $ \(groupName, action) -> do - when (match options `isInfixOf` groupName) $ do++ fmap H.fromList . forM actions $ \(groupName, action) -> do+ if (match options `isInfixOf` groupName) then do putStrLn groupName- case displayMode options of+ (groupName, ) <$> case displayMode options of NonInteractive -> runNonInteractive options action Interactive -> runInteractive options action+ else+ return (groupName, emptyAllStats)
src/Wrecker/Statistics.hs view
@@ -207,7 +207,7 @@ statToRow :: ResultStatistics -> [String] statToRow x = [ printf "%.4f" $ mean $ rs2xx x- , printf "%.4f" $ variance $ rs2xx x+ , printf "%.8f" $ variance $ rs2xx x , printf "%.4f" $ sMax $ rs2xx x , printf "%.4f" $ sMin $ rs2xx x , show $ count2xx x
wrecker.cabal view
@@ -1,19 +1,19 @@ name: wrecker-version: 0.1.0.1+version: 0.1.1.0 synopsis: A HTTP Performance Benchmarker-description: +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 + 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. homepage: https://github.com/skedgeme/wrecker#readme license: BSD3@@ -27,7 +27,7 @@ cabal-version: >=1.10 library- hs-source-dirs: src+ hs-source-dirs: src exposed-modules: Wrecker , Wrecker.Recorder , Wrecker.Runner@@ -38,7 +38,6 @@ build-depends: base >= 4.7 && < 5 , stm , stm-chans- , aeson-qq , statistics , vector , bytestring@@ -48,7 +47,7 @@ , time , clock , text- , http-client >= 0.5 && < 0.6+ , http-client >= 0.4 && < 0.5 , http-types , tabular , deepseq@@ -58,20 +57,90 @@ , threads-extras , clock-extras , optparse-applicative- , stm-chans , ansi-terminal , unagi-chan , next-ref+ , immortal default-language: Haskell2010- ghc-options: -Wall -fno-warn-unused-do-bind+ ghc-options: -Wall -fno-warn-unused-do-bind -pgmL markdown-unlit +executable example-server+ hs-source-dirs: examples+ main-is: Server.hs+ build-depends: base+ , wrecker+ , scotty+ , aeson-qq+ , warp+ , markdown-unlit+ , aeson+ , text+ , immortal+ , next-ref+ , wai+ , network+ cpp-options: -D_SERVER_IS_MAIN_+ ghc-options: -Wall -Wno-unused-do-bind -Wno-unused-top-binds -threaded -pgmL markdown-unlit -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++executable example-client+ hs-source-dirs: examples+ main-is: Client.lhs+ build-depends: base+ , wrecker+ , wreq+ , markdown-unlit+ , aeson+ , bytestring+ , text+ , http-client+ cpp-options: -D_CLIENT_IS_MAIN_+ ghc-options: -Wall -Wno-unused-top-binds -Wno-unused-do-bind -threaded -pgmL markdown-unlit -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++executable example+ hs-source-dirs: examples+ main-is: Main.lhs+ build-depends: base+ , wrecker+ , scotty+ , aeson-qq+ , warp+ , wreq+ , markdown-unlit+ , aeson+ , bytestring+ , text+ , http-client+ , connection+ , immortal+ , next-ref+ , wai+ , network+ ghc-options: -Wall -Wno-unused-do-bind -O2 -threaded -pgmL markdown-unlit -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ test-suite wrecker-test type: exitcode-stdio-1.0- hs-source-dirs: test+ hs-source-dirs: test, examples main-is: Spec.hs- build-depends: base- , wrecker- , hspec- , hspec-discovery- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends: base+ , wrecker+ , hspec+ , hspec-discover+ , scotty+ , aeson-qq+ , warp+ , wreq+ , markdown-unlit+ , aeson+ , bytestring+ , text+ , http-client+ , unordered-containers+ , wai+ , network+ , immortal+ , next-ref+ ghc-options: -Wall -Wno-unused-do-bind -O2 -threaded -pgmL markdown-unlit -rtsopts -with-rtsopts=-N default-language: Haskell2010