diff --git a/Program/Mighty.hs b/Program/Mighty.hs --- a/Program/Mighty.hs +++ b/Program/Mighty.hs @@ -7,21 +7,17 @@ -- * State , module Program.Mighty.FileCache , module Program.Mighty.Report - , module Program.Mighty.State -- * Utilities , module Program.Mighty.ByteString , module Program.Mighty.Network , module Program.Mighty.Process , module Program.Mighty.Resource , module Program.Mighty.Signal - -- * Internal modules - , module Program.Mighty.IORef ) where import Program.Mighty.ByteString import Program.Mighty.Config import Program.Mighty.FileCache -import Program.Mighty.IORef import Program.Mighty.Network import Program.Mighty.Parser import Program.Mighty.Process @@ -29,4 +25,3 @@ import Program.Mighty.Resource import Program.Mighty.Route import Program.Mighty.Signal -import Program.Mighty.State diff --git a/Program/Mighty/Config.hs b/Program/Mighty/Config.hs --- a/Program/Mighty/Config.hs +++ b/Program/Mighty/Config.hs @@ -21,6 +21,7 @@ -> Option defaultOption svrnm = Option { opt_port = 8080 + , opt_host = "*" , opt_debug_mode = True , opt_user = "root" , opt_group = "root" @@ -46,6 +47,7 @@ data Option = Option { opt_port :: !Int + , opt_host :: !String , opt_debug_mode :: !Bool , opt_user :: !String , opt_group :: !String @@ -80,6 +82,7 @@ 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 @@ -139,7 +142,7 @@ cfield = field <* commentLines field :: Parser Conf -field = (,) <$> key <*> (sep *> value) <* trailing +field = (,) <$> key <*> (sep *> value) key :: Parser String key = many1 (oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_") <* spcs @@ -148,14 +151,15 @@ sep = () <$ char ':' *> spcs value :: Parser ConfValue -value = choice [try cv_int, try cv_bool, cv_string] <* spcs +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 +cv_int = CV_Int . read <$> many1 digit <* trailing cv_bool :: Parser ConfValue -cv_bool = CV_Bool True <$ string "Yes" <|> - CV_Bool False <$ string "No" +cv_bool = CV_Bool True <$ string "Yes" <* trailing <|> + CV_Bool False <$ string "No" <* trailing cv_string :: Parser ConfValue -cv_string = CV_String <$> many1 (noneOf " \t\n") +cv_string = CV_String <$> many1 (noneOf " \t\n") <* trailing diff --git a/Program/Mighty/FileCache.hs b/Program/Mighty/FileCache.hs --- a/Program/Mighty/FileCache.hs +++ b/Program/Mighty/FileCache.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + module Program.Mighty.FileCache ( -- * Types GetInfo @@ -8,27 +10,27 @@ import Control.Exception import Control.Exception.IOChoice +import Control.Reaper import Data.ByteString (ByteString) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M -import Data.IORef import Network.HTTP.Date import Network.Wai.Application.Classic -import Program.Mighty.IORef import System.Posix.Files data Entry = Negative | Positive FileInfo type Cache = HashMap ByteString Entry type GetInfo = Path -> IO FileInfo type RemoveInfo = IO () +type FileCache = Reaper Cache (ByteString,Entry) -fileInfo :: IORef Cache -> GetInfo -fileInfo ref path = do - cache <- readIORef ref +fileInfo :: FileCache -> GetInfo +fileInfo reaper@Reaper{..} path = do + cache <- reaperRead case M.lookup bpath cache of Just Negative -> throwIO (userError "fileInfo") Just (Positive x) -> return x - Nothing -> register ||> negative ref path + Nothing -> register ||> negative reaper path where bpath = pathByteString path sfile = pathString path @@ -37,13 +39,13 @@ let regular = not (isDirectory fs) readable = fileMode fs `intersectFileModes` ownerReadMode /= 0 if regular && readable then - positive ref fs path + positive reaper fs path else goNext -positive :: IORef Cache -> FileStatus -> GetInfo -positive ref fs path = do - strictAtomicModifyIORef ref $ M.insert bpath entry +positive :: FileCache -> FileStatus -> GetInfo +positive Reaper{..} fs path = do + reaperAdd (bpath,entry) return info where info = FileInfo { @@ -57,20 +59,25 @@ entry = Positive info bpath = pathByteString path -negative :: IORef Cache -> GetInfo -negative ref path = do - strictAtomicModifyIORef ref $ M.insert bpath Negative +negative :: FileCache -> GetInfo +negative Reaper{..} path = do + reaperAdd (bpath,Negative) throwIO (userError "fileInfo") where bpath = pathByteString path ---------------------------------------------------------------- -fileCacheInit :: IO (GetInfo, RemoveInfo) -fileCacheInit = do - ref <- newIORef M.empty - return (fileInfo ref, remover ref) +fileCacheInit :: IO GetInfo +fileCacheInit = mkReaper settings >>= return . fileInfo + where + settings = defaultReaperSettings { + reaperAction = override + , reaperDelay = 10000000 -- 10 seconds + , reaperCons = uncurry M.insert + , reaperNull = M.null + , reaperEmpty = M.empty + } --- atomicModifyIORef is not necessary here. -remover :: IORef Cache -> IO () -remover ref = writeIORef ref M.empty +override :: Cache -> IO (Cache -> Cache) +override _ = return $ const M.empty diff --git a/Program/Mighty/IORef.hs b/Program/Mighty/IORef.hs deleted file mode 100644 --- a/Program/Mighty/IORef.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Program.Mighty.IORef where - -import Data.IORef - ----------------------------------------------------------------- - --- | Strict version of 'atomicModifyIORef'. --- When modifying the IORef, calculation is delayed. --- So, modification is quick and CAS would success. --- After modification, calculation is forced. --- So, no space leak. -strictAtomicModifyIORef :: IORef a -> (a -> a) -> IO () -strictAtomicModifyIORef ref f = do - c <- atomicModifyIORef ref - (\x -> let a = f x -- Lazy application of "f" - in (a, a `seq` ())) -- Lazy application of "seq" - -- The following forces "a `seq` ()", so it also forces "f x". - c `seq` return c diff --git a/Program/Mighty/Network.hs b/Program/Mighty/Network.hs --- a/Program/Mighty/Network.hs +++ b/Program/Mighty/Network.hs @@ -1,44 +1,10 @@ module Program.Mighty.Network ( - listenSocket - , daemonize + daemonize ) where -import Control.Exception import Control.Monad -import qualified Network as N -import Network.BSD -import Network.Socket import System.Exit import System.Posix - ----------------------------------------------------------------- - --- | Open an 'Socket' with 'ReuseAddr' and 'NoDelay' set. -listenSocket :: String -- ^ Service name - -> Int -- ^ A number of backlogs. - -> IO Socket -listenSocket serv backlog = do - proto <- getProtocolNumber "tcp" - let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_PASSIVE] - , addrSocketType = Stream - , addrProtocol = proto } - addrs <- getAddrInfo (Just hints) Nothing (Just serv) - let addrs' = filter (\x -> addrFamily x == AF_INET6) addrs - addr = head $ if null addrs' then addrs else addrs' - listenSocket' addr backlog - -listenSocket' :: AddrInfo -> Int -> IO Socket -listenSocket' addr backlog = bracketOnError setup cleanup $ \sock -> do - setSocketOption sock ReuseAddr 1 - setSocketOption sock NoDelay 1 - bindSocket sock (addrAddress addr) - listen sock backlog - return sock - where - setup = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) - cleanup = N.sClose - ----------------------------------------------------------------- -- | Run a program detaching its terminal. daemonize :: IO () -> IO () diff --git a/Program/Mighty/Parser.hs b/Program/Mighty/Parser.hs --- a/Program/Mighty/Parser.hs +++ b/Program/Mighty/Parser.hs @@ -79,7 +79,7 @@ -- >>> isLeft $ parse trailing "" "X# comments\n" -- True trailing :: Parser () -trailing = () <$ (comment *> newline <|> newline) +trailing = () <$ (spcs *> comment *> newline <|> spcs *> newline) -- | 'Parser' to consume a trailing comment -- diff --git a/Program/Mighty/Route.hs b/Program/Mighty/Route.hs --- a/Program/Mighty/Route.hs +++ b/Program/Mighty/Route.hs @@ -11,12 +11,18 @@ , Dst , Domain , Port + -- * RouteDBRef + , RouteDBRef + , newRouteDBRef + , readRouteDBRef + , writeRouteDBRef ) where import Control.Applicative hiding (many,(<|>)) 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 @@ -108,3 +114,16 @@ 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 diff --git a/Program/Mighty/State.hs b/Program/Mighty/State.hs deleted file mode 100644 --- a/Program/Mighty/State.hs +++ /dev/null @@ -1,120 +0,0 @@ -module Program.Mighty.State ( - -- * Types - Status(..) - , Stater - -- * Creating Stater - , initStater - -- * Accessing Stater - , getConnectionCounter - , getServerStatus - , isRetiring - -- * Modifying Stater - , increment - , decrement - , setMyWarpThreadId - , addAnotherWarpThreadId - , goRetiring - -- * Misc - , ifWarpThreadsAreActive - ) where - -import Control.Applicative -import Control.Concurrent -import Data.IORef -import Program.Mighty.IORef - ----------------------------------------------------------------- - --- | Server status -data Status = Serving | Retiring deriving (Eq, Show) - -data Two a = Zero | One a | Two a a - -data State = State { - connectionCounter :: !Int - , serverStatus :: !Status - , warpThreadId :: !(Two ThreadId) - } - -initialState :: State -initialState = State 0 Serving Zero - ----------------------------------------------------------------- - --- | Reference to a server state. -newtype Stater = Stater (IORef State) - --- | Creating a new 'Stater'. -initStater :: IO Stater -initStater = Stater <$> newIORef initialState - ----------------------------------------------------------------- - -getConnectionCounter :: Stater -> IO Int -getConnectionCounter (Stater sref) = connectionCounter <$> readIORef sref - -increment :: Stater -> IO () -increment (Stater sref) = - strictAtomicModifyIORef sref $ \st -> st { - connectionCounter = connectionCounter st + 1 - } - -decrement :: Stater -> IO () -decrement (Stater sref) = - strictAtomicModifyIORef sref $ \st -> st { - connectionCounter = connectionCounter st - 1 - } - ----------------------------------------------------------------- - -getServerStatus :: Stater -> IO Status -getServerStatus (Stater sref) = serverStatus <$> readIORef sref - -isRetiring :: Stater -> IO Bool -isRetiring stt = (== Retiring) <$> getServerStatus stt - --- | Setting status to 'Retiring'. -goRetiring :: Stater -> IO () -goRetiring (Stater sref) = - strictAtomicModifyIORef sref $ \st -> st { - serverStatus = Retiring - , warpThreadId = Zero - } - ----------------------------------------------------------------- - -getWarpThreadId :: Stater -> IO (Two ThreadId) -getWarpThreadId (Stater sref) = warpThreadId <$> readIORef sref - -setWarpThreadId :: Stater -> Two ThreadId -> IO () -setWarpThreadId (Stater sref) ttids = - strictAtomicModifyIORef sref $ \st -> st { - warpThreadId = ttids - } - -setMyWarpThreadId :: Stater -> IO () -setMyWarpThreadId stt = do - myid <- myThreadId - setWarpThreadId stt (One myid) - -addAnotherWarpThreadId :: Stater -> ThreadId -> IO () -addAnotherWarpThreadId stt aid = do - ttids <- getWarpThreadId stt - case ttids of - One tid -> setWarpThreadId stt (Two tid aid) - _ -> error "addAnotherWarpThreadId" - --- | If Warp threads are active, first terminate them and --- run new 'IO'. -ifWarpThreadsAreActive :: Stater -> IO () -> IO () -ifWarpThreadsAreActive stt act = do - ttids <- getWarpThreadId stt - case ttids of - Zero -> return () - One tid -> do - killThread tid - act - Two tid1 tid2 -> do - killThread tid1 - killThread tid2 - act diff --git a/conf/example.conf b/conf/example.conf --- a/conf/example.conf +++ b/conf/example.conf @@ -1,5 +1,7 @@ # 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 diff --git a/mighttpd2.cabal b/mighttpd2.cabal --- a/mighttpd2.cabal +++ b/mighttpd2.cabal @@ -1,5 +1,5 @@ Name: mighttpd2 -Version: 3.1.3 +Version: 3.2.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -27,7 +27,6 @@ Program.Mighty.ByteString Program.Mighty.Config Program.Mighty.FileCache - Program.Mighty.IORef Program.Mighty.Network Program.Mighty.Parser Program.Mighty.Process @@ -35,9 +34,10 @@ Program.Mighty.Resource Program.Mighty.Route Program.Mighty.Signal - Program.Mighty.State Build-Depends: base >= 4.0 && < 5 , array + , async + , auto-update , blaze-builder , byteorder , bytestring @@ -52,12 +52,13 @@ , network , parsec >= 3 , resourcet + , streaming-commons , unix , unix-time , unordered-containers , wai >= 3.0 , wai-app-file-cgi >= 3.0 - , warp >= 3.0 + , warp >= 3.0.1 Executable mighty Default-Language: Haskell2010 @@ -78,10 +79,11 @@ , conduit-extra , transformers , unix + , streaming-commons , wai >= 3.0 , wai-app-file-cgi >= 3.0 - , wai-logger >= 2.2 - , warp >= 3.0 + , wai-logger >= 2.2.2 + , warp >= 3.0.1 if flag(tls) Build-Depends: tls , warp-tls >= 1.4.1 diff --git a/src/Server.hs b/src/Server.hs --- a/src/Server.hs +++ b/src/Server.hs @@ -2,23 +2,24 @@ module Server (server, defaultDomain, defaultPort) where -import Control.Applicative ((<$>)) -import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent (runInUnboundThread) import Control.Exception (try) -import Control.Monad (void, unless, when) +import Control.Monad (unless, when) import qualified Data.ByteString.Char8 as BS (pack) +import Data.Streaming.Network (bindPortTCP) import Network (Socket, sClose) 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 Network.Wai.Logger #ifdef TLS +import Control.Concurrent.Async (concurrently) import Network.Wai.Handler.WarpTLS #endif @@ -34,18 +35,9 @@ defaultPort :: Int defaultPort = 80 -backlogNumber :: Int -backlogNumber = 2048 - openFileNumber :: Integer openFileNumber = 10000 -oneSecond :: Int -oneSecond = 1000000 - -longTimerInterval :: Int -longTimerInterval = 10 - logBufferSize :: Int logBufferSize = 4 * 1024 * 10 @@ -54,7 +46,6 @@ ---------------------------------------------------------------- -type LogRotator = IO () type LogRemover = IO () ---------------------------------------------------------------- @@ -64,21 +55,23 @@ unlimit openFileNumber svc <- openService opt unless debug writePidFile + rdr <- newRouteDBRef route setGroupUser (opt_user opt) (opt_group opt) logCheck logtype - stt <- initStater - (zdater,zupdater) <- clockDateCacher + (zdater,_) <- clockDateCacher ap <- initLogger FromSocket logtype zdater let lgr = apacheLogger ap - rotator = logRotator ap remover = logRemover ap - (getInfo,cleaner) <- fileCacheInit + getInfo <- fileCacheInit mgr <- getManager opt - let mighty = reload opt rpt svc stt lgr getInfo mgr - setHandlers opt rpt svc stt remover mighty + setHandlers opt rpt svc remover rdr + report rpt "Mighty started" - void . forkIO $ mighty route - mainLoop rpt stt cleaner remover debug rotator zupdater 0 + runInUnboundThread $ mighty opt rpt svc lgr getInfo mgr rdr + report rpt "Mighty retired" + finReporter rpt + remover + exitSuccess where debug = opt_debug_mode opt port = opt_port opt @@ -99,8 +92,8 @@ | debug = LogStdout logBufferSize | otherwise = LogFile logspec logBufferSize -setHandlers :: Option -> Reporter -> Service -> Stater -> LogRemover -> Mighty -> IO () -setHandlers opt rpt svc stt remover mighty = do +setHandlers :: Option -> Reporter -> Service -> LogRemover -> RouteDBRef -> IO () +setHandlers opt rpt svc remover rdr = do setHandler sigStop stopHandler setHandler sigRetire retireHandler setHandler sigInfo infoHandler @@ -113,24 +106,18 @@ closeService svc remover exitImmediately ExitSuccess - retireHandler = Catch $ ifWarpThreadsAreActive stt $ do + retireHandler = Catch $ do report rpt "Mighty retiring" - closeService svc - goRetiring stt - infoHandler = Catch $ do - i <- bshow <$> getConnectionCounter stt - status <- bshow <$> getServerStatus stt - report rpt $ status +++ ": # of connections = " +++ i - reloadHandler = Catch $ ifWarpThreadsAreActive stt $ + 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" - void . forkIO $ mighty newroute ---------------------------------------------------------------- -type Mighty = RouteDB -> IO () - -ifRouteFileIsValid :: Reporter -> Option -> Mighty -> IO () +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 @@ -139,31 +126,28 @@ ---------------------------------------------------------------- -reload :: Option -> Reporter -> Service -> Stater - -> ApacheLogger -> GetInfo -> ConnPool - -> Mighty -reload opt rpt svc stt lgr getInfo _mgr route = reportDo rpt $ do - setMyWarpThreadId stt - let app req = fileCgiApp cspec filespec cgispec revproxyspec route req - case svc of - HttpOnly s -> runSettingsSocket setting s app +mighty :: Option -> Reporter -> Service + -> ApacheLogger -> GetInfo -> ConnPool -> RouteDBRef + -> IO () +mighty opt rpt svc lgr getInfo _mgr rdr = reportDo rpt $ case svc of + HttpOnly s -> runSettingsSocket setting s app #ifdef TLS - HttpsOnly s -> runTLSSocket tlsSetting setting s app - HttpAndHttps s1 s2 -> do - tid <- forkIO $ runSettingsSocket setting s1 app - addAnotherWarpThreadId stt tid - runTLSSocket tlsSetting setting s2 app + HttpsOnly s -> runTLSSocket tlsSetting setting s app + HttpAndHttps s1 s2 -> concurrently + (runSettingsSocket setting s1 app) + (runTLSSocket tlsSetting setting s2 app) #else - _ -> error "never reach" + _ -> error "never reach" #endif where + app req = fileCgiApp cspec filespec cgispec revproxyspec rdr req debug = opt_debug_mode opt - setting = setPort (opt_port opt) - $ setOnException (if debug then printStdout else warpHandler rpt) - $ setOnOpen (\_ -> increment stt >> return True) - $ setOnClose (\_ -> decrement stt) - $ setTimeout (opt_connection_timeout opt) - $ setHost "*" + -- 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) $ setFdCacheDuration (opt_fd_cache_duration opt) defaultSettings serverName = BS.pack $ opt_server_name opt @@ -192,30 +176,6 @@ ---------------------------------------------------------------- -mainLoop :: Reporter -> Stater -> RemoveInfo - -> LogRemover -> Bool -> LogRotator - -> DateCacheUpdater - -> Int -> IO () -mainLoop rpt stt cleaner remover everySecond rotator zupdater sec = do - threadDelay oneSecond - retiring <- isRetiring stt - counter <- getConnectionCounter stt - if retiring && counter == 0 then do - report rpt "Mighty retired" - finReporter rpt - remover - exitSuccess - else do - zupdater - let longTimer = sec == longTimerInterval - when longTimer $ do - cleaner - rotator - let !next = if longTimer then 0 else sec + 1 - mainLoop rpt stt cleaner remover everySecond rotator zupdater next - ----------------------------------------------------------------- - data Service = HttpOnly Socket | HttpsOnly Socket | HttpAndHttps Socket Socket ---------------------------------------------------------------- @@ -223,22 +183,23 @@ openService :: Option -> IO Service openService opt | service == 1 = do - s <- listenSocket httpsPort backlogNumber - debugMessage $ "HTTP/TLS service on port " ++ httpsPort ++ "." + s <- bindPortTCP httpsPort hostpref + debugMessage $ "HTTP/TLS service on port " ++ show httpsPort ++ "." return $ HttpsOnly s | service == 2 = do - s1 <- listenSocket httpPort backlogNumber - s2 <- listenSocket httpsPort backlogNumber - debugMessage $ "HTTP service on port " ++ httpPort ++ " and " - ++ "HTTP/TLS service on port " ++ httpsPort ++ "." + s1 <- bindPortTCP httpPort hostpref + s2 <- bindPortTCP httpsPort hostpref + debugMessage $ "HTTP service on port " ++ show httpPort ++ " and " + ++ "HTTP/TLS service on port " ++ show httpsPort ++ "." return $ HttpAndHttps s1 s2 | otherwise = do - s <- listenSocket httpPort backlogNumber - debugMessage $ "HTTP service on port " ++ httpPort ++ "." + s <- bindPortTCP httpPort hostpref + debugMessage $ "HTTP service on port " ++ show httpPort ++ "." return $ HttpOnly s where - httpPort = show $ opt_port opt - httpsPort = show $ opt_tls_port opt + 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 @@ -248,8 +209,8 @@ ---------------------------------------------------------------- closeService :: Service -> IO () -closeService (HttpOnly s) = sClose s -closeService (HttpsOnly s) = sClose s +closeService (HttpOnly s) = sClose s +closeService (HttpsOnly s) = sClose s closeService (HttpAndHttps s1 s2) = sClose s1 >> sClose s2 ---------------------------------------------------------------- @@ -259,8 +220,9 @@ getManager :: Option -> IO ConnPool getManager opt = H.newManager H.defaultManagerSettings { H.managerConnCount = managerNumber - , H.managerResponseTimeout = if opt_proxy_timeout opt == 0 then - H.managerResponseTimeout H.defaultManagerSettings - else - Just (opt_proxy_timeout opt) + , H.managerResponseTimeout = responseTimeout } + where + responseTimeout + | opt_proxy_timeout opt == 0 = H.managerResponseTimeout H.defaultManagerSettings + | otherwise = Just (opt_proxy_timeout opt) diff --git a/src/WaiApp.hs b/src/WaiApp.hs --- a/src/WaiApp.hs +++ b/src/WaiApp.hs @@ -15,29 +15,31 @@ data Perhaps a = Found a | Redirect | Fail fileCgiApp :: ClassicAppSpec -> FileAppSpec -> CgiAppSpec -> RevProxyAppSpec - -> RouteDB -> Application -fileCgiApp cspec filespec cgispec revproxyspec um req respond = case mmp of - Fail -> do - let st = preconditionFailed412 - liftIO $ logger cspec req' st Nothing - fastResponse respond st defaultHeader "Precondition Failed\r\n" - Redirect -> do - let st = movedPermanently301 - hdr = defaultHeader ++ redirectHeader req' - liftIO $ logger cspec req st Nothing - 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 + -> RouteDBRef -> Application +fileCgiApp cspec filespec cgispec revproxyspec rdr req respond = do + um <- readRouteDBRef rdr + case mmp um of + Fail -> do + let st = preconditionFailed412 + liftIO $ logger cspec req' st Nothing + fastResponse respond st defaultHeader "Precondition Failed\r\n" + Redirect -> do + let st = movedPermanently301 + hdr = defaultHeader ++ redirectHeader req' + liftIO $ logger cspec req st Nothing + 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 path = urlDecode False $ rawPathInfo req - mmp = case getBlock host um of + mmp um = case getBlock host um of Nothing -> Fail Just blk -> getRoute path blk fastResponse resp st hdr body = resp $ responseLBS st hdr body diff --git a/test/ConfigSpec.hs b/test/ConfigSpec.hs --- a/test/ConfigSpec.hs +++ b/test/ConfigSpec.hs @@ -11,4 +11,4 @@ res `shouldBe` ans ans :: Option -ans = Option {opt_port = 80, opt_debug_mode = True, opt_user = "root", opt_group = "root", opt_pid_file = "/var/run/mighty.pid", opt_logging = True, opt_log_file = "/var/log/mighty", opt_log_file_size = 16777216, opt_log_backup_number = 10, opt_index_file = "index.html", opt_index_cgi = "index.cgi", opt_status_file_dir = "/usr/local/share/mighty/status", opt_connection_timeout = 30, opt_fd_cache_duration = 10, opt_server_name = "foo", opt_routing_file = Nothing, opt_tls_port = 443, opt_tls_cert_file = "certificate.pem", opt_tls_key_file = "key.pem", opt_service = 0, opt_report_file = "/tmp/mighty_report", opt_proxy_timeout = 0} +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 = "certificate.pem", opt_tls_key_file = "key.pem", opt_service = 0, opt_report_file = "/tmp/mighty_report", opt_proxy_timeout = 0}