diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,10 @@ +## 0.1.1.0 + +- `uhttpc-bench`: Add support for round-robin POST requests from file +- `uhttpc-bench`: Converted to `optparse-applicative` +- Fix `ssUnread` being incorrect when push-back buffer is non-empty +- Minor optimization reducing `IORef` contention + +## 0.1.0.0 + +- Initial release diff --git a/Network/HTTP/MicroClient.hs b/Network/HTTP/MicroClient.hs --- a/Network/HTTP/MicroClient.hs +++ b/Network/HTTP/MicroClient.hs @@ -47,7 +47,9 @@ , getPOSIXTimeUSecs ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative +#endif import Control.DeepSeq (NFData(rnf),deepseq) import Control.Exception import Control.Monad @@ -208,7 +210,7 @@ -- |Push-back read data into 'SockStream' ssUnRead :: ByteString -> SockStream -> IO () ssUnRead buf0 ss@(SockStream _ bufref _ _ _) = - ssDebug "ssUnRead" ss $ modifyIORef' bufref (<> buf0) + ssDebug "ssUnRead" ss $ modifyIORef' bufref (buf0 <>) -- |Returns length of data consumed (i.e. w/o 'ssUnRead' data) ssReadCnt :: SockStream -> IO Word64 @@ -253,7 +255,7 @@ | TeInvalid deriving (Show,Eq) -instance NFData TransferEncoding +instance NFData TransferEncoding where rnf !_ = () -- |Extract information from the header lines as returned by 'recvHttpHeaders' -- diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,115 @@ +# `uhttpc` - µHTTP client library + +`uhttpc` is a simple low-level and lightweight Haskell HTTP 1.1 +library providing the bare minimum required for HTTP benchmarking +purposes. + +This is **not** a RFC compliant HTTP client library and **shall not** +be used as a general purpose HTTP implementation! + +# `uhttpc-bench` + +This Cabal package comes with an executable `uhttpc-bench` which +represents an `ab`/`weighttpd`-style HTTP benchmarking tool: + + uhttpc-bench - a Haskell-based ab/weighttp-style webserver benchmarking tool + + Simple HTTP benchmark tool similiar to ab and weighttp + + uttpc-bench [OPTIONS] + + Common flags: + -n=num number of requests (default: 1) + -t=num threadcount (default: 1) + -c=num concurrent clients (default: 1) + -k enable keep alive + --csv=FILE dump request timings as CSV (RFC4180) file + --user-agent=ITEM specify User-Agent (default: "httpc-bench") + -H=str add header to request + -v --verbose enable more verbose statistics and output + --no-stats disable statistics + -p=FILE perform POST request with file-content as body + -l=FILE perform a POST request per line, no quoting, + round-robin, each client independently + -? --help Display help message + -V --version Print version information + +# How to use it + +First, install the `uhttpc` package +(This requires GHC 7.6.x or later) + + $ cabal install uhttpc + +A simple example invocation: + + $ uhttpc-bench -n 100000 -t1 -c3 -k http://localhost/ + + uhttpc-bench - a Haskell-based ab/weighttp-style webserver benchmarking tool + + starting benchmark... + finished in 2.314289 seconds, 100000 reqs (3 conns), 43209.8 req/s received + status codes: 100000 HTTP-200 + data received: 36205.098 KiB/s, 85800000 bytes total (24600000 bytes http + 61200000 bytes content) + rtt min/avg/max = 0.034/0.068/4.252 ms + +For comparison, [`weighttp`](https://github.com/lighttpd/weighttp) can be invoked with the very same arguments (in this case at least): + + $ weighttp -n 100000 -t1 -c3 -k http://localhost/ + + weighttp - a lightweight and simple webserver benchmarking tool + + starting benchmark... + spawning thread #1: 3 concurrent requests, 100000 total requests + + finished in 2 sec, 333 millisec and 421 microsec, 42855 req/s, 35908 kbyte/s + requests: 100000 total, 100000 started, 100000 done, 100000 succeeded, 0 failed, 0 errored + status codes: 100000 2xx, 0 3xx, 0 4xx, 0 5xx + traffic: 85800000 bytes total, 24600000 bytes http, 61200000 bytes data + +Another example invocation of `uhttpc-bench`: + + $ uhttpc-bench http://www.google.com/ -v -c8 -n1000 + + uhttpc-bench - a Haskell-based ab/weighttp-style webserver benchmarking tool + + using 88-byte request header (+ 0-byte body): + "GET / HTTP/1.1\r\nHost: www.google.com:80\r\nUser-Agent: uhttpc-bench\r\nConnection: close\r\n\r\n" + + starting benchmark... + + per-client stats: + + client spawned +0.000008 s, 125 reqs (125 conns), 8.1 req/s, finished in 15.369619 s + rtt min/avg/med/max = 99.586/122.902/122.109/167.193 ms + + client spawned +0.000258 s, 125 reqs (125 conns), 8.1 req/s, finished in 15.383278 s + rtt min/avg/med/max = 100.494/123.012/121.648/184.555 ms + + client spawned +0.000292 s, 125 reqs (125 conns), 8.1 req/s, finished in 15.365843 s + rtt min/avg/med/max = 98.721/122.872/121.668/163.810 ms + + client spawned +0.000327 s, 124 reqs (124 conns), 8.1 req/s, finished in 15.346788 s + rtt min/avg/med/max = 103.008/123.709/122.834/174.003 ms + + client spawned +0.000366 s, 126 reqs (126 conns), 8.2 req/s, finished in 15.367205 s + rtt min/avg/med/max = 95.255/121.907/120.736/152.943 ms + + client spawned +0.000403 s, 124 reqs (124 conns), 8.1 req/s, finished in 15.357957 s + rtt min/avg/med/max = 97.730/123.800/123.569/162.326 ms + + client spawned +0.000434 s, 125 reqs (125 conns), 8.1 req/s, finished in 15.388717 s + rtt min/avg/med/max = 103.056/123.055/121.961/162.419 ms + + client spawned +0.000461 s, 126 reqs (126 conns), 8.2 req/s, finished in 15.394365 s + rtt min/avg/med/max = 102.114/122.123/121.289/151.520 ms + + finished in 15.394867 seconds, 1000 reqs (1000 conns), 65.0 req/s received + status codes: 1000 HTTP-302 + data received: 63.498 KiB/s, 1001000 bytes total (783000 bytes http + 218000 bytes content) + rtt 2/9|25/50/75|91/98-th quantile = 103.737/108.696 | 115.124/121.688/129.944 | 137.715/148.159 ms + rtt min/avg/max = 95.255/122.919/184.555 ms + + +The `--csv` option allows to export the raw measurement data in format +suitable for offline analysis with statistical tools such as [`R`](http://www.r-project.org). diff --git a/src-exe/uhttpc-bench.hs b/src-exe/uhttpc-bench.hs --- a/src-exe/uhttpc-bench.hs +++ b/src-exe/uhttpc-bench.hs @@ -1,9 +1,14 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, RecordWildCards, BangPatterns #-} +{-# LANGUAGE Arrows #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Main (main) where import Control.Concurrent import Control.Concurrent.Async +import Control.DeepSeq (deepseq) import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -18,7 +23,8 @@ import GHC.Conc.Sync (numCapabilities,getNumProcessors) import Network.HTTP.MicroClient import Network.Socket hiding (send, sendTo, recv, recvFrom) -import System.Console.CmdArgs.Implicit +import Options.Applicative +import Options.Applicative.Arrows import System.IO import System.Mem (performGC) import Text.Printf @@ -53,44 +59,62 @@ , argWait :: Double , argUrl :: String , argPostFn :: FilePath + , argPostList :: FilePath } deriving (Show,Data,Typeable) -defaultArgs :: Args -defaultArgs = Args - { argNumReq = 1 &= typ "num" &= name "n" &= explicit - &= help "number of requests (default: 1)" - , argThrCnt = numCapabilities &= typ "num" &= explicit &= name "t" - &= help ("threadcount (default: " ++ show numCapabilities ++ ")") - , argClnCnt = 1 &= typ "num" &= name "c" &= explicit - &= help "concurrent clients (default: 1)" - , argKeepAlive = def &= name "k" &= explicit - &= help "enable keep alive" - , argHdrs = def &= typ "str" &= name "H" &= explicit - &= help "add header to request" - , argUA = "uhttpc-bench" &= name "user-agent" &= explicit - &= help "specify User-Agent (default: \"httpc-bench\")" - , argCsv = def &= typFile &= name "csv" &= explicit - &= help "dump request timings as CSV (RFC4180) file" - , argVerbose = def &= name "v" &= name "verbose" &= explicit - &= help "enable more verbose statistics and output" - , argNoStats = def &= name "no-stats" &= explicit - &= help "disable statistics" - , argPostFn = def &= typFile &= name "p" &= explicit - &= help "perform POST request with file-content as body" - , argLAddr = def &= typ "addr" &= name "local-addr" &= explicit - &= help "set specific source address for TCP connections" - , argWait = def &= typ "sec" &= name "wait" &= explicit - &= help "wait time between requests (per client) in seconds" - , argUrl = def &= argPos 0 &= typ "" - } &= program "uttpc-bench" - &= summary "Simple HTTP benchmarking tool similiar to 'ab' and 'weighttp'" +argsParser :: Parser Args +argsParser = runA $ proc () -> do + argNumReq <- asA (option auto $ value 1 <> metavar "NUM" <> short 'n' + <> help "number of requests" <> showDefault) -< () + argThrCnt <- asA (option auto $ value numCapabilities <> metavar "NUM" <> short 't' + <> help "thread-count" <> showDefault) -< () + argClnCnt <- asA (option auto $ value 1 <> metavar "NUM" <> short 'c' + <> help "concurrent clients" <> showDefault) -< () + + argKeepAlive <- asA (switch $ short 'k' <> help "enable keep alive") -< () + + argHdrs <- asA (many (option str $ metavar "STR" <> short 'H' + <> help "add header to request")) -< () + + argUA <- asA (option str $ value "httpc-bench" <> metavar "UA" <> long "user-agent" + <> help "specify User-Agent header" <> showDefault) -< () + + argCsv <- asA (option str $ value "" <> metavar "FILE" <> long "csv" + <> help "dump request timings as CSV (RFC4180) file") -< () + + argVerbose <- asA (switch $ short 'v' <> long "verbose" + <> help "enable more verbose statistics and output") -< () + + argNoStats <- asA (switch $ long "no-stats" + <> help "disable statistics") -< () + + argPostFn <- asA (option str $ value "" <> metavar "FILE" <> short 'p' + <> help "perform POST request with file-content as body") -< () + + argPostList <- asA (option str $ value "" <> metavar "FILE" <> short 'l' + <> help "perform a POST request per line, no quoting, round-robin, each client independently") -< () + + argLAddr <- asA (option str $ value "" <> metavar "IPADDR" <> long "local-addr" + <> help "set specific source address for TCP connections") -< () + + argWait <- asA (option auto $ value 0.0 <> metavar "SECS" <> long "wait" + <> help "wait time between requests (per client) in seconds" + <> showDefault) -< () + + argUrl <- asA (argument str (metavar "")) -< () + + returnA -< Args {..} + + main :: IO () main = runInUnboundThread $ do putStrLn "uhttpc-bench - a Haskell-based ab/weighttp-style webserver benchmarking tool\n" - pargs <- cmdArgs defaultArgs + pargs <- execParser (info (helper <*> argsParser) + (fullDesc <> header "Simple HTTP benchmarking tool similiar to 'ab' and 'weighttp'") + ) let verbose = argVerbose pargs (hostname,portnum,urlpath) <- either fail return $ splitUrl (argUrl pargs) @@ -137,41 +161,68 @@ putStrLn "*WARNING* client-count should be >= thread-count" ---------------------------------------------------------------------------- - let isPost = not $ null (argPostFn pargs) + let postOrGet = if null (argPostFn pargs) && null (argPostList pargs) + then GET + else POST - rawreqb <- if isPost - then fmap Just $ B.readFile (argPostFn pargs) - else return Nothing + when (verbose && not (null (argPostList pargs))) $ + putStrLn "reading the input file and preparing requests...\n" + bodyList <- if not (null $ argPostList pargs) -- overrides argPostFn + then fmap (take (fI $ argNumReq pargs) -- will at most use this + . map Just + . B8.lines) + $ B.readFile (argPostList pargs) + else if not (null $ argPostFn pargs) + then fmap (map Just . (: [])) $ B.readFile (argPostFn pargs) + else return [Nothing] + let hdrs | null (argUA pargs) = map B8.pack (argHdrs pargs) | otherwise = "User-Agent: " <> B8.pack (argUA pargs) : map B8.pack (argHdrs pargs) + mkRawreq :: Maybe B8.ByteString -> IO ByteString + mkRawreq rawreqb = do + let rawreqblen = maybe 0 B.length rawreqb + msg = mkHttp11Req postOrGet + (B8.pack urlpath) + ("Host: " <> B8.pack hostname + <> ":" <> B8.pack (show portnum)) + (argKeepAlive pargs) + hdrs + rawreqb + -- Printed when preparing the requests, not when sending. + when verbose $ + printf "using %d-byte request message (%d-byte body):\n %s\n\n" + (B.length msg) rawreqblen (show msg) + return $! msg - rawreqblen = maybe 0 B.length rawreqb - rawreq = mkHttp11Req (if isPost then POST else GET) - (B8.pack urlpath) - ("Host: " <> B8.pack hostname <> ":" <> B8.pack (show portnum)) - (argKeepAlive pargs) - hdrs - rawreqb + rawreqList <- mapM mkRawreq bodyList + let reqList = cycle rawreqList - when verbose $ - printf "using %d-byte request message (%d-byte body):\n %s\n\n" (B.length rawreq) rawreqblen (show rawreq) + -- We make sure the list is fully evaluated _before_ we send anything. + rawreqList `deepseq` + when (verbose && not (null (argPostList pargs))) $ + putStrLn $ show (length rawreqList) ++ " request(s) prepared\n" putStrLn "starting benchmark..." reqCounter <- newIORef (fI (argNumReq pargs) :: Int) + let clnCnt = fI $ argClnCnt pargs + performGC ts0' <- getTS - tss <- mapConcurrently (\() -> timeIO (doReqs lsa sa reqCounter rawreq (argWait pargs))) - (replicate (fI $ argClnCnt pargs) ()) + + tss <- if clnCnt == 1 + then mapM (\() -> timeIO (doReqsAll lsa sa reqCounter reqList (argWait pargs))) [()] + else mapConcurrently (\() -> timeIO (doReqs lsa sa reqCounter reqList (argWait pargs))) + (replicate clnCnt ()) ts1' <- getTS performGC numReqs' <- readIORef reqCounter unless (numReqs' + fI (argClnCnt pargs) == 0) $ - fail "virtual clients exited prematurely!" + fail $ "virtual clients exited prematurely! " ++ show numReqs' unless (argNoStats pargs) $ do when verbose $ do @@ -262,16 +313,17 @@ hist xs = [ (head g, length g) | g <- group (sort xs) ] -- |repeat executing 'doReq' until req-counter goes below 0 -doReqs :: Maybe SockAddr -> SockAddr -> IORef Int -> ByteString -> Double -> IO [Entry] -doReqs lsa sa cntref req wtime = go Nothing [] +doReqs :: Maybe SockAddr -> SockAddr -> IORef Int -> [ByteString] -> Double -> IO [Entry] +doReqs lsa sa cntref reqList wtime = go Nothing [] reqList where - go ss a = do + go _ _ [] = fail "internal error: request list ran out" + go ss a (req : rest) = do notDone <- decReqCounter cntref if notDone then do (ss',r) <- doReq lsa sa ss req when (wtimeUsecs > 0) $ threadDelay wtimeUsecs - go ss' (r:a) + go ss' (r:a) rest else do maybe (return ()) ssClose ss return a @@ -279,6 +331,26 @@ wtimeUsecs = floor $ 1000000 * wtime decReqCounter cnt = atomicModifyIORef' cnt (\n -> (n-1,n>0)) + +-- | Version of 'doReqs' that does all requests as indicated by req-counter at once +-- +-- This updates the IORef only once and thus avoids additional overhead +doReqsAll :: Maybe SockAddr -> SockAddr -> IORef Int -> [ByteString] -> Double -> IO [Entry] +doReqsAll lsa sa cntref reqList wtime = do + n <- atomicModifyIORef' cntref (\n -> (n-(max 0 (n+1)),(max 0 n))) + go Nothing [] n reqList + where + go _ _ _ [] = fail "internal error: request list ran out" + go ss a cnt (req : rest) + | cnt > 0 = do + (ss',r) <- doReq lsa sa ss req + when (wtimeUsecs > 0) $ threadDelay wtimeUsecs + go ss' (r:a) (cnt-1) rest + | otherwise = do + maybe (return ()) ssClose ss + return a + + wtimeUsecs = floor $ 1000000 * wtime -- |single measurement entry data Entry = Entry diff --git a/uhttpc.cabal b/uhttpc.cabal --- a/uhttpc.cabal +++ b/uhttpc.cabal @@ -1,12 +1,12 @@ name: uhttpc -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Minimal HTTP client library optimized for benchmarking homepage: https://github.com/hvr/uhttpc license: GPL-3 license-file: LICENSE author: Herbert Valerio Riedel maintainer: hvr@gnu.org -copyright: © 2013 Herbert Valerio Riedel +copyright: © 2013-2015 Herbert Valerio Riedel category: Network build-type: Simple cabal-version: >=1.10 @@ -32,6 +32,8 @@ instead which aim toward full RFC compliance as well as having good performance. +extra-source-files: README.md CHANGELOG.md + library default-language: Haskell2010 other-extensions: BangPatterns, CPP, OverloadedStrings @@ -39,15 +41,16 @@ ghc-options: -Wall -fwarn-tabs c-sources: cbits/get_posix_time.c build-depends: - base >=4.6 && <4.8, + base >=4.6 && <4.9, bytestring ==0.10.*, - network >=2.4.0.1 && <2.6, - bytestring-lexing ==0.4.*, - deepseq ==1.3.* + network ==2.6.*, + network-uri ==2.6.*, + bytestring-lexing >=0.4 && <0.6, + deepseq >=1.1 && <1.5 executable uhttpc-bench default-language: Haskell2010 - other-extensions: BangPatterns, DeriveDataTypeable, OverloadedStrings, RecordWildCards + other-extensions: Arrows, BangPatterns, DeriveDataTypeable, OverloadedStrings, RecordWildCards hs-source-dirs: src-exe main-is: uhttpc-bench.hs ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded -rtsopts @@ -57,12 +60,11 @@ base, bytestring, bytestring-lexing, + deepseq, network, -- build-deps which need version bounds - async ==2.0.*, - bytestring-lexing ==0.4.*, - cmdargs ==0.10.* - + async ==2.0.*, + optparse-applicative ==0.11.* Source-Repository head Type: git