diff --git a/Config.hs b/Config.hs deleted file mode 100644 --- a/Config.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Config (Option(..), parseOption, defaultOption) where - -import Config.Internal diff --git a/Config/Internal.hs b/Config/Internal.hs deleted file mode 100644 --- a/Config/Internal.hs +++ /dev/null @@ -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") diff --git a/FileCGIApp.hs b/FileCGIApp.hs deleted file mode 100644 --- a/FileCGIApp.hs +++ /dev/null @@ -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 diff --git a/FileCache.hs b/FileCache.hs deleted file mode 100644 --- a/FileCache.hs +++ /dev/null @@ -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 diff --git a/Log.hs b/Log.hs deleted file mode 100644 --- a/Log.hs +++ /dev/null @@ -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 diff --git a/Mighty.hs b/Mighty.hs deleted file mode 100644 --- a/Mighty.hs +++ /dev/null @@ -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 diff --git a/Parser.hs b/Parser.hs deleted file mode 100644 --- a/Parser.hs +++ /dev/null @@ -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 diff --git a/Process.hs b/Process.hs deleted file mode 100644 --- a/Process.hs +++ /dev/null @@ -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) diff --git a/Report.hs b/Report.hs deleted file mode 100644 --- a/Report.hs +++ /dev/null @@ -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 diff --git a/Route.hs b/Route.hs deleted file mode 100644 --- a/Route.hs +++ /dev/null @@ -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']) diff --git a/Signal.hs b/Signal.hs deleted file mode 100644 --- a/Signal.hs +++ /dev/null @@ -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 diff --git a/State.hs b/State.hs deleted file mode 100644 --- a/State.hs +++ /dev/null @@ -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 - } diff --git a/Types.hs b/Types.hs deleted file mode 100644 --- a/Types.hs +++ /dev/null @@ -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 diff --git a/Utils.hs b/Utils.hs deleted file mode 100644 --- a/Utils.hs +++ /dev/null @@ -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 diff --git a/conf/example.conf b/conf/example.conf new file mode 100644 --- /dev/null +++ b/conf/example.conf @@ -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 diff --git a/conf/example.route b/conf/example.route new file mode 100644 --- /dev/null +++ b/conf/example.route @@ -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/ diff --git a/example.conf b/example.conf deleted file mode 100644 --- a/example.conf +++ /dev/null @@ -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 diff --git a/example.route b/example.route deleted file mode 100644 --- a/example.route +++ /dev/null @@ -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/ diff --git a/mighttpd2.cabal b/mighttpd2.cabal --- a/mighttpd2.cabal +++ b/mighttpd2.cabal @@ -1,5 +1,5 @@ Name: mighttpd2 -Version: 2.8.4 +Version: 2.8.5 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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 diff --git a/mightyctl.hs b/mightyctl.hs deleted file mode 100644 --- a/mightyctl.hs +++ /dev/null @@ -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 diff --git a/mkindex.hs b/mkindex.hs deleted file mode 100644 --- a/mkindex.hs +++ /dev/null @@ -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 = "\ -\\n\ -\\n\ -\\n\ -\\n\ -\Directory contents\n\ -\\n\ -\

Directory contents

\n\ -\
\n\ -\
\n"
-
-content :: Int -> (String,String,String,Int) -> String
-content lim (f,m,s,len) = "" ++ f ++ "  " ++ replicate (lim - len) ' ' ++ m ++ "  " ++ s ++ "\n"
-
-tailer :: String
-tailer = "\
-\
\n\ -\
\n\ -\\n\ -\\n" diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,3 @@ +module Config (Option(..), parseOption, defaultOption) where + +import Config.Internal diff --git a/src/Config/Internal.hs b/src/Config/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Config/Internal.hs @@ -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") diff --git a/src/Daemon.hs b/src/Daemon.hs new file mode 100644 --- /dev/null +++ b/src/Daemon.hs @@ -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 diff --git a/src/FileCGIApp.hs b/src/FileCGIApp.hs new file mode 100644 --- /dev/null +++ b/src/FileCGIApp.hs @@ -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 diff --git a/src/FileCache.hs b/src/FileCache.hs new file mode 100644 --- /dev/null +++ b/src/FileCache.hs @@ -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 diff --git a/src/Log.hs b/src/Log.hs new file mode 100644 --- /dev/null +++ b/src/Log.hs @@ -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 diff --git a/src/Mighty.hs b/src/Mighty.hs new file mode 100644 --- /dev/null +++ b/src/Mighty.hs @@ -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 diff --git a/src/Multi.hs b/src/Multi.hs new file mode 100644 --- /dev/null +++ b/src/Multi.hs @@ -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] diff --git a/src/Net.hs b/src/Net.hs new file mode 100644 --- /dev/null +++ b/src/Net.hs @@ -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 diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -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 diff --git a/src/Process.hs b/src/Process.hs new file mode 100644 --- /dev/null +++ b/src/Process.hs @@ -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) diff --git a/src/Report.hs b/src/Report.hs new file mode 100644 --- /dev/null +++ b/src/Report.hs @@ -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 diff --git a/src/Resource.hs b/src/Resource.hs new file mode 100644 --- /dev/null +++ b/src/Resource.hs @@ -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 diff --git a/src/Route.hs b/src/Route.hs new file mode 100644 --- /dev/null +++ b/src/Route.hs @@ -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']) diff --git a/src/Signal.hs b/src/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Signal.hs @@ -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 diff --git a/src/Single.hs b/src/Single.hs new file mode 100644 --- /dev/null +++ b/src/Single.hs @@ -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 diff --git a/src/State.hs b/src/State.hs new file mode 100644 --- /dev/null +++ b/src/State.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -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 diff --git a/test/ConfigSpec.hs b/test/ConfigSpec.hs --- a/test/ConfigSpec.hs +++ b/test/ConfigSpec.hs @@ -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)] diff --git a/test/RouteSpec.hs b/test/RouteSpec.hs --- a/test/RouteSpec.hs +++ b/test/RouteSpec.hs @@ -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] diff --git a/utils/mightyctl.hs b/utils/mightyctl.hs new file mode 100644 --- /dev/null +++ b/utils/mightyctl.hs @@ -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 diff --git a/utils/mkindex.hs b/utils/mkindex.hs new file mode 100644 --- /dev/null +++ b/utils/mkindex.hs @@ -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 = "\ +\\n\ +\\n\ +\\n\ +\\n\ +\Directory contents\n\ +\\n\ +\

Directory contents

\n\ +\
\n\ +\
\n"
+
+content :: Int -> (String,String,String,Int) -> String
+content lim (f,m,s,len) = "" ++ f ++ "  " ++ replicate (lim - len) ' ' ++ m ++ "  " ++ s ++ "\n"
+
+tailer :: String
+tailer = "\
+\
\n\ +\
\n\ +\\n\ +\\n"