A couple of improvements. (Yes, these should be separate commits.)

* Support for specifying the HTTP method to use.

* Help text for options.

* Dumping of test config in JSON form.

app/App.hs

@@ -7,57 +7,76 @@ import Control.Applicative ((<$>))
 import Control.Monad (forM_, unless)
 import Criterion.Analysis (SampleAnalysis(..), OutlierEffect(..),
                            OutlierVariance(..))
-import Data.Aeson (encode)
+import Data.Aeson ((.=), encode, object)
 import Data.Maybe (catMaybes)
 import Data.Monoid (mappend)
 import Data.Text (Text)
 import Data.Text.Buildable (build)
 import Data.Text.Lazy.Builder (Builder)
-import Network.HTTP.LoadTest (Analysis(..), Basic(..), NetworkError(..))
+import Network.HTTP.Enumerator as E (Request(..), parseUrl)
+import Network.HTTP.LoadTest (Analysis(..), Basic(..), NetworkError(..), Req(..))
 import Network.Socket (withSocketsDo)
 import Statistics.Resampling.Bootstrap (Estimate(..))
 import System.Console.CmdArgs
 import System.Exit (ExitCode(ExitFailure), exitWith)
 import System.IO (hPutStrLn, stderr)
+import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Text.Format as T
 import qualified Network.HTTP.LoadTest as LoadTest
 
 data Args = Args {
-      bootstrap :: Bool
-    , concurrency :: Int
-    , json :: Maybe FilePath
+      concurrency :: Int
+    , method :: String
     , num_requests :: Int
     , requests_per_second :: Double
     , timeout :: Double
     , url :: String
+
+    , bootstrap :: Bool
+    , json :: Maybe FilePath
     } deriving (Eq, Show, Typeable, Data)
 
 defaultArgs :: Args
 defaultArgs = Args {
-                bootstrap = def
-              , concurrency = 1
-              , json = def
+                concurrency = 1
+                &= groupname "Load testing"
+                &= help "Number of requests to issue concurrently"
+              , method = "GET" &= typ "METHOD"
+                &= help "HTTP method to use (GET, POST, ...)"
               , num_requests = 1
+                &= help "Total number of requests to issue"
               , requests_per_second = def
-              , timeout = 60
+                &= help "Maximum request rate to sustain"
+              , timeout = 60 &= typ "SECS"
+                &= help "Time to wait before killing a connection"
               , url = def &= argPos 0
+
+              , bootstrap = def
+                &= groupname "Analysis of results"
+                &= help "Statistically robust analysis of results"
+              , json = def &= typ "FILE"
+                &= help "Save analysis in JSON format"
               } &= verbosity
 
-fromArgs :: Args -> LoadTest.Config
-fromArgs Args{..} = LoadTest.Config {
-                      LoadTest.concurrency = concurrency
-                    , LoadTest.numRequests = num_requests
-                    , LoadTest.requestsPerSecond = requests_per_second
-                    , LoadTest.timeout = timeout
-                    , LoadTest.url = url
-                    }
+fromArgs :: Args -> Request IO -> LoadTest.Config
+fromArgs Args{..} req =
+    LoadTest.Config {
+      LoadTest.concurrency = concurrency
+    , LoadTest.numRequests = num_requests
+    , LoadTest.requestsPerSecond = requests_per_second
+    , LoadTest.timeout = timeout
+    , LoadTest.request = Req req
+    }
 
 main :: IO ()
 main = withSocketsDo $ do
-  as@Args{..} <- cmdArgs defaultArgs
+  as@Args{..} <- cmdArgs $ defaultArgs &= program "http-load-tester"
   validateArgs as
-  run <- LoadTest.run (fromArgs as)
+  req0 <- parseUrl url
+  let req = req0 { E.method = B.pack method }
+      cfg = fromArgs as req
+  run <- LoadTest.run cfg
   case run of
     Left [NetworkError err] ->
       T.hprint stderr "Error: {}" [show err] >> exitWith (ExitFailure 1)
@@ -70,9 +89,10 @@ main = withSocketsDo $ do
       analysis <- if bootstrap
                   then Right <$> LoadTest.analyseFull results
                   else return . Left . LoadTest.analyseBasic $ results
+      let dump = object [ "config" .= cfg, "analysis" .= analysis ]
       case json of
-        Just "-" -> L.putStrLn (encode analysis)
-        Just f   -> L.writeFile f (encode analysis)
+        Just "-" -> L.putStrLn (encode dump)
+        Just f   -> L.writeFile f (encode dump)
         _        -> return ()
       whenNormal $ either reportBasic reportFull analysis
 

http-load-tester.cabal

@@ -38,9 +38,12 @@ library
     aeson,
     base < 5,
     bytestring,
+    case-insensitive,
     criterion >= 0.5.1.0,
     http-enumerator,
+    http-types,
     statistics,
+    text,
     time,
     vector,
     vector-algorithms
@@ -59,6 +62,7 @@ executable http-load-tester
     bytestring,
     cmdargs >= 0.7,
     criterion,
+    http-enumerator,
     http-load-tester,
     network,
     statistics,

lib/Network/HTTP/LoadTest.hs

@@ -5,6 +5,7 @@ module Network.HTTP.LoadTest
     -- * Running a load test
       NetworkError(..)
     , Config(..)
+    , Req(..)
     , defaultConfig
     , run
     -- * Result analysis
@@ -28,17 +29,16 @@ import Network.HTTP.Enumerator
 import Network.HTTP.LoadTest.Types
 import Prelude hiding (catch)
 import Statistics.Quantile (weightedAvg)
-import qualified Statistics.Sample as S
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Vector as V
 import qualified Data.Vector.Algorithms.Intro as I
 import qualified Data.Vector.Generic as G
 import qualified Data.Vector.Unboxed as U
+import qualified Statistics.Sample as S
 import qualified System.Timeout as T
 
 run :: Config -> IO (Either [NetworkError] (V.Vector Summary))
 run cfg@Config{..} = do
-  req <- parseUrl url
   let reqs = zipWith (+) (replicate concurrency reqsPerThread)
                          (replicate leftover 1 ++ repeat 0)
         where (reqsPerThread,leftover) = numRequests `quotRem` concurrency
@@ -47,18 +47,16 @@ run cfg@Config{..} = do
                                           requestsPerSecond)
   ch <- newChan
   forM_ reqs $ \numReqs -> forkIO . withManager $ \mgr -> do
-    let cfg' = cfg {
-                numRequests = numReqs
-              }
-    writeChan ch =<< try (client cfg' mgr req interval)
+    let cfg' = cfg { numRequests = numReqs }
+    writeChan ch =<< try (client cfg' mgr interval)
   (errs,vs) <- partitionEithers <$> replicateM concurrency (readChan ch)
   return $ case errs of
              [] -> Right (V.concat vs)
              _  -> Left (nub errs)
 
-client :: Config -> Manager -> Request IO -> POSIXTime
+client :: Config -> Manager -> POSIXTime
        -> IO (V.Vector Summary)
-client Config{..} mgr req interval = loop 0 [] =<< getPOSIXTime
+client Config{..} mgr interval = loop 0 [] =<< getPOSIXTime
   where
     loop !n acc now
         | n == numRequests = return $! V.fromList (reverse acc)
@@ -74,7 +72,8 @@ client Config{..} mgr req interval = loop 0 [] =<< getPOSIXTime
       when (elapsed < interval) $
         threadDelay . truncate $ (interval - elapsed) * 1000000
       loop (n+1) (s:acc) =<< getPOSIXTime
-    issueRequest = httpLbs req mgr `catch` (throwIO . NetworkError)
+    issueRequest = httpLbs (fromReq request) mgr
+                   `catch` (throwIO . NetworkError)
     timedRequest
       | timeout == 0 = respEvent <$> issueRequest
       | otherwise    = do

lib/Network/HTTP/LoadTest/Types.hs

@@ -1,9 +1,11 @@
-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, RecordWildCards #-}
+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, RecordWildCards,
+    ScopedTypeVariables #-}
 
 module Network.HTTP.LoadTest.Types
     (
     -- * Running a load test
       Config(..)
+    , Req(..)
     , defaultConfig
     , NetworkError(..)
     -- * Results
@@ -16,26 +18,69 @@ module Network.HTTP.LoadTest.Types
     ) where
 
 import Control.Applicative ((<$>), (<*>), empty)
-import Control.Exception (Exception, IOException)
+import Control.Arrow (first)
+import Control.Exception (Exception, IOException, SomeException, try)
+import Data.Aeson.Types (Value(..), FromJSON(..), ToJSON(..), (.:), (.=), object)
 import Data.Data (Data)
-import Data.Aeson.Types (Value(Object), FromJSON(..), ToJSON(..), (.:), (.=), object)
 import Data.Typeable (Typeable)
+import Network.HTTP.Enumerator (Request(..), parseUrl)
+import Network.HTTP.Types (renderQuery)
+import System.IO.Unsafe
+import qualified Data.ByteString.Char8 as B
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Text as T
+
+newtype Req = Req {
+      fromReq :: Request IO
+    } deriving (Typeable)
+
+instance Show Req where
+    show (Req Request{..}) = concat [http, B.unpack host, portie, B.unpack path,
+                                     B.unpack (renderQuery True queryString)]
+        where http | secure = "https://"
+                   | otherwise = "http://"
+              isDefaultPort | secure    = port == 443
+                            | otherwise = port == 80
+              portie | isDefaultPort = ""
+                     | otherwise     = ":" ++ show port
+
+instance ToJSON Req where
+    toJSON req@(Req Request{..}) = toJSON [
+                                     "url" .= show req
+                                   , "method" .= method
+                                   , "headers" .= map (first CI.original)
+                                                  requestHeaders
+                                   ]
+
+instance FromJSON Req where
+    parseJSON (Object v) = do
+      (u,m,h) <- (,,) <$> (v .: "url") <*> (v .: "method") <*> (v .: "headers")
+      req <- unsafePerformIO $ do
+               t <- try $ parseUrl (T.unpack u)
+               return $ case t of
+                          Left (_::SomeException) -> empty
+                          Right r -> return r
+      return . Req $ req {
+                        method = m
+                      , requestHeaders = map (first CI.mk) h
+                      }
+    parseJSON _ = empty
 
 data Config = Config {
       concurrency :: Int
     , numRequests :: Int
     , requestsPerSecond :: Double
     , timeout :: Double
-    , url :: String
-    } deriving (Eq, Read, Show, Typeable, Data)
+    , request :: Req
+    } deriving (Show, Typeable)
 
 instance ToJSON Config where
     toJSON Config{..} = object [
                           "concurrency" .= concurrency
                         , "numRequests" .= numRequests
                         , "requestsPerSecond" .= requestsPerSecond
                         , "timeout" .= timeout
-                        , "url" .= url
+                        , "request" .= request
                         ]
 
 instance FromJSON Config where
@@ -44,16 +89,20 @@ instance FromJSON Config where
                            v .: "numRequests" <*>
                            v .: "requestsPerSecond" <*>
                            v .: "timeout" <*>
-                           v .: "url"
+                           v .: "request"
     parseJSON _ = empty
 
+emptyReq :: Req
+emptyReq = Req . unsafePerformIO $ parseUrl "http://127.0.0.1/"
+{-# NOINLINE emptyReq #-}
+
 defaultConfig :: Config
 defaultConfig = Config {
                 concurrency = 1
               , numRequests = 1
               , requestsPerSecond = 0
               , timeout = 60
-              , url = ""
+              , request = emptyReq
               }
 
 data Event =