mighttpd2-2.8.7/0000755000000000000000000000000012177355156011634 5ustar0000000000000000mighttpd2-2.8.7/LICENSE0000644000000000000000000000276512177355156012653 0ustar0000000000000000Copyright (c) 2011, IIJ Innovation Institute Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. mighttpd2-2.8.7/mighttpd2.cabal0000644000000000000000000001142612177355156014526 0ustar0000000000000000Name: mighttpd2 Version: 2.8.7 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE Synopsis: High performance web server on WAI/warp Description: High performance web server to handle static files and CGI on WAI/warp. Reverse proxy functionality is also provided to connect web applications behind. Homepage: http://www.mew.org/~kazu/proj/mighttpd/ Category: Network, Web Cabal-Version: >= 1.8 Build-Type: Simple Data-Dir: conf Data-Files: example.conf example.route Flag rev-proxy Description: Support reverse proxy wish http-conduit. This requires unnecessary crypt libraries. Default: True Flag tls Description: Support http over tls (https). Default: False Executable mighty HS-Source-Dirs: src Main-Is: Mighty.hs GHC-Options: -Wall -threaded -rtsopts if flag(rev-proxy) Cpp-Options: -DREV_PROXY if flag(tls) Cpp-Options: -DTLS Build-Depends: base >= 4.0 && < 5 -- should be removed someday , blaze-html >= 0.5 , bytestring , conduit , date-cache , deepseq , directory , filepath , http-date , http-types , io-choice , 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 if flag(tls) Build-Depends: tls , warp-tls >= 1.4.1 Other-Modules: Config Config.Internal Daemon FileCGIApp FileCache Log Mighty Multi Net Parser Process Report Resource Route Signal Single State Types Utils Paths_mighttpd2 Executable mkindex HS-Source-Dirs: utils, src Main-Is: mkindex.hs GHC-Options: -Wall Build-Depends: base >= 4 && < 5 , unix , old-locale , directory , time Executable mightyctl HS-Source-Dirs: utils, src Main-Is: mightyctl.hs GHC-Options: -Wall Build-Depends: base >= 4 && < 5 , bytestring , conduit , process-conduit , unix Test-Suite spec 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 if flag(tls) Build-Depends: tls , warp-tls >= 1.4.1 Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/mighttpd2.git mighttpd2-2.8.7/Setup.hs0000644000000000000000000000005612177355156013271 0ustar0000000000000000import Distribution.Simple main = defaultMain mighttpd2-2.8.7/conf/0000755000000000000000000000000012177355156012561 5ustar0000000000000000mighttpd2-2.8.7/conf/example.conf0000644000000000000000000000152612177355156015067 0ustar0000000000000000# Example configuration for Mighttpd 2 Port: 80 Debug_Mode: Yes # Yes or No # If available, "nobody" is much more secure for User:. User: root # If available, "nobody" is much more secure for Group:. Group: root Pid_File: /var/run/mighty.pid Logging: Yes # Yes or No Log_File: /var/log/mighty # The directory must be writable by User: Log_File_Size: 16777216 # bytes Log_Backup_Number: 10 Index_File: index.html Index_Cgi: index.cgi Status_File_Dir: /usr/local/share/mighty/status Connection_Timeout: 30 # seconds Fd_Cache_Duration: 10 # seconds # Server_Name: Mighttpd/2.x.y Worker_Processes: 1 Tls_Port: 443 Tls_Cert_File: certificate.pem # should change this with an absolute path # Currently, Tls_Key_file must not be encrypted. Tls_Key_file: key.pem # should change this with an absolute path Service: 0 # 0 is HTTP only, 1 is HTTPS only, 2 is both mighttpd2-2.8.7/conf/example.route0000644000000000000000000000125312177355156015275 0ustar0000000000000000# Example routing for Mighttpd 2 # Domain lists [localhost www.example.com] # Entries are looked up in the specified order # All paths must end with "/" # A path to CGI scripts should be specified with "=>" /~alice/cgi-bin/ => /home/alice/public_html/cgi-bin/ # A path to static files should be specified with "->" /~alice/ -> /home/alice/public_html/ /cgi-bin/ => /export/cgi-bin/ # Reverse proxy rules should be specified with ">>" # /path >> host:port/path2 # Either "host" or ":port" can be committed, but not both. /app/cal/ >> example.net/calendar/ # Yesod app in the same server /app/wiki/ >> 127.0.0.1:3000/ / -> /export/www/ mighttpd2-2.8.7/src/0000755000000000000000000000000012177355156012423 5ustar0000000000000000mighttpd2-2.8.7/src/Config.hs0000644000000000000000000000012512177355156014162 0ustar0000000000000000module Config (Option(..), parseOption, defaultOption) where import Config.Internal mighttpd2-2.8.7/src/Daemon.hs0000644000000000000000000000165012177355156014164 0ustar0000000000000000module 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 mighttpd2-2.8.7/src/FileCache.hs0000644000000000000000000000372012177355156014564 0ustar0000000000000000module FileCache (fileCacheInit) where import Control.Concurrent import Control.Exception import Control.Exception.IOChoice import Control.Monad import Data.ByteString (ByteString) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.IORef import Network.HTTP.Date import Network.Wai.Application.Classic import System.Posix.Files import Utils data Entry = Negative | Positive FileInfo type Cache = HashMap ByteString Entry type GetInfo = Path -> IO FileInfo fileInfo :: IORef Cache -> GetInfo fileInfo ref path = do cache <- readIORef ref case M.lookup bpath cache of Just Negative -> throwIO (userError "fileInfo") Just (Positive x) -> return x Nothing -> register ||> negative ref path where bpath = pathByteString path sfile = pathString path register = do fs <- getFileStatus sfile if not (isDirectory fs) then positive ref fs path else goNext positive :: IORef Cache -> FileStatus -> GetInfo positive ref fs path = do strictAtomicModifyIORef ref $ M.insert bpath entry return info where info = FileInfo { fileInfoName = path , fileInfoSize = size fs , fileInfoTime = time , fileInfoDate = formatHTTPDate time } size = fromIntegral . fileSize time = epochTimeToHTTPDate (modificationTime fs) entry = Positive info bpath = pathByteString path negative :: IORef Cache -> GetInfo negative ref path = do strictAtomicModifyIORef ref $ M.insert bpath Negative throwIO (userError "fileInfo") where bpath = pathByteString path ---------------------------------------------------------------- fileCacheInit :: IO GetInfo fileCacheInit = do ref <- newIORef M.empty void . forkIO $ remover ref return $ fileInfo ref -- atomicModifyIORef is not necessary here. remover :: IORef Cache -> IO () remover ref = forever $ threadDelay 10000000 >> writeIORef ref M.empty mighttpd2-2.8.7/src/FileCGIApp.hs0000644000000000000000000000533312177355156014626 0ustar0000000000000000{-# 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 mighttpd2-2.8.7/src/Log.hs0000644000000000000000000000077012177355156013504 0ustar0000000000000000module 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 mighttpd2-2.8.7/src/Mighty.hs0000644000000000000000000001064212177355156014223 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} module Main where import Control.Concurrent import Control.Monad import Network.Wai.Application.Classic hiding ((), (+++)) import Network.Wai.Logger import Network.Wai.Logger.Prefork import System.Directory import System.Environment import System.Exit import System.FilePath import System.IO import System.Posix import Config import Daemon (background) import Log import Multi import Net (listenSocket) import Report import Resource (amIrootUser, unlimit) import Route import Signal import Single import State import Types ---------------------------------------------------------------- main :: IO () main = do (opt,route) <- getOptRoute checkTLS opt let reportFile = opt_report_file opt rpt <- initReporter reportFile >>= checkReporter reportFile if opt_debug_mode opt then server opt route rpt else background opt $ server opt route rpt where getOptRoute = getArgs >>= eachCase eachCase args | n == 0 = do root <- amIrootUser let opt | root = defaultOption { opt_port = 80 } | otherwise = defaultOption dir <- getCurrentDirectory let dst = fromString . addTrailingPathSeparator $ dir route = [Block ["*"] [RouteFile "/" dst]] return (opt, route) | n == 2 = do let config_file = args !! 0 routing_file <- getAbsoluteFile (args !! 1) opt <- parseOption config_file route <- parseRoute routing_file let opt' = opt {opt_routing_file = Just routing_file} return (opt',route) | otherwise = do hPutStrLn stderr "Usage: mighty" hPutStrLn stderr " mighty config_file routing_file" exitFailure where n = length args getAbsoluteFile file | isAbsolute file = return file | otherwise = do dir <- getCurrentDirectory return $ dir normalise file checkReporter _ (Right rpt) = return rpt checkReporter reportFile (Left e) = do hPutStrLn stderr $ reportFile ++ " is not writable" hPrint stderr e exitFailure #ifdef TLS checkTLS _ = return () #else checkTLS opt = when (opt_service opt > 1) $ do hPutStrLn stderr "This mighty does not support TLS" exitFailure #endif ---------------------------------------------------------------- server :: Option -> RouteDB -> Reporter -> IO () server opt route rpt = reportDo rpt $ do unlimit service <- openService opt unless debug writePidFile logCheck logtype myid <- getProcessID stt <- initStater if workers == 1 then do lgr <- initLogger FromSocket logtype -- killed by signal void . forkIO $ single opt route service rpt stt lgr void . forkIO $ logController logtype [myid] mainLoop rpt stt lgr else do cids <- multi opt route service logtype stt rpt void . forkIO $ logController logtype cids masterMainLoop rpt myid where debug = opt_debug_mode opt pidfile = opt_pid_file opt workers = opt_worker_processes opt writePidFile = do pid <- getProcessID writeFile pidfile $ show pid ++ "\n" setFileMode pidfile 0o644 logspec = FileLogSpec { log_file = opt_log_file opt , log_file_size = fromIntegral $ opt_log_file_size opt , log_backup_number = opt_log_backup_number opt } logtype | not (opt_logging opt) = LogNone | debug = LogStdout | otherwise = LogFile logspec sigLogCtl openService :: Option -> IO Service openService opt | service == 1 = do s <- listenSocket httpsPort debugMessage $ "HTTP/TLS service on port " ++ httpsPort ++ "." return $ HttpsOnly s | service == 2 = do s1 <- listenSocket httpPort s2 <- listenSocket httpsPort debugMessage $ "HTTP service on port " ++ httpPort ++ " and " ++ "HTTP/TLS service on port " ++ httpsPort ++ "." return $ HttpAndHttps s1 s2 | otherwise = do s <- listenSocket httpPort debugMessage $ "HTTP service on port " ++ httpPort ++ "." return $ HttpOnly s where httpPort = show $ opt_port opt httpsPort = show $ opt_tls_port opt service = opt_service opt debug = opt_debug_mode opt debugMessage msg = when debug $ do putStrLn msg hFlush stdout mighttpd2-2.8.7/src/Multi.hs0000644000000000000000000000446212177355156014057 0ustar0000000000000000{-# 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] mighttpd2-2.8.7/src/Net.hs0000644000000000000000000000167012177355156013511 0ustar0000000000000000module Net (listenSocket) where import Control.Exception import Network import Network.BSD import Network.Socket listenSocket :: String -> IO Socket listenSocket serv = do proto <- getProtocolNumber "tcp" let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_PASSIVE] , addrSocketType = Stream , addrProtocol = proto } addrs <- getAddrInfo (Just hints) Nothing (Just serv) let addrs' = filter (\x -> addrFamily x == AF_INET6) addrs addr = head $ if null addrs' then addrs else addrs' listenSocket' addr listenSocket' :: AddrInfo -> IO Socket listenSocket' addr = bracketOnError setup cleanup $ \sock -> do setSocketOption sock ReuseAddr 1 setSocketOption sock NoDelay 1 bindSocket sock (addrAddress addr) listen sock 2048 return sock where setup = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) cleanup = sClose mighttpd2-2.8.7/src/Parser.hs0000644000000000000000000000153412177355156014216 0ustar0000000000000000module 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 mighttpd2-2.8.7/src/Process.hs0000644000000000000000000000517712177355156014407 0ustar0000000000000000{-# 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) mighttpd2-2.8.7/src/Report.hs0000644000000000000000000000374212177355156014240 0ustar0000000000000000{-# 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 mighttpd2-2.8.7/src/Resource.hs0000644000000000000000000000166612177355156014557 0ustar0000000000000000module 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 mighttpd2-2.8.7/src/Route.hs0000644000000000000000000000403612177355156014060 0ustar0000000000000000{-# 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']) mighttpd2-2.8.7/src/Signal.hs0000644000000000000000000000132212177355156014172 0ustar0000000000000000module 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 mighttpd2-2.8.7/src/Single.hs0000644000000000000000000001310612177355156014201 0ustar0000000000000000{-# 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 mighttpd2-2.8.7/src/State.hs0000644000000000000000000000541712177355156014046 0ustar0000000000000000module 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 mighttpd2-2.8.7/src/Types.hs0000644000000000000000000000157712177355156014075 0ustar0000000000000000{-# 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 mighttpd2-2.8.7/src/Utils.hs0000644000000000000000000000150312177355156014056 0ustar0000000000000000{-# 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 mighttpd2-2.8.7/src/Config/0000755000000000000000000000000012177355156013630 5ustar0000000000000000mighttpd2-2.8.7/src/Config/Internal.hs0000644000000000000000000001147612177355156015751 0ustar0000000000000000{-# 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") mighttpd2-2.8.7/test/0000755000000000000000000000000012177355156012613 5ustar0000000000000000mighttpd2-2.8.7/test/ConfigSpec.hs0000644000000000000000000000163712177355156015176 0ustar0000000000000000module ConfigSpec where import Config.Internal import Test.Hspec spec :: Spec spec = do describe "parseConfig" $ do it "parses example.conf correctly" $ do res <- parseConfig "conf/example.conf" res `shouldBe` ans ans :: [(String, ConfValue)] ans = [("Port",CV_Int 80),("Debug_Mode",CV_Bool True),("User",CV_String "root"),("Group",CV_String "root"),("Pid_File",CV_String "/var/run/mighty.pid"),("Logging",CV_Bool True),("Log_File",CV_String "/var/log/mighty"),("Log_File_Size",CV_Int 16777216),("Log_Backup_Number",CV_Int 10),("Index_File",CV_String "index.html"),("Index_Cgi",CV_String "index.cgi"),("Status_File_Dir",CV_String "/usr/local/share/mighty/status"),("Connection_Timeout",CV_Int 30),("Fd_Cache_Duration",CV_Int 10),("Worker_Processes",CV_Int 1),("Tls_Port",CV_Int 443),("Tls_Cert_File",CV_String "certificate.pem"),("Tls_Key_file",CV_String "key.pem"),("Service",CV_Int 0)] mighttpd2-2.8.7/test/RouteSpec.hs0000644000000000000000000000117612177355156015065 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module RouteSpec where import Route import Test.Hspec import Types spec :: Spec spec = do describe "parseRoute" $ do it "parses example.route correctly" $ do res <- parseRoute "conf/example.route" res `shouldBe` ans ans :: [Block] ans = [Block ["localhost","www.example.com"] [RouteCGI "/~alice/cgi-bin/" "/home/alice/public_html/cgi-bin/",RouteFile "/~alice/" "/home/alice/public_html/",RouteCGI "/cgi-bin/" "/export/cgi-bin/",RouteRevProxy "/app/cal/" "/calendar/" "example.net" 80,RouteRevProxy "/app/wiki/" "/" "127.0.0.1" 3000,RouteFile "/" "/export/www/"]] mighttpd2-2.8.7/test/Spec.hs0000644000000000000000000000005412177355156014040 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} mighttpd2-2.8.7/utils/0000755000000000000000000000000012177355156012774 5ustar0000000000000000mighttpd2-2.8.7/utils/mightyctl.hs0000644000000000000000000000314112177355156015333 0ustar0000000000000000module Main where import Data.List import System.Environment import System.Exit import System.Posix.Signals import System.Posix.Types import Process (getMightyPid) import Signal commandDB :: [(String, Signal)] commandDB = [ ("stop", sigStop) , ("reload", sigReload) , ("retire", sigRetire) , ("info", sigInfo) ] usage :: IO a usage = do putStrLn "Usage:" putStrLn $ " mightyctl " ++ cmds ++ " [pid]" exitFailure where cmds = intercalate "|" $ map fst commandDB main :: IO () main = do (sig,mpid) <- getArgs >>= checkArgs pid <- maybe getProcessIdWithPS return mpid signalProcess sig pid checkArgs :: [String] -> IO (Signal, Maybe ProcessID) checkArgs [cmd] = do sig <- getSignal cmd return (sig, Nothing) checkArgs [cmd,num] = do sig <- getSignal cmd pid <- getProcessId num return (sig, Just pid) checkArgs _ = usage getSignal :: String -> IO Signal getSignal cmd = check $ lookup cmd commandDB where check (Just sig) = return sig check Nothing = do putStrLn $ "No such command: " ++ cmd usage getProcessId :: String -> IO ProcessID getProcessId num = check $ reads num where check [(pid,"")] = return . fromIntegral $ (pid :: Int) check _ = do putStrLn $ "No such process id: " ++ num usage getProcessIdWithPS :: IO ProcessID getProcessIdWithPS = getMightyPid >>= check where check [] = putStrLn "No Mighty found" >> usage check [pid] = return pid check pids = do putStrLn $ "Multiple Mighty found: " ++ intercalate ", " (map show pids) usage mighttpd2-2.8.7/utils/mkindex.hs0000644000000000000000000000462212177355156014773 0ustar0000000000000000{- mkindex :: Making index.html for the current directory. -} import Control.Applicative import Data.Bits import Data.Time import Data.Time.Clock.POSIX import System.Directory import System.Locale import System.Posix.Files import Text.Printf indexFile :: String indexFile = "index.html" main :: IO () main = do contents <- mkContents writeFile indexFile $ header ++ contents ++ tailer setFileMode indexFile mode where mode = ownerReadMode .|. ownerWriteMode .|. groupReadMode .|. otherReadMode mkContents :: IO String mkContents = do fileNames <- filter dotAndIndex <$> getDirectoryContents "." stats <- mapM getFileStatus fileNames let fmsls = zipWith pp fileNames stats maxLen = maximum $ map (\(_,_,_,x) -> x) fmsls contents = concatMap (content maxLen) fmsls return contents where dotAndIndex x = head x /= '.' && x /= indexFile pp :: String -> FileStatus -> (String,String,String,Int) pp f st = (file,mtime,size,flen) where file = ppFile f st flen = length file mtime = ppMtime st size = ppSize st ppFile :: String -> FileStatus -> String ppFile f st | isDirectory st = f ++ "/" | otherwise = f ppMtime :: FileStatus -> String ppMtime st = dateFormat . epochTimeToUTCTime $ st where epochTimeToUTCTime = posixSecondsToUTCTime . realToFrac . modificationTime dateFormat = formatTime defaultTimeLocale "%d-%b-%Y %H:%M" ppSize :: FileStatus -> String ppSize st | isDirectory st = " - " | otherwise = sizeFormat . fromIntegral . fileSize $ st where sizeFormat siz = unit siz " KMGT" unit _ [] = error "unit" unit s [u] = format s u unit s (u:us) | s >= 1024 = unit (s `div` 1024) us | otherwise = format s u format :: Integer -> Char -> String format = printf "%3d%c" header :: String header = "\ \\n\ \\n\ \\n\ \\n\ \Directory contents\n\ \\n\ \

Directory contents

\n\ \
\n\ \
\n"

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

tailer :: String
tailer = "\
\
\n\ \
\n\ \\n\ \\n"