diff --git a/Network/Wai/Handler/Warp.hs b/Network/Wai/Handler/Warp.hs --- a/Network/Wai/Handler/Warp.hs +++ b/Network/Wai/Handler/Warp.hs @@ -34,6 +34,7 @@ , settingsFdCacheDuration , settingsResourceTPerRequest , settingsBeforeMainLoop + , settingsServerName -- ** Data types , HostPreference (..) -- * Connection @@ -63,6 +64,8 @@ , parseFirst , readInt #endif + -- * Misc + , warpVersion ) where import Network.Wai.Handler.Warp.Request diff --git a/Network/Wai/Handler/Warp/Response.hs b/Network/Wai/Handler/Warp/Response.hs --- a/Network/Wai/Handler/Warp/Response.hs +++ b/Network/Wai/Handler/Warp/Response.hs @@ -21,6 +21,7 @@ import qualified Network.HTTP.Types as H import Network.Wai import Network.Wai.Handler.Warp.ReadInt +import Network.Wai.Handler.Warp.Settings import qualified Network.Wai.Handler.Warp.ResponseHeader as RH import qualified Network.Wai.Handler.Warp.Timeout as T import Network.Wai.Handler.Warp.Types @@ -29,12 +30,13 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -sendResponse :: Cleaner -> Request -> Connection -> Response +sendResponse :: Settings + -> Cleaner -> Request -> Connection -> Response -> ResourceT IO Bool ---------------------------------------------------------------- -sendResponse cleaner req conn (ResponseFile s hs path mpart) = +sendResponse settings cleaner req conn (ResponseFile s hs path mpart) = headerAndLength >>= sendResponse' where th = threadHandle cleaner @@ -49,12 +51,12 @@ sendResponse' (Right (lengthyHeaders, cl)) | hasBody s req = liftIO $ do - lheader <- composeHeader version s lengthyHeaders + lheader <- composeHeader settings version s lengthyHeaders connSendFile conn path beg end (T.tickle th) [lheader] cleaner T.tickle th return isPersist | otherwise = liftIO $ do - composeHeader version s hs >>= connSendAll conn + composeHeader settings version s hs >>= connSendAll conn T.tickle th return isPersist -- FIXME isKeepAlive? where @@ -65,15 +67,15 @@ (isPersist,_) = infoFromRequest req sendResponse' (Left (_ :: SomeException)) = - sendResponse cleaner req conn notFound + sendResponse settings cleaner req conn notFound where notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found" ---------------------------------------------------------------- -sendResponse cleaner req conn (ResponseBuilder s hs b) +sendResponse settings cleaner req conn (ResponseBuilder s hs b) | hasBody s req = liftIO $ do - header <- composeHeaderBuilder version s hs needsChunked + header <- composeHeaderBuilder settings version s hs needsChunked let body | needsChunked = header `mappend` chunkedTransferEncoding b `mappend` chunkedTransferTerminator @@ -83,7 +85,7 @@ T.tickle th return isKeepAlive | otherwise = liftIO $ do - composeHeader version s hs >>= connSendAll conn + composeHeader settings version s hs >>= connSendAll conn T.tickle th return isPersist where @@ -94,14 +96,14 @@ ---------------------------------------------------------------- -sendResponse cleaner req conn (ResponseSource s hs bodyFlush) +sendResponse settings cleaner req conn (ResponseSource s hs bodyFlush) | hasBody s req = do - header <- liftIO $ composeHeaderBuilder version s hs needsChunked + header <- liftIO $ composeHeaderBuilder settings version s hs needsChunked let src = CL.sourceList [header] `mappend` cbody src $$ builderToByteString =$ connSink conn th return isKeepAlive | otherwise = liftIO $ do - composeHeader version s hs >>= connSendAll conn + composeHeader settings version s hs >>= connSendAll conn T.tickle th return isPersist where @@ -193,23 +195,27 @@ addEncodingHeader :: H.ResponseHeaders -> H.ResponseHeaders addEncodingHeader hdrs = (hTransferEncoding, "chunked") : hdrs -addServerHeader :: H.ResponseHeaders -> H.ResponseHeaders -addServerHeader hdrs = case lookup hServer hdrs of - Nothing -> warpVersionHeader : hdrs +addServerHeader :: Settings -> H.ResponseHeaders -> H.ResponseHeaders +addServerHeader settings hdrs = case lookup hServer hdrs of + Nothing -> warpVersionHeader settings : hdrs Just _ -> hdrs -warpVersionHeader :: H.Header -warpVersionHeader = (hServer, ver) - where - ver = B.pack $ "Warp/" ++ warpVersion +warpVersionHeader :: Settings -> H.Header +warpVersionHeader settings = (hServer, settingsServerName settings) ---------------------------------------------------------------- -composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> IO ByteString -composeHeader version s hs = RH.composeHeader version s (addServerHeader hs) +composeHeader :: Settings + -> H.HttpVersion + -> H.Status + -> H.ResponseHeaders + -> IO ByteString +composeHeader settings version s hs = + RH.composeHeader version s + $ addServerHeader settings hs -composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder -composeHeaderBuilder ver s hs True = - fromByteString <$> composeHeader ver s (addEncodingHeader hs) -composeHeaderBuilder ver s hs False = - fromByteString <$> composeHeader ver s hs +composeHeaderBuilder :: Settings -> H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder +composeHeaderBuilder settings ver s hs True = + fromByteString <$> composeHeader settings ver s (addEncodingHeader hs) +composeHeaderBuilder settings ver s hs False = + fromByteString <$> composeHeader settings ver s hs diff --git a/Network/Wai/Handler/Warp/Run.hs b/Network/Wai/Handler/Warp/Run.hs --- a/Network/Wai/Handler/Warp/Run.hs +++ b/Network/Wai/Handler/Warp/Run.hs @@ -133,8 +133,6 @@ -- Since 1.3.5 runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO () runSettingsConnectionMaker set getConn app = do - tm <- maybe (T.initialize $ settingsTimeout set * 1000000) return - $ settingsManager set #if SENDFILEFD let duration = settingsFdCacheDuration set fc <- case duration of @@ -159,7 +157,7 @@ -- First mask all exceptions in the main loop. This is necessary to ensure -- that no async exception is throw between the call to getConnLoop and the -- registering of connClose. - mask_ . forever $ do + withTimeoutManager $ \tm -> mask_ . forever $ do -- Allow async exceptions before receiving the next connection maker. allowInterrupt @@ -220,6 +218,14 @@ onOpen = settingsOnOpen set onClose = settingsOnClose set + withTimeoutManager f = + case settingsManager set of + Nothing -> bracket + (T.initialize $ settingsTimeout set * 1000000) + T.stopManager + f + Just tm -> f tm + serveConnection :: Settings -> Cleaner -> Port -> Application -> Connection -> SockAddr-> IO () @@ -244,7 +250,7 @@ res <- app env liftIO $ T.resume th - sendResponse cleaner env conn res + sendResponse settings cleaner env conn res -- flush the rest of the request body requestBody env $$ CL.sinkNull diff --git a/Network/Wai/Handler/Warp/Settings.hs b/Network/Wai/Handler/Warp/Settings.hs --- a/Network/Wai/Handler/Warp/Settings.hs +++ b/Network/Wai/Handler/Warp/Settings.hs @@ -3,6 +3,7 @@ import Control.Exception import Control.Monad import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import Data.Conduit import Data.Conduit.Network (HostPreference (HostIPv4)) import Network.Wai @@ -39,6 +40,12 @@ -- Default: do nothing. -- -- Since 1.3.6 + , settingsServerName :: S.ByteString + -- ^ Server name to be sent in the Server header. + -- + -- Default: Warp\//version/ + -- + -- Since 1.3.8 } -- | The default settings for the Warp server. See the individual settings for @@ -61,6 +68,7 @@ , settingsFdCacheDuration = 10 , settingsResourceTPerRequest = True , settingsBeforeMainLoop = return () + , settingsServerName = S8.pack $ "Warp/" ++ warpVersion } where go :: InvalidRequest -> IO () diff --git a/Network/Wai/Handler/Warp/Timeout.hs b/Network/Wai/Handler/Warp/Timeout.hs --- a/Network/Wai/Handler/Warp/Timeout.hs +++ b/Network/Wai/Handler/Warp/Timeout.hs @@ -1,9 +1,12 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE UnboxedTuples, MagicHash #-} module Network.Wai.Handler.Warp.Timeout ( Manager , Handle , initialize + , stopManager , register , registerKillThread , tickle @@ -28,8 +31,7 @@ import Control.Monad (forever, void) import qualified Data.IORef as I import System.IO.Unsafe (unsafePerformIO) - --- FIXME implement stopManager +import Data.Typeable (Typeable) -- | A timeout manager newtype Manager = Manager (I.IORef [Handle]) @@ -48,13 +50,15 @@ initialize :: Int -> IO Manager initialize timeout = do ref <- I.newIORef [] - void . forkIO $ forever $ do + void . forkIO $ E.handle ignoreStop $ forever $ do threadDelay timeout ms <- I.atomicModifyIORef ref (\x -> ([], x)) ms' <- go ms id I.atomicModifyIORef ref (\x -> (ms' x, ())) return $ Manager ref where + ignoreStop TimeoutManagerStopped = return () + go [] front = return front go (m@(Handle onTimeout iactive):rest) front = do state <- I.atomicModifyIORef iactive (\x -> (go' x, x)) @@ -66,6 +70,19 @@ _ -> go rest (front . (:) m) go' Active = Inactive go' x = x + +data TimeoutManagerStopped = TimeoutManagerStopped + deriving (Show, Typeable) +instance E.Exception TimeoutManagerStopped + +stopManager :: Manager -> IO () +stopManager (Manager ihandles) = E.mask_ $ do + -- Put an undefined value in the IORef to kill the worker thread (yes, it's + -- a bit of a hack) + !handles <- I.atomicModifyIORef ihandles $ \h -> (E.throw TimeoutManagerStopped, h) + mapM_ go handles + where + go (Handle onTimeout _) = onTimeout `E.catch` ignoreAll ignoreAll :: E.SomeException -> IO () ignoreAll _ = return () diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 1.3.7.5 +Version: 1.3.8 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE