warp 3.2.27 → 3.2.28
raw patch · 23 files changed
+327/−433 lines, 23 filesdep +time-managerdep ~base
Dependencies added: time-manager
Dependency ranges changed: base
Files
- ChangeLog.md +10/−0
- Network/Wai/Handler/Warp.hs +1/−1
- Network/Wai/Handler/Warp/FdCache.hs +18/−22
- Network/Wai/Handler/Warp/FileInfoCache.hs +19/−22
- Network/Wai/Handler/Warp/HTTP2.hs +4/−4
- Network/Wai/Handler/Warp/HTTP2/Manager.hs +1/−1
- Network/Wai/Handler/Warp/HTTP2/Receiver.hs +35/−15
- Network/Wai/Handler/Warp/HTTP2/Request.hs +4/−8
- Network/Wai/Handler/Warp/HTTP2/Sender.hs +5/−5
- Network/Wai/Handler/Warp/HTTP2/Types.hs +51/−10
- Network/Wai/Handler/Warp/HTTP2/Worker.hs +8/−10
- Network/Wai/Handler/Warp/HashMap.hs +24/−15
- Network/Wai/Handler/Warp/Internal.hs +3/−2
- Network/Wai/Handler/Warp/MultiMap.hs +55/−44
- Network/Wai/Handler/Warp/Request.hs +6/−10
- Network/Wai/Handler/Warp/Response.hs +3/−3
- Network/Wai/Handler/Warp/Run.hs +23/−26
- Network/Wai/Handler/Warp/Settings.hs +1/−1
- Network/Wai/Handler/Warp/Timeout.hs +0/−153
- Network/Wai/Handler/Warp/Types.hs +2/−31
- test/FdCacheSpec.hs +1/−1
- test/RunSpec.hs +11/−19
- warp.cabal +42/−30
ChangeLog.md view
@@ -1,3 +1,13 @@+## 3.2.28++* Using the Strict and StrictData language extensions for GHC >8.+ [#752](https://github.com/yesodweb/wai/pull/752)+* System.TimeManager is now in a separate package: time-manager.+ [#750](https://github.com/yesodweb/wai/pull/750)+* Fixing a bug of ALPN.+* Introducing the half closed state for HTTP/2.+ [#717](https://github.com/yesodweb/wai/pull/717)+ ## 3.2.27 * Internally, use `lookupEnv` instead of `getEnvironment` to get the
Network/Wai/Handler/Warp.hs view
@@ -124,6 +124,7 @@ import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai (Request, Response, vault)+import System.TimeManager import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data)@@ -133,7 +134,6 @@ import Network.Wai.Handler.Warp.Response (warpVersion) import Network.Wai.Handler.Warp.Run import Network.Wai.Handler.Warp.Settings-import Network.Wai.Handler.Warp.Timeout import Network.Wai.Handler.Warp.Types hiding (getFileInfo) import Network.Wai.Handler.Warp.WithApplication
Network/Wai/Handler/Warp/FdCache.hs view
@@ -17,26 +17,24 @@ import Control.Exception (bracket) import Control.Reaper import Data.IORef-import Network.Wai.Handler.Warp.MultiMap+import Network.Wai.Handler.Warp.MultiMap as MM import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd, FdOption(CloseOnExec), setFdOption) #endif import System.Posix.Types (Fd) ---------------------------------------------------------------- -type Hash = Int- -- | An action to activate a Fd cache entry. type Refresh = IO () -getFdNothing :: Hash -> FilePath -> IO (Maybe Fd, Refresh)-getFdNothing _ _ = return (Nothing, return ())+getFdNothing :: FilePath -> IO (Maybe Fd, Refresh)+getFdNothing _ = return (Nothing, return ()) ---------------------------------------------------------------- -- | Creating 'MutableFdCache' and executing the action in the second -- argument. The first argument is a cache duration in second.-withFdCache :: Int -> ((Hash -> FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a+withFdCache :: Int -> ((FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a #ifdef WINDOWS withFdCache _ action = action getFdNothing #else@@ -65,7 +63,7 @@ ---------------------------------------------------------------- -data FdEntry = FdEntry !FilePath !Fd !MutableStatus+data FdEntry = FdEntry !Fd !MutableStatus openFile :: FilePath -> IO Fd openFile path = do@@ -77,25 +75,23 @@ closeFile = closeFd newFdEntry :: FilePath -> IO FdEntry-newFdEntry path = FdEntry path <$> openFile path <*> newActiveStatus+newFdEntry path = FdEntry <$> openFile path <*> newActiveStatus setFileCloseOnExec :: Fd -> IO () setFileCloseOnExec fd = setFdOption fd CloseOnExec True ---------------------------------------------------------------- -type FdCache = MMap FdEntry+type FdCache = MultiMap FdEntry -- | Mutable Fd cacher.-newtype MutableFdCache = MutableFdCache (Reaper FdCache (Hash, FdEntry))+newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath,FdEntry)) fdCache :: MutableFdCache -> IO FdCache fdCache (MutableFdCache reaper) = reaperRead reaper -look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)-look mfc path key = searchWith key check <$> fdCache mfc- where- check (FdEntry path' _ _) = path == path'+look :: MutableFdCache -> FilePath -> IO (Maybe FdEntry)+look mfc path = MM.lookup path <$> fdCache mfc ---------------------------------------------------------------- @@ -116,7 +112,7 @@ new <- pruneWith old prune return $ merge new where- prune (FdEntry _ fd mst) = status mst >>= act+ prune (_,FdEntry fd mst) = status mst >>= act where act Active = inactive mst >> return True act Inactive = closeFd fd >> return False@@ -126,21 +122,21 @@ terminate :: MutableFdCache -> IO () terminate (MutableFdCache reaper) = do !t <- reaperStop reaper- mapM_ closeIt $ toList t+ mapM_ (closeIt . snd) $ toList t where- closeIt (FdEntry _ fd _) = closeFd fd+ closeIt (FdEntry fd _) = closeFd fd ---------------------------------------------------------------- -- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.-getFd :: MutableFdCache -> Hash -> FilePath -> IO (Maybe Fd, Refresh)-getFd mfc@(MutableFdCache reaper) h path = look mfc path h >>= get+getFd :: MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh)+getFd mfc@(MutableFdCache reaper) path = look mfc path >>= get where get Nothing = do- ent@(FdEntry _ fd mst) <- newFdEntry path- reaperAdd reaper (h, ent)+ ent@(FdEntry fd mst) <- newFdEntry path+ reaperAdd reaper (path,ent) return (Just fd, refresh mst)- get (Just (FdEntry _ fd mst)) = do+ get (Just (FdEntry fd mst)) = do refresh mst return (Just fd, refresh mst) #endif
Network/Wai/Handler/Warp/FileInfoCache.hs view
@@ -2,7 +2,6 @@ module Network.Wai.Handler.Warp.FileInfoCache ( FileInfo(..)- , Hash , withFileInfoCache , getInfo -- test purpose only ) where@@ -18,8 +17,6 @@ ---------------------------------------------------------------- -type Hash = Int- -- | File information. data FileInfo = FileInfo { fileInfoName :: !FilePath@@ -29,8 +26,8 @@ } deriving (Eq, Show) data Entry = Negative | Positive FileInfo-type Cache = HashMap FilePath Entry-type FileInfoCache = Reaper Cache (Int,FilePath,Entry)+type Cache = HashMap Entry+type FileInfoCache = Reaper Cache (FilePath,Entry) ---------------------------------------------------------------- @@ -54,29 +51,29 @@ else throwIO (userError "FileInfoCache:getInfo") -getInfoNaive :: Hash -> FilePath -> IO FileInfo-getInfoNaive _ = getInfo+getInfoNaive :: FilePath -> IO FileInfo+getInfoNaive = getInfo ---------------------------------------------------------------- -getAndRegisterInfo :: FileInfoCache -> Hash -> FilePath -> IO FileInfo-getAndRegisterInfo reaper@Reaper{..} h path = do+getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo+getAndRegisterInfo reaper@Reaper{..} path = do cache <- reaperRead- case M.lookup h path cache of+ case M.lookup path cache of Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo") Just (Positive x) -> return x- Nothing -> positive reaper h path- `E.onException` negative reaper h path+ Nothing -> positive reaper path+ `E.onException` negative reaper path -positive :: FileInfoCache -> Hash -> FilePath -> IO FileInfo-positive Reaper{..} h path = do+positive :: FileInfoCache -> FilePath -> IO FileInfo+positive Reaper{..} path = do info <- getInfo path- reaperAdd (h, path, Positive info)+ reaperAdd (path, Positive info) return info -negative :: FileInfoCache -> Hash -> FilePath -> IO FileInfo-negative Reaper{..} h path = do- reaperAdd (h, path,Negative)+negative :: FileInfoCache -> FilePath -> IO FileInfo+negative Reaper{..} path = do+ reaperAdd (path, Negative) throwIO (userError "FileInfoCache:negative") ----------------------------------------------------------------@@ -85,7 +82,7 @@ -- and executing the action in the second argument. -- The first argument is a cache duration in second. withFileInfoCache :: Int- -> ((Hash -> FilePath -> IO FileInfo) -> IO a)+ -> ((FilePath -> IO FileInfo) -> IO a) -> IO a withFileInfoCache 0 action = action getInfoNaive withFileInfoCache duration action =@@ -93,14 +90,14 @@ terminate (action . getAndRegisterInfo) -initialize :: Hash -> IO FileInfoCache+initialize :: Int -> IO FileInfoCache initialize duration = mkReaper settings where settings = defaultReaperSettings { reaperAction = override , reaperDelay = duration- , reaperCons = \(h,k,v) -> M.insert h k v- , reaperNull = M.null+ , reaperCons = \(path,v) -> M.insert path v+ , reaperNull = M.isEmpty , reaperEmpty = M.empty }
Network/Wai/Handler/Warp/HTTP2.hs view
@@ -22,8 +22,8 @@ ---------------------------------------------------------------- -http2 :: Connection -> InternalInfo1 -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()-http2 conn ii1 addr transport settings readN app = do+http2 :: Connection -> InternalInfo -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()+http2 conn ii addr transport settings readN app = do checkTLS ok <- checkPreface when ok $ do@@ -40,8 +40,8 @@ -- context switches happen. replicateM_ 3 $ spawnAction mgr -- Receiver- let mkreq = mkRequest ii1 settings addr- tid <- forkIO $ frameReceiver ctx mkreq readN+ let mkreq = mkRequest ii settings addr+ tid <- forkIO $ frameReceiver ctx ii mkreq readN -- Sender -- frameSender is the main thread because it ensures to send -- a goway frame.
Network/Wai/Handler/Warp/HTTP2/Manager.hs view
@@ -19,10 +19,10 @@ import Data.IORef import Data.Set (Set) import qualified Data.Set as Set+import qualified System.TimeManager as T import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Settings-import qualified Network.Wai.Handler.Warp.Timeout as T ----------------------------------------------------------------
Network/Wai/Handler/Warp/HTTP2/Receiver.hs view
@@ -27,8 +27,8 @@ ---------------------------------------------------------------- -frameReceiver :: Context -> MkReq -> (BufSize -> IO ByteString) -> IO ()-frameReceiver ctx mkreq recvN = loop 0 `E.catch` sendGoaway+frameReceiver :: Context -> InternalInfo -> MkReq -> (BufSize -> IO ByteString) -> IO ()+frameReceiver ctx ii mkreq recvN = loop 0 `E.catch` sendGoaway where Context{ http2settings , streamTable@@ -109,8 +109,8 @@ PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl checkPriority newpri streamId return True -- just ignore this frame- Just strm@Stream{streamState,streamPrecedence} -> do- state <- readIORef streamState+ Just strm@Stream{streamPrecedence} -> do+ state <- readStreamState strm state' <- stream ftyp header pl ctx state strm case state' of Open (NoBody tbl@(_,reqvt) pri) -> do@@ -119,8 +119,8 @@ when (just mcl (/= (0 :: Int))) $ E.throwIO $ StreamError ProtocolError streamId writeIORef streamPrecedence $ toPrecedence pri- writeIORef streamState HalfClosed- (!req, !ii) <- mkreq tbl (Just 0, return "")+ halfClosedRemote ctx strm+ !req <- mkreq tbl (Just 0, return "") atomically $ writeTQueue inputQ $ Input strm req reqvt ii Open (HasBody tbl@(_,reqvt) pri) -> do resetContinued@@ -128,17 +128,20 @@ let !mcl = readInt <$> getHeaderValue tokenContentLength reqvt writeIORef streamPrecedence $ toPrecedence pri bodyLength <- newIORef 0- writeIORef streamState $ Open (Body q mcl bodyLength)+ setStreamState ctx strm $ Open (Body q mcl bodyLength) readQ <- newReadBody q bodySource <- mkSource readQ- (!req, !ii) <- mkreq tbl (mcl, readSource bodySource)+ !req <- mkreq tbl (mcl, readSource bodySource) atomically $ writeTQueue inputQ $ Input strm req reqvt ii s@(Open Continued{}) -> do setContinued- writeIORef streamState s- s -> do -- Idle, Open Body, HalfClosed, Closed+ setStreamState ctx strm s+ HalfClosedRemote -> do resetContinued- writeIORef streamState s+ halfClosedRemote ctx strm+ s -> do -- Idle, Open Body, Closed+ resetContinued+ setStreamState ctx strm s return True where setContinued = writeIORef continued (Just streamId)@@ -155,8 +158,8 @@ case mstrm0 of js@(Just strm0) -> do when (ftyp == FrameHeaders) $ do- st <- readIORef $ streamState strm0- when (isHalfClosed st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half closed"+ st <- readStreamState strm0+ when (isHalfClosedRemote st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half or fully closed stream" -- Priority made an idele stream when (isIdle st) $ opened ctx strm0 return js@@ -286,12 +289,29 @@ let !endOfStream = testEndStream flags if endOfStream then do atomically $ writeTQueue q ""- return HalfClosed+ return HalfClosedRemote else -- we don't support continuation here. E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported" +-- ignore data-frame except for flow-control when we're done locally stream FrameData+ FrameHeader{flags,payloadLength}+ _bs+ Context{controlQ} s@(HalfClosedLocal _)+ Stream{streamNumber} = do+ let !endOfStream = testEndStream flags+ when (payloadLength /= 0) $ do+ let !frame1 = windowUpdateFrame 0 payloadLength+ !frame2 = windowUpdateFrame streamNumber payloadLength+ !frame = frame1 `BS.append` frame2+ enqueueControl controlQ $ CFrame frame+ if endOfStream then do+ return HalfClosedRemote+ else+ return s++stream FrameData header@FrameHeader{flags,payloadLength,streamId} bs Context{controlQ} s@(Open (Body q mcl bodyLength))@@ -312,7 +332,7 @@ Nothing -> return () Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId atomically $ writeTQueue q ""- return HalfClosed+ return HalfClosedRemote else return s
Network/Wai/Handler/Warp/HTTP2/Request.hs view
@@ -22,23 +22,22 @@ import System.IO.Unsafe (unsafePerformIO) import Network.Wai.Handler.Warp.HTTP2.Types-import Network.Wai.Handler.Warp.HashMap (hashByteString) import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Request (getFileInfoKey) import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath) import Network.Wai.Handler.Warp.Types -type MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request,InternalInfo)+type MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request) -mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq+mkRequest :: InternalInfo -> S.Settings -> SockAddr -> MkReq mkRequest ii1 settings addr (reqths,reqvt) (bodylen,body) = do ref <- newIORef Nothing mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) -mkRequest' :: InternalInfo1 -> S.Settings -> SockAddr+mkRequest' :: InternalInfo -> S.Settings -> SockAddr -> IORef (Maybe HTTP2Data) -> MkReq-mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) = return (req,ii)+mkRequest' ii settings addr ref (reqths,reqvt) (bodylen,body) = return req where !req = Request { requestMethod = colonMethod@@ -77,9 +76,6 @@ (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth) !path = H.extractPath unparsedPath !rawPath = if S.settingsNoParsePath settings then unparsedPath else path- !h = hashByteString rawPath- -- timeout handler must be overwritten with worker's one.- !ii = toInternalInfo ii1 h !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii) $ Vault.insert getHTTP2DataKey (readIORef ref) $ Vault.insert setHTTP2DataKey (writeIORef ref)
Network/Wai/Handler/Warp/HTTP2/Sender.hs view
@@ -22,7 +22,7 @@ #else import Network.Wai.Handler.Warp.FdCache import Network.Wai.Handler.Warp.SendFile (positionRead)-import qualified Network.Wai.Handler.Warp.Timeout as T+import qualified System.TimeManager as T #endif import Network.Wai.Handler.Warp.Buffer@@ -137,7 +137,7 @@ off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen case rspn of RspnNobody _ _ -> do- closed ctx strm Finished+ halfClosedLocal ctx strm Finished return off RspnFile _ _ path mpart -> do -- Data frame payload@@ -174,8 +174,8 @@ output _ _ _ = undefined -- never reach outputOrEnqueueAgain out off = E.handle resetStream $ do- state <- readIORef $ streamState strm- if isClosed state then+ state <- readStreamState strm+ if isHalfClosedLocal state then return off else case out of Output _ _ _ wait _ OWait -> do@@ -292,7 +292,7 @@ handleEndOfBody True off0 noTrailers trailers = do off1 <- handleTrailers noTrailers off0 trailers void tell- closed ctx strm Finished+ halfClosedLocal ctx strm Finished return off1 handleEndOfBody False off0 _ _ = return off0
Network/Wai/Handler/Warp/HTTP2/Types.hs view
@@ -33,7 +33,7 @@ where useHTTP2 = case tlsNegotiatedProtocol tls of Nothing -> False- Just proto -> "h2-" `BS.isPrefixOf` proto+ Just proto -> "h2" `BS.isPrefixOf` proto ---------------------------------------------------------------- @@ -166,7 +166,8 @@ data StreamState = Idle | Open !OpenState- | HalfClosed+ | HalfClosedRemote+ | HalfClosedLocal !ClosedCode | Closed !ClosedCode | Reserved @@ -178,10 +179,16 @@ isOpen Open{} = True isOpen _ = False -isHalfClosed :: StreamState -> Bool-isHalfClosed HalfClosed = True-isHalfClosed _ = False+isHalfClosedRemote :: StreamState -> Bool+isHalfClosedRemote HalfClosedRemote = True+isHalfClosedRemote (Closed _) = True+isHalfClosedRemote _ = False +isHalfClosedLocal :: StreamState -> Bool+isHalfClosedLocal (HalfClosedLocal _) = True+isHalfClosedLocal (Closed _) = True+isHalfClosedLocal _ = False+ isClosed :: StreamState -> Bool isClosed Closed{} = True isClosed _ = False@@ -189,7 +196,8 @@ instance Show StreamState where show Idle = "Idle" show Open{} = "Open"- show HalfClosed = "HalfClosed"+ show HalfClosedRemote = "HalfClosedRemote"+ show (HalfClosedLocal e) = "HalfClosedLocal: " ++ show e show (Closed e) = "Closed: " ++ show e show Reserved = "Reserved" @@ -221,16 +229,49 @@ ---------------------------------------------------------------- +{-# INLINE readStreamState #-}+readStreamState :: Stream -> IO StreamState+readStreamState Stream{streamState} =+ readIORef streamState++{-# INLINE setStreamState #-}+setStreamState :: Context -> Stream -> StreamState -> IO ()+setStreamState _ Stream{streamState} val = writeIORef streamState val+ opened :: Context -> Stream -> IO ()-opened Context{concurrency} Stream{streamState} = do+opened ctx@Context{concurrency} strm = do atomicModifyIORef' concurrency (\x -> (x+1,()))- writeIORef streamState (Open JustOpened)+ setStreamState ctx strm (Open JustOpened) +halfClosedRemote :: Context -> Stream -> IO ()+halfClosedRemote ctx stream@Stream{streamState} = do+ !closingCode <- atomicModifyIORef streamState closeHalf+ case closingCode of+ Nothing -> return ()+ Just cc -> closed ctx stream cc+ where+ closeHalf :: StreamState -> (StreamState, Maybe ClosedCode)+ closeHalf x@(Closed _) = (x, Nothing)+ closeHalf (HalfClosedLocal cc) = (Closed cc, Just cc)+ closeHalf _ = (HalfClosedRemote, Nothing)++halfClosedLocal :: Context -> Stream -> ClosedCode -> IO ()+halfClosedLocal ctx stream@Stream{streamState} cc = do+ shouldFinalize <- atomicModifyIORef streamState closeHalf+ when shouldFinalize $+ closed ctx stream cc+ where+ closeHalf :: StreamState -> (StreamState, Bool)+ closeHalf x@(Closed _) = (x, False)+ closeHalf HalfClosedRemote = (Closed cc, True)+ closeHalf _ = (HalfClosedLocal cc, False)+ closed :: Context -> Stream -> ClosedCode -> IO ()-closed Context{concurrency,streamTable} Stream{streamState,streamNumber} cc = do+closed ctx@Context{concurrency,streamTable} strm@Stream{streamNumber} cc = do remove streamTable streamNumber+ -- TODO: prevent double-counting atomicModifyIORef' concurrency (\x -> (x-1,()))- writeIORef streamState (Closed cc) -- anyway+ setStreamState ctx strm (Closed cc) -- anyway ----------------------------------------------------------------
Network/Wai/Handler/Warp/HTTP2/Worker.hs view
@@ -23,8 +23,8 @@ import Network.HTTP2 import Network.HTTP2.Priority import Network.Wai-import qualified Network.Wai.Handler.Warp.Timeout as Timeout-import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..))+import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..), getRequestBodyChunk)+import qualified System.TimeManager as T import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.HTTP2.EncodeFrame@@ -36,7 +36,6 @@ import Network.Wai.Handler.Warp.Request (pauseTimeoutKey) import qualified Network.Wai.Handler.Warp.Response as R import qualified Network.Wai.Handler.Warp.Settings as S-import qualified Network.Wai.Handler.Warp.Timeout as T import Network.Wai.Handler.Warp.Types ----------------------------------------------------------------@@ -45,6 +44,7 @@ -- This type implements the second argument (Response -> IO ResponseReceived) -- with extra arguments. type Responder = InternalInfo+ -> T.Handle -> ValueTable -- for Request -> ThreadContinue -> Stream@@ -119,7 +119,7 @@ -- They also pass 'Response's from 'Application's to this function. -- This function enqueues commands for the HTTP/2 sender. response :: S.Settings -> Context -> Manager -> Responder-response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = E.handle (E.throwIO . ExceptionInsideResponseBody) $ case rsp of+response settings ctx@Context{outputQ} mgr ii th reqvt tconf strm req rsp = E.handle (E.throwIO . ExceptionInsideResponseBody) $ case rsp of ResponseStream s0 hs0 strmbdy | noBody s0 -> responseNoBody s0 hs0 | isHead -> responseNoBody s0 hs0@@ -142,7 +142,6 @@ noBody = not . R.hasBody !isHead = requestMethod req == H.methodHead !logger = S.settingsLogger settings- !th = threadHandle ii sid = streamNumber strm !h2data = getHTTP2Data req @@ -246,21 +245,20 @@ setStreamInfo sinfo inp T.resume th T.tickle th- let !ii' = ii { threadHandle = th }- !body = requestBody req+ let !body = getRequestBodyChunk req !body' = do T.pause th bs <- body T.resume th return bs- !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) $ vault req+ !vaultValue = Vault.insert pauseTimeoutKey (T.pause th) $ vault req !req' = req { vault = vaultValue, requestBody = body' }- mr <- E.try $ app req' $ responder ii' reqvt tcont strm req'+ mr <- E.try $ app req' $ responder ii th reqvt tcont strm req' case mr of Right ok -> return ok Left e@(SomeException _) | Just (ExceptionInsideResponseBody e') <- E.fromException e -> E.throwIO e'- | otherwise -> responder ii' reqvt tcont strm req' (S.settingsOnExceptionResponse set e)+ | otherwise -> responder ii th reqvt tcont strm req' (S.settingsOnExceptionResponse set e) cont1 <- case ex of Right ResponseReceived -> return True Left e@(SomeException _)
Network/Wai/Handler/Warp/HashMap.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE BangPatterns #-}+ module Network.Wai.Handler.Warp.HashMap where import Data.Hashable (hash)@@ -7,27 +9,34 @@ import qualified Data.Map.Strict as M import Prelude hiding (lookup) -import Network.Wai.Handler.Warp.Imports hiding (insert, lookup)+---------------------------------------------------------------- -type Hash = Int-newtype HashMap k v = HashMap (IntMap (Map k v))+-- | 'HashMap' is used for cache of file information.+-- Hash values of file pathes are used as outer keys.+-- Because negative entries are also contained,+-- a bad guy can intentionally cause the hash collison.+-- So, 'Map' is used internally to prevent+-- the hash collision attack.+newtype HashMap v = HashMap (IntMap (Map FilePath v)) -hashByteString :: ByteString -> Hash-hashByteString = hash+---------------------------------------------------------------- -empty :: HashMap k v+empty :: HashMap v empty = HashMap I.empty -null :: HashMap k v -> Bool-null (HashMap hm) = I.null hm+isEmpty :: HashMap v -> Bool+isEmpty (HashMap hm) = I.null hm -insert :: Ord k => Hash -> k -> v -> HashMap k v -> HashMap k v-insert h k v (HashMap hm) = HashMap $ I.insertWith f h m hm+----------------------------------------------------------------++insert :: FilePath -> v -> HashMap v -> HashMap v+insert path v (HashMap hm) = HashMap $ I.insertWith f h m hm where- m = M.singleton k v+ !h = hash path+ !m = M.singleton path v f = M.union -- fimxe-{-# SPECIALIZE insert :: Hash -> String -> v -> HashMap String v -> HashMap String v #-} -lookup :: Ord k => Hash -> k -> HashMap k v -> Maybe v-lookup h k (HashMap hm) = I.lookup h hm >>= M.lookup k-{-# SPECIALIZE lookup :: Hash -> String -> HashMap String v -> Maybe v #-}+lookup :: FilePath -> HashMap v -> Maybe v+lookup path (HashMap hm) = I.lookup h hm >>= M.lookup path+ where+ !h = hash path
Network/Wai/Handler/Warp/Internal.hs view
@@ -53,7 +53,7 @@ -- resumed as soon as we return from user code. -- -- * Every time data is successfully sent to the client, the timeout is tickled.- , module Network.Wai.Handler.Warp.Timeout+ , module System.TimeManager -- * File descriptor cache , module Network.Wai.Handler.Warp.FdCache -- * File information cache@@ -69,6 +69,8 @@ , windowsThreadBlockHack ) where +import System.TimeManager+ import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Date import Network.Wai.Handler.Warp.FdCache@@ -80,6 +82,5 @@ import Network.Wai.Handler.Warp.Run import Network.Wai.Handler.Warp.SendFile import Network.Wai.Handler.Warp.Settings-import Network.Wai.Handler.Warp.Timeout import Network.Wai.Handler.Warp.Types import Network.Wai.Handler.Warp.Windows
Network/Wai/Handler/Warp/MultiMap.hs view
@@ -1,100 +1,111 @@+{-# LANGUAGE BangPatterns #-}+ module Network.Wai.Handler.Warp.MultiMap (- MMap+ MultiMap , isEmpty , empty , singleton , insert- , search- , searchWith+ , Network.Wai.Handler.Warp.MultiMap.lookup , pruneWith , toList , merge ) where +import Data.Hashable (hash) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as I-import qualified Data.List.NonEmpty as NE import Data.Semigroup import Prelude -- Silence redundant import warnings -import Network.Wai.Handler.Warp.Imports hiding ((<>), union, empty, insert)- ---------------------------------------------------------------- -type MMap v = IntMap (NonEmpty v)+-- | 'MultiMap' is used for cache of file descriptors.+-- Since multiple threads would open file descriptors for+-- the same file simultaneously, multiple entries must+-- be contained for the file.+-- Since hash values of file pathes are used as outer keys,+-- collison would happen for multiple file pathes.+-- Becase only positive entries are contained,+-- a bad guy cannot be cause the hash collision intentinally.+-- So, lists are good enough.+newtype MultiMap v = MultiMap (IntMap [(FilePath,v)]) ---------------------------------------------------------------- -- | O(1)-isEmpty :: MMap v -> Bool-isEmpty = I.null+empty :: MultiMap v+empty = MultiMap $ I.empty -- | O(1)-empty :: MMap v-empty = I.empty+isEmpty :: MultiMap v -> Bool+isEmpty (MultiMap mm) = I.null mm ---------------------------------------------------------------- -- | O(1)-singleton :: Int -> v -> MMap v-singleton k v = I.singleton k (v :| [])+singleton :: FilePath -> v -> MultiMap v+singleton path v = MultiMap mm+ where+ !h = hash path+ !mm = I.singleton h [(path,v)] ---------------------------------------------------------------- --- | O(log n)-search :: Int -> MMap v -> Maybe v-search k m = case I.lookup k m of+-- | O(N)+lookup :: FilePath -> MultiMap v -> Maybe v+lookup path (MultiMap mm) = case I.lookup h mm of Nothing -> Nothing- Just s -> Just $! NE.head s---- | O(log n)-searchWith :: Int -> (v -> Bool) -> MMap v -> Maybe v-searchWith k f m = case I.lookup k m of- Nothing -> Nothing- Just nxs -> find f $ NE.toList nxs+ Just s -> Prelude.lookup path s+ where+ !h = hash path ---------------------------------------------------------------- -- | O(log n)-insert :: Int -> v -> MMap v -> MMap v-insert k v m = I.insertWith (<>) k (v :| []) m+insert :: FilePath -> v -> MultiMap v -> MultiMap v+insert path v (MultiMap mm) = MultiMap mm'+ where+ !h = hash path+ !mm' = I.insertWith (<>) h [(path,v)] mm ---------------------------------------------------------------- -- | O(n)-toList :: MMap v -> [v]-toList m = concatMap f $ I.toAscList m- where- f (_,s) = NE.toList s+toList :: MultiMap v -> [(FilePath,v)]+toList (MultiMap mm) = concatMap snd $ I.toAscList mm ---------------------------------------------------------------- -- | O(n)-pruneWith :: MMap v- -> (v -> IO Bool)- -> IO (MMap v)-pruneWith m action = I.fromAscList <$> go (I.toDescList m) []+pruneWith :: MultiMap v+ -> ((FilePath,v) -> IO Bool)+ -> IO (MultiMap v)+pruneWith (MultiMap mm) action = MultiMap <$> mm' where- go [] acc = return acc- go ((k,s):kss) acc = do- mt <- prune action s- case mt of- Nothing -> go kss acc- Just t -> go kss ((k,t) : acc)+ !mm' = I.fromAscList <$> go (I.toDescList mm) []+ go [] !acc = return acc+ go ((h,s):kss) !acc = do+ rs <- prune action s+ case rs of+ [] -> go kss acc+ _ -> go kss ((h,rs) : acc) ---------------------------------------------------------------- -- O(n + m) where N is the size of the second argument-merge :: MMap v -> MMap v -> MMap v-merge m1 m2 = I.unionWith (<>) m1 m2+merge :: MultiMap v -> MultiMap v -> MultiMap v+merge (MultiMap m1) (MultiMap m2) = MultiMap mm+ where+ !mm = I.unionWith (<>) m1 m2 ---------------------------------------------------------------- -prune :: (a -> IO Bool) -> NonEmpty a -> IO (Maybe (NonEmpty a))-prune act nxs = NE.nonEmpty <$> go (NE.toList nxs)+prune :: ((FilePath,v) -> IO Bool) -> [(FilePath,v)] -> IO [(FilePath,v)]+prune action xs0 = go xs0 where go [] = return [] go (x:xs) = do- keep <- act x+ keep <- action x rs <- go xs return $ if keep then x:rs else rs
Network/Wai/Handler/Warp/Request.hs view
@@ -24,15 +24,14 @@ import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai-import qualified Network.Wai.Handler.Warp.Timeout as Timeout import Network.Wai.Handler.Warp.Types import Network.Wai.Internal import Prelude hiding (lines) import System.IO.Unsafe (unsafePerformIO)+import qualified System.TimeManager as Timeout import Network.Wai.Handler.Warp.Conduit import Network.Wai.Handler.Warp.FileInfoCache-import Network.Wai.Handler.Warp.HashMap (hashByteString) import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Imports hiding (readInt, lines) import Network.Wai.Handler.Warp.ReadInt@@ -52,20 +51,20 @@ recvRequest :: Bool -- ^ first request on this connection? -> Settings -> Connection- -> InternalInfo1+ -> InternalInfo+ -> Timeout.Handle -> SockAddr -- ^ Peer's address. -> Source -- ^ Where HTTP request comes from. -> IO (Request ,Maybe (I.IORef Int) ,IndexedHeader- ,IO ByteString- ,InternalInfo) -- ^+ ,IO ByteString) -- ^ -- 'Request' passed to 'Application', -- how many bytes remain to be consumed, if known -- 'IndexedHeader' of HTTP request for internal use, -- Body producing action used for flushing the request body -recvRequest firstRequest settings conn ii1 addr src = do+recvRequest firstRequest settings conn ii th addr src = do hdrlines <- headerLines firstRequest src (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines let idxhdr = indexRequestHeader hdr@@ -74,9 +73,6 @@ te = idxhdr ! fromEnum ReqTransferEncoding handle100Continue = handleExpect conn httpversion expect rawPath = if settingsNoParsePath settings then unparsedPath else path- h = hashByteString rawPath- ii = toInternalInfo ii1 h- th = threadHandle ii vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) $ Vault.insert getFileInfoKey (getFileInfo ii) Vault.empty@@ -103,7 +99,7 @@ , requestHeaderReferer = idxhdr ! fromEnum ReqReferer , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent }- return (req, remainingRef, idxhdr, rbodyFlush, ii)+ return (req, remainingRef, idxhdr, rbodyFlush) ----------------------------------------------------------------
Network/Wai/Handler/Warp/Response.hs view
@@ -30,6 +30,7 @@ import Network.Wai import Network.Wai.Internal import qualified Paths_warp+import qualified System.TimeManager as T import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer) import qualified Network.Wai.Handler.Warp.Date as D@@ -39,7 +40,6 @@ import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.ResponseHeader import Network.Wai.Handler.Warp.Settings-import qualified Network.Wai.Handler.Warp.Timeout as T import Network.Wai.Handler.Warp.Types -- $setup@@ -101,12 +101,13 @@ sendResponse :: Settings -> Connection -> InternalInfo+ -> T.Handle -> Request -- ^ HTTP request. -> IndexedHeader -- ^ Indexed header of HTTP request. -> IO ByteString -- ^ source from client, for raw response -> Response -- ^ HTTP response including status code and response header. -> IO Bool -- ^ Returing True if the connection is persistent.-sendResponse settings conn ii req reqidxhdr src response = do+sendResponse settings conn ii th req reqidxhdr src response = do hs <- addServerAndDate hs0 if hasBody s then do -- The response to HEAD does not have body.@@ -133,7 +134,6 @@ s = responseStatus response hs0 = sanitizeHeaders $ responseHeaders response rspidxhdr = indexResponseHeader hs0- th = threadHandle ii getdate = getDate ii addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr (isPersist,isChunked0) = infoFromRequest req reqidxhdr
Network/Wai/Handler/Warp/Run.hs view
@@ -25,6 +25,7 @@ import Network.Wai.Internal (ResponseReceived (ResponseReceived)) import System.Environment (lookupEnv) import System.Timeout (timeout)+import qualified System.TimeManager as T import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Counter@@ -40,7 +41,6 @@ import Network.Wai.Handler.Warp.Response import Network.Wai.Handler.Warp.SendFile import Network.Wai.Handler.Warp.Settings-import qualified Network.Wai.Handler.Warp.Timeout as T import Network.Wai.Handler.Warp.Types @@ -168,15 +168,15 @@ runSettingsConnectionMakerSecure set getConnMaker app = do settingsBeforeMainLoop set counter <- newCounter- withII0 $ acceptConnection set getConnMaker app counter+ withII $ acceptConnection set getConnMaker app counter where- withII0 action =+ withII action = withTimeoutManager $ \tm -> D.withDateCache $ \dc -> F.withFdCache fdCacheDurationInSeconds $ \fdc -> I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do- let ii0 = InternalInfo0 tm dc fdc fic- action ii0+ let ii = InternalInfo tm dc fdc fic+ action ii !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000@@ -205,9 +205,9 @@ -> IO (IO (Connection, Transport), SockAddr) -> Application -> Counter- -> InternalInfo0+ -> InternalInfo -> IO ()-acceptConnection set getConnMaker app counter ii0 = do+acceptConnection set getConnMaker app counter ii = do -- First mask all exceptions in acceptLoop. This is necessary to -- ensure that no async exception is throw between the call to -- acceptNewConnection and the registering of connClose.@@ -234,7 +234,7 @@ case mx of Nothing -> return () Just (mkConn, addr) -> do- fork set mkConn addr app counter ii0+ fork set mkConn addr app counter ii acceptLoop acceptNewConnection = do@@ -257,9 +257,9 @@ -> SockAddr -> Application -> Counter- -> InternalInfo0+ -> InternalInfo -> IO ()-fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->+fork set mkConn addr app counter ii = settingsFork set $ \unmask -> -- Call the user-supplied on exception code if any -- exceptions are thrown. handle (settingsOnException set Nothing) .@@ -291,7 +291,6 @@ -- the connection immediately in case the child thread catches the -- async exception or performs some long-running cleanup action. serve unmask ref (conn, transport) = bracket register cancel $ \th -> do- let ii1 = toInternalInfo1 ii0 th -- We now have fully registered a connection close handler in -- the case of all exceptions, so it is safe to once again -- allow async exceptions.@@ -301,9 +300,9 @@ bracket (onOpen addr) (onClose addr) $ \goingon -> -- Actually serve this connection. bracket with closeConn -- above ensures the connection is closed.- when goingon $ serveConnection conn ii1 addr transport set app+ when goingon $ serveConnection conn ii th addr transport set app where- register = T.registerKillThread (timeoutManager0 ii0)+ register = T.registerKillThread (timeoutManager ii) (closeConn ref conn) cancel = T.cancel @@ -311,13 +310,14 @@ onClose adr _ = decrease counter >> settingsOnClose set adr serveConnection :: Connection- -> InternalInfo1+ -> InternalInfo+ -> T.Handle -> SockAddr -> Transport -> Settings -> Application -> IO ()-serveConnection conn ii1 origAddr transport settings app = do+serveConnection conn ii th origAddr transport settings app = do -- fixme: Upgrading to HTTP/2 should be supported. (h2,bs) <- if isHTTP2 transport then return (True, "")@@ -332,7 +332,7 @@ rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn) let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN -- fixme: origAddr- http2 conn ii1 origAddr transport settings recvN app+ http2 conn ii origAddr transport settings recvN app else do src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings)) writeIORef istatus True@@ -344,7 +344,7 @@ -- https://github.com/yesodweb/wai/issues/618 Just NoKeepAliveRequest -> return () Nothing -> do- sendErrorResponse (dummyreq addr) istatus e+ _ <- sendErrorResponse (dummyreq addr) istatus e throwIO e where@@ -388,18 +388,15 @@ decodeAscii = map (chr . fromEnum) . S.unpack - th = threadHandle1 ii1- shouldSendErrorResponse se | Just ConnectionClosedByPeer <- fromException se = False | otherwise = True sendErrorResponse req istatus e = do status <- readIORef istatus- if (shouldSendErrorResponse e && status)+ if shouldSendErrorResponse e && status then do- let ii = toInternalInfo ii1 0 -- dummy- sendResponse settings conn ii req defaultIndexRequestHeader (return S.empty) (errorResponse e)+ sendResponse settings conn ii th req defaultIndexRequestHeader (return S.empty) (errorResponse e) else return False dummyreq addr = defaultRequest { remoteHost = addr }@@ -407,9 +404,9 @@ errorResponse e = settingsOnExceptionResponse settings e http1 firstRequest addr istatus src = do- (req', mremainingRef, idxhdr, nextBodyFlush, ii) <- recvRequest firstRequest settings conn ii1 addr src+ (req', mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src let req = req' { isSecure = isTransportSecure transport }- keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii+ keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush `E.catch` \e -> do settingsOnException settings (Just req) e -- Don't throw the error again to prevent calling settingsOnException twice.@@ -425,7 +422,7 @@ -- and ignore. See: https://github.com/yesodweb/wai/issues/618 when keepAlive $ http1 False addr istatus src - processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii = do+ processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do -- Let the application run for as long as it wants T.pause th @@ -439,7 +436,7 @@ -- send more meaningful error messages to the user. -- However, it may affect performance. writeIORef istatus False- keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res+ keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res writeIORef keepAliveRef keepAlive return ResponseReceived case r of
Network/Wai/Handler/Warp/Settings.hs view
@@ -21,9 +21,9 @@ import qualified Paths_warp import System.IO (stderr) import System.IO.Error (ioeGetErrorType)+import System.TimeManager import Network.Wai.Handler.Warp.Imports-import Network.Wai.Handler.Warp.Timeout import Network.Wai.Handler.Warp.Types -- | Various Warp server settings. This is purposely kept as an abstract data
− Network/Wai/Handler/Warp/Timeout.hs
@@ -1,153 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}--module Network.Wai.Handler.Warp.Timeout (- -- ** Types- Manager- , TimeoutAction- , Handle- -- ** Manager- , initialize- , stopManager- , killManager- , withManager- -- ** Registration- , register- , registerKillThread- -- ** Control- , tickle- , cancel- , pause- , resume- -- ** Exceptions- , TimeoutThread (..)- ) where--import Control.Concurrent (myThreadId)-import qualified Control.Exception as E-import Control.Reaper-import Data.Typeable (Typeable)-import Data.IORef (IORef)-import qualified Data.IORef as I---------------------------------------------------------------------- | A timeout manager-type Manager = Reaper [Handle] Handle---- | An action to be performed on timeout.-type TimeoutAction = IO ()---- | A handle used by 'Manager'-data Handle = Handle !(IORef TimeoutAction) !(IORef State)--data State = Active -- Manager turns it to Inactive.- | Inactive -- Manager removes it with timeout action.- | Paused -- Manager does not change it.- | Canceled -- Manager removes it without timeout action.---------------------------------------------------------------------- | Creating timeout manager which works every N micro seconds--- where N is the first argument.-initialize :: Int -> IO Manager-initialize timeout = mkReaper defaultReaperSettings- { reaperAction = mkListAction prune- , reaperDelay = timeout- }- where- 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- _ -> return $ Just m-- inactivate Active = Inactive- inactivate x = x---------------------------------------------------------------------- | Stopping timeout manager with onTimeout fired.-stopManager :: Manager -> IO ()-stopManager mgr = E.mask_ (reaperStop mgr >>= mapM_ fire)- where- 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- 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 -> TimeoutAction -> IO Handle-registerKillThread m onTimeout = do- -- 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- -- First run the timeout action in case the child thread is masked.- register m $ onTimeout `E.finally` E.throwTo tid TimeoutThread--data TimeoutThread = TimeoutThread- deriving Typeable-instance E.Exception TimeoutThread where- toException = E.asyncExceptionToException- fromException = E.asyncExceptionFromException-instance Show TimeoutThread where- show TimeoutThread = "Thread killed by Warp's timeout reaper"---------------------------------------------------------------------- | Setting the state to active.--- 'Manager' turns active to inactive repeatedly.-tickle :: Handle -> IO ()-tickle (Handle _ stateRef) = I.writeIORef stateRef Active---- | Setting the state to canceled.--- 'Manager' eventually removes this without timeout action.-cancel :: Handle -> IO ()-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 _ stateRef) = I.writeIORef stateRef Paused---- | Setting the paused state to active.--- This is an alias to 'tickle'.-resume :: Handle -> IO ()-resume = tickle---------------------------------------------------------------------- | Call the inner function with a timeout manager.-withManager :: Int -- ^ timeout in microseconds- -> (Manager -> IO a)- -> IO a-withManager timeout f = do- -- FIXME when stopManager is available, use it- man <- initialize timeout- f man
Network/Wai/Handler/Warp/Types.hs view
@@ -10,12 +10,12 @@ import Data.Typeable (Typeable) import Foreign.Ptr (Ptr) import System.Posix.Types (Fd)+import qualified System.TimeManager as T import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F import qualified Network.Wai.Handler.Warp.FileInfoCache as I import Network.Wai.Handler.Warp.Imports-import qualified Network.Wai.Handler.Warp.Timeout as T ---------------------------------------------------------------- @@ -126,41 +126,12 @@ ---------------------------------------------------------------- -type Hash = Int---data InternalInfo0 =- InternalInfo0 T.Manager- (IO D.GMTDate)- (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))- (Hash -> FilePath -> IO I.FileInfo)--timeoutManager0 :: InternalInfo0 -> T.Manager-timeoutManager0 (InternalInfo0 tm _ _ _) = tm--data InternalInfo1 =- InternalInfo1 T.Handle- T.Manager- (IO D.GMTDate)- (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))- (Hash -> FilePath -> IO I.FileInfo)--toInternalInfo1 :: InternalInfo0 -> T.Handle -> InternalInfo1-toInternalInfo1 (InternalInfo0 b c d e) a = InternalInfo1 a b c d e--threadHandle1 :: InternalInfo1 -> T.Handle-threadHandle1 (InternalInfo1 th _ _ _ _) = th- data InternalInfo = InternalInfo {- threadHandle :: T.Handle- , timeoutManager :: T.Manager+ timeoutManager :: T.Manager , getDate :: IO D.GMTDate , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh) , getFileInfo :: FilePath -> IO I.FileInfo }--toInternalInfo :: InternalInfo1 -> Hash -> InternalInfo-toInternalInfo (InternalInfo1 a b c d e) h = InternalInfo a b c (d h) (e h) ----------------------------------------------------------------
test/FdCacheSpec.hs view
@@ -17,7 +17,7 @@ it "clean up Fd" $ do ref <- newIORef (Fd (-1)) withFdCache 30000000 $ \getFd -> do- (Just fd,_) <- getFd 0 "warp.cabal"+ (Just fd,_) <- getFd "warp.cabal" writeIORef ref fd nfd <- readIORef ref fdRead nfd 1 `shouldThrow` anyIOException
test/RunSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -22,6 +21,7 @@ import Network.Socket import Network.Socket.ByteString (sendAll) import Network.Wai hiding (responseHeaders)+import Network.Wai.Internal (getRequestBodyChunk) import Network.Wai.Handler.Warp import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout)@@ -85,7 +85,7 @@ readBody :: CounterApplication readBody icount req f = do- body <- consumeBody $ requestBody req+ body <- consumeBody $ getRequestBodyChunk req case () of () | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"@@ -106,8 +106,8 @@ doubleConnect :: CounterApplication doubleConnect icount req f = do- _ <- consumeBody $ requestBody req- _ <- consumeBody $ requestBody req+ _ <- consumeBody $ getRequestBodyChunk req+ _ <- consumeBody $ getRequestBodyChunk req incr icount f $ responseLBS status200 [] "double connect" @@ -277,7 +277,7 @@ countVar <- newTVarIO (0 :: Int) ifront <- I.newIORef id let app req f = do- bss <- consumeBody $ requestBody req+ bss <- consumeBody $ getRequestBodyChunk req liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] ""@@ -299,13 +299,11 @@ [ "Hello World\nBye" , "Hello World" ]-#if !WINDOWS--- Too slow on Windows it "lots of chunks" $ do ifront <- I.newIORef id countVar <- newTVarIO (0 :: Int) let app req f = do- bss <- consumeBody $ requestBody req+ bss <- consumeBody $ getRequestBodyChunk req I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] ""@@ -328,7 +326,7 @@ ifront <- I.newIORef id countVar <- newTVarIO (0 :: Int) let app req f = do- bss <- consumeBody $ requestBody req+ bss <- consumeBody $ getRequestBodyChunk req liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] ""@@ -350,11 +348,10 @@ [ "Hello World\nBye" , "Hello World" ]-#endif it "timeout in request body" $ do ifront <- I.newIORef id let app req f = do- bss <- (consumeBody $ requestBody req) `onException`+ bss <- (consumeBody $ getRequestBodyChunk req) `onException` liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ()))) liftIO $ threadDelay 4000000 `E.catch` \e -> do I.atomicModifyIORef ifront (\front ->@@ -398,10 +395,6 @@ timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "1122334455") msWrite ms "67890" timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "6677889900")--#if !WINDOWS--- No idea why this test is so unreliable on Windows--- It fails in multiple ways on CI it "only one date and server header" $ do let app _ f = f $ responseLBS status200 [ ("server", "server")@@ -418,13 +411,13 @@ it "streaming echo #249" $ do countVar <- newTVarIO (0 :: Int) let app req f = f $ responseStream status200 [] $ \write _ -> do- let loop = do- bs <- requestBody req+ let loop = do+ bs <- getRequestBodyChunk req unless (S.null bs) $ do write $ byteString bs atomically $ modifyTVar countVar (+ 1) loop- loop+ loop withApp defaultSettings app $ \port -> do (sock, _addr) <- getSocketTCP "127.0.0.1" port sendAll sock "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"@@ -435,7 +428,6 @@ check $ count >= 1 bs <- safeRecv sock 4096 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"-#endif it "streaming response with length" $ do let app _ f = f $ responseStream status200 [("content-length", "20")] $ \write _ -> do
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 3.2.27+Version: 3.2.28 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE@@ -8,7 +8,7 @@ Homepage: http://github.com/yesodweb/wai Category: Web, Yesod Build-Type: Simple-Cabal-Version: >=1.8+Cabal-Version: >= 1.10 Stability: Stable description: HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported. For HTTP\/2, Warp supports direct and ALPN (in TLS)@@ -42,19 +42,20 @@ , case-insensitive >= 0.2 , containers , ghc-prim- , http-types >= 0.9.1- , iproute >= 1.3.1+ , hashable+ , http-date+ , http-types >= 0.11 , http2 >= 1.6 && < 1.7+ , iproute >= 1.3.1 , simple-sendfile >= 0.2.7 && < 0.3- , unix-compat >= 0.2- , wai >= 3.2 && < 3.3- , text+ , stm >= 2.3 , streaming-commons >= 0.1.10+ , text+ , time-manager+ , unix-compat >= 0.2 , vault >= 0.3- , stm >= 2.3+ , wai >= 3.2 && < 3.3 , word8- , hashable- , http-date if impl(ghc < 8) Build-Depends: semigroups if flag(network-bytestring)@@ -95,7 +96,6 @@ Network.Wai.Handler.Warp.Run Network.Wai.Handler.Warp.SendFile Network.Wai.Handler.Warp.Settings- Network.Wai.Handler.Warp.Timeout Network.Wai.Handler.Warp.Types Network.Wai.Handler.Warp.Windows Network.Wai.Handler.Warp.WithApplication@@ -112,6 +112,9 @@ else Build-Depends: unix Other-modules: Network.Wai.Handler.Warp.MultiMap+ if impl(ghc >= 8)+ Default-Extensions: Strict StrictData+ Default-Language: Haskell2010 Test-Suite doctest Type: exitcode-stdio-1.0@@ -122,6 +125,9 @@ , doctest >= 0.10.1 if os(windows) Buildable: False+ if impl(ghc >= 8)+ Default-Extensions: Strict StrictData+ Default-Language: Haskell2010 Test-Suite spec Main-Is: Spec.hs@@ -171,7 +177,6 @@ Network.Wai.Handler.Warp.Run Network.Wai.Handler.Warp.SendFile Network.Wai.Handler.Warp.Settings- Network.Wai.Handler.Warp.Timeout Network.Wai.Handler.Warp.Types Network.Wai.Handler.Warp.Windows Network.Wai.Handler.Warp.WithApplication@@ -180,39 +185,40 @@ Hs-Source-Dirs: test, . Type: exitcode-stdio-1.0 - Ghc-Options: -Wall+ Ghc-Options: -Wall -threaded Build-Depends: base >= 4.8 && < 5+ , HUnit+ , QuickCheck , array+ , async , auto-update , bsb-http-chunked < 0.1 , bytestring >= 0.9.1.4 , case-insensitive >= 0.2+ , containers+ , directory , ghc-prim+ , hashable+ , hspec >= 1.3 , http-client+ , http-date , http-types >= 0.8.5+ , http2 >= 1.6 && < 1.7 , iproute >= 1.3.1 , lifted-base >= 0.1+ , network+ , process , simple-sendfile >= 0.2.4 && < 0.3+ , stm >= 2.3+ , streaming-commons >= 0.1.10+ , text+ , time+ , time-manager , transformers >= 0.2.2 , unix-compat >= 0.2- , wai >= 3.2 && < 3.3- , network- , HUnit- , QuickCheck- , hspec >= 1.3- , time- , text- , streaming-commons >= 0.1.10- , async , vault- , stm >= 2.3- , directory- , process- , containers- , http2 >= 1.6 && < 1.7+ , wai >= 3.2 && < 3.3 , word8- , hashable- , http-date -- Build-Tool-Depends: hspec-discover:hspec-discover if impl(ghc < 8) Build-Depends: semigroups@@ -223,6 +229,9 @@ if os(windows) Cpp-Options: -DWINDOWS Build-Depends: time+ if impl(ghc >= 8)+ Default-Extensions: Strict StrictData+ Default-Language: Haskell2010 Benchmark parser Type: exitcode-stdio-1.0@@ -233,7 +242,6 @@ Network.Wai.Handler.Warp.HashMap Network.Wai.Handler.Warp.Imports Network.Wai.Handler.Warp.MultiMap- Network.Wai.Handler.Warp.Timeout Network.Wai.Handler.Warp.Types HS-Source-Dirs: bench . Build-Depends: base >= 4.8 && < 5@@ -246,6 +254,7 @@ , http-types , network , network+ , time-manager , unix-compat if impl(ghc < 8) Build-Depends: semigroups@@ -256,6 +265,9 @@ if os(windows) Cpp-Options: -DWINDOWS Build-Depends: time+ if impl(ghc >= 8)+ Default-Extensions: Strict StrictData+ Default-Language: Haskell2010 Source-Repository head Type: git