diff --git a/examples/Client.lhs b/examples/Client.lhs new file mode 100644 --- /dev/null +++ b/examples/Client.lhs @@ -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 +``` diff --git a/examples/Main.lhs b/examples/Main.lhs new file mode 100644 --- /dev/null +++ b/examples/Main.lhs @@ -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 +``` diff --git a/examples/Server.hs b/examples/Server.hs new file mode 100644 --- /dev/null +++ b/examples/Server.hs @@ -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 diff --git a/src/Wrecker.hs b/src/Wrecker.hs --- a/src/Wrecker.hs +++ b/src/Wrecker.hs @@ -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 diff --git a/src/Wrecker/Logger.hs b/src/Wrecker/Logger.hs --- a/src/Wrecker/Logger.hs +++ b/src/Wrecker/Logger.hs @@ -18,6 +18,8 @@ , currentLevel :: LogLevel } + + newLogger :: Handle -> Int -> LogLevel -> IO Logger newLogger handle maxSize currentLevel = do (inChan, outChan) <- U.newChan maxSize diff --git a/src/Wrecker/Main.hs b/src/Wrecker/Main.hs --- a/src/Wrecker/Main.hs +++ b/src/Wrecker/Main.hs @@ -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 diff --git a/src/Wrecker/Options.hs b/src/Wrecker/Options.hs --- a/src/Wrecker/Options.hs +++ b/src/Wrecker/Options.hs @@ -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 - diff --git a/src/Wrecker/Recorder.hs b/src/Wrecker/Recorder.hs --- a/src/Wrecker/Recorder.hs +++ b/src/Wrecker/Recorder.hs @@ -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" > ] diff --git a/src/Wrecker/Runner.hs b/src/Wrecker/Runner.hs --- a/src/Wrecker/Runner.hs +++ b/src/Wrecker/Runner.hs @@ -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) diff --git a/src/Wrecker/Statistics.hs b/src/Wrecker/Statistics.hs --- a/src/Wrecker/Statistics.hs +++ b/src/Wrecker/Statistics.hs @@ -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 diff --git a/wrecker.cabal b/wrecker.cabal --- a/wrecker.cabal +++ b/wrecker.cabal @@ -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