diff --git a/Program/Mighty.hs b/Program/Mighty.hs new file mode 100644 --- /dev/null +++ b/Program/Mighty.hs @@ -0,0 +1,32 @@ +-- | Special library for Mighty. +module Program.Mighty ( + -- * Parsers + module Program.Mighty.Config + , module Program.Mighty.Route + , module Program.Mighty.Parser + -- * State + , module Program.Mighty.FileCache + , module Program.Mighty.Report + , module Program.Mighty.State + -- * Utilities + , module Program.Mighty.ByteString + , module Program.Mighty.Network + , module Program.Mighty.Process + , module Program.Mighty.Resource + , module Program.Mighty.Signal + -- * Internal modules + , module Program.Mighty.IORef + ) where + +import Program.Mighty.ByteString +import Program.Mighty.Config +import Program.Mighty.FileCache +import Program.Mighty.IORef +import Program.Mighty.Network +import Program.Mighty.Parser +import Program.Mighty.Process +import Program.Mighty.Report +import Program.Mighty.Resource +import Program.Mighty.Route +import Program.Mighty.Signal +import Program.Mighty.State diff --git a/Program/Mighty/ByteString.hs b/Program/Mighty/ByteString.hs new file mode 100644 --- /dev/null +++ b/Program/Mighty/ByteString.hs @@ -0,0 +1,15 @@ +module Program.Mighty.ByteString where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS + +-- | Converting showalbe data to 'ByteString'. +bshow :: Show a => a -> ByteString +bshow = BS.pack . show + +infixr 5 +++ + +-- | Appending two 'ByteString'. +(+++) :: ByteString -> ByteString -> ByteString +(+++) = BS.append + diff --git a/Program/Mighty/Config.hs b/Program/Mighty/Config.hs new file mode 100644 --- /dev/null +++ b/Program/Mighty/Config.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, OverloadedStrings #-} + +module Program.Mighty.Config ( + -- * Parsing a configuration file. + parseOption + -- * Creating 'Option'. + , defaultOption + -- * Types + , Option(..) + ) where + +import Control.Applicative hiding (many,optional,(<|>)) +import Program.Mighty.Parser +import Text.Parsec +import Text.Parsec.ByteString.Lazy + +---------------------------------------------------------------- + +-- | Getting a default 'Option'. +defaultOption :: String -- ^ A default server name (e.g. \"Mighttpd/3.0.0\") + -> Option +defaultOption svrnm = 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_proxy_timeout = 0 + , opt_fd_cache_duration = 10 + , opt_server_name = svrnm + , 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_proxy_timeout :: !Int + , opt_fd_cache_duration :: !Int + , opt_server_name :: !String + , 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) + +---------------------------------------------------------------- + +-- | Parsing a configuration file to get an 'Option'. +parseOption :: FilePath -> String -> IO Option +parseOption file svrnm = makeOpt (defaultOption svrnm) <$> 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_proxy_timeout = get "Proxy_Timeout" opt_proxy_timeout + , opt_fd_cache_duration = get "Fd_Cache_Duration" opt_fd_cache_duration + , opt_server_name = get "Server_Name" opt_server_name + , 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/Program/Mighty/FileCache.hs b/Program/Mighty/FileCache.hs new file mode 100644 --- /dev/null +++ b/Program/Mighty/FileCache.hs @@ -0,0 +1,76 @@ +module Program.Mighty.FileCache ( + -- * Types + GetInfo + , RemoveInfo + -- * Starter + , fileCacheInit + ) where + +import Control.Exception +import Control.Exception.IOChoice +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 Program.Mighty.IORef +import System.Posix.Files + +data Entry = Negative | Positive FileInfo +type Cache = HashMap ByteString Entry +type GetInfo = Path -> IO FileInfo +type RemoveInfo = IO () + +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 + let regular = not (isDirectory fs) + readable = fileMode fs `intersectFileModes` ownerReadMode /= 0 + if regular && readable 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, RemoveInfo) +fileCacheInit = do + ref <- newIORef M.empty + return (fileInfo ref, remover ref) + +-- atomicModifyIORef is not necessary here. +remover :: IORef Cache -> IO () +remover ref = writeIORef ref M.empty diff --git a/Program/Mighty/IORef.hs b/Program/Mighty/IORef.hs new file mode 100644 --- /dev/null +++ b/Program/Mighty/IORef.hs @@ -0,0 +1,18 @@ +module Program.Mighty.IORef where + +import Data.IORef + +---------------------------------------------------------------- + +-- | Strict version of 'atomicModifyIORef'. +-- When modifying the IORef, calculation is delayed. +-- So, modification is quick and CAS would success. +-- After modification, calculation is forced. +-- So, no space leak. +strictAtomicModifyIORef :: IORef a -> (a -> a) -> IO () +strictAtomicModifyIORef ref f = do + c <- atomicModifyIORef ref + (\x -> let a = f x -- Lazy application of "f" + in (a, a `seq` ())) -- Lazy application of "seq" + -- The following forces "a `seq` ()", so it also forces "f x". + c `seq` return c diff --git a/Program/Mighty/Network.hs b/Program/Mighty/Network.hs new file mode 100644 --- /dev/null +++ b/Program/Mighty/Network.hs @@ -0,0 +1,59 @@ +module Program.Mighty.Network ( + listenSocket + , daemonize + ) where + +import Control.Exception +import Control.Monad +import qualified Network as N +import Network.BSD +import Network.Socket +import System.Exit +import System.Posix + +---------------------------------------------------------------- + +-- | Open an 'Socket' with 'ReuseAddr' and 'NoDelay' set. +listenSocket :: String -- ^ Service name + -> Int -- ^ A number of backlogs. + -> IO Socket +listenSocket serv backlog = 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 backlog + +listenSocket' :: AddrInfo -> Int -> IO Socket +listenSocket' addr backlog = bracketOnError setup cleanup $ \sock -> do + setSocketOption sock ReuseAddr 1 + setSocketOption sock NoDelay 1 + bindSocket sock (addrAddress addr) + listen sock backlog + return sock + where + setup = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + cleanup = N.sClose + +---------------------------------------------------------------- + +-- | Run a program detaching its terminal. +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/Program/Mighty/Parser.hs b/Program/Mighty/Parser.hs new file mode 100644 --- /dev/null +++ b/Program/Mighty/Parser.hs @@ -0,0 +1,91 @@ +-- | Parsers for Mighty + +module Program.Mighty.Parser ( + -- * Utilities + parseFile + -- * Parsers + , spcs + , spcs1 + , spc + , commentLines + , trailing + , comment + ) 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 + +-- $setup +-- >>> import Data.Either +-- >>> let isLeft = either (const True) (const False) + +-- | Parsing a file. +-- If parsing fails, an 'IOException' is thrown. +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 + +-- | 'Parser' to consume zero or more white spaces +-- +-- >>> parse spcs "" " " +-- Right () +-- >>> parse spcs "" "" +-- Right () +spcs :: Parser () +spcs = () <$ many spc + +-- | 'Parser' to consume one or more white spaces +-- +-- >>> parse spcs1 "" " " +-- Right () +-- >>> parse spcs1 "" " " +-- Right () +-- >>> isLeft $ parse spcs1 "" "" +-- True +spcs1 :: Parser () +spcs1 = () <$ many1 spc + +-- | 'Parser' to consume exactly one white space +-- +-- >>> parse spc "" " " +-- Right ' ' +-- >>> isLeft $ parse spc "" "" +-- True +spc :: Parser Char +spc = satisfy (`elem` " \t") + +-- | 'Parser' to consume one or more comment lines +-- +-- >>> parse commentLines "" "# comments\n# comments\n# comments\n" +-- Right () +commentLines :: Parser () +commentLines = () <$ many commentLine + where + commentLine = trailing + +-- | 'Parser' to consume a trailing comment +-- +-- >>> parse trailing "" "# comments\n" +-- Right () +-- >>> isLeft $ parse trailing "" "X# comments\n" +-- True +trailing :: Parser () +trailing = () <$ (comment *> newline <|> newline) + +-- | 'Parser' to consume a trailing comment +-- +-- >>> parse comment "" "# comments" +-- Right () +-- >>> isLeft $ parse comment "" "foo" +-- True +comment :: Parser () +comment = () <$ char '#' <* many (noneOf "\n") diff --git a/Program/Mighty/Process.hs b/Program/Mighty/Process.hs new file mode 100644 --- /dev/null +++ b/Program/Mighty/Process.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Program.Mighty.Process ( + getMightyPid + ) 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) + +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 + +---------------------------------------------------------------- + +-- | Getting the process id of a running Mighty. +getMightyPid :: IO [ProcessID] +getMightyPid = (map pid . findParent) <$> 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/Program/Mighty/Report.hs b/Program/Mighty/Report.hs new file mode 100644 --- /dev/null +++ b/Program/Mighty/Report.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Program.Mighty.Report ( + Reporter + , initReporter + , finReporter + , report + , reportDo + , warpHandler + , printStdout + ) where + +import Control.Applicative +import Control.Exception +import qualified Control.Exception as E (catch) +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.UnixTime +import GHC.IO.Exception (IOErrorType(..)) +import Network.Wai +import Network.Wai.Handler.Warp (InvalidRequest) +import System.IO +import System.IO.Error (ioeGetErrorType) +import System.Posix (getProcessID) + +import Program.Mighty.ByteString + +data Method = FileOnly | FileAndStdout deriving Eq +data Reporter = Reporter Method Handle + +initReporter :: Bool -> FilePath -> IO (Either SomeException Reporter) +initReporter debug reportFile = try $ Reporter method <$> openFile reportFile AppendMode + where + method + | debug = FileAndStdout + | otherwise = FileOnly + +finReporter :: Reporter -> IO () +finReporter (Reporter _ rpthdl) = hClose rpthdl + +report :: Reporter -> ByteString -> IO () +report (Reporter method rpthdl) msg = handle (\(SomeException _) -> return ()) $ do + pid <- BS.pack . show <$> getProcessID + tm <- getUnixTime >>= formatUnixTime "%d %b %Y %H:%M:%S" + let logmsg = BS.concat [tm, ": pid = ", pid, ": ", msg, "\n"] + BS.hPutStr rpthdl logmsg + hFlush rpthdl + when (method == FileAndStdout) $ BS.putStr logmsg + +---------------------------------------------------------------- + +reportDo :: Reporter -> IO () -> IO () +reportDo rpt act = act `E.catch` warpHandler rpt Nothing + +---------------------------------------------------------------- + +warpHandler :: Reporter -> Maybe Request -> 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 + +---------------------------------------------------------------- + +printStdout :: Maybe Request -> SomeException -> IO () +printStdout _ x = print x >> hFlush stdout diff --git a/Program/Mighty/Resource.hs b/Program/Mighty/Resource.hs new file mode 100644 --- /dev/null +++ b/Program/Mighty/Resource.hs @@ -0,0 +1,40 @@ +module Program.Mighty.Resource ( + amIrootUser + , setGroupUser + , unlimit + ) where + +import Control.Applicative +import Control.Exception +import Control.Monad +import System.Posix + +---------------------------------------------------------------- + +-- | Checking if this process has the root privilege. +amIrootUser :: IO Bool +amIrootUser = (== 0) <$> getRealUserID + +---------------------------------------------------------------- + +-- | Setting user and group. +setGroupUser :: String -- ^ User + -> String -- ^ Group + -> IO () +setGroupUser user group = do + root <- amIrootUser + when root $ do + getGroupEntryForName group >>= setGroupID . groupID + getUserEntryForName user >>= setUserID . userID + +---------------------------------------------------------------- + +-- | Set the limit of open files. +unlimit :: Integer -> IO () +unlimit limit = handle (\(SomeException _) -> return ()) $ do + hard <- hardLimit <$> getResourceLimit ResourceOpenFiles + let lim = if hard == ResourceLimitInfinity then + ResourceLimits (ResourceLimit limit) hard + else + ResourceLimits hard hard + setResourceLimit ResourceOpenFiles lim diff --git a/Program/Mighty/Route.hs b/Program/Mighty/Route.hs new file mode 100644 --- /dev/null +++ b/Program/Mighty/Route.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings, TupleSections #-} + +module Program.Mighty.Route ( + -- * Paring a routing file + parseRoute + -- * Types + , RouteDB + , Route(..) + , Block(..) + , Src + , Dst + , Domain + , Port + ) where + +import Control.Applicative hiding (many,(<|>)) +import Control.Monad +import Data.ByteString +import qualified Data.ByteString.Char8 as BS +import Network.Wai.Application.Classic +import Text.Parsec +import Text.Parsec.ByteString.Lazy + +import Program.Mighty.Parser + +---------------------------------------------------------------- + +-- | A logical path specified in URL. +type Src = Path +-- | A physical path in a file system. +type Dst = Path +type Domain = 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] + +---------------------------------------------------------------- + +-- | Parsing a route file. +parseRoute :: FilePath + -> Domain -- ^ A default domain, typically \"localhost\" + -> Port -- ^ A default port, typically 80. + -> IO RouteDB +parseRoute file ddom dport = parseFile (routeDB ddom dport) file + +routeDB :: Domain -> Port -> Parser RouteDB +routeDB ddom dport = commentLines *> many1 (block ddom dport) <* eof + +block :: Domain -> Port -> Parser Block +block ddom dport = Block <$> cdomains <*> many croute + where + cdomains = domains <* commentLines + croute = route ddom dport <* 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 :: Domain -> Port -> Parser Route +route ddom dport = 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 ddom dport + 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 :: Domain -> Port -> Parser (Domain, Port, Dst) +domPortDst ddom dport = (ddom,,) <$> port <*> path + <|> try((,,) <$> domain <*> port <*> path) + <|> (,dport,) <$> domain <*> path + where + domain = BS.pack <$> many1 (noneOf ":/[], \t\n") + port = do + void $ char ':' + read <$> many1 (oneOf ['0'..'9']) diff --git a/Program/Mighty/Signal.hs b/Program/Mighty/Signal.hs new file mode 100644 --- /dev/null +++ b/Program/Mighty/Signal.hs @@ -0,0 +1,36 @@ +module Program.Mighty.Signal ( + -- * Signals + sigStop + , sigReload + , sigRetire + , sigInfo + -- * Signal handling + , setHandler + ) where + +import Control.Monad +import System.Posix + +---------------------------------------------------------------- + +-- | The signal to stop Mighty. +sigStop :: Signal +sigStop = sigTERM + +-- | The signal to reload a configration file. +sigReload :: Signal +sigReload = sigHUP + +-- | The signal to top accepting new connections and to finish current connections. +sigRetire :: Signal +sigRetire = sigQUIT + +-- | The signal to get information from Mighty. +sigInfo :: Signal +sigInfo = sigUSR2 + +---------------------------------------------------------------- + +-- | Setting 'Handler' for 'Signal'. +setHandler :: Signal -> Handler -> IO () +setHandler sig func = void $ installHandler sig func Nothing diff --git a/Program/Mighty/State.hs b/Program/Mighty/State.hs new file mode 100644 --- /dev/null +++ b/Program/Mighty/State.hs @@ -0,0 +1,120 @@ +module Program.Mighty.State ( + -- * Types + Status(..) + , Stater + -- * Creating Stater + , initStater + -- * Accessing Stater + , getConnectionCounter + , getServerStatus + , isRetiring + -- * Modifying Stater + , increment + , decrement + , setMyWarpThreadId + , addAnotherWarpThreadId + , goRetiring + -- * Misc + , ifWarpThreadsAreActive + ) where + +import Control.Applicative +import Control.Concurrent +import Data.IORef +import Program.Mighty.IORef + +---------------------------------------------------------------- + +-- | Server status +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 + +---------------------------------------------------------------- + +-- | Reference to a server state. +newtype Stater = Stater (IORef State) + +-- | Creating a new 'Stater'. +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 + +-- | Setting status to 'Retiring'. +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) + _ -> error "addAnotherWarpThreadId" + +-- | If Warp threads are active, first terminate them and +-- run new 'IO'. +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/conf/example.conf b/conf/example.conf --- a/conf/example.conf +++ b/conf/example.conf @@ -16,7 +16,6 @@ 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. diff --git a/mighttpd2.cabal b/mighttpd2.cabal --- a/mighttpd2.cabal +++ b/mighttpd2.cabal @@ -1,5 +1,5 @@ Name: mighttpd2 -Version: 2.8.9 +Version: 3.0.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -11,130 +11,115 @@ to connect web applications behind. Homepage: http://www.mew.org/~kazu/proj/mighttpd/ Category: Network, Web -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.10 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 +Library + Default-Language: Haskell2010 + GHC-Options: -Wall + Exposed-Modules: Program.Mighty + Program.Mighty.ByteString + Program.Mighty.Config + Program.Mighty.FileCache + Program.Mighty.IORef + Program.Mighty.Network + Program.Mighty.Parser + Program.Mighty.Process + Program.Mighty.Report + Program.Mighty.Resource + Program.Mighty.Route + Program.Mighty.Signal + Program.Mighty.State + Build-Depends: base >= 4.0 && < 5 + , array + , blaze-builder + , byteorder + , bytestring + , case-insensitive + , conduit + , directory + , filepath + , http-date + , http-types + , io-choice + , network + , parsec >= 3 + , process-conduit + , unix + , unix-time + , unordered-containers + , wai >= 2.0 + , wai-app-file-cgi >= 1.0 + , warp >= 2.0 + Executable mighty + Default-Language: Haskell2010 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 , bytestring - , conduit - , date-cache - , deepseq , directory , filepath + , http-client , http-date , http-types - , io-choice + , mighttpd2 , network , network-conduit - , old-locale - , parsec >= 3 - , process-conduit - , time , transformers , unix - , unix-time >= 0.2 - , unordered-containers - , wai >= 1.3 - , wai-app-file-cgi - , wai-logger - , wai-logger-prefork - , warp >= 1.3 - if flag(rev-proxy) - Build-Depends: http-conduit >= 1.8.2.1 + , wai >= 2.0 + , wai-app-file-cgi >= 2.0 + , wai-logger >= 2.0 + , warp >= 2.0 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 + Other-Modules: Mighty + Server + WaiApp Paths_mighttpd2 Executable mighty-mkindex + Default-Language: Haskell2010 HS-Source-Dirs: utils, src Main-Is: mkindex.hs GHC-Options: -Wall Build-Depends: base >= 4 && < 5 - , unix - , old-locale , directory + , old-locale , time + , unix Executable mightyctl + Default-Language: Haskell2010 HS-Source-Dirs: utils, src Main-Is: mightyctl.hs GHC-Options: -Wall Build-Depends: base >= 4 && < 5 - , bytestring - , conduit - , process-conduit , unix + , mighttpd2 Test-Suite spec + Default-Language: Haskell2010 Main-Is: Spec.hs Hs-Source-Dirs: test, src Type: exitcode-stdio-1.0 Other-Modules: ConfigSpec RouteSpec Build-Depends: base >= 4 && < 5 - , bytestring - , deepseq - , directory - , filepath - , http-date - , http-types - , network - , network-conduit - , old-locale - , parsec >= 3 - , time - , transformers - , unix - , unordered-containers - , wai >= 1.1 - , wai-app-file-cgi - , wai-logger - , wai-logger-prefork - , warp , hspec >= 1.3 - if flag(rev-proxy) - Build-Depends: http-conduit >= 1.8.2.1 + , mighttpd2 + , http-client if flag(tls) Build-Depends: tls , warp-tls >= 1.4.1 diff --git a/src/Config.hs b/src/Config.hs deleted file mode 100644 --- a/src/Config.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Config (Option(..), parseOption, defaultOption) where - -import Config.Internal diff --git a/src/Config/Internal.hs b/src/Config/Internal.hs deleted file mode 100644 --- a/src/Config/Internal.hs +++ /dev/null @@ -1,152 +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 - , 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 deleted file mode 100644 --- a/src/Daemon.hs +++ /dev/null @@ -1,33 +0,0 @@ -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 deleted file mode 100644 --- a/src/FileCGIApp.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/FileCache.hs +++ /dev/null @@ -1,72 +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 - let regular = not (isDirectory fs) - readable = fileMode fs `intersectFileModes` ownerReadMode /= 0 - if regular && readable 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 deleted file mode 100644 --- a/src/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/src/Mighty.hs b/src/Mighty.hs --- a/src/Mighty.hs +++ b/src/Mighty.hs @@ -2,50 +2,47 @@ module Main where -import Control.Concurrent -import Control.Monad +import Control.Monad (when) +import Data.Version (showVersion) 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.Directory (getCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.FilePath (addTrailingPathSeparator, isAbsolute, normalise, ()) 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 +import Program.Mighty +import Server +import Paths_mighttpd2 as P + ---------------------------------------------------------------- +programName :: String +programName = "Mighttpd" + +programVersion :: String +programVersion = showVersion P.version + +---------------------------------------------------------------- + main :: IO () main = do (opt,route) <- getOptRoute checkTLS opt let reportFile = reportFileName opt - rpt <- initReporter reportFile >>= checkReporter reportFile - if opt_debug_mode opt then - server opt route rpt - else - background opt $ server opt route rpt + debug = opt_debug_mode opt + rpt <- initReporter debug reportFile >>= checkReporter reportFile + let run = server opt rpt route + if debug then run else background opt run where getOptRoute = getArgs >>= eachCase + svrnm = programName ++ "/" ++ programVersion eachCase args | n == 0 = do root <- amIrootUser - let opt | root = defaultOption { opt_port = 80 } - | otherwise = defaultOption + let opt | root = (defaultOption svrnm) { opt_port = 80 } + | otherwise = defaultOption svrnm dir <- getCurrentDirectory let dst = fromString . addTrailingPathSeparator $ dir route = [Block ["*"] [RouteFile "/" dst]] @@ -53,8 +50,8 @@ | n == 2 = do let config_file = args !! 0 routing_file <- getAbsoluteFile (args !! 1) - opt <- parseOption config_file - route <- parseRoute routing_file + opt <- parseOption config_file svrnm + route <- parseRoute routing_file defaultDomain defaultPort let opt' = opt {opt_routing_file = Just routing_file} return (opt',route) | otherwise = do @@ -68,12 +65,6 @@ | otherwise = do dir <- getCurrentDirectory return $ dir normalise file - reportFileName opt - | port == 80 = rfile - | otherwise = rfile ++ show port - where - rfile = opt_report_file opt - port = opt_port opt checkReporter _ (Right rpt) = return rpt checkReporter reportFile (Left e) = do hPutStrLn stderr $ reportFile ++ " is not writable" @@ -89,63 +80,19 @@ ---------------------------------------------------------------- -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 +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 \"" ++ reportFileName opt ++ "\".)" + hFlush stdout + daemonize svr 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 + port = opt_port opt -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 +reportFileName :: Option -> FilePath +reportFileName opt + | port == 80 = rfile + | otherwise = rfile ++ show port 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 + rfile = opt_report_file opt + port = opt_port opt diff --git a/src/Multi.hs b/src/Multi.hs deleted file mode 100644 --- a/src/Multi.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Net.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Net (listenSocket) where - -import Control.Exception -import qualified Network as N -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 = N.sClose diff --git a/src/Parser.hs b/src/Parser.hs deleted file mode 100644 --- a/src/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/src/Process.hs b/src/Process.hs deleted file mode 100644 --- a/src/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/src/Report.hs b/src/Report.hs deleted file mode 100644 --- a/src/Report.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# 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 <- getUnixTime >>= formatUnixTime "%d %b %Y %H:%M:%S" - 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 deleted file mode 100644 --- a/src/Resource.hs +++ /dev/null @@ -1,35 +0,0 @@ -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 deleted file mode 100644 --- a/src/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/src/Server.hs b/src/Server.hs new file mode 100644 --- /dev/null +++ b/src/Server.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE OverloadedStrings, CPP, BangPatterns #-} + +module Server (server, defaultDomain, defaultPort) where + +import Control.Applicative ((<$>)) +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception (try) +import Control.Monad (void, unless, when) +import qualified Data.ByteString.Char8 as BS (pack) +import Network (Socket, sClose) +import qualified Network.HTTP.Client.Manager as H +import Network.Wai.Application.Classic hiding ((), (+++)) +import Network.Wai.Handler.Warp +import System.Exit (ExitCode(..), exitSuccess) +import System.IO +import System.IO.Error (ioeGetErrorString) +import System.Posix (exitImmediately, Handler(..), getProcessID, setFileMode) +import System.Posix.Signals (sigCHLD) +import Network.Wai.Logger + +#ifdef TLS +import Network.Wai.Handler.WarpTLS +#endif + +import Program.Mighty + +import WaiApp + +---------------------------------------------------------------- + +defaultDomain :: Domain +defaultDomain = "localhost" + +defaultPort :: Int +defaultPort = 80 + +backlogNumber :: Int +backlogNumber = 2048 + +openFileNumber :: Integer +openFileNumber = 10000 + +oneSecond :: Int +oneSecond = 1000000 + +longTimerInterval :: Int +longTimerInterval = 10 + +logBufferSize :: Int +logBufferSize = 4 * 1024 * 10 + +managerNumber :: Int +managerNumber = 1024 -- FIXME + +---------------------------------------------------------------- + +type LogFlusher = IO () +type LogRotator = IO () +type LogRemover = IO () + +---------------------------------------------------------------- + +server :: Option -> Reporter -> RouteDB -> IO () +server opt rpt route = reportDo rpt $ do + unlimit openFileNumber + svc <- openService opt + unless debug writePidFile + setGroupUser (opt_user opt) (opt_group opt) + logCheck logtype + stt <- initStater + (zdater,zupdater) <- clockDateCacher + ap <- initLogger FromSocket logtype zdater + let lgr = apacheLogger ap + flusher = logFlusher ap + rotator = logRotator ap + remover = logRemover ap + (getInfo,cleaner) <- fileCacheInit + mgr <- getManager opt + let mighty = reload opt rpt svc stt lgr getInfo mgr + setHandlers opt rpt svc stt remover mighty + report rpt "Mighty started" + void . forkIO $ mighty route + mainLoop rpt stt cleaner flusher remover debug rotator zupdater 0 + where + debug = opt_debug_mode opt + port = opt_port opt + pidfile + | port == 80 = opt_pid_file opt + | otherwise = opt_pid_file opt ++ show port + 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 logBufferSize + | otherwise = LogFile logspec logBufferSize + +setHandlers :: Option -> Reporter -> Service -> Stater -> LogRemover -> Mighty -> IO () +setHandlers opt rpt svc stt remover mighty = do + setHandler sigStop stopHandler + setHandler sigRetire retireHandler + setHandler sigInfo infoHandler + setHandler sigReload reloadHandler + setHandler sigCHLD Ignore -- for CGI + where + stopHandler = Catch $ do + report rpt "Mighty finished" + finReporter rpt + closeService svc + remover + exitImmediately ExitSuccess + retireHandler = Catch $ ifWarpThreadsAreActive stt $ do + report rpt "Mighty retiring" + closeService svc + goRetiring stt + infoHandler = Catch $ do + i <- bshow <$> getConnectionCounter stt + status <- bshow <$> getServerStatus stt + report rpt $ status +++ ": # of connections = " +++ i + reloadHandler = Catch $ ifWarpThreadsAreActive stt $ + ifRouteFileIsValid rpt opt $ \newroute -> do + report rpt "Mighty reloaded" + void . forkIO $ mighty newroute + +---------------------------------------------------------------- + +type Mighty = RouteDB -> IO () + +ifRouteFileIsValid :: Reporter -> Option -> Mighty -> IO () +ifRouteFileIsValid rpt opt act = case opt_routing_file opt of + Nothing -> return () + Just rfile -> try (parseRoute rfile defaultDomain defaultPort) >>= either reportError act + where + reportError = report rpt . BS.pack . ioeGetErrorString + +---------------------------------------------------------------- + +reload :: Option -> Reporter -> Service -> Stater + -> ApacheLogger -> GetInfo -> ConnPool + -> Mighty +reload opt rpt svc stt lgr getInfo _mgr route = reportDo rpt $ do + setMyWarpThreadId stt + let app req = fileCgiApp cspec filespec cgispec revproxyspec route req + case svc 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 + } + serverName = BS.pack $ opt_server_name opt + cspec = ClassicAppSpec { + softwareName = serverName + , logger = lgr + , 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 + } +#ifdef TLS + tlsSetting = defaultTlsSettings { + certFile = opt_tls_cert_file opt + , keyFile = opt_tls_key_file opt + } +#endif + +---------------------------------------------------------------- + +mainLoop :: Reporter -> Stater -> RemoveInfo + -> LogFlusher -> LogRemover -> Bool -> LogRotator + -> DateCacheUpdater + -> Int -> IO () +mainLoop rpt stt cleaner flusher remover everySecond rotator zupdater sec = do + threadDelay oneSecond + retiring <- isRetiring stt + counter <- getConnectionCounter stt + if retiring && counter == 0 then do + report rpt "Mighty retired" + finReporter rpt + remover + exitSuccess + else do + zupdater + when everySecond flusher + let longTimer = sec == longTimerInterval + when longTimer $ do + unless everySecond flusher + cleaner + rotator + let !next = if longTimer then 0 else sec + 1 + mainLoop rpt stt cleaner flusher remover everySecond rotator zupdater next + +---------------------------------------------------------------- + +data Service = HttpOnly Socket | HttpsOnly Socket | HttpAndHttps Socket Socket + +---------------------------------------------------------------- + +openService :: Option -> IO Service +openService opt + | service == 1 = do + s <- listenSocket httpsPort backlogNumber + debugMessage $ "HTTP/TLS service on port " ++ httpsPort ++ "." + return $ HttpsOnly s + | service == 2 = do + s1 <- listenSocket httpPort backlogNumber + s2 <- listenSocket httpsPort backlogNumber + debugMessage $ "HTTP service on port " ++ httpPort ++ " and " + ++ "HTTP/TLS service on port " ++ httpsPort ++ "." + return $ HttpAndHttps s1 s2 + | otherwise = do + s <- listenSocket httpPort backlogNumber + 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 + +---------------------------------------------------------------- + +closeService :: Service -> IO () +closeService (HttpOnly s) = sClose s +closeService (HttpsOnly s) = sClose s +closeService (HttpAndHttps s1 s2) = sClose s1 >> sClose s2 + +---------------------------------------------------------------- + +type ConnPool = H.Manager + +getManager :: Option -> IO ConnPool +getManager opt = H.newManager H.defaultManagerSettings { + H.managerConnCount = managerNumber + , H.managerResponseTimeout = if opt_proxy_timeout opt == 0 then + H.managerResponseTimeout H.defaultManagerSettings + else + Just (opt_proxy_timeout opt) + } diff --git a/src/Signal.hs b/src/Signal.hs deleted file mode 100644 --- a/src/Signal.hs +++ /dev/null @@ -1,34 +0,0 @@ -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 deleted file mode 100644 --- a/src/Single.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/State.hs +++ /dev/null @@ -1,109 +0,0 @@ -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 deleted file mode 100644 --- a/src/Types.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Utils.hs +++ /dev/null @@ -1,34 +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 diff --git a/src/WaiApp.hs b/src/WaiApp.hs new file mode 100644 --- /dev/null +++ b/src/WaiApp.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings, CPP #-} + +module WaiApp (fileCgiApp) where + +import Control.Monad.IO.Class (liftIO) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS (isPrefixOf, length) +import Network.HTTP.Types (preconditionFailed412, movedPermanently301) +import Network.Wai (Application, responseLBS) +import Network.Wai.Internal +import Network.Wai.Application.Classic + +import Program.Mighty + +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 + (host, _) = hostPort req + mmp = case getBlock host 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/test/ConfigSpec.hs b/test/ConfigSpec.hs --- a/test/ConfigSpec.hs +++ b/test/ConfigSpec.hs @@ -1,14 +1,14 @@ module ConfigSpec where -import Config.Internal +import Program.Mighty import Test.Hspec spec :: Spec spec = do describe "parseConfig" $ do it "parses example.conf correctly" $ do - res <- parseConfig "conf/example.conf" + res <- parseOption "conf/example.conf" "foo" 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),("Tls_Port",CV_Int 443),("Tls_Cert_File",CV_String "certificate.pem"),("Tls_Key_file",CV_String "key.pem"),("Service",CV_Int 0)] +ans :: Option +ans = Option {opt_port = 80, 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 = "foo", 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", opt_proxy_timeout = 0} diff --git a/test/RouteSpec.hs b/test/RouteSpec.hs --- a/test/RouteSpec.hs +++ b/test/RouteSpec.hs @@ -2,15 +2,15 @@ module RouteSpec where -import Route import Test.Hspec -import Types +import Program.Mighty + spec :: Spec spec = do describe "parseRoute" $ do it "parses example.route correctly" $ do - res <- parseRoute "conf/example.route" + res <- parseRoute "conf/example.route" "localhost" 80 res `shouldBe` ans ans :: [Block] diff --git a/utils/mightyctl.hs b/utils/mightyctl.hs --- a/utils/mightyctl.hs +++ b/utils/mightyctl.hs @@ -6,8 +6,7 @@ import System.Posix.Signals import System.Posix.Types -import Process (getMightyPid) -import Signal +import Program.Mighty (getMightyPid, sigStop, sigReload, sigRetire, sigInfo) commandDB :: [(String, Signal)] commandDB = [