1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
{-# LANGUAGE BangPatterns, FlexibleContexts, OverloadedStrings #-}
import Text.Printf
import qualified Data.Attoparsec.ByteString as A (feed, parseWith, IResult(..), parse)
import qualified Data.Attoparsec.ByteString.Char8 as C
import RFC2616
import Control.Exception
import Control.Concurrent.QSemN
import Control.Monad
import Network.Socket hiding (connect)
import System.Console.GetOpt
import Data.Monoid
import GHC.Conc (numCapabilities)
import Args (ljust, parseArgs, positive, theLast)
import Control.Concurrent (forkIO)
import System.Environment (getArgs)
import qualified Data.ByteString.Char8 as B
import Text.Parsec
import Text.Parsec.String
import Data.Char (isSpace)
import GHC.Event (ensureIOManagerIsRunning)
import EventSocket (connect, recv, sendAll)
import Data.Time.Clock (diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
import qualified Data.Semigroup as S
type URL = (String, String, String)
url :: Parser URL
url =
(,,) <$> (string "http://" *> (many . satisfy $ \c -> c /= ':' && c /= '/'))
<*> ((char ':' *> many digit) <|> pure "80")
<*> ((many1 . satisfy $ not . isSpace) <|> pure "/")
urlConnector :: String -> IO (IO (Socket, B.ByteString))
urlConnector urlStr = do
let (host, port, uri) = case parse url "<cmdline>" urlStr of
Left err -> error (show err)
Right req -> req
myHints = defaultHints { addrSocketType = Stream }
(ai:_) <- getAddrInfo (Just myHints) (Just host) (Just port)
return $ do
sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)
let req = B.concat ["GET ", B.pack uri, " HTTP/1.1\r\n"
,"Host: ", B.pack host, ":", B.pack port, "\r\n"]
connect sock (addrAddress ai)
return (sock, req)
client ctors reqs = do
forM_ ctors $ \connector -> do
let loop slop !reqno sock reqStart = do
let refill = recv sock 65536
req = B.concat [reqStart, "\r\n"]
sendAll sock req
resp <- (if B.null slop then refill else return slop) >>=
A.parseWith refill RFC2616.response
case resp of
err@(A.Partial _) -> print err
A.Fail bs _ msg -> print (msg, B.take 10 bs)
A.Done bs (_, chdrs) -> do
let hdrs = map lowerHeader chdrs
closeHeader = Header "connection" ["close"]
contentLength = case A.parse C.decimal (B.concat
(lookupHeader "content-length" hdrs)) `A.feed` "" of
A.Done _ n -> n
_ -> error (show chdrs)
let slurp !n s = do
let len = B.length s
if len == 0 || len >= n
then return $! B.drop n s
else slurp (n-len) =<< recv sock 65536
if B.length bs >= contentLength
then if reqno >= reqs || closeHeader `elem` hdrs
then return ()
else loop (B.drop contentLength bs) (reqno+1) sock reqStart
else slurp contentLength bs >>= \s ->
if reqno >= reqs || closeHeader `elem` hdrs
then return ()
else loop s (reqno+1) sock reqStart
bracket connector (close . fst) . uncurry $ loop "" 1
main = do
(cfg, urls) <- parseArgs defaultConfig defaultOptions =<< getArgs
when (null urls) $ error "no URLs"
ensureIOManagerIsRunning
ctors <- mapM urlConnector urls
let clients = theLast cfgClients cfg
conns = theLast cfgConnections cfg
requests = theLast cfgRequests cfg
total = clients * conns * requests
putStrLn $ "issuing " ++ show total ++ " requests"
sem <- newQSemN 0
start <- getCurrentTime
replicateM_ clients $ do
_ <- forkIO $ client (take conns (cycle ctors)) requests `finally` signalQSemN sem 1
return ()
waitQSemN sem clients
end <- getCurrentTime
let elapsed = realToFrac (nominalDiffTimeToSeconds $ diffUTCTime end start) :: Double
rate = realToFrac (fromIntegral total / elapsed) :: Double
printf "%.6g reqs/sec in %.6g secs\n" rate elapsed
------------------------------------------------------------------------
-- Configuration
data Config = Config {
cfgClients :: Last Int
, cfgConnections :: Last Int
, cfgRequests :: Last Int
}
defaultConfig :: Config
defaultConfig = Config {
cfgClients = ljust numCapabilities
, cfgConnections = ljust numCapabilities
, cfgRequests = ljust 1
}
instance Monoid Config where
mempty = Config {
cfgClients = mempty
, cfgConnections = mempty
, cfgRequests = mempty
}
mappend = (<>)
instance S.Semigroup Config where
Config {
cfgClients = a
, cfgConnections = b
, cfgRequests = c
} <> Config { cfgClients = d
, cfgConnections = e
, cfgRequests = f
} =
Config { cfgClients = a <> d
, cfgConnections = b <> e
, cfgRequests = c <> f }
defaultOptions :: [OptDescr (IO Config)]
defaultOptions = [
Option ['c'] ["clients"]
(ReqArg (positive "number of concurrent clients" $ \n ->
mempty { cfgClients = n }) "N")
"number of concurrent clients"
, Option ['n'] ["connections"]
(ReqArg (positive "number of connections" $ \n ->
mempty { cfgConnections = n }) "N")
"number of connections"
, Option ['r'] ["requests"]
(ReqArg (positive "number of requests per connection" $ \n ->
mempty { cfgRequests = n }) "N")
"number of requests"
]
|
