mighttpd2-3.4.6/0000755000000000000000000000000013504325521011614 5ustar0000000000000000mighttpd2-3.4.6/Setup.hs0000644000000000000000000000005613504325521013251 0ustar0000000000000000import Distribution.Simple main = defaultMain mighttpd2-3.4.6/LICENSE0000644000000000000000000000276513504325521012633 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-3.4.6/mighttpd2.cabal0000644000000000000000000001151613504325521014506 0ustar0000000000000000Name: mighttpd2 Version: 3.4.6 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE Synopsis: High performance web server on WAI/warp Description: High performance web server to handle static files and CGI on WAI/warp. Reverse proxy functionality is also provided to connect web applications behind. Homepage: http://www.mew.org/~kazu/proj/mighttpd/ Category: Network, Web Cabal-Version: >= 1.10 Build-Type: Simple Data-Dir: conf Data-Files: example.conf example.route Flag tls Description: Support http over tls (https). Default: False Library Default-Language: Haskell2010 GHC-Options: -Wall Exposed-Modules: Program.Mighty Program.Mighty.ByteString Program.Mighty.Config Program.Mighty.Network Program.Mighty.Parser Program.Mighty.Process Program.Mighty.Report Program.Mighty.Resource Program.Mighty.Route Program.Mighty.Signal 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 , unix , unix-time , unordered-containers , wai >= 3.2 && < 3.3 , wai-app-file-cgi >= 3.1.9 && < 3.2 , warp >= 3.3 && < 3.4 if impl(ghc >= 8) Default-Extensions: Strict StrictData Executable mighty Default-Language: Haskell2010 HS-Source-Dirs: src Main-Is: Mighty.hs GHC-Options: -Wall -threaded -rtsopts if flag(tls) Cpp-Options: -DHTTP_OVER_TLS Build-Depends: async , tls-session-manager >= 0.0.2.0 Build-Depends: base >= 4.0 && < 5 , bytestring , directory , filepath , http-client >= 0.5 , http-date , http-types , mighttpd2 , network , conduit-extra , transformers , unix , streaming-commons , wai >= 3.2 && < 3.3 , wai-app-file-cgi >= 3.1.9 && < 3.2 , wai-logger >= 2.3.0 , warp >= 3.3 && < 3.4 , wai-http2-extra >= 0.1 if flag(tls) Build-Depends: tls , warp-tls >= 3.2.7 && < 3.3 Other-Modules: Server WaiApp Paths_mighttpd2 if impl(ghc >= 8) Default-Extensions: Strict StrictData Executable mighty-mkindex Default-Language: Haskell2010 HS-Source-Dirs: utils, src Main-Is: mkindex.hs GHC-Options: -Wall Build-Depends: base >= 4 && < 5 , directory , old-locale , time , unix Executable mightyctl Default-Language: Haskell2010 HS-Source-Dirs: utils, src Main-Is: mightyctl.hs GHC-Options: -Wall Build-Depends: base >= 4 && < 5 , unix , mighttpd2 if impl(ghc >= 8) Default-Extensions: Strict StrictData Test-Suite spec Default-Language: Haskell2010 Main-Is: Spec.hs Hs-Source-Dirs: test, src Type: exitcode-stdio-1.0 Other-Modules: ConfigSpec RouteSpec Build-Depends: base >= 4 && < 5 , hspec >= 1.3 , mighttpd2 , http-client >= 0.5 if flag(tls) Build-Depends: tls , warp-tls >= 3.2.7 && < 3.3 if impl(ghc >= 8) Default-Extensions: Strict StrictData Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/mighttpd2.git mighttpd2-3.4.6/test/0000755000000000000000000000000013504325521012573 5ustar0000000000000000mighttpd2-3.4.6/test/ConfigSpec.hs0000644000000000000000000000167413504325521015157 0ustar0000000000000000module 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" "foo" res `shouldBe` ans 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_logging = True, opt_log_file = "/var/log/mighty", opt_log_file_size = 16777216, opt_log_backup_number = 10, opt_index_file = "index.html", opt_index_cgi = "index.cgi", opt_status_file_dir = "/usr/local/share/mighty/status", opt_connection_timeout = 30, opt_fd_cache_duration = 10, opt_server_name = "foo", opt_routing_file = Nothing, opt_tls_port = 443, opt_tls_cert_file = "cert.pem", opt_tls_chain_files = "chain.pem", opt_tls_key_file = "privkey.pem", opt_service = 0, opt_report_file = "/tmp/mighty_report", opt_proxy_timeout = 0} mighttpd2-3.4.6/test/RouteSpec.hs0000644000000000000000000000121213504325521015034 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-3.4.6/test/Spec.hs0000644000000000000000000000005413504325521014020 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} mighttpd2-3.4.6/utils/0000755000000000000000000000000013504325521012754 5ustar0000000000000000mighttpd2-3.4.6/utils/mightyctl.hs0000644000000000000000000000320213504325521015311 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-3.4.6/utils/mkindex.hs0000644000000000000000000000504513504325521014753 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-3.4.6/Program/0000755000000000000000000000000013504325521013223 5ustar0000000000000000mighttpd2-3.4.6/Program/Mighty.hs0000644000000000000000000000125513504325521015023 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 ) 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 mighttpd2-3.4.6/Program/Mighty/0000755000000000000000000000000013504325521014464 5ustar0000000000000000mighttpd2-3.4.6/Program/Mighty/Process.hs0000644000000000000000000000512013504325521016434 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Program.Mighty.Process ( getMightyPid ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif 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 Data.Ord import System.Posix.Types ---------------------------------------------------------------- data PsResult = PsResult { uid :: ByteString , pid :: ProcessID , ppid :: ProcessID , command :: ByteString } deriving (Eq, Show) toPsResult :: [ByteString] -> PsResult toPsResult (a:b:c:_:_:_:_:h:_) = PsResult { uid = a , pid = maybe 0 (fromIntegral . fst) $ BS.readInt b , ppid = maybe 0 (fromIntegral . fst) $ BS.readInt c , command = h } toPsResult _ = PsResult "unknown" 0 0 "unknown" ---------------------------------------------------------------- runPS :: IO [PsResult] runPS = 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) $ sortBy (comparing ppid) rest deleteAloneChild :: [PsResult] -> [PsResult] deleteAloneChild [] = [] deleteAloneChild (p:ps) = p : deleteAloneChild (filter noParent ps) where parent = pid p noParent x = ppid x /= parent ---------------------------------------------------------------- -- | Getting the process id of a running Mighty. getMightyPid :: IO [ProcessID] getMightyPid = (map pid . findParent) <$> runPS ---------------------------------------------------------------- split :: Char -> ByteString -> [ByteString] split _ "" = [] split c s = case BS.break (c==) s of ("",r) -> split c (BS.tail r) (s',"") -> [s'] (s',r) -> s' : split c (BS.tail r) mighttpd2-3.4.6/Program/Mighty/Network.hs0000644000000000000000000000122413504325521016450 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-3.4.6/Program/Mighty/Parser.hs0000644000000000000000000000411613504325521016256 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Parsers for Mighty module Program.Mighty.Parser ( -- * Utilities parseFile -- * Parsers , spcs , spcs1 , spc , commentLines , trailing , comment ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative hiding (many,(<|>)) #endif import Control.Exception import qualified Data.ByteString.Lazy.Char8 as BL import System.IO import Text.Parsec import Text.Parsec.ByteString.Lazy -- $setup -- >>> import Data.Either -- >>> let isLeft = either (const True) (const False) -- | Parsing a file. -- If parsing fails, an 'IOException' is thrown. parseFile :: Parser a -> FilePath -> IO a parseFile p file = do hdl <- openFile file ReadMode hSetEncoding hdl latin1 bs <- BL.hGetContents hdl case parse p "parseFile" bs of Right x -> return x Left e -> throwIO . userError . show $ e -- | 'Parser' to consume zero or more white spaces -- -- >>> parse spcs "" " " -- Right () -- >>> parse spcs "" "" -- Right () spcs :: Parser () spcs = () <$ many spc -- | 'Parser' to consume one or more white spaces -- -- >>> parse spcs1 "" " " -- Right () -- >>> parse spcs1 "" " " -- Right () -- >>> isLeft $ parse spcs1 "" "" -- True spcs1 :: Parser () spcs1 = () <$ many1 spc -- | 'Parser' to consume exactly one white space -- -- >>> parse spc "" " " -- Right ' ' -- >>> isLeft $ parse spc "" "" -- True spc :: Parser Char spc = satisfy (`elem` " \t") -- | 'Parser' to consume one or more comment lines -- -- >>> parse commentLines "" "# comments\n# comments\n# comments\n" -- Right () commentLines :: Parser () commentLines = () <$ many commentLine where commentLine = trailing -- | 'Parser' to consume a trailing comment -- -- >>> parse trailing "" "# comments\n" -- Right () -- >>> isLeft $ parse trailing "" "X# comments\n" -- True trailing :: Parser () trailing = () <$ (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-3.4.6/Program/Mighty/Report.hs0000644000000000000000000000527113504325521016300 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Program.Mighty.Report ( Reporter , initReporter , finReporter , 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 Network.Wai.Handler.Warp.Internal (TimeoutThread(..)) import System.IO import System.IO.Error (ioeGetErrorType) import System.Posix (getProcessID) import Program.Mighty.ByteString data Method = FileOnly | FileAndStdout deriving Eq data Reporter = Reporter Method Handle initReporter :: Bool -> FilePath -> IO (Either SomeException Reporter) initReporter debug reportFile = try $ Reporter method <$> openFile reportFile AppendMode where method | debug = FileAndStdout | otherwise = FileOnly finReporter :: Reporter -> IO () finReporter (Reporter _ rpthdl) = hClose rpthdl report :: Reporter -> ByteString -> IO () report (Reporter method rpthdl) msg = handle (\(SomeException _) -> return ()) $ do pid <- BS.pack . show <$> getProcessID tm <- getUnixTime >>= formatUnixTime "%d %b %Y %H:%M:%S" let logmsg = BS.concat [tm, ": pid = ", pid, ": ", msg, "\n"] BS.hPutStr rpthdl logmsg hFlush rpthdl when (method == FileAndStdout) $ BS.putStr logmsg ---------------------------------------------------------------- reportDo :: Reporter -> IO () -> IO () reportDo rpt act = act `E.catch` warpHandler rpt Nothing ---------------------------------------------------------------- warpHandler :: Reporter -> Maybe Request -> SomeException -> IO () warpHandler rpt _ e = throwIO e `catches` handlers where handlers = [Handler ah, Handler th, Handler ih, Handler oh, Handler sh] ah :: AsyncException -> IO () ah ThreadKilled = norecode ah x = recode x th :: TimeoutThread -> IO () th TimeoutThread = norecode ih :: InvalidRequest -> IO () ih _ = norecode oh :: IOException -> IO () oh x | et `elem` ignEts = norecode | otherwise = recode x where et = ioeGetErrorType x ignEts = [ResourceVanished, InvalidArgument] sh :: SomeException -> IO () sh x = recode x norecode = return () recode :: Exception e => e -> IO () recode = report rpt . bshow ---------------------------------------------------------------- printStdout :: Maybe Request -> SomeException -> IO () printStdout _ x = print x >> hFlush stdout mighttpd2-3.4.6/Program/Mighty/ByteString.hs0000644000000000000000000000052613504325521017115 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-3.4.6/Program/Mighty/Config.hs0000644000000000000000000001274213504325521016233 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, OverloadedStrings #-} {-# LANGUAGE CPP #-} module Program.Mighty.Config ( -- * Parsing a configuration file. parseOption -- * Creating 'Option'. , defaultOption -- * Types , Option(..) ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative hiding (many,optional,(<|>)) #endif import Program.Mighty.Parser import Text.Parsec import Text.Parsec.ByteString.Lazy ---------------------------------------------------------------- -- | Getting a default 'Option'. defaultOption :: String -- ^ A default server name (e.g. \"Mighttpd/3.0.0\") -> Option defaultOption svrnm = Option { opt_port = 8080 , opt_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_server_name = svrnm , opt_routing_file = Nothing , opt_tls_port = 443 , opt_tls_cert_file = "cert.pem" , opt_tls_chain_files = "chain.pem" , opt_tls_key_file = "privkey.pem" , opt_service = 0 } data Option = Option { opt_port :: !Int , 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 :: !Int , opt_log_backup_number :: !Int , opt_index_file :: !FilePath , opt_index_cgi :: !FilePath , opt_status_file_dir :: !FilePath , opt_connection_timeout :: !Int , opt_proxy_timeout :: !Int , opt_fd_cache_duration :: !Int , opt_server_name :: !String , opt_routing_file :: !(Maybe FilePath) , opt_tls_port :: !Int , opt_tls_cert_file :: !FilePath , opt_tls_chain_files :: !FilePath , opt_tls_key_file :: !FilePath , opt_service :: !Int } deriving (Eq,Show) ---------------------------------------------------------------- -- | Parsing a configuration file to get an 'Option'. parseOption :: FilePath -> String -> IO Option parseOption file svrnm = makeOpt (defaultOption svrnm) <$> parseConfig file ---------------------------------------------------------------- makeOpt :: Option -> [Conf] -> Option makeOpt def conf = Option { opt_port = get "Port" opt_port , opt_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_server_name = get "Server_Name" opt_server_name , opt_routing_file = Nothing , opt_tls_port = get "Tls_Port" opt_tls_port , opt_tls_cert_file = get "Tls_Cert_File" opt_tls_cert_file , opt_tls_chain_files = get "Tls_Chain_Files" opt_tls_chain_files , opt_tls_key_file = get "Tls_Key_File" opt_tls_key_file , opt_service = get "Service" opt_service } where get k func = maybe (func def) fromConf $ lookup k conf ---------------------------------------------------------------- type Conf = (String, ConfValue) data ConfValue = CV_Int Int | CV_Bool Bool | CV_String String deriving (Eq,Show) class FromConf a where fromConf :: ConfValue -> a instance FromConf Int where fromConf (CV_Int n) = n fromConf _ = error "fromConf int" instance FromConf Bool where fromConf (CV_Bool b) = b fromConf _ = error "fromConf bool" instance FromConf String where fromConf (CV_String s) = s fromConf _ = error "fromConf string" ---------------------------------------------------------------- parseConfig :: FilePath -> IO [Conf] parseConfig = parseFile config ---------------------------------------------------------------- config :: Parser [Conf] config = commentLines *> many cfield <* eof where cfield = field <* commentLines field :: Parser Conf field = (,) <$> key <*> (sep *> value) key :: Parser String key = many1 (oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_") <* spcs sep :: Parser () sep = () <$ char ':' *> spcs value :: Parser ConfValue value = choice [try cv_int, try cv_bool, cv_string] -- Trailing should be included in try to allow IP addresses. cv_int :: Parser ConfValue cv_int = CV_Int . 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-3.4.6/Program/Mighty/Signal.hs0000644000000000000000000000147613504325521016245 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-3.4.6/Program/Mighty/Resource.hs0000644000000000000000000000236413504325521016614 0ustar0000000000000000{-# LANGUAGE CPP #-} module Program.Mighty.Resource ( amIrootUser , setGroupUser , unlimit ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Exception import Control.Monad import System.Posix ---------------------------------------------------------------- -- | Checking if this process has the root privilege. amIrootUser :: IO Bool amIrootUser = (== 0) <$> getRealUserID ---------------------------------------------------------------- -- | Setting user and group. setGroupUser :: String -- ^ User -> String -- ^ Group -> IO () setGroupUser user group = do root <- amIrootUser when root $ do getGroupEntryForName group >>= setGroupID . groupID getUserEntryForName user >>= setUserID . userID ---------------------------------------------------------------- -- | Set the limit of open files. unlimit :: Integer -> IO () unlimit limit = handle (\(SomeException _) -> return ()) $ do hard <- hardLimit <$> getResourceLimit ResourceOpenFiles let lim = if hard == ResourceLimitInfinity then ResourceLimits (ResourceLimit limit) hard else ResourceLimits hard hard setResourceLimit ResourceOpenFiles lim mighttpd2-3.4.6/Program/Mighty/Route.hs0000644000000000000000000000720713504325521016124 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, TupleSections #-} {-# LANGUAGE CPP #-} module Program.Mighty.Route ( -- * Paring a routing file parseRoute -- * Types , RouteDB , Route(..) , Block(..) , Src , Dst , Domain , Port -- * RouteDBRef , RouteDBRef , newRouteDBRef , readRouteDBRef , writeRouteDBRef ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative hiding (many,(<|>)) #endif import Control.Monad import Data.ByteString import qualified Data.ByteString.Char8 as BS import Data.IORef import Network.Wai.Application.Classic import Text.Parsec import Text.Parsec.ByteString.Lazy import Program.Mighty.Parser ---------------------------------------------------------------- -- | A logical path specified in URL. type Src = Path -- | A physical path in a file system. type Dst = Path type Domain = ByteString type Port = Int data Block = Block [Domain] [Route] deriving (Eq,Show) data Route = RouteFile Src Dst | RouteRedirect Src Dst | RouteCGI Src Dst | RouteRevProxy Src Dst Domain Port deriving (Eq,Show) type RouteDB = [Block] ---------------------------------------------------------------- -- | Parsing a route file. parseRoute :: FilePath -> Domain -- ^ A default domain, typically \"localhost\" -> Port -- ^ A default port, typically 80. -> IO RouteDB parseRoute file ddom dport = parseFile (routeDB ddom dport) file routeDB :: Domain -> Port -> Parser RouteDB routeDB ddom dport = commentLines *> many1 (block ddom dport) <* eof block :: Domain -> Port -> Parser Block block ddom dport = Block <$> cdomains <*> many croute where cdomains = domains <* commentLines croute = route ddom dport <* commentLines domains :: Parser [Domain] domains = open *> doms <* close <* trailing where open = () <$ char '[' *> spcs close = () <$ char ']' *> spcs doms = (domain `sepBy1` sep) <* spcs domain = BS.pack <$> many1 (noneOf "[], \t\n") sep = () <$ spcs1 data Op = OpFile | OpCGI | OpRevProxy | OpRedirect route :: Domain -> Port -> Parser Route route ddom dport = do s <- src o <- op case o of OpFile -> RouteFile s <$> dst <* trailing OpRedirect -> RouteRedirect s <$> dst' <* trailing OpCGI -> RouteCGI s <$> dst <* trailing OpRevProxy -> do (dom,prt,d) <- domPortDst ddom dport return $ RouteRevProxy s d dom prt where src = path dst = path dst' = path' op0 = OpFile <$ string "->" <|> OpRedirect <$ string "<<" <|> OpCGI <$ string "=>" <|> OpRevProxy <$ string ">>" op = op0 <* spcs path :: Parser Path path = do c <- char '/' 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-3.4.6/conf/0000755000000000000000000000000013504325521012541 5ustar0000000000000000mighttpd2-3.4.6/conf/example.conf0000644000000000000000000000202613504325521015043 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 Log_File: /var/log/mighty # The directory must be writable by User: Log_File_Size: 16777216 # bytes Log_Backup_Number: 10 Index_File: index.html Index_Cgi: index.cgi Status_File_Dir: /usr/local/share/mighty/status Connection_Timeout: 30 # seconds Proxy_Timeout: 0 # seconds, 0 is default of http-client, ie 30 seconds Fd_Cache_Duration: 10 # seconds # Server_Name: Mighttpd/3.x.y Tls_Port: 443 Tls_Cert_File: cert.pem # should change this with an absolute path # 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 Service: 0 # 0 is HTTP only, 1 is HTTPS only, 2 is both mighttpd2-3.4.6/conf/example.route0000644000000000000000000000125313504325521015255 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-3.4.6/src/0000755000000000000000000000000013504325521012403 5ustar0000000000000000mighttpd2-3.4.6/src/WaiApp.hs0000644000000000000000000000565713504325521014135 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} 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 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-3.4.6/src/Mighty.hs0000644000000000000000000000610613504325521014203 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} module Main where #ifndef HTTP_OVER_TLS import Control.Monad (when) #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 >>= checkReporter reportFile let run = server opt rpt route if debug then run else background opt run where getOptRoute = getArgs >>= eachCase svrnm = programName ++ "/" ++ programVersion eachCase args | n == 0 = do root <- amIrootUser let opt | root = (defaultOption svrnm) { opt_port = 80 } | otherwise = defaultOption svrnm dir <- getCurrentDirectory let dst = fromString . addTrailingPathSeparator $ dir route = [Block ["*"] [RouteFile "/" dst]] return (opt, route) | n == 2 = do let config_file = args !! 0 routing_file <- getAbsoluteFile (args !! 1) opt <- parseOption config_file svrnm route <- parseRoute routing_file defaultDomain defaultPort let opt' = opt {opt_routing_file = Just routing_file} return (opt',route) | otherwise = do hPutStrLn stderr "Usage: mighty" hPutStrLn stderr " mighty config_file routing_file" exitFailure where n = length args getAbsoluteFile file | isAbsolute file = return file | otherwise = do dir <- getCurrentDirectory return $ dir normalise file checkReporter _ (Right rpt) = return rpt checkReporter reportFile (Left e) = do hPutStrLn stderr $ reportFile ++ " is not writable" hPrint stderr e exitFailure #ifdef HTTP_OVER_TLS checkTLS _ = return () #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-3.4.6/src/Server.hs0000644000000000000000000002165613504325521014217 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP, BangPatterns #-} module Server (server, defaultDomain, defaultPort) where import Control.Concurrent (runInUnboundThread) import Control.Exception (try) import Control.Monad (unless, when) import qualified Data.ByteString.Char8 as BS #ifdef HTTP_OVER_TLS import Data.Char (isSpace) import Data.List (dropWhile, dropWhileEnd, break) #endif import Data.Streaming.Network (bindPortTCP) import Network.Socket (Socket, close) import qualified Network.HTTP.Client as H 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 Program.Mighty import WaiApp import qualified Network.Wai.Middleware.Push.Referer as P #ifdef HTTP_OVER_TLS import Control.Concurrent.Async (concurrently) import Control.Monad (void) import Network.Wai.Handler.WarpTLS import Network.TLS.SessionManager #else data TLSSettings = TLSSettings #endif ---------------------------------------------------------------- defaultDomain :: Domain defaultDomain = "localhost" defaultPort :: Int defaultPort = 80 openFileNumber :: Integer openFileNumber = 10000 logBufferSize :: Int 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 tlsSetting <- getTlsSetting opt setGroupUser (opt_user opt) (opt_group opt) 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 tlsSetting report rpt "Mighty retired" finReporter rpt 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 = opt_log_backup_number opt } logtype | not (opt_logging opt) = LogNone | debug = LogStdout logBufferSize | otherwise = LogFile logspec 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" finReporter rpt closeService svc remover exitImmediately ExitSuccess retireHandler = Catch $ do report rpt "Mighty retiring" closeService svc -- this lets warp break infoHandler = Catch $ report rpt "obsolted" reloadHandler = Catch $ do ifRouteFileIsValid rpt opt $ \newroute -> do writeRouteDBRef rdr newroute report rpt "Mighty reloaded" getTlsSetting :: Option -> IO TLSSettings getTlsSetting _opt = #ifdef HTTP_OVER_TLS case opt_service _opt of 0 -> return defaultTlsSettings -- this is dummy _ -> do cert <- BS.readFile $ opt_tls_cert_file _opt let 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 chains <- mapM BS.readFile chain_files key <- BS.readFile $ opt_tls_key_file _opt let settings0 = tlsSettingsChainMemory cert chains key settings = settings0 { tlsSessionManagerConfig = Just defaultConfig { dbMaxSize = 1000 } } return settings #else return TLSSettings #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 -> TLSSettings -> IO () mighty opt rpt svc lgr pushlgr mgr rdr _tlsSetting = 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 -> void $ concurrently (runSettingsSocket setting s1 app) (runTLSSocket _tlsSetting setting s2 app) #else _ -> error "never reach" #endif where app = P.pushOnReferer P.defaultSettings (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 (opt_port opt) -- just in case $ setHost (fromString (opt_host opt)) -- just in case $ setOnException (if debug then printStdout else warpHandler rpt) $ setTimeout (opt_connection_timeout opt) -- seconds $ setFdCacheDuration (opt_fd_cache_duration opt) $ setFileInfoCacheDuration 10 $ setServerName serverName $ setLogger lgr $ setServerPushLogger pushlgr defaultSettings 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 } ---------------------------------------------------------------- data Service = HttpOnly Socket | HttpsOnly Socket | HttpAndHttps 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 | otherwise = do s <- bindPortTCP httpPort hostpref debugMessage $ urlForHTTP httpPort return $ HttpOnly s where httpPort = opt_port opt httpsPort = 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 ---------------------------------------------------------------- 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 (opt_proxy_timeout opt * 1000000) -- micro seconds