warp 1.3.7.5 → 1.3.8
raw patch · 6 files changed
+73/−33 lines, 6 files
Files
- Network/Wai/Handler/Warp.hs +3/−0
- Network/Wai/Handler/Warp/Response.hs +31/−25
- Network/Wai/Handler/Warp/Run.hs +10/−4
- Network/Wai/Handler/Warp/Settings.hs +8/−0
- Network/Wai/Handler/Warp/Timeout.hs +20/−3
- warp.cabal +1/−1
Network/Wai/Handler/Warp.hs view
@@ -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
Network/Wai/Handler/Warp/Response.hs view
@@ -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
Network/Wai/Handler/Warp/Run.hs view
@@ -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
Network/Wai/Handler/Warp/Settings.hs view
@@ -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 ()
Network/Wai/Handler/Warp/Timeout.hs view
@@ -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 ()
warp.cabal view
@@ -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