diff --git a/Network/HTTP2/TLS/Config.hs b/Network/HTTP2/TLS/Config.hs --- a/Network/HTTP2/TLS/Config.hs +++ b/Network/HTTP2/TLS/Config.hs @@ -5,10 +5,8 @@ import Data.ByteString (ByteString) import Foreign.Marshal.Alloc (free, mallocBytes) -import Network.HTTP2.Client ( - Config (..), - defaultPositionReadMaker, - ) +import Network.HTTP2.Client (Config) +import qualified Network.HTTP2.Client as C import Network.Socket (SockAddr) import Network.Socket.BufferPool import qualified System.TimeManager as T @@ -27,21 +25,22 @@ buf <- mallocBytes settingsSendBufferSize recvN <- makeRecvN "" recv let config = - Config - { confWriteBuffer = buf - , confBufferSize = settingsSendBufferSize - , confSendAll = send - , confReadN = recvN - , confPositionReadMaker = defaultPositionReadMaker - , confTimeoutManager = mgr - , confMySockAddr = mysa - , confPeerSockAddr = peersa + C.defaultConfig + { C.confWriteBuffer = buf + , C.confBufferSize = settingsSendBufferSize + , C.confSendAll = send + , C.confReadN = recvN + , C.confPositionReadMaker = C.defaultPositionReadMaker + , C.confTimeoutManager = mgr + , C.confMySockAddr = mysa + , C.confPeerSockAddr = peersa + , C.confReadNTimeout = False } return config -- | Deallocating the resource of the simple configuration. freeConfigForServer :: Config -> IO () -freeConfigForServer conf = free $ confWriteBuffer conf +freeConfigForServer conf = free $ C.confWriteBuffer conf allocConfigForClient :: (ByteString -> IO ()) -> IO ByteString -> SockAddr -> SockAddr -> IO Config @@ -53,20 +52,21 @@ -- So, a timeout manager is created per connection. mgr <- T.initialize 30000000 -- fixme let config = - Config - { confWriteBuffer = buf - , confBufferSize = wbufsiz - , confSendAll = send - , confReadN = recvN - , confPositionReadMaker = defaultPositionReadMaker - , confTimeoutManager = mgr - , confMySockAddr = mysa - , confPeerSockAddr = peersa + C.defaultConfig + { C.confWriteBuffer = buf + , C.confBufferSize = wbufsiz + , C.confSendAll = send + , C.confReadN = recvN + , C.confPositionReadMaker = C.defaultPositionReadMaker + , C.confTimeoutManager = mgr + , C.confMySockAddr = mysa + , C.confPeerSockAddr = peersa + , C.confReadNTimeout = False } return config -- | Deallocating the resource of the simple configuration. freeConfigForClient :: Config -> IO () -freeConfigForClient Config{..} = do - free confWriteBuffer - T.killManager confTimeoutManager +freeConfigForClient conf = do + free $ C.confWriteBuffer conf + T.killManager $ C.confTimeoutManager conf diff --git a/Network/HTTP2/TLS/Server.hs b/Network/HTTP2/TLS/Server.hs --- a/Network/HTTP2/TLS/Server.hs +++ b/Network/HTTP2/TLS/Server.hs @@ -92,8 +92,8 @@ -> PortNumber -> ByteString -- ^ ALPN - -> (T.Manager -> IOBackend -> IO a) - -> IO a + -> (T.Manager -> IOBackend -> IO ()) + -> IO () runTLS settings creds host port alpn action = runTCPServer (settingsTimeout settings) @@ -104,9 +104,8 @@ ctx <- contextNew backend params handshake ctx iobackend <- timeoutIOBackend th settings <$> tlsIOBackend ctx sock - r <- action mgr iobackend + action mgr iobackend bye ctx - return r where params = getServerParams settings creds alpn @@ -119,8 +118,8 @@ -> Socket -> ByteString -- ^ ALPN - -> (T.Manager -> IOBackend -> IO a) - -> IO a + -> (T.Manager -> IOBackend -> IO ()) + -> IO () runTLSWithSocket settings creds s alpn action = runTCPServerWithSocket (settingsTimeout settings) diff --git a/http2-tls.cabal b/http2-tls.cabal --- a/http2-tls.cabal +++ b/http2-tls.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: http2-tls -version: 0.4.9 +version: 0.5.3 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto @@ -38,22 +38,23 @@ build-depends: base >=4.9 && <5, bytestring >=0.10, - crypton-x509-store >=1.6.11 && <1.7.0, - crypton-x509-system >=1.6 && <1.7, - crypton-x509-validation >=1.6 && <1.7, - http2 >=5.3.9 && <5.4, + crypton-x509-store >=1.9.0 && <1.10, + crypton-x509-system >=1.9.0 && <1.10, + crypton-x509-validation >=1.9 && <1.10, + http2 >=5.4 && <5.5, network >=3.1.4, network-control >=0.1 && <0.2, - network-run >=0.4 && <0.5, + network-run >=0.5 && <0.6, recv >=0.1.0 && <0.2, - time-manager >=0.2 && <0.3, - tls >=2.1.10 && <2.2, + time-manager >=0.2 && <0.4, + tls >=2.3.0 && <2.4, utf8-string >=1.0 && <1.1 executable h2-client main-is: h2-client.hs hs-source-dirs: util other-modules: Client + Monitor default-language: Haskell2010 default-extensions: Strict StrictData ghc-options: -Wall -threaded -rtsopts @@ -66,7 +67,8 @@ http-types, http2, http2-tls, - tls + tls, + unix-time if flag(devel) diff --git a/util/Client.hs b/util/Client.hs --- a/util/Client.hs +++ b/util/Client.hs @@ -1,39 +1,121 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} module Client where +import Control.Concurrent import Control.Concurrent.Async import qualified Control.Exception as E -import Control.Monad (when) +import Control.Monad +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8 -import Data.CaseInsensitive (foldedCase) -import Network.HTTP.Semantics +import Data.UnixTime +import Foreign.C.Types import Network.HTTP.Types +import System.IO +import Text.Printf import Network.HTTP2.Client -client :: Int -> [Path] -> Client () -client n0 paths sendRequest _aux = do - ex <- E.try $ foldr1 concurrently_ $ map (client' n0 sendRequest) paths +import Monitor + +data Options = Options + { optPerformance :: Int + , optNumOfReqs :: Int + , optMonitor :: Bool + , optInteractive :: Bool + , optKeyLogFile :: Maybe FilePath + , optValidate :: Bool + , optResumption :: Bool + , opt0RTT :: Bool + } + deriving (Show) + +client :: Options -> [Path] -> Client () +client Options{..} paths sendRequest _aux = do + labelMe "h2 client" + let cli + | optPerformance /= 0 = clientPF optPerformance sendRequest + | otherwise = clientNReqs optNumOfReqs sendRequest + ex <- E.try $ mapConcurrently_ cli paths 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 = do + labelMe "h2 clinet N requests" + loop n0 where req = requestNoBody methodGet path [] loop 0 = return () loop n = do sendRequest req $ \rsp -> do print $ responseStatus rsp - mapM_ (\(k, v) -> C8.putStrLn (foldedCase (tokenKey k) <> ": " <> v)) $ - fst $ - responseHeaders - rsp - consume rsp + getResponseBodyChunk rsp >>= C8.putStrLn loop (n - 1) - consume rsp = do - x <- getResponseBodyChunk rsp - when (x /= "") $ consume rsp + +-- Path is dummy +clientPF :: Int -> SendRequest -> Path -> IO () +clientPF n sendRequest _ = do + labelMe "h2 clinet performance" + 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 + +console + :: Options -> [ByteString] -> IO () -> Aux -> IO () +console _opt paths cli aux = do + putStrLn "q -- quit" + putStrLn "g -- get" + putStrLn "p -- ping" + mvar <- newEmptyMVar + loop mvar `E.catch` \(E.SomeException _) -> return () + where + loop mvar = do + hSetBuffering stdout NoBuffering + putStr "> " + hSetBuffering stdout LineBuffering + l <- getLine + case l of + "q" -> putStrLn "bye" + "g" -> do + mapM_ (\p -> putStrLn $ "GET " ++ C8.unpack p) paths + _ <- forkIO $ cli >> putMVar mvar () + takeMVar mvar + loop mvar + "p" -> do + putStrLn "Ping" + auxSendPing aux + loop mvar + _ -> do + putStrLn "No such command" + loop mvar diff --git a/util/Monitor.hs b/util/Monitor.hs new file mode 100644 --- /dev/null +++ b/util/Monitor.hs @@ -0,0 +1,30 @@ +module Monitor (monitor, labelMe) where + +import Control.Monad +import Data.List +import Data.Maybe +import GHC.Conc.Sync + +monitor :: IO () -> IO () +monitor action = do + labelMe "monitor" + forever $ do + action + threadSummary >>= mapM_ (putStrLn . showT) + putStr "\n" + where + showT (i, l, s) = i ++ " " ++ l ++ ": " ++ show s + +threadSummary :: IO [(String, String, ThreadStatus)] +threadSummary = listThreads >>= mapM summary . sort + where + summary t = do + let idstr = drop 9 $ show t + l <- fromMaybe "(no name)" <$> threadLabel t + s <- threadStatus t + return (idstr, l, s) + +labelMe :: String -> IO () +labelMe lbl = do + tid <- myThreadId + labelThread tid lbl diff --git a/util/Server.hs b/util/Server.hs --- a/util/Server.hs +++ b/util/Server.hs @@ -8,14 +8,22 @@ 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 [] @@ -24,6 +32,20 @@ where 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 diff --git a/util/h2-client.hs b/util/h2-client.hs --- a/util/h2-client.hs +++ b/util/h2-client.hs @@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module Main where +import Control.Concurrent import Control.Monad import qualified Data.ByteString.Char8 as C8 import Data.IORef @@ -12,25 +14,22 @@ import System.Environment import System.Exit -import Client +import Network.HTTP2.Client (Path) -data Options = Options - { optKeyLogFile :: Maybe FilePath - , optValidate :: Bool - , optResumption :: Bool - , opt0RTT :: Bool - , optNumOfReqs :: Int - } - deriving (Show) +import Client +import Monitor defaultOptions :: Options defaultOptions = Options - { optKeyLogFile = Nothing + { optPerformance = 0 + , optNumOfReqs = 1 + , optMonitor = False + , optInteractive = False + , optKeyLogFile = Nothing , optValidate = False , optResumption = False , opt0RTT = False - , optNumOfReqs = 1 } usage :: String @@ -39,6 +38,26 @@ options :: [OptDescr (Options -> Options)] options = [ Option + ['t'] + ["performance"] + (ReqArg (\n o -> o{optPerformance = read n}) "") + "measure performance" + , Option + ['n'] + ["number-of-requests"] + (ReqArg (\n o -> o{optNumOfReqs = read n}) "") + "specify the number of requests" + , Option + ['m'] + ["monitor"] + (NoArg (\opts -> opts{optMonitor = True})) + "run thread monitor" + , Option + ['i'] + ["interactive"] + (NoArg (\o -> o{optInteractive = True})) + "enter interactive mode" + , Option ['l'] ["key-log-file"] (ReqArg (\file o -> o{optKeyLogFile = Just file}) "") @@ -58,11 +77,6 @@ ["0rtt"] (NoArg (\o -> o{opt0RTT = True})) "try sending early data" - , Option - ['n'] - ["number-of-requests"] - (ReqArg (\n o -> o{optNumOfReqs = read n}) "") - "specify the number of requests" ] showUsageAndExit :: String -> IO a @@ -80,24 +94,25 @@ main :: IO () main = do args <- getArgs - (Options{..}, ips) <- clientOpts args + (opts, ips) <- clientOpts args (host, port, paths) <- case ips of [] -> showUsageAndExit usage _ : [] -> showUsageAndExit usage h : p : [] -> return (h, read p, ["/"]) h : p : ps -> return (h, read p, C8.pack <$> ps) + when (optMonitor opts) $ void $ forkIO $ monitor $ threadDelay 1000000 ref <- newIORef Nothing - let keylog = case optKeyLogFile of + let keylog = case optKeyLogFile opts of Nothing -> settingsKeyLogger defaultSettings Just file -> \msg -> appendFile file (msg ++ "\n") settings = defaultSettings - { settingsValidateCert = optValidate + { settingsValidateCert = optValidate opts , settingsKeyLogger = keylog , settingsSessionManager = sessionRef ref } - run settings host port $ client optNumOfReqs paths - when (optResumption || opt0RTT) $ do + run settings host port $ client' opts paths + when (optResumption opts || opt0RTT opts) $ do mr <- readIORef ref case mr of Nothing -> do @@ -106,12 +121,12 @@ _ -> do let settings2 = defaultSettings - { settingsValidateCert = optValidate + { settingsValidateCert = optValidate opts , settingsKeyLogger = keylog , settingsWantSessionResume = mr - , settingsUseEarlyData = opt0RTT + , settingsUseEarlyData = opt0RTT opts } - run settings2 host port $ client optNumOfReqs paths + run settings2 host port $ client opts paths sessionRef :: IORef (Maybe (SessionID, SessionData)) -> SessionManager sessionRef ref = @@ -120,3 +135,11 @@ writeIORef ref $ Just (sid, sdata) return Nothing } + +client' :: Options -> [Path] -> Client () +client' opts paths sendRequest _aux + | optInteractive opts = do + let action = client opts paths sendRequest _aux + console opts paths action _aux + return () + | otherwise = client opts paths sendRequest _aux