http2-tls 0.4.9 → 0.5.3
raw patch · 7 files changed
Files
- Network/HTTP2/TLS/Config.hs +26/−26
- Network/HTTP2/TLS/Server.hs +5/−6
- http2-tls.cabal +11/−9
- util/Client.hs +98/−16
- util/Monitor.hs +30/−0
- util/Server.hs +24/−2
- util/h2-client.hs +47/−24
Network/HTTP2/TLS/Config.hs view
@@ -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
Network/HTTP2/TLS/Server.hs view
@@ -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)
http2-tls.cabal view
@@ -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 <kazu@iij.ad.jp>@@ -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)
util/Client.hs view
@@ -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
+ util/Monitor.hs view
@@ -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
util/Server.hs view
@@ -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
util/h2-client.hs view
@@ -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}) "<size>")+ "measure performance"+ , Option+ ['n']+ ["number-of-requests"]+ (ReqArg (\n o -> o{optNumOfReqs = read n}) "<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}) "<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}) "<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