diff --git a/Program/Mighty/Parser.hs b/Program/Mighty/Parser.hs --- a/Program/Mighty/Parser.hs +++ b/Program/Mighty/Parser.hs @@ -12,11 +12,11 @@ comment, ) where +import Control.Exception import qualified Data.ByteString.Lazy.Char8 as BL import System.IO import Text.Parsec import Text.Parsec.ByteString.Lazy -import UnliftIO.Exception -- $setup -- >>> :seti -XOverloadedStrings diff --git a/Program/Mighty/Report.hs b/Program/Mighty/Report.hs --- a/Program/Mighty/Report.hs +++ b/Program/Mighty/Report.hs @@ -14,6 +14,8 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif +import Control.Exception +import qualified Control.Exception as E (catch) import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS @@ -21,10 +23,10 @@ import GHC.IO.Exception (IOErrorType (..)) import Network.Wai import Network.Wai.Handler.Warp (InvalidRequest) +import Network.Wai.Handler.Warp.Internal (TimeoutThread(..)) import System.IO import System.IO.Error (ioeGetErrorType) import System.Posix (getProcessID) -import UnliftIO.Exception import Program.Mighty.ByteString @@ -49,12 +51,14 @@ ---------------------------------------------------------------- reportDo :: Reporter -> IO () -> IO () -reportDo rpt act = act `catchAny` warpHandler rpt Nothing +reportDo rpt act = act `E.catch` warpHandler rpt Nothing ---------------------------------------------------------------- warpHandler :: Reporter -> Maybe Request -> SomeException -> IO () warpHandler rpt _ se + | Just ThreadKilled <- fromException se = return () + | Just TimeoutThread <- fromException se = return () | Just (_ :: InvalidRequest) <- fromException se = return () | Just (e :: IOException) <- fromException se = if ioeGetErrorType e `elem` [ResourceVanished, InvalidArgument] diff --git a/Program/Mighty/Resource.hs b/Program/Mighty/Resource.hs --- a/Program/Mighty/Resource.hs +++ b/Program/Mighty/Resource.hs @@ -6,8 +6,8 @@ unlimit, ) where +import Control.Exception import System.Posix -import UnliftIO.Exception ---------------------------------------------------------------- diff --git a/mighttpd2.cabal b/mighttpd2.cabal --- a/mighttpd2.cabal +++ b/mighttpd2.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: mighttpd2 -version: 4.0.7 +version: 4.0.8 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto @@ -82,8 +82,7 @@ unordered-containers, wai >=3.2 && <3.3, wai-app-file-cgi >=3.1.9 && <3.2, - warp >=3.4 && <3.5, - unliftio + warp >=3.4 && <3.5 if impl(ghc >=8) default-extensions: Strict StrictData @@ -167,7 +166,7 @@ main-is: mightyctl.hs hs-source-dirs: utils src default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -threaded build-depends: base >=4.9 && <5, unix, diff --git a/src/Server.hs b/src/Server.hs --- a/src/Server.hs +++ b/src/Server.hs @@ -7,11 +7,15 @@ import Control.Concurrent (runInUnboundThread) import Control.Exception (try) import Control.Monad (unless, when) -import Data.Either (fromRight) import qualified Data.ByteString.Char8 as BS +import Data.Either (fromRight) +import Data.List (sort) +import Data.Maybe (fromMaybe) import Data.Streaming.Network (bindPortTCP, bindPortUDP) +import GHC.Conc.Sync import qualified Network.HTTP.Client as H import Network.Socket (Socket, close) +import Network.Wai import Network.Wai.Application.Classic hiding (()) import Network.Wai.Handler.Warp import Network.Wai.Logger @@ -34,7 +38,6 @@ import qualified Network.TLS.SessionTicket as SM import Network.Wai.Handler.WarpTLS #ifdef HTTP_OVER_QUIC -import Control.Concurrent.Async (mapConcurrently_) import Data.Bits import Data.ByteString (ByteString) import Data.List (find) @@ -72,6 +75,7 @@ server :: Option -> Reporter -> RouteDB -> IO () server opt rpt route = reportDo rpt $ do + labelMe "Mighty main" unlimit openFileNumber svc <- openService opt unless debug writePidFile @@ -80,16 +84,21 @@ (mcred, smgr) <- setup opt _changed <- setGroupUser (opt_user opt) (opt_group opt) logCheck logtype + -- "Time cacher of FastLogger (AutoUpdate)" (zdater,_) <- clockDateCacher + -- Loggerset of FastLogger (Debounce) ap <- initLogger FromSocket logtype zdater let lgr = apacheLogger ap remover = logRemover ap pushlgr = serverpushLogger ap + -- HTTP Client Manager mgr <- getManager opt setHandlers opt rpt svc remover rdr report rpt "Mighty started" - runInUnboundThread $ mighty opt rpt svc lgr pushlgr mgr rdr mcred smgr tmgr + runInUnboundThread $ do + labelMe "Mighty main (bound thread)" + mighty opt rpt svc lgr pushlgr mgr rdr mcred smgr tmgr report rpt "Mighty retired" remover exitSuccess @@ -129,12 +138,24 @@ retireHandler = Catch $ do report rpt "Mighty retiring" closeService svc -- this lets warp break - infoHandler = Catch $ report rpt "obsoleted" + infoHandler = Catch $ do + labelMe "Info signale handler" + threadSummary >>= mapM_ (putStrLn . showT) + showT (i, l, s) = i ++ " " ++ l ++ ": " ++ show s reloadHandler = Catch $ do ifRouteFileIsValid rpt opt $ \newroute -> do writeRouteDBRef rdr newroute report rpt "Mighty reloaded" +threadSummary :: IO [(String, String, ThreadStatus)] +threadSummary = (sort <$> listThreads) >>= mapM summary + where + summary t = do + let idstr = drop 9 $ show t + l <- fromMaybe "(no name)" <$> threadLabel t + s <- threadStatus t + return (idstr, l, s) + #ifdef HTTP_OVER_TLS loadCredentials :: Option -> IO Credentials loadCredentials opt = do @@ -158,9 +179,9 @@ ifRouteFileIsValid :: Reporter -> Option -> (RouteDB -> IO ()) -> IO () ifRouteFileIsValid rpt opt act = case opt_routing_file opt of Nothing -> return () - Just rfile -> try (parseRoute rfile defaultDomain defaultPort) >>= either reportError act + Just rfile -> try (parseRoute rfile defaultDomain defaultPort) >>= either reportError_ act where - reportError = report rpt . BS.pack . ioeGetErrorString + reportError_ = report rpt . BS.pack . ioeGetErrorString ---------------------------------------------------------------- @@ -171,14 +192,14 @@ -> IO () mighty opt rpt svc lgr pushlgr mgr rdr _mcreds _msmgr tmgr = reportDo rpt $ case svc of - HttpOnly s -> runSettingsSocket setting s app + HttpOnly s -> runHTTP setting s app #ifdef HTTP_OVER_TLS - HttpsOnly s -> runTLSSocket tlsSetting setting s app + HttpsOnly s -> runHTTPS tlsSetting setting s app HttpAndHttps s1 s2 -> concurrently_ - (runSettingsSocket setting s1 app) - (runTLSSocket tlsSetting setting s2 app) + (runHTTP setting s1 app) + (runHTTPS tlsSetting setting s2 app) #ifdef HTTP_OVER_QUIC - QUIC s1 s2 s3 -> do + QUIC s1 s2 ss3 -> do let quicPort' = BS.pack $ show quicPort strver Q.Version1 = "" strver Q.Version2 = "" @@ -187,10 +208,11 @@ value v = BS.concat ["h3",v,"=\":",quicPort',"\""] altsvc = BS.intercalate "," $ map value quicDrafts settingT = setAltSvc altsvc setting - mapConcurrently_ id [runSettingsSocket setting s1 app - ,runTLSSocket tlsSetting settingT s2 app - ,runQUICSocket qconf setting s3 app - ] + h12 = concurrently_ (runHTTP setting s1 app) + (runHTTPS tlsSetting settingT s2 app) + h123 = concurrently_ (runHTTP3 qconf setting ss3 app) + (labelMe "concurrently" >> h12) + h123 #else _ -> error "never reach" #endif @@ -272,7 +294,7 @@ data Service = HttpOnly Socket | HttpsOnly Socket | HttpAndHttps Socket Socket - | QUIC Socket Socket Socket + | QUIC Socket Socket [Socket] instance Show Service where show HttpOnly{} = "HttpOnly" @@ -297,11 +319,11 @@ | service == 3 = do s1 <- bindPortTCP httpPort hostpref s2 <- bindPortTCP httpsPort hostpref - s3 <- bindPortUDP quicPort hostpref + ss3 <- mapM (bindPortUDP quicPort) quicAddrs debugMessage $ urlForHTTP httpPort debugMessage $ urlForHTTPS httpsPort debugMessage "QUIC is also available via Alt-Svc" - return $ QUIC s1 s2 s3 + return $ QUIC s1 s2 ss3 | otherwise = do s <- bindPortTCP httpPort hostpref debugMessage $ urlForHTTP httpPort @@ -310,6 +332,7 @@ httpPort = naturalToInt $ opt_port opt httpsPort = naturalToInt $ opt_tls_port opt quicPort = naturalToInt $ opt_quic_port opt + quicAddrs = fromString <$> opt_quic_addr opt hostpref = fromString $ opt_host opt service = opt_service opt debug = opt_debug_mode opt @@ -328,7 +351,7 @@ closeService (HttpOnly s) = close s closeService (HttpsOnly s) = close s closeService (HttpAndHttps s1 s2) = close s1 >> close s2 -closeService (QUIC s1 s2 s3) = close s1 >> close s2 >> close s3 +closeService (QUIC s1 s2 ss3) = close s1 >> close s2 >> mapM_ close ss3 ---------------------------------------------------------------- @@ -358,4 +381,28 @@ service = opt_service opt #else setup _ = return (Nothing, Nothing) +#endif + +labelMe :: String -> IO () +labelMe lbl = do + tid <- myThreadId + labelThread tid lbl + +runHTTP :: Settings -> Socket -> Application -> IO () +runHTTP setting s app = do + labelMe "HTTP1/2 server" + runSettingsSocket setting s app + +#ifdef HTTP_OVER_TLS +runHTTPS :: TLSSettings -> Settings -> Socket -> Application -> IO () +runHTTPS tlsSetting setting s app = do + labelMe "HTTP1/2 over TLS server" + runTLSSocket tlsSetting setting s app + +#ifdef HTTP_OVER_QUIC +runHTTP3 :: QUICSettings -> Settings -> [Socket]-> Application -> IO () +runHTTP3 qconf setting ss app = do + labelMe "HTTP3 server" + runQUICSockets qconf setting ss app +#endif #endif