performance option for h2c-client and h2c-server

http2.cabal

@@ -140,6 +140,7 @@ executable h2c-client
         http-types,
         http2,
         network-run >= 0.3 && <0.4,
+        unix-time,
         unliftio
 
     if flag(devel)

util/Client.hs

@@ -1,24 +1,39 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Client where
 
+import Control.Monad
 import qualified Data.ByteString.Char8 as C8
+import Data.UnixTime
+import Foreign.C.Types
 import Network.HTTP.Types
+import Text.Printf
 import UnliftIO.Async
 import qualified UnliftIO.Exception as E
 
 import Network.HTTP2.Client
 
-client :: Int -> [Path] -> Client ()
-client n0 paths sendRequest _aux = do
-    ex <- E.try $ foldr1 concurrently_ $ map (client' n0 sendRequest) paths
+data Options = Options
+    { optPerformance :: Int
+    , optNumOfReqs :: Int
+    }
+    deriving (Show)
+
+client :: Options -> [Path] -> Client ()
+client Options{..} paths sendRequest _aux = do
+    let cli
+            | optPerformance /= 0 = clientPF optPerformance sendRequest
+            | otherwise =
+                foldr1 concurrently_ $ map (clientNReqs optNumOfReqs sendRequest) paths
+    ex <- E.try cli
     case ex of
         Right () -> return ()
         Left e -> print (e :: HTTP2Error)
 
-client' :: Int -> SendRequest -> Path -> IO ()
-client' n0 sendRequest path = loop n0
+clientNReqs :: Int -> SendRequest -> Path -> IO ()
+clientNReqs n0 sendRequest path = loop n0
   where
     req = requestNoBody methodGet path []
     loop 0 = return ()
@@ -27,3 +42,36 @@ client' n0 sendRequest path = loop n0
             print $ responseStatus rsp
             getResponseBodyChunk rsp >>= C8.putStrLn
         loop (n - 1)
+
+clientPF :: Int -> SendRequest -> IO ()
+clientPF n sendRequest = do
+    t1 <- getUnixTime
+    sendRequest req loop
+    t2 <- getUnixTime
+    printThroughput t1 t2 n
+  where
+    req = requestNoBody methodGet path []
+    path = "/perf/" <> C8.pack (show n)
+    loop rsp = do
+        bs <- getResponseBodyChunk rsp
+        when (bs /= "") $ loop rsp
+
+printThroughput :: UnixTime -> UnixTime -> Int -> IO ()
+printThroughput t1 t2 n =
+    printf
+        "Throughput %.2f Mbps (%d bytes in %d msecs)\n"
+        bytesPerSeconds
+        n
+        millisecs
+  where
+    UnixDiffTime (CTime s) u = t2 `diffUnixTime` t1
+    millisecs :: Int
+    millisecs = fromIntegral s * 1000 + fromIntegral u `div` 1000
+    bytesPerSeconds :: Double
+    bytesPerSeconds =
+        fromIntegral n
+            * (1000 :: Double)
+            * 8
+            / fromIntegral millisecs
+            / 1024
+            / 1024

util/Server.hs

@@ -8,14 +8,22 @@ import qualified Crypto.Hash as CH
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
 import Data.ByteString.Builder (byteString)
+import qualified Data.ByteString.Builder as BB
 import qualified Data.ByteString.Char8 as C8
 import Network.HTTP.Types
 import Network.HTTP2.Server
 
 server :: Server
 server req _aux sendResponse = case requestMethod req of
-    Just "GET"
-        | requestPath req == Just "/" -> sendResponse responseHello []
+    Just "GET" -> case requestPath req of
+        Nothing -> sendResponse response404 []
+        Just path
+            | path == "/" -> sendResponse responseHello []
+            | "/perf/" `B.isPrefixOf` path -> do
+                case C8.readInt (B.drop 6 path) of
+                    Nothing -> sendResponse responseHello []
+                    Just (n, _) -> sendResponse (responsePerf n) []
+            | otherwise -> sendResponse response404 []
     Just "POST" -> sendResponse (responseEcho req) []
     _ -> sendResponse response404 []
 
@@ -25,6 +33,20 @@ responseHello = responseBuilder ok200 header body
     header = [("Content-Type", "text/plain")]
     body = byteString "Hello, world!\n"
 
+responsePerf :: Int -> Response
+responsePerf n0 = responseStreaming ok200 header streaming
+  where
+    header = [("Content-Type", "text/plain")]
+    bs1024 = BB.byteString $ B.replicate 1024 65
+    streaming write _flush = loop n0
+      where
+        loop 0 = return ()
+        loop n
+            | n < 1024 = write $ BB.byteString $ B.replicate (fromIntegral n) 65
+            | otherwise = do
+                write bs1024
+                loop (n - 1024)
+
 response404 :: Response
 response404 = responseBuilder notFound404 header body
   where

util/h2c-client.hs

@@ -13,15 +13,11 @@ import qualified UnliftIO.Exception as E
 
 import Client
 
-data Options = Options
-    { optNumOfReqs :: Int
-    }
-    deriving (Show)
-
 defaultOptions :: Options
 defaultOptions =
     Options
-        { optNumOfReqs = 1
+        { optPerformance = 0
+        , optNumOfReqs = 1
         }
 
 usage :: String
@@ -30,6 +26,11 @@ usage = "Usage: h2c-client [OPTION] addr port [path]"
 options :: [OptDescr (Options -> Options)]
 options =
     [ Option
+        ['t']
+        ["performance"]
+        (ReqArg (\n o -> o{optPerformance = read n}) "<size>")
+        "measure performance"
+    , Option
         ['n']
         ["number-of-requests"]
         (ReqArg (\n o -> o{optNumOfReqs = read n}) "<n>")
@@ -51,7 +52,7 @@ clientOpts argv =
 main :: IO ()
 main = do
     args <- getArgs
-    (Options{..}, ips) <- clientOpts args
+    (opts, ips) <- clientOpts args
     (host, port, paths) <- case ips of
         [] -> showUsageAndExit usage
         _ : [] -> showUsageAndExit usage
@@ -62,4 +63,4 @@ main = do
         E.bracket
             (allocSimpleConfig s 4096)
             freeSimpleConfig
-            (\conf -> run cliconf conf $ client optNumOfReqs paths)
+            (\conf -> run cliconf conf $ client opts paths)