warp 0.3.2 → 0.3.2.1
raw patch · 3 files changed
+81/−43 lines, 3 files
Files
- Network/Wai/Handler/Warp.hs +73/−41
- Timeout.hs +7/−1
- warp.cabal +1/−1
Network/Wai/Handler/Warp.hs view
@@ -41,12 +41,11 @@ , sendResponse , parseRequest #if TEST- , takeLineMax , takeHeaders #endif ) where -import Prelude hiding (catch)+import Prelude hiding (catch, lines) import Network.Wai import qualified System.IO @@ -150,7 +149,7 @@ forever $ do (conn, sa) <- accept socket _ <- forkIO $ do- th <- T.register tm $ sClose conn+ th <- T.registerKillThread tm serveConnection th onE port app conn sa T.cancel th return ()@@ -181,10 +180,9 @@ parseRequest' port headers' remoteHost' -- FIXME come up with good values here-maxHeaders, maxHeaderLength, bytesPerRead :: Int-maxHeaders = 30-maxHeaderLength = 1024+bytesPerRead, maxTotalHeaderLength :: Int bytesPerRead = 4096+maxTotalHeaderLength = 50 * 1024 sendFileCount :: Integer sendFileCount = 65536@@ -398,41 +396,6 @@ ------ The functions below are not warp-specific and could be split out into a --separate package. -takeHeaders :: E.Iteratee ByteString IO [ByteString]-takeHeaders = takeUntilBlank 0 id--takeUntilBlank :: Int- -> ([ByteString] -> [ByteString])- -> E.Iteratee S.ByteString IO [ByteString]-takeUntilBlank count _- | count > maxHeaders = E.throwError TooManyHeaders-takeUntilBlank count front = do- l <- takeLineMax 0 id- if B.null l- then return $ front []- else takeUntilBlank (count + 1) $ front . (:) l--takeLineMax :: Int- -> ([ByteString] -> [ByteString])- -> E.Iteratee ByteString IO ByteString-takeLineMax len front = do- mbs <- EL.head- case mbs of- Nothing -> E.throwError IncompleteHeaders- Just bs -> do- let (x, y) = S.breakByte 10 bs- x' = if S.length x > 0 && S.last x == 13- then S.init x- else x- let len' = len + B.length x- case () of- ()- | len' > maxHeaderLength -> E.throwError OverLargeHeader- | B.null y -> takeLineMax len' $ front . (:) x- | otherwise -> do- E.yield () $ E.Chunks [B.drop 1 y]- return $ B.concat $ front [x']- iterSocket :: T.Handle -> Socket -> E.Iteratee B.ByteString IO ()@@ -464,3 +427,72 @@ where go :: InvalidRequest -> IO () go _ = return ()++takeHeaders :: E.Iteratee ByteString IO [ByteString]+takeHeaders = do+ !x <- forceHead+ takeHeaders' 0 id id x++{-# INLINE takeHeaders #-}++takeHeaders' :: Int+ -> ([ByteString] -> [ByteString])+ -> ([ByteString] -> [ByteString])+ -> ByteString+ -> E.Iteratee S.ByteString IO [ByteString]+takeHeaders' !len _ _ _ | len > maxTotalHeaderLength = E.throwError OverLargeHeader+takeHeaders' !len !lines !prepend !bs = do+ let !bsLen = {-# SCC "takeHeaders'.bsLen" #-} S.length bs+ !mnl = {-# SCC "takeHeaders'.mnl" #-} S.elemIndex 10 bs+ case mnl of+ -- no newline. prepend entire bs to next line+ !Nothing -> {-# SCC "takeHeaders'.noNewline" #-} do+ let !len' = len + bsLen+ !more <- forceHead + takeHeaders' len' lines (prepend . (:) bs) more+ Just !nl -> {-# SCC "takeHeaders'.newline" #-} do+ let !end = nl + !start = nl + 1+ !line = {-# SCC "takeHeaders'.line" #-}+ if end > 0+ -- line data included in this chunk+ then S.concat $! prepend [SU.unsafeTake (checkCR bs end) bs]+ --then S.concat $! prepend [SU.unsafeTake (end-1) bs]+ -- no line data in this chunk (all in prepend, or empty line)+ else S.concat $! prepend []+ if S.null line+ -- no more headers+ then {-# SCC "takeHeaders'.noMoreHeaders" #-} do+ let !lines' = {-# SCC "takeHeaders'.noMoreHeaders.lines'" #-} lines []+ if start < bsLen+ then {-# SCC "takeHeaders'.noMoreHeaders.yield" #-} do+ let !rest = {-# SCC "takeHeaders'.noMoreHeaders.yield.rest" #-} SU.unsafeDrop start bs+ E.yield lines' $! E.Chunks [rest]+ else return lines'++ -- more headers+ else {-# SCC "takeHeaders'.moreHeaders" #-} do+ let !len' = len + start + !lines' = {-# SCC "takeHeaders.lines'" #-} lines . (:) line+ !more <- {-# SCC "takeHeaders'.more" #-} + if start < bsLen+ then return $! SU.unsafeDrop start bs+ else forceHead+ {-# SCC "takeHeaders'.takeMore" #-} takeHeaders' len' lines' id more+{-# INLINE takeHeaders' #-}++forceHead :: E.Iteratee ByteString IO ByteString+forceHead = do+ !mx <- EL.head+ case mx of+ !Nothing -> E.throwError IncompleteHeaders+ Just !x -> return x+{-# INLINE forceHead #-}++checkCR :: ByteString -> Int -> Int+checkCR bs pos = + let !p = pos - 1+ in if '\r' == B.index bs p+ then p+ else pos+{-# INLINE checkCR #-}
Timeout.hs view
@@ -3,6 +3,7 @@ , Handle , initialize , register+ , registerKillThread , tickle , pause , resume@@ -10,7 +11,7 @@ ) where import qualified Data.IORef as I-import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread) import Control.Monad (forever) import qualified Control.Exception as E @@ -51,6 +52,11 @@ let h = Handle onTimeout iactive I.atomicModifyIORef ref (\x -> (h : x, ())) return h++registerKillThread :: Manager -> IO Handle+registerKillThread m = do+ tid <- myThreadId+ register m $ killThread tid tickle, pause, resume, cancel :: Handle -> IO () tickle (Handle _ iactive) = I.writeIORef iactive Active
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 0.3.2+Version: 0.3.2.1 Synopsis: A fast, light-weight web server for WAI applications. License: BSD3 License-file: LICENSE