http2 5.3.6 → 5.3.7

raw patch · 10 files changed

+101/−69 lines, 10 filesdep ~time-manager

Dependency ranges changed: time-manager

Files

• ChangeLog.md +7/−0
• Network/HTTP2/Client.hs +1/−0
• Network/HTTP2/H2/Config.hs +10/−2
• Network/HTTP2/H2/Manager.hs +9/−12
• Network/HTTP2/Server.hs +1/−0
• Network/HTTP2/Server/Worker.hs +42/−45
• http2.cabal +2/−2
• util/Client.hs +1/−0
• util/h2c-client.hs +9/−2
• util/h2c-server.hs +19/−6

@@ -1,5 +1,12 @@ # ChangeLog for http2 +## 5.3.7++* Using `withHandle` of time-manager.+* Getting `Handle` for each thread.+* Providing allocSimpleConfig' to enable customizing WAI tiemout manager.+* Monitor option (-m) for h2c-client and h2c-server.+ ## 5.3.6  * Making `runIO` friendly with the new synchronism mechanism.

@@ -74,6 +74,7 @@     -- * Common configuration     Config (..),     allocSimpleConfig,+    allocSimpleConfig',     freeSimpleConfig,     module Network.HTTP.Semantics.Client, 

@@ -12,11 +12,19 @@  -- | Making simple configuration whose IO is not efficient. --   A write buffer is allocated internally.+--   WAI timeout manger is initialized with 30_000_000 microseconds. allocSimpleConfig :: Socket -> BufferSize -> IO Config-allocSimpleConfig s bufsiz = do+allocSimpleConfig s bufsiz = allocSimpleConfig' s bufsiz (30 * 1000000)++-- | Making simple configuration whose IO is not efficient.+--   A write buffer is allocated internally.+--   The third argument is microseconds to initialize WAI+--   timeout manager.+allocSimpleConfig' :: Socket -> BufferSize -> Int -> IO Config+allocSimpleConfig' s bufsiz usec = do     buf <- mallocBytes bufsiz     ref <- newIORef Nothing-    timmgr <- T.initialize $ 30 * 1000000+    timmgr <- T.initialize usec     mysa <- getSocketName s     peersa <- getPeerName s     let config =

@@ -97,16 +97,18 @@ forkManagedUnmask     :: Manager -> String -> ((forall x. IO x -> IO x) -> IO ()) -> IO () forkManagedUnmask (Manager _timmgr var) label io =-    void $ mask_ $ forkIOWithUnmask $ \unmask -> E.handle handler $ do+    -- This is the top level of thread.+    -- So, SomeException should be reasonable.+    void $ mask_ $ forkIOWithUnmask $ \unmask -> E.handle ignore $ do         labelMe label         tid <- myThreadId         atomically $ modifyTVar var $ Map.insert tid ThreadWithoutTimeout         -- We catch the exception and do not rethrow it: we don't want the         -- exception printed to stderr.-        io unmask `catch` \(_e :: SomeException) -> return ()+        io unmask `catch` ignore         atomically $ modifyTVar var $ Map.delete tid   where-    handler (E.SomeException _) = return ()+    ignore (E.SomeException _) = return ()  waitCounter0 :: Manager -> IO () waitCounter0 (Manager _timmgr var) = atomically $ do@@ -115,15 +117,10 @@  ---------------------------------------------------------------- -withTimeout :: Manager -> (T.Handle -> IO a) -> IO a-withTimeout (Manager timmgr var) action = do-    E.bracket register unregister $ \h ->-        action h-  where-    register = do+withTimeout :: Manager -> (T.Handle -> IO ()) -> IO ()+withTimeout (Manager timmgr var) action =+    T.withHandleKillThread timmgr (return ()) $ \th -> do         tid <- myThreadId-        th <- T.registerKillThread timmgr $ return ()         -- overriding ThreadWithoutTimeout         atomically $ modifyTVar var $ Map.insert tid $ ThreadWithTimeout th-        return th-    unregister th = T.cancel th+        action th

@@ -55,6 +55,7 @@     -- * Common configuration     Config (..),     allocSimpleConfig,+    allocSimpleConfig',     freeSimpleConfig,     module Network.HTTP.Semantics.Server, ) where

@@ -30,7 +30,7 @@                 aux = Aux th mySockAddr peerSockAddr                 request = Request req'             lc <- newLoopCheck strm Nothing-            server request aux $ sendResponse conf ctx lc th strm request+            server request aux $ sendResponse conf ctx lc strm request             adjustRxWindow ctx strm   where     label = "H2 response sender for stream " ++ show (streamNumber strm)@@ -52,18 +52,17 @@     :: Config     -> Context     -> LoopCheck-    -> T.Handle     -> Stream     -> Request     -> Response     -> [PushPromise]     -> IO ()-sendResponse conf ctx lc th strm (Request req) (Response rsp) pps = do+sendResponse conf ctx lc strm (Request req) (Response rsp) pps = do     mwait <- pushStream conf ctx strm reqvt pps     case mwait of         Nothing -> return ()         Just wait -> wait -- all pushes are sent-    sendHeaderBody conf ctx lc th strm rsp+    sendHeaderBody conf ctx lc strm rsp   where     (_, reqvt) = inpObjHeaders req @@ -99,28 +98,27 @@     push _ [] n = return (n :: Int)     push tvar (pp : pps) n = do         forkManaged threadManager "H2 server push" $ do-            withTimeout threadManager $ \th -> do-                (pid, newstrm) <- makePushStream ctx pstrm-                let scheme = fromJust $ getFieldValue tokenScheme reqvt-                    -- fixme: this value can be Nothing-                    auth =-                        fromJust-                            ( getFieldValue tokenAuthority reqvt-                                <|> getFieldValue tokenHost reqvt-                            )-                    path = promiseRequestPath pp-                    promiseRequest =-                        [ (tokenMethod, methodGet)-                        , (tokenScheme, scheme)-                        , (tokenAuthority, auth)-                        , (tokenPath, path)-                        ]-                    ot = OPush promiseRequest pid-                    Response rsp = promiseResponse pp-                increment tvar-                lc <- newLoopCheck newstrm Nothing-                syncWithSender ctx newstrm ot lc-                sendHeaderBody conf ctx lc th newstrm rsp+            (pid, newstrm) <- makePushStream ctx pstrm+            let scheme = fromJust $ getFieldValue tokenScheme reqvt+                -- fixme: this value can be Nothing+                auth =+                    fromJust+                        ( getFieldValue tokenAuthority reqvt+                            <|> getFieldValue tokenHost reqvt+                        )+                path = promiseRequestPath pp+                promiseRequest =+                    [ (tokenMethod, methodGet)+                    , (tokenScheme, scheme)+                    , (tokenAuthority, auth)+                    , (tokenPath, path)+                    ]+                ot = OPush promiseRequest pid+                Response rsp = promiseResponse pp+            increment tvar+            lc <- newLoopCheck newstrm Nothing+            syncWithSender ctx newstrm ot lc+            sendHeaderBody conf ctx lc newstrm rsp         push tvar pps (n + 1)  ----------------------------------------------------------------@@ -138,11 +136,10 @@     :: Config     -> Context     -> LoopCheck-    -> T.Handle     -> Stream     -> OutObj     -> IO ()-sendHeaderBody Config{..} ctx lc th strm OutObj{..} = do+sendHeaderBody Config{..} ctx lc strm OutObj{..} = do     (mnext, mtbq) <- case outObjBody of         OutBodyNone -> return (Nothing, Nothing)         OutBodyFile (FileSpec path fileoff bytecount) -> do@@ -153,11 +150,11 @@             let next = fillBuilderBodyGetNext builder             return (Just next, Nothing)         OutBodyStreaming strmbdy -> do-            q <- sendStreaming ctx strm th $ \OutBodyIface{..} -> strmbdy outBodyPush outBodyFlush+            q <- sendStreaming ctx strm $ \OutBodyIface{..} -> strmbdy outBodyPush outBodyFlush             let next = nextForStreaming q             return (Just next, Just q)         OutBodyStreamingIface strmbdy -> do-            q <- sendStreaming ctx strm th strmbdy+            q <- sendStreaming ctx strm strmbdy             let next = nextForStreaming q             return (Just next, Just q)     let lc' = lc{lcTBQ = mtbq}@@ -168,25 +165,25 @@ sendStreaming     :: Context     -> Stream-    -> T.Handle     -> (OutBodyIface -> IO ())     -> IO (TBQueue StreamingChunk)-sendStreaming Context{..} strm th strmbdy = do+sendStreaming Context{..} strm strmbdy = do     tbq <- newTBQueueIO 10 -- fixme: hard coding: 10     forkManaged threadManager label $-        withOutBodyIface tbq id $ \iface -> do-            let iface' =-                    iface-                        { outBodyPush = \b -> do-                            T.pause th-                            outBodyPush iface b-                            T.resume th-                        , outBodyPushFinal = \b -> do-                            T.pause th-                            outBodyPushFinal iface b-                            T.resume th-                        }-            strmbdy iface'+        withTimeout threadManager $ \th ->+            withOutBodyIface tbq id $ \iface -> do+                let iface' =+                        iface+                            { outBodyPush = \b -> do+                                T.pause th+                                outBodyPush iface b+                                T.resume th+                            , outBodyPushFinal = \b -> do+                                T.pause th+                                outBodyPushFinal iface b+                                T.resume th+                            }+                strmbdy iface'     return tbq   where     label = "H2 response streaming sender for " ++ show (streamNumber strm)

@@ -1,6 +1,6 @@ cabal-version:      >=1.10 name:               http2-version:            5.3.6+version:            5.3.7 license:            BSD3 license-file:       LICENSE maintainer:         Kazu Yamamoto <kazu@iij.ad.jp>@@ -123,7 +123,7 @@         network-byte-order >=0.1.7 && <0.2,         network-control >=0.1 && <0.2,         stm >=2.5 && <2.6,-        time-manager >=0.1 && <0.2,+        time-manager >=0.1.3 && <0.2,         unix-time >=0.4.11 && <0.5,         utf8-string >=1.0 && <1.1 

@@ -20,6 +20,7 @@ data Options = Options     { optPerformance :: Int     , optNumOfReqs :: Int+    , optMonitor :: Bool     }     deriving (Show) 

@@ -5,6 +5,7 @@  import Control.Concurrent import qualified Control.Exception as E+import Control.Monad import qualified Data.ByteString.Char8 as C8 import Network.HTTP2.Client import Network.Run.TCP (runTCPClient)@@ -20,6 +21,7 @@     Options         { optPerformance = 0         , optNumOfReqs = 1+        , optMonitor = False         }  usage :: String@@ -37,6 +39,11 @@         ["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"     ]  showUsageAndExit :: String -> IO a@@ -61,10 +68,10 @@         _ : [] -> showUsageAndExit usage         h : p : [] -> return (h, p, ["/"])         h : p : ps -> return (h, p, C8.pack <$> ps)+    when (optMonitor opts) $ void $ forkIO $ monitor $ threadDelay 1000000     let cliconf = defaultClientConfig{authority = host}-    _ <- forkIO $ monitor $ threadDelay 1000000     runTCPClient host port $ \s ->         E.bracket-            (allocSimpleConfig s 4096)+            (allocSimpleConfig' s 4096 5000000)             freeSimpleConfig             (\conf -> run cliconf conf $ client opts paths)

@@ -6,6 +6,7 @@  import Control.Concurrent import qualified Control.Exception as E+import Control.Monad import Network.HTTP2.Server import Network.Run.TCP import System.Console.GetOpt@@ -16,7 +17,13 @@ import Server  options :: [OptDescr (Options -> Options)]-options = []+options =+    [ Option+        ['m']+        ["monitor"]+        (NoArg (\opts -> opts{optMonitor = True}))+        "run thread monitor"+    ]  showUsageAndExit :: String -> IO a showUsageAndExit msg = do@@ -30,10 +37,16 @@         (o, n, []) -> return (foldl (flip id) defaultOptions o, n)         (_, _, errs) -> showUsageAndExit $ concat errs -data Options = Options deriving (Show)+data Options = Options+    { optMonitor :: Bool+    }+    deriving (Show)  defaultOptions :: Options-defaultOptions = Options+defaultOptions =+    Options+        { optMonitor = False+        }  usage :: String usage = "Usage: h2c-server [OPTION] <addr> <port>"@@ -42,13 +55,13 @@ main = do     labelMe "h2c-server main"     args <- getArgs-    (Options, ips) <- serverOpts args+    (opts, ips) <- serverOpts args     (host, port) <- case ips of         [h, p] -> return (h, p)         _ -> showUsageAndExit usage-    _ <- forkIO $ monitor $ threadDelay 1000000+    when (optMonitor opts) $ void $ forkIO $ monitor $ threadDelay 1000000     runTCPServer (Just host) port $ \s -> do         E.bracket-            (allocSimpleConfig s 4096)+            (allocSimpleConfig' s 4096 5000000)             freeSimpleConfig             (\conf -> run defaultServerConfig conf server)