http2-tls 0.4.9 → 0.5.0

raw patch · 7 files changed

+212/−52 lines, 7 filesdep +unix-timedep ~network-rundep ~time-managerPVP ok

version bump matches the API change (PVP)

Dependencies added: unix-time

Dependency ranges changed: network-run, time-manager

API changes (from Hackage documentation)

Files

• Network/HTTP2/TLS/Config.hs +2/−0
• Network/HTTP2/TLS/Server.hs +5/−6
• http2-tls.cabal +6/−4
• util/Client.hs +98/−16
• util/Monitor.hs +30/−0
• util/Server.hs +24/−2
• util/h2-client.hs +47/−24

@@ -36,6 +36,7 @@                 , confTimeoutManager = mgr                 , confMySockAddr = mysa                 , confPeerSockAddr = peersa+                , confReadNTimeout = False                 }     return config @@ -62,6 +63,7 @@                 , confTimeoutManager = mgr                 , confMySockAddr = mysa                 , confPeerSockAddr = peersa+                , confReadNTimeout = False                 }     return config 

@@ -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)

@@ -1,6 +1,6 @@ cabal-version: >=1.10 name:          http2-tls-version:       0.4.9+version:       0.5.0 license:       BSD3 license-file:  LICENSE maintainer:    Kazu Yamamoto <kazu@iij.ad.jp>@@ -44,9 +44,9 @@         http2 >=5.3.9 && <5.4,         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,+        time-manager >=0.2 && <0.4,         tls >=2.1.10 && <2.2,         utf8-string >=1.0 && <1.1 @@ -54,6 +54,7 @@     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) 

@@ -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

@@ -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

@@ -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

@@ -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