mighttpd2 2.7.0 → 2.7.1
raw patch · 6 files changed
+229/−105 lines, 6 files
Files
+ Log.hs view
@@ -0,0 +1,22 @@+module Log (+ Logger+ , initLogger+ , apatcheLogger+ , finLogger+ ) where++import Network.Wai.Logger+import Network.Wai.Logger.Prefork++data Logger = Logger ApacheLogger LogFlusher++initLogger :: IPAddrSource -> LogType -> IO Logger+initLogger ipsrc logtyp = do+ (aplgr, flusher) <- logInit ipsrc logtyp+ return $ Logger aplgr flusher++finLogger :: Logger -> LogFlusher+finLogger (Logger _ flusher) = flusher++apatcheLogger :: Logger -> ApacheLogger+apatcheLogger (Logger aplogr _) = aplogr
Mighty.hs view
@@ -11,12 +11,15 @@ import Data.Conduit.Network import FileCGIApp import FileCache+import GHC.IO.Exception (IOErrorType(ResourceVanished))+import Log import Network import qualified Network.HTTP.Conduit as H import Network.Wai.Application.Classic hiding ((</>), (+++)) import Network.Wai.Handler.Warp import Network.Wai.Logger import Network.Wai.Logger.Prefork+import Prelude hiding (catch) import Process import Report import Route@@ -27,7 +30,7 @@ import System.Exit import System.FilePath import System.IO-import System.IO.Error (ioeGetErrorString)+import System.IO.Error (ioeGetErrorString, ioeGetErrorType) import System.Posix import Types import Utils@@ -37,14 +40,11 @@ main :: IO () main = do (opt,route) <- getOptRoute+ rpt <- initReporter >>= checkReporter if opt_debug_mode opt then- server opt route- else do- let port = opt_port opt- putStrLn $ "Serving on port " ++ show port ++ " and detaching this terminal..."- putStrLn $ "(If errors occur, they will be written in \"" ++ reportFile ++ "\".)"- hFlush stdout- daemonize $ server opt route+ server opt route rpt+ else+ background opt $ server opt route rpt where getOptRoute = getArgs >>= eachCase eachCase args@@ -74,11 +74,17 @@ | otherwise = do dir <- getCurrentDirectory return $ dir </> normalise file+ checkReporter (Right rpt) = return rpt+ checkReporter (Left e) = do+ hPutStrLn stderr $ reportFile ++ " is not writable"+ hPrint stderr e+ exitFailure ---------------------------------------------------------------- -server :: Option -> RouteDB -> IO ()-server opt route = safeDo $ do+server :: Option -> RouteDB -> Reporter -> IO ()+server opt route rpt = reportDo rpt $ do+ unlimit s <- sOpen if debug then do putStrLn $ "Serving on port " ++ show port ++ "."@@ -86,16 +92,18 @@ else writePidFile logCheck logtype- sref <- initState myid <- getProcessID+ stt <- initStater if workers == 1 then do- void . forkIO $ single opt route s logtype sref -- killed by signal+ lgr <- initLogger FromSocket logtype+ -- killed by signal+ void . forkIO $ single opt route s rpt stt lgr void . forkIO $ logController logtype [myid]- slaveMainLoop sref+ slaveMainLoop rpt stt lgr else do- cids <- multi opt route s logtype sref+ cids <- multi opt route s logtype stt rpt void . forkIO $ logController logtype cids- masterMainLoop myid+ masterMainLoop rpt myid where debug = opt_debug_mode opt port = opt_port opt@@ -114,48 +122,65 @@ logtype | not (opt_logging opt) = LogNone | debug = LogStdout- | otherwise = LogFile logspec+ | otherwise = LogFile logspec sigLogCtl ---------------------------------------------------------------- -masterMainLoop :: ProcessID -> IO ()-masterMainLoop myid = do+masterMainLoop :: Reporter -> ProcessID -> IO ()+masterMainLoop rpt myid = do threadDelay 10000000 cs <- findChildren myid- if null cs then -- FIXME serverStatus st == Retiring- report "Master Mighty retired"+ if null cs then do -- FIXME serverStatus st == Retiring+ report rpt "Master Mighty retired"+ finReporter rpt+ -- No logging+ exitSuccess else- masterMainLoop myid+ masterMainLoop rpt myid -slaveMainLoop :: StateRef -> IO ()-slaveMainLoop sref = do+slaveMainLoop :: Reporter -> Stater -> Logger -> IO ()+slaveMainLoop rpt stt lgr = do threadDelay 1000000- st <- getState sref- if serverStatus st == Retiring && connectionCounter st == 0 then- report "Worker Mighty retired"+ retiring <- isRetiring stt+ counter <- getConnectionCounter stt+ if retiring && counter == 0 then do+ report rpt "Worker Mighty retired"+ finReporter rpt+ finLogger lgr+ exitSuccess else- slaveMainLoop sref+ slaveMainLoop rpt stt lgr ---------------------------------------------------------------- -safeDo :: IO () -> IO ()-safeDo act = act `catches` [Handler asynHandler, Handler someHandler]--asynHandler :: AsyncException -> IO ()-asynHandler e- | e == ThreadKilled = return ()- | otherwise = report $ bshow e+reportDo :: Reporter -> IO () -> IO ()+reportDo rpt act = act `catch` warpHandler rpt -someHandler :: SomeException -> IO ()-someHandler e = report $ bshow e+warpHandler :: Reporter -> SomeException -> IO ()+warpHandler rpt e = throwIO e `catches` handlers+ where+ handlers = [Handler ah, Handler ih, Handler oh, Handler sh]+ ah :: AsyncException -> IO ()+ ah ThreadKilled = norecode+ ah x = recode x+ ih :: InvalidRequest -> IO ()+ ih _ = norecode+ oh :: IOException -> IO ()+ oh x+ | ioeGetErrorType x == ResourceVanished = norecode+ | otherwise = recode x+ sh :: SomeException -> IO ()+ sh x = recode x+ norecode = return ()+ recode :: Exception e => e -> IO ()+ recode = report rpt . bshow ---------------------------------------------------------------- -single :: Option -> RouteDB -> Socket -> LogType -> StateRef -> IO ()-single opt route s logtype sref = safeDo $ do+single :: Option -> RouteDB -> Socket -> Reporter -> Stater -> Logger -> IO ()+single opt route s rpt stt lgr = reportDo rpt $ do setGroupUser opt -- don't change the user of the master process ignoreSigChild- lgr <- logInit FromSocket logtype getInfo <- fileCacheInit mgr <- H.newManager H.def { -- FIXME@@ -165,52 +190,54 @@ setHandler sigRetire retireHandler setHandler sigReload (reloadHandler lgr getInfo mgr) setHandler sigInfo infoHandler- report "Worker Mighty started"- single' opt route s sref lgr getInfo mgr+ report rpt "Worker Mighty started"+ single' opt route s rpt stt lgr getInfo mgr where stopHandler = Catch $ do- report "Worker Mighty finished"+ report rpt "Worker Mighty finished"+ finReporter rpt+ finLogger lgr sClose s exitImmediately ExitSuccess retireHandler = Catch $- warpThreadId <$> getState sref >>>= \tid -> do- report "Worker Mighty retiring"+ getWarpThreadId stt >>>= \tid -> do+ report rpt "Worker Mighty retiring" killThread tid sClose s- retireStatus sref- reloadHandler lgr getInfo mgr = Catch $- warpThreadId <$> getState sref >>>= \tid ->- ifRouteFileIsValid opt $ \newroute -> do- report "Worker Mighty reloaded"+ goRetiring stt+ reloadHandler lggr getInfo mgr = Catch $+ getWarpThreadId stt >>>= \tid ->+ ifRouteFileIsValid rpt opt $ \newroute -> do+ report rpt "Worker Mighty reloaded" killThread tid- void . forkIO $ single' opt newroute s sref lgr getInfo mgr+ void . forkIO $ single' opt newroute s rpt stt lggr getInfo mgr infoHandler = Catch $ do- st <- getState sref- let i = bshow $ connectionCounter st- status = bshow $ serverStatus st- report $ status +++ ": # of connections = " +++ i+ i <- bshow <$> getConnectionCounter stt+ status <- bshow <$> getServerStatus stt+ report rpt $ status +++ ": # of connections = " +++ i single' :: Option -> RouteDB -> Socket- -> StateRef -> ApacheLogger -> (Path -> IO FileInfo) -> H.Manager+ -> Reporter -> Stater -> Logger+ -> (Path -> IO FileInfo) -> H.Manager -> IO ()-single' opt route s sref lgr getInfo mgr = safeDo $ do- myThreadId >>= setWarpThreadId sref+single' opt route s rpt stt lgr getInfo mgr = reportDo rpt $ do+ myThreadId >>= setWarpThreadId stt runSettingsSocket setting s $ \req -> fileCgiApp cspec filespec cgispec revproxyspec route req where debug = opt_debug_mode opt setting = defaultSettings { settingsPort = opt_port opt- , settingsOnException = if debug then printStdout else ignore- , settingsOnOpen = increment sref- , settingsOnClose = decrement sref+ , settingsOnException = if debug then printStdout else warpHandler rpt+ , settingsOnOpen = increment stt+ , settingsOnClose = decrement stt , settingsTimeout = opt_connection_timeout opt , settingsHost = HostAny } serverName = BS.pack $ opt_server_name opt cspec = ClassicAppSpec { softwareName = serverName- , logger = lgr+ , logger = apatcheLogger lgr , statusFileDir = fromString $ opt_status_file_dir opt } filespec = FileAppSpec {@@ -227,13 +254,15 @@ ---------------------------------------------------------------- -multi :: Option -> RouteDB -> Socket -> LogType -> StateRef -> IO [ProcessID]-multi opt route s logtype sref = do- report "Master Mighty started"+multi :: Option -> RouteDB -> Socket -> LogType -> Stater -> Reporter -> IO [ProcessID]+multi opt route s logtype stt rpt = do+ report rpt "Master Mighty started" ignoreSigChild cids <- replicateM workers $ forkProcess $ do- void . forkIO $ single opt route s logtype sref -- killed by signal- slaveMainLoop sref+ lgr <- initLogger FromSocket logtype+ -- killed by signal+ void . forkIO $ single opt route s rpt stt lgr+ slaveMainLoop rpt stt lgr sClose s setHandler sigStop $ stopHandler cids setHandler sigINT $ stopHandler cids -- C-c from keyboard when debugging@@ -244,26 +273,28 @@ where workers = opt_worker_processes opt stopHandler cids = Catch $ do- report "Master Mighty finished"+ report rpt "Master Mighty finished"+ finReporter rpt+ -- No logging mapM_ (sendSignal sigStop) cids exitImmediately ExitSuccess retireHandler cids = Catch $ do- report "Master Mighty retiring"- retireStatus sref+ report rpt "Master Mighty retiring"+ goRetiring stt mapM_ (sendSignal sigRetire) cids- reloadHandler cids = Catch $ ifRouteFileIsValid opt $ \_ -> do- report "Master Mighty reloaded"+ reloadHandler cids = Catch $ ifRouteFileIsValid rpt opt $ \_ -> do+ report rpt "Master Mighty reloaded" mapM_ (sendSignal sigReload) cids infoHandler cids = Catch $ mapM_ (sendSignal sigInfo) cids ---------------------------------------------------------------- -ifRouteFileIsValid :: Option -> (RouteDB -> IO ()) -> IO ()-ifRouteFileIsValid opt act =+ifRouteFileIsValid :: Reporter -> Option -> (RouteDB -> IO ()) -> IO ()+ifRouteFileIsValid rpt opt act = return (opt_routing_file opt) >>>= \rfile -> try (parseRoute rfile) >>= either reportError act where- reportError = report . BS.pack . ioeGetErrorString+ reportError = report rpt . BS.pack . ioeGetErrorString ---------------------------------------------------------------- @@ -279,6 +310,26 @@ ---------------------------------------------------------------- +unlimit :: IO ()+unlimit = handle ignore $ do+ hard <- hardLimit <$> getResourceLimit ResourceOpenFiles+ let lim = if hard == ResourceLimitInfinity then+ ResourceLimits (ResourceLimit 10000) hard+ else+ ResourceLimits hard hard+ setResourceLimit ResourceOpenFiles lim++----------------------------------------------------------------++background :: Option -> IO () -> IO ()+background opt svr = do+ putStrLn $ "Serving on port " ++ show port ++ " and detaching this terminal..."+ putStrLn $ "(If errors occur, they will be written in \"" ++ reportFile ++ "\".)"+ hFlush stdout+ daemonize svr+ where+ port = opt_port opt+ daemonize :: IO () -> IO () daemonize program = ensureDetachTerminalCanWork $ do detachTerminal@@ -290,8 +341,8 @@ where ensureDetachTerminalCanWork p = do void $ forkProcess p- exitImmediately ExitSuccess+ exitSuccess ensureNeverAttachTerminal p = do void $ forkProcess p- exitImmediately ExitSuccess+ exitSuccess detachTerminal = void createSession
Report.hs view
@@ -1,22 +1,37 @@ {-# LANGUAGE OverloadedStrings #-} -module Report where+module Report (+ Reporter+ , initReporter+ , finReporter+ , report+ , reportFile+ ) where import Control.Applicative import Control.Exception import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.UnixTime+import System.IO import System.Posix import Utils reportFile :: FilePath reportFile = "/tmp/mighty_report" -report :: ByteString -> IO ()-report msg = handle ignore $ do- pid <- BS.pack . show <$> getProcessID- tm <- formatUnixTime "%d %b %Y %H:%M:%S" <$> getUnixTime- BS.appendFile reportFile $ BS.concat [tm, ": pid = ", pid, ": ", msg, "\n"]+newtype Reporter = Reporter Handle +initReporter :: IO (Either SomeException Reporter)+initReporter = try $ Reporter <$> openFile reportFile AppendMode +finReporter :: Reporter -> IO ()+finReporter (Reporter rpthdl) = hClose rpthdl++report :: Reporter -> ByteString -> IO ()+report (Reporter rpthdl) msg = handle ignore $ do+ pid <- BS.pack . show <$> getProcessID+ tm <- formatUnixTime "%d %b %Y %H:%M:%S" <$> getUnixTime+ let logmsg = BS.concat [tm, ": pid = ", pid, ": ", msg, "\n"]+ BS.hPutStr rpthdl logmsg+ hFlush rpthdl
Signal.hs view
@@ -18,7 +18,10 @@ sigRetire = sigQUIT sigInfo :: Signal-sigInfo = sigUSR2 -- sigUSR1 does not work on Linux+sigInfo = sigUSR2++sigLogCtl :: Signal+sigLogCtl = sigUSR1 ----------------------------------------------------------------
State.hs view
@@ -1,49 +1,81 @@-module State where+module State (+ Status(..)+ , Stater+ , initStater+ , getConnectionCounter+ , increment+ , decrement+ , isRetiring+ , goRetiring+ , getServerStatus+ , getWarpThreadId+ , setWarpThreadId+ ) where +import Control.Applicative import Control.Concurrent import Data.IORef import Utils +----------------------------------------------------------------+ data Status = Serving | Retiring deriving (Eq, Show) data State = State { connectionCounter :: !Int- , serverStatus :: !Status- , warpThreadId :: !(Maybe ThreadId)+ , serverStatus :: !Status+ , warpThreadId :: !(Maybe ThreadId) } initialState :: State initialState = State 0 Serving Nothing -type StateRef = IORef State+---------------------------------------------------------------- -initState :: IO (IORef State)-initState = newIORef initialState+newtype Stater = Stater (IORef State) -getState :: IORef State -> IO State-getState = readIORef+initStater :: IO Stater+initStater = Stater <$> newIORef initialState -retireStatus :: StateRef -> IO ()-retireStatus sref =- strictAtomicModifyIORef sref $ \st -> st {- serverStatus = Retiring- , warpThreadId = Nothing- }+---------------------------------------------------------------- -increment :: IORef State -> IO ()-increment sref =+getConnectionCounter :: Stater -> IO Int+getConnectionCounter (Stater sref) = connectionCounter <$> readIORef sref++increment :: Stater -> IO ()+increment (Stater sref) = strictAtomicModifyIORef sref $ \st -> st { connectionCounter = connectionCounter st + 1 } -decrement :: IORef State -> IO ()-decrement sref =+decrement :: Stater -> IO ()+decrement (Stater sref) = strictAtomicModifyIORef sref $ \st -> st { connectionCounter = connectionCounter st - 1 } -setWarpThreadId :: IORef State -> ThreadId -> IO ()-setWarpThreadId sref tid =+----------------------------------------------------------------++getServerStatus :: Stater -> IO Status+getServerStatus (Stater sref) = serverStatus <$> readIORef sref++isRetiring :: Stater -> IO Bool+isRetiring stt = (== Retiring) <$> getServerStatus stt++goRetiring :: Stater -> IO ()+goRetiring (Stater sref) =+ strictAtomicModifyIORef sref $ \st -> st {+ serverStatus = Retiring+ , warpThreadId = Nothing+ }++----------------------------------------------------------------++getWarpThreadId :: Stater -> IO (Maybe ThreadId)+getWarpThreadId (Stater sref) = warpThreadId <$> readIORef sref++setWarpThreadId :: Stater -> ThreadId -> IO ()+setWarpThreadId (Stater sref) tid = strictAtomicModifyIORef sref $ \st -> st { warpThreadId = Just tid }
mighttpd2.cabal view
@@ -1,5 +1,5 @@ Name: mighttpd2-Version: 2.7.0+Version: 2.7.1 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -17,7 +17,7 @@ Executable mighty Main-Is: Mighty.hs- GHC-Options: -Wall -threaded -eventlog+ GHC-Options: -Wall -threaded Build-Depends: base >= 4.0 && < 5 -- should be removed someday , blaze-html >= 0.5@@ -50,6 +50,7 @@ Config.Internal FileCGIApp FileCache+ Log Mighty Parser Process