diff --git a/Network/Wai/Handler/Warp/Date.hs b/Network/Wai/Handler/Warp/Date.hs --- a/Network/Wai/Handler/Warp/Date.hs +++ b/Network/Wai/Handler/Warp/Date.hs @@ -18,8 +18,8 @@ import Network.HTTP.Date #if WINDOWS -import Data.Time (UTCTime, formatTime, getCurrentTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import Data.Time (UTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Foreign.C.Types (CTime(..)) #else import System.Posix (epochTime) diff --git a/Network/Wai/Handler/Warp/File.hs b/Network/Wai/Handler/Warp/File.hs --- a/Network/Wai/Handler/Warp/File.hs +++ b/Network/Wai/Handler/Warp/File.hs @@ -12,9 +12,7 @@ import Data.Array ((!)) import Data.ByteString (ByteString) import qualified Data.ByteString as B hiding (pack) -import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Char8 as B (pack, readInteger) -import qualified Data.ByteString.Lazy as L import Network.HTTP.Date import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as H @@ -163,7 +161,7 @@ addContentHeaders hs off len size = hs'' where contentRange = contentRangeHeader off (off + len - 1) size - lengthBS = L.toStrict $ B.toLazyByteString $ B.integerDec len + !lengthBS = B.pack $ show len hs' = (H.hContentLength, lengthBS):( #if MIN_VERSION_http_types(0,9,0) H.hAcceptRanges diff --git a/Network/Wai/Handler/Warp/HTTP2.hs b/Network/Wai/Handler/Warp/HTTP2.hs --- a/Network/Wai/Handler/Warp/HTTP2.hs +++ b/Network/Wai/Handler/Warp/HTTP2.hs @@ -38,7 +38,7 @@ -- fixme: hard coding: 10 replicateM_ 10 $ spawnAction mgr -- Receiver - let mkreq = mkRequest settings addr + let mkreq = mkRequest ii settings addr tid <- forkIO $ frameReceiver ctx mkreq readN -- Sender -- frameSender is the main thread because it ensures to send diff --git a/Network/Wai/Handler/Warp/HTTP2/Request.hs b/Network/Wai/Handler/Warp/HTTP2/Request.hs --- a/Network/Wai/Handler/Warp/HTTP2/Request.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Request.hs @@ -19,6 +19,7 @@ import Data.CaseInsensitive (mk) import Data.IORef (IORef, readIORef, newIORef, writeIORef) import Data.Maybe (isJust) +import qualified Data.Vault.Lazy as Vault #if __GLASGOW_HASKELL__ < 709 import Data.Monoid (mempty) #endif @@ -28,10 +29,13 @@ import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai +import Network.Wai.Internal (Request(..)) import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.ReadInt +import Network.Wai.Handler.Warp.Request (pauseTimeoutKey, getFileInfoKey) +import Network.Wai.Handler.Warp.Types (InternalInfo(..)) import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath) -import Network.Wai.Internal (Request(..)) +import qualified Network.Wai.Handler.Warp.Timeout as Timeout data ValidHeaders = ValidHeaders { vhMethod :: ByteString @@ -43,8 +47,8 @@ type MkReq = ValidHeaders -> IO ByteString -> Request -mkRequest :: S.Settings -> SockAddr -> MkReq -mkRequest settings addr (ValidHeaders m p ma _ hdr) body = req +mkRequest :: InternalInfo -> S.Settings -> SockAddr -> MkReq +mkRequest ii settings addr (ValidHeaders m p ma _ hdr) body = req where (unparsedPath,query) = B8.break (=='?') p path = H.extractPath unparsedPath @@ -61,11 +65,15 @@ , isSecure = True , remoteHost = addr , requestBody = body - , vault = mempty + , vault = vaultValue , requestBodyLength = ChunkedBody -- fixme , requestHeaderHost = ma , requestHeaderRange = lookup hRange hdr } + th = threadHandle ii + vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) + $ Vault.insert getFileInfoKey (fileInfo ii) + Vault.empty ---------------------------------------------------------------- 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,7 +1,4 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -- for GHC 7.4 or earlier module Network.Wai.Handler.Warp.Timeout ( -- ** Types @@ -11,6 +8,7 @@ -- ** Manager , initialize , stopManager + , killManager , withManager -- ** Registration , register @@ -24,25 +22,12 @@ , TimeoutThread (..) ) where -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - -#if MIN_VERSION_base(4,6,0) -import Control.Concurrent (mkWeakThreadId, ThreadId) -#else -import GHC.Conc (ThreadId(..)) -import GHC.Exts (mkWeak#) -import GHC.IO (IO (IO)) -#endif import Control.Concurrent (myThreadId) import qualified Control.Exception as E -import GHC.Weak (Weak (..)) +import Control.Reaper +import Data.Typeable (Typeable) import Network.Wai.Handler.Warp.IORef (IORef) import qualified Network.Wai.Handler.Warp.IORef as I -import System.Mem.Weak (deRefWeak) -import Data.Typeable (Typeable) -import Control.Reaper ---------------------------------------------------------------- @@ -53,7 +38,7 @@ type TimeoutAction = IO () -- | A handle used by 'Manager' -data Handle = Handle TimeoutAction (IORef State) +data Handle = Handle !(IORef TimeoutAction) !(IORef State) data State = Active -- Manager turns it to Inactive. | Inactive -- Manager removes it with timeout action. @@ -70,10 +55,11 @@ , reaperDelay = timeout } where - prune m@(Handle onTimeout iactive) = do - state <- I.atomicModifyIORef' iactive (\x -> (inactivate x, x)) + prune m@(Handle actionRef stateRef) = do + state <- I.atomicModifyIORef' stateRef (\x -> (inactivate x, x)) case state of Inactive -> do + onTimeout <- I.readIORef actionRef onTimeout `E.catch` ignoreAll return Nothing Canceled -> return Nothing @@ -84,38 +70,42 @@ ---------------------------------------------------------------- --- | Stopping timeout manager. +-- | Stopping timeout manager with onTimeout fired. stopManager :: Manager -> IO () stopManager mgr = E.mask_ (reaperStop mgr >>= mapM_ fire) where - fire (Handle onTimeout _) = onTimeout `E.catch` ignoreAll + fire (Handle actionRef _) = do + onTimeout <- I.readIORef actionRef + onTimeout `E.catch` ignoreAll ignoreAll :: E.SomeException -> IO () ignoreAll _ = return () +-- | Killing timeout manager immediately without firing onTimeout. +killManager :: Manager -> IO () +killManager = reaperKill + ---------------------------------------------------------------- -- | Registering a timeout action. register :: Manager -> TimeoutAction -> IO Handle register mgr onTimeout = do - iactive <- I.newIORef Active - let h = Handle onTimeout iactive + actionRef <- I.newIORef onTimeout + stateRef <- I.newIORef Active + let h = Handle actionRef stateRef reaperAdd mgr h return h -- | Registering a timeout action of killing this thread. registerKillThread :: Manager -> IO Handle registerKillThread m = do - wtid <- myThreadId >>= mkWeakThreadId - register m $ killIfExist wtid - --- If ThreadId is hold referred by a strong reference, --- it leaks even after the thread is killed. --- So, let's use a weak reference so that CG can throw ThreadId away. --- deRefWeak checks if ThreadId referenced by the weak reference --- exists. If exists, it means that the thread is alive. -killIfExist :: Weak ThreadId -> TimeoutAction -killIfExist wtid = deRefWeak wtid >>= maybe (return ()) (`E.throwTo` TimeoutThread) + -- If we hold ThreadId, the stack and data of the thread is leaked. + -- If we hold Weak ThreadId, the stack is released. However, its + -- data is still leaked probably because of a bug of GHC. + -- So, let's just use ThreadId and release ThreadId by + -- overriding the timeout action by "cancel". + tid <- myThreadId + register m $ E.throwTo tid TimeoutThread data TimeoutThread = TimeoutThread deriving Typeable @@ -123,29 +113,24 @@ instance Show TimeoutThread where show TimeoutThread = "Thread killed by Warp's timeout reaper" -#if !MIN_VERSION_base(4,6,0) -mkWeakThreadId :: ThreadId -> IO (Weak ThreadId) -mkWeakThreadId t@(ThreadId t#) = IO $ \s -> - case mkWeak# t# t Nothing s of - (# s1, w #) -> (# s1, Weak w #) -#endif - ---------------------------------------------------------------- -- | Setting the state to active. -- 'Manager' turns active to inactive repeatedly. tickle :: Handle -> IO () -tickle (Handle _ iactive) = I.writeIORef iactive Active +tickle (Handle _ stateRef) = I.writeIORef stateRef Active -- | Setting the state to canceled. -- 'Manager' eventually removes this without timeout action. cancel :: Handle -> IO () -cancel (Handle _ iactive) = I.writeIORef iactive Canceled +cancel (Handle actionRef stateRef) = do + I.writeIORef actionRef (return ()) -- ensuring to release ThreadId + I.writeIORef stateRef Canceled -- | Setting the state to paused. -- 'Manager' does not change the value. pause :: Handle -> IO () -pause (Handle _ iactive) = I.writeIORef iactive Paused +pause (Handle _ stateRef) = I.writeIORef stateRef Paused -- | Setting the paused state to active. -- This is an alias to 'tickle'. diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 3.1.10 +Version: 3.1.11 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE @@ -43,7 +43,7 @@ , ghc-prim , http-types >= 0.8.5 , iproute >= 1.3.1 - , http2 >= 1.3 + , http2 >= 1.3 && < 1.4 , simple-sendfile >= 0.2.7 && < 0.3 , unix-compat >= 0.2 , wai >= 3.0.4 && < 3.1 @@ -54,6 +54,7 @@ , word8 , hashable , unordered-containers + , http-date if flag(network-bytestring) Build-Depends: network >= 2.2.1.5 && < 2.2.3 , network-bytestring >= 0.1.3 && < 0.1.4 @@ -104,7 +105,6 @@ Build-Depends: time else Build-Depends: unix - , http-date Other-modules: Network.Wai.Handler.Warp.MultiMap Test-Suite doctest @@ -167,11 +167,11 @@ , word8 , hashable , unordered-containers + , http-date if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd) Cpp-Options: -DSENDFILEFD Build-Depends: unix - , http-date if os(windows) Cpp-Options: -DWINDOWS