mighttpd2 4.0.7 → 4.0.8
raw patch · 5 files changed
+77/−27 lines, 5 filesdep −unliftioPVP ok
version bump matches the API change (PVP)
Dependencies removed: unliftio
API changes (from Hackage documentation)
Files
- Program/Mighty/Parser.hs +1/−1
- Program/Mighty/Report.hs +6/−2
- Program/Mighty/Resource.hs +1/−1
- mighttpd2.cabal +3/−4
- src/Server.hs +66/−19
Program/Mighty/Parser.hs view
@@ -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
Program/Mighty/Report.hs view
@@ -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]
Program/Mighty/Resource.hs view
@@ -6,8 +6,8 @@ unlimit, ) where +import Control.Exception import System.Posix-import UnliftIO.Exception ----------------------------------------------------------------
mighttpd2.cabal view
@@ -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 <kazu@iij.ad.jp>@@ -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,
src/Server.hs view
@@ -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