Commits

Bryan O'Sullivan committed b6afb9d

Refactor the package into a library and a command line application.

Comments (0)

Files changed (4)

+{-# LANGUAGE BangPatterns, DeriveDataTypeable, OverloadedStrings,
+    RecordWildCards #-}
+
+module Main (main) where
+
+import Control.Monad (forM_, unless)
+import Data.Maybe (catMaybes)
+import Network.Socket (withSocketsDo)
+import Prelude hiding (catch)
+import System.Console.CmdArgs
+import System.Exit (ExitCode(ExitFailure), exitWith)
+import System.IO (hPutStrLn, stderr)
+import qualified Data.Text.Format as T
+import qualified Network.HTTP.LoadTest as LoadTest
+
+data Args = Args {
+      concurrency :: Int
+    , num_requests :: Int
+    , requests_per_second :: Double
+    , timeout :: Double
+    , url :: String
+    } deriving (Eq, Show, Typeable, Data)
+
+defaultArgs :: Args
+defaultArgs = Args {
+                concurrency = 1
+              , num_requests = 1
+              , requests_per_second = def
+              , timeout = 60
+              , url = def &= argPos 0
+              }
+
+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
+                    }
+
+main :: IO ()
+main = withSocketsDo $ do
+  as@Args{..} <- cmdArgs defaultArgs
+  validateArgs as
+  !results <- LoadTest.run (fromArgs as)
+  T.print "analysing results\n" ()
+  analysis <- LoadTest.analyse results
+  LoadTest.report analysis
+
+validateArgs :: Args -> IO ()
+validateArgs Args{..} = do
+  let p !? what | p         = Nothing
+                | otherwise = Just what
+      infix 1 !?
+      problems = catMaybes [
+         concurrency > 0 !? "--concurrency must be positive"
+       , num_requests > 0 !? "--num-requests must be positive"
+       , requests_per_second >= 0 !? "--requests-per-second cannot be negative"
+       , timeout >= 0 !? "--timeout cannot be negative"
+       ]
+  forM_ problems $ hPutStrLn stderr . ("Error: " ++)
+  unless (null problems) $ exitWith (ExitFailure 1)

http-load-tester.cabal

 name:                http-load-tester
-version:             0
+version:             0.1.0.0
 synopsis:            A small command line app for HTTP load testing
 description:
-  A small command line app for HTTP load testing.  You can think of it
-  as similar to `httperf` or `ab`, only it's more modern and simpler
-  to deal with.
+  A library and command line tool for HTTP load testing.  You can
+  think of this package as similar to `httperf` or `ab`, only more
+  modern, faster, more scalable, easier to deal with, and
+  programmable.
 homepage:            https://github.com/mailrank/http-load-tester
 license:             BSD3
 license-file:        LICENSE
 extra-source-files:  
     README.markdown
 
-executable http-load-tester
-  hs-source-dirs: src
-  main-is:        LoadTester.hs
+library
+  hs-source-dirs: lib
+  exposed-modules:
+    Network.HTTP.LoadTest
 
-  ghc-options: -threaded -rtsopts -Wall
+  ghc-options: -Wall
 
   build-depends:
     base < 5,
     bytestring,
-    cmdargs >= 0.7,
     criterion >= 0.5.1.0,
     http-enumerator,
-    network,
     statistics,
     text,
     text-format,
     vector,
     vector-algorithms
 
+executable http-load-tester
+  hs-source-dirs: app
+  main-is:        App.hs
+
+  ghc-options: -threaded -rtsopts -Wall
+
+  build-depends:
+    base < 5,
+    cmdargs >= 0.7,
+    http-load-tester,
+    network,
+    text-format
+
 source-repository head
   type:     git
   location: git://github.com/mailrank/http-load-tester

lib/Network/HTTP/LoadTest.hs

+{-# LANGUAGE BangPatterns, DeriveDataTypeable, OverloadedStrings,
+    RecordWildCards, ScopedTypeVariables #-}
+
+module Network.HTTP.LoadTest
+    (
+    -- * Running a load test
+      Config(..)
+    , defaultConfig
+    , run
+    -- * Results
+    , Event(..)
+    , Summary(..)
+    , summEnd
+    -- * Result analysis
+    , Analysis(..)
+    , analyse
+    , report
+    ) where
+
+import Control.Applicative ((<$>))
+import Control.Concurrent (forkIO, threadDelay)
+import Control.Concurrent.Chan (newChan, readChan, writeChan)
+import Control.Exception (IOException, catch)
+import Control.Monad (forM_, replicateM, when)
+import Criterion.Analysis (OutlierEffect(..), OutlierVariance(..),
+                           SampleAnalysis(..), analyseSample, scale)
+import Data.Data (Data)
+import Data.Function (on)
+import Data.Monoid (mappend)
+import Data.Text (Text)
+import Data.Text.Buildable (build)
+import Data.Text.Lazy.Builder (Builder)
+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
+import Data.Typeable (Typeable)
+import Network.HTTP.Enumerator
+import Prelude hiding (catch)
+import Statistics.Quantile (weightedAvg)
+import Statistics.Resampling.Bootstrap (Estimate(..))
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Text.Format as T
+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 System.Timeout as T
+
+data Config = Config {
+      concurrency :: Int
+    , numRequests :: Int
+    , requestsPerSecond :: Double
+    , timeout :: Double
+    , url :: String
+    } deriving (Eq, Read, Show, Typeable, Data)
+
+defaultConfig :: Config
+defaultConfig = Config {
+                concurrency = 1
+              , numRequests = 1
+              , requestsPerSecond = 0
+              , timeout = 60
+              , url = ""
+              }
+
+data Event =
+    HttpResponse {
+      respCode :: {-# UNPACK #-} !Int
+    , respLength :: {-# UNPACK #-} !Int
+    } | NetworkError
+      | Timeout
+      | Done
+    deriving (Eq, Read, Show, Typeable, Data)
+
+data Summary = Summary {
+      summEvent :: Event
+    , summElapsed :: {-# UNPACK #-} !Double
+    , summStart :: {-# UNPACK #-} !Double
+    } deriving (Eq, Read, Show, Typeable, Data)
+
+summEnd :: Summary -> Double
+summEnd Summary{..} = summStart + summElapsed
+
+run :: Config -> IO (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
+  let !interval | requestsPerSecond == 0 = 0
+                | otherwise = realToFrac (fromIntegral concurrency /
+                                          requestsPerSecond)
+  ch <- newChan
+  forM_ reqs $ \numReqs -> forkIO . withManager $ \mgr -> do
+    let cfg' = cfg {
+                numRequests = numReqs
+              }
+    writeChan ch =<< client cfg' mgr req interval
+  V.concat <$> replicateM concurrency (readChan ch)
+
+client :: Config -> Manager -> Request IO -> POSIXTime
+       -> IO (V.Vector Summary)
+client Config{..} mgr req interval = loop 0 [] =<< getPOSIXTime
+  where
+    loop !n acc now
+        | n == numRequests = return $! V.fromList (reverse acc)
+        | otherwise = do
+      !evt <- timedRequest `catch`
+              \(_::IOException) -> closeManager mgr >> return NetworkError
+      now' <- getPOSIXTime
+      let elapsed = now' - now
+          !s = Summary {
+                 summEvent = evt
+               , summElapsed = realToFrac elapsed
+               , summStart = realToFrac now'
+               }
+      when (elapsed < interval) $
+        threadDelay . truncate $ (interval - elapsed) * 1000000
+      loop (n+1) (s:acc) =<< getPOSIXTime
+    issueRequest = httpLbs req mgr
+    timedRequest
+      | timeout == 0 = respEvent <$> issueRequest
+      | otherwise    = do
+      maybeResp <- T.timeout (truncate (timeout * 1e6)) issueRequest
+      case maybeResp of
+        Just resp -> return (respEvent resp)
+        _         -> closeManager mgr >> return Timeout
+
+respEvent :: Response -> Event
+respEvent resp = HttpResponse {
+                   respCode = statusCode resp
+                 , respLength = fromIntegral . L.length . responseBody $ resp
+                 }
+
+data Analysis = Analysis {
+      latency :: SampleAnalysis
+    , latency99 :: Double
+    , latency999 :: Double
+    , throughput :: SampleAnalysis
+    , throughput10 :: Double
+    } deriving (Eq, Show, Typeable, Data)
+
+analyse :: V.Vector Summary -> IO Analysis
+analyse sums = do
+  let sumv = sortBy (compare `on` summStart) sums
+      start = summStart . G.head $ sumv
+      end = summEnd . G.last $ sumv
+      elapsed = end - start
+      timeSlice = min elapsed 1 / 200
+      slices = U.unfoldrN (round (elapsed / timeSlice)) go (sumv,1)
+        where go (v,i) = let (a,b) = G.span (\s -> summStart s <= t) v
+                             t = start + (i * timeSlice)
+                         in Just (fromIntegral $ G.length a,(b,i+1))
+      ci = 0.95
+      resamples = 10 * 1000
+  l <- analyseSample ci (G.convert . G.map summElapsed $ sumv) resamples
+  t <- analyseSample ci slices resamples
+  return Analysis {
+                 latency = l
+               , latency99 = weightedAvg 99 100 . G.map summElapsed $ sumv
+               , latency999 = weightedAvg 999 1000 . G.map summElapsed $ sumv
+               , throughput = scale (recip timeSlice) t
+               , throughput10 = (/ timeSlice) . weightedAvg 10 100 $ slices
+    }
+
+time :: Double -> Builder
+time t
+     | t < 1e-3  = build (t * 1e6) `mappend` " usec"
+     | t < 1     = build (t * 1e3) `mappend` " msec"
+     | otherwise = build t `mappend` " sec"
+
+report :: Analysis -> IO ()
+report Analysis{..} = do
+  T.print "latency:\n    mean:    {}\n    std dev: {}\n"
+    (time (estPoint (anMean latency)), time (estPoint (anStdDev latency)))
+  effect (anOutliers latency)
+  T.print "    99%:     {}\n    99.9%:   {}\n" (time latency99, time latency999)
+  T.print "\nthroughput:\n    mean:    {} req/sec\n    std dev: {} req/sec\n"
+    (estPoint (anMean throughput), estPoint (anStdDev throughput))
+  effect (anOutliers throughput)
+  T.print "    10%:     {} req/sec\n" [throughput10]
+
+effect :: OutlierVariance -> IO ()
+effect OutlierVariance{..} =
+    case ovEffect of
+      Unaffected -> return ()
+      _ -> T.print "    estimates {} affected by outliers ({}%)\n"
+           (howMuch, T.fixed 1 (ovFraction * 100))
+    where howMuch = case ovEffect of
+                      Unaffected -> "not" :: Text
+                      Slight     -> "slightly"
+                      Moderate   -> "moderately"
+                      Severe     -> "severely"
+
+-- | Sort a vector.
+sortBy :: (G.Vector v e) => I.Comparison e -> v e -> v e
+sortBy cmp = G.modify (I.sortBy cmp)
+{-# INLINE sortBy #-}

src/LoadTester.hs

-{-# LANGUAGE BangPatterns, DeriveDataTypeable, OverloadedStrings,
-    RecordWildCards, ScopedTypeVariables #-}
-
-module Main (main) where
-
-import Control.Applicative ((<$>))
-import Control.Concurrent (forkIO, threadDelay)
-import Control.Concurrent.Chan (newChan, readChan, writeChan)
-import Control.Exception (IOException, catch)
-import Control.Monad (forM_, replicateM, unless, when)
-import Criterion.Analysis
-    (OutlierEffect(..), OutlierVariance(..), SampleAnalysis(..),
-     analyseSample, scale)
-import Data.Function (on)
-import Data.Maybe (catMaybes)
-import Data.Monoid
-import Data.Text (Text)
-import Data.Text.Buildable
-import Data.Text.Lazy.Builder
-import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
-import Network.HTTP.Enumerator
-import Network.Socket (withSocketsDo)
-import Prelude hiding (catch)
-import Statistics.Quantile (weightedAvg)
-import Statistics.Resampling.Bootstrap (Estimate(..))
-import System.Console.CmdArgs
-import System.Exit (ExitCode(ExitFailure), exitWith)
-import System.IO (hPutStrLn, stderr)
-import qualified Data.ByteString.Lazy as L
-import qualified Data.Text.Format as T
-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 System.Timeout as T
-
-data Args = Args {
-      concurrency :: Int
-    , num_requests :: Int
-    , requests_per_second :: Double
-    , timeout :: Double
-    , url :: String
-    } deriving (Eq, Show, Typeable, Data)
-
-defaultArgs :: Args
-defaultArgs = Args {
-                concurrency = 1
-              , num_requests = 1
-              , requests_per_second = def
-              , timeout = 60
-              , url = def &= argPos 0
-              }
-
-data Event =
-    HttpResponse {
-      respCode :: {-# UNPACK #-} !Int
-    , respLength :: {-# UNPACK #-} !Int
-    } | NetworkError
-      | Timeout
-      | Done
-    deriving (Eq, Show)
-
-data Summary = Summary {
-      summEvent :: Event
-    , summElapsed :: {-# UNPACK #-} !Double
-    , summStart :: {-# UNPACK #-} !Double
-    } deriving (Eq, Show)
-
-summEnd :: Summary -> Double
-summEnd Summary{..} = summStart + summElapsed
-
-main :: IO ()
-main = withSocketsDo $ do
-  as@Args{..} <- cmdArgs defaultArgs
-  validateArgs as
-  req <- parseUrl url
-  let reqs = zipWith (+) (replicate concurrency reqsPerThread)
-                         (replicate leftover 1 ++ repeat 0)
-        where (reqsPerThread,leftover) = num_requests `quotRem` concurrency
-  let !interval | requests_per_second == 0 = 0
-                | otherwise = realToFrac (fromIntegral concurrency /
-                                          requests_per_second)
-  ch <- newChan
-  forM_ reqs $ \numReqs -> forkIO . withManager $ \mgr -> do
-    let as' = as {
-                num_requests = numReqs
-              }
-    writeChan ch =<< client as' mgr req interval
-  results <- V.concat <$> replicateM concurrency (readChan ch)
-  putStrLn "analysing results"
-  report =<< analyse results
-
-client :: Args -> Manager -> Request IO -> POSIXTime
-       -> IO (V.Vector Summary)
-client Args{..} mgr req interval = loop 0 [] =<< getPOSIXTime
-  where
-    loop !n acc now
-        | n == num_requests = return $! V.fromList (reverse acc)
-        | otherwise = do
-      !evt <- timedRequest `catch`
-              \(_::IOException) -> closeManager mgr >> return NetworkError
-      now' <- getPOSIXTime
-      let elapsed = now' - now
-          !s = Summary {
-                 summEvent = evt
-               , summElapsed = realToFrac elapsed
-               , summStart = realToFrac now'
-               }
-      when (elapsed < interval) $
-        threadDelay . truncate $ (interval - elapsed) * 1000000
-      loop (n+1) (s:acc) =<< getPOSIXTime
-    issueRequest = httpLbs req mgr
-    timedRequest
-      | timeout == 0 = respEvent <$> issueRequest
-      | otherwise    = do
-      maybeResp <- T.timeout (truncate (timeout * 1e6)) issueRequest
-      case maybeResp of
-        Just resp -> return (respEvent resp)
-        _         -> closeManager mgr >> return Timeout
-
-respEvent :: Response -> Event
-respEvent resp = HttpResponse {
-                   respCode = statusCode resp
-                 , respLength = fromIntegral . L.length . responseBody $ resp
-                 }
-
-validateArgs :: Args -> IO ()
-validateArgs Args{..} = do
-  let p !? what | p         = Nothing
-                | otherwise = Just what
-      infix 1 !?
-      problems = catMaybes [
-         concurrency > 0 !? "--concurrency must be positive"
-       , num_requests > 0 !? "--num-requests must be positive"
-       , requests_per_second >= 0 !? "--requests-per-second cannot be negative"
-       , timeout >= 0 !? "--timeout cannot be negative"
-       ]
-  forM_ problems $ hPutStrLn stderr . ("Error: " ++)
-  unless (null problems) $ exitWith (ExitFailure 1)
-
-data Analysis = Analysis {
-      latency :: SampleAnalysis
-    , latency99 :: Double
-    , latency999 :: Double
-    , throughput :: SampleAnalysis
-    , throughput10 :: Double
-    } deriving (Show)
-
-analyse :: V.Vector Summary -> IO Analysis
-analyse sums = do
-  let sumv = sortBy (compare `on` summStart) sums
-      start = summStart . G.head $ sumv
-      end = summEnd . G.last $ sumv
-      elapsed = end - start
-      timeSlice = min elapsed 1 / 200
-      slices = U.unfoldrN (round (elapsed / timeSlice)) go (sumv,1)
-        where go (v,i) = let (a,b) = G.span (\s -> summStart s <= t) v
-                             t = start + (i * timeSlice)
-                         in Just (fromIntegral $ G.length a,(b,i+1))
-      ci = 0.95
-      resamples = 10 * 1000
-  l <- analyseSample ci (G.convert . G.map summElapsed $ sumv) resamples
-  t <- analyseSample ci slices resamples
-  return Analysis {
-                 latency = l
-               , latency99 = weightedAvg 99 100 . G.map summElapsed $ sumv
-               , latency999 = weightedAvg 999 1000 . G.map summElapsed $ sumv
-               , throughput = scale (recip timeSlice) t
-               , throughput10 = (/ timeSlice) . weightedAvg 10 100 $ slices
-    }
-
-time :: Double -> Builder
-time t
-     | t < 1e-3  = build (t * 1e6) `mappend` " usec"
-     | t < 1     = build (t * 1e3) `mappend` " msec"
-     | otherwise = build t `mappend` " sec"
-
-report :: Analysis -> IO ()
-report Analysis{..} = do
-  T.print "latency:\n    mean:    {}\n    std dev: {}\n"
-    (time (estPoint (anMean latency)), time (estPoint (anStdDev latency)))
-  effect (anOutliers latency)
-  T.print "    99%:     {}\n    99.9%:   {}\n" (time latency99, time latency999)
-  T.print "\nthroughput:\n    mean:    {} req/sec\n    std dev: {} req/sec\n"
-    (estPoint (anMean throughput), estPoint (anStdDev throughput))
-  effect (anOutliers throughput)
-  T.print "    10%:     {} req/sec\n" [throughput10]
-
-effect :: OutlierVariance -> IO ()
-effect OutlierVariance{..} =
-    case ovEffect of
-      Unaffected -> return ()
-      _ -> T.print "    estimates {} affected by outliers ({}%)\n"
-           (howMuch, T.fixed 1 (ovFraction * 100))
-    where howMuch = case ovEffect of
-                      Unaffected -> "not" :: Text
-                      Slight     -> "slightly"
-                      Moderate   -> "moderately"
-                      Severe     -> "severely"
-
--- | Sort a vector.
-sortBy :: (G.Vector v e) => I.Comparison e -> v e -> v e
-sortBy cmp = G.modify (I.sortBy cmp)
-{-# INLINE sortBy #-}