mighttpd2-4.0.9/0000755000000000000000000000000007346545000011617 5ustar0000000000000000mighttpd2-4.0.9/LICENSE0000644000000000000000000000276507346545000012636 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.9/Program/0000755000000000000000000000000007346545000013226 5ustar0000000000000000mighttpd2-4.0.9/Program/Mighty.hs0000644000000000000000000000137107346545000015025 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.9/Program/Mighty/0000755000000000000000000000000007346545000014467 5ustar0000000000000000mighttpd2-4.0.9/Program/Mighty/ByteString.hs0000644000000000000000000000052507346545000017117 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.9/Program/Mighty/Config.hs0000644000000000000000000001763307346545000016242 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.9/Program/Mighty/Dhall/0000755000000000000000000000000007346545000015513 5ustar0000000000000000mighttpd2-4.0.9/Program/Mighty/Dhall/Option.dhall0000755000000000000000000000107507346545000017777 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.9/Program/Mighty/Dhall/Option.hs0000644000000000000000000000060007346545000017313 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} 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.9/Program/Mighty/Network.hs0000644000000000000000000000122307346545000016452 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.9/Program/Mighty/Parser.hs0000644000000000000000000000377207346545000016270 0ustar0000000000000000-- | Parsers for Mighty module Program.Mighty.Parser ( -- * Utilities parseFile, -- * Parsers spcs, spcs1, spc, commentLines, trailing, comment, ) where import Control.Exception import qualified Data.ByteString.Lazy.Char8 as BL import System.IO import Text.Parsec import Text.Parsec.ByteString.Lazy -- $setup -- >>> :seti -XOverloadedStrings -- >>> import Data.Either -- | 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 () -- >>> parse trailing "" " \n" -- Right () -- >>> isLeft $ parse trailing "" "X# comments\n" -- True trailing :: Parser () trailing = () <$ (spcs *> optional comment *> 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.9/Program/Mighty/Process.hs0000644000000000000000000000507207346545000016445 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.9/Program/Mighty/Report.hs0000644000000000000000000000550007346545000016276 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.Exception import qualified Control.Exception as E (catch) import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.UnixTime import GHC.IO.Exception (IOErrorType (..)) import Network.Wai import Network.Wai.Handler.Warp (InvalidRequest) import System.Exit (ExitCode) import System.IO import System.IO.Error (ioeGetErrorType) import System.Posix (getProcessID) import Network.HTTP2.Client (HTTP2Error) #ifdef HTTP_OVER_TLS import Network.TLS (TLSException) import Network.Wai.Handler.WarpTLS (WarpTLSException) #ifdef HTTP_OVER_QUIC import Network.QUIC (QUICException) #endif #endif 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 `E.catch` warpHandler rpt Nothing ---------------------------------------------------------------- {- FOURMOLU_DISABLE -} warpHandler :: Reporter -> Maybe Request -> SomeException -> IO () warpHandler rpt _ se | Just (_ :: ExitCode) <- fromException se = return () | Just (e :: IOException) <- fromException se = if ioeGetErrorType e `elem` [ResourceVanished, InvalidArgument] then return () else report rpt $ bshow se | Just (_ :: InvalidRequest) <- fromException se = return () -- Warp | Just (_ :: HTTP2Error) <- fromException se = return () #ifdef HTTP_OVER_TLS | Just (_ :: TLSException) <- fromException se = return () | Just (_ :: WarpTLSException) <- fromException se = return () #ifdef HTTP_OVER_QUIC | Just (_ :: QUICException) <- fromException se = return () #endif #endif | otherwise = report rpt $ bshow se {- FOURMOLU_ENABLE -} ---------------------------------------------------------------- printStdout :: Maybe Request -> SomeException -> IO () printStdout _ x = print x >> hFlush stdout mighttpd2-4.0.9/Program/Mighty/Resource.hs0000644000000000000000000000241307346545000016612 0ustar0000000000000000{-# LANGUAGE CPP #-} module Program.Mighty.Resource ( amIrootUser, setGroupUser, unlimit, ) where import Control.Exception import System.Posix ---------------------------------------------------------------- -- | Checking if this process has the root privilege. amIrootUser :: IO Bool amIrootUser = (== 0) <$> getRealUserID ---------------------------------------------------------------- -- | Setting user and group. setGroupUser :: String -- ^ User -> String -- ^ Group -> IO 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.9/Program/Mighty/Route.hs0000644000000000000000000000714007346545000016123 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.9/Program/Mighty/Signal.hs0000644000000000000000000000150207346545000016236 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.9/Program/Mighty/Types.hs0000644000000000000000000000045007346545000016126 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.9/Setup.hs0000644000000000000000000000005707346545000013255 0ustar0000000000000000import Distribution.Simple main = defaultMain mighttpd2-4.0.9/conf/0000755000000000000000000000000007346545000012544 5ustar0000000000000000mighttpd2-4.0.9/conf/example.conf0000644000000000000000000000225007346545000015045 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.9/conf/example.dhall0000755000000000000000000000342207346545000015211 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.9/conf/example.route0000644000000000000000000000125307346545000015260 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.9/mighttpd2.cabal0000644000000000000000000001153307346545000014510 0ustar0000000000000000cabal-version: >=1.10 name: mighttpd2 version: 4.0.9 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 utils/restart.sh 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, http2, network, parsec >=3, resourcet, split, streaming-commons, text, unix, unix-time, unordered-containers, wai >=3.2 && <3.3, wai-app-file-cgi >=3.1.9 && <3.2, warp >=3.4 && <3.5 if impl(ghc >=8) default-extensions: Strict StrictData if flag(dhall) cpp-options: -DDHALL build-depends: dhall if flag(tls) build-depends: tls, warp-tls if flag(quic) build-depends: quic, http3 executable mighty main-is: Mighty.hs hs-source-dirs: src other-modules: Server WaiApp Paths_mighttpd2 default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-qn1 -A32m -kc2k" 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.4 && <3.5 if flag(tls) cpp-options: -DHTTP_OVER_TLS build-depends: async, tls-session-manager >=0.0.5 if flag(quic) cpp-options: -DHTTP_OVER_QUIC build-depends: async, base16-bytestring 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 >= 0.2 && < 0.3, warp-quic >= 0.0.2 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 -threaded 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 build-tool-depends: hspec-discover:hspec-discover 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.9/src/0000755000000000000000000000000007346545000012406 5ustar0000000000000000mighttpd2-4.0.9/src/Mighty.hs0000644000000000000000000000652007346545000014206 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 id else run (background opt) 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 $ "Detaching this terminal..." putStrLn $ "(If errors occur, they will be written in \"" ++ reportFileName opt ++ "\".)" hFlush stdout daemonize svr 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.9/src/Server.hs0000644000000000000000000003363607346545000014223 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) import qualified Data.ByteString.Char8 as BS import Data.Either (fromRight) import Data.Streaming.Network (bindPortTCP, bindPortUDP) #if __GLASGOW_HASKELL__ >= 906 import GHC.Conc.Sync import Data.List (sort) import Data.Maybe (fromMaybe) #endif import qualified Network.HTTP.Client as H import Network.Socket (Socket, close) import Network.Wai import Network.Wai.Application.Classic hiding (()) import Network.Wai.Handler.Warp import Network.Wai.Logger import System.Exit (ExitCode(..), exitSuccess) 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 qualified Network.TLS.SessionTicket as SM import Network.Wai.Handler.WarpTLS #ifdef HTTP_OVER_QUIC 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 #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 () -> IO ()) -> IO () server opt rpt route runMighty = reportDo rpt $ do labelMe "Mighty main" unlimit openFileNumber svc <- openService opt runMighty $ do unless debug writePidFile rdr <- newRouteDBRef route let usec = naturalToInt (opt_connection_timeout opt) * 1000000 T.withManager usec $ \tmgr -> do (mcred, smgr) <- setup opt _changed <- setGroupUser (opt_user opt) (opt_group opt) logCheck logtype -- "Time cacher of FastLogger (AutoUpdate)" (zdater,_) <- clockDateCacher -- Loggerset of FastLogger (Debounce) ap <- initLogger FromSocket logtype zdater let lgr = apacheLogger ap remover = logRemover ap pushlgr = serverpushLogger ap -- HTTP Client Manager mgr <- getManager opt setHandlers opt rpt svc remover rdr report rpt "Mighty started" runInUnboundThread $ do labelMe "Mighty main (bound thread)" 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 $ do labelMe "Info signale handler" threadSummary >>= mapM_ (report rpt . showT) showT (i, l, s) = BS.pack (i ++ " " ++ l ++ ": " ++ show s) reloadHandler = Catch $ do ifRouteFileIsValid rpt opt $ \newroute -> do writeRouteDBRef rdr newroute report rpt "Mighty reloaded" #if __GLASGOW_HASKELL__ >= 906 threadSummary :: IO [(String, String, ThreadStatus)] threadSummary = (sort <$> listThreads) >>= mapM summary where summary t = do let idstr = drop 9 $ show t l <- fromMaybe "(no name)" <$> threadLabel t s <- threadStatus t return (idstr, l, s) #else threadSummary :: IO [(String, String, String)] threadSummary = return [] #endif #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 $ drop 1 r (s',"") -> [s'] (s',r) -> s' : split (drop 1 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 -> runHTTP setting s app #ifdef HTTP_OVER_TLS HttpsOnly s -> runHTTPS tlsSetting setting s app HttpAndHttps s1 s2 -> concurrently_ (runHTTP setting s1 app) (runHTTPS tlsSetting setting s2 app) #ifdef HTTP_OVER_QUIC QUIC s1 s2 ss3 -> 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 h12 = concurrently_ (runHTTP setting s1 app) (runHTTPS tlsSetting settingT s2 app) h123 = concurrently_ (runHTTP3 qconf setting ss3 app) (labelMe "concurrently" >> h12) h123 #else _ -> error "never reach" #endif #else _ -> error "never reach" #endif where app = fileCgiApp cspec filespec cgispec revproxyspec rdr -- 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 $ 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 -- Lazy binding for opt_service == 0 so that -- 'fromJust' is not called. ~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 [Socket] instance Show Service where show HttpOnly{} = "HttpOnly" show HttpsOnly{} = "HttpOnlys" show HttpAndHttps{} = "HttpAndHttps" show QUIC{} = "QUIC" ---------------------------------------------------------------- openService :: Option -> IO Service openService opt | service == 1 = do s <- bindPortTCP httpsPort hostpref putStrLn $ urlForHTTPS httpsPort return $ HttpsOnly s | service == 2 = do s1 <- bindPortTCP httpPort hostpref s2 <- bindPortTCP httpsPort hostpref putStrLn $ urlForHTTP httpPort putStrLn $ urlForHTTPS httpsPort return $ HttpAndHttps s1 s2 | service == 3 = do s1 <- bindPortTCP httpPort hostpref s2 <- bindPortTCP httpsPort hostpref ss3 <- mapM (bindPortUDP quicPort) quicAddrs putStrLn $ urlForHTTP httpPort putStrLn $ urlForHTTPS httpsPort putStrLn "QUIC is also available via Alt-Svc" return $ QUIC s1 s2 ss3 | otherwise = do s <- bindPortTCP httpPort hostpref putStrLn $ urlForHTTP httpPort return $ HttpOnly s where httpPort = naturalToInt $ opt_port opt httpsPort = naturalToInt $ opt_tls_port opt quicPort = naturalToInt $ opt_quic_port opt quicAddrs = fromString <$> opt_quic_addr opt hostpref = fromString $ opt_host opt service = opt_service opt 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 ss3) = close s1 >> close s2 >> mapM_ close ss3 ---------------------------------------------------------------- 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 ---------------------------------------------------------------- setup :: Option -> IO (Maybe Credentials, Maybe SessionManager) #ifdef HTTP_OVER_TLS setup opt | 1 <= service && service <= 3 = do mcred <- Just <$> loadCredentials opt smgr <- Just <$> SM.newSessionTicketManager SM.defaultConfig return (mcred, smgr) | otherwise = return (Nothing, Nothing) where service = opt_service opt #else setup _ = return (Nothing, Nothing) #endif labelMe :: String -> IO () #if __GLASGOW_HASKELL__ >= 906 labelMe lbl = do tid <- myThreadId labelThread tid lbl #else labelMe _ = return () #endif runHTTP :: Settings -> Socket -> Application -> IO () runHTTP setting s app = do labelMe "HTTP1/2 server" runSettingsSocket setting s app #ifdef HTTP_OVER_TLS runHTTPS :: TLSSettings -> Settings -> Socket -> Application -> IO () runHTTPS tlsSetting setting s app = do labelMe "HTTP1/2 over TLS server" runTLSSocket tlsSetting setting s app #ifdef HTTP_OVER_QUIC runHTTP3 :: QUICSettings -> Settings -> [Socket]-> Application -> IO () runHTTP3 qconf setting ss app = do labelMe "HTTP3 server" runQUICSockets qconf setting ss app #endif #endif mighttpd2-4.0.9/src/WaiApp.hs0000644000000000000000000000617607346545000014135 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module WaiApp (fileCgiApp) where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Network.HTTP.Types ( badRequest400, movedPermanently301, preconditionFailed412, urlDecode, ) import Network.Wai (Application, responseLBS) import Network.Wai.Application.Classic import Network.Wai.Internal 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 = not (BS.isPrefixOf "/.well-known/" rawpath) && (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.9/test/0000755000000000000000000000000007346545000012576 5ustar0000000000000000mighttpd2-4.0.9/test/ConfigSpec.hs0000644000000000000000000000313707346545000015156 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} 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 = ["0.0.0.0", "::"] , 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.9/test/RouteSpec.hs0000644000000000000000000000134107346545000015042 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.9/test/Spec.hs0000644000000000000000000000005407346545000014023 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} mighttpd2-4.0.9/utils/0000755000000000000000000000000007346545000012757 5ustar0000000000000000mighttpd2-4.0.9/utils/mightyctl.hs0000644000000000000000000000315507346545000015323 0ustar0000000000000000module Main where import Data.List import System.Environment import System.Exit import System.Posix.Signals import System.Posix.Types import Program.Mighty (getMightyPid, sigInfo, sigReload, sigRetire, sigStop) 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.9/utils/mkindex.hs0000644000000000000000000000504507346545000014756 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" mighttpd2-4.0.9/utils/restart.sh0000755000000000000000000000125707346545000015007 0ustar0000000000000000#! /bin/sh # A shell script to restart mighty: # * The current mighty is retired # * A new mighty is started # Assuming this directory contains everything. MIGHTY_PATH=/usr/local/mighty # % ls -1 /usr/local/mighty # conf # mighty* # mightyctl* # restart.sh* # route # webroot/ # Assuming that the following entries is included in "route" # /.well-known/acme-challenge/ -> /usr/local/mighty/webroot/.well-known/acme-challenge/ # This script can be used with "certbot renew" # % sudo certbot renew --webroot -w /usr/local/mighty/webroot --deploy-hook /usr/local/mighty/restart.sh ${MIGHTY_PATH}/mightyctl retire ${MIGHTY_PATH}/mighty ${MIGHTY_PATH}/conf ${MIGHTY_PATH}/route +RTS -N2