diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -3,11 +3,9 @@ import Network.HTTP.Client import Options.Applicative.Builder import Options.Applicative -import Data.Monoid import Control.Exception import Control.Monad (void) -import qualified Network.Wreq as Wreq -import Control.Lens +import Data.Monoid parser :: Parser (PartialOptions, String) parser @@ -32,7 +30,10 @@ main :: IO () main = do (options, url) <- runParser' - man <- newManager defaultManagerSettings { managerConnCount = concurrency options } - void $ runOne options $ \env -> do - void $ record (recorder env) url - $ Wreq.getWith (Wreq.defaults & Wreq.manager .~ Right man) url + man <- newManager defaultManagerSettings { managerConnCount = concurrency options + , managerIdleConnectionCount = concurrency options + } + + req <- parseRequest url + void $ runOne options $ \env -> + void $ record (recorder env) url $ httpLbs req man diff --git a/examples/Client.lhs b/examples/Client.lhs --- a/examples/Client.lhs +++ b/examples/Client.lhs @@ -50,13 +50,7 @@ This is Haskell, so first we turn on the extensions we would like to use. ```haskell -{-# LANGUAGE NamedFieldPuns - , DeriveAnyClass - , DeriveGeneric - , OverloadedStrings - , DuplicateRecordFields - , CPP -#-} +{-# LANGUAGE NamedFieldPuns, DeriveGeneric, OverloadedStrings, CPP #-} ``` - `NamedFieldPuns` will let us destructure records conveniently.  @@ -64,8 +58,6 @@ 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` lets us use the `username` field in two records...welcome -to the future. - `CPP`...ignore that... ```haskell @@ -106,7 +98,6 @@ ```haskell import GHC.Generics import Data.ByteString.Lazy (ByteString) -import Data.Text (Text) import Data.Text as T import Network.HTTP.Client (responseBody) ``` @@ -127,7 +118,10 @@ It is represented in Haskell as ```haskell data Envelope a = Envelope { value :: a } - deriving (Show, Eq, Generic, FromJSON, ToJSON) + deriving (Show, Eq, Generic) + +instance FromJSON a => FromJSON (Envelope a) +instance ToJSON a => ToJSON (Envelope a) ``` The `Envelope` only exists to transmit data between the server and the browser. @@ -270,7 +264,9 @@ , users :: Ref [Ref User ] , login :: RPC Credentials (Ref User) , checkout :: RPC (Ref Cart) () - } deriving (Eq, Show, Generic, FromJSON) + } deriving (Eq, Show, Generic) + +instance FromJSON Root ``` Since the JSON is so uniform, we can use `aeson`'s generic instances. @@ -286,7 +282,9 @@ ```haskell data Product = Product { summary :: Text - } deriving (Eq, Show, Generic, FromJSON) + } deriving (Eq, Show, Generic) + +instance FromJSON Product ``` Calling `GET` on a `Ref Cart` or "/carts/:id" gives @@ -300,7 +298,9 @@ ```haskell data Cart = Cart { items :: Ref [Ref Product] - } deriving (Eq, Show, Generic, FromJSON) + } deriving (Eq, Show, Generic) + +instance FromJSON Cart ``` Calling `GET` on a `Ref User` or "/users/:id" gives @@ -314,7 +314,9 @@ data User = User { cart :: Ref Cart , username :: Text - } deriving (Eq, Show, Generic, FromJSON) + } deriving (Eq, Show, Generic) + +instance FromJSON User ``` ## RPC Types @@ -323,15 +325,17 @@ ```json { "password" : "password" -, "username" : "a@example.com" +, "userid" : "a@example.com" } ``` ```haskell data Credentials = Credentials { password :: Text - , username :: Text - } deriving (Eq, Show, Generic, ToJSON) + , userid :: Text + } deriving (Eq, Show, Generic) + +instance ToJSON Credentials ``` ## Profiling Script @@ -362,7 +366,7 @@ ```haskell userRef <- rpc sess login ( Credentials - { username = "a@example.com" + { userid = "a@example.com" , password = "password" } ) diff --git a/examples/Main.lhs b/examples/Main.lhs --- a/examples/Main.lhs +++ b/examples/Main.lhs @@ -1,10 +1,10 @@ ## 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` +- Run the whole benchmark example with `cabal run example` +- Run just the client with `cabal run example-client ` +- Run just the server with `cabal run example-server` -Additionally the examples take the standard `wrecker` command line arguments, which can be viewed with +Additionally, the examples take the standard `wrecker` command line arguments, which can be viewed with cabal run example -- --help @@ -32,13 +32,14 @@ --silent Disable all output ``` -Below is the source for `example` which creates a client and server. +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 Wrecker (run) +import Wrecker.Options (runParser) import Data.Function (fix) import Control.Exception (handle, IOException) import Control.Concurrent ( threadDelay @@ -52,9 +53,10 @@ , ConnectionParams (..) , initConnectionContext ) +import System.Environment ``` -A little utility function which loops until a port is ready for connections. +A little utility function which loops until a port is ready for connections: ```haskell waitFor :: Int -> IO () @@ -72,13 +74,13 @@ ) ``` -Entry point +Entry point: ```haskell main :: IO () main = do -- Start the server on it's own thread - forkIO $ Server.main + forkIO $ withArgs [] Server.main -- The examples use port 3000 by default let port = 3000 diff --git a/examples/Server.hs b/examples/Server.hs --- a/examples/Server.hs +++ b/examples/Server.hs @@ -1,20 +1,8 @@ -{-# LANGUAGE ScopedTypeVariables - , TypeOperators - , OverloadedStrings - , DeriveGeneric - , FlexibleInstances - , QuasiQuotes - , DeriveAnyClass - , CPP - , FlexibleContexts - , UndecidableInstances - , RecordWildCards - , DeriveFunctor - , LambdaCase - , RecursiveDo - , OverloadedStrings - , TupleSections -#-} +{-# LANGUAGE ScopedTypeVariables, TypeOperators, OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric, FlexibleInstances, QuasiQuotes #-} +{-# LANGUAGE CPP, FlexibleContexts, UndecidableInstances, RecordWildCards #-} +{-# LANGUAGE DeriveFunctor, LambdaCase, OverloadedStrings #-} +{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving #-} #ifndef _SERVER_IS_MAIN_ module Server where @@ -36,6 +24,7 @@ import qualified Data.Text as T import Data.Monoid import Wrecker +import Wrecker.Runner import Control.Concurrent.NextRef (NextRef) import qualified Control.Concurrent.NextRef as NextRef import qualified Control.Immortal as Immortal @@ -45,10 +34,15 @@ import Network.Socket (Socket) import qualified Network.Socket as N import Control.Exception +import Data.Maybe (listToMaybe) +import System.Environment +import Control.Applicative -newtype Envelope a = Envelope { value :: a } - deriving (Show, Eq, Generic, ToJSON) +data Envelope a = Envelope { value :: a } + deriving (Show, Eq, Generic) +instance ToJSON a => ToJSON (Envelope a) + rootRef :: Int -> Text rootRef port = T.pack $ "http://localhost:" ++ show port @@ -189,7 +183,7 @@ 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 100 + N.listen s 1000 return (port, s) Nothing -> openFreePort @@ -213,10 +207,12 @@ main :: IO () main = do + xs <- getArgs + let delay = maybe 0 read $ listToMaybe xs (port, socket) <- getASocket $ Just 3000 (ref, recorderThread, recorder) <- newStandaloneRecorder - scottyApp <- Scotty.scottyApp $ app (pure 0) port + scottyApp <- Scotty.scottyApp $ app (pure delay) port (Warp.runSettingsSocket defaultSettings socket $ recordMiddleware recorder diff --git a/src/Wrecker/Options.hs b/src/Wrecker/Options.hs --- a/src/Wrecker/Options.hs +++ b/src/Wrecker/Options.hs @@ -95,7 +95,7 @@ , mRequestNameColumnSize = requestNameColumnSize defaultOptions , mOutputFilePath = outputFilePath defaultOptions , mSilent = Just $ silent defaultOptions - , murlDisplay = Just $ urlDisplay defaultOptions + , murlDisplay = Just $ urlDisplay defaultOptions } mappend x y = PartialOptions { mConcurrency = mConcurrency x <|> mConcurrency y @@ -127,7 +127,7 @@ , mRequestNameColumnSize = requestNameColumnSize , mOutputFilePath = outputFilePath , mSilent = Just silent - , murlDisplay = Just urlDisplay + , murlDisplay = Just urlDisplay } -> Just $ Options {..} _ -> Nothing @@ -154,11 +154,11 @@ <*> optional ( RunCount <$> option auto ( long "run-count" - <> help "number of times to repeat " + <> help "number of times to repeat" ) <|> RunTimed <$> option auto ( long "run-timed" - <> help "number of seconds to repeat " + <> help "number of seconds to repeat" ) ) <*> optionalOption @@ -166,8 +166,8 @@ <> help "How long to wait for all requests to finish" ) <*> optional - ( Interactive <$ switch (long "interactive") - <|> NonInteractive <$ switch (long "non-interactive") + ( NonInteractive <$ switch (long "non-interactive") + <|> Interactive <$ switch (long "interactive") ) <*> optionalOption ( long "log-level" diff --git a/src/Wrecker/Recorder.hs b/src/Wrecker/Recorder.hs --- a/src/Wrecker/Recorder.hs +++ b/src/Wrecker/Recorder.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass, CPP, BangPatterns #-} +{-# LANGUAGE CPP, BangPatterns #-} module Wrecker.Recorder where import Control.Concurrent.STM import Control.Concurrent.STM.TBMQueue @@ -9,6 +9,9 @@ import System.Clock import Control.Exception import System.Clock.TimeIt +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif data RunResult = Success { resultTime :: !Double @@ -58,7 +61,7 @@ {- | 'record' is a low level function for collecting timing information. Wrap each action of interest in a call to record. -> record recorder $ threadDelay 1000000 +> record recorder $ threadDelay 1000000 'record' measures the elapsed time of the call, and catches 'HttpException' in the case of failure. This means failures diff --git a/src/Wrecker/Runner.hs b/src/Wrecker/Runner.hs --- a/src/Wrecker/Runner.hs +++ b/src/Wrecker/Runner.hs @@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards, ScopedTypeVariables, LambdaCase, BangPatterns #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections, CPP #-} module Wrecker.Runner where import Wrecker.Logger import System.Posix.Signals @@ -29,6 +29,9 @@ import Data.Maybe import Network.Connection (ConnectionContext) import qualified Network.Connection as Connection +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif -- TODO configure whether errors are used in times or not @@ -261,7 +264,7 @@ -} runOne :: Options -> (Environment -> IO ()) -> IO AllStats runOne options f - = let key = "key" + = let key = "" in fromMaybe (error "runOne: impossible!") . H.lookup key <$> run options [(key, f)] diff --git a/wrecker.cabal b/wrecker.cabal --- a/wrecker.cabal +++ b/wrecker.cabal @@ -1,5 +1,5 @@ name: wrecker -version: 0.1.3.0 +version: 0.1.3.1 synopsis: An HTTP Performance Benchmarker description: 'wrecker' is a library and executable for creating HTTP benchmarks. It is designed for @@ -8,7 +8,7 @@ 'wrecker' includes a wrapped version of the `wreq` Session API , mainly through 'Network.Wreq.Wrecker'. - See https://github.com/skedgeme/wrecker#readme for more information. + See for more information. homepage: https://github.com/skedgeme/wrecker#readme license: BSD3 license-file: LICENSE @@ -54,53 +54,53 @@ , Network.PublicSuffixList.Serialize , Network.PublicSuffixList.DataStructure - build-depends: base >= 4.7 && < 5 - , aeson >= 0.7.0.3 + build-depends: base >= 4.6 && < 5 + , aeson >= 0.7 , ansi-terminal >= 0.6.2 , ansigraph >= 0.3.0 - , array >= 0.5.1 + , array >= 0.5.0 , base64-bytestring >= 1.0.0 , blaze-builder >= 0.4.0 , bytestring >= 0.10 , case-insensitive >= 1.2.0 - , clock >= 0.7.2 + , clock >= 0.4 , clock-extras >= 0.1.0 - , connection >= 0.2.6 - , containers >= 0.5.7 - , cookie >= 0.4.2 - , cryptonite >= 0.20 - , data-default >= 0.7.1 - , data-default-class >= 0.1.2 - , deepseq >= 1.4.2 - , exceptions >= 0.8.3 - , filepath >= 1.4.1 - , http-client >= 0.4.31 - , http-types >= 0.9.1 - , immortal >= 0.2.2 - , memory >= 0.13 + , connection >= 0.2.4 + , containers >= 0.5.5 + , cookie >= 0.4.1 + , cryptonite >= 0.6 + , data-default >= 0.5.3 + , data-default-class >= 0.0.1 + , deepseq >= 1.3 + , exceptions >= 0.8 + , filepath >= 1.3 + , http-client >= 0.4.11 + , http-types >= 0.8.6 + , immortal >= 0.2 + , memory >= 0.7 , mime-types >= 0.1.0 - , network >= 2.6.3 - , network-uri >= 2.6.1 + , network >= 2.6 + , network-uri >= 2.6 , next-ref >= 0.1.0 - , optparse-applicative >= 0.13.0 + , optparse-applicative >= 0.11.0 , random >= 1.1 - , statistics >= 0.13.3 + , statistics >= 0.13.2 , stm >= 2.4.4 , stm-chans >= 3.0.0 - , streaming-commons >= 0.1.16 + , streaming-commons >= 0.1.10 , tabular >= 0.2.2 - , text >= 1.2.2 + , text >= 1.2 , threads >= 0.5.1 , threads-extras >= 0.1.0 - , time >= 1.6.0 - , tls >= 1.3.8 - , transformers >= 0.5.2 + , time >= 1.4 + , tls >= 1.2 + , transformers >= 0.3 , unagi-chan >= 0.4.0 - , unix >= 2.7.2 - , unordered-containers >= 0.2.7 - , vector >= 0.11.0 + , unix >= 2.7 + , unordered-containers >= 0.2.5 + , vector >= 0.10.12 , vty >= 5.11 - , wreq >= 0.4.1 + , wreq >= 0.3 default-language: Haskell2010 ghc-options: -Wall -fno-warn-unused-do-bind -pgmL markdown-unlit @@ -114,8 +114,9 @@ , http-client , wreq , lens + cpp-options: -D_SERVER_IS_MAIN_ - ghc-options: -O2 -Wall -Wno-unused-do-bind -Wno-unused-top-binds -threaded -pgmL markdown-unlit -rtsopts "-with-rtsopts=-N -I0 -qg" + ghc-options: -Wall -fno-warn-unused-do-bind -threaded -pgmL markdown-unlit -rtsopts "-with-rtsopts=-N -I0 -qg" default-language: Haskell2010 executable example-server @@ -125,7 +126,7 @@ , wrecker , scotty , aeson-qq - , warp + , warp >= 3.2.4 , markdown-unlit , aeson , text @@ -133,8 +134,9 @@ , next-ref , wai , network + , transformers cpp-options: -D_SERVER_IS_MAIN_ - ghc-options: -O2 -Wall -Wno-unused-do-bind -Wno-unused-top-binds -threaded -pgmL markdown-unlit -rtsopts "-with-rtsopts=-N -I0 -qg" + ghc-options: -Wall -fno-warn-unused-do-bind -threaded -pgmL markdown-unlit -rtsopts "-with-rtsopts=-N -I0 -qg" default-language: Haskell2010 executable example-client @@ -150,7 +152,7 @@ , http-client , connection cpp-options: -D_CLIENT_IS_MAIN_ - ghc-options: -O2 -Wall -Wno-unused-top-binds -Wno-unused-do-bind -threaded -pgmL markdown-unlit -rtsopts "-with-rtsopts=-N -I0 -qg" + ghc-options: -Wall -fno-warn-unused-do-bind -threaded -pgmL markdown-unlit -rtsopts "-with-rtsopts=-N -I0 -qg" default-language: Haskell2010 executable example @@ -160,7 +162,7 @@ , wrecker , scotty , aeson-qq - , warp + , warp >= 3.2.4 , wreq , markdown-unlit , aeson @@ -173,7 +175,8 @@ , wai , network , connection - ghc-options: -O2 -Wall -Wno-unused-do-bind -O2 -threaded -pgmL markdown-unlit -rtsopts "-with-rtsopts=-N -I0 -qg" + , transformers + ghc-options: -Wall -fno-warn-unused-do-bind -threaded -pgmL markdown-unlit -rtsopts "-with-rtsopts=-N -I0 -qg" default-language: Haskell2010 test-suite wrecker-test @@ -199,5 +202,10 @@ , immortal , next-ref , connection - ghc-options: -Wall -Wno-unused-do-bind -O2 -threaded -pgmL markdown-unlit -rtsopts -with-rtsopts=-N + , transformers + ghc-options: -Wall -fno-warn-unused-do-bind -threaded -pgmL markdown-unlit -rtsopts "-with-rtsopts=-N -I0 -qg" default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/skedgeme/wrecker