packages feed

mighttpd2 2.8.9 → 3.0.0

raw patch · 39 files changed

+1384/−1354 lines, 39 filesdep +arraydep +blaze-builderdep +byteorderdep −blaze-htmldep −date-cachedep −deepseqdep ~basedep ~unix-timedep ~wai

Dependencies added: array, blaze-builder, byteorder, case-insensitive, http-client, mighttpd2

Dependencies removed: blaze-html, date-cache, deepseq, http-conduit, wai-logger-prefork

Dependency ranges changed: base, unix-time, wai, wai-app-file-cgi, wai-logger, warp

Files

+ Program/Mighty.hs view
@@ -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
+ Program/Mighty/ByteString.hs view
@@ -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+
+ Program/Mighty/Config.hs view
@@ -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")
+ Program/Mighty/FileCache.hs view
@@ -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
+ Program/Mighty/IORef.hs view
@@ -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
+ Program/Mighty/Network.hs view
@@ -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
+ Program/Mighty/Parser.hs view
@@ -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")
+ Program/Mighty/Process.hs view
@@ -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)
+ Program/Mighty/Report.hs view
@@ -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
+ Program/Mighty/Resource.hs view
@@ -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
+ Program/Mighty/Route.hs view
@@ -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'])
+ Program/Mighty/Signal.hs view
@@ -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
+ Program/Mighty/State.hs view
@@ -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
conf/example.conf view
@@ -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.
mighttpd2.cabal view
@@ -1,5 +1,5 @@ Name:                   mighttpd2-Version:                2.8.9+Version:                3.0.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> 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
− src/Config.hs 
@@ -1,3 +0,0 @@-module Config (Option(..), parseOption, defaultOption) where--import Config.Internal
− src/Config/Internal.hs 
@@ -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")
− src/Daemon.hs 
@@ -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
− src/FileCGIApp.hs 
@@ -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
− src/FileCache.hs 
@@ -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
− src/Log.hs 
@@ -1,22 +0,0 @@-module Log (-    Logger-  , initLogger-  , apatcheLogger-  , finLogger-  ) where--import Network.Wai.Logger-import Network.Wai.Logger.Prefork--data Logger = Logger ApacheLogger LogFlusher--initLogger :: IPAddrSource -> LogType -> IO Logger-initLogger ipsrc logtyp = do-    (aplgr, flusher) <- logInit ipsrc logtyp-    return $ Logger aplgr flusher--finLogger :: Logger -> LogFlusher-finLogger (Logger _ flusher) = flusher--apatcheLogger :: Logger -> ApacheLogger-apatcheLogger (Logger aplogr _) = aplogr
src/Mighty.hs view
@@ -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
− src/Multi.hs 
@@ -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]
− src/Net.hs 
@@ -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
− src/Parser.hs 
@@ -1,37 +0,0 @@-module Parser where--import Control.Applicative hiding (many,(<|>))-import Control.Exception-import qualified Data.ByteString.Lazy.Char8 as BL-import System.IO-import Text.Parsec-import Text.Parsec.ByteString.Lazy--spcs :: Parser ()-spcs = () <$ many spc--spcs1 :: Parser ()-spcs1 = () <$ many1 spc--spc :: Parser Char-spc = satisfy (`elem` " \t")--commentLines :: Parser ()-commentLines = () <$ many commentLine-  where-    commentLine = trailing--trailing :: Parser ()-trailing = () <$ (comment *> newline <|> newline)--comment :: Parser ()-comment = () <$ char '#' <* many (noneOf "\n")--parseFile :: Parser a -> FilePath -> IO a-parseFile p file = do-    hdl <- openFile file ReadMode-    hSetEncoding hdl latin1-    bs <- BL.hGetContents hdl-    case parse p "parseFile" bs of-        Right x -> return x-        Left  e -> throwIO . userError . show $ e
− src/Process.hs 
@@ -1,98 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Process (-    getMightyPid-  , findChildren-  , dummyResult-  , PsResult(..)-  ) where--import Control.Applicative-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as BS-import Data.Conduit-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.List as CL-import Data.Conduit.Process-import Data.Function-import Data.List-import Data.Ord-import System.Posix.Types--------------------------------------------------------------------data PsResult = PsResult {-    uid :: ByteString-  , pid :: ProcessID-  , ppid :: ProcessID-  , command :: ByteString-  } deriving (Eq, Show)--dummyResult :: PsResult-dummyResult = PsResult "" 0 0 ""--toPsResult :: [ByteString] -> PsResult-toPsResult (a:b:c:_:_:_:_:h:_) = PsResult {-    uid     = a-  , pid     = maybe 0 (fromIntegral . fst) $ BS.readInt b-  , ppid    = maybe 0 (fromIntegral . fst) $ BS.readInt c-  , command = h-  }-toPsResult _ = PsResult "unknown" 0 0 "unknown"--------------------------------------------------------------------runPS :: IO [PsResult]-runPS = runResourceT $-       sourceCmd "ps -ef"-    $= CB.lines-    $= CL.map BS.words-    $= CL.map toPsResult-    $= CL.filter mighty-    $$ CL.consume-  where-    commandName = last . split '/' . command-    mighty ps = "mighty" `BS.isInfixOf` name-             && not ("mightyctl" `BS.isInfixOf` name)-        where-          name = commandName ps--------------------------------------------------------------------findParent :: [PsResult] -> [PsResult]-findParent ps = deleteAloneChild $ masters ++ candidates-  where-    iAmMaster p = ppid p == 1-    masters = filter iAmMaster ps-    rest    = filter (not.iAmMaster) ps-    candidates = map head-               $ filter (\xs -> length xs == 1) -- master is alone-               $ groupBy ((==) `on` ppid)-               $ sortBy (comparing ppid) rest---deleteAloneChild :: [PsResult] -> [PsResult]-deleteAloneChild [] = []-deleteAloneChild (p:ps) = p : deleteAloneChild (filter noParent ps)-  where-    parent = pid p-    noParent x = ppid x /= parent--------------------------------------------------------------------getMightyPid :: IO [ProcessID]-getMightyPid = (map pid . findParent) <$> runPS--------------------------------------------------------------------findChildren :: ProcessID -> IO [PsResult]-findChildren parent = filter (\p -> ppid p == parent) <$> runPS--------------------------------------------------------------------split :: Char -> ByteString -> [ByteString]-split _ "" = []-split c s = case BS.break (c==) s of-    ("",r)  -> split c (BS.tail r)-    (s',"") -> [s']-    (s',r)  -> s' : split c (BS.tail r)
− src/Report.hs 
@@ -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
− src/Resource.hs 
@@ -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
− src/Route.hs 
@@ -1,76 +0,0 @@-{-# LANGUAGE OverloadedStrings, TupleSections #-}--module Route (parseRoute) where--import Control.Applicative hiding (many,(<|>))-import Control.Monad-import qualified Data.ByteString.Char8 as BS-import Network.Wai.Application.Classic-import Parser-import Text.Parsec-import Text.Parsec.ByteString.Lazy-import Types--parseRoute :: FilePath -> IO RouteDB-parseRoute = parseFile routeDB--routeDB :: Parser RouteDB-routeDB = commentLines *> many1 block <* eof--block :: Parser Block-block = Block <$> cdomains <*> many croute-  where-    cdomains = domains <* commentLines-    croute   = route   <* commentLines--domains :: Parser [Domain]-domains = open *> doms <* close <* trailing-  where-    open  = () <$ char '[' *> spcs-    close = () <$ char ']' *> spcs-    doms = (domain `sepBy1` sep) <* spcs-    domain = BS.pack <$> many1 (noneOf "[], \t\n")-    sep = () <$ spcs1--data Op = OpFile | OpCGI | OpRevProxy | OpRedirect--route :: Parser Route-route = do-    s <- src-    o <- op-    case o of-        OpFile     -> RouteFile     s <$> dst <* trailing-        OpRedirect -> RouteRedirect s <$> dst' <* trailing-        OpCGI      -> RouteCGI      s <$> dst <* trailing-        OpRevProxy -> do-            (dom,prt,d) <- domPortDst-            return $ RouteRevProxy s d dom prt-  where-    src = path-    dst = path-    dst' = path'-    op0 = OpFile     <$ string "->"-      <|> OpRedirect <$ string "<<"-      <|> OpCGI      <$ string "=>"-      <|> OpRevProxy <$ string ">>"-    op  = op0 <* spcs--path :: Parser Path-path = do-    c <- char '/'-    fromByteString . BS.pack . (c:) <$> many (noneOf "[], \t\n") <* spcs--path' :: Parser Path-path' = fromByteString . BS.pack <$> many (noneOf "[], \t\n") <* spcs---- [host1][:port2]/path2--domPortDst :: Parser (Domain, Port, Dst)-domPortDst = (defaultDomain,,) <$> port <*> path-         <|> try((,,) <$> domain <*> port <*> path)-         <|> (,defaultPort,) <$> domain <*> path-  where-    domain = BS.pack <$> many1 (noneOf ":/[], \t\n")-    port = do-        void $ char ':'-        read <$> many1 (oneOf ['0'..'9'])
+ src/Server.hs view
@@ -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)+  }
− src/Signal.hs 
@@ -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
− src/Single.hs 
@@ -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
− src/State.hs 
@@ -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
− src/Types.hs 
@@ -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
− src/Utils.hs 
@@ -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
+ src/WaiApp.hs view
@@ -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
test/ConfigSpec.hs view
@@ -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}
test/RouteSpec.hs view
@@ -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]
utils/mightyctl.hs view
@@ -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 = [