mighttpd2-4.0.3/0000755000000000000000000000000007346545000011611 5ustar0000000000000000mighttpd2-4.0.3/LICENSE0000644000000000000000000000276507346545000012630 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-4.0.3/Program/0000755000000000000000000000000007346545000013220 5ustar0000000000000000mighttpd2-4.0.3/Program/Mighty.hs0000644000000000000000000000135107346545000015015 0ustar0000000000000000-- | Special library for Mighty. module Program.Mighty ( -- * Parsers module Program.Mighty.Config , module Program.Mighty.Route , module Program.Mighty.Parser -- * State , module Program.Mighty.Report -- * Utilities , module Program.Mighty.ByteString , module Program.Mighty.Network , module Program.Mighty.Process , module Program.Mighty.Resource , module Program.Mighty.Signal , module Program.Mighty.Types ) where import Program.Mighty.ByteString import Program.Mighty.Config 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.Types mighttpd2-4.0.3/Program/Mighty/0000755000000000000000000000000007346545000014461 5ustar0000000000000000mighttpd2-4.0.3/Program/Mighty/ByteString.hs0000644000000000000000000000052607346545000017112 0ustar0000000000000000module 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 mighttpd2-4.0.3/Program/Mighty/Config.hs0000644000000000000000000001763307346545000016234 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Program.Mighty.Config ( -- * Parsing a configuration file. parseOption #ifdef DHALL , parseOptionDhall #else , Natural #endif -- * Creating 'Option'. , defaultOption -- * Types , Option(..) ) where import Data.List.Split (splitOn) import Text.Parsec import Text.Parsec.ByteString.Lazy #ifdef DHALL import Data.String (fromString) import qualified Data.Text as T import Dhall(Generic, Natural, input, auto, FromDhall) import qualified Program.Mighty.Dhall.Option as Do #else import Program.Mighty.Types #endif import Program.Mighty.Parser ---------------------------------------------------------------- data Option = Option { opt_port :: Natural , opt_host :: String , opt_debug_mode :: Bool , opt_user :: String , opt_group :: String , opt_pid_file :: FilePath , opt_report_file :: FilePath , opt_logging :: Bool , opt_log_file :: FilePath , opt_log_file_size :: Natural , opt_log_backup_number :: Natural , opt_index_file :: FilePath , opt_index_cgi :: FilePath , opt_status_file_dir :: FilePath , opt_connection_timeout :: Natural , opt_proxy_timeout :: Natural , opt_fd_cache_duration :: Natural , opt_service :: Natural , opt_tls_port :: Natural , opt_tls_cert_file :: FilePath , opt_tls_chain_files :: FilePath , opt_tls_key_file :: FilePath , opt_quic_port :: Natural , opt_quic_addr :: [String] , opt_quic_debug_dir :: Maybe FilePath , opt_quic_qlog_dir :: Maybe FilePath , opt_server_name :: String , opt_routing_file :: Maybe String #ifdef DHALL } deriving (Eq, Show, Generic) #else } deriving (Eq, Show) #endif #ifdef DHALL instance FromDhall Option #endif -- | Getting a default 'Option'. defaultOption :: Option defaultOption = Option { opt_port = 8080 , opt_host = "*" , opt_debug_mode = True , opt_user = "root" , opt_group = "root" , opt_pid_file = "/var/run/mighty.pid" , opt_report_file = "/tmp/mighty_report" , 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_service = 0 , opt_tls_port = 443 , opt_tls_cert_file = "cert.pem" , opt_tls_chain_files = "chain.pem" , opt_tls_key_file = "privkey.pem" , opt_quic_port = 443 , opt_quic_addr = ["127.0.0.1"] , opt_quic_debug_dir = Nothing , opt_quic_qlog_dir = Nothing , opt_server_name = "Dummy" , opt_routing_file = Nothing } ---------------------------------------------------------------- -- | Parsing a configuration file to get an 'Option'. parseOption :: FilePath -> IO Option parseOption file = makeOpt defaultOption <$> parseConfig file #ifdef DHALL parseOptionDhall :: FilePath -> IO Option parseOptionDhall = fmap optionFromDhall . input auto . fromString optionFromDhall :: Do.Option -> Option optionFromDhall o = Option { opt_port = Do.port o , opt_host = T.unpack $ Do.host o , opt_debug_mode = Do.debugMode o , opt_user = T.unpack $ Do.user o , opt_group = T.unpack $ Do.group o , opt_pid_file = T.unpack $ Do.pidFile o , opt_report_file = T.unpack $ Do.reportFile o , opt_logging = Do.logging o , opt_log_file = T.unpack $ Do.logFile o , opt_log_file_size = Do.logFileSize o , opt_log_backup_number = Do.logBackupNumber o , opt_index_file = T.unpack $ Do.indexFile o , opt_index_cgi = T.unpack $ Do.indexCgi o , opt_status_file_dir = T.unpack $ Do.statusFileDir o , opt_connection_timeout = Do.connectionTimeout o , opt_proxy_timeout = Do.proxyTimeout o , opt_fd_cache_duration = Do.fdCacheDuration o , opt_service = Do.service o , opt_tls_port = Do.tlsPort o , opt_tls_cert_file = T.unpack $ Do.tlsCertFile o , opt_tls_chain_files = T.unpack $ Do.tlsChainFiles o , opt_tls_key_file = T.unpack $ Do.tlsKeyFile o , opt_quic_addr = T.unpack <$> Do.quicAddr o , opt_quic_port = Do.quicPort o , opt_quic_debug_dir = T.unpack <$> Do.quicDebugDir o , opt_quic_qlog_dir = T.unpack <$> Do.quicQlogDir o , opt_server_name = "Dummy" , opt_routing_file = Nothing } #endif ---------------------------------------------------------------- makeOpt :: Option -> [Conf] -> Option makeOpt def conf = Option { opt_port = get "Port" opt_port , opt_host = get "Host" opt_host , 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_report_file = get "Report_File" opt_report_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_service = get "Service" opt_service , opt_tls_port = get "Tls_Port" opt_tls_port , opt_tls_cert_file = get "Tls_Cert_File" opt_tls_cert_file , opt_tls_chain_files = get "Tls_Chain_Files" opt_tls_chain_files , opt_tls_key_file = get "Tls_Key_File" opt_tls_key_file , opt_quic_addr = get "Quic_Addr" opt_quic_addr , opt_quic_port = get "Quic_Port" opt_quic_port , opt_quic_debug_dir = get "Quic_Debug_Dir" opt_quic_debug_dir , opt_quic_qlog_dir = get "Quic_Qlog_Dir" opt_quic_qlog_dir , opt_server_name = "Dummy" , opt_routing_file = Nothing } where get k func = maybe (func def) fromConf $ lookup k conf ---------------------------------------------------------------- type Conf = (String, ConfValue) data ConfValue = CV_Natural Natural | CV_Bool Bool | CV_String String deriving (Eq,Show) class FromConf a where fromConf :: ConfValue -> a instance FromConf Natural where fromConf (CV_Natural 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" instance FromConf (Maybe String) where fromConf (CV_String "") = Nothing fromConf (CV_String s) = Just s fromConf _ = error "fromConf string" instance FromConf [String] where fromConf (CV_String s) = splitOn "," 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) 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_natural, try cv_bool, cv_string] -- Trailing should be included in try to allow IP addresses. cv_natural :: Parser ConfValue cv_natural = CV_Natural . read <$> many1 digit <* trailing cv_bool :: Parser ConfValue cv_bool = CV_Bool True <$ string "Yes" <* trailing <|> CV_Bool False <$ string "No" <* trailing cv_string :: Parser ConfValue cv_string = CV_String <$> many (noneOf " \t\n") <* trailing mighttpd2-4.0.3/Program/Mighty/Dhall/0000755000000000000000000000000007346545000015505 5ustar0000000000000000mighttpd2-4.0.3/Program/Mighty/Dhall/Option.dhall0000644000000000000000000000107507346545000017766 0ustar0000000000000000{ port : Natural , host : Text , debugMode : Bool , user : Text , group : Text , pidFile : Text , reportFile : Text , logging : Bool , logFile : Text , logFileSize : Natural , logBackupNumber : Natural , indexFile : Text , indexCgi : Text , statusFileDir : Text , connectionTimeout : Natural , proxyTimeout : Natural , fdCacheDuration : Natural , service : Natural , tlsPort : Natural , tlsCertFile : Text , tlsChainFiles : Text , tlsKeyFile : Text , quicPort : Natural , quicAddr : List Text , quicDebugDir : Optional Text , quicQlogDir : Optional Text }mighttpd2-4.0.3/Program/Mighty/Dhall/Option.hs0000644000000000000000000000063407346545000017314 0ustar0000000000000000{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} module Program.Mighty.Dhall.Option where #ifdef DHALL import Dhall.TH Dhall.TH.makeHaskellTypes [ SingleConstructor "Option" "MakeOption" "./Program/Mighty/Dhall/Option.dhall" ] #endif mighttpd2-4.0.3/Program/Mighty/Network.hs0000644000000000000000000000122407346545000016445 0ustar0000000000000000module Program.Mighty.Network ( daemonize ) where import Control.Monad import System.Exit import System.Posix -- | 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 mighttpd2-4.0.3/Program/Mighty/Parser.hs0000644000000000000000000000377307346545000016263 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Parsers for Mighty module Program.Mighty.Parser ( -- * Utilities parseFile -- * Parsers , spcs , spcs1 , spc , commentLines , trailing , comment ) where import qualified Data.ByteString.Lazy.Char8 as BL import System.IO import Text.Parsec import Text.Parsec.ByteString.Lazy import UnliftIO.Exception -- $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 = () <$ (spcs *> comment *> newline <|> spcs *> newline) -- | 'Parser' to consume a trailing comment -- -- >>> parse comment "" "# comments" -- Right () -- >>> isLeft $ parse comment "" "foo" -- True comment :: Parser () comment = () <$ char '#' <* many (noneOf "\n") mighttpd2-4.0.3/Program/Mighty/Process.hs0000644000000000000000000000476207346545000016444 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Program.Mighty.Process ( getMightyPid ) where import Control.Monad.Trans.Resource (runResourceT) 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 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 = snd <$> runResourceT (sourceCmdWithConsumer "ps -ef" consumer) where consumer = CB.lines .| CL.map BS.words .| CL.map toPsResult .| CL.filter mighty .| CL.consume 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) $ sortOn 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) mighttpd2-4.0.3/Program/Mighty/Report.hs0000644000000000000000000000407607346545000016277 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Program.Mighty.Report ( Reporter , initReporter , report , reportDo , warpHandler , printStdout ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif 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 UnliftIO.Exception import Program.Mighty.ByteString data Method = FileOnly | FileAndStdout deriving Eq data Reporter = Reporter Method FilePath initReporter :: Bool -> FilePath -> Reporter initReporter debug reportFile = Reporter method reportFile where method | debug = FileAndStdout | otherwise = FileOnly report :: Reporter -> ByteString -> IO () report (Reporter method reportFile) 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.appendFile reportFile logmsg when (method == FileAndStdout) $ BS.putStr logmsg ---------------------------------------------------------------- reportDo :: Reporter -> IO () -> IO () reportDo rpt act = act `catchAny` warpHandler rpt Nothing ---------------------------------------------------------------- warpHandler :: Reporter -> Maybe Request -> SomeException -> IO () warpHandler rpt _ se | Just (_ :: InvalidRequest) <- fromException se = return () | Just (e :: IOException) <- fromException se = if ioeGetErrorType e `elem` [ResourceVanished,InvalidArgument] then return () else report rpt $ bshow se | otherwise = report rpt $ bshow se ---------------------------------------------------------------- printStdout :: Maybe Request -> SomeException -> IO () printStdout _ x = print x >> hFlush stdout mighttpd2-4.0.3/Program/Mighty/Resource.hs0000644000000000000000000000232707346545000016610 0ustar0000000000000000{-# LANGUAGE CPP #-} module Program.Mighty.Resource ( amIrootUser , setGroupUser , unlimit ) where import System.Posix import UnliftIO.Exception ---------------------------------------------------------------- -- | Checking if this process has the root privilege. amIrootUser :: IO Bool amIrootUser = (== 0) <$> getRealUserID ---------------------------------------------------------------- -- | Setting user and group. setGroupUser :: String -- ^ User -> String -- ^ Group -> IO Bool setGroupUser user group = do root <- amIrootUser if root then do getGroupEntryForName group >>= setGroupID . groupID getUserEntryForName user >>= setUserID . userID return True else return False ---------------------------------------------------------------- -- | 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 mighttpd2-4.0.3/Program/Mighty/Route.hs0000644000000000000000000000724707346545000016125 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} module Program.Mighty.Route ( -- * Paring a routing file parseRoute -- * Types , RouteDB , Route(..) , Block(..) , Src , Dst , Domain , Port -- * RouteDBRef , RouteDBRef , newRouteDBRef , readRouteDBRef , writeRouteDBRef ) where import Control.Monad import Data.ByteString import qualified Data.ByteString.Char8 as BS import Data.IORef #ifdef DHALL import GHC.Natural (Natural) #endif 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 #ifdef DHALL type Port = Natural #else type Port = Int #endif 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 '/' BS.pack . (c:) <$> many (noneOf "[], \t\n") <* spcs path' :: Parser Path path' = 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']) ---------------------------------------------------------------- newtype RouteDBRef = RouteDBRef (IORef RouteDB) newRouteDBRef :: RouteDB -> IO RouteDBRef newRouteDBRef rout = RouteDBRef <$> newIORef rout readRouteDBRef :: RouteDBRef -> IO RouteDB readRouteDBRef (RouteDBRef ref) = readIORef ref writeRouteDBRef :: RouteDBRef -> RouteDB -> IO () writeRouteDBRef (RouteDBRef ref) rout = writeIORef ref rout mighttpd2-4.0.3/Program/Mighty/Signal.hs0000644000000000000000000000147607346545000016242 0ustar0000000000000000module 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 mighttpd2-4.0.3/Program/Mighty/Types.hs0000644000000000000000000000045007346545000016120 0ustar0000000000000000{-# LANGUAGE CPP #-} module Program.Mighty.Types (Natural, naturalToInt) where #ifdef DHALL import GHC.Natural (Natural, naturalToWord) naturalToInt :: Natural -> Int naturalToInt = fromIntegral . naturalToWord #else type Natural = Int naturalToInt :: Natural -> Int naturalToInt = id #endif mighttpd2-4.0.3/Setup.hs0000644000000000000000000000005607346545000013246 0ustar0000000000000000import Distribution.Simple main = defaultMain mighttpd2-4.0.3/cbits/0000755000000000000000000000000007346545000012715 5ustar0000000000000000mighttpd2-4.0.3/cbits/setcap.c0000644000000000000000000000214107346545000014336 0ustar0000000000000000#if defined(__linux__) #include #include #include #include #include #include #include #include #include #include "Rts.h" void set_capabilities (uint32_t cap) { cap_user_header_t header = malloc(sizeof(*header)); header->version = _LINUX_CAPABILITY_VERSION_3; header->pid = 0; cap_user_data_t data = malloc(sizeof(*data)); data->effective = cap; data->permitted = cap; data->inheritable = 0; capset(header,data); free(header); free(data); } void handler(int signum) { uint32_t cap = 1 << CAP_NET_BIND_SERVICE; set_capabilities (cap); } void FlagDefaultsHook () { if (geteuid() == 0) { prctl(PR_SET_SECUREBITS, SECBIT_KEEP_CAPS, 0L, 0L, 0L); struct sigaction sa; memset(&sa, 0, sizeof(sa)); sa.sa_handler = handler; sa.sa_flags = SA_RESTART; sigaction(SIGUSR1, &sa, NULL); } } void send_signal (int tid, int sig) { int tgid = getpid(); syscall(SYS_tgkill, tgid, tid, sig); } #else void send_signal (int tid, int sig) {} #endif mighttpd2-4.0.3/conf/0000755000000000000000000000000007346545000012536 5ustar0000000000000000mighttpd2-4.0.3/conf/example.conf0000644000000000000000000000225007346545000015037 0ustar0000000000000000# Example configuration for Mighttpd 2 Port: 80 # IP address or "*" Host: * 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 Report_File: /tmp/mighty_report Logging: Yes # Yes or No # The directory must be writable by User: Log_File: /var/log/mighty 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 Proxy_Timeout: 0 # seconds, 0 is default of http-client, ie 30 seconds Fd_Cache_Duration: 10 # seconds # 0 is HTTP only # 1 is HTTPS only # 2 is for both HTTP and HTTPs # 3 is for HTTP, HTTPs and QUIC(HTTP/3) Service: 0 Tls_Port: 443 # should change this with an absolute path Tls_Cert_File: cert.pem # should change this with comma-separated absolute paths Tls_Chain_Files: chain.pem # Currently, Tls_Key_File must not be encrypted Tls_Key_File: privkey.pem # should change this with an absolute path Quic_Addr: 0.0.0.0,:: Quic_Port: 443 #Quic_Debug_Dir: /var/log/mighy/quic-debug/ #Quic_Qlog_Dir: /varlog/mighty/qlog/ mighttpd2-4.0.3/conf/example.dhall0000644000000000000000000000342207346545000015200 0ustar0000000000000000-- { port : Natural -- , host : Text -- , debugMode : Bool -- , user : Text -- , group : Text -- , pidFile : Text -- , reportFile : Text -- , logging : Bool -- , logFile : Text -- , logFileSize : Natural -- , logBackupNumber : Natural -- , indexFile : Text -- , indexCgi : Text -- , statusFileDir : Text -- , connectionTimeout : Natural -- , proxyTimeout : Natural -- , fdCacheDuration : Natural -- , service : Natural -- , tlsPort : Natural -- , tlsCertFile : Text -- , tlsChainFiles : Text -- , tlsKeyFile : Text -- , quicAddr : List Text -- , quicPort : Natural -- , quicDebugDir : Optional Text -- , quicQlogDir : Optional Text -- } { port = 80 -- IP address or "*" , host = "*" , debugMode = True -- If available, "nobody" is much more secure for user , user = "root" -- If available, "nobody" is much more secure for group , group = "root" , pidFile = "/var/run/mighty.pid" , reportFile = "/tmp/mighty_report" , logging = True -- The directory must be writable by the user. , logFile = "/var/log/mighty" , logFileSize = 16777216 -- bytes , logBackupNumber = 10 , indexFile = "index.html" , indexCgi = "index.cgi" , statusFileDir = "/usr/local/share/mighty/status" , connectionTimeout = 30 -- seconds , proxyTimeout = 0 -- seconds, 0 is default of http-client, ie 30 seconds , fdCacheDuration = 10 -- seconds -- 0 is HTTP only -- 1 is HTTPS only -- 2 is for both HTTP and HTTPs -- 3 is for HTTP, HTTPs and QUIC(HTTP/3) , service = 0 , tlsPort = 443 -- should change this with an absolute path , tlsCertFile = "cert.pem" -- should change this with an absolute path , tlsChainFiles = "chain.pem" -- Currently, tlsKeyFile must not be encrypted , tlsKeyFile = "privkey.pem" , quicPort = 443 , quicAddr = ["0.0.0.0","::"] , quicDebugDir = None Text , quicQlogDir = None Text } mighttpd2-4.0.3/conf/example.route0000644000000000000000000000125307346545000015252 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-4.0.3/mighttpd2.cabal0000644000000000000000000001124407346545000014501 0ustar0000000000000000cabal-version: >=1.10 name: mighttpd2 version: 4.0.3 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto author: Kazu Yamamoto homepage: https://kazu-yamamoto.github.io/mighttpd2/ 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. category: Network, Web build-type: Simple data-files: example.conf example.route data-dir: conf extra-source-files: Program/Mighty/Dhall/Option.dhall conf/example.dhall source-repository head type: git location: git://github.com/kazu-yamamoto/mighttpd2.git flag tls description: Support HTTP over TLS (HTTPS). default: False flag quic description: Support HTTP over QUIC (HTTP/3). default: False flag dhall description: Support Dhall default: False library exposed-modules: Program.Mighty Program.Mighty.ByteString Program.Mighty.Config Program.Mighty.Network Program.Mighty.Parser Program.Mighty.Process Program.Mighty.Report Program.Mighty.Resource Program.Mighty.Route Program.Mighty.Signal Program.Mighty.Dhall.Option Program.Mighty.Types default-language: Haskell2010 ghc-options: -Wall build-depends: base >=4.9 && <5, array, async, auto-update, byteorder, bytestring, case-insensitive, conduit >=1.1, conduit-extra, directory, filepath, http-date, http-types, network, parsec >=3, resourcet, streaming-commons, split, text, unix, unix-time, unordered-containers, wai >=3.2 && <3.3, wai-app-file-cgi >=3.1.9 && <3.2, warp >=3.3.15 && <3.4, unliftio if impl(ghc >=8) default-extensions: Strict StrictData if flag(dhall) cpp-options: -DDHALL build-depends: dhall executable mighty main-is: Mighty.hs hs-source-dirs: src other-modules: Server WaiApp Paths_mighttpd2 default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts build-depends: base >=4.9 && <5, bytestring, directory, filepath, http-client >=0.5, http-date, http-types, mighttpd2, network, conduit-extra, transformers, unix, streaming-commons, time-manager, wai >=3.2 && <3.3, wai-app-file-cgi >=3.1.9 && <3.2, wai-logger >=2.3.0, warp >=3.3.13 && <3.4 if flag(tls) cpp-options: -DHTTP_OVER_TLS build-depends: async, tls-session-manager >=0.0.2.0 if flag(quic) cpp-options: -DHTTP_OVER_QUIC build-depends: async, base16-bytestring if os(linux) cpp-options: -DDROP_EXCEPT_BIND c-sources: cbits/setcap.c if flag(dhall) cpp-options: -DDHALL build-depends: dhall if flag(tls) build-depends: tls, warp-tls >=3.2.12 && <3.5 if flag(quic) build-depends: quic, warp-quic if impl(ghc >=8) default-extensions: Strict StrictData executable mighty-mkindex main-is: mkindex.hs hs-source-dirs: utils src default-language: Haskell2010 ghc-options: -Wall build-depends: base >=4.9 && <5, directory, old-locale, time, unix executable mightyctl main-is: mightyctl.hs hs-source-dirs: utils src default-language: Haskell2010 ghc-options: -Wall build-depends: base >=4.9 && <5, unix, mighttpd2 if impl(ghc >=8) default-extensions: Strict StrictData test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test src other-modules: ConfigSpec RouteSpec default-language: Haskell2010 build-depends: base >=4.9 && <5, hspec >=1.3, mighttpd2, http-client >=0.5 if flag(tls) build-depends: tls, warp-tls >=3.2.12 && <3.5 if impl(ghc >=8) default-extensions: Strict StrictData if flag(dhall) cpp-options: -DDHALL build-depends: dhall mighttpd2-4.0.3/src/0000755000000000000000000000000007346545000012400 5ustar0000000000000000mighttpd2-4.0.3/src/Mighty.hs0000644000000000000000000000662307346545000014204 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main where #ifndef HTTP_OVER_QUIC import Control.Monad (when) #endif #ifdef DHALL import Data.List (isSuffixOf) #endif import Data.Version (showVersion) import Network.Wai.Application.Classic hiding (()) import System.Directory (getCurrentDirectory) import System.Environment (getArgs) import System.Exit (exitFailure) import System.FilePath (addTrailingPathSeparator, isAbsolute, normalise, ()) import System.IO 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 debug = opt_debug_mode opt rpt = initReporter debug reportFile 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 opt0 = defaultOption { opt_server_name = svrnm } let opt | root = opt0 { opt_port = 80 } | otherwise = opt0 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) #ifdef DHALL let isDhall = ".dhall" `Data.List.isSuffixOf` config_file opt <- if isDhall then parseOptionDhall config_file else parseOption config_file #else opt <- parseOption config_file #endif route <- parseRoute routing_file defaultDomain defaultPort let opt' = opt { opt_routing_file = Just routing_file , opt_server_name = svrnm } 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 #ifdef HTTP_OVER_TLS #ifdef HTTP_OVER_QUIC checkTLS _ = return () #else checkTLS opt = when (opt_service opt > 2) $ do hPutStrLn stderr "This mighty does not support QUIC" exitFailure #endif #else checkTLS opt = when (opt_service opt > 1) $ do hPutStrLn stderr "This mighty does not support TLS" exitFailure #endif ---------------------------------------------------------------- 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 port = opt_port opt reportFileName :: Option -> FilePath reportFileName opt | port == 80 = rfile | otherwise = rfile ++ show port where rfile = opt_report_file opt port = opt_port opt mighttpd2-4.0.3/src/Server.hs0000644000000000000000000003041307346545000014203 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} module Server (server, defaultDomain, defaultPort) where import Control.Concurrent (runInUnboundThread) import Control.Exception (try) import Control.Monad (unless, when) import Data.Either (fromRight) import qualified Data.ByteString.Char8 as BS import Data.Streaming.Network (bindPortTCP) import qualified Network.HTTP.Client as H import Network.Socket (Socket, close) import Network.Wai.Application.Classic hiding (()) import Network.Wai.Handler.Warp import Network.Wai.Logger 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 qualified System.TimeManager as T import Program.Mighty import WaiApp #ifdef HTTP_OVER_TLS import Control.Concurrent.Async (concurrently_) import Data.Char (isSpace) import Data.List (dropWhileEnd) import Network.TLS (Credentials(..),SessionManager) import qualified Network.TLS as TLS import Network.TLS.SessionManager import qualified Network.TLS.SessionManager as SM import Network.Wai.Handler.WarpTLS #ifdef HTTP_OVER_QUIC import Control.Concurrent.Async (mapConcurrently_) import Data.Bits import Data.ByteString (ByteString) import Data.List (find) import Data.Maybe (fromJust) import qualified Network.QUIC.Internal as Q import Network.Wai.Handler.WarpQUIC #ifdef DROP_EXCEPT_BIND import Control.Monad (forM_) import Foreign.C.Types (CInt(..)) import System.Directory (listDirectory) import System.Posix.Signals (sigUSR1) #endif #endif #else data Credentials data SessionManager #endif ---------------------------------------------------------------- defaultDomain :: Domain defaultDomain = "localhost" defaultPort :: Natural defaultPort = 80 openFileNumber :: Integer openFileNumber = 10000 logBufferSize :: Natural logBufferSize = 4 * 1024 * 10 managerNumber :: Int managerNumber = 1024 -- FIXME ---------------------------------------------------------------- type LogRemover = IO () ---------------------------------------------------------------- server :: Option -> Reporter -> RouteDB -> IO () server opt rpt route = reportDo rpt $ do unlimit openFileNumber svc <- openService opt unless debug writePidFile rdr <- newRouteDBRef route tmgr <- T.initialize (naturalToInt (opt_connection_timeout opt) * 1000000) #ifdef HTTP_OVER_TLS mcred <- Just <$> loadCredentials opt smgr <- Just <$> SM.newSessionManager SM.defaultConfig { dbMaxSize = 1000 } #else let mcred = Nothing smgr = Nothing #endif _changed <- setGroupUser (opt_user opt) (opt_group opt) #ifdef DROP_EXCEPT_BIND when _changed dropExceptBind #endif logCheck logtype (zdater,_) <- clockDateCacher ap <- initLogger FromSocket logtype zdater let lgr = apacheLogger ap remover = logRemover ap pushlgr = serverpushLogger ap mgr <- getManager opt setHandlers opt rpt svc remover rdr report rpt "Mighty started" runInUnboundThread $ mighty opt rpt svc lgr pushlgr mgr rdr mcred smgr tmgr report rpt "Mighty retired" remover exitSuccess 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 = naturalToInt $ opt_log_backup_number opt } logtype | not (opt_logging opt) = LogNone | debug = LogStdout $ naturalToInt logBufferSize | otherwise = LogFile logspec $ naturalToInt logBufferSize setHandlers :: Option -> Reporter -> Service -> LogRemover -> RouteDBRef -> IO () setHandlers opt rpt svc remover rdr = 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" closeService svc remover exitImmediately ExitSuccess retireHandler = Catch $ do report rpt "Mighty retiring" closeService svc -- this lets warp break infoHandler = Catch $ report rpt "obsoleted" reloadHandler = Catch $ do ifRouteFileIsValid rpt opt $ \newroute -> do writeRouteDBRef rdr newroute report rpt "Mighty reloaded" #ifdef HTTP_OVER_TLS loadCredentials :: Option -> IO Credentials loadCredentials opt = do cert <- BS.readFile $ opt_tls_cert_file opt chains <- mapM BS.readFile chain_files key <- BS.readFile $ opt_tls_key_file opt let cred = fromRight (error "loadCredentials") $ TLS.credentialLoadX509ChainFromMemory cert chains key return $ Credentials [cred] where strip = dropWhileEnd isSpace . dropWhile isSpace split "" = [] split s = case break (',' ==) s of ("",r) -> split (tail r) (s',"") -> [s'] (s',r) -> s' : split (tail r) chain_files = map strip $ split $ opt_tls_chain_files opt #endif ---------------------------------------------------------------- ifRouteFileIsValid :: Reporter -> Option -> (RouteDB -> IO ()) -> 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 ---------------------------------------------------------------- mighty :: Option -> Reporter -> Service -> ApacheLogger -> ServerPushLogger -> ConnPool -> RouteDBRef -> Maybe Credentials -> Maybe SessionManager -> T.Manager -> IO () mighty opt rpt svc lgr pushlgr mgr rdr _mcreds _msmgr tmgr = reportDo rpt $ case svc of HttpOnly s -> runSettingsSocket setting s app #ifdef HTTP_OVER_TLS HttpsOnly s -> runTLSSocket tlsSetting setting s app HttpAndHttps s1 s2 -> concurrently_ (runSettingsSocket setting s1 app) (runTLSSocket tlsSetting setting s2 app) #ifdef HTTP_OVER_QUIC QUIC s1 s2 -> do let quicPort' = BS.pack $ show quicPort strver Q.Version1 = "" strver Q.Version2 = "" strver v = BS.append "-" $ BS.pack $ show $ fromVersion v quicDrafts = map strver quicVersions value v = BS.concat ["h3",v,"=\":",quicPort',"\""] altsvc = BS.intercalate "," $ map value quicDrafts settingT = setAltSvc altsvc setting mapConcurrently_ id [runSettingsSocket setting s1 app ,runTLSSocket tlsSetting settingT s2 app ,runQUIC qconf setting app ] #else _ -> error "never reach" #endif #else _ -> error "never reach" #endif where app = fileCgiApp cspec filespec cgispec revproxyspec rdr debug = opt_debug_mode opt -- We don't use setInstallShutdownHandler because we may use -- two sockets for HTTP and HTTPS. setting = setPort (naturalToInt $ opt_port opt) -- just in case $ setHost (fromString (opt_host opt)) -- just in case $ setOnException (if debug then printStdout else warpHandler rpt) $ setManager tmgr $ setFdCacheDuration (naturalToInt $ opt_fd_cache_duration opt) $ setFileInfoCacheDuration 10 $ setServerName serverName $ setLogger lgr $ setServerPushLogger pushlgr defaultSettings #ifdef HTTP_OVER_TLS tlsSetting = defaultTlsSettings { tlsCredentials = _mcreds , tlsSessionManager = _msmgr , tlsAllowedVersions = [TLS.TLS13,TLS.TLS12] } #endif serverName = BS.pack $ opt_server_name opt cspec = ClassicAppSpec { softwareName = serverName , statusFileDir = fromString $ opt_status_file_dir opt } filespec = FileAppSpec { indexFile = fromString $ opt_index_file opt , isHTML = \x -> ".html" `isSuffixOf` x || ".htm" `isSuffixOf` x } cgispec = CgiAppSpec { indexCgi = "index.cgi" } revproxyspec = RevProxyAppSpec { revProxyManager = mgr } #ifdef HTTP_OVER_QUIC quicAddr = read <$> opt_quic_addr opt quicPort = fromIntegral $ opt_quic_port opt quicVersions = Q.scVersions Q.defaultServerConfig qconf = Q.defaultServerConfig { Q.scAddresses = (,quicPort) <$> quicAddr , Q.scALPN = Just chooseALPN , Q.scRequireRetry = False , Q.scSessionManager = fromJust _msmgr , Q.scUse0RTT = True , Q.scDebugLog = opt_quic_debug_dir opt , Q.scQLog = opt_quic_qlog_dir opt , Q.scCredentials = fromJust _mcreds } chooseALPN :: Q.Version -> [ByteString] -> IO ByteString chooseALPN ver protos = case find (\x -> x == h3 || x == hq) protos of Nothing -> return "" Just proto -> return proto where h3 | ver == Q.Version1 = "h3" | ver == Q.Version2 = "h3" | otherwise = "h3-" `BS.append` BS.pack (show (fromVersion ver)) hq | ver == Q.Version1 = "hq-interop" | ver == Q.Version2 = "hq-interop" | otherwise = "hq-" `BS.append` BS.pack (show (fromVersion ver)) fromVersion :: Q.Version -> Int fromVersion (Q.Version ver) = fromIntegral (0x000000ff .&. ver) #endif ---------------------------------------------------------------- data Service = HttpOnly Socket | HttpsOnly Socket | HttpAndHttps Socket Socket | QUIC Socket Socket ---------------------------------------------------------------- openService :: Option -> IO Service openService opt | service == 1 = do s <- bindPortTCP httpsPort hostpref debugMessage $ urlForHTTPS httpsPort return $ HttpsOnly s | service == 2 = do s1 <- bindPortTCP httpPort hostpref s2 <- bindPortTCP httpsPort hostpref debugMessage $ urlForHTTP httpPort debugMessage $ urlForHTTPS httpsPort return $ HttpAndHttps s1 s2 | service == 3 = do s1 <- bindPortTCP httpPort hostpref s2 <- bindPortTCP httpsPort hostpref debugMessage $ urlForHTTP httpPort debugMessage $ urlForHTTPS httpsPort debugMessage "QUIC is also available via Alt-Svc" return $ QUIC s1 s2 | otherwise = do s <- bindPortTCP httpPort hostpref debugMessage $ urlForHTTP httpPort return $ HttpOnly s where httpPort = naturalToInt $ opt_port opt httpsPort = naturalToInt $ opt_tls_port opt hostpref = fromString $ opt_host opt service = opt_service opt debug = opt_debug_mode opt debugMessage msg = when debug $ do putStrLn msg hFlush stdout urlForHTTP 80 = "http://localhost/" urlForHTTP p = "http://localhost:" ++ show p ++ "/" urlForHTTPS 443 = "https://localhost/" urlForHTTPS p = "https://localhost:" ++ show p ++ "/" ---------------------------------------------------------------- closeService :: Service -> IO () closeService (HttpOnly s) = close s closeService (HttpsOnly s) = close s closeService (HttpAndHttps s1 s2) = close s1 >> close s2 closeService (QUIC s1 s2) = close s1 >> close s2 ---------------------------------------------------------------- type ConnPool = H.Manager getManager :: Option -> IO ConnPool getManager opt = H.newManager H.defaultManagerSettings { H.managerConnCount = managerNumber , H.managerResponseTimeout = responseTimeout } where responseTimeout | opt_proxy_timeout opt == 0 = H.managerResponseTimeout H.defaultManagerSettings | otherwise = H.responseTimeoutMicro (naturalToInt $ opt_proxy_timeout opt * 1000000) -- micro seconds #ifdef DROP_EXCEPT_BIND foreign import ccall unsafe "send_signal" c_send_signal :: CInt -> CInt -> IO () dropExceptBind :: IO () dropExceptBind = do pid <- getProcessID strtids <- listDirectory ("/proc/" ++ show pid ++ "/task") let tids = map read strtids :: [Int] forM_ tids $ \tid -> c_send_signal (fromIntegral tid) sigUSR1 #endif mighttpd2-4.0.3/src/WaiApp.hs0000644000000000000000000000571607346545000014126 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module WaiApp (fileCgiApp) where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Network.HTTP.Types (preconditionFailed412, movedPermanently301, urlDecode, badRequest400) 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 -> RouteDBRef -> Application fileCgiApp cspec filespec cgispec revproxyspec rdr req respond | dotFile = do let st = badRequest400 fastResponse respond st defaultHeader "Bad Request\r\n" | otherwise = do um <- readRouteDBRef rdr case mmp um of Fail -> do let st = preconditionFailed412 fastResponse respond st defaultHeader "Precondition Failed\r\n" Redirect -> do let st = movedPermanently301 hdr = defaultHeader ++ redirectHeader req' fastResponse respond st hdr "Moved Permanently\r\n" Found (RouteFile src dst) -> fileApp cspec filespec (FileRoute src dst) req' respond Found (RouteRedirect src dst) -> redirectApp cspec (RedirectRoute src dst) req' respond Found (RouteCGI src dst) -> cgiApp cspec cgispec (CgiRoute src dst) req' respond Found (RouteRevProxy src dst dom prt) -> revProxyApp cspec revproxyspec (RevProxyRoute src dst dom (naturalToInt prt)) req respond where (host, _) = hostPort req rawpath = rawPathInfo req path = urlDecode False rawpath dotFile = BS.isPrefixOf "." rawpath || BS.isInfixOf "/." rawpath mmp um = case getBlock host um of Nothing -> Fail Just blk -> getRoute path blk fastResponse resp st hdr body = resp $ responseLBS st hdr body defaultHeader = [("Content-Type", "text/plain")] req' = req { rawPathInfo = path } -- FIXME 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 isMountPointOf :: Path -> ByteString -> Bool isMountPointOf src key = hasTrailingPathSeparator src && BS.length src - BS.length key == 1 && key `BS.isPrefixOf` src mighttpd2-4.0.3/test/0000755000000000000000000000000007346545000012570 5ustar0000000000000000mighttpd2-4.0.3/test/ConfigSpec.hs0000644000000000000000000000277507346545000015157 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module ConfigSpec where import Program.Mighty import Test.Hspec spec :: Spec spec = do describe "parseConfig" $ do it "parses example.conf correctly" $ do res <- parseOption "conf/example.conf" res { opt_server_name = "foo" } `shouldBe` ans #ifdef DHALL describe "parseDhall" $ do it "parses example.dhall correctly" $ do res <- parseOptionDhall "./conf/example.dhall" res { opt_server_name = "foo" } `shouldBe` ans #endif ans :: Option ans = Option { opt_port = 80 , opt_host = "*" , opt_debug_mode = True , opt_user = "root" , opt_group = "root" , opt_pid_file = "/var/run/mighty.pid" , opt_report_file = "/tmp/mighty_report" , 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_service = 0 , opt_tls_port = 443 , opt_tls_cert_file = "cert.pem" , opt_tls_chain_files = "chain.pem" , opt_tls_key_file = "privkey.pem" , opt_quic_addr = ["127.0.0.1","::1"] , opt_quic_port = 443 , opt_quic_debug_dir = Nothing , opt_quic_qlog_dir = Nothing , opt_server_name = "foo" , opt_routing_file = Nothing } mighttpd2-4.0.3/test/RouteSpec.hs0000644000000000000000000000121207346545000015031 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module RouteSpec where import Test.Hspec import Program.Mighty spec :: Spec spec = do describe "parseRoute" $ do it "parses example.route correctly" $ do res <- parseRoute "conf/example.route" "localhost" 80 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-4.0.3/test/Spec.hs0000644000000000000000000000005407346545000014015 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} mighttpd2-4.0.3/utils/0000755000000000000000000000000007346545000012751 5ustar0000000000000000mighttpd2-4.0.3/utils/mightyctl.hs0000644000000000000000000000320207346545000015306 0ustar0000000000000000module Main where import Data.List import System.Environment import System.Exit import System.Posix.Signals import System.Posix.Types import Program.Mighty (getMightyPid, sigStop, sigReload, sigRetire, sigInfo) 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-4.0.3/utils/mkindex.hs0000644000000000000000000000504507346545000014750 0ustar0000000000000000{-# LANGUAGE CPP #-} -- mkindex :: Making index.html for the current directory. #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Data.Bits import Data.Time (formatTime) import Data.Time.Clock.POSIX import System.Directory import System.Posix.Files import Text.Printf #if MIN_VERSION_time(1,5,0) import Data.Time (defaultTimeLocale) #else import System.Locale (defaultTimeLocale) #endif 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"