mighttpd2 3.1.3 → 3.2.0

raw patch · 13 files changed

+149/−328 lines, 13 filesdep +asyncdep +auto-updatedep +streaming-commonsdep ~wai-loggerdep ~warpPVP ok

version bump matches the API change (PVP)

Dependencies added: async, auto-update, streaming-commons

Dependency ranges changed: wai-logger, warp

API changes (from Hackage documentation)

Files

• Program/Mighty.hs +0/−5
• Program/Mighty/Config.hs +10/−6
• Program/Mighty/FileCache.hs +27/−20
• Program/Mighty/IORef.hs +0/−18
• Program/Mighty/Network.hs +1/−35
• Program/Mighty/Parser.hs +1/−1
• Program/Mighty/Route.hs +19/−0
• Program/Mighty/State.hs +0/−120
• conf/example.conf +2/−0
• mighttpd2.cabal +8/−6
• src/Server.hs +58/−96
• src/WaiApp.hs +22/−20
• test/ConfigSpec.hs +1/−1

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 ()

@@ -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 --

@@ -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

@@ -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

@@ -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

@@ -1,5 +1,5 @@ Name:                   mighttpd2-Version:                3.1.3+Version:                3.2.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> 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

@@ -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)

@@ -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

@@ -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}