diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/Network/HTTP2/Client.hs b/Network/HTTP2/Client.hs --- a/Network/HTTP2/Client.hs +++ b/Network/HTTP2/Client.hs @@ -74,6 +74,7 @@ -- * Common configuration Config (..), allocSimpleConfig, + allocSimpleConfig', freeSimpleConfig, module Network.HTTP.Semantics.Client, diff --git a/Network/HTTP2/H2/Config.hs b/Network/HTTP2/H2/Config.hs --- a/Network/HTTP2/H2/Config.hs +++ b/Network/HTTP2/H2/Config.hs @@ -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 = diff --git a/Network/HTTP2/H2/Manager.hs b/Network/HTTP2/H2/Manager.hs --- a/Network/HTTP2/H2/Manager.hs +++ b/Network/HTTP2/H2/Manager.hs @@ -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 diff --git a/Network/HTTP2/Server.hs b/Network/HTTP2/Server.hs --- a/Network/HTTP2/Server.hs +++ b/Network/HTTP2/Server.hs @@ -55,6 +55,7 @@ -- * Common configuration Config (..), allocSimpleConfig, + allocSimpleConfig', freeSimpleConfig, module Network.HTTP.Semantics.Server, ) where diff --git a/Network/HTTP2/Server/Worker.hs b/Network/HTTP2/Server/Worker.hs --- a/Network/HTTP2/Server/Worker.hs +++ b/Network/HTTP2/Server/Worker.hs @@ -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) diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -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 @@ -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 diff --git a/util/Client.hs b/util/Client.hs --- a/util/Client.hs +++ b/util/Client.hs @@ -20,6 +20,7 @@ data Options = Options { optPerformance :: Int , optNumOfReqs :: Int + , optMonitor :: Bool } deriving (Show) diff --git a/util/h2c-client.hs b/util/h2c-client.hs --- a/util/h2c-client.hs +++ b/util/h2c-client.hs @@ -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}) "") "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) diff --git a/util/h2c-server.hs b/util/h2c-server.hs --- a/util/h2c-server.hs +++ b/util/h2c-server.hs @@ -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] " @@ -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)