mighttpd2 2.8.4 → 2.8.5
raw patch · 44 files changed
+1567/−1340 lines, 44 filesdep +tlsdep +warp-tlsdep ~http-conduit
Dependencies added: tls, warp-tls
Dependency ranges changed: http-conduit
Files
- Config.hs +0/−3
- Config/Internal.hs +0/−137
- FileCGIApp.hs +0/−74
- FileCache.hs +0/−70
- Log.hs +0/−22
- Mighty.hs +0/−385
- Parser.hs +0/−37
- Process.hs +0/−98
- Report.hs +0/−37
- Route.hs +0/−76
- Signal.hs +0/−35
- State.hs +0/−81
- Types.hs +0/−34
- Utils.hs +0/−41
- conf/example.conf +24/−0
- conf/example.route +23/−0
- example.conf +0/−19
- example.route +0/−23
- mighttpd2.cabal +34/−4
- mightyctl.hs +0/−66
- mkindex.hs +0/−95
- src/Config.hs +3/−0
- src/Config/Internal.hs +152/−0
- src/Daemon.hs +33/−0
- src/FileCGIApp.hs +86/−0
- src/FileCache.hs +70/−0
- src/Log.hs +22/−0
- src/Mighty.hs +145/−0
- src/Multi.hs +73/−0
- src/Net.hs +28/−0
- src/Parser.hs +37/−0
- src/Process.hs +98/−0
- src/Report.hs +69/−0
- src/Resource.hs +35/−0
- src/Route.hs +76/−0
- src/Signal.hs +34/−0
- src/Single.hs +179/−0
- src/State.hs +109/−0
- src/Types.hs +38/−0
- src/Utils.hs +34/−0
- test/ConfigSpec.hs +2/−2
- test/RouteSpec.hs +1/−1
- utils/mightyctl.hs +67/−0
- utils/mkindex.hs +95/−0
− Config.hs
@@ -1,3 +0,0 @@-module Config (Option(..), parseOption, defaultOption) where--import Config.Internal
− Config/Internal.hs
@@ -1,137 +0,0 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, OverloadedStrings #-}--module Config.Internal where--import Control.Applicative hiding (many,optional,(<|>))-import Parser-import Text.Parsec-import Text.Parsec.ByteString.Lazy-import Types--------------------------------------------------------------------defaultOption :: Option-defaultOption = Option {- opt_port = 8080- , opt_debug_mode = True- , opt_user = "root"- , opt_group = "root"- , opt_pid_file = "/var/run/mighty.pid"- , opt_logging = True- , opt_log_file = "/var/log/mighty"- , opt_log_file_size = 16777216- , opt_log_backup_number = 10- , opt_index_file = "index.html"- , opt_index_cgi = "index.cgi"- , opt_status_file_dir = "/usr/local/share/mighty/status"- , opt_connection_timeout = 30- , opt_fd_cache_duration = 10- , opt_server_name = programName ++ "/" ++ programVersion- , opt_worker_processes = 1- , opt_routing_file = Nothing-}--data Option = Option {- opt_port :: !Int- , opt_debug_mode :: !Bool- , opt_user :: !String- , opt_group :: !String- , opt_pid_file :: !String- , opt_logging :: !Bool- , opt_log_file :: !String- , opt_log_file_size :: !Int- , opt_log_backup_number :: !Int- , opt_index_file :: !String- , opt_index_cgi :: !String- , opt_status_file_dir :: !String- , opt_connection_timeout :: !Int- , opt_fd_cache_duration :: !Int- , opt_server_name :: !String- , opt_worker_processes :: !Int- , opt_routing_file :: !(Maybe FilePath)-} deriving (Eq,Show)--------------------------------------------------------------------parseOption :: String -> IO Option-parseOption file = makeOpt defaultOption <$> parseConfig file--------------------------------------------------------------------makeOpt :: Option -> [Conf] -> Option-makeOpt def conf = Option {- opt_port = get "Port" opt_port- , opt_debug_mode = get "Debug_Mode" opt_debug_mode- , opt_user = get "User" opt_user- , opt_group = get "Group" opt_group- , opt_pid_file = get "Pid_File" opt_pid_file- , opt_logging = get "Logging" opt_logging- , opt_log_file = get "Log_File" opt_log_file- , opt_log_file_size = get "Log_File_Size" opt_log_file_size- , opt_log_backup_number = get "Log_Backup_Number" opt_log_backup_number- , opt_index_file = get "Index_File" opt_index_file- , opt_index_cgi = get "Index_Cgi" opt_index_cgi- , opt_status_file_dir = get "Status_File_Dir" opt_status_file_dir- , opt_connection_timeout = get "Connection_Timeout" opt_connection_timeout- , opt_fd_cache_duration = get "Fd_Cache_Duration" opt_fd_cache_duration- , opt_server_name = get "Server_Name" opt_server_name- , opt_worker_processes = get "Worker_Processes" opt_worker_processes- , opt_routing_file = Nothing- }- where- get k func = maybe (func def) fromConf $ lookup k conf--------------------------------------------------------------------type Conf = (String, ConfValue)--data ConfValue = CV_Int Int | CV_Bool Bool | CV_String String deriving (Eq,Show)--class FromConf a where- fromConf :: ConfValue -> a--instance FromConf Int where- fromConf (CV_Int n) = n- fromConf _ = error "fromConf int"--instance FromConf Bool where- fromConf (CV_Bool b) = b- fromConf _ = error "fromConf bool"--instance FromConf String where- fromConf (CV_String s) = s- fromConf _ = error "fromConf string"--------------------------------------------------------------------parseConfig :: FilePath -> IO [Conf]-parseConfig = parseFile config--------------------------------------------------------------------config :: Parser [Conf]-config = commentLines *> many cfield <* eof- where- cfield = field <* commentLines--field :: Parser Conf-field = (,) <$> key <*> (sep *> value) <* trailing--key :: Parser String-key = many1 (oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_") <* spcs--sep :: Parser ()-sep = () <$ char ':' *> spcs--value :: Parser ConfValue-value = choice [try cv_int, try cv_bool, cv_string] <* spcs--cv_int :: Parser ConfValue-cv_int = CV_Int . read <$> many1 digit--cv_bool :: Parser ConfValue-cv_bool = CV_Bool True <$ string "Yes" <|>- CV_Bool False <$ string "No"--cv_string :: Parser ConfValue-cv_string = CV_String <$> many1 (noneOf " \t\n")
− FileCGIApp.hs
@@ -1,74 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module FileCGIApp (fileCgiApp) where--import Control.Monad.IO.Class (liftIO)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BS-import Network.HTTP.Types-import Network.Wai-import Network.Wai.Application.Classic-import Types--data Perhaps a = Found a | Redirect | Fail--fileCgiApp :: ClassicAppSpec -> FileAppSpec -> CgiAppSpec -> RevProxyAppSpec -> RouteDB -> Application-fileCgiApp cspec filespec cgispec revproxyspec um req = case mmp of- Fail -> do- let st = preconditionFailed412- liftIO $ logger cspec req st Nothing- fastResponse st defaultHeader "Precondition Failed\r\n"- Redirect -> do- let st = movedPermanently301- hdr = defaultHeader ++ redirectHeader req- liftIO $ logger cspec req st Nothing- fastResponse st hdr "Moved Permanently\r\n"- Found (RouteFile src dst) ->- fileApp cspec filespec (FileRoute src dst) req- Found (RouteRedirect src dst) ->- redirectApp cspec (RedirectRoute src dst) req- Found (RouteCGI src dst) ->- cgiApp cspec cgispec (CgiRoute src dst) req- Found (RouteRevProxy src dst dom prt) ->- revProxyApp cspec revproxyspec (RevProxyRoute src dst dom prt) req- where- mmp = case getBlock (serverName req) um of- Nothing -> Fail- Just blk -> getRoute (rawPathInfo req) blk- fastResponse st hdr body = return $ responseLBS st hdr body- defaultHeader = [("Content-Type", "text/plain")- ,("Server", softwareName cspec)]--getBlock :: ByteString -> RouteDB -> Maybe [Route]-getBlock _ [] = Nothing-getBlock key (Block doms maps : ms)- | "*" `elem` doms = Just maps- | key `elem` doms = Just maps- | otherwise = getBlock key ms--getRoute :: ByteString -> [Route] -> Perhaps Route-getRoute _ [] = Fail-getRoute key (m:ms)- | src `isPrefixOf` key = Found m- | src `isMountPointOf` key = Redirect- | otherwise = getRoute key ms- where- src = routeSource m--routeSource :: Route -> Src-routeSource (RouteFile src _) = src-routeSource (RouteRedirect src _) = src-routeSource (RouteCGI src _) = src-routeSource (RouteRevProxy src _ _ _) = src--isPrefixOf :: Path -> ByteString -> Bool-isPrefixOf src key = src' `BS.isPrefixOf` key- where- src' = pathByteString src--isMountPointOf :: Path -> ByteString -> Bool-isMountPointOf src key = hasTrailingPathSeparator src- && BS.length src' - BS.length key == 1- && key `BS.isPrefixOf` src'- where- src' = pathByteString src
− FileCache.hs
@@ -1,70 +0,0 @@-module FileCache (fileCacheInit) where--import Control.Concurrent-import Control.Exception-import Control.Exception.IOChoice-import Control.Monad-import Data.ByteString (ByteString)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import Data.IORef-import Network.HTTP.Date-import Network.Wai.Application.Classic-import System.Posix.Files-import Utils--data Entry = Negative | Positive FileInfo-type Cache = HashMap ByteString Entry-type GetInfo = Path -> IO FileInfo--fileInfo :: IORef Cache -> GetInfo-fileInfo ref path = do- cache <- readIORef ref- case M.lookup bpath cache of- Just Negative -> throwIO (userError "fileInfo")- Just (Positive x) -> return x- Nothing -> register ||> negative ref path- where- bpath = pathByteString path- sfile = pathString path- register = do- fs <- getFileStatus sfile- if not (isDirectory fs) then- positive ref fs path- else- goNext--positive :: IORef Cache -> FileStatus -> GetInfo-positive ref fs path = do- strictAtomicModifyIORef ref $ M.insert bpath entry- return info- where- info = FileInfo {- fileInfoName = path- , fileInfoSize = size fs- , fileInfoTime = time- , fileInfoDate = formatHTTPDate time- }- size = fromIntegral . fileSize- time = epochTimeToHTTPDate (modificationTime fs)- entry = Positive info- bpath = pathByteString path--negative :: IORef Cache -> GetInfo-negative ref path = do- strictAtomicModifyIORef ref $ M.insert bpath Negative- throwIO (userError "fileInfo")- where- bpath = pathByteString path--------------------------------------------------------------------fileCacheInit :: IO GetInfo-fileCacheInit = do- ref <- newIORef M.empty- void . forkIO $ remover ref- return $ fileInfo ref---- atomicModifyIORef is not necessary here.-remover :: IORef Cache -> IO ()-remover ref = forever $ threadDelay 10000000 >> writeIORef ref M.empty
− Log.hs
@@ -1,22 +0,0 @@-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
@@ -1,385 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Main where--import Config-import Control.Applicative-import Control.Concurrent-import Control.Exception-import qualified Control.Exception as E (catch)-import Control.Monad-import qualified Data.ByteString.Char8 as BS-import Data.Conduit.Network-import FileCGIApp-import FileCache-import GHC.IO.Exception (IOErrorType(ResourceVanished))-import Log-import Network-import Network.BSD-import qualified Network.HTTP.Conduit as H-import Network.HTTP.Date-import Network.Socket-import Network.Wai.Application.Classic hiding ((</>), (+++))-import Network.Wai.Handler.Warp-import Network.Wai.Logger-import Network.Wai.Logger.Prefork-import Process (findChildren, PsResult, dummyResult)-import Report-import Route-import Signal-import State-import System.Date.Cache-import System.Directory-import System.Environment-import System.Exit-import System.FilePath-import System.IO-import System.IO.Error (ioeGetErrorString, ioeGetErrorType)-import System.Posix-import Types-import Utils--------------------------------------------------------------------main :: IO ()-main = do- (opt,route) <- getOptRoute- rpt <- initReporter >>= checkReporter- if opt_debug_mode opt then- server opt route rpt- else- background opt $ server opt route rpt- where- getOptRoute = getArgs >>= eachCase- eachCase args- | n == 0 = do- root <- amIrootUser- let opt | root = defaultOption { opt_port = 80 }- | otherwise = defaultOption- dir <- getCurrentDirectory- let dst = fromString . addTrailingPathSeparator $ dir- route = [Block ["*"] [RouteFile "/" dst]]- return (opt, route)- | n == 2 = do- let config_file = args !! 0- routing_file <- getAbsoluteFile (args !! 1)- opt <- parseOption config_file- route <- parseRoute routing_file- let opt' = opt {opt_routing_file = Just routing_file}- return (opt',route)- | otherwise = do- hPutStrLn stderr "Usage: mighty"- hPutStrLn stderr " mighty config_file routing_file"- exitFailure- where- n = length args- getAbsoluteFile file- | isAbsolute file = return file- | 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 -> Reporter -> IO ()-server opt route rpt = reportDo rpt $ do- unlimit- s <- sOpen- if debug then do- putStrLn $ "Serving on port " ++ show port ++ "."- hFlush stdout- else- writePidFile- logCheck logtype- myid <- getProcessID- stt <- initStater- if workers == 1 then do- lgr <- initLogger FromSocket logtype- -- killed by signal- void . forkIO $ single opt route s rpt stt lgr- void . forkIO $ logController logtype [myid]- slaveMainLoop rpt stt lgr- else do- cids <- multi opt route s logtype stt rpt- void . forkIO $ logController logtype cids- masterMainLoop rpt myid- where- debug = opt_debug_mode opt- port = opt_port opt- sOpen = listenSocket (show port)- pidfile = opt_pid_file opt- workers = opt_worker_processes opt- writePidFile = do- pid <- getProcessID- writeFile pidfile $ show pid ++ "\n"- setFileMode pidfile 0o644- logspec = FileLogSpec {- log_file = opt_log_file opt- , log_file_size = fromIntegral $ opt_log_file_size opt- , log_backup_number = opt_log_backup_number opt- }- logtype- | not (opt_logging opt) = LogNone- | debug = LogStdout- | otherwise = LogFile logspec sigLogCtl--------------------------------------------------------------------masterMainLoop :: Reporter -> ProcessID -> IO ()-masterMainLoop rpt myid = do- threadDelay 10000000- cs <- findChildren myid `E.catch` handler- if null cs then do -- FIXME serverStatus st == Retiring- report rpt "Master Mighty retired"- finReporter rpt- -- No logging- exitSuccess- else- masterMainLoop rpt myid- where- handler :: SomeException -> IO [PsResult]- handler _ = return [dummyResult]--slaveMainLoop :: Reporter -> Stater -> Logger -> IO ()-slaveMainLoop rpt stt lgr = do- threadDelay 1000000- retiring <- isRetiring stt- counter <- getConnectionCounter stt- if retiring && counter == 0 then do- report rpt "Worker Mighty retired"- finReporter rpt- finLogger lgr- exitSuccess- else- slaveMainLoop rpt stt lgr--------------------------------------------------------------------reportDo :: Reporter -> IO () -> IO ()-reportDo rpt act = act `E.catch` warpHandler rpt--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 -> 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- getInfo <- fileCacheInit- mgr <- H.newManager H.def {- -- FIXME- H.managerConnCount = 1024- }- setHandler sigStop stopHandler- setHandler sigRetire retireHandler- setHandler sigReload (reloadHandler lgr getInfo mgr)- setHandler sigInfo infoHandler- report rpt "Worker Mighty started"- single' opt route s rpt stt lgr getInfo mgr- where- stopHandler = Catch $ do- report rpt "Worker Mighty finished"- finReporter rpt- finLogger lgr- sClose s- exitImmediately ExitSuccess- retireHandler = Catch $- getWarpThreadId stt >>>= \tid -> do- report rpt "Worker Mighty retiring"- killThread tid- sClose s- 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 rpt stt lggr getInfo mgr- infoHandler = Catch $ do- i <- bshow <$> getConnectionCounter stt- status <- bshow <$> getServerStatus stt- report rpt $ status +++ ": # of connections = " +++ i--single' :: Option -> RouteDB -> Socket- -> Reporter -> Stater -> Logger- -> (Path -> IO FileInfo) -> H.Manager- -> IO ()-single' opt route s rpt stt lgr getInfo mgr = reportDo rpt $ do- myThreadId >>= setWarpThreadId stt- zdater <- initZoneDater- runSettingsSocket setting s $ \req ->- fileCgiApp (cspec zdater) filespec cgispec revproxyspec route req- where- debug = opt_debug_mode opt- setting = defaultSettings {- settingsPort = opt_port opt- , settingsOnException = if debug then printStdout else warpHandler rpt- , settingsOnOpen = increment stt- , settingsOnClose = decrement stt- , settingsTimeout = opt_connection_timeout opt- , settingsHost = HostAny- , settingsFdCacheDuration = opt_fd_cache_duration opt- , settingsResourceTPerRequest = False- }- serverName = BS.pack $ opt_server_name opt- cspec zdater = ClassicAppSpec {- softwareName = serverName- , logger = apatcheLogger lgr- , dater = zdater- , statusFileDir = fromString $ opt_status_file_dir opt- }- filespec = FileAppSpec {- indexFile = fromString $ opt_index_file opt- , isHTML = \x -> ".html" `isSuffixOf` x || ".htm" `isSuffixOf` x- , getFileInfo = getInfo- }- cgispec = CgiAppSpec {- indexCgi = "index.cgi"- }- revproxyspec = RevProxyAppSpec {- revProxyManager = mgr- }- initZoneDater = fst <$> clockDateCacher DateCacheConf {- getTime = epochTime- , formatDate = return . formatHTTPDate . epochTimeToHTTPDate- }--------------------------------------------------------------------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- 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- setHandler sigRetire $ retireHandler cids- setHandler sigReload $ reloadHandler cids- setHandler sigInfo $ infoHandler cids- return cids- where- workers = opt_worker_processes opt- stopHandler cids = Catch $ do- report rpt "Master Mighty finished"- finReporter rpt- -- No logging- mapM_ (sendSignal sigStop) cids- exitImmediately ExitSuccess- retireHandler cids = Catch $ do- report rpt "Master Mighty retiring"- goRetiring stt- mapM_ (sendSignal sigRetire) cids- reloadHandler cids = Catch $ ifRouteFileIsValid rpt opt $ \_ -> do- report rpt "Master Mighty reloaded"- mapM_ (sendSignal sigReload) cids- infoHandler cids = Catch $ mapM_ (sendSignal sigInfo) cids--------------------------------------------------------------------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 rpt . BS.pack . ioeGetErrorString--------------------------------------------------------------------amIrootUser :: IO Bool-amIrootUser = (== 0) <$> getRealUserID--setGroupUser :: Option -> IO ()-setGroupUser opt = do- root <- amIrootUser- when root $ do- getGroupEntryForName (opt_group opt) >>= setGroupID . groupID- getUserEntryForName (opt_user opt) >>= setUserID . userID--------------------------------------------------------------------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- ensureNeverAttachTerminal $ do- changeWorkingDirectory "/"- void $ setFileCreationMask 0- mapM_ closeFd [stdInput, stdOutput, stdError]- program- where- ensureDetachTerminalCanWork p = do- void $ forkProcess p- exitSuccess- ensureNeverAttachTerminal p = do- void $ forkProcess p- exitSuccess- detachTerminal = void createSession--listenSocket :: String -> IO Socket-listenSocket serv = do- proto <- getProtocolNumber "tcp"- let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_PASSIVE]- , addrSocketType = Stream- , addrProtocol = proto }- addrs <- getAddrInfo (Just hints) Nothing (Just serv)- let addrs' = filter (\x -> addrFamily x == AF_INET6) addrs- addr = if null addrs' then head addrs else head addrs'- listenSocket' addr--listenSocket' :: AddrInfo -> IO Socket-listenSocket' addr = bracketOnError setup cleanup $ \sock -> do- setSocketOption sock ReuseAddr 1- setSocketOption sock NoDelay 1- bindSocket sock (addrAddress addr)- listen sock 2048- return sock- where- setup = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)- cleanup = sClose
− Parser.hs
@@ -1,37 +0,0 @@-module Parser where--import Control.Applicative hiding (many,(<|>))-import Control.Exception-import qualified Data.ByteString.Lazy.Char8 as BL-import System.IO-import Text.Parsec-import Text.Parsec.ByteString.Lazy--spcs :: Parser ()-spcs = () <$ many spc--spcs1 :: Parser ()-spcs1 = () <$ many1 spc--spc :: Parser Char-spc = satisfy (`elem` " \t")--commentLines :: Parser ()-commentLines = () <$ many commentLine- where- commentLine = trailing--trailing :: Parser ()-trailing = () <$ (comment *> newline <|> newline)--comment :: Parser ()-comment = () <$ char '#' <* many (noneOf "\n")--parseFile :: Parser a -> FilePath -> IO a-parseFile p file = do- hdl <- openFile file ReadMode- hSetEncoding hdl latin1- bs <- BL.hGetContents hdl- case parse p "parseFile" bs of- Right x -> return x- Left e -> throwIO . userError . show $ e
− Process.hs
@@ -1,98 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Process (- getMightyPid- , findChildren- , dummyResult- , PsResult(..)- ) where--import Control.Applicative-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as BS-import Data.Conduit-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.List as CL-import Data.Conduit.Process-import Data.Function-import Data.List-import Data.Ord-import System.Posix.Types--------------------------------------------------------------------data PsResult = PsResult {- uid :: ByteString- , pid :: ProcessID- , ppid :: ProcessID- , command :: ByteString- } deriving (Eq, Show)--dummyResult :: PsResult-dummyResult = PsResult "" 0 0 ""--toPsResult :: [ByteString] -> PsResult-toPsResult (a:b:c:_:_:_:_:h:_) = PsResult {- uid = a- , pid = maybe 0 (fromIntegral . fst) $ BS.readInt b- , ppid = maybe 0 (fromIntegral . fst) $ BS.readInt c- , command = h- }-toPsResult _ = PsResult "unknown" 0 0 "unknown"--------------------------------------------------------------------runPS :: IO [PsResult]-runPS = runResourceT $- sourceCmd "ps -ef"- $= CB.lines- $= CL.map BS.words- $= CL.map toPsResult- $= CL.filter mighty- $$ CL.consume- where- commandName = last . split '/' . command- mighty ps = "mighty" `BS.isInfixOf` name- && not ("mightyctl" `BS.isInfixOf` name)- where- name = commandName ps--------------------------------------------------------------------findParent :: [PsResult] -> [PsResult]-findParent ps = deleteAloneChild $ masters ++ candidates- where- iAmMaster p = ppid p == 1- masters = filter iAmMaster ps- rest = filter (not.iAmMaster) ps- candidates = map head- $ filter (\xs -> length xs == 1) -- master is alone- $ groupBy ((==) `on` ppid)- $ sortBy (comparing ppid) rest---deleteAloneChild :: [PsResult] -> [PsResult]-deleteAloneChild [] = []-deleteAloneChild (p:ps) = p : deleteAloneChild (filter noParent ps)- where- parent = pid p- noParent x = ppid x /= parent--------------------------------------------------------------------getMightyPid :: IO [ProcessID]-getMightyPid = (map pid . findParent) <$> runPS--------------------------------------------------------------------findChildren :: ProcessID -> IO [PsResult]-findChildren parent = filter (\p -> ppid p == parent) <$> runPS--------------------------------------------------------------------split :: Char -> ByteString -> [ByteString]-split _ "" = []-split c s = case BS.break (c==) s of- ("",r) -> split c (BS.tail r)- (s',"") -> [s']- (s',r) -> s' : split c (BS.tail r)
− Report.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--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"--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
− Route.hs
@@ -1,76 +0,0 @@-{-# LANGUAGE OverloadedStrings, TupleSections #-}--module Route (parseRoute) where--import Control.Applicative hiding (many,(<|>))-import Control.Monad-import qualified Data.ByteString.Char8 as BS-import Network.Wai.Application.Classic-import Parser-import Text.Parsec-import Text.Parsec.ByteString.Lazy-import Types--parseRoute :: FilePath -> IO RouteDB-parseRoute = parseFile routeDB--routeDB :: Parser RouteDB-routeDB = commentLines *> many1 block <* eof--block :: Parser Block-block = Block <$> cdomains <*> many croute- where- cdomains = domains <* commentLines- croute = route <* commentLines--domains :: Parser [Domain]-domains = open *> doms <* close <* trailing- where- open = () <$ char '[' *> spcs- close = () <$ char ']' *> spcs- doms = (domain `sepBy1` sep) <* spcs- domain = BS.pack <$> many1 (noneOf "[], \t\n")- sep = () <$ spcs1--data Op = OpFile | OpCGI | OpRevProxy | OpRedirect--route :: Parser Route-route = do- s <- src- o <- op- case o of- OpFile -> RouteFile s <$> dst <* trailing- OpRedirect -> RouteRedirect s <$> dst' <* trailing- OpCGI -> RouteCGI s <$> dst <* trailing- OpRevProxy -> do- (dom,prt,d) <- domPortDst- return $ RouteRevProxy s d dom prt- where- src = path- dst = path- dst' = path'- op0 = OpFile <$ string "->"- <|> OpRedirect <$ string "<<"- <|> OpCGI <$ string "=>"- <|> OpRevProxy <$ string ">>"- op = op0 <* spcs--path :: Parser Path-path = do- c <- char '/'- fromByteString . BS.pack . (c:) <$> many (noneOf "[], \t\n") <* spcs--path' :: Parser Path-path' = fromByteString . BS.pack <$> many (noneOf "[], \t\n") <* spcs---- [host1][:port2]/path2--domPortDst :: Parser (Domain, Port, Dst)-domPortDst = (defaultDomain,,) <$> port <*> path- <|> try((,,) <$> domain <*> port <*> path)- <|> (,defaultPort,) <$> domain <*> path- where- domain = BS.pack <$> many1 (noneOf ":/[], \t\n")- port = do- void $ char ':'- read <$> many1 (oneOf ['0'..'9'])
− Signal.hs
@@ -1,35 +0,0 @@-module Signal where--import Control.Exception (catch)-import Control.Monad-import Prelude hiding (catch)-import System.Posix-import Utils--------------------------------------------------------------------sigStop :: Signal-sigStop = sigTERM--sigReload :: Signal-sigReload = sigHUP--sigRetire :: Signal-sigRetire = sigQUIT--sigInfo :: Signal-sigInfo = sigUSR2--sigLogCtl :: Signal-sigLogCtl = sigUSR1--------------------------------------------------------------------sendSignal :: Signal -> ProcessID -> IO ()-sendSignal sig cid = signalProcess sig cid `catch` ignore--setHandler :: Signal -> Handler -> IO ()-setHandler sig func = void $ installHandler sig func Nothing--ignoreSigChild :: IO ()-ignoreSigChild = setHandler sigCHLD Ignore
− State.hs
@@ -1,81 +0,0 @@-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)- }--initialState :: State-initialState = State 0 Serving Nothing--------------------------------------------------------------------newtype Stater = Stater (IORef State)--initStater :: IO Stater-initStater = Stater <$> newIORef initialState--------------------------------------------------------------------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 :: Stater -> IO ()-decrement (Stater sref) =- strictAtomicModifyIORef sref $ \st -> st {- connectionCounter = connectionCounter st - 1- }--------------------------------------------------------------------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- }
− Types.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Types where--import Data.ByteString-import Data.ByteString.Char8 ()-import Data.Version-import Network.Wai.Application.Classic-import Paths_mighttpd2--type Src = Path-type Dst = Path-type Domain = ByteString-type PathInfo = ByteString-type Port = Int-data Block = Block [Domain] [Route] deriving (Eq,Show)-data Route = RouteFile Src Dst- | RouteRedirect Src Dst- | RouteCGI Src Dst- | RouteRevProxy Src Dst Domain Port- deriving (Eq,Show)-type RouteDB = [Block]--programName :: String-programName = "Mighttpd"--programVersion :: String-programVersion = showVersion version--defaultDomain :: Domain-defaultDomain = "localhost"--defaultPort :: Int-defaultPort = 80
− Utils.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Utils where--import Control.Exception-import Data.IORef-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BS-import System.IO--------------------------------------------------------------------ignore :: SomeException -> IO ()-ignore _ = return ()--printStdout :: SomeException -> IO ()-printStdout x = print x >> hFlush stdout--------------------------------------------------------------------strictAtomicModifyIORef :: IORef a -> (a -> a) -> IO ()-strictAtomicModifyIORef ref f = do- !_ <- atomicModifyIORef ref (\x -> let !r = f x in (r, ()))- return ()--------------------------------------------------------------------bshow :: Show a => a -> ByteString-bshow = BS.pack . show--infixr 5 +++--(+++) :: ByteString -> ByteString -> ByteString-(+++) = BS.append- -------------------------------------------------------------------infixr 0 >>>=--(>>>=) :: IO (Maybe a) -> (a -> IO ()) -> IO ()-x >>>= f = x >>= maybe (return ()) f
+ conf/example.conf view
@@ -0,0 +1,24 @@+# Example configuration for Mighttpd 2+Port: 80+Debug_Mode: Yes # Yes or No+# If available, "nobody" is much more secure for User:.+User: root+# If available, "nobody" is much more secure for Group:.+Group: root+Pid_File: /var/run/mighty.pid+Logging: Yes # Yes or No+Log_File: /var/log/mighty # The directory must be writable by User:+Log_File_Size: 16777216 # bytes+Log_Backup_Number: 10+Index_File: index.html+Index_Cgi: index.cgi+Status_File_Dir: /usr/local/share/mighty/status+Connection_Timeout: 30 # seconds+Fd_Cache_Duration: 10 # seconds+# Server_Name: Mighttpd/2.x.y+Worker_Processes: 1+Tls_Port: 443+Tls_Cert_File: certificate.pem # should change this with an absolute path+# Currently, Tls_Key_file must not be encrypted.+Tls_Key_file: key.pem # should change this with an absolute path+Service: 0 # 0 is HTTP only, 1 is HTTPS only, 2 is both
+ conf/example.route view
@@ -0,0 +1,23 @@+# Example routing for Mighttpd 2++# Domain lists+[localhost www.example.com]++# Entries are looked up in the specified order+# All paths must end with "/"++# A path to CGI scripts should be specified with "=>"+/~alice/cgi-bin/ => /home/alice/public_html/cgi-bin/++# A path to static files should be specified with "->"+/~alice/ -> /home/alice/public_html/+/cgi-bin/ => /export/cgi-bin/++# Reverse proxy rules should be specified with ">>"+# /path >> host:port/path2+# Either "host" or ":port" can be committed, but not both.+/app/cal/ >> example.net/calendar/+# Yesod app in the same server+/app/wiki/ >> 127.0.0.1:3000/++/ -> /export/www/
− example.conf
@@ -1,19 +0,0 @@-# Example configuration for Mighttpd 2-Port: 80-Debug_Mode: Yes # Yes or No-# If available, "nobody" is much more secure for User:.-User: root-# If available, "nobody" is much more secure for Group:.-Group: root-Pid_File: /var/run/mighty.pid-Logging: Yes # Yes or No-Log_File: /var/log/mighty # The directory must be writable by User:-Log_File_Size: 16777216 # bytes-Log_Backup_Number: 10-Index_File: index.html-Index_Cgi: index.cgi-Status_File_Dir: /usr/local/share/mighty/status-Connection_Timeout: 30 # seconds-Fd_Cache_Duration: 10 # seconds-# Server_Name: Mighttpd/2.x.y-Worker_Processes: 1
− example.route
@@ -1,23 +0,0 @@-# Example routing for Mighttpd 2--# Domain lists-[localhost www.example.com]--# Entries are looked up in the specified order-# All paths must end with "/"--# A path to CGI scripts should be specified with "=>"-/~alice/cgi-bin/ => /home/alice/public_html/cgi-bin/--# A path to static files should be specified with "->"-/~alice/ -> /home/alice/public_html/-/cgi-bin/ => /export/cgi-bin/--# Reverse proxy rules should be specified with ">>"-# /path >> host:port/path2-# Either "host" or ":port" can be committed, but not both.-/app/cal/ >> example.net/calendar/-# Yesod app in the same server-/app/wiki/ >> 127.0.0.1:3000/--/ -> /export/www/
mighttpd2.cabal view
@@ -1,5 +1,5 @@ Name: mighttpd2-Version: 2.8.4+Version: 2.8.5 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -13,11 +13,26 @@ Category: Network, Web Cabal-Version: >= 1.8 Build-Type: Simple+Data-Dir: conf Data-Files: example.conf example.route +Flag rev-proxy+ Description: Support reverse proxy wish http-conduit.+ This requires unnecessary crypt libraries.+ Default: True++Flag tls+ Description: Support http over tls (https).+ Default: False+ Executable mighty+ HS-Source-Dirs: src Main-Is: Mighty.hs GHC-Options: -Wall -threaded -rtsopts+ if flag(rev-proxy)+ Cpp-Options: -DREV_PROXY+ if flag(tls)+ Cpp-Options: -DTLS Build-Depends: base >= 4.0 && < 5 -- should be removed someday , blaze-html >= 0.5@@ -27,7 +42,6 @@ , deepseq , directory , filepath- , http-conduit >= 1.8.2.1 , http-date , http-types , io-choice@@ -46,23 +60,34 @@ , wai-logger , wai-logger-prefork , warp >= 1.3+ if flag(rev-proxy)+ Build-Depends: http-conduit >= 1.8.2.1+ if flag(tls)+ Build-Depends: tls+ , warp-tls >= 1.4.1 Other-Modules: Config Config.Internal+ Daemon FileCGIApp FileCache Log Mighty+ Multi+ Net Parser Process Report+ Resource Route Signal+ Single State Types Utils Paths_mighttpd2 Executable mkindex+ HS-Source-Dirs: utils, src Main-Is: mkindex.hs GHC-Options: -Wall Build-Depends: base >= 4 && < 5@@ -72,6 +97,7 @@ , time Executable mightyctl+ HS-Source-Dirs: utils, src Main-Is: mightyctl.hs GHC-Options: -Wall Build-Depends: base >= 4 && < 5@@ -82,7 +108,7 @@ Test-Suite spec Main-Is: Spec.hs- Hs-Source-Dirs: test, .+ Hs-Source-Dirs: test, src Type: exitcode-stdio-1.0 Other-Modules: ConfigSpec RouteSpec@@ -91,7 +117,6 @@ , deepseq , directory , filepath- , http-conduit , http-date , http-types , network@@ -108,6 +133,11 @@ , wai-logger-prefork , warp , hspec >= 1.3+ if flag(rev-proxy)+ Build-Depends: http-conduit >= 1.8.2.1+ if flag(tls)+ Build-Depends: tls+ , warp-tls >= 1.4.1 Source-Repository head Type: git
− mightyctl.hs
@@ -1,66 +0,0 @@-module Main where--import Data.List-import Process (getMightyPid)-import Signal-import System.Environment-import System.Exit-import System.Posix.Signals-import System.Posix.Types--commandDB :: [(String, Signal)]-commandDB = [- ("stop", sigStop)- , ("reload", sigReload)- , ("retire", sigRetire)- , ("info", sigInfo)- ]--usage :: IO a-usage = do- putStrLn "Usage:"- putStrLn $ " mightyctl " ++ cmds ++ " [pid]"- exitFailure- where- cmds = intercalate "|" $ map fst commandDB--main :: IO ()-main = do- (sig,mpid) <- getArgs >>= checkArgs- pid <- maybe getProcessIdWithPS return mpid- signalProcess sig pid--checkArgs :: [String] -> IO (Signal, Maybe ProcessID)-checkArgs [cmd] = do- sig <- getSignal cmd- return (sig, Nothing)-checkArgs [cmd,num] = do- sig <- getSignal cmd- pid <- getProcessId num- return (sig, Just pid)-checkArgs _ = usage--getSignal :: String -> IO Signal-getSignal cmd = check $ lookup cmd commandDB- where- check (Just sig) = return sig- check Nothing = do- putStrLn $ "No such command: " ++ cmd- usage--getProcessId :: String -> IO ProcessID-getProcessId num = check $ reads num- where- check [(pid,"")] = return . fromIntegral $ (pid :: Int)- check _ = do- putStrLn $ "No such process id: " ++ num- usage--getProcessIdWithPS :: IO ProcessID-getProcessIdWithPS = getMightyPid >>= check- where- check [] = putStrLn "No Mighty found" >> usage- check [pid] = return pid- check pids = do- putStrLn $ "Multiple Mighty found: " ++ intercalate ", " (map show pids)- usage
− mkindex.hs
@@ -1,95 +0,0 @@-{-- mkindex :: Making index.html for the current directory.--}-import Control.Applicative-import Data.Bits-import Data.Time-import Data.Time.Clock.POSIX-import System.Directory-import System.Locale-import System.Posix.Files-import Text.Printf--indexFile :: String-indexFile = "index.html"--main :: IO ()-main = do- contents <- mkContents- writeFile indexFile $ header ++ contents ++ tailer- setFileMode indexFile mode- where- mode = ownerReadMode .|. ownerWriteMode .|. groupReadMode .|. otherReadMode--mkContents :: IO String-mkContents = do- fileNames <- filter dotAndIndex <$> getDirectoryContents "."- stats <- mapM getFileStatus fileNames- let fmsls = zipWith pp fileNames stats- maxLen = maximum $ map (\(_,_,_,x) -> x) fmsls- contents = concatMap (content maxLen) fmsls- return contents- where- dotAndIndex x = head x /= '.' && x /= indexFile--pp :: String -> FileStatus -> (String,String,String,Int)-pp f st = (file,mtime,size,flen)- where- file = ppFile f st- flen = length file- mtime = ppMtime st- size = ppSize st--ppFile :: String -> FileStatus -> String-ppFile f st- | isDirectory st = f ++ "/"- | otherwise = f--ppMtime :: FileStatus -> String-ppMtime st = dateFormat . epochTimeToUTCTime $ st- where- epochTimeToUTCTime = posixSecondsToUTCTime . realToFrac . modificationTime- dateFormat = formatTime defaultTimeLocale "%d-%b-%Y %H:%M"--ppSize :: FileStatus -> String-ppSize st- | isDirectory st = " - "- | otherwise = sizeFormat . fromIntegral . fileSize $ st- where- sizeFormat siz = unit siz " KMGT"- unit _ [] = error "unit"- unit s [u] = format s u- unit s (u:us)- | s >= 1024 = unit (s `div` 1024) us- | otherwise = format s u- format :: Integer -> Char -> String- format = printf "%3d%c"--header :: String-header = "\-\<html>\n\-\<head>\n\-\<style type=\"text/css\">\n\-\<!--\n\-\body { padding-left: 10%; }\n\-\h1 { font-size: x-large; }\n\-\pre { font-size: large; }\n\-\hr { text-align: left; margin-left: 0px; width: 80% }\n\-\-->\n\-\</style>\n\-\</head>\n\-\<title>Directory contents</title>\n\-\<body>\n\-\<h1>Directory contents</h1>\n\-\<hr>\n\-\<pre>\n"--content :: Int -> (String,String,String,Int) -> String-content lim (f,m,s,len) = "<a href=\"" ++ f ++ "\">" ++ f ++ "</a> " ++ replicate (lim - len) ' ' ++ m ++ " " ++ s ++ "\n"--tailer :: String-tailer = "\-\</pre>\n\-\<hr>\n\-\</body>\n\-\</html>\n"
+ src/Config.hs view
@@ -0,0 +1,3 @@+module Config (Option(..), parseOption, defaultOption) where++import Config.Internal
+ src/Config/Internal.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, OverloadedStrings #-}++module Config.Internal where++import Control.Applicative hiding (many,optional,(<|>))+import Parser+import Text.Parsec+import Text.Parsec.ByteString.Lazy+import Types++----------------------------------------------------------------++defaultOption :: Option+defaultOption = Option {+ opt_port = 8080+ , opt_debug_mode = True+ , opt_user = "root"+ , opt_group = "root"+ , opt_pid_file = "/var/run/mighty.pid"+ , opt_logging = True+ , opt_log_file = "/var/log/mighty"+ , opt_log_file_size = 16777216+ , opt_log_backup_number = 10+ , opt_index_file = "index.html"+ , opt_index_cgi = "index.cgi"+ , opt_status_file_dir = "/usr/local/share/mighty/status"+ , opt_connection_timeout = 30+ , opt_fd_cache_duration = 10+ , opt_server_name = programName ++ "/" ++ programVersion+ , opt_worker_processes = 1+ , opt_routing_file = Nothing+ , opt_tls_port = 443+ , opt_tls_cert_file = "certificate.pem"+ , opt_tls_key_file = "key.pem"+ , opt_service = 0+ , opt_report_file = "/tmp/mighty_report"+}++data Option = Option {+ opt_port :: !Int+ , opt_debug_mode :: !Bool+ , opt_user :: !String+ , opt_group :: !String+ , opt_pid_file :: !FilePath+ , opt_logging :: !Bool+ , opt_log_file :: !FilePath+ , opt_log_file_size :: !Int+ , opt_log_backup_number :: !Int+ , opt_index_file :: !FilePath+ , opt_index_cgi :: !FilePath+ , opt_status_file_dir :: !FilePath+ , opt_connection_timeout :: !Int+ , opt_fd_cache_duration :: !Int+ , opt_server_name :: !String+ , opt_worker_processes :: !Int+ , opt_routing_file :: !(Maybe FilePath)+ , opt_tls_port :: !Int+ , opt_tls_cert_file :: !FilePath+ , opt_tls_key_file :: !FilePath+ , opt_service :: !Int+ , opt_report_file :: !FilePath+} deriving (Eq,Show)++----------------------------------------------------------------++parseOption :: String -> IO Option+parseOption file = makeOpt defaultOption <$> parseConfig file++----------------------------------------------------------------++makeOpt :: Option -> [Conf] -> Option+makeOpt def conf = Option {+ opt_port = get "Port" opt_port+ , opt_debug_mode = get "Debug_Mode" opt_debug_mode+ , opt_user = get "User" opt_user+ , opt_group = get "Group" opt_group+ , opt_pid_file = get "Pid_File" opt_pid_file+ , opt_logging = get "Logging" opt_logging+ , opt_log_file = get "Log_File" opt_log_file+ , opt_log_file_size = get "Log_File_Size" opt_log_file_size+ , opt_log_backup_number = get "Log_Backup_Number" opt_log_backup_number+ , opt_index_file = get "Index_File" opt_index_file+ , opt_index_cgi = get "Index_Cgi" opt_index_cgi+ , opt_status_file_dir = get "Status_File_Dir" opt_status_file_dir+ , opt_connection_timeout = get "Connection_Timeout" opt_connection_timeout+ , opt_fd_cache_duration = get "Fd_Cache_Duration" opt_fd_cache_duration+ , opt_server_name = get "Server_Name" opt_server_name+ , opt_worker_processes = get "Worker_Processes" opt_worker_processes+ , opt_routing_file = Nothing+ , opt_tls_port = get "Tls_Port" opt_tls_port+ , opt_tls_cert_file = get "Tls_Cert_File" opt_tls_cert_file+ , opt_tls_key_file = get "Tls_Key_File" opt_tls_key_file+ , opt_service = get "Service" opt_service+ , opt_report_file = get "ReportFile" opt_report_file+ }+ where+ get k func = maybe (func def) fromConf $ lookup k conf++----------------------------------------------------------------++type Conf = (String, ConfValue)++data ConfValue = CV_Int Int | CV_Bool Bool | CV_String String deriving (Eq,Show)++class FromConf a where+ fromConf :: ConfValue -> a++instance FromConf Int where+ fromConf (CV_Int n) = n+ fromConf _ = error "fromConf int"++instance FromConf Bool where+ fromConf (CV_Bool b) = b+ fromConf _ = error "fromConf bool"++instance FromConf String where+ fromConf (CV_String s) = s+ fromConf _ = error "fromConf string"++----------------------------------------------------------------++parseConfig :: FilePath -> IO [Conf]+parseConfig = parseFile config++----------------------------------------------------------------++config :: Parser [Conf]+config = commentLines *> many cfield <* eof+ where+ cfield = field <* commentLines++field :: Parser Conf+field = (,) <$> key <*> (sep *> value) <* trailing++key :: Parser String+key = many1 (oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_") <* spcs++sep :: Parser ()+sep = () <$ char ':' *> spcs++value :: Parser ConfValue+value = choice [try cv_int, try cv_bool, cv_string] <* spcs++cv_int :: Parser ConfValue+cv_int = CV_Int . read <$> many1 digit++cv_bool :: Parser ConfValue+cv_bool = CV_Bool True <$ string "Yes" <|>+ CV_Bool False <$ string "No"++cv_string :: Parser ConfValue+cv_string = CV_String <$> many1 (noneOf " \t\n")
+ src/Daemon.hs view
@@ -0,0 +1,33 @@+module Daemon (background) where++import Config+import Control.Monad+import System.Exit+import System.IO+import System.Posix++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 \"" ++ opt_report_file opt ++ "\".)"+ hFlush stdout+ daemonize svr+ where+ port = opt_port opt++daemonize :: IO () -> IO ()+daemonize program = ensureDetachTerminalCanWork $ do+ detachTerminal+ ensureNeverAttachTerminal $ do+ changeWorkingDirectory "/"+ void $ setFileCreationMask 0+ mapM_ closeFd [stdInput, stdOutput, stdError]+ program+ where+ ensureDetachTerminalCanWork p = do+ void $ forkProcess p+ exitSuccess+ ensureNeverAttachTerminal p = do+ void $ forkProcess p+ exitSuccess+ detachTerminal = void createSession
+ src/FileCGIApp.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings, CPP #-}++module FileCGIApp (fileCgiApp) where++import Control.Monad.IO.Class (liftIO)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Application.Classic+import Types++data Perhaps a = Found a | Redirect | Fail++fileCgiApp :: ClassicAppSpec -> FileAppSpec -> CgiAppSpec+#ifdef REV_PROXY+ -> RevProxyAppSpec+#endif+ -> RouteDB -> Application+fileCgiApp cspec filespec cgispec+#ifdef REV_PROXY+ revproxyspec+#endif+ um req = case mmp of+ Fail -> do+ let st = preconditionFailed412+ liftIO $ logger cspec req st Nothing+ fastResponse st defaultHeader "Precondition Failed\r\n"+ Redirect -> do+ let st = movedPermanently301+ hdr = defaultHeader ++ redirectHeader req+ liftIO $ logger cspec req st Nothing+ fastResponse st hdr "Moved Permanently\r\n"+ Found (RouteFile src dst) ->+ fileApp cspec filespec (FileRoute src dst) req+ Found (RouteRedirect src dst) ->+ redirectApp cspec (RedirectRoute src dst) req+ Found (RouteCGI src dst) ->+ cgiApp cspec cgispec (CgiRoute src dst) req+#ifdef REV_PROXY+ Found (RouteRevProxy src dst dom prt) ->+ revProxyApp cspec revproxyspec (RevProxyRoute src dst dom prt) req+#else+ _ -> error "never reach"+#endif+ where+ mmp = case getBlock (serverName req) um of+ Nothing -> Fail+ Just blk -> getRoute (rawPathInfo req) blk+ fastResponse st hdr body = return $ responseLBS st hdr body+ defaultHeader = [("Content-Type", "text/plain")+ ,("Server", softwareName cspec)]++getBlock :: ByteString -> RouteDB -> Maybe [Route]+getBlock _ [] = Nothing+getBlock key (Block doms maps : ms)+ | "*" `elem` doms = Just maps+ | key `elem` doms = Just maps+ | otherwise = getBlock key ms++getRoute :: ByteString -> [Route] -> Perhaps Route+getRoute _ [] = Fail+getRoute key (m:ms)+ | src `isPrefixOf` key = Found m+ | src `isMountPointOf` key = Redirect+ | otherwise = getRoute key ms+ where+ src = routeSource m++routeSource :: Route -> Src+routeSource (RouteFile src _) = src+routeSource (RouteRedirect src _) = src+routeSource (RouteCGI src _) = src+routeSource (RouteRevProxy src _ _ _) = src++isPrefixOf :: Path -> ByteString -> Bool+isPrefixOf src key = src' `BS.isPrefixOf` key+ where+ src' = pathByteString src++isMountPointOf :: Path -> ByteString -> Bool+isMountPointOf src key = hasTrailingPathSeparator src+ && BS.length src' - BS.length key == 1+ && key `BS.isPrefixOf` src'+ where+ src' = pathByteString src
+ src/FileCache.hs view
@@ -0,0 +1,70 @@+module FileCache (fileCacheInit) where++import Control.Concurrent+import Control.Exception+import Control.Exception.IOChoice+import Control.Monad+import Data.ByteString (ByteString)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as M+import Data.IORef+import Network.HTTP.Date+import Network.Wai.Application.Classic+import System.Posix.Files+import Utils++data Entry = Negative | Positive FileInfo+type Cache = HashMap ByteString Entry+type GetInfo = Path -> IO FileInfo++fileInfo :: IORef Cache -> GetInfo+fileInfo ref path = do+ cache <- readIORef ref+ case M.lookup bpath cache of+ Just Negative -> throwIO (userError "fileInfo")+ Just (Positive x) -> return x+ Nothing -> register ||> negative ref path+ where+ bpath = pathByteString path+ sfile = pathString path+ register = do+ fs <- getFileStatus sfile+ if not (isDirectory fs) then+ positive ref fs path+ else+ goNext++positive :: IORef Cache -> FileStatus -> GetInfo+positive ref fs path = do+ strictAtomicModifyIORef ref $ M.insert bpath entry+ return info+ where+ info = FileInfo {+ fileInfoName = path+ , fileInfoSize = size fs+ , fileInfoTime = time+ , fileInfoDate = formatHTTPDate time+ }+ size = fromIntegral . fileSize+ time = epochTimeToHTTPDate (modificationTime fs)+ entry = Positive info+ bpath = pathByteString path++negative :: IORef Cache -> GetInfo+negative ref path = do+ strictAtomicModifyIORef ref $ M.insert bpath Negative+ throwIO (userError "fileInfo")+ where+ bpath = pathByteString path++----------------------------------------------------------------++fileCacheInit :: IO GetInfo+fileCacheInit = do+ ref <- newIORef M.empty+ void . forkIO $ remover ref+ return $ fileInfo ref++-- atomicModifyIORef is not necessary here.+remover :: IORef Cache -> IO ()+remover ref = forever $ threadDelay 10000000 >> writeIORef ref M.empty
+ src/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
+ src/Mighty.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE OverloadedStrings, CPP #-}++module Main where++import Control.Concurrent+import Control.Monad+import Network.Wai.Application.Classic hiding ((</>), (+++))+import Network.Wai.Logger+import Network.Wai.Logger.Prefork+import System.Directory+import System.Environment+import System.Exit+import System.FilePath+import System.IO+import System.Posix++import Config+import Daemon (background)+import Log+import Multi+import Net (listenSocket)+import Report+import Resource (amIrootUser, unlimit)+import Route+import Signal+import Single+import State+import Types++----------------------------------------------------------------++main :: IO ()+main = do+ (opt,route) <- getOptRoute+ checkTLS opt+ let reportFile = opt_report_file opt+ rpt <- initReporter reportFile >>= checkReporter reportFile+ if opt_debug_mode opt then+ server opt route rpt+ else+ background opt $ server opt route rpt+ where+ getOptRoute = getArgs >>= eachCase+ eachCase args+ | n == 0 = do+ root <- amIrootUser+ let opt | root = defaultOption { opt_port = 80 }+ | otherwise = defaultOption+ dir <- getCurrentDirectory+ let dst = fromString . addTrailingPathSeparator $ dir+ route = [Block ["*"] [RouteFile "/" dst]]+ return (opt, route)+ | n == 2 = do+ let config_file = args !! 0+ routing_file <- getAbsoluteFile (args !! 1)+ opt <- parseOption config_file+ route <- parseRoute routing_file+ let opt' = opt {opt_routing_file = Just routing_file}+ return (opt',route)+ | otherwise = do+ hPutStrLn stderr "Usage: mighty"+ hPutStrLn stderr " mighty config_file routing_file"+ exitFailure+ where+ n = length args+ getAbsoluteFile file+ | isAbsolute file = return file+ | otherwise = do+ dir <- getCurrentDirectory+ return $ dir </> normalise file+ checkReporter _ (Right rpt) = return rpt+ checkReporter reportFile (Left e) = do+ hPutStrLn stderr $ reportFile ++ " is not writable"+ hPrint stderr e+ exitFailure+#ifdef TLS+ checkTLS _ = return ()+#else+ checkTLS opt = when (opt_service opt > 1) $ do+ hPutStrLn stderr "This mighty does not support TLS"+ exitFailure+#endif++----------------------------------------------------------------++server :: Option -> RouteDB -> Reporter -> IO ()+server opt route rpt = reportDo rpt $ do+ unlimit+ service <- openService opt+ unless debug writePidFile+ logCheck logtype+ myid <- getProcessID+ stt <- initStater+ if workers == 1 then do+ lgr <- initLogger FromSocket logtype+ -- killed by signal+ void . forkIO $ single opt route service rpt stt lgr+ void . forkIO $ logController logtype [myid]+ mainLoop rpt stt lgr+ else do+ cids <- multi opt route service logtype stt rpt+ void . forkIO $ logController logtype cids+ masterMainLoop rpt myid+ where+ debug = opt_debug_mode opt+ pidfile = opt_pid_file opt+ workers = opt_worker_processes opt+ writePidFile = do+ pid <- getProcessID+ writeFile pidfile $ show pid ++ "\n"+ setFileMode pidfile 0o644+ logspec = FileLogSpec {+ log_file = opt_log_file opt+ , log_file_size = fromIntegral $ opt_log_file_size opt+ , log_backup_number = opt_log_backup_number opt+ }+ logtype+ | not (opt_logging opt) = LogNone+ | debug = LogStdout+ | otherwise = LogFile logspec sigLogCtl++openService :: Option -> IO Service+openService opt+ | service == 1 = do+ s <- listenSocket httpsPort+ debugMessage $ "HTTP/TLS service on port " ++ httpsPort ++ "."+ return $ HttpsOnly s+ | service == 2 = do+ s1 <- listenSocket httpPort+ s2 <- listenSocket httpsPort+ debugMessage $ "HTTP service on port " ++ httpPort ++ " and "+ ++ "HTTP/TLS service on port " ++ httpsPort ++ "."+ return $ HttpAndHttps s1 s2+ | otherwise = do+ s <- listenSocket httpPort+ debugMessage $ "HTTP service on port " ++ httpPort ++ "."+ return $ HttpOnly s+ where+ httpPort = show $ opt_port opt+ httpsPort = show $ opt_tls_port opt+ service = opt_service opt+ debug = opt_debug_mode opt+ debugMessage msg = when debug $ do+ putStrLn msg+ hFlush stdout
+ src/Multi.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}++module Multi (multi, masterMainLoop) where++import Control.Concurrent+import Control.Exception+import qualified Control.Exception as E (catch)+import Control.Monad+import Network.Wai.Logger+import Network.Wai.Logger.Prefork+import Process (findChildren, PsResult, dummyResult)+import System.Exit+import System.Posix++import Config+import Log+import Report+import Signal+import Single+import State+import Types++----------------------------------------------------------------++multi :: Option -> RouteDB -> Service -> LogType -> Stater -> Reporter -> IO [ProcessID]+multi opt route service logtype stt rpt = do+ report rpt "Master Mighty started"+ ignoreSigChild+ cids <- replicateM workers $ forkProcess $ do+ lgr <- initLogger FromSocket logtype+ -- killed by signal+ void . forkIO $ single opt route service rpt stt lgr+ mainLoop rpt stt lgr+ closeService service+ setHandler sigStop $ stopHandler cids+ setHandler sigINT $ stopHandler cids -- C-c from keyboard when debugging+ setHandler sigRetire $ retireHandler cids+ setHandler sigReload $ reloadHandler cids+ setHandler sigInfo $ infoHandler cids+ return cids+ where+ workers = opt_worker_processes opt+ stopHandler cids = Catch $ do+ report rpt "Master Mighty finished"+ finReporter rpt+ -- No logging+ mapM_ (sendSignal sigStop) cids+ exitImmediately ExitSuccess+ retireHandler cids = Catch $ do+ report rpt "Master Mighty retiring"+ goRetiring stt+ mapM_ (sendSignal sigRetire) cids+ reloadHandler cids = Catch $ ifRouteFileIsValid rpt opt $ \_ -> do+ report rpt "Master Mighty reloaded"+ mapM_ (sendSignal sigReload) cids+ infoHandler cids = Catch $ mapM_ (sendSignal sigInfo) cids++----------------------------------------------------------------++masterMainLoop :: Reporter -> ProcessID -> IO ()+masterMainLoop rpt myid = do+ threadDelay 10000000+ cs <- findChildren myid `E.catch` handler+ if null cs then do -- FIXME serverStatus st == Retiring+ report rpt "Master Mighty retired"+ finReporter rpt+ -- No logging+ exitSuccess+ else+ masterMainLoop rpt myid+ where+ handler :: SomeException -> IO [PsResult]+ handler _ = return [dummyResult]
+ src/Net.hs view
@@ -0,0 +1,28 @@+module Net (listenSocket) where++import Control.Exception+import Network+import Network.BSD+import Network.Socket++listenSocket :: String -> IO Socket+listenSocket serv = do+ proto <- getProtocolNumber "tcp"+ let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_PASSIVE]+ , addrSocketType = Stream+ , addrProtocol = proto }+ addrs <- getAddrInfo (Just hints) Nothing (Just serv)+ let addrs' = filter (\x -> addrFamily x == AF_INET6) addrs+ addr = head $ if null addrs' then addrs else addrs'+ listenSocket' addr++listenSocket' :: AddrInfo -> IO Socket+listenSocket' addr = bracketOnError setup cleanup $ \sock -> do+ setSocketOption sock ReuseAddr 1+ setSocketOption sock NoDelay 1+ bindSocket sock (addrAddress addr)+ listen sock 2048+ return sock+ where+ setup = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ cleanup = sClose
+ src/Parser.hs view
@@ -0,0 +1,37 @@+module Parser where++import Control.Applicative hiding (many,(<|>))+import Control.Exception+import qualified Data.ByteString.Lazy.Char8 as BL+import System.IO+import Text.Parsec+import Text.Parsec.ByteString.Lazy++spcs :: Parser ()+spcs = () <$ many spc++spcs1 :: Parser ()+spcs1 = () <$ many1 spc++spc :: Parser Char+spc = satisfy (`elem` " \t")++commentLines :: Parser ()+commentLines = () <$ many commentLine+ where+ commentLine = trailing++trailing :: Parser ()+trailing = () <$ (comment *> newline <|> newline)++comment :: Parser ()+comment = () <$ char '#' <* many (noneOf "\n")++parseFile :: Parser a -> FilePath -> IO a+parseFile p file = do+ hdl <- openFile file ReadMode+ hSetEncoding hdl latin1+ bs <- BL.hGetContents hdl+ case parse p "parseFile" bs of+ Right x -> return x+ Left e -> throwIO . userError . show $ e
+ src/Process.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}++module Process (+ getMightyPid+ , findChildren+ , dummyResult+ , PsResult(..)+ ) where++import Control.Applicative+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.Conduit+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+import Data.Conduit.Process+import Data.Function+import Data.List+import Data.Ord+import System.Posix.Types++----------------------------------------------------------------++data PsResult = PsResult {+ uid :: ByteString+ , pid :: ProcessID+ , ppid :: ProcessID+ , command :: ByteString+ } deriving (Eq, Show)++dummyResult :: PsResult+dummyResult = PsResult "" 0 0 ""++toPsResult :: [ByteString] -> PsResult+toPsResult (a:b:c:_:_:_:_:h:_) = PsResult {+ uid = a+ , pid = maybe 0 (fromIntegral . fst) $ BS.readInt b+ , ppid = maybe 0 (fromIntegral . fst) $ BS.readInt c+ , command = h+ }+toPsResult _ = PsResult "unknown" 0 0 "unknown"++----------------------------------------------------------------++runPS :: IO [PsResult]+runPS = runResourceT $+ sourceCmd "ps -ef"+ $= CB.lines+ $= CL.map BS.words+ $= CL.map toPsResult+ $= CL.filter mighty+ $$ CL.consume+ where+ commandName = last . split '/' . command+ mighty ps = "mighty" `BS.isInfixOf` name+ && not ("mightyctl" `BS.isInfixOf` name)+ where+ name = commandName ps++----------------------------------------------------------------++findParent :: [PsResult] -> [PsResult]+findParent ps = deleteAloneChild $ masters ++ candidates+ where+ iAmMaster p = ppid p == 1+ masters = filter iAmMaster ps+ rest = filter (not.iAmMaster) ps+ candidates = map head+ $ filter (\xs -> length xs == 1) -- master is alone+ $ groupBy ((==) `on` ppid)+ $ sortBy (comparing ppid) rest+++deleteAloneChild :: [PsResult] -> [PsResult]+deleteAloneChild [] = []+deleteAloneChild (p:ps) = p : deleteAloneChild (filter noParent ps)+ where+ parent = pid p+ noParent x = ppid x /= parent++----------------------------------------------------------------++getMightyPid :: IO [ProcessID]+getMightyPid = (map pid . findParent) <$> runPS++----------------------------------------------------------------++findChildren :: ProcessID -> IO [PsResult]+findChildren parent = filter (\p -> ppid p == parent) <$> runPS++----------------------------------------------------------------++split :: Char -> ByteString -> [ByteString]+split _ "" = []+split c s = case BS.break (c==) s of+ ("",r) -> split c (BS.tail r)+ (s',"") -> [s']+ (s',r) -> s' : split c (BS.tail r)
+ src/Report.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}++module Report (+ Reporter+ , initReporter+ , finReporter+ , report+ , reportDo+ , warpHandler+ ) where++import Control.Applicative+import Control.Exception+import qualified Control.Exception as E (catch)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.UnixTime+import GHC.IO.Exception (IOErrorType(..))+import Network.Wai.Handler.Warp (InvalidRequest)+import System.IO+import System.IO.Error (ioeGetErrorType)+import System.Posix (getProcessID)++import Utils++newtype Reporter = Reporter Handle++initReporter :: FilePath -> IO (Either SomeException Reporter)+initReporter reportFile = 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++----------------------------------------------------------------++reportDo :: Reporter -> IO () -> IO ()+reportDo rpt act = act `E.catch` warpHandler rpt++----------------------------------------------------------------++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+ | et `elem` ignEts = norecode+ | otherwise = recode x+ where+ et = ioeGetErrorType x+ ignEts = [ResourceVanished, InvalidArgument]+ sh :: SomeException -> IO ()+ sh x = recode x+ norecode = return ()+ recode :: Exception e => e -> IO ()+ recode = report rpt . bshow
+ src/Resource.hs view
@@ -0,0 +1,35 @@+module Resource (+ amIrootUser+ , setGroupUser+ , unlimit+ ) where++import Config+import Control.Applicative+import Control.Exception+import Control.Monad+import System.Posix+import Utils++----------------------------------------------------------------++amIrootUser :: IO Bool+amIrootUser = (== 0) <$> getRealUserID++setGroupUser :: Option -> IO ()+setGroupUser opt = do+ root <- amIrootUser+ when root $ do+ getGroupEntryForName (opt_group opt) >>= setGroupID . groupID+ getUserEntryForName (opt_user opt) >>= setUserID . userID++----------------------------------------------------------------++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
+ src/Route.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings, TupleSections #-}++module Route (parseRoute) where++import Control.Applicative hiding (many,(<|>))+import Control.Monad+import qualified Data.ByteString.Char8 as BS+import Network.Wai.Application.Classic+import Parser+import Text.Parsec+import Text.Parsec.ByteString.Lazy+import Types++parseRoute :: FilePath -> IO RouteDB+parseRoute = parseFile routeDB++routeDB :: Parser RouteDB+routeDB = commentLines *> many1 block <* eof++block :: Parser Block+block = Block <$> cdomains <*> many croute+ where+ cdomains = domains <* commentLines+ croute = route <* commentLines++domains :: Parser [Domain]+domains = open *> doms <* close <* trailing+ where+ open = () <$ char '[' *> spcs+ close = () <$ char ']' *> spcs+ doms = (domain `sepBy1` sep) <* spcs+ domain = BS.pack <$> many1 (noneOf "[], \t\n")+ sep = () <$ spcs1++data Op = OpFile | OpCGI | OpRevProxy | OpRedirect++route :: Parser Route+route = do+ s <- src+ o <- op+ case o of+ OpFile -> RouteFile s <$> dst <* trailing+ OpRedirect -> RouteRedirect s <$> dst' <* trailing+ OpCGI -> RouteCGI s <$> dst <* trailing+ OpRevProxy -> do+ (dom,prt,d) <- domPortDst+ return $ RouteRevProxy s d dom prt+ where+ src = path+ dst = path+ dst' = path'+ op0 = OpFile <$ string "->"+ <|> OpRedirect <$ string "<<"+ <|> OpCGI <$ string "=>"+ <|> OpRevProxy <$ string ">>"+ op = op0 <* spcs++path :: Parser Path+path = do+ c <- char '/'+ fromByteString . BS.pack . (c:) <$> many (noneOf "[], \t\n") <* spcs++path' :: Parser Path+path' = fromByteString . BS.pack <$> many (noneOf "[], \t\n") <* spcs++-- [host1][:port2]/path2++domPortDst :: Parser (Domain, Port, Dst)+domPortDst = (defaultDomain,,) <$> port <*> path+ <|> try((,,) <$> domain <*> port <*> path)+ <|> (,defaultPort,) <$> domain <*> path+ where+ domain = BS.pack <$> many1 (noneOf ":/[], \t\n")+ port = do+ void $ char ':'+ read <$> many1 (oneOf ['0'..'9'])
+ src/Signal.hs view
@@ -0,0 +1,34 @@+module Signal where++import qualified Control.Exception as E+import Control.Monad+import System.Posix+import Utils++----------------------------------------------------------------++sigStop :: Signal+sigStop = sigTERM++sigReload :: Signal+sigReload = sigHUP++sigRetire :: Signal+sigRetire = sigQUIT++sigInfo :: Signal+sigInfo = sigUSR2++sigLogCtl :: Signal+sigLogCtl = sigUSR1++----------------------------------------------------------------++sendSignal :: Signal -> ProcessID -> IO ()+sendSignal sig cid = signalProcess sig cid `E.catch` ignore++setHandler :: Signal -> Handler -> IO ()+setHandler sig func = void $ installHandler sig func Nothing++ignoreSigChild :: IO ()+ignoreSigChild = setHandler sigCHLD Ignore
+ src/Single.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE OverloadedStrings, CPP #-}++module Single (single, mainLoop, closeService, ifRouteFileIsValid) where++import Config+import Route+import Control.Applicative+import Control.Concurrent+import Control.Exception+import Control.Monad+import qualified Data.ByteString.Char8 as BS+import Data.Conduit.Network+import Network+import Network.HTTP.Date+import Network.Wai.Application.Classic hiding ((</>), (+++))+import Network.Wai.Handler.Warp+import System.Date.Cache+import System.Exit+import System.Posix+import System.IO.Error (ioeGetErrorString)+#ifdef REV_PROXY+import qualified Network.HTTP.Conduit as H+#endif+#ifdef TLS+import Network.Wai.Handler.WarpTLS+#endif++import FileCGIApp+import FileCache+import Log+import Report+import Resource (setGroupUser)+import Signal+import State+import Types+import Utils++----------------------------------------------------------------++#ifdef REV_PROXY+type ConnPool = H.Manager+#else+type ConnPool = ()+#endif++----------------------------------------------------------------++single :: Option -> RouteDB -> Service -> Reporter -> Stater -> Logger -> IO ()+single opt route service rpt stt lgr = reportDo rpt $ do+ setGroupUser opt -- don't change the user of the master process+ ignoreSigChild+ getInfo <- fileCacheInit+ setHandler sigStop stopHandler+ setHandler sigRetire retireHandler+ setHandler sigInfo infoHandler+#ifdef REV_PROXY+ mgr <- H.newManager H.def { H.managerConnCount = 1024 } -- FIXME+#else+ let mgr = ()+#endif+ setHandler sigReload (reloadHandler lgr getInfo mgr)+ report rpt "Worker Mighty started"+ reload opt route service rpt stt lgr getInfo mgr+ where+ stopHandler = Catch $ do+ report rpt "Worker Mighty finished"+ finReporter rpt+ finLogger lgr+ closeService service+ exitImmediately ExitSuccess+ retireHandler = Catch $ ifWarpThreadsAreActive stt $ do+ report rpt "Worker Mighty retiring"+ closeService service+ goRetiring stt+ reloadHandler lggr getInfo mgr = Catch $ ifWarpThreadsAreActive stt $+ ifRouteFileIsValid rpt opt $ \newroute -> do+ report rpt "Worker Mighty reloaded"+ void . forkIO $ reload opt newroute service rpt stt lggr getInfo mgr+ infoHandler = Catch $ do+ i <- bshow <$> getConnectionCounter stt+ status <- bshow <$> getServerStatus stt+ report rpt $ status +++ ": # of connections = " +++ i++ifRouteFileIsValid :: Reporter -> Option -> (RouteDB -> IO ()) -> IO ()+ifRouteFileIsValid rpt opt act = case opt_routing_file opt of+ Nothing -> return ()+ Just rfile -> try (parseRoute rfile) >>= either reportError act+ where+ reportError = report rpt . BS.pack . ioeGetErrorString++----------------------------------------------------------------++reload :: Option -> RouteDB -> Service+ -> Reporter -> Stater -> Logger+ -> (Path -> IO FileInfo) -> ConnPool+ -> IO ()+reload opt route service rpt stt lgr getInfo _mgr = reportDo rpt $ do+ setMyWarpThreadId stt+ zdater <- initZoneDater+#ifdef REV_PROXY+ let app req = fileCgiApp (cspec zdater) filespec cgispec revproxyspec route req+#else+ let app req = fileCgiApp (cspec zdater) filespec cgispec route req+#endif+ case service of+ HttpOnly s -> runSettingsSocket setting s app+#ifdef TLS+ HttpsOnly s -> runTLSSocket tlsSetting setting s app+ HttpAndHttps s1 s2 -> do+ tid <- forkIO $ runSettingsSocket setting s1 app+ addAnotherWarpThreadId stt tid+ runTLSSocket tlsSetting setting s2 app+#else+ _ -> error "never reach"+#endif+ where+ debug = opt_debug_mode opt+ setting = defaultSettings {+ settingsPort = opt_port opt+ , settingsOnException = if debug then printStdout else warpHandler rpt+ , settingsOnOpen = increment stt+ , settingsOnClose = decrement stt+ , settingsTimeout = opt_connection_timeout opt+ , settingsHost = HostAny+ , settingsFdCacheDuration = opt_fd_cache_duration opt+ , settingsResourceTPerRequest = False+ }+ serverName = BS.pack $ opt_server_name opt+ cspec zdater = ClassicAppSpec {+ softwareName = serverName+ , logger = apatcheLogger lgr+ , dater = zdater+ , statusFileDir = fromString $ opt_status_file_dir opt+ }+ filespec = FileAppSpec {+ indexFile = fromString $ opt_index_file opt+ , isHTML = \x -> ".html" `isSuffixOf` x || ".htm" `isSuffixOf` x+ , getFileInfo = getInfo+ }+ cgispec = CgiAppSpec {+ indexCgi = "index.cgi"+ }+ initZoneDater = fst <$> clockDateCacher DateCacheConf {+ getTime = epochTime+ , formatDate = return . formatHTTPDate . epochTimeToHTTPDate+ }+#ifdef REV_PROXY+ revproxyspec = RevProxyAppSpec {+ revProxyManager = _mgr+ }+#endif+#ifdef TLS+ tlsSetting = defaultTlsSettings {+ certFile = opt_tls_cert_file opt+ , keyFile = opt_tls_key_file opt+ }+#endif++----------------------------------------------------------------++mainLoop :: Reporter -> Stater -> Logger -> IO ()+mainLoop rpt stt lgr = do+ threadDelay 1000000+ retiring <- isRetiring stt+ counter <- getConnectionCounter stt+ if retiring && counter == 0 then do+ report rpt "Worker Mighty retired"+ finReporter rpt+ finLogger lgr+ exitSuccess+ else+ mainLoop rpt stt lgr++----------------------------------------------------------------++closeService :: Service -> IO ()+closeService (HttpOnly s) = sClose s+closeService (HttpsOnly s) = sClose s+closeService (HttpAndHttps s1 s2) = sClose s1 >> sClose s2
+ src/State.hs view
@@ -0,0 +1,109 @@+module State (+ Status(..)+ , Stater+ , initStater+ , getConnectionCounter+ , increment+ , decrement+ , isRetiring+ , goRetiring+ , getServerStatus+ , setMyWarpThreadId+ , addAnotherWarpThreadId+ , ifWarpThreadsAreActive+ ) where++import Control.Applicative+import Control.Concurrent+import Data.IORef+import Utils++----------------------------------------------------------------++data Status = Serving | Retiring deriving (Eq, Show)++data Two a = Zero | One a | Two a a++data State = State {+ connectionCounter :: !Int+ , serverStatus :: !Status+ , warpThreadId :: !(Two ThreadId)+ }++initialState :: State+initialState = State 0 Serving Zero++----------------------------------------------------------------++newtype Stater = Stater (IORef State)++initStater :: IO Stater+initStater = Stater <$> newIORef initialState++----------------------------------------------------------------++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 :: Stater -> IO ()+decrement (Stater sref) =+ strictAtomicModifyIORef sref $ \st -> st {+ connectionCounter = connectionCounter st - 1+ }++----------------------------------------------------------------++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 = Zero+ }++----------------------------------------------------------------++getWarpThreadId :: Stater -> IO (Two ThreadId)+getWarpThreadId (Stater sref) = warpThreadId <$> readIORef sref++setWarpThreadId :: Stater -> Two ThreadId -> IO ()+setWarpThreadId (Stater sref) ttids =+ strictAtomicModifyIORef sref $ \st -> st {+ warpThreadId = ttids+ }++setMyWarpThreadId :: Stater -> IO ()+setMyWarpThreadId stt = do+ myid <- myThreadId+ setWarpThreadId stt (One myid)++addAnotherWarpThreadId :: Stater -> ThreadId -> IO ()+addAnotherWarpThreadId stt aid = do+ ttids <- getWarpThreadId stt+ case ttids of+ One tid -> setWarpThreadId stt (Two tid aid)+ _ -> undefined -- FIXME++ifWarpThreadsAreActive :: Stater -> IO () -> IO ()+ifWarpThreadsAreActive stt act = do+ ttids <- getWarpThreadId stt+ case ttids of+ Zero -> return ()+ One tid -> do+ killThread tid+ act+ Two tid1 tid2 -> do+ killThread tid1+ killThread tid2+ act
+ src/Types.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}++module Types where++import Data.ByteString+import Data.ByteString.Char8 ()+import Data.Version+import Network (Socket)+import Network.Wai.Application.Classic++import Paths_mighttpd2++type Src = Path+type Dst = Path+type Domain = ByteString+type PathInfo = ByteString+type Port = Int+data Block = Block [Domain] [Route] deriving (Eq,Show)+data Route = RouteFile Src Dst+ | RouteRedirect Src Dst+ | RouteCGI Src Dst+ | RouteRevProxy Src Dst Domain Port+ deriving (Eq,Show)+type RouteDB = [Block]++programName :: String+programName = "Mighttpd"++programVersion :: String+programVersion = showVersion version++defaultDomain :: Domain+defaultDomain = "localhost"++defaultPort :: Int+defaultPort = 80++data Service = HttpOnly Socket | HttpsOnly Socket | HttpAndHttps Socket Socket
+ src/Utils.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE BangPatterns #-}++module Utils where++import Control.Exception+import Data.IORef+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import System.IO++----------------------------------------------------------------++ignore :: SomeException -> IO ()+ignore _ = return ()++printStdout :: SomeException -> IO ()+printStdout x = print x >> hFlush stdout++----------------------------------------------------------------++strictAtomicModifyIORef :: IORef a -> (a -> a) -> IO ()+strictAtomicModifyIORef ref f = do+ !_ <- atomicModifyIORef ref (\x -> let !r = f x in (r, ()))+ return ()++----------------------------------------------------------------++bshow :: Show a => a -> ByteString+bshow = BS.pack . show++infixr 5 +++++(+++) :: ByteString -> ByteString -> ByteString+(+++) = BS.append
test/ConfigSpec.hs view
@@ -7,8 +7,8 @@ spec = do describe "parseConfig" $ do it "parses example.conf correctly" $ do- res <- parseConfig "example.conf"+ res <- parseConfig "conf/example.conf" res `shouldBe` ans ans :: [(String, ConfValue)]-ans = [("Port",CV_Int 80),("Debug_Mode",CV_Bool True),("User",CV_String "root"),("Group",CV_String "root"),("Pid_File",CV_String "/var/run/mighty.pid"),("Logging",CV_Bool True),("Log_File",CV_String "/var/log/mighty"),("Log_File_Size",CV_Int 16777216),("Log_Backup_Number",CV_Int 10),("Index_File",CV_String "index.html"),("Index_Cgi",CV_String "index.cgi"),("Status_File_Dir",CV_String "/usr/local/share/mighty/status"),("Connection_Timeout",CV_Int 30),("Fd_Cache_Duration",CV_Int 10),("Worker_Processes",CV_Int 1)]+ans = [("Port",CV_Int 80),("Debug_Mode",CV_Bool True),("User",CV_String "root"),("Group",CV_String "root"),("Pid_File",CV_String "/var/run/mighty.pid"),("Logging",CV_Bool True),("Log_File",CV_String "/var/log/mighty"),("Log_File_Size",CV_Int 16777216),("Log_Backup_Number",CV_Int 10),("Index_File",CV_String "index.html"),("Index_Cgi",CV_String "index.cgi"),("Status_File_Dir",CV_String "/usr/local/share/mighty/status"),("Connection_Timeout",CV_Int 30),("Fd_Cache_Duration",CV_Int 10),("Worker_Processes",CV_Int 1),("Tls_Port",CV_Int 443),("Tls_Cert_File",CV_String "certificate.pem"),("Tls_Key_file",CV_String "key.pem"),("Service",CV_Int 0)]
test/RouteSpec.hs view
@@ -10,7 +10,7 @@ spec = do describe "parseRoute" $ do it "parses example.route correctly" $ do- res <- parseRoute "example.route"+ res <- parseRoute "conf/example.route" res `shouldBe` ans ans :: [Block]
+ utils/mightyctl.hs view
@@ -0,0 +1,67 @@+module Main where++import Data.List+import System.Environment+import System.Exit+import System.Posix.Signals+import System.Posix.Types++import Process (getMightyPid)+import Signal++commandDB :: [(String, Signal)]+commandDB = [+ ("stop", sigStop)+ , ("reload", sigReload)+ , ("retire", sigRetire)+ , ("info", sigInfo)+ ]++usage :: IO a+usage = do+ putStrLn "Usage:"+ putStrLn $ " mightyctl " ++ cmds ++ " [pid]"+ exitFailure+ where+ cmds = intercalate "|" $ map fst commandDB++main :: IO ()+main = do+ (sig,mpid) <- getArgs >>= checkArgs+ pid <- maybe getProcessIdWithPS return mpid+ signalProcess sig pid++checkArgs :: [String] -> IO (Signal, Maybe ProcessID)+checkArgs [cmd] = do+ sig <- getSignal cmd+ return (sig, Nothing)+checkArgs [cmd,num] = do+ sig <- getSignal cmd+ pid <- getProcessId num+ return (sig, Just pid)+checkArgs _ = usage++getSignal :: String -> IO Signal+getSignal cmd = check $ lookup cmd commandDB+ where+ check (Just sig) = return sig+ check Nothing = do+ putStrLn $ "No such command: " ++ cmd+ usage++getProcessId :: String -> IO ProcessID+getProcessId num = check $ reads num+ where+ check [(pid,"")] = return . fromIntegral $ (pid :: Int)+ check _ = do+ putStrLn $ "No such process id: " ++ num+ usage++getProcessIdWithPS :: IO ProcessID+getProcessIdWithPS = getMightyPid >>= check+ where+ check [] = putStrLn "No Mighty found" >> usage+ check [pid] = return pid+ check pids = do+ putStrLn $ "Multiple Mighty found: " ++ intercalate ", " (map show pids)+ usage
+ utils/mkindex.hs view
@@ -0,0 +1,95 @@+{-+ mkindex :: Making index.html for the current directory.+-}+import Control.Applicative+import Data.Bits+import Data.Time+import Data.Time.Clock.POSIX+import System.Directory+import System.Locale+import System.Posix.Files+import Text.Printf++indexFile :: String+indexFile = "index.html"++main :: IO ()+main = do+ contents <- mkContents+ writeFile indexFile $ header ++ contents ++ tailer+ setFileMode indexFile mode+ where+ mode = ownerReadMode .|. ownerWriteMode .|. groupReadMode .|. otherReadMode++mkContents :: IO String+mkContents = do+ fileNames <- filter dotAndIndex <$> getDirectoryContents "."+ stats <- mapM getFileStatus fileNames+ let fmsls = zipWith pp fileNames stats+ maxLen = maximum $ map (\(_,_,_,x) -> x) fmsls+ contents = concatMap (content maxLen) fmsls+ return contents+ where+ dotAndIndex x = head x /= '.' && x /= indexFile++pp :: String -> FileStatus -> (String,String,String,Int)+pp f st = (file,mtime,size,flen)+ where+ file = ppFile f st+ flen = length file+ mtime = ppMtime st+ size = ppSize st++ppFile :: String -> FileStatus -> String+ppFile f st+ | isDirectory st = f ++ "/"+ | otherwise = f++ppMtime :: FileStatus -> String+ppMtime st = dateFormat . epochTimeToUTCTime $ st+ where+ epochTimeToUTCTime = posixSecondsToUTCTime . realToFrac . modificationTime+ dateFormat = formatTime defaultTimeLocale "%d-%b-%Y %H:%M"++ppSize :: FileStatus -> String+ppSize st+ | isDirectory st = " - "+ | otherwise = sizeFormat . fromIntegral . fileSize $ st+ where+ sizeFormat siz = unit siz " KMGT"+ unit _ [] = error "unit"+ unit s [u] = format s u+ unit s (u:us)+ | s >= 1024 = unit (s `div` 1024) us+ | otherwise = format s u+ format :: Integer -> Char -> String+ format = printf "%3d%c"++header :: String+header = "\+\<html>\n\+\<head>\n\+\<style type=\"text/css\">\n\+\<!--\n\+\body { padding-left: 10%; }\n\+\h1 { font-size: x-large; }\n\+\pre { font-size: large; }\n\+\hr { text-align: left; margin-left: 0px; width: 80% }\n\+\-->\n\+\</style>\n\+\</head>\n\+\<title>Directory contents</title>\n\+\<body>\n\+\<h1>Directory contents</h1>\n\+\<hr>\n\+\<pre>\n"++content :: Int -> (String,String,String,Int) -> String+content lim (f,m,s,len) = "<a href=\"" ++ f ++ "\">" ++ f ++ "</a> " ++ replicate (lim - len) ' ' ++ m ++ " " ++ s ++ "\n"++tailer :: String+tailer = "\+\</pre>\n\+\<hr>\n\+\</body>\n\+\</html>\n"