warp 3.3.31 → 3.4.0
raw patch · 48 files changed
+2704/−2130 lines, 48 filesdep ~case-insensitivedep ~http2dep ~streaming-commons
Dependency ranges changed: case-insensitive, http2, streaming-commons, vault, wai
Files
- ChangeLog.md +9/−0
- Network/Wai/Handler/Warp.hs +150/−124
- Network/Wai/Handler/Warp/Buffer.hs +14/−14
- Network/Wai/Handler/Warp/Conduit.hs +46/−43
- Network/Wai/Handler/Warp/Counter.hs +6/−7
- Network/Wai/Handler/Warp/Date.hs +9/−7
- Network/Wai/Handler/Warp/FdCache.hs +41/−30
- Network/Wai/Handler/Warp/File.hs +72/−56
- Network/Wai/Handler/Warp/FileInfoCache.hs +51/−43
- Network/Wai/Handler/Warp/HTTP1.hs +144/−64
- Network/Wai/Handler/Warp/HTTP2.hs +57/−45
- Network/Wai/Handler/Warp/HTTP2/PushPromise.hs +9/−11
- Network/Wai/Handler/Warp/HTTP2/Request.hs +61/−47
- Network/Wai/Handler/Warp/HTTP2/Response.hs +66/−46
- Network/Wai/Handler/Warp/HTTP2/Types.hs +17/−16
- Network/Wai/Handler/Warp/HashMap.hs +3/−2
- Network/Wai/Handler/Warp/Header.hs +48/−42
- Network/Wai/Handler/Warp/IO.hs +36/−32
- Network/Wai/Handler/Warp/Imports.hs +14/−14
- Network/Wai/Handler/Warp/Internal.hs +54/−39
- Network/Wai/Handler/Warp/MultiMap.hs +27/−25
- Network/Wai/Handler/Warp/PackInt.hs +9/−18
- Network/Wai/Handler/Warp/ReadInt.hs +10/−9
- Network/Wai/Handler/Warp/Request.hs +195/−183
- Network/Wai/Handler/Warp/RequestHeader.hs +43/−38
- Network/Wai/Handler/Warp/Response.hs +226/−153
- Network/Wai/Handler/Warp/ResponseHeader.hs +17/−27
- Network/Wai/Handler/Warp/Run.hs +142/−109
- Network/Wai/Handler/Warp/SendFile.hs +65/−59
- Network/Wai/Handler/Warp/Settings.hs +204/−186
- Network/Wai/Handler/Warp/Types.hs +72/−65
- Network/Wai/Handler/Warp/Windows.hs +4/−3
- Network/Wai/Handler/Warp/WithApplication.hs +52/−49
- bench/Parser.hs +156/−87
- test/ConduitSpec.hs +17/−15
- test/ExceptionSpec.hs +28/−26
- test/FdCacheSpec.hs +1/−1
- test/FileSpec.hs +30/−16
- test/HTTP.hs +14/−14
- test/PackIntSpec.hs +14/−0
- test/ReadIntSpec.hs +6/−4
- test/RequestSpec.hs +92/−82
- test/ResponseHeaderSpec.hs +14/−13
- test/ResponseSpec.hs +32/−22
- test/RunSpec.hs +226/−167
- test/SendFileSpec.hs +44/−40
- test/WithApplicationSpec.hs +35/−31
- warp.cabal +22/−6
ChangeLog.md view
@@ -1,5 +1,14 @@ # ChangeLog for warp +## 3.4.0++* Reworked request lines (`CRLF`) parsing: [#968](https://github.com/yesodweb/wai/pulls)+ * We do not accept multiline headers anymore.+ ([`RFC 7230`](https://www.rfc-editor.org/rfc/rfc7230#section-3.2.4) deprecated it 10 years ago)+ * Reworked request lines (`CRLF`) parsing to not unnecessarily copy bytestrings.+* Using http2 v5.1.0.+* `fourmolu` is used as an official formatter.+ ## 3.3.31 * Supporting http2 v5.0.
Network/Wai/Handler/Warp.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} ---------------------------------------------------------@@ -34,114 +34,128 @@ -- * call the 'pauseTimeout' function -- -- For more information, see <https://github.com/yesodweb/wai/issues/351>.------ module Network.Wai.Handler.Warp ( -- * Run a Warp server+ -- | All of these automatically serve the same 'Application' over HTTP\/1, -- HTTP\/1.1, and HTTP\/2.- run- , runEnv- , runSettings- , runSettingsSocket+ run,+ runEnv,+ runSettings,+ runSettingsSocket,+ -- * Settings- , Settings- , defaultSettings+ Settings,+ defaultSettings,+ -- ** Setters- , setPort- , setHost- , setOnException- , setOnExceptionResponse- , setOnOpen- , setOnClose- , setTimeout- , setManager- , setFdCacheDuration- , setFileInfoCacheDuration- , setBeforeMainLoop- , setNoParsePath- , setInstallShutdownHandler- , setServerName- , setMaximumBodyFlush- , setFork- , setAccept- , setProxyProtocolNone- , setProxyProtocolRequired- , setProxyProtocolOptional- , setSlowlorisSize- , setHTTP2Disabled- , setLogger- , setServerPushLogger- , setGracefulShutdownTimeout- , setGracefulCloseTimeout1- , setGracefulCloseTimeout2- , setMaxTotalHeaderLength- , setAltSvc- , setMaxBuilderResponseBufferSize+ setPort,+ setHost,+ setOnException,+ setOnExceptionResponse,+ setOnOpen,+ setOnClose,+ setTimeout,+ setManager,+ setFdCacheDuration,+ setFileInfoCacheDuration,+ setBeforeMainLoop,+ setNoParsePath,+ setInstallShutdownHandler,+ setServerName,+ setMaximumBodyFlush,+ setFork,+ setAccept,+ setProxyProtocolNone,+ setProxyProtocolRequired,+ setProxyProtocolOptional,+ setSlowlorisSize,+ setHTTP2Disabled,+ setLogger,+ setServerPushLogger,+ setGracefulShutdownTimeout,+ setGracefulCloseTimeout1,+ setGracefulCloseTimeout2,+ setMaxTotalHeaderLength,+ setAltSvc,+ setMaxBuilderResponseBufferSize,+ -- ** Getters- , getPort- , getHost- , getOnOpen- , getOnClose- , getOnException- , getGracefulShutdownTimeout- , getGracefulCloseTimeout1- , getGracefulCloseTimeout2+ getPort,+ getHost,+ getOnOpen,+ getOnClose,+ getOnException,+ getGracefulShutdownTimeout,+ getGracefulCloseTimeout1,+ getGracefulCloseTimeout2,+ -- ** Exception handler- , defaultOnException- , defaultShouldDisplayException+ defaultOnException,+ defaultShouldDisplayException,+ -- ** Exception response handler- , defaultOnExceptionResponse- , exceptionResponseForDebug+ defaultOnExceptionResponse,+ exceptionResponseForDebug,+ -- * Data types- , HostPreference- , Port- , InvalidRequest (..)+ HostPreference,+ Port,+ InvalidRequest (..),+ -- * Utilities- , pauseTimeout- , FileInfo(..)- , getFileInfo+ pauseTimeout,+ FileInfo (..),+ getFileInfo, #ifdef MIN_VERSION_crypton_x509- , clientCertificate+ clientCertificate, #endif- , withApplication- , withApplicationSettings- , testWithApplication- , testWithApplicationSettings- , openFreePort+ withApplication,+ withApplicationSettings,+ testWithApplication,+ testWithApplicationSettings,+ openFreePort,+ -- * Version- , warpVersion+ warpVersion,+ -- * HTTP/2+ -- ** HTTP2 data- , HTTP2Data- , http2dataPushPromise- , http2dataTrailers- , defaultHTTP2Data- , getHTTP2Data- , setHTTP2Data- , modifyHTTP2Data+ HTTP2Data,+ http2dataPushPromise,+ http2dataTrailers,+ defaultHTTP2Data,+ getHTTP2Data,+ setHTTP2Data,+ modifyHTTP2Data,+ -- ** Push promise- , PushPromise- , promisedPath- , promisedFile- , promisedResponseHeaders- , promisedWeight- , defaultPushPromise- ) where+ PushPromise,+ promisedPath,+ promisedFile,+ promisedResponseHeaders,+ promisedWeight,+ defaultPushPromise,+) where -import UnliftIO.Exception (SomeException, throwIO) import Data.Streaming.Network (HostPreference) import qualified Data.Vault.Lazy as Vault+import UnliftIO.Exception (SomeException, throwIO) #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif import qualified Network.HTTP.Types as H-import Network.Socket (Socket, SockAddr)+import Network.Socket (SockAddr, Socket) 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)+import Network.Wai.Handler.Warp.HTTP2.Request (+ getHTTP2Data,+ modifyHTTP2Data,+ setHTTP2Data,+ ) import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Request@@ -155,20 +169,21 @@ -- -- Since 2.1.0 setPort :: Port -> Settings -> Settings-setPort x y = y { settingsPort = x }+setPort x y = y{settingsPort = x} -- | Interface to bind to. Default value: HostIPv4 -- -- Since 2.1.0 setHost :: HostPreference -> Settings -> Settings-setHost x y = y { settingsHost = x }+setHost x y = y{settingsHost = x} -- | What to do with exceptions thrown by either the application or server. -- Default: 'defaultOnException' -- -- Since 2.1.0-setOnException :: (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings-setOnException x y = y { settingsOnException = x }+setOnException+ :: (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings+setOnException x y = y{settingsOnException = x} -- | A function to create a `Response` when an exception occurs. -- Default: 'defaultOnExceptionResponse'@@ -185,7 +200,7 @@ -- -- Since 2.1.0 setOnExceptionResponse :: (SomeException -> Response) -> Settings -> Settings-setOnExceptionResponse x y = y { settingsOnExceptionResponse = x }+setOnExceptionResponse x y = y{settingsOnExceptionResponse = x} -- | What to do when a connection is opened. When 'False' is returned, the -- connection is closed immediately. Otherwise, the connection is going on.@@ -193,13 +208,13 @@ -- -- Since 2.1.0 setOnOpen :: (SockAddr -> IO Bool) -> Settings -> Settings-setOnOpen x y = y { settingsOnOpen = x }+setOnOpen x y = y{settingsOnOpen = x} -- | What to do when a connection is closed. Default: do nothing. -- -- Since 2.1.0 setOnClose :: (SockAddr -> IO ()) -> Settings -> Settings-setOnClose x y = y { settingsOnClose = x }+setOnClose x y = y{settingsOnClose = x} -- | "Slow-loris" timeout lower-bound value in seconds. Connections where -- network progress is made less frequently than this may be closed. In@@ -211,14 +226,14 @@ -- -- Since 2.1.0 setTimeout :: Int -> Settings -> Settings-setTimeout x y = y { settingsTimeout = x }+setTimeout x y = y{settingsTimeout = x} -- | Use an existing timeout manager instead of spawning a new one. If used, -- 'settingsTimeout' is ignored. -- -- Since 2.1.0 setManager :: Manager -> Settings -> Settings-setManager x y = y { settingsManager = Just x }+setManager x y = y{settingsManager = Just x} -- | Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. --@@ -234,7 +249,7 @@ -- -- Since 3.0.13 setFdCacheDuration :: Int -> Settings -> Settings-setFdCacheDuration x y = y { settingsFdCacheDuration = x }+setFdCacheDuration x y = y{settingsFdCacheDuration = x} -- | Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. --@@ -248,7 +263,7 @@ -- -- Default value: 0 setFileInfoCacheDuration :: Int -> Settings -> Settings-setFileInfoCacheDuration x y = y { settingsFileInfoCacheDuration = x }+setFileInfoCacheDuration x y = y{settingsFileInfoCacheDuration = x} -- | Code to run after the listening socket is ready but before entering -- the main event loop. Useful for signaling to tests that they can start@@ -258,7 +273,7 @@ -- -- Since 2.1.0 setBeforeMainLoop :: IO () -> Settings -> Settings-setBeforeMainLoop x y = y { settingsBeforeMainLoop = x }+setBeforeMainLoop x y = y{settingsBeforeMainLoop = x} -- | Perform no parsing on the rawPathInfo. --@@ -268,7 +283,7 @@ -- -- Since 2.1.0 setNoParsePath :: Bool -> Settings -> Settings-setNoParsePath x y = y { settingsNoParsePath = x }+setNoParsePath x y = y{settingsNoParsePath = x} -- | Get the listening port. --@@ -332,7 +347,7 @@ -- -- Since 3.0.1 setInstallShutdownHandler :: (IO () -> IO ()) -> Settings -> Settings-setInstallShutdownHandler x y = y { settingsInstallShutdownHandler = x }+setInstallShutdownHandler x y = y{settingsInstallShutdownHandler = x} -- | Default server name to be sent as the \"Server:\" header -- if an application does not set one.@@ -341,7 +356,7 @@ -- -- Since 3.0.2 setServerName :: ByteString -> Settings -> Settings-setServerName x y = y { settingsServerName = x }+setServerName x y = y{settingsServerName = x} -- | The maximum number of bytes to flush from an unconsumed request body. --@@ -358,7 +373,7 @@ setMaximumBodyFlush :: Maybe Int -> Settings -> Settings setMaximumBodyFlush x y | Just x' <- x, x' < 0 = error "setMaximumBodyFlush: must be positive"- | otherwise = y { settingsMaximumBodyFlush = x }+ | otherwise = y{settingsMaximumBodyFlush = x} -- | Code to fork a new thread to accept a connection. --@@ -368,8 +383,9 @@ -- Default: void . forkIOWithUnmask -- -- Since 3.0.4-setFork :: (((forall a. IO a -> IO a) -> IO ()) -> IO ()) -> Settings -> Settings-setFork fork' s = s { settingsFork = fork' }+setFork+ :: (((forall a. IO a -> IO a) -> IO ()) -> IO ()) -> Settings -> Settings+setFork fork' s = s{settingsFork = fork'} -- | Code to accept a new connection. --@@ -380,13 +396,13 @@ -- -- Since 3.3.24 setAccept :: (Socket -> IO (Socket, SockAddr)) -> Settings -> Settings-setAccept accept' s = s { settingsAccept = accept' }+setAccept accept' s = s{settingsAccept = accept'} -- | Do not use the PROXY protocol. -- -- Since 3.0.5 setProxyProtocolNone :: Settings -> Settings-setProxyProtocolNone y = y { settingsProxyProtocol = ProxyProtocolNone }+setProxyProtocolNone y = y{settingsProxyProtocol = ProxyProtocolNone} -- | Require PROXY header. --@@ -402,7 +418,7 @@ -- -- Since 3.0.5 setProxyProtocolRequired :: Settings -> Settings-setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired }+setProxyProtocolRequired y = y{settingsProxyProtocol = ProxyProtocolRequired} -- | Use the PROXY header if it exists, but also accept -- connections without the header. See 'setProxyProtocolRequired'.@@ -418,35 +434,39 @@ -- -- Since 3.0.5 setProxyProtocolOptional :: Settings -> Settings-setProxyProtocolOptional y = y { settingsProxyProtocol = ProxyProtocolOptional }+setProxyProtocolOptional y = y{settingsProxyProtocol = ProxyProtocolOptional} -- | Size in bytes read to prevent Slowloris attacks. Default value: 2048 -- -- Since 3.1.2 setSlowlorisSize :: Int -> Settings -> Settings-setSlowlorisSize x y = y { settingsSlowlorisSize = x }+setSlowlorisSize x y = y{settingsSlowlorisSize = x} -- | Disable HTTP2. -- -- Since 3.1.7 setHTTP2Disabled :: Settings -> Settings-setHTTP2Disabled y = y { settingsHTTP2Enabled = False }+setHTTP2Disabled y = y{settingsHTTP2Enabled = False} -- | Setting a log function. -- -- Since 3.X.X-setLogger :: (Request -> H.Status -> Maybe Integer -> IO ()) -- ^ request, status, maybe file-size- -> Settings- -> Settings-setLogger lgr y = y { settingsLogger = lgr }+setLogger+ :: (Request -> H.Status -> Maybe Integer -> IO ())+ -- ^ request, status, maybe file-size+ -> Settings+ -> Settings+setLogger lgr y = y{settingsLogger = lgr} -- | Setting a log function for HTTP/2 server push. -- -- Since: 3.2.7-setServerPushLogger :: (Request -> ByteString -> Integer -> IO ()) -- ^ request, path, file-size- -> Settings- -> Settings-setServerPushLogger lgr y = y { settingsServerPushLogger = lgr }+setServerPushLogger+ :: (Request -> ByteString -> Integer -> IO ())+ -- ^ request, path, file-size+ -> Settings+ -> Settings+setServerPushLogger lgr y = y{settingsServerPushLogger = lgr} -- | Set the graceful shutdown timeout. A timeout of `Nothing' will -- wait indefinitely, and a number, if provided, will be treated as seconds@@ -457,29 +477,32 @@ -- response to a UNIX signal. -- -- Since 3.2.8-setGracefulShutdownTimeout :: Maybe Int- -> Settings -> Settings-setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }+setGracefulShutdownTimeout+ :: Maybe Int+ -> Settings+ -> Settings+setGracefulShutdownTimeout time y = y{settingsGracefulShutdownTimeout = time} -- | Set the maximum header size that Warp will tolerate when using HTTP/1.x. -- -- Since 3.3.8 setMaxTotalHeaderLength :: Int -> Settings -> Settings-setMaxTotalHeaderLength maxTotalHeaderLength settings = settings- { settingsMaxTotalHeaderLength = maxTotalHeaderLength }-+setMaxTotalHeaderLength maxTotalHeaderLength settings =+ settings+ { settingsMaxTotalHeaderLength = maxTotalHeaderLength+ } -- | Setting the header value of Alternative Services (AltSvc:). -- -- Since 3.3.11 setAltSvc :: ByteString -> Settings -> Settings-setAltSvc altsvc settings = settings { settingsAltSvc = Just altsvc }+setAltSvc altsvc settings = settings{settingsAltSvc = Just altsvc} -- | Set the maximum buffer size for sending `Builder` responses. -- -- Since 3.3.22 setMaxBuilderResponseBufferSize :: Int -> Settings -> Settings-setMaxBuilderResponseBufferSize maxRspBufSize settings = settings { settingsMaxBuilderResponseBufferSize = maxRspBufSize }+setMaxBuilderResponseBufferSize maxRspBufSize settings = settings{settingsMaxBuilderResponseBufferSize = maxRspBufSize} -- | Explicitly pause the slowloris timeout. --@@ -507,7 +530,10 @@ -- -- Since 3.1.10 getFileInfo :: Request -> FilePath -> IO FileInfo-getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault+getFileInfo =+ fromMaybe (\_ -> throwIO (userError "getFileInfo"))+ . Vault.lookup getFileInfoKey+ . vault -- | A timeout to limit the time (in milliseconds) waiting for -- FIN for HTTP/1.x. 0 means uses immediate close.@@ -515,7 +541,7 @@ -- -- Since 3.3.5 setGracefulCloseTimeout1 :: Int -> Settings -> Settings-setGracefulCloseTimeout1 x y = y { settingsGracefulCloseTimeout1 = x }+setGracefulCloseTimeout1 x y = y{settingsGracefulCloseTimeout1 = x} -- | A timeout to limit the time (in milliseconds) waiting for -- FIN for HTTP/1.x. 0 means uses immediate close.@@ -530,7 +556,7 @@ -- -- Since 3.3.5 setGracefulCloseTimeout2 :: Int -> Settings -> Settings-setGracefulCloseTimeout2 x y = y { settingsGracefulCloseTimeout2 = x }+setGracefulCloseTimeout2 x y = y{settingsGracefulCloseTimeout2 = x} -- | A timeout to limit the time (in milliseconds) waiting for -- FIN for HTTP/2. 0 means uses immediate close.
Network/Wai/Handler/Warp/Buffer.hs view
@@ -1,15 +1,15 @@ module Network.Wai.Handler.Warp.Buffer (- createWriteBuffer- , allocateBuffer- , freeBuffer- , toBuilderBuffer- , bufferIO- ) where+ createWriteBuffer,+ allocateBuffer,+ freeBuffer,+ toBuilderBuffer,+ bufferIO,+) where import Data.IORef (IORef, readIORef) import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..)) import Foreign.ForeignPtr-import Foreign.Marshal.Alloc (mallocBytes, free)+import Foreign.Marshal.Alloc (free, mallocBytes) import Foreign.Ptr (plusPtr) import Network.Socket.BufferPool @@ -22,13 +22,13 @@ -- containing that size and a finalizer. createWriteBuffer :: BufSize -> IO WriteBuffer createWriteBuffer size = do- bytes <- allocateBuffer size- return- WriteBuffer- { bufBuffer = bytes,- bufSize = size,- bufFree = freeBuffer bytes- }+ bytes <- allocateBuffer size+ return+ WriteBuffer+ { bufBuffer = bytes+ , bufSize = size+ , bufFree = freeBuffer bytes+ } ----------------------------------------------------------------
Network/Wai/Handler/Warp/Conduit.hs view
@@ -2,9 +2,10 @@ module Network.Wai.Handler.Warp.Conduit where -import UnliftIO (assert, throwIO) import qualified Data.ByteString as S import qualified Data.IORef as I+import Data.Word8 (_0, _9, _A, _F, _a, _cr, _f, _lf)+import UnliftIO (assert, throwIO) import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types@@ -29,46 +30,44 @@ if count == 0 then return S.empty else do+ bs <- readSource src - bs <- readSource src+ -- If no chunk available, then there aren't enough bytes in the+ -- stream. Throw a ConnectionClosedByPeer+ when (S.null bs) $ throwIO ConnectionClosedByPeer - -- If no chunk available, then there aren't enough bytes in the- -- stream. Throw a ConnectionClosedByPeer- when (S.null bs) $ throwIO ConnectionClosedByPeer+ let -- How many of the bytes in this chunk to send downstream+ toSend = min count (S.length bs)+ -- How many bytes will still remain to be sent downstream+ count' = count - toSend - let -- How many of the bytes in this chunk to send downstream- toSend = min count (S.length bs)- -- How many bytes will still remain to be sent downstream- count' = count - toSend- case () of- ()- -- The expected count is greater than the size of the+ I.writeIORef ref count'++ if count' > 0+ then -- The expected count is greater than the size of the -- chunk we just read. Send the entire chunk -- downstream, and then loop on this function for the -- next chunk.- | count' > 0 -> do- I.writeIORef ref count' return bs-- -- Some of the bytes in this chunk should not be sent- -- downstream. Split up the chunk into the sent and- -- not-sent parts, add the not-sent parts onto the new- -- source, and send the rest of the chunk downstream.- | otherwise -> do+ else do+ -- Some of the bytes in this chunk should not be sent+ -- downstream. Split up the chunk into the sent and+ -- not-sent parts, add the not-sent parts onto the new+ -- source, and send the rest of the chunk downstream. let (x, y) = S.splitAt toSend bs leftoverSource src y- assert (count' == 0) $ I.writeIORef ref count'- return x+ assert (count' == 0) $ return x ---------------------------------------------------------------- data CSource = CSource !Source !(I.IORef ChunkState) -data ChunkState = NeedLen- | NeedLenNewline- | HaveLen Word- | DoneChunking- deriving Show+data ChunkState+ = NeedLen+ | NeedLenNewline+ | HaveLen Word+ | DoneChunking+ deriving (Show) mkCSource :: Source -> IO CSource mkCSource src = do@@ -106,17 +105,19 @@ bs <- readSource src case S.uncons bs of Nothing -> return ()- Just (13, bs') -> dropLF bs'- Just (10, bs') -> leftoverSource src bs'- Just _ -> leftoverSource src bs+ Just (w8, bs')+ | w8 == _cr -> dropLF bs'+ | w8 == _lf -> leftoverSource src bs'+ | otherwise -> leftoverSource src bs dropLF bs = case S.uncons bs of Nothing -> do bs2 <- readSource' src unless (S.null bs2) $ dropLF bs2- Just (10, bs') -> leftoverSource src bs'- Just _ -> leftoverSource src bs+ Just (w8, bs') ->+ leftoverSource src $+ if w8 == _lf then bs' else bs go NeedLen = getLen go NeedLenNewline = dropCRLF >> getLen@@ -139,17 +140,18 @@ return S.empty else do (x, y) <-- case S.break (== 10) bs of+ case S.break (== _lf) bs of (x, y) | S.null y -> do bs2 <- readSource' src- return $ if S.null bs2- then (x, y)- else S.break (== 10) $ bs `S.append` bs2+ return $+ if S.null bs2+ then (x, y)+ else S.break (== _lf) $ bs `S.append` bs2 | otherwise -> return (x, y) let w =- S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0- $ S.takeWhile isHexDigit x+ S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0 $+ S.takeWhile isHexDigit x let y' = S.drop 1 y y'' <-@@ -159,11 +161,12 @@ withLen w y'' hexToWord w- | w < 58 = w - 48- | w < 71 = w - 55+ | w <= _9 = w - _0+ | w <= _F = w - 55 | otherwise = w - 87 isHexDigit :: Word8 -> Bool-isHexDigit w = w >= 48 && w <= 57- || w >= 65 && w <= 70- || w >= 97 && w <= 102+isHexDigit w =+ w >= _0 && w <= _9+ || w >= _A && w <= _F+ || w >= _a && w <= _f
Network/Wai/Handler/Warp/Counter.hs view
@@ -1,17 +1,16 @@ {-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Counter (- Counter- , newCounter- , waitForZero- , increase- , decrease- ) where+ Counter,+ newCounter,+ waitForZero,+ increase,+ decrease,+) where import Control.Concurrent.STM import Network.Wai.Handler.Warp.Imports- newtype Counter = Counter (TVar Int)
Network/Wai/Handler/Warp/Date.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Date (- withDateCache- , GMTDate- ) where+ withDateCache,+ GMTDate,+) where -import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)+import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, updateAction) import Data.ByteString import Network.HTTP.Date @@ -25,9 +25,11 @@ withDateCache action = initialize >>= action initialize :: IO (IO GMTDate)-initialize = mkAutoUpdate defaultUpdateSettings {- updateAction = formatHTTPDate <$> getCurrentHTTPDate- }+initialize =+ mkAutoUpdate+ defaultUpdateSettings+ { updateAction = formatHTTPDate <$> getCurrentHTTPDate+ } #ifdef WINDOWS uToH :: UTCTime -> HTTPDate
Network/Wai/Handler/Warp/FdCache.hs view
@@ -1,24 +1,32 @@-{-# LANGUAGE BangPatterns, CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} -- | File descriptor cache to avoid locks in kernel.- module Network.Wai.Handler.Warp.FdCache (- withFdCache- , Fd- , Refresh+ withFdCache,+ Fd,+ Refresh, #ifndef WINDOWS- , openFile- , closeFile- , setFileCloseOnExec+ closeFile,+ openFile,+ setFileCloseOnExec, #endif- ) where+) where #ifndef WINDOWS-import UnliftIO.Exception (bracket) import Control.Reaper import Data.IORef import Network.Wai.Handler.Warp.MultiMap as MM-import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd, FdOption(CloseOnExec), setFdOption)+import System.Posix.IO (+ FdOption (CloseOnExec),+ OpenFileFlags (..),+ OpenMode (ReadOnly),+ closeFd,+ defaultFileFlags,+ openFd,+ setFdOption,+ )+import UnliftIO.Exception (bracket) #endif import System.Posix.Types (Fd) @@ -36,12 +44,14 @@ -- argument. The first argument is a cache duration in second. withFdCache :: Int -> ((FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a #ifdef WINDOWS-withFdCache _ action = action getFdNothing+withFdCache _ action = action getFdNothing #else-withFdCache 0 action = action getFdNothing-withFdCache duration action = bracket (initialize duration)- terminate- (action . getFd)+withFdCache 0 action = action getFdNothing+withFdCache duration action =+ bracket+ (initialize duration)+ terminate+ (action . getFd) ---------------------------------------------------------------- @@ -68,9 +78,9 @@ openFile :: FilePath -> IO Fd openFile path = do #if MIN_VERSION_unix(2,8,0)- fd <- openFd path ReadOnly defaultFileFlags{nonBlock=False}+ fd <- openFd path ReadOnly defaultFileFlags{nonBlock = False} #else- fd <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock=False}+ fd <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock = False} #endif setFileCloseOnExec fd return fd@@ -89,7 +99,7 @@ type FdCache = MultiMap FdEntry -- | Mutable Fd cacher.-newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath,FdEntry))+newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath, FdEntry)) fdCache :: MutableFdCache -> IO FdCache fdCache (MutableFdCache reaper) = reaperRead reaper@@ -103,23 +113,24 @@ initialize :: Int -> IO MutableFdCache initialize duration = MutableFdCache <$> mkReaper settings where- settings = defaultReaperSettings {- reaperAction = clean- , reaperDelay = duration- , reaperCons = uncurry insert- , reaperNull = isEmpty- , reaperEmpty = empty- }+ settings =+ defaultReaperSettings+ { reaperAction = clean+ , reaperDelay = duration+ , reaperCons = uncurry insert+ , reaperNull = isEmpty+ , reaperEmpty = empty+ } clean :: FdCache -> IO (FdCache -> FdCache) clean old = do 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+ act Active = inactive mst >> return True+ act Inactive = closeFd fd >> return False ---------------------------------------------------------------- @@ -138,7 +149,7 @@ where get Nothing = do ent@(FdEntry fd mst) <- newFdEntry path- reaperAdd reaper (path,ent)+ reaperAdd reaper (path, ent) return (Just fd, refresh mst) get (Just (FdEntry fd mst)) = do refresh mst
Network/Wai/Handler/Warp/File.hs view
@@ -1,13 +1,13 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.File (- RspFileInfo(..)- , conditionalRequest- , addContentHeadersForFilePart- , H.parseByteRanges- ) where+ RspFileInfo (..),+ conditionalRequest,+ addContentHeadersForFilePart,+ H.parseByteRanges,+) where import Data.Array ((!)) import qualified Data.ByteString.Char8 as C8 (pack)@@ -21,36 +21,36 @@ import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.PackInt ---- $setup--- >>> import Test.QuickCheck- ---------------------------------------------------------------- -data RspFileInfo = WithoutBody H.Status- | WithBody H.Status H.ResponseHeaders Integer Integer- deriving (Eq,Show)+data RspFileInfo+ = WithoutBody H.Status+ | WithBody H.Status H.ResponseHeaders Integer Integer+ deriving (Eq, Show) ---------------------------------------------------------------- -conditionalRequest :: I.FileInfo- -> H.ResponseHeaders- -> H.Method- -> IndexedHeader -- ^ Response- -> IndexedHeader -- ^ Request- -> RspFileInfo+conditionalRequest+ :: I.FileInfo+ -> H.ResponseHeaders+ -> H.Method+ -> IndexedHeader+ -- ^ Response+ -> IndexedHeader+ -- ^ Request+ -> RspFileInfo conditionalRequest finfo hs0 method rspidx reqidx = case condition of nobody@(WithoutBody _) -> nobody- WithBody s _ off len ->+ WithBody s _ off len -> let !hs1 = addContentHeaders hs0 off len size !hs = case rspidx ! fromEnum ResLastModified of Just _ -> hs1- Nothing -> (H.hLastModified,date) : hs1- in WithBody s hs off len+ Nothing -> (H.hLastModified, date) : hs1+ in WithBody s hs off len where !mtime = I.fileInfoTime finfo- !size = I.fileInfoSize finfo- !date = I.fileInfoDate finfo+ !size = I.fileInfoSize finfo+ !date = I.fileInfoDate finfo -- According to RFC 9110: -- "A recipient cache or origin server MUST evaluate the request -- preconditions defined by this specification in the following order:@@ -64,9 +64,10 @@ -- we also don't want to block middleware or applications from -- using ETags. And sending If-(None-)Match headers in a request -- to a server that doesn't use them is requester's problem.- !mcondition = ifunmodified reqidx mtime- <|> ifmodified reqidx mtime method- <|> ifrange reqidx mtime method size+ !mcondition =+ ifunmodified reqidx mtime+ <|> ifmodified reqidx mtime method+ <|> ifrange reqidx mtime method size !condition = fromMaybe (unconditional reqidx size) mcondition ----------------------------------------------------------------@@ -112,7 +113,7 @@ -- "When the method is GET and both Range and If-Range are -- present, evaluate the If-Range precondition:" date <- ifRange reqidx- rng <- reqidx ! fromEnum ReqRange+ rng <- reqidx ! fromEnum ReqRange guard $ method == H.methodGet return $ if date == mtime@@ -122,27 +123,28 @@ unconditional :: IndexedHeader -> Integer -> RspFileInfo unconditional reqidx = case reqidx ! fromEnum ReqRange of- Nothing -> WithBody H.ok200 [] 0+ Nothing -> WithBody H.ok200 [] 0 Just rng -> parseRange rng ---------------------------------------------------------------- parseRange :: ByteString -> Integer -> RspFileInfo parseRange rng size = case H.parseByteRanges rng of- Nothing -> WithoutBody H.requestedRangeNotSatisfiable416- Just [] -> WithoutBody H.requestedRangeNotSatisfiable416- Just (r:_) -> let (!beg, !end) = checkRange r size- !len = end - beg + 1- s = if beg == 0 && end == size - 1 then- H.ok200- else- H.partialContent206- in WithBody s [] beg len+ Nothing -> WithoutBody H.requestedRangeNotSatisfiable416+ Just [] -> WithoutBody H.requestedRangeNotSatisfiable416+ Just (r : _) ->+ let (!beg, !end) = checkRange r size+ !len = end - beg + 1+ s =+ if beg == 0 && end == size - 1+ then H.ok200+ else H.partialContent206+ in WithBody s [] beg len checkRange :: H.ByteRange -> Integer -> (Integer, Integer)-checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)-checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)-checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)+checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)+checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)+checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1) ---------------------------------------------------------------- @@ -151,24 +153,37 @@ contentRangeHeader :: Integer -> Integer -> Integer -> H.Header contentRangeHeader beg end total = (H.hContentRange, range) where- range = C8.pack- -- building with ShowS- $ 'b' : 'y': 't' : 'e' : 's' : ' '- : (if beg > end then ('*':) else- showInt beg- . ('-' :)- . showInt end)- ( '/'- : showInt total "")+ range =+ C8.pack+ -- building with ShowS+ $+ 'b'+ : 'y'+ : 't'+ : 'e'+ : 's'+ : ' '+ : ( if beg > end+ then ('*' :)+ else+ showInt beg+ . ('-' :)+ . showInt end+ )+ ( '/'+ : showInt total ""+ ) -addContentHeaders :: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders+addContentHeaders+ :: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders addContentHeaders hs off len size- | len == size = hs'- | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size- in ctrng:hs'+ | len == size = hs'+ | otherwise =+ let !ctrng = contentRangeHeader off (off + len - 1) size+ in ctrng : hs' where !lengthBS = packIntegral len- !hs' = (H.hContentLength, lengthBS) : (H.hAcceptRanges,"bytes") : hs+ !hs' = (H.hContentLength, lengthBS) : (H.hAcceptRanges, "bytes") : hs -- | --@@ -176,7 +191,8 @@ -- [("Content-Range","bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")] -- >>> addContentHeadersForFilePart [] (FilePart 0 16 16) -- [("Content-Length","16"),("Accept-Ranges","bytes")]-addContentHeadersForFilePart :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders+addContentHeadersForFilePart+ :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders addContentHeadersForFilePart hs part = addContentHeaders hs off len size where off = filePartOffset part
Network/Wai/Handler/Warp/FileInfoCache.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE RecordWildCards, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-} module Network.Wai.Handler.Warp.FileInfoCache (- FileInfo(..)- , withFileInfoCache- , getInfo -- test purpose only- ) where+ FileInfo (..),+ withFileInfoCache,+ getInfo, -- test purpose only+) where import Control.Reaper import Network.HTTP.Date@@ -13,7 +14,7 @@ #else import System.Posix.Files #endif-import qualified UnliftIO (onException, bracket, throwIO)+import qualified UnliftIO (bracket, onException, throwIO) import Network.Wai.Handler.Warp.HashMap (HashMap) import qualified Network.Wai.Handler.Warp.HashMap as M@@ -22,16 +23,19 @@ ---------------------------------------------------------------- -- | File information.-data FileInfo = FileInfo {- fileInfoName :: !FilePath- , fileInfoSize :: !Integer- , fileInfoTime :: HTTPDate -- ^ Modification time- , fileInfoDate :: ByteString -- ^ Modification time in the GMT format- } deriving (Eq, Show)+data FileInfo = FileInfo+ { fileInfoName :: !FilePath+ , fileInfoSize :: !Integer+ , fileInfoTime :: HTTPDate+ -- ^ Modification time+ , fileInfoDate :: ByteString+ -- ^ Modification time in the GMT format+ }+ deriving (Eq, Show) data Entry = Negative | Positive FileInfo type Cache = HashMap Entry-type FileInfoCache = Reaper Cache (FilePath,Entry)+type FileInfoCache = Reaper Cache (FilePath, Entry) ---------------------------------------------------------------- @@ -41,19 +45,20 @@ fs <- getFileStatus path -- file access let regular = not (isDirectory fs) readable = fileMode fs `intersectFileModes` ownerReadMode /= 0- if regular && readable then do- let time = epochTimeToHTTPDate $ modificationTime fs- date = formatHTTPDate time- size = fromIntegral $ fileSize fs- info = FileInfo {- fileInfoName = path- , fileInfoSize = size- , fileInfoTime = time- , fileInfoDate = date- }- return info- else- UnliftIO.throwIO (userError "FileInfoCache:getInfo")+ if regular && readable+ then do+ let time = epochTimeToHTTPDate $ modificationTime fs+ date = formatHTTPDate time+ size = fromIntegral $ fileSize fs+ info =+ FileInfo+ { fileInfoName = path+ , fileInfoSize = size+ , fileInfoTime = time+ , fileInfoDate = date+ }+ return info+ else UnliftIO.throwIO (userError "FileInfoCache:getInfo") getInfoNaive :: FilePath -> IO FileInfo getInfoNaive = getInfo@@ -64,10 +69,11 @@ getAndRegisterInfo reaper@Reaper{..} path = do cache <- reaperRead case M.lookup path cache of- Just Negative -> UnliftIO.throwIO (userError "FileInfoCache:getAndRegisterInfo")+ Just Negative -> UnliftIO.throwIO (userError "FileInfoCache:getAndRegisterInfo") Just (Positive x) -> return x- Nothing -> positive reaper path- `UnliftIO.onException` negative reaper path+ Nothing ->+ positive reaper path+ `UnliftIO.onException` negative reaper path positive :: FileInfoCache -> FilePath -> IO FileInfo positive Reaper{..} path = do@@ -85,26 +91,28 @@ -- | Creating a file information cache -- and executing the action in the second argument. -- The first argument is a cache duration in second.-withFileInfoCache :: Int- -> ((FilePath -> IO FileInfo) -> IO a)- -> IO a-withFileInfoCache 0 action = action getInfoNaive+withFileInfoCache+ :: Int+ -> ((FilePath -> IO FileInfo) -> IO a)+ -> IO a+withFileInfoCache 0 action = action getInfoNaive withFileInfoCache duration action = UnliftIO.bracket- (initialize duration)- terminate- (action . getAndRegisterInfo)+ (initialize duration)+ terminate+ (action . getAndRegisterInfo) initialize :: Int -> IO FileInfoCache initialize duration = mkReaper settings where- settings = defaultReaperSettings {- reaperAction = override- , reaperDelay = duration- , reaperCons = \(path,v) -> M.insert path v- , reaperNull = M.isEmpty- , reaperEmpty = M.empty- }+ settings =+ defaultReaperSettings+ { reaperAction = override+ , reaperDelay = duration+ , reaperCons = \(path, v) -> M.insert path v+ , reaperNull = M.isEmpty+ , reaperEmpty = M.empty+ } override :: Cache -> IO (Cache -> Cache) override _ = return $ const M.empty
Network/Wai/Handler/Warp/HTTP1.hs view
@@ -5,20 +5,21 @@ {-# LANGUAGE ScopedTypeVariables #-} module Network.Wai.Handler.Warp.HTTP1 (- http1- ) where+ http1,+) where -import "iproute" Data.IP (toHostAddress, toHostAddress6) import qualified Control.Concurrent as Conc (yield)-import qualified UnliftIO-import UnliftIO (SomeException, fromException, throwIO) import qualified Data.ByteString as BS import Data.Char (chr) import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Network.Socket (SockAddr(SockAddrInet, SockAddrInet6))+import Data.Word8 (_cr, _space)+import Network.Socket (SockAddr (SockAddrInet, SockAddrInet6)) import Network.Wai import Network.Wai.Internal (ResponseReceived (ResponseReceived)) import qualified System.TimeManager as T+import UnliftIO (SomeException, fromException, throwIO)+import qualified UnliftIO+import "iproute" Data.IP (toHostAddress, toHostAddress6) import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Imports hiding (readInt)@@ -28,7 +29,16 @@ import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Types -http1 :: Settings -> InternalInfo -> Connection -> Transport -> Application -> SockAddr -> T.Handle -> ByteString -> IO ()+http1+ :: Settings+ -> InternalInfo+ -> Connection+ -> Transport+ -> Application+ -> SockAddr+ -> T.Handle+ -> ByteString+ -> IO () http1 settings ii conn transport app origAddr th bs0 = do istatus <- newIORef True src <- mkSource (wrappedRecv conn istatus (settingsSlowlorisSize settings))@@ -36,7 +46,7 @@ addr <- getProxyProtocolAddr src http1server settings ii conn transport app addr th istatus src where- wrappedRecv Connection { connRecv = recv } istatus slowlorisSize = do+ wrappedRecv Connection{connRecv = recv} istatus slowlorisSize = do bs <- recv unless (BS.null bs) $ do writeIORef istatus True@@ -54,56 +64,97 @@ seg <- readSource src if BS.isPrefixOf "PROXY " seg then parseProxyProtocolHeader src seg- else do leftoverSource src seg- return origAddr+ else do+ leftoverSource src seg+ return origAddr parseProxyProtocolHeader src seg = do- let (header,seg') = BS.break (== 0x0d) seg -- 0x0d == CR- maybeAddr = case BS.split 0x20 header of -- 0x20 == space- ["PROXY","TCP4",clientAddr,_,clientPort,_] ->+ let (header, seg') = BS.break (== _cr) seg+ maybeAddr = case BS.split _space header of+ ["PROXY", "TCP4", clientAddr, _, clientPort, _] -> case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of- [a] -> Just (SockAddrInet (readInt clientPort)- (toHostAddress a))+ [a] ->+ Just+ ( SockAddrInet+ (readInt clientPort)+ (toHostAddress a)+ ) _ -> Nothing- ["PROXY","TCP6",clientAddr,_,clientPort,_] ->+ ["PROXY", "TCP6", clientAddr, _, clientPort, _] -> case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of- [a] -> Just (SockAddrInet6 (readInt clientPort)- 0- (toHostAddress6 a)- 0)+ [a] ->+ Just+ ( SockAddrInet6+ (readInt clientPort)+ 0+ (toHostAddress6 a)+ 0+ ) _ -> Nothing- ("PROXY":"UNKNOWN":_) ->+ ("PROXY" : "UNKNOWN" : _) -> Just origAddr _ -> Nothing case maybeAddr of Nothing -> throwIO (BadProxyHeader (decodeAscii header))- Just a -> do leftoverSource src (BS.drop 2 seg') -- drop CRLF- return a+ Just a -> do+ leftoverSource src (BS.drop 2 seg') -- drop CRLF+ return a decodeAscii = map (chr . fromEnum) . BS.unpack -http1server :: Settings -> InternalInfo -> Connection -> Transport -> Application -> SockAddr -> T.Handle -> IORef Bool -> Source -> IO ()+http1server+ :: Settings+ -> InternalInfo+ -> Connection+ -> Transport+ -> Application+ -> SockAddr+ -> T.Handle+ -> IORef Bool+ -> Source+ -> IO () http1server settings ii conn transport app addr th istatus src = loop True `UnliftIO.catchAny` handler where handler e- -- See comment below referencing- -- https://github.com/yesodweb/wai/issues/618- | Just NoKeepAliveRequest <- fromException e = return ()- -- No valid request- | Just (BadFirstLine _) <- fromException e = return ()- | otherwise = do- _ <- sendErrorResponse settings ii conn th istatus defaultRequest { remoteHost = addr } e- throwIO e+ -- See comment below referencing+ -- https://github.com/yesodweb/wai/issues/618+ | Just NoKeepAliveRequest <- fromException e = return ()+ -- No valid request+ | Just (BadFirstLine _) <- fromException e = return ()+ | otherwise = do+ _ <-+ sendErrorResponse+ settings+ ii+ conn+ th+ istatus+ defaultRequest{remoteHost = addr}+ e+ throwIO e loop firstRequest = do- (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport- keepAlive <- processRequest settings ii conn app th istatus src req mremainingRef idxhdr nextBodyFlush- `UnliftIO.catchAny` \e -> do- settingsOnException settings (Just req) e- -- Don't throw the error again to prevent calling settingsOnException twice.- return False+ (req, mremainingRef, idxhdr, nextBodyFlush) <-+ recvRequest firstRequest settings conn ii th addr src transport+ keepAlive <-+ processRequest+ settings+ ii+ conn+ app+ th+ istatus+ src+ req+ mremainingRef+ idxhdr+ nextBodyFlush+ `UnliftIO.catchAny` \e -> do+ settingsOnException settings (Just req) e+ -- Don't throw the error again to prevent calling settingsOnException twice.+ return False -- When doing a keep-alive connection, the other side may just -- close the connection. We don't want to treat that as an@@ -116,7 +167,19 @@ when keepAlive $ loop False -processRequest :: Settings -> InternalInfo -> Connection -> Application -> T.Handle -> IORef Bool -> Source -> Request -> Maybe (IORef Int) -> IndexedHeader -> IO ByteString -> IO Bool+processRequest+ :: Settings+ -> InternalInfo+ -> Connection+ -> Application+ -> T.Handle+ -> IORef Bool+ -> Source+ -> Request+ -> Maybe (IORef Int)+ -> IndexedHeader+ -> IO ByteString+ -> IO Bool processRequest settings ii conn app th istatus src req mremainingRef idxhdr nextBodyFlush = do -- Let the application run for as long as it wants T.pause th@@ -137,8 +200,8 @@ case r of Right ResponseReceived -> return () Left (e :: SomeException)- | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e'- | otherwise -> do+ | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e'+ | otherwise -> do keepAlive <- sendErrorResponse settings ii conn th istatus req e settingsOnException settings (Just req) e writeIORef keepAliveRef keepAlive@@ -156,8 +219,7 @@ Conc.yield if keepAlive- then- -- If there is an unknown or large amount of data to still be read+ then -- If there is an unknown or large amount of data to still be read -- from the request body, simple drop this connection instead of -- reading it all in to satisfy a keep-alive request. case settingsMaximumBodyFlush settings of@@ -169,33 +231,47 @@ let tryKeepAlive = do -- flush the rest of the request body isComplete <- flushBody nextBodyFlush maxToRead- if isComplete then do- T.resume th- return True- else- return False+ if isComplete+ then do+ T.resume th+ return True+ else return False case mremainingRef of Just ref -> do remaining <- readIORef ref- if remaining <= maxToRead then- tryKeepAlive- else- return False+ if remaining <= maxToRead+ then tryKeepAlive+ else return False Nothing -> tryKeepAlive- else- return False+ else return False -sendErrorResponse :: Settings -> InternalInfo -> Connection -> T.Handle -> IORef Bool -> Request -> SomeException -> IO Bool+sendErrorResponse+ :: Settings+ -> InternalInfo+ -> Connection+ -> T.Handle+ -> IORef Bool+ -> Request+ -> SomeException+ -> IO Bool sendErrorResponse settings ii conn th istatus req e = do status <- readIORef istatus- if shouldSendErrorResponse e && status then- sendResponse settings conn ii th req defaultIndexRequestHeader (return BS.empty) errorResponse- else- return False+ if shouldSendErrorResponse e && status+ then+ sendResponse+ settings+ conn+ ii+ th+ req+ defaultIndexRequestHeader+ (return BS.empty)+ errorResponse+ else return False where shouldSendErrorResponse se- | Just ConnectionClosedByPeer <- fromException se = False- | otherwise = True+ | Just ConnectionClosedByPeer <- fromException se = False+ | otherwise = True errorResponse = settingsOnExceptionResponse settings e flushEntireBody :: IO ByteString -> IO ()@@ -206,9 +282,13 @@ bs <- src unless (BS.null bs) loop -flushBody :: IO ByteString -- ^ get next chunk- -> Int -- ^ maximum to flush- -> IO Bool -- ^ True == flushed the entire body, False == we didn't+flushBody+ :: IO ByteString+ -- ^ get next chunk+ -> Int+ -- ^ maximum to flush+ -> IO Bool+ -- ^ True == flushed the entire body, False == we didn't flushBody src = loop where loop toRead = do
Network/Wai/Handler/Warp/HTTP2.hs view
@@ -1,23 +1,23 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.Wai.Handler.Warp.HTTP2 (- http2- , http2server- ) where+ http2,+ http2server,+) where import qualified Data.ByteString as BS-import Data.IORef (IORef, newIORef, writeIORef, readIORef)+import Data.IORef (readIORef) import qualified Data.IORef as I import qualified Network.HTTP2.Frame as H2 import qualified Network.HTTP2.Server as H2 import Network.Socket (SockAddr) import Network.Socket.BufferPool import Network.Wai-import Network.Wai.Internal (ResponseReceived(..))+import Network.Wai.Internal (ResponseReceived (..)) import qualified System.TimeManager as T import qualified UnliftIO @@ -31,9 +31,17 @@ ---------------------------------------------------------------- -http2 :: S.Settings -> InternalInfo -> Connection -> Transport -> Application -> SockAddr -> T.Handle -> ByteString -> IO ()+http2+ :: S.Settings+ -> InternalInfo+ -> Connection+ -> Transport+ -> Application+ -> SockAddr+ -> T.Handle+ -> ByteString+ -> IO () http2 settings ii conn transport app peersa th bs = do- istatus <- newIORef False rawRecvN <- makeRecvN bs $ connRecv conn writeBuffer <- readIORef $ connWriteBuffer conn -- This thread becomes the sender in http2 library.@@ -43,23 +51,25 @@ -- output data from the worker. It's not good enough to tickle -- the time handler in the receiver only. So, we should tickle -- the time handler in both the receiver and the sender.- let recvN = wrappedRecvN th istatus (S.settingsSlowlorisSize settings) rawRecvN+ let recvN = wrappedRecvN th (S.settingsSlowlorisSize settings) rawRecvN sendBS x = connSendAll conn x >> T.tickle th- conf = H2.Config {- confWriteBuffer = bufBuffer writeBuffer- , confBufferSize = bufSize writeBuffer- , confSendAll = sendBS- , confReadN = recvN- , confPositionReadMaker = pReadMaker ii- , confTimeoutManager = timeoutManager ii+ conf =+ H2.Config+ { confWriteBuffer = bufBuffer writeBuffer+ , confBufferSize = bufSize writeBuffer+ , confSendAll = sendBS+ , confReadN = recvN+ , confPositionReadMaker = pReadMaker ii+ , confTimeoutManager = timeoutManager ii #if MIN_VERSION_http2(4,2,0)- , confMySockAddr = connMySockAddr conn- , confPeerSockAddr = peersa+ , confMySockAddr = connMySockAddr conn+ , confPeerSockAddr = peersa #endif- }+ } checkTLS setConnHTTP2 conn True- H2.run H2.defaultServerConfig conf $ http2server settings ii transport peersa app+ H2.run H2.defaultServerConfig conf $+ http2server settings ii transport peersa app where checkTLS = case transport of TCP -> return () -- direct@@ -69,32 +79,33 @@ -- | Converting WAI application to the server type of http2 library. -- -- Since 3.3.11-http2server :: S.Settings- -> InternalInfo- -> Transport- -> SockAddr- -> Application- -> H2.Server+http2server+ :: S.Settings+ -> InternalInfo+ -> Transport+ -> SockAddr+ -> Application+ -> H2.Server http2server settings ii transport addr app h2req0 aux0 response = do req <- toWAIRequest h2req0 aux0 ref <- I.newIORef Nothing eResponseReceived <- UnliftIO.tryAny $ app req $ \rsp -> do- (h2rsp,st,hasBody) <- fromResponse settings ii req rsp+ (h2rsp, st, hasBody) <- fromResponse settings ii req rsp pps <- if hasBody then fromPushPromises ii req else return [] I.writeIORef ref $ Just (h2rsp, pps, st) _ <- response h2rsp pps return ResponseReceived case eResponseReceived of- Right ResponseReceived -> do- Just (h2rsp, pps, st) <- I.readIORef ref- let msiz = fromIntegral <$> H2.responseBodySize h2rsp- logResponse req st msiz- mapM_ (logPushPromise req) pps- Left e -> do+ Right ResponseReceived -> do+ Just (h2rsp, pps, st) <- I.readIORef ref+ let msiz = fromIntegral <$> H2.responseBodySize h2rsp+ logResponse req st msiz+ mapM_ (logPushPromise req) pps+ Left e -> do S.settingsOnException settings (Just req) e let ersp = S.settingsOnExceptionResponse settings e st = responseStatus ersp- (h2rsp',_,_) <- fromResponse settings ii req ersp+ (h2rsp', _, _) <- fromResponse settings ii req ersp let msiz = fromIntegral <$> H2.responseBodySize h2rsp' _ <- response h2rsp' [] logResponse req st msiz@@ -115,23 +126,24 @@ !path = H2.promiseRequestPath pp !siz = case H2.responseBodySize $ H2.promiseResponse pp of Nothing -> 0- Just s -> fromIntegral s+ Just s -> fromIntegral s -wrappedRecvN :: T.Handle -> IORef Bool -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)-wrappedRecvN th istatus slowlorisSize readN bufsize = do- bs <- UnliftIO.handleAny handler $ readN bufsize- unless (BS.null bs) $ do- writeIORef istatus True+wrappedRecvN+ :: T.Handle -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)+wrappedRecvN th slowlorisSize readN bufsize = do+ bs <- UnliftIO.handleAny handler $ readN bufsize -- TODO: think about the slowloris protection in HTTP2: current code -- might open a slow-loris attack vector. Rather than timing we should -- consider limiting the per-client connections assuming that in HTTP2 -- we should allow only few connections per host (real-world -- deployments with large NATs may be trickier).- when (BS.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th+ when+ (BS.length bs > 0 && BS.length bs >= slowlorisSize || bufsize <= slowlorisSize) $+ T.tickle th return bs- where- handler :: UnliftIO.SomeException -> IO ByteString- handler _ = return ""+ where+ handler :: UnliftIO.SomeException -> IO ByteString+ handler _ = return "" -- connClose must not be called here since Run:fork calls it goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()
Network/Wai/Handler/Warp/HTTP2/PushPromise.hs view
@@ -3,9 +3,9 @@ module Network.Wai.Handler.Warp.HTTP2.PushPromise where -import qualified UnliftIO import qualified Network.HTTP.Types as H import qualified Network.HTTP2.Server as H2+import qualified UnliftIO import Network.Wai import Network.Wai.Handler.Warp.FileInfoCache@@ -17,19 +17,17 @@ fromPushPromises :: InternalInfo -> Request -> IO [H2.PushPromise] fromPushPromises ii req = do mh2data <- getHTTP2Data req- let pp = case mh2data of- Nothing -> []- Just h2data -> http2dataPushPromise h2data+ let pp = maybe [] http2dataPushPromise mh2data catMaybes <$> mapM (fromPushPromise ii) pp fromPushPromise :: InternalInfo -> PushPromise -> IO (Maybe H2.PushPromise) fromPushPromise ii (PushPromise path file rsphdr w) = do efinfo <- UnliftIO.tryIO $ getFileInfo ii file case efinfo of- Left (_ex :: UnliftIO.IOException) -> return Nothing- Right finfo -> do- let !siz = fromIntegral $ fileInfoSize finfo- !fileSpec = H2.FileSpec file 0 siz- !rsp = H2.responseFile H.ok200 rsphdr fileSpec- !pp = H2.pushPromise path rsp w- return $ Just pp+ Left (_ex :: UnliftIO.IOException) -> return Nothing+ Right finfo -> do+ let !siz = fromIntegral $ fileInfoSize finfo+ !fileSpec = H2.FileSpec file 0 siz+ !rsp = H2.responseFile H.ok200 rsphdr fileSpec+ !pp = H2.pushPromise path rsp w+ return $ Just pp
Network/Wai/Handler/Warp/HTTP2/Request.hs view
@@ -2,11 +2,11 @@ {-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.HTTP2.Request (- toRequest- , getHTTP2Data- , setHTTP2Data- , modifyHTTP2Data- ) where+ toRequest,+ getHTTP2Data,+ setHTTP2Data,+ modifyHTTP2Data,+) where import Control.Arrow (first) import qualified Data.ByteString.Char8 as C8@@ -17,7 +17,6 @@ import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai-import Network.Wai.Internal (Request(..)) import System.IO.Unsafe (unsafePerformIO) import qualified System.TimeManager as T @@ -27,10 +26,19 @@ #ifdef MIN_VERSION_crypton_x509 import Network.Wai.Handler.Warp.Request (getClientCertificateKey) #endif-import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)+import qualified Network.Wai.Handler.Warp.Settings as S (+ Settings,+ settingsNoParsePath,+ ) import Network.Wai.Handler.Warp.Types -type ToReq = (TokenHeaderList,ValueTable) -> Maybe Int -> IO ByteString -> T.Handle -> Transport -> IO Request+type ToReq =+ (TokenHeaderList, ValueTable)+ -> Maybe Int+ -> IO ByteString+ -> T.Handle+ -> Transport+ -> IO Request ---------------------------------------------------------------- @@ -42,36 +50,41 @@ ref <- newIORef Nothing toRequest' ii settings addr ref ht bodylen body th transport -toRequest' :: InternalInfo -> S.Settings -> SockAddr- -> IORef (Maybe HTTP2Data)- -> ToReq-toRequest' ii settings addr ref (reqths,reqvt) bodylen body th transport = return req+toRequest'+ :: InternalInfo+ -> S.Settings+ -> SockAddr+ -> IORef (Maybe HTTP2Data)+ -> ToReq+toRequest' ii settings addr ref (reqths, reqvt) bodylen body th transport =+ -- setting 'requestBody' with 'setRequestBodyChunks' to avoid warnings+ return $! setRequestBodyChunks body req where- !req = Request {- requestMethod = colonMethod- , httpVersion = if isTransportQUIC transport then http30 else H.http20- , rawPathInfo = rawPath- , pathInfo = H.decodePathSegments path- , rawQueryString = query- , queryString = H.parseQuery query- , requestHeaders = headers- , isSecure = isTransportSecure transport- , remoteHost = addr- , requestBody = body- , vault = vaultValue- , requestBodyLength = maybe ChunkedBody (KnownLength . fromIntegral) bodylen- , requestHeaderHost = mHost <|> mAuth- , requestHeaderRange = mRange- , requestHeaderReferer = mReferer- , requestHeaderUserAgent = mUserAgent- }+ !req =+ defaultRequest+ { requestMethod = colonMethod+ , httpVersion = if isTransportQUIC transport then http30 else H.http20+ , rawPathInfo = rawPath+ , pathInfo = H.decodePathSegments path+ , rawQueryString = query+ , queryString = H.parseQuery query+ , requestHeaders = headers+ , isSecure = isTransportSecure transport+ , remoteHost = addr+ , vault = vaultValue+ , requestBodyLength = maybe ChunkedBody (KnownLength . fromIntegral) bodylen+ , requestHeaderHost = mHost <|> mAuth+ , requestHeaderRange = mRange+ , requestHeaderReferer = mReferer+ , requestHeaderUserAgent = mUserAgent+ } headers = map (first tokenKey) ths where ths = case mHost of- Just _ -> reqths+ Just _ -> reqths Nothing -> case mAuth of- Just auth -> (tokenHost, auth) : reqths- _ -> reqths+ Just auth -> (tokenHost, auth) : reqths+ _ -> reqths !mPath = getHeaderValue tokenPath reqvt -- SHOULD !colonMethod = fromJust $ getHeaderValue tokenMethod reqvt -- MUST !mAuth = getHeaderValue tokenAuthority reqvt -- SHOULD@@ -81,19 +94,20 @@ !mUserAgent = getHeaderValue tokenUserAgent reqvt -- CONNECT request will have ":path" omitted, use ":authority" as unparsed -- path instead so that it will have consistent behavior compare to HTTP 1.0- (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth)+ (unparsedPath, query) = C8.break (== '?') $ fromJust (mPath <|> mAuth) !path = H.extractPath unparsedPath !rawPath = if S.settingsNoParsePath settings then unparsedPath else path -- fixme: pauseTimeout. th is not available here.- !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii)- $ Vault.insert getHTTP2DataKey (readIORef ref)- $ Vault.insert setHTTP2DataKey (writeIORef ref)- $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)- $ Vault.insert pauseTimeoutKey (T.pause th)+ !vaultValue =+ Vault.insert getFileInfoKey (getFileInfo ii)+ . Vault.insert getHTTP2DataKey (readIORef ref)+ . Vault.insert setHTTP2DataKey (writeIORef ref)+ . Vault.insert modifyHTTP2DataKey (modifyIORef' ref)+ . Vault.insert pauseTimeoutKey (T.pause th) #ifdef MIN_VERSION_crypton_x509- $ Vault.insert getClientCertificateKey (getTransportClientCertificate transport)+ . Vault.insert getClientCertificateKey (getTransportClientCertificate transport) #endif- Vault.empty+ $ Vault.empty getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data)) getHTTP2DataKey = unsafePerformIO Vault.newKey@@ -105,8 +119,8 @@ -- Since: 3.2.7 getHTTP2Data :: Request -> IO (Maybe HTTP2Data) getHTTP2Data req = case Vault.lookup getHTTP2DataKey (vault req) of- Nothing -> return Nothing- Just getter -> getter+ Nothing -> return Nothing+ Just getter -> getter setHTTP2DataKey :: Vault.Key (Maybe HTTP2Data -> IO ()) setHTTP2DataKey = unsafePerformIO Vault.newKey@@ -118,8 +132,8 @@ -- Since: 3.2.7 setHTTP2Data :: Request -> Maybe HTTP2Data -> IO () setHTTP2Data req mh2d = case Vault.lookup setHTTP2DataKey (vault req) of- Nothing -> return ()- Just setter -> setter mh2d+ Nothing -> return ()+ Just setter -> setter mh2d modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()) modifyHTTP2DataKey = unsafePerformIO Vault.newKey@@ -131,5 +145,5 @@ -- Since: 3.2.8 modifyHTTP2Data :: Request -> (Maybe HTTP2Data -> Maybe HTTP2Data) -> IO () modifyHTTP2Data req func = case Vault.lookup modifyHTTP2DataKey (vault req) of- Nothing -> return ()- Just modify -> modify func+ Nothing -> return ()+ Just modify -> modify func
Network/Wai/Handler/Warp/HTTP2/Response.hs view
@@ -1,50 +1,55 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.Wai.Handler.Warp.HTTP2.Response (- fromResponse- ) where+ fromResponse,+) where import qualified Data.ByteString.Builder as BB import qualified Data.List as L (find) import qualified Network.HTTP.Types as H import qualified Network.HTTP2.Server as H2-import Network.Wai hiding (responseFile, responseBuilder, responseStream)-import Network.Wai.Internal (Response(..))+import Network.Wai hiding (responseBuilder, responseFile, responseStream)+import Network.Wai.Internal (Response (..)) import qualified UnliftIO import Network.Wai.Handler.Warp.File-import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data) import Network.Wai.Handler.Warp.HTTP2.Types+import Network.Wai.Handler.Warp.Header import qualified Network.Wai.Handler.Warp.Response as R import qualified Network.Wai.Handler.Warp.Settings as S import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- -fromResponse :: S.Settings -> InternalInfo -> Request -> Response -> IO (H2.Response, H.Status, Bool)+fromResponse+ :: S.Settings+ -> InternalInfo+ -> Request+ -> Response+ -> IO (H2.Response, H.Status, Bool) fromResponse settings ii req rsp = do date <- getDate ii rspst@(h2rsp, st, hasBody) <- case rsp of- ResponseFile st rsphdr path mpart -> do- let rsphdr' = add date rsphdr- responseFile st rsphdr' method path mpart ii reqhdr- ResponseBuilder st rsphdr builder -> do- let rsphdr' = add date rsphdr- return $ responseBuilder st rsphdr' method builder- ResponseStream st rsphdr strmbdy -> do- let rsphdr' = add date rsphdr- return $ responseStream st rsphdr' method strmbdy- _ -> error "ResponseRaw is not supported in HTTP/2"+ ResponseFile st rsphdr path mpart -> do+ let rsphdr' = add date rsphdr+ responseFile st rsphdr' method path mpart ii reqhdr+ ResponseBuilder st rsphdr builder -> do+ let rsphdr' = add date rsphdr+ return $ responseBuilder st rsphdr' method builder+ ResponseStream st rsphdr strmbdy -> do+ let rsphdr' = add date rsphdr+ return $ responseStream st rsphdr' method strmbdy+ _ -> error "ResponseRaw is not supported in HTTP/2" mh2data <- getHTTP2Data req case mh2data of- Nothing -> return rspst- Just h2data -> do- let !trailers = http2dataTrailers h2data- !h2rsp' = H2.setResponseTrailersMaker h2rsp trailers- return (h2rsp', st, hasBody)+ Nothing -> return rspst+ Just h2data -> do+ let !trailers = http2dataTrailers h2data+ !h2rsp' = H2.setResponseTrailersMaker h2rsp trailers+ return (h2rsp', st, hasBody) where !method = requestMethod req !reqhdr = requestHeaders req@@ -53,24 +58,28 @@ let hasServerHdr = L.find ((== H.hServer) . fst) rsphdr addSVR = maybe ((H.hServer, server) :) (const id) hasServerHdr- in R.addAltSvc settings $- (H.hDate, date) : addSVR rsphdr+ in R.addAltSvc settings $+ (H.hDate, date) : addSVR rsphdr ---------------------------------------------------------------- -responseFile :: H.Status -> H.ResponseHeaders -> H.Method- -> FilePath -> Maybe FilePart -> InternalInfo -> H.RequestHeaders- -> IO (H2.Response, H.Status, Bool)+responseFile+ :: H.Status+ -> H.ResponseHeaders+ -> H.Method+ -> FilePath+ -> Maybe FilePart+ -> InternalInfo+ -> H.RequestHeaders+ -> IO (H2.Response, H.Status, Bool) responseFile st rsphdr _ _ _ _ _- | noBody st = return $ responseNoBody st rsphdr-+ | noBody st = return $ responseNoBody st rsphdr responseFile st rsphdr method path (Just fp) _ _ = return $ responseFile2XX st rsphdr method fileSpec where- !off' = fromIntegral $ filePartOffset fp+ !off' = fromIntegral $ filePartOffset fp !bytes' = fromIntegral $ filePartByteCount fp !fileSpec = H2.FileSpec path off' bytes'- responseFile _ rsphdr method path Nothing ii reqhdr = do efinfo <- UnliftIO.tryIO $ getFileInfo ii path case efinfo of@@ -79,37 +88,48 @@ let reqidx = indexRequestHeader reqhdr rspidx = indexResponseHeader rsphdr case conditionalRequest finfo rsphdr method rspidx reqidx of- WithoutBody s -> return $ responseNoBody s rsphdr+ WithoutBody s -> return $ responseNoBody s rsphdr WithBody s rsphdr' off bytes -> do- let !off' = fromIntegral off+ let !off' = fromIntegral off !bytes' = fromIntegral bytes !fileSpec = H2.FileSpec path off' bytes' return $ responseFile2XX s rsphdr' method fileSpec ---------------------------------------------------------------- -responseFile2XX :: H.Status -> H.ResponseHeaders -> H.Method -> H2.FileSpec -> (H2.Response, H.Status, Bool)+responseFile2XX+ :: H.Status+ -> H.ResponseHeaders+ -> H.Method+ -> H2.FileSpec+ -> (H2.Response, H.Status, Bool) responseFile2XX st rsphdr method fileSpec- | method == H.methodHead = responseNoBody st rsphdr- | otherwise = (H2.responseFile st rsphdr fileSpec, st, True)+ | method == H.methodHead = responseNoBody st rsphdr+ | otherwise = (H2.responseFile st rsphdr fileSpec, st, True) ---------------------------------------------------------------- -responseBuilder :: H.Status -> H.ResponseHeaders -> H.Method- -> BB.Builder- -> (H2.Response, H.Status, Bool)+responseBuilder+ :: H.Status+ -> H.ResponseHeaders+ -> H.Method+ -> BB.Builder+ -> (H2.Response, H.Status, Bool) responseBuilder st rsphdr method builder- | method == H.methodHead || noBody st = responseNoBody st rsphdr- | otherwise = (H2.responseBuilder st rsphdr builder, st, True)+ | method == H.methodHead || noBody st = responseNoBody st rsphdr+ | otherwise = (H2.responseBuilder st rsphdr builder, st, True) ---------------------------------------------------------------- -responseStream :: H.Status -> H.ResponseHeaders -> H.Method- -> StreamingBody- -> (H2.Response, H.Status, Bool)+responseStream+ :: H.Status+ -> H.ResponseHeaders+ -> H.Method+ -> StreamingBody+ -> (H2.Response, H.Status, Bool) responseStream st rsphdr method strmbdy- | method == H.methodHead || noBody st = responseNoBody st rsphdr- | otherwise = (H2.responseStreaming st rsphdr strmbdy, st, True)+ | method == H.methodHead || noBody st = responseNoBody st rsphdr+ | otherwise = (H2.responseStreaming st rsphdr strmbdy, st, True) ----------------------------------------------------------------
Network/Wai/Handler/Warp/HTTP2/Types.hs view
@@ -18,7 +18,7 @@ isHTTP2 tls = useHTTP2 where useHTTP2 = case tlsNegotiatedProtocol tls of- Nothing -> False+ Nothing -> False Just proto -> "h2" `BS.isPrefixOf` proto ----------------------------------------------------------------@@ -26,15 +26,15 @@ -- | HTTP/2 specific data. -- -- Since: 3.2.7-data HTTP2Data = HTTP2Data {- -- | Accessor for 'PushPromise' in 'HTTP2Data'.+data HTTP2Data = HTTP2Data+ { http2dataPushPromise :: [PushPromise]+ -- ^ Accessor for 'PushPromise' in 'HTTP2Data'. -- -- Since: 3.2.7- http2dataPushPromise :: [PushPromise]- -- | Accessor for 'H2.TrailersMaker' in 'HTTP2Data'.+ , http2dataTrailers :: H2.TrailersMaker+ -- ^ Accessor for 'H2.TrailersMaker' in 'HTTP2Data'. -- -- Since: 3.2.8 but the type changed in 3.3.0- , http2dataTrailers :: H2.TrailersMaker } -- | Default HTTP/2 specific data.@@ -48,30 +48,31 @@ -- while the HTTP/2 library supports other types. -- -- Since: 3.2.7-data PushPromise = PushPromise {- -- | Accessor for a URL path in 'PushPromise'.+data PushPromise = PushPromise+ { promisedPath :: ByteString+ -- ^ Accessor for a URL path in 'PushPromise'. -- E.g. \"\/style\/default.css\". -- -- Since: 3.2.7- promisedPath :: ByteString- -- | Accessor for 'FilePath' in 'PushPromise'.+ , promisedFile :: FilePath+ -- ^ Accessor for 'FilePath' in 'PushPromise'. -- E.g. \"FILE_PATH/default.css\". -- -- Since: 3.2.7- , promisedFile :: FilePath- -- | Accessor for 'H.ResponseHeaders' in 'PushPromise'+ , promisedResponseHeaders :: H.ResponseHeaders+ -- ^ Accessor for 'H.ResponseHeaders' in 'PushPromise' -- \"content-type\" must be specified. -- Default value: []. -- -- -- Since: 3.2.7- , promisedResponseHeaders :: H.ResponseHeaders- -- | Accessor for 'Weight' in 'PushPromise'.+ , promisedWeight :: Weight+ -- ^ Accessor for 'Weight' in 'PushPromise'. -- Default value: 16. -- -- Since: 3.2.7- , promisedWeight :: Weight- } deriving (Eq,Ord,Show)+ }+ deriving (Eq, Ord, Show) -- | Default push promise. --
Network/Wai/Handler/Warp/HashMap.hs view
@@ -28,8 +28,9 @@ ---------------------------------------------------------------- insert :: FilePath -> v -> HashMap v -> HashMap v-insert path v (HashMap hm) = HashMap- $ I.insertWith M.union (hash path) (M.singleton path v) hm+insert path v (HashMap hm) =+ HashMap $+ I.insertWith M.union (hash path) (M.singleton path v) hm lookup :: FilePath -> HashMap v -> Maybe v lookup path (HashMap hm) = I.lookup (hash path) hm >>= M.lookup path
Network/Wai/Handler/Warp/Header.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.Header where @@ -20,20 +21,21 @@ indexRequestHeader :: RequestHeaders -> IndexedHeader indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex -data RequestHeaderIndex = ReqContentLength- | ReqTransferEncoding- | ReqExpect- | ReqConnection- | ReqRange- | ReqHost- | ReqIfModifiedSince- | ReqIfUnmodifiedSince- | ReqIfRange- | ReqReferer- | ReqUserAgent- | ReqIfMatch- | ReqIfNoneMatch- deriving (Enum,Bounded)+data RequestHeaderIndex+ = ReqContentLength+ | ReqTransferEncoding+ | ReqExpect+ | ReqConnection+ | ReqRange+ | ReqHost+ | ReqIfModifiedSince+ | ReqIfUnmodifiedSince+ | ReqIfRange+ | ReqReferer+ | ReqUserAgent+ | ReqIfMatch+ | ReqIfNoneMatch+ deriving (Enum, Bounded) -- | The size for 'IndexedHeader' for HTTP Request. -- From 0 to this corresponds to:@@ -56,36 +58,40 @@ requestKeyIndex :: HeaderName -> Int requestKeyIndex hn = case BS.length bs of- 4 | bs == "host" -> fromEnum ReqHost- 5 | bs == "range" -> fromEnum ReqRange- 6 | bs == "expect" -> fromEnum ReqExpect- 7 | bs == "referer" -> fromEnum ReqReferer- 8 | bs == "if-range" -> fromEnum ReqIfRange- | bs == "if-match" -> fromEnum ReqIfMatch- 10 | bs == "user-agent" -> fromEnum ReqUserAgent- | bs == "connection" -> fromEnum ReqConnection- 13 | bs == "if-none-match" -> fromEnum ReqIfNoneMatch- 14 | bs == "content-length" -> fromEnum ReqContentLength- 17 | bs == "transfer-encoding" -> fromEnum ReqTransferEncoding- | bs == "if-modified-since" -> fromEnum ReqIfModifiedSince- 19 | bs == "if-unmodified-since" -> fromEnum ReqIfUnmodifiedSince- _ -> -1+ 4 | bs == "host" -> fromEnum ReqHost+ 5 | bs == "range" -> fromEnum ReqRange+ 6 | bs == "expect" -> fromEnum ReqExpect+ 7 | bs == "referer" -> fromEnum ReqReferer+ 8+ | bs == "if-range" -> fromEnum ReqIfRange+ | bs == "if-match" -> fromEnum ReqIfMatch+ 10+ | bs == "user-agent" -> fromEnum ReqUserAgent+ | bs == "connection" -> fromEnum ReqConnection+ 13 | bs == "if-none-match" -> fromEnum ReqIfNoneMatch+ 14 | bs == "content-length" -> fromEnum ReqContentLength+ 17+ | bs == "transfer-encoding" -> fromEnum ReqTransferEncoding+ | bs == "if-modified-since" -> fromEnum ReqIfModifiedSince+ 19 | bs == "if-unmodified-since" -> fromEnum ReqIfUnmodifiedSince+ _ -> -1 where bs = foldedCase hn defaultIndexRequestHeader :: IndexedHeader-defaultIndexRequestHeader = array (0, requestMaxIndex) [(i, Nothing) | i <- [0..requestMaxIndex]]+defaultIndexRequestHeader = array (0, requestMaxIndex) [(i, Nothing) | i <- [0 .. requestMaxIndex]] ---------------------------------------------------------------- indexResponseHeader :: ResponseHeaders -> IndexedHeader indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex -data ResponseHeaderIndex = ResContentLength- | ResServer- | ResDate- | ResLastModified- deriving (Enum,Bounded)+data ResponseHeaderIndex+ = ResContentLength+ | ResServer+ | ResDate+ | ResLastModified+ deriving (Enum, Bounded) -- | The size for 'IndexedHeader' for HTTP Response. responseMaxIndex :: Int@@ -93,11 +99,11 @@ responseKeyIndex :: HeaderName -> Int responseKeyIndex hn = case BS.length bs of- 4 | bs == "date" -> fromEnum ResDate- 6 | bs == "server" -> fromEnum ResServer+ 4 | bs == "date" -> fromEnum ResDate+ 6 | bs == "server" -> fromEnum ResServer 13 | bs == "last-modified" -> fromEnum ResLastModified 14 | bs == "content-length" -> fromEnum ResContentLength- _ -> -1+ _ -> -1 where bs = foldedCase hn @@ -105,12 +111,12 @@ traverseHeader :: [Header] -> Int -> (HeaderName -> Int) -> IndexedHeader traverseHeader hdr maxidx getIndex = runSTArray $ do- arr <- newArray (0,maxidx) Nothing+ arr <- newArray (0, maxidx) Nothing mapM_ (insert arr) hdr return arr where- insert arr (key,val)- | idx == -1 = return ()- | otherwise = writeArray arr idx (Just val)+ insert arr (key, val)+ | idx == -1 = return ()+ | otherwise = writeArray arr idx (Just val) where idx = getIndex key
Network/Wai/Handler/Warp/IO.hs view
@@ -8,39 +8,43 @@ import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types -toBufIOWith :: Int -> IORef WriteBuffer -> (ByteString -> IO ()) -> Builder -> IO Integer+toBufIOWith+ :: Int -> IORef WriteBuffer -> (ByteString -> IO ()) -> Builder -> IO Integer toBufIOWith maxRspBufSize writeBufferRef io builder = do- writeBuffer <- readIORef writeBufferRef- loop writeBuffer firstWriter 0+ writeBuffer <- readIORef writeBufferRef+ loop writeBuffer firstWriter 0 where firstWriter = runBuilder builder loop writeBuffer writer bytesSent = do- let buf = bufBuffer writeBuffer- size = bufSize writeBuffer- (len, signal) <- writer buf size- bufferIO buf len io- let totalBytesSent = toInteger len + bytesSent- case signal of- Done -> return totalBytesSent- More minSize next- | size < minSize -> do- when (minSize > maxRspBufSize) $- error $ "Sending a Builder response required a buffer of size "- ++ show minSize ++ " which is bigger than the specified maximum of "- ++ show maxRspBufSize ++ "!"- -- The current WriteBuffer is too small to fit the next- -- batch of bytes from the Builder so we free it and- -- create a new bigger one. Freeing the current buffer,- -- creating a new one and writing it to the IORef need- -- to be performed atomically to prevent both double- -- frees and missed frees. So we mask async exceptions:- biggerWriteBuffer <- mask_ $ do- bufFree writeBuffer- biggerWriteBuffer <- createWriteBuffer minSize- writeIORef writeBufferRef biggerWriteBuffer- return biggerWriteBuffer- loop biggerWriteBuffer next totalBytesSent- | otherwise -> loop writeBuffer next totalBytesSent- Chunk bs next -> do- io bs- loop writeBuffer next totalBytesSent+ let buf = bufBuffer writeBuffer+ size = bufSize writeBuffer+ (len, signal) <- writer buf size+ bufferIO buf len io+ let totalBytesSent = toInteger len + bytesSent+ case signal of+ Done -> return totalBytesSent+ More minSize next+ | size < minSize -> do+ when (minSize > maxRspBufSize) $+ error $+ "Sending a Builder response required a buffer of size "+ ++ show minSize+ ++ " which is bigger than the specified maximum of "+ ++ show maxRspBufSize+ ++ "!"+ -- The current WriteBuffer is too small to fit the next+ -- batch of bytes from the Builder so we free it and+ -- create a new bigger one. Freeing the current buffer,+ -- creating a new one and writing it to the IORef need+ -- to be performed atomically to prevent both double+ -- frees and missed frees. So we mask async exceptions:+ biggerWriteBuffer <- mask_ $ do+ bufFree writeBuffer+ biggerWriteBuffer <- createWriteBuffer minSize+ writeIORef writeBufferRef biggerWriteBuffer+ return biggerWriteBuffer+ loop biggerWriteBuffer next totalBytesSent+ | otherwise -> loop writeBuffer next totalBytesSent+ Chunk bs next -> do+ io bs+ loop writeBuffer next totalBytesSent
Network/Wai/Handler/Warp/Imports.hs view
@@ -1,23 +1,23 @@ module Network.Wai.Handler.Warp.Imports (- ByteString(..)- , NonEmpty(..)- , module Control.Applicative- , module Control.Monad- , module Data.Bits- , module Data.Int- , module Data.Monoid- , module Data.Ord- , module Data.Word- , module Data.Maybe- , module Numeric- ) where+ ByteString (..),+ NonEmpty (..),+ module Control.Applicative,+ module Control.Monad,+ module Data.Bits,+ module Data.Int,+ module Data.Monoid,+ module Data.Ord,+ module Data.Word,+ module Data.Maybe,+ module Numeric,+) where import Control.Applicative import Control.Monad import Data.Bits-import Data.ByteString.Internal (ByteString(..))+import Data.ByteString.Internal (ByteString (..)) import Data.Int-import Data.List.NonEmpty (NonEmpty(..))+import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.Monoid import Data.Ord
Network/Wai/Handler/Warp/Internal.hs view
@@ -2,40 +2,49 @@ module Network.Wai.Handler.Warp.Internal ( -- * Settings- Settings (..)- , ProxyProtocol(..)+ Settings (..),+ ProxyProtocol (..),+ -- * Low level run functions- , runSettingsConnection- , runSettingsConnectionMaker- , runSettingsConnectionMakerSecure- , Transport (..)+ runSettingsConnection,+ runSettingsConnectionMaker,+ runSettingsConnectionMakerSecure,+ Transport (..),+ -- * Connection- , Connection (..)- , socketConnection+ Connection (..),+ socketConnection,+ -- ** Receive- , Recv- , RecvBuf+ Recv,+ RecvBuf,+ -- ** Buffer- , Buffer- , BufSize- , WriteBuffer(..)- , createWriteBuffer- , allocateBuffer- , freeBuffer- , copy+ Buffer,+ BufSize,+ WriteBuffer (..),+ createWriteBuffer,+ allocateBuffer,+ freeBuffer,+ copy,+ -- ** Sendfile- , FileId (..)- , SendFile- , sendFile- , readSendFile+ FileId (..),+ SendFile,+ sendFile,+ readSendFile,+ -- * Version- , warpVersion+ warpVersion,+ -- * Data types- , InternalInfo (..)- , HeaderValue- , IndexedHeader- , requestMaxIndex+ InternalInfo (..),+ HeaderValue,+ IndexedHeader,+ requestMaxIndex,+ -- * Time out manager+ -- | -- -- In order to provide slowloris protection, Warp provides timeout handlers. We@@ -53,25 +62,31 @@ -- resumed as soon as we return from user code. -- -- * Every time data is successfully sent to the client, the timeout is tickled.- , module System.TimeManager+ module System.TimeManager,+ -- * File descriptor cache- , module Network.Wai.Handler.Warp.FdCache+ module Network.Wai.Handler.Warp.FdCache,+ -- * File information cache- , module Network.Wai.Handler.Warp.FileInfoCache+ module Network.Wai.Handler.Warp.FileInfoCache,+ -- * Date- , module Network.Wai.Handler.Warp.Date+ module Network.Wai.Handler.Warp.Date,+ -- * Request and response- , Source- , recvRequest- , sendResponse+ Source,+ recvRequest,+ sendResponse,+ -- * Platform dependent helper functions- , setSocketCloseOnExec- , windowsThreadBlockHack+ setSocketCloseOnExec,+ windowsThreadBlockHack,+ -- * Misc- , http2server- , withII- , pReadMaker- ) where+ http2server,+ withII,+ pReadMaker,+) where import Network.Socket.BufferPool import System.TimeManager
Network/Wai/Handler/Warp/MultiMap.hs view
@@ -1,14 +1,14 @@ module Network.Wai.Handler.Warp.MultiMap (- MultiMap- , isEmpty- , empty- , singleton- , insert- , Network.Wai.Handler.Warp.MultiMap.lookup- , pruneWith- , toList- , merge- ) where+ MultiMap,+ isEmpty,+ empty,+ singleton,+ insert,+ Network.Wai.Handler.Warp.MultiMap.lookup,+ pruneWith,+ toList,+ merge,+) where import Control.Monad (filterM) import Data.Hashable (hash)@@ -28,7 +28,7 @@ -- Because only positive entries are stored, -- Malicious attack cannot cause the inner list to blow up. -- So, lists are good enough.-newtype MultiMap v = MultiMap (IntMap [(FilePath,v)])+newtype MultiMap v = MultiMap (IntMap [(FilePath, v)]) ---------------------------------------------------------------- @@ -44,7 +44,7 @@ -- | O(1) singleton :: FilePath -> v -> MultiMap v-singleton path v = MultiMap $ I.singleton (hash path) [(path,v)]+singleton path v = MultiMap $ I.singleton (hash path) [(path, v)] ---------------------------------------------------------------- @@ -52,35 +52,37 @@ lookup :: FilePath -> MultiMap v -> Maybe v lookup path (MultiMap mm) = case I.lookup (hash path) mm of Nothing -> Nothing- Just s -> Prelude.lookup path s+ Just s -> Prelude.lookup path s ---------------------------------------------------------------- -- | O(log n) insert :: FilePath -> v -> MultiMap v -> MultiMap v-insert path v (MultiMap mm) = MultiMap- $ I.insertWith (<>) (hash path) [(path,v)] mm+insert path v (MultiMap mm) =+ MultiMap $+ I.insertWith (<>) (hash path) [(path, v)] mm ---------------------------------------------------------------- -- | O(n)-toList :: MultiMap v -> [(FilePath,v)]+toList :: MultiMap v -> [(FilePath, v)] toList (MultiMap mm) = concatMap snd $ I.toAscList mm ---------------------------------------------------------------- -- | O(n)-pruneWith :: MultiMap v- -> ((FilePath,v) -> IO Bool)- -> IO (MultiMap v)-pruneWith (MultiMap mm) action- = I.foldrWithKey go (pure . MultiMap) mm I.empty+pruneWith+ :: MultiMap v+ -> ((FilePath, v) -> IO Bool)+ -> IO (MultiMap v)+pruneWith (MultiMap mm) action =+ I.foldrWithKey go (pure . MultiMap) mm I.empty where go h s cont acc = do- rs <- filterM action s- case rs of- [] -> cont acc- _ -> cont $! I.insert h rs acc+ rs <- filterM action s+ case rs of+ [] -> cont acc+ _ -> cont $! I.insert h rs acc ----------------------------------------------------------------
Network/Wai/Handler/Warp/PackInt.hs view
@@ -1,23 +1,16 @@-{-# LANGUAGE OverloadedStrings, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.PackInt where import Data.ByteString.Internal (unsafeCreate)+import Data.Word8 (_0) import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (poke) import qualified Network.HTTP.Types as H import Network.Wai.Handler.Warp.Imports --- $setup--- >>> import Data.ByteString.Char8 as C8--- >>> import Test.QuickCheck (Large(..))---- |------ prop> packIntegral (abs n) == C8.pack (show (abs n))--- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packIntegral n' == C8.pack (show n')- packIntegral :: Integral a => a -> ByteString packIntegral 0 = "0" packIntegral n | n < 0 = error "packIntegral"@@ -28,10 +21,9 @@ go0 p = go n $ p `plusPtr` (len - 1) go :: Integral a => a -> Ptr Word8 -> IO () go i p = do- let (d,r) = i `divMod` 10- poke p (48 + fromIntegral r)+ let (d, r) = i `divMod` 10+ poke p (_0 + fromIntegral r) when (d /= 0) $ go d (p `plusPtr` (-1))- {-# SPECIALIZE packIntegral :: Int -> ByteString #-} {-# SPECIALIZE packIntegral :: Integer -> ByteString #-} @@ -41,16 +33,15 @@ -- "200" -- >>> packStatus H.preconditionFailed412 -- "412"- packStatus :: H.Status -> ByteString packStatus status = unsafeCreate 3 $ \p -> do- poke p (toW8 r2)+ poke p (toW8 r2) poke (p `plusPtr` 1) (toW8 r1) poke (p `plusPtr` 2) (toW8 r0) where toW8 :: Int -> Word8- toW8 n = 48 + fromIntegral n+ toW8 n = _0 + fromIntegral n !s = fromIntegral $ H.statusCode status- (!q0,!r0) = s `divMod` 10- (!q1,!r1) = q0 `divMod` 10+ (!q0, !r0) = s `divMod` 10+ (!q1, !r1) = q0 `divMod` 10 !r2 = q1 `mod` 10
Network/Wai/Handler/Warp/ReadInt.hs view
@@ -1,19 +1,22 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-} -- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com> -- License : BSD3 module Network.Wai.Handler.Warp.ReadInt (- readInt- , readInt64- ) where+ readInt,+ readInt64,+) where import qualified Data.ByteString as S+import Data.Word8 (isDigit, _0) import Network.Wai.Handler.Warp.Imports hiding (readInt) {-# INLINE readInt #-}++-- | Will 'takeWhile isDigit' and return the parsed 'Integral'. readInt :: Integral a => ByteString -> a readInt bs = fromIntegral $ readInt64 bs @@ -27,8 +30,6 @@ {-# NOINLINE readInt64 #-} readInt64 :: ByteString -> Int64-readInt64 bs = S.foldl' (\ !i !c -> i * 10 + fromIntegral (c - 48)) 0- $ S.takeWhile isDigit bs--isDigit :: Word8 -> Bool-isDigit w = w >= 48 && w <= 57+readInt64 bs =+ S.foldl' (\ !i !c -> i * 10 + fromIntegral (c - _0)) 0 $+ S.takeWhile isDigit bs
Network/Wai/Handler/Warp/Request.hs view
@@ -1,22 +1,20 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Request (- recvRequest- , headerLines- , pauseTimeoutKey- , getFileInfoKey+ recvRequest,+ headerLines,+ pauseTimeoutKey,+ getFileInfoKey, #ifdef MIN_VERSION_crypton_x509- , getClientCertificateKey+ getClientCertificateKey, #endif- , NoKeepAliveRequest (..)- ) where+ NoKeepAliveRequest (..),+) where import qualified Control.Concurrent as Conc (yield)-import UnliftIO (throwIO, Exception) import Data.Array ((!)) import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as SU@@ -24,17 +22,19 @@ import qualified Data.IORef as I import Data.Typeable (Typeable) import qualified Data.Vault.Lazy as Vault+import Data.Word8 (_cr, _lf) #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif+import UnliftIO (Exception, throwIO) import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai 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 Prelude hiding (lines) import Network.Wai.Handler.Warp.Conduit import Network.Wai.Handler.Warp.FileInfoCache@@ -42,67 +42,78 @@ import Network.Wai.Handler.Warp.Imports hiding (readInt) import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.RequestHeader-import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, settingsMaxTotalHeaderLength)+import Network.Wai.Handler.Warp.Settings (+ Settings,+ settingsMaxTotalHeaderLength,+ settingsNoParsePath,+ ) ---------------------------------------------------------------- -- | Receiving a HTTP request from 'Connection' and parsing its header -- to create 'Request'.-recvRequest :: Bool -- ^ first request on this connection?- -> Settings- -> Connection- -> InternalInfo- -> Timeout.Handle- -> SockAddr -- ^ Peer's address.- -> Source -- ^ Where HTTP request comes from.- -> Transport- -> IO (Request- ,Maybe (I.IORef Int)- ,IndexedHeader- ,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+ :: Bool+ -- ^ first request on this connection?+ -> Settings+ -> Connection+ -> InternalInfo+ -> Timeout.Handle+ -> SockAddr+ -- ^ Peer's address.+ -> Source+ -- ^ Where HTTP request comes from.+ -> Transport+ -> IO+ ( Request+ , Maybe (I.IORef Int)+ , IndexedHeader+ , 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 ii th addr src transport = do hdrlines <- headerLines (settingsMaxTotalHeaderLength settings) firstRequest src- (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines+ (method, unparsedPath, path, query, httpversion, hdr) <-+ parseHeaderLines hdrlines let idxhdr = indexRequestHeader hdr expect = idxhdr ! fromEnum ReqExpect- cl = idxhdr ! fromEnum ReqContentLength- te = idxhdr ! fromEnum ReqTransferEncoding handle100Continue = handleExpect conn httpversion expect- rawPath = if settingsNoParsePath settings then unparsedPath else path- vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)- $ Vault.insert getFileInfoKey (getFileInfo ii)-#ifdef MIN_VERSION_crypton_x509- $ Vault.insert getClientCertificateKey (getTransportClientCertificate transport)-#endif- Vault.empty- (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te+ (rbody, remainingRef, bodyLength) <- bodyAndSource src idxhdr -- body producing function which will produce '100-continue', if needed rbody' <- timeoutBody remainingRef th rbody handle100Continue -- body producing function which will never produce 100-continue rbodyFlush <- timeoutBody remainingRef th rbody (return ())- let req = Request {- requestMethod = method- , httpVersion = httpversion- , pathInfo = H.decodePathSegments path- , rawPathInfo = rawPath- , rawQueryString = query- , queryString = H.parseQuery query- , requestHeaders = hdr- , isSecure = isTransportSecure transport- , remoteHost = addr- , requestBody = rbody'- , vault = vaultValue- , requestBodyLength = bodyLength- , requestHeaderHost = idxhdr ! fromEnum ReqHost- , requestHeaderRange = idxhdr ! fromEnum ReqRange- , requestHeaderReferer = idxhdr ! fromEnum ReqReferer- , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent- }+ let rawPath = if settingsNoParsePath settings then unparsedPath else path+ vaultValue =+ Vault.insert pauseTimeoutKey (Timeout.pause th)+ . Vault.insert getFileInfoKey (getFileInfo ii)+#ifdef MIN_VERSION_crypton_x509+ . Vault.insert getClientCertificateKey (getTransportClientCertificate transport)+#endif+ $ Vault.empty+ req =+ Request+ { requestMethod = method+ , httpVersion = httpversion+ , pathInfo = H.decodePathSegments path+ , rawPathInfo = rawPath+ , rawQueryString = query+ , queryString = H.parseQuery query+ , requestHeaders = hdr+ , isSecure = isTransportSecure transport+ , remoteHost = addr+ , requestBody = rbody'+ , vault = vaultValue+ , requestBodyLength = bodyLength+ , requestHeaderHost = idxhdr ! fromEnum ReqHost+ , requestHeaderRange = idxhdr ! fromEnum ReqRange+ , requestHeaderReferer = idxhdr ! fromEnum ReqReferer+ , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent+ } return (req, remainingRef, idxhdr, rbodyFlush) ----------------------------------------------------------------@@ -111,11 +122,14 @@ headerLines maxTotalHeaderLength firstRequest src = do bs <- readSource src if S.null bs- -- When we're working on a keep-alive connection and trying to+ then -- When we're working on a keep-alive connection and trying to -- get the second or later request, we don't want to treat the -- lack of data as a real exception. See the http1 function in -- the Run module for more details.- then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest++ if firstRequest+ then throwIO ConnectionClosedByPeer+ else throwIO NoKeepAliveRequest else push maxTotalHeaderLength src (THStatus 0 0 id id) bs data NoKeepAliveRequest = NoKeepAliveRequest@@ -124,66 +138,71 @@ ---------------------------------------------------------------- -handleExpect :: Connection- -> H.HttpVersion- -> Maybe HeaderValue- -> IO ()+handleExpect+ :: Connection+ -> H.HttpVersion+ -> Maybe HeaderValue+ -> IO () handleExpect conn ver (Just "100-continue") = do connSendAll conn continue Conc.yield where continue- | ver == H.http11 = "HTTP/1.1 100 Continue\r\n\r\n"- | otherwise = "HTTP/1.0 100 Continue\r\n\r\n"-handleExpect _ _ _ = return ()+ | ver == H.http11 = "HTTP/1.1 100 Continue\r\n\r\n"+ | otherwise = "HTTP/1.0 100 Continue\r\n\r\n"+handleExpect _ _ _ = return () ---------------------------------------------------------------- -bodyAndSource :: Source- -> Maybe HeaderValue -- ^ content length- -> Maybe HeaderValue -- ^ transfer-encoding- -> IO (IO ByteString- ,Maybe (I.IORef Int)- ,RequestBodyLength- )-bodyAndSource src cl te- | chunked = do- csrc <- mkCSource src- return (readCSource csrc, Nothing, ChunkedBody)- | otherwise = do- isrc@(ISource _ remaining) <- mkISource src len- return (readISource isrc, Just remaining, bodyLen)+bodyAndSource+ :: Source+ -> IndexedHeader+ -> IO+ ( IO ByteString+ , Maybe (I.IORef Int)+ , RequestBodyLength+ )+bodyAndSource src idxhdr+ | chunked = do+ csrc <- mkCSource src+ return (readCSource csrc, Nothing, ChunkedBody)+ | otherwise = do+ let len = toLength $ idxhdr ! fromEnum ReqContentLength+ bodyLen = KnownLength $ fromIntegral len+ isrc@(ISource _ remaining) <- mkISource src len+ return (readISource isrc, Just remaining, bodyLen) where- len = toLength cl- bodyLen = KnownLength $ fromIntegral len- chunked = isChunked te+ chunked = isChunked $ idxhdr ! fromEnum ReqTransferEncoding toLength :: Maybe HeaderValue -> Int-toLength Nothing = 0+toLength Nothing = 0 toLength (Just bs) = readInt bs isChunked :: Maybe HeaderValue -> Bool isChunked (Just bs) = CI.foldCase bs == "chunked"-isChunked _ = False+isChunked _ = False ---------------------------------------------------------------- -timeoutBody :: Maybe (I.IORef Int) -- ^ remaining- -> Timeout.Handle- -> IO ByteString- -> IO ()- -> IO (IO ByteString)+timeoutBody+ :: Maybe (I.IORef Int)+ -- ^ remaining+ -> Timeout.Handle+ -> IO ByteString+ -> IO ()+ -> IO (IO ByteString) timeoutBody remainingRef timeoutHandle rbody handle100Continue = do isFirstRef <- I.newIORef True let checkEmpty = case remainingRef of Nothing -> return . S.null- Just ref -> \bs -> if S.null bs- then return True- else do- x <- I.readIORef ref- return $! x <= 0+ Just ref -> \bs ->+ if S.null bs+ then return True+ else do+ x <- I.readIORef ref+ return $! x <= 0 return $ do isFirst <- I.readIORef isFirstRef@@ -211,14 +230,15 @@ ---------------------------------------------------------------- -type BSEndo = ByteString -> ByteString+type BSEndo = S.ByteString -> S.ByteString type BSEndoList = [ByteString] -> [ByteString] -data THStatus = THStatus- !Int -- running total byte count (excluding current header chunk)- !Int -- current header chunk byte count- BSEndoList -- previously parsed lines- BSEndo -- bytestrings to be prepended+data THStatus+ = THStatus+ Int -- running total byte count (excluding current header chunk)+ Int -- current header chunk byte count+ BSEndoList -- previously parsed lines+ BSEndo -- bytestrings to be prepended ---------------------------------------------------------------- @@ -227,93 +247,85 @@ close = throwIO IncompleteHeaders -} +-- | Assumes the 'ByteString' is never 'S.null' push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]-push maxTotalHeaderLength src (THStatus totalLen chunkLen lines prepend) bs'+push maxTotalHeaderLength src (THStatus totalLen chunkLen reqLines prepend) bs+ -- Newline found at index 'ix'+ | Just ix <- S.elemIndex _lf bs = do -- Too many bytes- | currentTotal > maxTotalHeaderLength = throwIO OverLargeHeader- | otherwise = push' mNL+ when (currentTotal > maxTotalHeaderLength) $ throwIO OverLargeHeader+ newlineFound ix+ -- No newline found+ | otherwise = do+ -- Early easy abort+ when (currentTotal + bsLen > maxTotalHeaderLength) $ throwIO OverLargeHeader+ withNewChunk noNewlineFound where- currentTotal = totalLen + chunkLen- -- bs: current header chunk, plus maybe (parts of) next header- bs = prepend bs' bsLen = S.length bs- -- Maybe newline- -- Returns: Maybe- -- ( length of this chunk up to newline- -- , position of newline in relation to entire current header- -- , is this part of a multiline header- -- )- mNL = do- -- 10 is the code point for newline (\n)- chunkNL <- S.elemIndex 10 bs'- let headerNL = chunkNL + S.length (prepend "")- chunkNLlen = chunkNL + 1- -- check if there are two more bytes in the bs- -- if so, see if the second of those is a horizontal space- if bsLen > headerNL + 1 then- let c = S.index bs (headerNL + 1)- b = case headerNL of- 0 -> True- 1 -> S.index bs 0 == 13- _ -> False- isMultiline = not b && (c == 32 || c == 9)- in Just (chunkNLlen, headerNL, isMultiline)- else- Just (chunkNLlen, headerNL, False)-- {-# INLINE push' #-}- push' :: Maybe (Int, Int, Bool) -> IO [ByteString]- -- No newline find in this chunk. Add it to the prepend,- -- update the length, and continue processing.- push' Nothing = do- bst <- readSource' src- when (S.null bst) $ throwIO IncompleteHeaders- push maxTotalHeaderLength src status bst- where- prepend' = S.append bs- thisChunkLen = S.length bs'- newChunkLen = chunkLen + thisChunkLen- status = THStatus totalLen newChunkLen lines prepend'- -- Found a newline, but next line continues as a multiline header- push' (Just (chunkNLlen, end, True)) =- push maxTotalHeaderLength src status rest- where- rest = S.drop (end + 1) bs- prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)- -- If we'd just update the entire current chunk up to newline- -- we wouldn't count all the dropped newlines in between.- -- So update 'chunkLen' with current chunk up to newline- -- and use 'chunkLen' later on to add to 'totalLen'.- newChunkLen = chunkLen + chunkNLlen- status = THStatus totalLen newChunkLen lines prepend'- -- Found a newline at position end.- push' (Just (chunkNLlen, end, False))- -- leftover- | S.null line = do- when (start < bsLen) $ leftoverSource src (SU.unsafeDrop start bs)- return (lines [])- -- more headers- | otherwise = let lines' = lines . (line:)- newTotalLength = totalLen + chunkLen + chunkNLlen- status = THStatus newTotalLength 0 lines' id- in if start < bsLen then- -- more bytes in this chunk, push again- let bs'' = SU.unsafeDrop start bs- in push maxTotalHeaderLength src status bs''- else do- -- no more bytes in this chunk, ask for more- bst <- readSource' src- when (S.null bs) $ throwIO IncompleteHeaders- push maxTotalHeaderLength src status bst+ currentTotal = totalLen + chunkLen+ {-# INLINE withNewChunk #-}+ withNewChunk :: (S.ByteString -> IO a) -> IO a+ withNewChunk f = do+ newChunk <- readSource' src+ when (S.null newChunk) $ throwIO IncompleteHeaders+ f newChunk+ {-# INLINE noNewlineFound #-}+ noNewlineFound newChunk+ -- The chunk split the CRLF in half+ | SU.unsafeLast bs == _cr && S.head newChunk == _lf =+ let bs' = SU.unsafeDrop 1 newChunk+ in if bsLen == 1 && chunkLen == 0+ -- first part is only CRLF, we're done+ then do+ when (not $ S.null bs') $ leftoverSource src bs'+ pure $ reqLines []+ else do+ rest <- if S.null bs'+ -- new chunk is only LF, we need more to check for multiline+ then withNewChunk pure+ else pure bs'+ let status = addLine (bsLen + 1) (SU.unsafeTake (bsLen - 1) bs)+ push maxTotalHeaderLength src status rest+ -- chunk and keep going+ | otherwise = do+ let newChunkTotal = chunkLen + bsLen+ newPrepend = prepend . (bs <>)+ status = THStatus totalLen newChunkTotal reqLines newPrepend+ push maxTotalHeaderLength src status newChunk+ {-# INLINE newlineFound #-}+ newlineFound ix+ -- Is end of headers+ | chunkLen == 0 && startsWithLF = do+ let rest = SU.unsafeDrop end bs+ when (not $ S.null rest) $ leftoverSource src rest+ pure $ reqLines []+ | otherwise = do+ -- LF is on last byte+ let p = ix - 1+ chunk =+ if ix > 0 && SU.unsafeIndex bs p == _cr then p else ix+ status = addLine end (SU.unsafeTake chunk bs)+ continue = push maxTotalHeaderLength src status+ if end == bsLen+ then withNewChunk continue+ else continue $ SU.unsafeDrop end bs where- start = end + 1 -- start of next chunk- line = SU.unsafeTake (checkCR bs end) bs+ end = ix + 1+ startsWithLF =+ case ix of+ 0 -> True+ 1 -> SU.unsafeHead bs == _cr+ _ -> False+ -- addLine: take the current chunk and, if there's nothing to prepend,+ -- add straight to 'reqLines', otherwise first prepend then add.+ {-# INLINE addLine #-}+ addLine len chunk =+ let newTotal = currentTotal + len+ newLine =+ if chunkLen == 0 then chunk else prepend chunk+ in THStatus newTotal 0 (reqLines . (newLine:)) id+{- HLint ignore push "Use unless" -} -{-# INLINE checkCR #-}-checkCR :: ByteString -> Int -> Int-checkCR bs pos = if pos > 0 && 13 == S.index bs p then p else pos -- 13 is CR (\r)- where- !p = pos - 1 pauseTimeoutKey :: Vault.Key (IO ()) pauseTimeoutKey = unsafePerformIO Vault.newKey
Network/Wai/Handler/Warp/RequestHeader.hs view
@@ -1,18 +1,19 @@ {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.RequestHeader (- parseHeaderLines- ) where+ parseHeaderLines,+) where -import UnliftIO (throwIO) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C8 (unpack) import Data.ByteString.Internal (memchr) import qualified Data.CaseInsensitive as CI+import Data.Word8 import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)+import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr) import Foreign.Storable (peek) import qualified Network.HTTP.Types as H+import UnliftIO (throwIO) import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types@@ -22,16 +23,18 @@ ---------------------------------------------------------------- -parseHeaderLines :: [ByteString]- -> IO (H.Method- ,ByteString -- Path- ,ByteString -- Path, parsed- ,ByteString -- Query- ,H.HttpVersion- ,H.RequestHeaders- )+parseHeaderLines+ :: [ByteString]+ -> IO+ ( H.Method+ , ByteString -- Path+ , ByteString -- Path, parsed+ , ByteString -- Query+ , H.HttpVersion+ , H.RequestHeaders+ ) parseHeaderLines [] = throwIO $ NotEnoughLines []-parseHeaderLines (firstLine:otherLines) = do+parseHeaderLines (firstLine : otherLines) = do (method, path', query, httpversion) <- parseRequestLine firstLine let path = H.extractPath path' hdr = map parseHeader otherLines@@ -51,24 +54,27 @@ -- *** Exception: Warp: Request line specified a non-HTTP request -- >>> parseRequestLine "PRI * HTTP/2.0" -- ("PRI","*","",HTTP/2.0)-parseRequestLine :: ByteString- -> IO (H.Method- ,ByteString -- Path- ,ByteString -- Query- ,H.HttpVersion)+parseRequestLine+ :: ByteString+ -> IO+ ( H.Method+ , ByteString -- Path+ , ByteString -- Query+ , H.HttpVersion+ ) parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do when (len < 14) $ throwIO baderr let methodptr = ptr `plusPtr` off limptr = methodptr `plusPtr` len lim0 = fromIntegral len - pathptr0 <- memchr methodptr 32 lim0 -- ' '+ pathptr0 <- memchr methodptr _space lim0 when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $ throwIO baderr let pathptr = pathptr0 `plusPtr` 1 lim1 = fromIntegral (limptr `minusPtr` pathptr0) - httpptr0 <- memchr pathptr 32 lim1 -- ' '+ httpptr0 <- memchr pathptr _space lim1 when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $ throwIO baderr let httpptr = httpptr0 `plusPtr` 1@@ -76,17 +82,17 @@ checkHTTP httpptr !hv <- httpVersion httpptr- queryptr <- memchr pathptr 63 lim2 -- '?'+ queryptr <- memchr pathptr _question lim2 let !method = bs ptr methodptr pathptr0 !path- | queryptr == nullPtr = bs ptr pathptr httpptr0- | otherwise = bs ptr pathptr queryptr+ | queryptr == nullPtr = bs ptr pathptr httpptr0+ | otherwise = bs ptr pathptr queryptr !query- | queryptr == nullPtr = S.empty- | otherwise = bs ptr queryptr httpptr0+ | queryptr == nullPtr = S.empty+ | otherwise = bs ptr queryptr httpptr0 - return (method,path,query,hv)+ return (method, path, query, hv) where baderr = BadFirstLine $ C8.unpack requestLine check :: Ptr Word8 -> Int -> Word8 -> IO ()@@ -94,19 +100,19 @@ w0 <- peek $ p `plusPtr` n when (w0 /= w) $ throwIO NonHttp checkHTTP httpptr = do- check httpptr 0 72 -- 'H'- check httpptr 1 84 -- 'T'- check httpptr 2 84 -- 'T'- check httpptr 3 80 -- 'P'- check httpptr 4 47 -- '/'- check httpptr 6 46 -- '.'+ check httpptr 0 _H+ check httpptr 1 _T+ check httpptr 2 _T+ check httpptr 3 _P+ check httpptr 4 _slash+ check httpptr 6 _period httpVersion httpptr = do major <- peek (httpptr `plusPtr` 5) :: IO Word8 minor <- peek (httpptr `plusPtr` 7) :: IO Word8 let version- | major == 49 = if minor == 49 then H.http11 else H.http10- | major == 50 && minor == 48 = H.HttpVersion 2 0- | otherwise = H.http10+ | major == _1 = if minor == _1 then H.http11 else H.http10+ | major == _2 && minor == _0 = H.http20+ | otherwise = H.http10 return version bs ptr p0 p1 = PS fptr o l where@@ -125,9 +131,8 @@ -- ("Host","example.com:8080") -- >>> parseHeader "NoSemiColon" -- ("NoSemiColon","")- parseHeader :: ByteString -> H.Header parseHeader s =- let (k, rest) = S.break (== 58) s -- ':'- rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest+ let (k, rest) = S.break (== _colon) s+ rest' = S.dropWhile (\c -> c == _space || c == _tab) $ S.drop 1 rest in (CI.mk k, rest')
Network/Wai/Handler/Warp/Response.hs view
@@ -1,38 +1,44 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-} module Network.Wai.Handler.Warp.Response (- sendResponse- , sanitizeHeaderValue -- for testing- , warpVersion- , hasBody- , replaceHeader- , addServer -- testing- , addAltSvc- ) where+ sendResponse,+ sanitizeHeaderValue, -- for testing+ warpVersion,+ hasBody,+ replaceHeader,+ addServer, -- testing+ addAltSvc,+) where -import Data.ByteString.Builder.HTTP.Chunked (chunkedTransferEncoding, chunkedTransferTerminator)-import qualified UnliftIO import Data.Array ((!)) import qualified Data.ByteString as S-import Data.ByteString.Builder (byteString, Builder)+import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Builder.Extra (flush)+import Data.ByteString.Builder.HTTP.Chunked (+ chunkedTransferEncoding,+ chunkedTransferTerminator,+ ) import qualified Data.ByteString.Char8 as C8 import qualified Data.CaseInsensitive as CI import Data.Function (on) import Data.List (deleteBy)-import Data.Streaming.ByteString.Builder (newByteStringBuilderRecv, reuseBufferStrategy)+import Data.Streaming.ByteString.Builder (+ newByteStringBuilderRecv,+ reuseBufferStrategy,+ ) import Data.Version (showVersion)-import Data.Word8 (_cr, _lf)+import Data.Word8 (_cr, _lf, _space, _tab) import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as H import Network.Wai import Network.Wai.Internal import qualified Paths_warp import qualified System.TimeManager as T+import qualified UnliftIO import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer) import qualified Network.Wai.Handler.Warp.Date as D@@ -99,36 +105,42 @@ -- If-Modified-Since, If-Unmodified-Since, If-Range and Range -- are processed. Since a proper status is chosen, 'Status' is -- ignored. Last-Modified is inserted.--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+ -> 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 th req reqidxhdr src response = do hs <- addAltSvc settings <$> addServerAndDate hs0- if hasBody s then do- -- The response to HEAD does not have body.- -- But to handle the conditional requests defined RFC 7232 and- -- to generate appropriate content-length, content-range,- -- and status, the response to HEAD is processed here.- --- -- See definition of rsp below for proper body stripping.- (ms, mlen) <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method rsp- case ms of- Nothing -> return ()- Just realStatus -> logger req realStatus mlen- T.tickle th- return ret- else do- _ <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method RspNoBody- logger req s Nothing- T.tickle th- return isPersist+ if hasBody s+ then do+ -- The response to HEAD does not have body.+ -- But to handle the conditional requests defined RFC 7232 and+ -- to generate appropriate content-length, content-range,+ -- and status, the response to HEAD is processed here.+ --+ -- See definition of rsp below for proper body stripping.+ (ms, mlen) <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method rsp+ case ms of+ Nothing -> return ()+ Just realStatus -> logger req realStatus mlen+ T.tickle th+ return ret+ else do+ _ <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method RspNoBody+ logger req s Nothing+ T.tickle th+ return isPersist where defServer = settingsServerName settings logger = settingsLogger settings@@ -139,26 +151,26 @@ rspidxhdr = indexResponseHeader hs0 getdate = getDate ii addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr- (isPersist,isChunked0) = infoFromRequest req reqidxhdr+ (isPersist, isChunked0) = infoFromRequest req reqidxhdr isChunked = not isHead && isChunked0- (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist,isChunked)+ (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist, isChunked) method = requestMethod req isHead = method == H.methodHead rsp = case response of- ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr isHead (T.tickle th)+ ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr (T.tickle th) ResponseBuilder _ _ b- | isHead -> RspNoBody- | otherwise -> RspBuilder b needsChunked+ | isHead -> RspNoBody+ | otherwise -> RspBuilder b needsChunked ResponseStream _ _ fb- | isHead -> RspNoBody- | otherwise -> RspStream fb needsChunked- ResponseRaw raw _ -> RspRaw raw src+ | isHead -> RspNoBody+ | otherwise -> RspStream fb needsChunked+ ResponseRaw raw _ -> RspRaw raw src -- Make sure we don't hang on to 'response' (avoid space leak) !ret = case response of- ResponseFile {} -> isPersist- ResponseBuilder {} -> isKeepAlive- ResponseStream {} -> isKeepAlive- ResponseRaw {} -> False+ ResponseFile{} -> isPersist+ ResponseBuilder{} -> isKeepAlive+ ResponseStream{} -> isKeepAlive+ ResponseRaw{} -> False ---------------------------------------------------------------- @@ -166,8 +178,8 @@ sanitizeHeaders = map (sanitize <$>) where sanitize v- | containsNewlines v = sanitizeHeaderValue v -- slow path- | otherwise = v -- fast path+ | containsNewlines v = sanitizeHeaderValue v -- slow path+ | otherwise = v -- fast path {-# INLINE containsNewlines #-} containsNewlines :: ByteString -> Bool@@ -176,37 +188,38 @@ {-# INLINE sanitizeHeaderValue #-} sanitizeHeaderValue :: ByteString -> ByteString sanitizeHeaderValue v = case C8.lines $ S.filter (/= _cr) v of- [] -> ""+ [] -> "" x : xs -> C8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs) where- addSpaceIfMissing line = case C8.uncons line of- Nothing -> Nothing+ addSpaceIfMissing line = case S.uncons line of+ Nothing -> Nothing Just (first, _)- | first == ' ' || first == '\t' -> Just line- | otherwise -> Just $ " " <> line+ | first == _space || first == _tab -> Just line+ | otherwise -> Just $ _space `S.cons` line ---------------------------------------------------------------- -data Rsp = RspNoBody- | RspFile FilePath (Maybe FilePart) IndexedHeader Bool (IO ())- | RspBuilder Builder Bool- | RspStream StreamingBody Bool- | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString)+data Rsp+ = RspNoBody+ | RspFile FilePath (Maybe FilePart) IndexedHeader (IO ())+ | RspBuilder Builder Bool+ | RspStream StreamingBody Bool+ | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) ---------------------------------------------------------------- -sendRsp :: Connection- -> InternalInfo- -> T.Handle- -> H.HttpVersion- -> H.Status- -> H.ResponseHeaders- -> IndexedHeader -- Response- -> Int -- maxBuilderResponseBufferSize- -> H.Method- -> Rsp- -> IO (Maybe H.Status, Maybe Integer)-+sendRsp+ :: Connection+ -> InternalInfo+ -> T.Handle+ -> H.HttpVersion+ -> H.Status+ -> H.ResponseHeaders+ -> IndexedHeader -- Response+ -> Int -- maxBuilderResponseBufferSize+ -> H.Method+ -> Rsp+ -> IO (Maybe H.Status, Maybe Integer) ---------------------------------------------------------------- sendRsp conn _ _ ver s hs _ _ _ RspNoBody = do@@ -220,19 +233,29 @@ sendRsp conn _ th ver s hs _ maxRspBufSize _ (RspBuilder body needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked let hdrBdy- | needsChunked = header <> chunkedTransferEncoding body- <> chunkedTransferTerminator- | otherwise = header <> body+ | needsChunked =+ header+ <> chunkedTransferEncoding body+ <> chunkedTransferTerminator+ | otherwise = header <> body writeBufferRef = connWriteBuffer conn- len <- toBufIOWith maxRspBufSize writeBufferRef (\bs -> connSendAll conn bs >> T.tickle th) hdrBdy+ len <-+ toBufIOWith+ maxRspBufSize+ writeBufferRef+ (\bs -> connSendAll conn bs >> T.tickle th)+ hdrBdy return (Just s, Just len) ---------------------------------------------------------------- sendRsp conn _ th ver s hs _ _ _ (RspStream streamingBody needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked- (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy- $ toBuilderBuffer $ connWriteBuffer conn+ (recv, finish) <-+ newByteStringBuilderRecv $+ reuseBufferStrategy $+ toBuilderBuffer $+ connWriteBuffer conn let send builder = do popper <- recv builder let loop = do@@ -267,8 +290,21 @@ -- Sophisticated WAI applications. -- We respect s0. s0 MUST be a proper value.-sendRsp conn ii th ver s0 hs0 rspidxhdr maxRspBufSize method (RspFile path (Just part) _ isHead hook) =- sendRspFile2XX conn ii th ver s0 hs rspidxhdr maxRspBufSize method path beg len isHead hook+sendRsp conn ii th ver s0 hs0 rspidxhdr maxRspBufSize method (RspFile path (Just part) _ hook) =+ sendRspFile2XX+ conn+ ii+ th+ ver+ s0+ hs+ rspidxhdr+ maxRspBufSize+ method+ path+ beg+ len+ hook where beg = filePartOffset part len = filePartByteCount part@@ -278,59 +314,86 @@ -- Simple WAI applications. -- Status is ignored-sendRsp conn ii th ver _ hs0 rspidxhdr maxRspBufSize method (RspFile path Nothing reqidxhdr isHead hook) = do+sendRsp conn ii th ver _ hs0 rspidxhdr maxRspBufSize method (RspFile path Nothing reqidxhdr hook) = do efinfo <- UnliftIO.tryIO $ getFileInfo ii path case efinfo of Left (_ex :: UnliftIO.IOException) -> #ifdef WARP_DEBUG- print _ex >>+ print _ex >> #endif- sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize method+ sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize method Right finfo -> case conditionalRequest finfo hs0 method rspidxhdr reqidxhdr of- WithoutBody s -> sendRsp conn ii th ver s hs0 rspidxhdr maxRspBufSize method RspNoBody- WithBody s hs beg len -> sendRspFile2XX conn ii th ver s hs rspidxhdr maxRspBufSize method path beg len isHead hook+ WithoutBody s ->+ sendRsp conn ii th ver s hs0 rspidxhdr maxRspBufSize method RspNoBody+ WithBody s hs beg len ->+ sendRspFile2XX+ conn+ ii+ th+ ver+ s+ hs+ rspidxhdr+ maxRspBufSize+ method+ path+ beg+ len+ hook ---------------------------------------------------------------- -sendRspFile2XX :: Connection- -> InternalInfo- -> T.Handle- -> H.HttpVersion- -> H.Status- -> H.ResponseHeaders- -> IndexedHeader- -> Int- -> H.Method- -> FilePath- -> Integer- -> Integer- -> Bool- -> IO ()- -> IO (Maybe H.Status, Maybe Integer)-sendRspFile2XX conn ii th ver s hs rspidxhdr maxRspBufSize method path beg len isHead hook- | isHead = sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method RspNoBody- | otherwise = do- lheader <- composeHeader ver s hs- (mfd, fresher) <- getFd ii path- let fid = FileId path mfd- hook' = hook >> fresher- connSendFile conn fid beg len hook' [lheader]- return (Just s, Just len)+sendRspFile2XX+ :: Connection+ -> InternalInfo+ -> T.Handle+ -> H.HttpVersion+ -> H.Status+ -> H.ResponseHeaders+ -> IndexedHeader+ -> Int+ -> H.Method+ -> FilePath+ -> Integer+ -> Integer+ -> IO ()+ -> IO (Maybe H.Status, Maybe Integer)+sendRspFile2XX conn ii th ver s hs rspidxhdr maxRspBufSize method path beg len hook+ | method == H.methodHead =+ sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method RspNoBody+ | otherwise = do+ lheader <- composeHeader ver s hs+ (mfd, fresher) <- getFd ii path+ let fid = FileId path mfd+ hook' = hook >> fresher+ connSendFile conn fid beg len hook' [lheader]+ return (Just s, Just len) -sendRspFile404 :: Connection- -> InternalInfo- -> T.Handle- -> H.HttpVersion- -> H.ResponseHeaders- -> IndexedHeader- -> Int- -> H.Method- -> IO (Maybe H.Status, Maybe Integer)+sendRspFile404+ :: Connection+ -> InternalInfo+ -> T.Handle+ -> H.HttpVersion+ -> H.ResponseHeaders+ -> IndexedHeader+ -> Int+ -> H.Method+ -> IO (Maybe H.Status, Maybe Integer) sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize method =- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method (RspBuilder body True)+ sendRsp+ conn+ ii+ th+ ver+ s+ hs+ rspidxhdr+ maxRspBufSize+ method+ (RspBuilder body True) where s = H.notFound404- hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0+ hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0 body = byteString "File not found" ----------------------------------------------------------------@@ -338,34 +401,39 @@ -- | Use 'connSendAll' to send this data while respecting timeout rules. sendFragment :: Connection -> T.Handle -> ByteString -> IO ()-sendFragment Connection { connSendAll = send } th bs = do+sendFragment Connection{connSendAll = send} th bs = do T.resume th send bs T.pause th- -- We pause timeouts before passing control back to user code. This ensures- -- that a timeout will only ever be executed when Warp is in control. We- -- also make sure to resume the timeout after the completion of user code- -- so that we can kill idle connections. +-- We pause timeouts before passing control back to user code. This ensures+-- that a timeout will only ever be executed when Warp is in control. We+-- also make sure to resume the timeout after the completion of user code+-- so that we can kill idle connections.+ ---------------------------------------------------------------- -infoFromRequest :: Request -> IndexedHeader -> (Bool -- isPersist- ,Bool) -- isChunked+infoFromRequest+ :: Request+ -> IndexedHeader+ -> ( Bool -- isPersist+ , Bool -- isChunked+ ) infoFromRequest req reqidxhdr = (checkPersist req reqidxhdr, checkChunk req) checkPersist :: Request -> IndexedHeader -> Bool checkPersist req reqidxhdr | ver == H.http11 = checkPersist11 conn- | otherwise = checkPersist10 conn+ | otherwise = checkPersist10 conn where ver = httpVersion req conn = reqidxhdr ! fromEnum ReqConnection checkPersist11 (Just x)- | CI.foldCase x == "close" = False- checkPersist11 _ = True+ | CI.foldCase x == "close" = False+ checkPersist11 _ = True checkPersist10 (Just x) | CI.foldCase x == "keep-alive" = True- checkPersist10 _ = False+ checkPersist10 _ = False checkChunk :: Request -> Bool checkChunk req = httpVersion req == H.http11@@ -379,8 +447,8 @@ -- -- Content-Length is specified by a reverse proxy. -- Note that CGI does not specify Content-Length.-infoFromResponse :: IndexedHeader -> (Bool,Bool) -> (Bool,Bool)-infoFromResponse rspidxhdr (isPersist,isChunked) = (isKeepAlive, needsChunked)+infoFromResponse :: IndexedHeader -> (Bool, Bool) -> (Bool, Bool)+infoFromResponse rspidxhdr (isPersist, isChunked) = (isKeepAlive, needsChunked) where needsChunked = isChunked && not hasLength isKeepAlive = isPersist && (isChunked || hasLength)@@ -389,9 +457,10 @@ ---------------------------------------------------------------- hasBody :: H.Status -> Bool-hasBody s = sc /= 204- && sc /= 304- && sc >= 200+hasBody s =+ sc /= 204+ && sc /= 304+ && sc >= 200 where sc = H.statusCode s @@ -400,7 +469,8 @@ addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders addTransferEncoding hdrs = (H.hTransferEncoding, "chunked") : hdrs -addDate :: IO D.GMTDate -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders+addDate+ :: IO D.GMTDate -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders addDate getdate rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of Nothing -> do gmtdate <- getdate@@ -414,18 +484,19 @@ warpVersion = showVersion Paths_warp.version {-# INLINE addServer #-}-addServer :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders+addServer+ :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders addServer "" rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of Nothing -> hdrs- _ -> filter ((/= H.hServer) . fst) hdrs+ _ -> filter ((/= H.hServer) . fst) hdrs addServer serverName rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of Nothing -> (H.hServer, serverName) : hdrs- _ -> hdrs+ _ -> hdrs addAltSvc :: Settings -> H.ResponseHeaders -> H.ResponseHeaders addAltSvc settings hs = case settingsAltSvc settings of- Nothing -> hs- Just v -> ("Alt-Svc", v) : hs+ Nothing -> hs+ Just v -> ("Alt-Svc", v) : hs ---------------------------------------------------------------- @@ -433,12 +504,14 @@ -- -- >>> replaceHeader "Content-Type" "new" [("content-type","old")] -- [("Content-Type","new")]-replaceHeader :: H.HeaderName -> HeaderValue -> H.ResponseHeaders -> H.ResponseHeaders-replaceHeader k v hdrs = (k,v) : deleteBy ((==) `on` fst) (k,v) hdrs+replaceHeader+ :: H.HeaderName -> HeaderValue -> H.ResponseHeaders -> H.ResponseHeaders+replaceHeader k v hdrs = (k, v) : deleteBy ((==) `on` fst) (k, v) hdrs ---------------------------------------------------------------- -composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder+composeHeaderBuilder+ :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder composeHeaderBuilder ver s hs True = byteString <$> composeHeader ver s (addTransferEncoding hs) composeHeaderBuilder ver s hs False =
Network/Wai/Handler/Warp/ResponseHeader.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where @@ -7,6 +7,7 @@ import Data.ByteString.Internal (create) import qualified Data.CaseInsensitive as CI import Data.List (foldl')+import Data.Word8 import Foreign.Ptr import GHC.Storable import qualified Network.HTTP.Types as H@@ -23,7 +24,7 @@ void $ copyCRLF ptr2 where !len = 17 + slen + foldl' fieldLength 0 responseHeaders- fieldLength !l (!k,!v) = l + S.length (CI.original k) + S.length v + 4+ fieldLength !l (!k, !v) = l + S.length (CI.original k) + S.length v + 4 !slen = S.length $ H.statusMessage status httpVer11 :: ByteString@@ -36,50 +37,39 @@ copyStatus :: Ptr Word8 -> H.HttpVersion -> H.Status -> IO (Ptr Word8) copyStatus !ptr !httpversion !status = do ptr1 <- copy ptr httpVer- writeWord8OffPtr ptr1 0 (zero + fromIntegral r2)- writeWord8OffPtr ptr1 1 (zero + fromIntegral r1)- writeWord8OffPtr ptr1 2 (zero + fromIntegral r0)- writeWord8OffPtr ptr1 3 spc+ writeWord8OffPtr ptr1 0 (_0 + fromIntegral r2)+ writeWord8OffPtr ptr1 1 (_0 + fromIntegral r1)+ writeWord8OffPtr ptr1 2 (_0 + fromIntegral r0)+ writeWord8OffPtr ptr1 3 _space ptr2 <- copy (ptr1 `plusPtr` 4) (H.statusMessage status) copyCRLF ptr2 where httpVer- | httpversion == H.HttpVersion 1 1 = httpVer11- | otherwise = httpVer10- (q0,r0) = H.statusCode status `divMod` 10- (q1,r1) = q0 `divMod` 10+ | httpversion == H.HttpVersion 1 1 = httpVer11+ | otherwise = httpVer10+ (q0, r0) = H.statusCode status `divMod` 10+ (q1, r1) = q0 `divMod` 10 r2 = q1 `mod` 10 {-# INLINE copyHeaders #-} copyHeaders :: Ptr Word8 -> [H.Header] -> IO (Ptr Word8) copyHeaders !ptr [] = return ptr-copyHeaders !ptr (h:hs) = do+copyHeaders !ptr (h : hs) = do ptr1 <- copyHeader ptr h copyHeaders ptr1 hs {-# INLINE copyHeader #-} copyHeader :: Ptr Word8 -> H.Header -> IO (Ptr Word8)-copyHeader !ptr (k,v) = do+copyHeader !ptr (k, v) = do ptr1 <- copy ptr (CI.original k)- writeWord8OffPtr ptr1 0 colon- writeWord8OffPtr ptr1 1 spc+ writeWord8OffPtr ptr1 0 _colon+ writeWord8OffPtr ptr1 1 _space ptr2 <- copy (ptr1 `plusPtr` 2) v copyCRLF ptr2 {-# INLINE copyCRLF #-} copyCRLF :: Ptr Word8 -> IO (Ptr Word8) copyCRLF !ptr = do- writeWord8OffPtr ptr 0 cr- writeWord8OffPtr ptr 1 lf+ writeWord8OffPtr ptr 0 _cr+ writeWord8OffPtr ptr 1 _lf return $! ptr `plusPtr` 2--zero :: Word8-zero = 48-spc :: Word8-spc = 32-colon :: Word8-colon = 58-cr :: Word8-cr = 13-lf :: Word8-lf = 10
Network/Wai/Handler/Warp/Run.hs view
@@ -8,14 +8,25 @@ module Network.Wai.Handler.Warp.Run where import Control.Arrow (first)-import qualified Control.Exception import Control.Exception (allowInterrupt)+import qualified Control.Exception import qualified Data.ByteString as S import Data.IORef (newIORef, readIORef) import Data.Streaming.Network (bindPortTCP)-import Foreign.C.Error (Errno(..), eCONNABORTED)-import GHC.IO.Exception (IOException(..), IOErrorType(..))-import Network.Socket (Socket, close, withSocketsDo, SockAddr, setSocketOption, SocketOption(..), getSocketName)+import Foreign.C.Error (Errno (..), eCONNABORTED)+import GHC.IO.Exception (IOErrorType (..), IOException (..))+import Network.Socket (+ SockAddr,+ Socket,+ SocketOption (..),+ close,+#if !WINDOWS+ fdSocket,+#endif+ getSocketName,+ setSocketOption,+ withSocketsDo,+ ) #if MIN_VERSION_network(3,1,1) import Network.Socket (gracefulClose) #endif@@ -26,8 +37,8 @@ import System.IO.Error (ioeGetErrorType) import qualified System.TimeManager as T import System.Timeout (timeout)-import qualified UnliftIO import UnliftIO (toException)+import qualified UnliftIO import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Counter@@ -41,12 +52,8 @@ import Network.Wai.Handler.Warp.SendFile import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Types-- #if WINDOWS import Network.Wai.Handler.Warp.Windows-#else-import Network.Socket (fdSocket) #endif -- | Creating 'Connection' for plain HTTP based on a given socket.@@ -61,54 +68,67 @@ writeBufferRef <- newIORef writeBuffer isH2 <- newIORef False -- HTTP/1.x mysa <- getSocketName s- return Connection {- connSendMany = Sock.sendMany s- , connSendAll = sendall- , connSendFile = sendfile writeBufferRef+ return+ Connection+ { connSendMany = Sock.sendMany s+ , connSendAll = sendall+ , connSendFile = sendfile writeBufferRef #if MIN_VERSION_network(3,1,1)- , connClose = do- h2 <- readIORef isH2- let tm = if h2 then settingsGracefulCloseTimeout2 set- else settingsGracefulCloseTimeout1 set- if tm == 0 then- close s- else- gracefulClose s tm `UnliftIO.catchAny` \(UnliftIO.SomeException _) -> return ()+ , connClose = do+ h2 <- readIORef isH2+ let tm =+ if h2+ then settingsGracefulCloseTimeout2 set+ else settingsGracefulCloseTimeout1 set+ if tm == 0+ then close s+ else gracefulClose s tm `UnliftIO.catchAny` \(UnliftIO.SomeException _) -> return () #else- , connClose = close s+ , connClose = close s #endif- , connRecv = receive' s bufferPool- , connRecvBuf = \_ _ -> return True -- obsoleted- , connWriteBuffer = writeBufferRef- , connHTTP2 = isH2- , connMySockAddr = mysa- }+ , connRecv = receive' s bufferPool+ , connRecvBuf = \_ _ -> return True -- obsoleted+ , connWriteBuffer = writeBufferRef+ , connHTTP2 = isH2+ , connMySockAddr = mysa+ } where receive' sock pool = UnliftIO.handleIO handler $ receive sock pool where handler :: UnliftIO.IOException -> IO ByteString handler e- | ioeGetErrorType e == InvalidArgument = return ""- | otherwise = UnliftIO.throwIO e+ | ioeGetErrorType e == InvalidArgument = return ""+ | otherwise = UnliftIO.throwIO e sendfile writeBufferRef fid offset len hook headers = do- writeBuffer <- readIORef writeBufferRef- sendFile s (bufBuffer writeBuffer) (bufSize writeBuffer) sendall- fid offset len hook headers+ writeBuffer <- readIORef writeBufferRef+ sendFile+ s+ (bufBuffer writeBuffer)+ (bufSize writeBuffer)+ sendall+ fid+ offset+ len+ hook+ headers sendall = sendAll' s - sendAll' sock bs = UnliftIO.handleJust- (\ e -> if ioeGetErrorType e == ResourceVanished- then Just ConnectionClosedByPeer- else Nothing)- UnliftIO.throwIO- $ Sock.sendAll sock bs+ sendAll' sock bs =+ UnliftIO.handleJust+ ( \e ->+ if ioeGetErrorType e == ResourceVanished+ then Just ConnectionClosedByPeer+ else Nothing+ )+ UnliftIO.throwIO+ $ Sock.sendAll sock bs -- | Run an 'Application' on the given port. -- This calls 'runSettings' with 'defaultSettings'. run :: Port -> Application -> IO ()-run p = runSettings defaultSettings { settingsPort = p }+run p = runSettings defaultSettings{settingsPort = p} -- | Run an 'Application' on the port present in the @PORT@ -- environment variable. Uses the 'Port' given when the variable is unset.@@ -120,24 +140,25 @@ mp <- lookupEnv "PORT" maybe (run p app) runReadPort mp- where runReadPort :: String -> IO () runReadPort sp = case reads sp of- ((p', _):_) -> run p' app+ ((p', _) : _) -> run p' app _ -> fail $ "Invalid value in $PORT: " ++ sp -- | Run an 'Application' with the given 'Settings'. -- This opens a listen socket on the port defined in 'Settings' and -- calls 'runSettingsSocket'. runSettings :: Settings -> Application -> IO ()-runSettings set app = withSocketsDo $- UnliftIO.bracket- (bindPortTCP (settingsPort set) (settingsHost set))- close- (\socket -> do- setSocketCloseOnExec socket- runSettingsSocket set socket app)+runSettings set app =+ withSocketsDo $+ UnliftIO.bracket+ (bindPortTCP (settingsPort set) (settingsHost set))+ close+ ( \socket -> do+ setSocketCloseOnExec socket+ runSettingsSocket set socket app+ ) -- | This installs a shutdown handler for the given socket and -- calls 'runSettingsConnection' with the default connection setup action@@ -174,20 +195,22 @@ -- in a separate worker thread instead of the main server loop. -- -- Since 1.3.5-runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()+runSettingsConnection+ :: Settings -> IO (Connection, SockAddr) -> Application -> IO () runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMaker app where getConnMaker = do- (conn, sa) <- getConn- return (return conn, sa)+ (conn, sa) <- getConn+ return (return conn, sa) -- | This modifies the connection maker so that it returns 'TCP' for 'Transport' -- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'.-runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()+runSettingsConnectionMaker+ :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO () runSettingsConnectionMaker x y = runSettingsConnectionMakerSecure x (toTCP <$> y) where- toTCP = first ((, TCP) <$>)+ toTCP = first ((,TCP) <$>) ---------------------------------------------------------------- @@ -197,7 +220,8 @@ -- or HTTP over TLS. -- -- Since 2.1.4-runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()+runSettingsConnectionMakerSecure+ :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO () runSettingsConnectionMakerSecure set getConnMaker app = do settingsBeforeMainLoop set counter <- newCounter@@ -209,21 +233,22 @@ withII :: Settings -> (InternalInfo -> IO a) -> IO a withII set action = withTimeoutManager $ \tm ->- D.withDateCache $ \dc ->- F.withFdCache fdCacheDurationInSeconds $ \fdc ->- I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do- let ii = InternalInfo tm dc fdc fic- action ii+ D.withDateCache $ \dc ->+ F.withFdCache fdCacheDurationInSeconds $ \fdc ->+ I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do+ let ii = InternalInfo tm dc fdc fic+ action ii where !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000 !timeoutInSeconds = settingsTimeout set * 1000000 withTimeoutManager f = case settingsManager set of Just tm -> f tm- Nothing -> UnliftIO.bracket- (T.initialize timeoutInSeconds)- T.stopManager- f+ Nothing ->+ UnliftIO.bracket+ (T.initialize timeoutInSeconds)+ T.stopManager+ f -- Note that there is a thorough discussion of the exception safety of the -- following code at: https://github.com/yesodweb/wai/issues/146@@ -238,12 +263,13 @@ -- async exceptions. -- -- Our approach is explained in the comments below.-acceptConnection :: Settings- -> IO (IO (Connection, Transport), SockAddr)- -> Application- -> Counter- -> InternalInfo- -> IO ()+acceptConnection+ :: Settings+ -> IO (IO (Connection, Transport), SockAddr)+ -> Application+ -> Counter+ -> InternalInfo+ -> IO () 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@@ -269,7 +295,7 @@ -- negotiation. mx <- acceptNewConnection case mx of- Nothing -> return ()+ Nothing -> return () Just (mkConn, addr) -> do fork set mkConn addr app counter ii acceptLoop@@ -289,13 +315,14 @@ -- Fork a new worker thread for this connection maker, and ask for a -- function to unmask (i.e., allow async exceptions to be thrown).-fork :: Settings- -> IO (Connection, Transport)- -> SockAddr- -> Application- -> Counter- -> InternalInfo- -> IO ()+fork+ :: Settings+ -> IO (Connection, Transport)+ -> SockAddr+ -> Application+ -> Counter+ -> InternalInfo+ -> IO () fork set mkConn addr app counter ii = settingsFork set $ \unmask -> -- Call the user-supplied on exception code if any -- exceptions are thrown.@@ -317,9 +344,10 @@ -- fact that async exceptions are still masked. UnliftIO.bracket mkConn cleanUp (serve unmask) where- cleanUp (conn, _) = connClose conn `UnliftIO.finally` do- writeBuffer <- readIORef $ connWriteBuffer conn- bufFree writeBuffer+ cleanUp (conn, _) =+ connClose conn `UnliftIO.finally` do+ writeBuffer <- readIORef $ connWriteBuffer conn+ bufFree writeBuffer -- We need to register a timeout handler for this thread, and -- cancel that handler as soon as we exit.@@ -327,42 +355,46 @@ -- 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.- unmask .+ unmask+ . -- Call the user-supplied code for connection open and -- close events- UnliftIO.bracket (onOpen addr) (onClose addr) $ \goingon ->- -- Actually serve this connection. bracket with closeConn- -- above ensures the connection is closed.- when goingon $ serveConnection conn ii th addr transport set app+ UnliftIO.bracket (onOpen addr) (onClose addr)+ $ \goingon ->+ -- Actually serve this connection. bracket with closeConn+ -- above ensures the connection is closed.+ when goingon $ serveConnection conn ii th addr transport set app where register = T.registerKillThread (timeoutManager ii) (connClose conn)- cancel = T.cancel+ cancel = T.cancel - onOpen adr = increase counter >> settingsOnOpen set adr+ onOpen adr = increase counter >> settingsOnOpen set adr onClose adr _ = decrease counter >> settingsOnClose set adr -serveConnection :: Connection- -> InternalInfo- -> T.Handle- -> SockAddr- -> Transport- -> Settings- -> Application- -> IO ()+serveConnection+ :: Connection+ -> InternalInfo+ -> T.Handle+ -> SockAddr+ -> Transport+ -> Settings+ -> Application+ -> IO () 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, "")- else do- bs0 <- connRecv conn- if S.length bs0 >= 4 && "PRI " `S.isPrefixOf` bs0 then- return (True, bs0)- else- return (False, bs0)- if settingsHTTP2Enabled settings && h2 then do- http2 settings ii conn transport app origAddr th bs- else do- http1 settings ii conn transport app origAddr th bs+ (h2, bs) <-+ if isHTTP2 transport+ then return (True, "")+ else do+ bs0 <- connRecv conn+ if S.length bs0 >= 4 && "PRI " `S.isPrefixOf` bs0+ then return (True, bs0)+ else return (False, bs0)+ if settingsHTTP2Enabled settings && h2+ then do+ http2 settings ii conn transport app origAddr th bs+ else do+ http1 settings ii conn transport app origAddr th bs -- | Set flag FileCloseOnExec flag on a socket (on Unix) --@@ -389,4 +421,5 @@ waitForZero counter (Just seconds) -> void (timeout (seconds * microsPerSecond) (waitForZero counter))- where microsPerSecond = 1000000+ where+ microsPerSecond = 1000000
Network/Wai/Handler/Warp/SendFile.hs view
@@ -1,13 +1,14 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-} module Network.Wai.Handler.Warp.SendFile (- sendFile- , readSendFile- , packHeader -- for testing+ sendFile,+ readSendFile,+ packHeader, -- for testing #ifndef WINDOWS- , positionRead+ positionRead, #endif- ) where+) where import qualified Data.ByteString as BS import Network.Socket (Socket)@@ -18,13 +19,13 @@ import Foreign.Ptr (plusPtr) import qualified System.IO as IO #else-import qualified UnliftIO import Foreign.C.Error (throwErrno) import Foreign.C.Types import Foreign.Ptr (Ptr, castPtr, plusPtr) import Network.Sendfile import Network.Wai.Handler.Warp.FdCache (openFile, closeFile) import System.Posix.Types+import qualified UnliftIO #endif import Network.Wai.Handler.Warp.Buffer@@ -42,8 +43,8 @@ #ifdef SENDFILEFD sendFile s _ _ _ fid off len act hdr = case mfid of -- settingsFdCacheDuration is 0- Nothing -> sendfileWithHeader s path (PartOfFile off len) act hdr- Just fd -> sendfileFdWithHeader s fd (PartOfFile off len) act hdr+ Nothing -> sendfileWithHeader s path (PartOfFile off len) act hdr+ Just fd -> sendfileFdWithHeader s fd (PartOfFile off len) act hdr where mfid = fileIdFd fid path = fileIdPath fid@@ -53,31 +54,35 @@ ---------------------------------------------------------------- -packHeader :: Buffer -> BufSize -> (ByteString -> IO ())- -> IO () -> [ByteString]- -> Int- -> IO Int-packHeader _ _ _ _ [] n = return n-packHeader buf siz send hook (bs:bss) n- | len < room = do- let dst = buf `plusPtr` n- void $ copy dst bs- packHeader buf siz send hook bss (n + len)- | otherwise = do- let dst = buf `plusPtr` n- (bs1, bs2) = BS.splitAt room bs- void $ copy dst bs1- bufferIO buf siz send- hook- packHeader buf siz send hook (bs2:bss) 0+packHeader+ :: Buffer+ -> BufSize+ -> (ByteString -> IO ())+ -> IO ()+ -> [ByteString]+ -> Int+ -> IO Int+packHeader _ _ _ _ [] n = return n+packHeader buf siz send hook (bs : bss) n+ | len < room = do+ let dst = buf `plusPtr` n+ void $ copy dst bs+ packHeader buf siz send hook bss (n + len)+ | otherwise = do+ let dst = buf `plusPtr` n+ (bs1, bs2) = BS.splitAt room bs+ void $ copy dst bs1+ bufferIO buf siz send+ hook+ packHeader buf siz send hook (bs2 : bss) 0 where len = BS.length bs room = siz - n mini :: Int -> Integer -> Int mini i n- | fromIntegral i < n = i- | otherwise = fromIntegral n+ | fromIntegral i < n = i+ | otherwise = fromIntegral n -- | Function to send a file based on pread()\/send() for Unix. -- This makes use of the file descriptor cache.@@ -101,50 +106,51 @@ where path = fileIdPath fid loop h fptr len- | len <= 0 = return ()- | otherwise = do- n <- IO.hGetBufSome h buf (mini siz len)- when (n /= 0) $ do- let bs = PS fptr 0 n- n' = fromIntegral n- send bs- hook- loop h fptr (len - n')+ | len <= 0 = return ()+ | otherwise = do+ n <- IO.hGetBufSome h buf (mini siz len)+ when (n /= 0) $ do+ let bs = PS fptr 0 n+ n' = fromIntegral n+ send bs+ hook+ loop h fptr (len - n') #else readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile readSendFile buf siz send fid off0 len0 hook headers =- UnliftIO.bracket setup teardown $ \fd -> do- hn <- packHeader buf siz send hook headers 0- let room = siz - hn- buf' = buf `plusPtr` hn- n <- positionRead fd buf' (mini room len0) off0- bufferIO buf (hn + n) send- hook- let n' = fromIntegral n- loop fd (len0 - n') (off0 + n')+ UnliftIO.bracket setup teardown $ \fd -> do+ hn <- packHeader buf siz send hook headers 0+ let room = siz - hn+ buf' = buf `plusPtr` hn+ n <- positionRead fd buf' (mini room len0) off0+ bufferIO buf (hn + n) send+ hook+ let n' = fromIntegral n+ loop fd (len0 - n') (off0 + n') where path = fileIdPath fid setup = case fileIdFd fid of- Just fd -> return fd- Nothing -> openFile path+ Just fd -> return fd+ Nothing -> openFile path teardown fd = case fileIdFd fid of- Just _ -> return ()- Nothing -> closeFile fd+ Just _ -> return ()+ Nothing -> closeFile fd loop fd len off- | len <= 0 = return ()- | otherwise = do- n <- positionRead fd buf (mini siz len) off- bufferIO buf n send- let n' = fromIntegral n- hook- loop fd (len - n') (off + n')+ | len <= 0 = return ()+ | otherwise = do+ n <- positionRead fd buf (mini siz len) off+ bufferIO buf n send+ let n' = fromIntegral n+ hook+ loop fd (len - n') (off + n') positionRead :: Fd -> Buffer -> BufSize -> Integer -> IO Int positionRead fd buf siz off = do- bytes <- fromIntegral <$> c_pread fd (castPtr buf) (fromIntegral siz) (fromIntegral off)+ bytes <-+ fromIntegral <$> c_pread fd (castPtr buf) (fromIntegral siz) (fromIntegral off) when (bytes < 0) $ throwErrno "positionRead" return bytes foreign import ccall unsafe "pread"- c_pread :: Fd -> Ptr CChar -> ByteCount -> FileOffset -> IO CSsize+ c_pread :: Fd -> Ptr CChar -> ByteCount -> FileOffset -> IO CSsize #endif
Network/Wai/Handler/Warp/Settings.hs view
@@ -1,27 +1,31 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-}-{-# LANGUAGE ImpredicativeTypes, CPP #-}-{-# LANGUAGE MagicHash, UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ViewPatterns #-} module Network.Wai.Handler.Warp.Settings where -import GHC.IO (unsafeUnmask, IO (IO))-import GHC.Prim (fork#)-import UnliftIO (SomeException, fromException)-import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Char8 as C8 import Data.Streaming.Network (HostPreference) import qualified Data.Text as T import qualified Data.Text.IO as TIO import Data.Version (showVersion)-import GHC.IO.Exception (IOErrorType(..), AsyncException (ThreadKilled))+import GHC.IO (IO (IO), unsafeUnmask)+import GHC.IO.Exception (AsyncException (ThreadKilled), IOErrorType (..))+import GHC.Prim (fork#) import qualified Network.HTTP.Types as H-import Network.Socket (Socket, SockAddr, accept)+import Network.Socket (SockAddr, Socket, accept) import Network.Wai import qualified Paths_warp import System.IO (stderr) import System.IO.Error (ioeGetErrorType) import System.TimeManager+import UnliftIO (SomeException, fromException) import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types@@ -36,178 +40,186 @@ -- -- > setTimeout 20 defaultSettings data Settings = Settings- { settingsPort :: Port -- ^ Port to listen on. Default value: 3000- , settingsHost :: HostPreference -- ^ Default value: HostIPv4- , settingsOnException :: Maybe Request -> SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr.+ { settingsPort :: Port+ -- ^ Port to listen on. Default value: 3000+ , settingsHost :: HostPreference+ -- ^ Default value: HostIPv4+ , settingsOnException :: Maybe Request -> SomeException -> IO ()+ -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr. , settingsOnExceptionResponse :: SomeException -> Response- -- ^ A function to create `Response` when an exception occurs.- --- -- Default: 500, text/plain, \"Something went wrong\"- --- -- Since 2.0.3- , settingsOnOpen :: SockAddr -> IO Bool -- ^ What to do when a connection is open. When 'False' is returned, the connection is closed immediately. Otherwise, the connection is going on. Default: always returns 'True'.- , settingsOnClose :: SockAddr -> IO () -- ^ What to do when a connection is close. Default: do nothing.- , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30- , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'- , settingsFdCacheDuration :: Int -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0- , settingsFileInfoCacheDuration :: Int -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0+ -- ^ A function to create `Response` when an exception occurs.+ --+ -- Default: 500, text/plain, \"Something went wrong\"+ --+ -- Since 2.0.3+ , settingsOnOpen :: SockAddr -> IO Bool+ -- ^ What to do when a connection is open. When 'False' is returned, the connection is closed immediately. Otherwise, the connection is going on. Default: always returns 'True'.+ , settingsOnClose :: SockAddr -> IO ()+ -- ^ What to do when a connection is close. Default: do nothing.+ , settingsTimeout :: Int+ -- ^ Timeout value in seconds. Default value: 30+ , settingsManager :: Maybe Manager+ -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'+ , settingsFdCacheDuration :: Int+ -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0+ , settingsFileInfoCacheDuration :: Int+ -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0 , settingsBeforeMainLoop :: IO ()- -- ^ Code to run after the listening socket is ready but before entering- -- the main event loop. Useful for signaling to tests that they can start- -- running, or to drop permissions after binding to a restricted port.- --- -- Default: do nothing.- --- -- Since 1.3.6-+ -- ^ Code to run after the listening socket is ready but before entering+ -- the main event loop. Useful for signaling to tests that they can start+ -- running, or to drop permissions after binding to a restricted port.+ --+ -- Default: do nothing.+ --+ -- Since 1.3.6 , settingsFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()- -- ^ Code to fork a new thread to accept a connection.- --- -- This may be useful if you need OS bound threads, or if- -- you wish to develop an alternative threading model.- --- -- Default: 'defaultFork'- --- -- Since 3.0.4-+ -- ^ Code to fork a new thread to accept a connection.+ --+ -- This may be useful if you need OS bound threads, or if+ -- you wish to develop an alternative threading model.+ --+ -- Default: 'defaultFork'+ --+ -- Since 3.0.4 , settingsAccept :: Socket -> IO (Socket, SockAddr)- -- ^ Code to accept a new connection.- --- -- Useful if you need to provide connected sockets from something other- -- than a standard accept call.- --- -- Default: 'defaultAccept'- --- -- Since 3.3.24-+ -- ^ Code to accept a new connection.+ --+ -- Useful if you need to provide connected sockets from something other+ -- than a standard accept call.+ --+ -- Default: 'defaultAccept'+ --+ -- Since 3.3.24 , settingsNoParsePath :: Bool- -- ^ Perform no parsing on the rawPathInfo.- --- -- This is useful for writing HTTP proxies.- --- -- Default: False- --- -- Since 2.0.3+ -- ^ Perform no parsing on the rawPathInfo.+ --+ -- This is useful for writing HTTP proxies.+ --+ -- Default: False+ --+ -- Since 2.0.3 , settingsInstallShutdownHandler :: IO () -> IO ()- -- ^ An action to install a handler (e.g. Unix signal handler)- -- to close a listen socket.- -- The first argument is an action to close the listen socket.- --- -- Default: no action- --- -- Since 3.0.1+ -- ^ An action to install a handler (e.g. Unix signal handler)+ -- to close a listen socket.+ -- The first argument is an action to close the listen socket.+ --+ -- Default: no action+ --+ -- Since 3.0.1 , settingsServerName :: ByteString- -- ^ Default server name if application does not set one.- --- -- Since 3.0.2+ -- ^ Default server name if application does not set one.+ --+ -- Since 3.0.2 , settingsMaximumBodyFlush :: Maybe Int- -- ^ See @setMaximumBodyFlush@.- --- -- Since 3.0.3+ -- ^ See @setMaximumBodyFlush@.+ --+ -- Since 3.0.3 , settingsProxyProtocol :: ProxyProtocol- -- ^ Specify usage of the PROXY protocol.- --- -- Since 3.0.5+ -- ^ Specify usage of the PROXY protocol.+ --+ -- Since 3.0.5 , settingsSlowlorisSize :: Int- -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048- --- -- Since 3.1.2+ -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048+ --+ -- Since 3.1.2 , settingsHTTP2Enabled :: Bool- -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True- --- -- Since 3.1.7+ -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True+ --+ -- Since 3.1.7 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()- -- ^ A log function. Default: no action.- --- -- Since 3.1.10+ -- ^ A log function. Default: no action.+ --+ -- Since 3.1.10 , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()- -- ^ A HTTP/2 server push log function. Default: no action.- --- -- Since 3.2.7+ -- ^ A HTTP/2 server push log function. Default: no action.+ --+ -- Since 3.2.7 , settingsGracefulShutdownTimeout :: Maybe Int- -- ^ An optional timeout to limit the time (in seconds) waiting for- -- a graceful shutdown of the web server.- --- -- Since 3.2.8+ -- ^ An optional timeout to limit the time (in seconds) waiting for+ -- a graceful shutdown of the web server.+ --+ -- Since 3.2.8 , settingsGracefulCloseTimeout1 :: Int- -- ^ A timeout to limit the time (in milliseconds) waiting for- -- FIN for HTTP/1.x. 0 means uses immediate close.- -- Default: 0.- --- -- Since 3.3.5+ -- ^ A timeout to limit the time (in milliseconds) waiting for+ -- FIN for HTTP/1.x. 0 means uses immediate close.+ -- Default: 0.+ --+ -- Since 3.3.5 , settingsGracefulCloseTimeout2 :: Int- -- ^ A timeout to limit the time (in milliseconds) waiting for- -- FIN for HTTP/2. 0 means uses immediate close.- -- Default: 2000.- --- -- Since 3.3.5+ -- ^ A timeout to limit the time (in milliseconds) waiting for+ -- FIN for HTTP/2. 0 means uses immediate close.+ -- Default: 2000.+ --+ -- Since 3.3.5 , settingsMaxTotalHeaderLength :: Int- -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.- --- -- Since 3.3.8+ -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.+ --+ -- Since 3.3.8 , settingsAltSvc :: Maybe ByteString- -- ^ Specify the header value of Alternative Services (AltSvc:).- --- -- Default: Nothing- --- -- Since 3.3.11+ -- ^ Specify the header value of Alternative Services (AltSvc:).+ --+ -- Default: Nothing+ --+ -- Since 3.3.11 , settingsMaxBuilderResponseBufferSize :: Int- -- ^ Determines the maxium buffer size when sending `Builder` responses- -- (See `responseBuilder`).- --- -- When sending a builder response warp uses a 16 KiB buffer to write the- -- builder to. When that buffer is too small to fit the builder warp will- -- free it and create a new one that will fit the builder.- --- -- To protect against allocating too large a buffer warp will error if the- -- builder requires more than this maximum.- --- -- Default: 1049_000_000 = 1 MiB.- --- -- Since 3.3.22+ -- ^ Determines the maxium buffer size when sending `Builder` responses+ -- (See `responseBuilder`).+ --+ -- When sending a builder response warp uses a 16 KiB buffer to write the+ -- builder to. When that buffer is too small to fit the builder warp will+ -- free it and create a new one that will fit the builder.+ --+ -- To protect against allocating too large a buffer warp will error if the+ -- builder requires more than this maximum.+ --+ -- Default: 1049_000_000 = 1 MiB.+ --+ -- Since 3.3.22 } -- | Specify usage of the PROXY protocol.-data ProxyProtocol = ProxyProtocolNone- -- ^ See @setProxyProtocolNone@.- | ProxyProtocolRequired- -- ^ See @setProxyProtocolRequired@.- | ProxyProtocolOptional- -- ^ See @setProxyProtocolOptional@.+data ProxyProtocol+ = -- | See @setProxyProtocolNone@.+ ProxyProtocolNone+ | -- | See @setProxyProtocolRequired@.+ ProxyProtocolRequired+ | -- | See @setProxyProtocolOptional@.+ ProxyProtocolOptional -- | The default settings for the Warp server. See the individual settings for -- the default value. defaultSettings :: Settings-defaultSettings = Settings- { settingsPort = 3000- , settingsHost = "*4"- , settingsOnException = defaultOnException- , settingsOnExceptionResponse = defaultOnExceptionResponse- , settingsOnOpen = const $ return True- , settingsOnClose = const $ return ()- , settingsTimeout = 30- , settingsManager = Nothing- , settingsFdCacheDuration = 0- , settingsFileInfoCacheDuration = 0- , settingsBeforeMainLoop = return ()- , settingsFork = defaultFork- , settingsAccept = defaultAccept- , settingsNoParsePath = False- , settingsInstallShutdownHandler = const $ return ()- , settingsServerName = C8.pack $ "Warp/" ++ showVersion Paths_warp.version- , settingsMaximumBodyFlush = Just 8192- , settingsProxyProtocol = ProxyProtocolNone- , settingsSlowlorisSize = 2048- , settingsHTTP2Enabled = True- , settingsLogger = \_ _ _ -> return ()- , settingsServerPushLogger = \_ _ _ -> return ()- , settingsGracefulShutdownTimeout = Nothing- , settingsGracefulCloseTimeout1 = 0- , settingsGracefulCloseTimeout2 = 2000- , settingsMaxTotalHeaderLength = 50 * 1024- , settingsAltSvc = Nothing- , settingsMaxBuilderResponseBufferSize = 1049000000- }+defaultSettings =+ Settings+ { settingsPort = 3000+ , settingsHost = "*4"+ , settingsOnException = defaultOnException+ , settingsOnExceptionResponse = defaultOnExceptionResponse+ , settingsOnOpen = const $ return True+ , settingsOnClose = const $ return ()+ , settingsTimeout = 30+ , settingsManager = Nothing+ , settingsFdCacheDuration = 0+ , settingsFileInfoCacheDuration = 0+ , settingsBeforeMainLoop = return ()+ , settingsFork = defaultFork+ , settingsAccept = defaultAccept+ , settingsNoParsePath = False+ , settingsInstallShutdownHandler = const $ return ()+ , settingsServerName = C8.pack $ "Warp/" ++ showVersion Paths_warp.version+ , settingsMaximumBodyFlush = Just 8192+ , settingsProxyProtocol = ProxyProtocolNone+ , settingsSlowlorisSize = 2048+ , settingsHTTP2Enabled = True+ , settingsLogger = \_ _ _ -> return ()+ , settingsServerPushLogger = \_ _ _ -> return ()+ , settingsGracefulShutdownTimeout = Nothing+ , settingsGracefulCloseTimeout1 = 0+ , settingsGracefulCloseTimeout2 = 2000+ , settingsMaxTotalHeaderLength = 50 * 1024+ , settingsAltSvc = Nothing+ , settingsMaxBuilderResponseBufferSize = 1049000000+ } -- | Apply the logic provided by 'defaultOnException' to determine if an -- exception should be shown or not. The goal is to hide exceptions which occur@@ -219,7 +231,8 @@ | Just ThreadKilled <- fromException se = False | Just (_ :: InvalidRequest) <- fromException se = False | Just (ioeGetErrorType -> et) <- fromException se- , et == ResourceVanished || et == InvalidArgument = False+ , et == ResourceVanished || et == InvalidArgument =+ False | Just TimeoutThread <- fromException se = False | otherwise = True @@ -229,8 +242,10 @@ -- Since: 3.1.0 defaultOnException :: Maybe Request -> SomeException -> IO () defaultOnException _ e =- when (defaultShouldDisplayException e)- $ TIO.hPutStrLn stderr $ T.pack $ show e+ when (defaultShouldDisplayException e) $+ TIO.hPutStrLn stderr $+ T.pack $+ show e -- | Sending 400 for bad requests. -- Sending 500 for internal server errors.@@ -240,21 +255,26 @@ -- Since 3.2.27 defaultOnExceptionResponse :: SomeException -> Response defaultOnExceptionResponse e- | Just PayloadTooLarge <-- fromException e = responseLBS H.status413- [(H.hContentType, "text/plain; charset=utf-8")]- "Payload too large"- | Just RequestHeaderFieldsTooLarge <-- fromException e = responseLBS H.status431- [(H.hContentType, "text/plain; charset=utf-8")]- "Request header fields too large"- | Just (_ :: InvalidRequest) <-- fromException e = responseLBS H.badRequest400- [(H.hContentType, "text/plain; charset=utf-8")]- "Bad Request"- | otherwise = responseLBS H.internalServerError500- [(H.hContentType, "text/plain; charset=utf-8")]- "Something went wrong"+ | Just PayloadTooLarge <- fromException e =+ responseLBS+ H.status413+ [(H.hContentType, "text/plain; charset=utf-8")]+ "Payload too large"+ | Just RequestHeaderFieldsTooLarge <- fromException e =+ responseLBS+ H.status431+ [(H.hContentType, "text/plain; charset=utf-8")]+ "Request header fields too large"+ | Just (_ :: InvalidRequest) <- fromException e =+ responseLBS+ H.badRequest400+ [(H.hContentType, "text/plain; charset=utf-8")]+ "Bad Request"+ | otherwise =+ responseLBS+ H.internalServerError500+ [(H.hContentType, "text/plain; charset=utf-8")]+ "Something went wrong" -- | Exception handler for the debugging purpose. -- 500, text/plain, a showed exception.@@ -262,9 +282,10 @@ -- Since: 2.0.3.2 exceptionResponseForDebug :: SomeException -> Response exceptionResponseForDebug e =- responseBuilder H.internalServerError500- [(H.hContentType, "text/plain; charset=utf-8")]- $ "Exception: " <> Builder.stringUtf8 (show e)+ responseBuilder+ H.internalServerError500+ [(H.hContentType, "text/plain; charset=utf-8")]+ $ "Exception: " <> Builder.stringUtf8 (show e) -- | Similar to @forkIOWithUnmask@, but does not set up the default exception handler. --@@ -276,18 +297,15 @@ -- @since 3.3.17 defaultFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO () defaultFork io =+ IO $ \s0 -> #if __GLASGOW_HASKELL__ >= 904- IO $ \s0 ->- case io unsafeUnmask of- IO io' ->- case (fork# io' s0) of- (# s1, _tid #) ->- (# s1, () #)+ case io unsafeUnmask of+ IO io' ->+ case fork# io' s0 of+ (# s1, _tid #) -> (# s1, () #) #else- IO $ \s0 ->- case (fork# (io unsafeUnmask) s0) of- (# s1, _tid #) ->- (# s1, () #)+ case fork# (io unsafeUnmask) s0 of+ (# s1, _tid #) -> (# s1, () #) #endif -- | Standard "accept" call for a listening socket.
Network/Wai/Handler/Warp/Types.hs view
@@ -4,10 +4,10 @@ module Network.Wai.Handler.Warp.Types where -import qualified UnliftIO import qualified Data.ByteString as S-import Data.IORef (IORef, readIORef, writeIORef, newIORef)+import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Typeable (Typeable)+import qualified UnliftIO #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif@@ -34,16 +34,19 @@ ---------------------------------------------------------------- -- | Error types for bad 'Request'.-data InvalidRequest = NotEnoughLines [String]- | BadFirstLine String- | NonHttp- | IncompleteHeaders- | ConnectionClosedByPeer- | OverLargeHeader- | BadProxyHeader String- | PayloadTooLarge -- ^ Since 3.3.22- | RequestHeaderFieldsTooLarge -- ^ Since 3.3.22- deriving (Eq, Typeable)+data InvalidRequest+ = NotEnoughLines [String]+ | BadFirstLine String+ | NonHttp+ | IncompleteHeaders+ | ConnectionClosedByPeer+ | OverLargeHeader+ | BadProxyHeader String+ | -- | Since 3.3.22+ PayloadTooLarge+ | -- | Since 3.3.22+ RequestHeaderFieldsTooLarge+ deriving (Eq, Typeable) instance Show InvalidRequest where show (NotEnoughLines xs) = "Warp: Incomplete request headers, received: " ++ show xs@@ -51,7 +54,8 @@ show NonHttp = "Warp: Request line specified a non-HTTP request" show IncompleteHeaders = "Warp: Request headers did not finish transmission" show ConnectionClosedByPeer = "Warp: Client closed connection prematurely"- show OverLargeHeader = "Warp: Request headers too large, possible memory attack detected. Closing connection."+ show OverLargeHeader =+ "Warp: Request headers too large, possible memory attack detected. Closing connection." show (BadProxyHeader s) = "Warp: Invalid PROXY protocol header: " ++ show s show RequestHeaderFieldsTooLarge = "Request header fields too large" show PayloadTooLarge = "Payload too large"@@ -66,7 +70,6 @@ -- -- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe -- or irrecoverable.- newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody UnliftIO.SomeException deriving (Show, Typeable) @@ -79,10 +82,10 @@ -- the file descriptor cache. -- -- Since: 3.1.0-data FileId = FileId {- fileIdPath :: FilePath- , fileIdFd :: Maybe Fd- }+data FileId = FileId+ { fileIdPath :: FilePath+ , fileIdFd :: Maybe Fd+ } -- | fileid, offset, length, hook action, HTTP headers --@@ -91,58 +94,58 @@ -- | A write buffer of a specified size -- containing bytes and a way to free the buffer.-data WriteBuffer = WriteBuffer {- bufBuffer :: Buffer- -- | The size of the write buffer.+data WriteBuffer = WriteBuffer+ { bufBuffer :: Buffer , bufSize :: !BufSize- -- | Free the allocated buffer. Warp guarantees it will only be- -- called once, and no other functions will be called after it.+ -- ^ The size of the write buffer. , bufFree :: IO ()+ -- ^ Free the allocated buffer. Warp guarantees it will only be+ -- called once, and no other functions will be called after it. } type RecvBuf = Buffer -> BufSize -> IO Bool -- | Data type to manipulate IO actions for connections. -- This is used to abstract IO actions for plain HTTP and HTTP over TLS.-data Connection = Connection {- -- | This is not used at this moment.- connSendMany :: [ByteString] -> IO ()- -- | The sending function.- , connSendAll :: ByteString -> IO ()- -- | The sending function for files in HTTP/1.1.- , connSendFile :: SendFile- -- | The connection closing function. Warp guarantees it will only be+data Connection = Connection+ { connSendMany :: [ByteString] -> IO ()+ -- ^ This is not used at this moment.+ , connSendAll :: ByteString -> IO ()+ -- ^ The sending function.+ , connSendFile :: SendFile+ -- ^ The sending function for files in HTTP/1.1.+ , connClose :: IO ()+ -- ^ The connection closing function. Warp guarantees it will only be -- called once. Other functions (like 'connRecv') may be called after -- 'connClose' is called.- , connClose :: IO ()- -- | The connection receiving function. This returns "" for EOF or exceptions.- , connRecv :: Recv- -- | Obsoleted.- , connRecvBuf :: RecvBuf- -- | Reference to a write buffer. When during sending of a 'Builder'+ , connRecv :: Recv+ -- ^ The connection receiving function. This returns "" for EOF or exceptions.+ , connRecvBuf :: RecvBuf+ -- ^ Obsoleted.+ , connWriteBuffer :: IORef WriteBuffer+ -- ^ Reference to a write buffer. When during sending of a 'Builder' -- response it's detected the current 'WriteBuffer' is too small it will be -- freed and a new bigger buffer will be created and written to this -- reference.- , connWriteBuffer :: IORef WriteBuffer- -- | Is this connection HTTP/2?- , connHTTP2 :: IORef Bool- , connMySockAddr :: SockAddr+ , connHTTP2 :: IORef Bool+ -- ^ Is this connection HTTP/2?+ , connMySockAddr :: SockAddr } getConnHTTP2 :: Connection -> IO Bool-getConnHTTP2 conn = readIORef (connHTTP2 conn)+getConnHTTP2 = readIORef . connHTTP2 setConnHTTP2 :: Connection -> Bool -> IO ()-setConnHTTP2 conn b = writeIORef (connHTTP2 conn) b+setConnHTTP2 = writeIORef . connHTTP2 ---------------------------------------------------------------- -data InternalInfo = InternalInfo {- timeoutManager :: T.Manager- , getDate :: IO D.GMTDate- , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)- , getFileInfo :: FilePath -> IO I.FileInfo- }+data InternalInfo = InternalInfo+ { timeoutManager :: T.Manager+ , getDate :: IO D.GMTDate+ , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)+ , getFileInfo :: FilePath -> IO I.FileInfo+ } ---------------------------------------------------------------- @@ -168,7 +171,7 @@ readSource' (Source _ func) = func leftoverSource :: Source -> ByteString -> IO ()-leftoverSource (Source ref _) bs = writeIORef ref bs+leftoverSource (Source ref _) = writeIORef ref readLeftoverSource :: Source -> IO ByteString readLeftoverSource (Source ref _) = readIORef ref@@ -176,31 +179,35 @@ ---------------------------------------------------------------- -- | What kind of transport is used for this connection?-data Transport = TCP -- ^ Plain channel: TCP- | TLS {- tlsMajorVersion :: Int- , tlsMinorVersion :: Int- , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301- , tlsChiperID :: Word16+data Transport+ = -- | Plain channel: TCP+ TCP+ | TLS+ { tlsMajorVersion :: Int+ , tlsMinorVersion :: Int+ , tlsNegotiatedProtocol :: Maybe ByteString+ -- ^ The result of Application Layer Protocol Negociation in RFC 7301+ , tlsChiperID :: Word16+ -- ^ Encrypted channel: TLS or SSL #ifdef MIN_VERSION_crypton_x509- , tlsClientCertificate :: Maybe CertificateChain+ , tlsClientCertificate :: Maybe CertificateChain #endif- } -- ^ Encrypted channel: TLS or SSL- | QUIC {- quicNegotiatedProtocol :: Maybe ByteString- , quicChiperID :: Word16+ }+ | QUIC+ { quicNegotiatedProtocol :: Maybe ByteString+ , quicChiperID :: Word16 #ifdef MIN_VERSION_crypton_x509- , quicClientCertificate :: Maybe CertificateChain+ , quicClientCertificate :: Maybe CertificateChain #endif- }+ } isTransportSecure :: Transport -> Bool isTransportSecure TCP = False-isTransportSecure _ = True+isTransportSecure _ = True isTransportQUIC :: Transport -> Bool isTransportQUIC QUIC{} = True-isTransportQUIC _ = False+isTransportQUIC _ = False #ifdef MIN_VERSION_crypton_x509 getTransportClientCertificate :: Transport -> Maybe CertificateChain
Network/Wai/Handler/Warp/Windows.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-}-module Network.Wai.Handler.Warp.Windows- ( windowsThreadBlockHack- ) where++module Network.Wai.Handler.Warp.Windows (+ windowsThreadBlockHack,+) where #if WINDOWS import Control.Concurrent.MVar
Network/Wai/Handler/Warp/WithApplication.hs view
@@ -1,23 +1,24 @@ {-# LANGUAGE OverloadedStrings #-}+ module Network.Wai.Handler.Warp.WithApplication (- withApplication,- withApplicationSettings,- testWithApplication,- testWithApplicationSettings,- openFreePort,- withFreePort,+ withApplication,+ withApplicationSettings,+ testWithApplication,+ testWithApplicationSettings,+ openFreePort,+ withFreePort, ) where -import Control.Concurrent+import Control.Concurrent+import Control.Monad (when)+import Data.Streaming.Network (bindRandomPortTCP)+import Network.Socket+import Network.Wai+import Network.Wai.Handler.Warp.Run+import Network.Wai.Handler.Warp.Settings+import Network.Wai.Handler.Warp.Types import qualified UnliftIO-import UnliftIO.Async-import Control.Monad (when)-import Data.Streaming.Network (bindRandomPortTCP)-import Network.Socket-import Network.Wai-import Network.Wai.Handler.Warp.Run-import Network.Wai.Handler.Warp.Settings-import Network.Wai.Handler.Warp.Types+import UnliftIO.Async -- | Runs the given 'Application' on a free port. Passes the port to the given -- operation and executes it, while the 'Application' is running. Shuts down the@@ -33,20 +34,21 @@ -- @since 3.2.7 withApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a withApplicationSettings settings' mkApp action = do- app <- mkApp- withFreePort $ \ (port, sock) -> do- started <- mkWaiter- let settings =- settings' {- settingsBeforeMainLoop- = notify started () >> settingsBeforeMainLoop settings'- }- result <- race- (runSettingsSocket settings sock app)- (waitFor started >> action port)- case result of- Left () -> UnliftIO.throwString "Unexpected: runSettingsSocket exited"- Right x -> return x+ app <- mkApp+ withFreePort $ \(port, sock) -> do+ started <- mkWaiter+ let settings =+ settings'+ { settingsBeforeMainLoop =+ notify started () >> settingsBeforeMainLoop settings'+ }+ result <-+ race+ (runSettingsSocket settings sock app)+ (waitFor started >> action port)+ case result of+ Left () -> UnliftIO.throwString "Unexpected: runSettingsSocket exited"+ Right x -> return x -- | Same as 'withApplication' but with different exception handling: If the -- given 'Application' throws an exception, 'testWithApplication' will re-throw@@ -67,31 +69,32 @@ -- | 'testWithApplication' with given 'Settings'. -- -- @since 3.2.7-testWithApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a+testWithApplicationSettings+ :: Settings -> IO Application -> (Port -> IO a) -> IO a testWithApplicationSettings settings mkApp action = do- callingThread <- myThreadId- app <- mkApp- let wrappedApp request respond =- app request respond `UnliftIO.catchAny` \ e -> do- when- (defaultShouldDisplayException e)- (throwTo callingThread e)- UnliftIO.throwIO e- withApplicationSettings settings (return wrappedApp) action+ callingThread <- myThreadId+ app <- mkApp+ let wrappedApp request respond =+ app request respond `UnliftIO.catchAny` \e -> do+ when+ (defaultShouldDisplayException e)+ (throwTo callingThread e)+ UnliftIO.throwIO e+ withApplicationSettings settings (return wrappedApp) action -data Waiter a- = Waiter {- notify :: a -> IO (),- waitFor :: IO a- }+data Waiter a = Waiter+ { notify :: a -> IO ()+ , waitFor :: IO a+ } mkWaiter :: IO (Waiter a) mkWaiter = do- mvar <- newEmptyMVar- return Waiter {- notify = putMVar mvar,- waitFor = readMVar mvar- }+ mvar <- newEmptyMVar+ return+ Waiter+ { notify = putMVar mvar+ , waitFor = readMVar mvar+ } -- | Opens a socket on a free port and returns both port and socket. --
bench/Parser.hs view
@@ -1,24 +1,27 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-} module Main where import Control.Monad import qualified Data.ByteString as S---import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as B (unpack)-import qualified Network.HTTP.Types as H-import Network.Wai.Handler.Warp.Types-import Prelude hiding (lines)-import UnliftIO.Exception (throwIO, impureThrow)-+import qualified Data.ByteString.Char8 as B (pack, unpack) import Data.ByteString.Internal-import Data.Word+import Data.IORef (atomicModifyIORef', newIORef)+import qualified Data.List as L+import Data.Word8 import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable+import qualified Network.HTTP.Types as H+import UnliftIO.Exception (impureThrow, throwIO)+import Prelude hiding (lines) +import Network.Wai.Handler.Warp.Request (headerLines)+import Network.Wai.Handler.Warp.Types+ #if MIN_VERSION_gauge(0, 2, 0) import Gauge #else@@ -34,20 +37,31 @@ main = do let requestLine1 = "GET http://www.example.com HTTP/1.1" let requestLine2 = "GET http://www.example.com/cgi-path/search.cgi?key=parser HTTP/1.0"- defaultMain [- bgroup "requestLine1" [- bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine1- , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine1- , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine1- , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine1- ]- , bgroup "requestLine2" [- bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine2- , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine2- , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine2- , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine2- ]- ]+ defaultMain+ [ bgroup+ "requestLine1"+ [ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine1+ , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine1+ , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine1+ , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine1+ ]+ , bgroup+ "requestLine2"+ [ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine2+ , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine2+ , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine2+ , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine2+ ]+ , bgroup+ "parsing request"+ [ bench "new parsing 4" $ whnfAppIO testIt (chunkRequest 4)+ , bench "new parsing 10" $ whnfAppIO testIt (chunkRequest 10)+ , bench "new parsing 25" $ whnfAppIO testIt (chunkRequest 25)+ , bench "new parsing 100" $ whnfAppIO testIt (chunkRequest 100)+ ]+ ]+ where+ testIt req = producer req >>= headerLines 800 False ---------------------------------------------------------------- @@ -61,26 +75,29 @@ -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine3 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp-parseRequestLine3 :: ByteString- -> (H.Method- ,ByteString -- Path- ,ByteString -- Query- ,H.HttpVersion)+parseRequestLine3+ :: ByteString+ -> ( H.Method+ , ByteString -- Path+ , ByteString -- Query+ , H.HttpVersion+ ) parseRequestLine3 requestLine = ret where- (!method,!rest) = S.break (== 32) requestLine -- ' '- (!pathQuery,!httpVer')- | rest == "" = impureThrow badmsg- | otherwise = S.break (== 32) (S.drop 1 rest) -- ' '- (!path,!query) = S.break (== 63) pathQuery -- '?'+ (!method, !rest) = S.break (== _space) requestLine+ (!pathQuery, !httpVer')+ | rest == "" = impureThrow badmsg+ | otherwise = S.break (== _space) (S.drop 1 rest)+ (!path, !query) = S.break (== _question) pathQuery !httpVer = S.drop 1 httpVer'- (!http,!ver)- | httpVer == "" = impureThrow badmsg- | otherwise = S.break (== 47) httpVer -- '/'- !hv | http /= "HTTP" = impureThrow NonHttp- | ver == "/1.1" = H.http11- | otherwise = H.http10- !ret = (method,path,query,hv)+ (!http, !ver)+ | httpVer == "" = impureThrow badmsg+ | otherwise = S.break (== _slash) httpVer+ !hv+ | http /= "HTTP" = impureThrow NonHttp+ | ver == "/1.1" = H.http11+ | otherwise = H.http10+ !ret = (method, path, query, hv) badmsg = BadFirstLine $ B.unpack requestLine ----------------------------------------------------------------@@ -95,24 +112,27 @@ -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine2 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp-parseRequestLine2 :: ByteString- -> IO (H.Method- ,ByteString -- Path- ,ByteString -- Query- ,H.HttpVersion)+parseRequestLine2+ :: ByteString+ -> IO+ ( H.Method+ , ByteString -- Path+ , ByteString -- Query+ , H.HttpVersion+ ) parseRequestLine2 requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do when (len < 14) $ throwIO baderr let methodptr = ptr `plusPtr` off limptr = methodptr `plusPtr` len lim0 = fromIntegral len - pathptr0 <- memchr methodptr 32 lim0 -- ' '+ pathptr0 <- memchr methodptr _space lim0 when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $ throwIO baderr let pathptr = pathptr0 `plusPtr` 1 lim1 = fromIntegral (limptr `minusPtr` pathptr0) - httpptr0 <- memchr pathptr 32 lim1 -- ' '+ httpptr0 <- memchr pathptr _space lim1 when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $ throwIO baderr let httpptr = httpptr0 `plusPtr` 1@@ -120,17 +140,16 @@ checkHTTP httpptr !hv <- httpVersion httpptr- queryptr <- memchr pathptr 63 lim2 -- '?'-+ queryptr <- memchr pathptr _question lim2 let !method = bs ptr methodptr pathptr0 !path- | queryptr == nullPtr = bs ptr pathptr httpptr0- | otherwise = bs ptr pathptr queryptr+ | queryptr == nullPtr = bs ptr pathptr httpptr0+ | otherwise = bs ptr pathptr queryptr !query- | queryptr == nullPtr = S.empty- | otherwise = bs ptr queryptr httpptr0+ | queryptr == nullPtr = S.empty+ | otherwise = bs ptr queryptr httpptr0 - return (method,path,query,hv)+ return (method, path, query, hv) where baderr = BadFirstLine $ B.unpack requestLine check :: Ptr Word8 -> Int -> Word8 -> IO ()@@ -138,19 +157,18 @@ w0 <- peek $ p `plusPtr` n when (w0 /= w) $ throwIO NonHttp checkHTTP httpptr = do- check httpptr 0 72 -- 'H'- check httpptr 1 84 -- 'T'- check httpptr 2 84 -- 'T'- check httpptr 3 80 -- 'P'- check httpptr 4 47 -- '/'- check httpptr 6 46 -- '.'+ check httpptr 0 _H+ check httpptr 1 _T+ check httpptr 2 _T+ check httpptr 3 _P+ check httpptr 4 _slash+ check httpptr 6 _period httpVersion httpptr = do major <- peek $ httpptr `plusPtr` 5 minor <- peek $ httpptr `plusPtr` 7- if major == (49 :: Word8) && minor == (49 :: Word8) then- return H.http11- else- return H.http10+ if major == _1 && minor == _1+ then return H.http11+ else return H.http10 bs ptr p0 p1 = PS fptr o l where o = p0 `minusPtr` ptr@@ -168,23 +186,29 @@ -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine1 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp-parseRequestLine1 :: ByteString- -> IO (H.Method- ,ByteString -- Path- ,ByteString -- Query- ,H.HttpVersion)+parseRequestLine1+ :: ByteString+ -> IO+ ( H.Method+ , ByteString -- Path+ , ByteString -- Query+ , H.HttpVersion+ ) parseRequestLine1 requestLine = do- let (!method,!rest) = S.break (== 32) requestLine -- ' '- (!pathQuery,!httpVer') = S.break (== 32) (S.drop 1 rest) -- ' '+ let (!method, !rest) = S.break (== _space) requestLine+ (!pathQuery, !httpVer') = S.break (== _space) (S.drop 1 rest) !httpVer = S.drop 1 httpVer' when (rest == "" || httpVer == "") $- throwIO $ BadFirstLine $ B.unpack requestLine- let (!path,!query) = S.break (== 63) pathQuery -- '?'- (!http,!ver) = S.break (== 47) httpVer -- '/'+ throwIO $+ BadFirstLine $+ B.unpack requestLine+ let (!path, !query) = S.break (== _question) pathQuery+ (!http, !ver) = S.break (== _slash) httpVer when (http /= "HTTP") $ throwIO NonHttp- let !hv | ver == "/1.1" = H.http11- | otherwise = H.http10- return $! (method,path,query,hv)+ let !hv+ | ver == "/1.1" = H.http11+ | otherwise = H.http10+ return $! (method, path, query, hv) ---------------------------------------------------------------- @@ -198,23 +222,68 @@ -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine0 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp-parseRequestLine0 :: ByteString- -> IO (H.Method- ,ByteString -- Path- ,ByteString -- Query- ,H.HttpVersion)+parseRequestLine0+ :: ByteString+ -> IO+ ( H.Method+ , ByteString -- Path+ , ByteString -- Query+ , H.HttpVersion+ ) parseRequestLine0 s =- case filter (not . S.null) $ S.splitWith (\c -> c == 32 || c == 9) s of -- '- (method':query:http'') -> do+ case filter (not . S.null) $ S.splitWith (\c -> c == _space || c == _tab) s of+ (method' : query : http'') -> do let !method = method' !http' = S.concat http'' (!hfirst, !hsecond) = S.splitAt 5 http' if hfirst == "HTTP/"- then let (!rpath, !qstring) = S.break (== 63) query -- '?'+ then+ let (!rpath, !qstring) = S.break (== _question) query !hv = case hsecond of "1.1" -> H.http11 _ -> H.http10- in return $! (method, rpath, qstring, hv)- else throwIO NonHttp+ in return $! (method, rpath, qstring, hv)+ else throwIO NonHttp _ -> throwIO $ BadFirstLine $ B.unpack s++producer :: [ByteString] -> IO Source+producer a = do+ ref <- newIORef a+ mkSource $+ atomicModifyIORef' ref $ \case+ [] -> ([], S.empty)+ b : bs -> (bs, b)++chunkRequest :: Int -> [ByteString]+chunkRequest chunkAmount =+ go basicRequest+ where+ len = L.length basicRequest+ chunkSize = (len `div` chunkAmount) + 1+ go [] = []+ go xs =+ let (a, b) = L.splitAt chunkSize xs+ in B.pack a : go b++-- Random google search request+basicRequest :: String+basicRequest =+ mconcat+ [ "GET /search?q=test&sca_esv=600090652&source=hp&uact=5&oq=test&sclient=gws-wiz HTTP/3\r\n"+ , "Host: www.google.com\r\n"+ , "User-Agent: Mozilla/5.0 (X11; Ubuntu; Linux x86_64; rv:121.0) Gecko/20100101 Firefox/121.0\r\n"+ , "Accept: text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,*/*;q=0.8\r\n"+ , "Accept-Language: en-US,en;q=0.5\r\n"+ , "Accept-Encoding: gzip, deflate, br\r\n"+ , "Referer: https://www.google.com/\r\n"+ , "Alt-Used: www.google.com\r\n"+ , "Connection: keep-alive\r\n"+ , "Cookie: CONSENT=PENDING+252\r\n"+ , "Upgrade-Insecure-Requests: 1\r\n"+ , "Sec-Fetch-Dest: document\r\n"+ , "Sec-Fetch-Mode: navigate\r\n"+ , "Sec-Fetch-Site: same-origin\r\n"+ , "Sec-Fetch-User: ?1\r\n"+ , "TE: trailers\r\n\r\n"+ ]
test/ConduitSpec.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE OverloadedStrings #-}+ module ConduitSpec (main, spec) where +import Control.Monad (replicateM)+import qualified Data.ByteString as S+import Data.IORef as I import Network.Wai.Handler.Warp.Conduit import Network.Wai.Handler.Warp.Types-import Control.Monad (replicateM) import Test.Hspec-import Data.IORef as I-import qualified Data.ByteString as S main :: IO () main = hspec spec@@ -14,23 +15,23 @@ spec :: Spec spec = describe "conduit" $ do it "IsolatedBSSource" $ do- ref <- newIORef $ map S.singleton [1..50]+ ref <- newIORef $ map S.singleton [1 .. 50] src <- mkSource $ do x <- readIORef ref case x of [] -> return S.empty- y:z -> do+ y : z -> do writeIORef ref z return y isrc <- mkISource src 40 x <- replicateM 20 $ readISource isrc- S.concat x `shouldBe` S.pack [1..20]+ S.concat x `shouldBe` S.pack [1 .. 20] y <- replicateM 40 $ readISource isrc- S.concat y `shouldBe` S.pack [21..40]+ S.concat y `shouldBe` S.pack [21 .. 40] z <- replicateM 40 $ readSource src- S.concat z `shouldBe` S.pack [41..50]+ S.concat z `shouldBe` S.pack [41 .. 50] it "chunkedSource" $ do ref <- newIORef "5\r\n12345\r\n3\r\n678\r\n0\r\n\r\nBLAH" src <- mkSource $ do@@ -45,17 +46,18 @@ y <- replicateM 15 $ readSource src S.concat y `shouldBe` "BLAH" it "chunk boundaries" $ do- ref <- newIORef- [ "5\r\n"- , "12345\r\n3\r"- , "\n678\r\n0\r\n"- , "\r\nBLAH"- ]+ ref <-+ newIORef+ [ "5\r\n"+ , "12345\r\n3\r"+ , "\n678\r\n0\r\n"+ , "\r\nBLAH"+ ] src <- mkSource $ do x <- readIORef ref case x of [] -> return S.empty- y:z -> do+ y : z -> do writeIORef ref z return y csrc <- mkCSource src
test/ExceptionSpec.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module ExceptionSpec (main, spec) where @@ -6,15 +7,15 @@ import Control.Applicative #endif import Control.Monad+import qualified Data.Streaming.Network as N import Network.HTTP.Types hiding (Header)+import Network.Socket (close) import Network.Wai hiding (Response, responseStatus)-import Network.Wai.Internal (Request(..)) import Network.Wai.Handler.Warp+import Network.Wai.Internal (Request (..)) import Test.Hspec-import UnliftIO.Exception-import qualified Data.Streaming.Network as N import UnliftIO.Async (withAsync)-import Network.Socket (close)+import UnliftIO.Exception import HTTP @@ -26,11 +27,11 @@ (N.bindRandomPortTCP "127.0.0.1") (close . snd) $ \(prt, lsocket) -> do- withAsync (runSettingsSocket defaultSettings lsocket testApp)- $ \_ -> inner prt+ withAsync (runSettingsSocket defaultSettings lsocket testApp) $+ \_ -> inner prt testApp :: Application-testApp (Network.Wai.Internal.Request {pathInfo = [x]}) f+testApp (Network.Wai.Internal.Request{pathInfo = [x]}) f | x == "statusError" = f $ responseLBS undefined [] "foo" | x == "headersError" =@@ -43,24 +44,25 @@ void $ fail "ioException" f $ responseLBS ok200 [] "foo" testApp _ f =- f $ responseLBS ok200 [] "foo"+ f $ responseLBS ok200 [] "foo" spec :: Spec spec = describe "responds even if there is an exception" $ do- {- Disabling these tests. We can consider forcing evaluation in Warp.- it "statusError" $ do- sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/statusError"- sc `shouldBe` internalServerError500- it "headersError" $ do- sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headersError"- sc `shouldBe` internalServerError500- it "headerError" $ do- sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headerError"- sc `shouldBe` internalServerError500- it "bodyError" $ do- sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/bodyError"- sc `shouldBe` internalServerError500- -}- it "ioException" $ withTestServer $ \prt -> do- sc <- responseStatus <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException")- sc `shouldBe` internalServerError500+ {- Disabling these tests. We can consider forcing evaluation in Warp.+ it "statusError" $ do+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/statusError"+ sc `shouldBe` internalServerError500+ it "headersError" $ do+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headersError"+ sc `shouldBe` internalServerError500+ it "headerError" $ do+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headerError"+ sc `shouldBe` internalServerError500+ it "bodyError" $ do+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/bodyError"+ sc `shouldBe` internalServerError500+ -}+ it "ioException" $ withTestServer $ \prt -> do+ sc <-+ responseStatus <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException")+ sc `shouldBe` internalServerError500
test/FdCacheSpec.hs view
@@ -6,7 +6,7 @@ #ifndef WINDOWS import Data.IORef import Network.Wai.Handler.Warp.FdCache-import System.Posix.IO (fdRead)+import System.Posix.IO.ByteString (fdRead) import System.Posix.Types (Fd(..)) main :: IO ()
test/FileSpec.hs view
@@ -15,7 +15,8 @@ main :: IO () main = hspec spec -changeHeaders :: (ResponseHeaders -> ResponseHeaders) -> RspFileInfo -> RspFileInfo+changeHeaders+ :: (ResponseHeaders -> ResponseHeaders) -> RspFileInfo -> RspFileInfo changeHeaders f rfi = case rfi of WithBody s hs off len -> WithBody s (f hs) off len@@ -27,10 +28,11 @@ WithBody _ hs _ _ -> hs _ -> [] -testFileRange :: String- -> RequestHeaders- -> RspFileInfo- -> Spec+testFileRange+ :: String+ -> RequestHeaders+ -> RspFileInfo+ -> Spec testFileRange desc reqhs ans = it desc $ do finfo <- getInfo "attic/hex" let f = (:) ("Last-Modified", fileInfoDate finfo)@@ -41,21 +43,25 @@ [] methodGet (indexResponseHeader hs)- (indexRequestHeader reqhs) `shouldBe` ans'+ (indexRequestHeader reqhs)+ `shouldBe` ans' farPast, farFuture :: ByteString farPast = "Thu, 01 Jan 1970 00:00:00 GMT" farFuture = "Sun, 05 Oct 3000 00:00:00 GMT" regularBody :: RspFileInfo-regularBody = WithBody ok200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16+regularBody = WithBody ok200 [("Content-Length", "16"), ("Accept-Ranges", "bytes")] 0 16 make206Body :: Integer -> Integer -> RspFileInfo make206Body start len =- WithBody status206 [crHeader, lenHeader, ("Accept-Ranges","bytes")] start len+ WithBody status206 [crHeader, lenHeader, ("Accept-Ranges", "bytes")] start len where lenHeader = ("Content-Length", fromString $ show len)- crHeader = ("Content-Range", fromString $ "bytes " <> show start <> "-" <> show (start + len - 1) <> "/16")+ crHeader =+ ( "Content-Range"+ , fromString $ "bytes " <> show start <> "-" <> show (start + len - 1) <> "/16"+ ) spec :: Spec spec = do@@ -66,15 +72,15 @@ regularBody testFileRange "gets a file size from file system and handles Range and returns Partical Content"- [("Range","bytes=2-14")]+ [("Range", "bytes=2-14")] $ make206Body 2 13 testFileRange "truncates end point of range to file size"- [("Range","bytes=10-20")]+ [("Range", "bytes=10-20")] $ make206Body 10 6 testFileRange "gets a file size from file system and handles Range and returns OK if Range means the entire"- [("Range:","bytes=0-15")]+ [("Range:", "bytes=0-15")] regularBody testFileRange "returns a 412 if the file has been changed in the meantime"@@ -90,7 +96,10 @@ regularBody testFileRange "still gives only a range, even after conditionals"- [("If-Match", "SomeETag"), ("If-Unmodified-Since", farPast), ("Range","bytes=10-20")]+ [ ("If-Match", "SomeETag")+ , ("If-Unmodified-Since", farPast)+ , ("Range", "bytes=10-20")+ ] $ make206Body 10 6 testFileRange "gets a file if the file has been changed in the meantime"@@ -106,13 +115,18 @@ regularBody testFileRange "still gives only a range, even after conditionals"- [("If-None-Match", "SomeETag"), ("If-Modified-Since", farFuture), ("Range","bytes=10-13")]+ [ ("If-None-Match", "SomeETag")+ , ("If-Modified-Since", farFuture)+ , ("Range", "bytes=10-13")+ ] $ make206Body 10 4 testFileRange "gives the a range, if the condition is met"- [("If-Range", fileInfoDate (unsafePerformIO $ getInfo "attic/hex")), ("Range","bytes=2-7")]+ [ ("If-Range", fileInfoDate (unsafePerformIO $ getInfo "attic/hex"))+ , ("Range", "bytes=2-7")+ ] $ make206Body 2 6 testFileRange "gives the entire body and ignores the Range header if the condition isn't met"- [("If-Range", farPast), ("Range","bytes=2-7")]+ [("If-Range", farPast), ("Range", "bytes=2-7")] regularBody
test/HTTP.hs view
@@ -1,19 +1,19 @@ module HTTP (- sendGET- , sendGETwH- , sendHEAD- , sendHEADwH- , responseBody- , responseStatus- , responseHeaders- , getHeaderValue- , HeaderName- ) where+ sendGET,+ sendGETwH,+ sendHEAD,+ sendHEADwH,+ responseBody,+ responseStatus,+ responseHeaders,+ getHeaderValue,+ HeaderName,+) where -import Network.HTTP.Client-import Network.HTTP.Types import Data.ByteString import qualified Data.ByteString.Lazy as BL+import Network.HTTP.Client+import Network.HTTP.Types sendGET :: String -> IO (Response BL.ByteString) sendGET url = sendGETwH url []@@ -22,7 +22,7 @@ sendGETwH url hdr = do manager <- newManager defaultManagerSettings request <- parseRequest url- let request' = request { requestHeaders = hdr }+ let request' = request{requestHeaders = hdr} response <- httpLbs request' manager return response @@ -33,7 +33,7 @@ sendHEADwH url hdr = do manager <- newManager defaultManagerSettings request <- parseRequest url- let request' = request { requestHeaders = hdr, method = methodHead }+ let request' = request{requestHeaders = hdr, method = methodHead} response <- httpLbs request' manager return response
+ test/PackIntSpec.hs view
@@ -0,0 +1,14 @@+module PackIntSpec (spec) where++import qualified Data.ByteString.Char8 as C8+import Network.Wai.Handler.Warp.PackInt+import Test.Hspec+import Test.Hspec.QuickCheck+import qualified Test.QuickCheck as QC++spec :: Spec+spec = describe "readInt64" $ do+ prop "" $ \n -> packIntegral (abs n :: Int) == C8.pack (show (abs n))+ prop "" $ \(QC.Large n) ->+ let n' = fromIntegral (abs n :: Int)+ in packIntegral (n' :: Int) == C8.pack (show n')
test/ReadIntSpec.hs view
@@ -1,9 +1,9 @@ module ReadIntSpec (main, spec) where import Data.ByteString (ByteString)-import Test.Hspec-import Network.Wai.Handler.Warp.ReadInt import qualified Data.ByteString.Char8 as B+import Network.Wai.Handler.Warp.ReadInt+import Test.Hspec import qualified Test.QuickCheck as QC main :: IO ()@@ -11,7 +11,8 @@ spec :: Spec spec = describe "readInt64" $ do- it "converts ByteString to Int" $ QC.property (prop_read_show_idempotent readInt64)+ it "converts ByteString to Int" $+ QC.property (prop_read_show_idempotent readInt64) -- A QuickCheck property. Test that for a number >= 0, converting it to -- a string using show and then reading the value back with the function@@ -19,7 +20,8 @@ -- The functions under test only work on Natural numbers (the Conent-Length -- field in a HTTP header is always >= 0) so we check the absolute value of -- the value that QuickCheck generates for us.-prop_read_show_idempotent :: (Integral a, Show a) => (ByteString -> a) -> a -> Bool+prop_read_show_idempotent+ :: (Integral a, Show a) => (ByteString -> a) -> a -> Bool prop_read_show_idempotent freader x = px == freader (toByteString px) where px = abs x
test/RequestSpec.hs view
@@ -1,18 +1,22 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module RequestSpec (main, spec) where +import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import Data.IORef+import Data.Monoid (Sum (..))+import qualified Network.HTTP.Types.Header as HH import Network.Wai.Handler.Warp.File (parseByteRanges) import Network.Wai.Handler.Warp.Request+import Network.Wai.Handler.Warp.Settings (+ defaultSettings,+ settingsMaxTotalHeaderLength,+ ) import Network.Wai.Handler.Warp.Types-import Network.Wai.Handler.Warp.Settings (settingsMaxTotalHeaderLength, defaultSettings) import Test.Hspec import Test.Hspec.QuickCheck-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import qualified Network.HTTP.Types.Header as HH-import Data.IORef main :: IO () main = hspec spec@@ -22,86 +26,92 @@ spec :: Spec spec = do- describe "headerLines" $ do- it "takes until blank" $- blankSafe `shouldReturn` ("", ["foo", "bar", "baz"])- it "ignored leading whitespace in bodies" $- whiteSafe `shouldReturn` (" hi there", ["foo", "bar", "baz"])- it "throws OverLargeHeader when too many" $- tooMany `shouldThrow` overLargeHeader- it "throws OverLargeHeader when too large" $- tooLarge `shouldThrow` overLargeHeader- it "known bad chunking behavior #239" $ do- let chunks =- [ "GET / HTTP/1.1\r\nConnection: Close\r"- , "\n\r\n"- ]- (actual, src) <- headerLinesList' chunks- leftover <- readLeftoverSource src- leftover `shouldBe` S.empty- actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"]- prop "random chunking" $ \breaks extraS -> do- let bsFull = "GET / HTTP/1.1\r\nConnection: Close\r\n\r\n" `S8.append` extra- extra = S8.pack extraS- chunks = loop breaks bsFull- loop [] bs = [bs, undefined]- loop (x:xs) bs =- bs1 : loop xs bs2- where- (bs1, bs2) = S8.splitAt ((x `mod` 10) + 1) bs- (actual, src) <- headerLinesList' chunks- leftover <- consumeLen (length extraS) src+ describe "headerLines" $ do+ it "takes until blank" $+ blankSafe `shouldReturn` ("", ["foo", "bar", "baz"])+ it "ignored leading whitespace in bodies" $+ whiteSafe `shouldReturn` (" hi there", ["foo", "bar", "baz"])+ it "throws OverLargeHeader when too many" $+ tooMany `shouldThrow` overLargeHeader+ it "throws OverLargeHeader when too large" $+ tooLarge `shouldThrow` overLargeHeader+ it "known bad chunking behavior #239" $ do+ let chunks =+ [ "GET / HTTP/1.1\r\nConnection: Close\r"+ , "\n\r\n"+ ]+ (actual, src) <- headerLinesList' chunks+ leftover <- readLeftoverSource src+ leftover `shouldBe` S.empty+ actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"]+ prop "random chunking" $ \breaks extraS -> do+ let bsFull = "GET / HTTP/1.1\r\nConnection: Close\r\n\r\n" `S8.append` extra+ extra = S8.pack extraS+ chunks = loop breaks bsFull+ loop [] bs = [bs, undefined]+ loop (x : xs) bs =+ bs1 : loop xs bs2+ where+ (bs1, bs2) = S8.splitAt ((x `mod` 10) + 1) bs+ (actual, src) <- headerLinesList' chunks+ leftover <- consumeLen (length extraS) src - actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"]- leftover `shouldBe` extra- describe "parseByteRanges" $ do- let test x y = it x $ parseByteRanges (S8.pack x) `shouldBe` y- test "bytes=0-499" $ Just [HH.ByteRangeFromTo 0 499]- test "bytes=500-999" $ Just [HH.ByteRangeFromTo 500 999]- test "bytes=-500" $ Just [HH.ByteRangeSuffix 500]- test "bytes=9500-" $ Just [HH.ByteRangeFrom 9500]- test "foobytes=9500-" Nothing- test "bytes=0-0,-1" $ Just [HH.ByteRangeFromTo 0 0, HH.ByteRangeSuffix 1]+ actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"]+ leftover `shouldBe` extra+ describe "parseByteRanges" $ do+ let test x y = it x $ parseByteRanges (S8.pack x) `shouldBe` y+ test "bytes=0-499" $ Just [HH.ByteRangeFromTo 0 499]+ test "bytes=500-999" $ Just [HH.ByteRangeFromTo 500 999]+ test "bytes=-500" $ Just [HH.ByteRangeSuffix 500]+ test "bytes=9500-" $ Just [HH.ByteRangeFrom 9500]+ test "foobytes=9500-" Nothing+ test "bytes=0-0,-1" $ Just [HH.ByteRangeFromTo 0 0, HH.ByteRangeSuffix 1] - describe "headerLines" $ do- it "can handle a normal case" $ do- src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource- x <- headerLines defaultMaxTotalHeaderLength True src- x `shouldBe` ["Status: 200", "Content-Type: text/plain"]+ describe "headerLines" $ do+ let parseHeaderLine chunks = do+ src <- mkSourceFunc chunks >>= mkSource+ x <- headerLines defaultMaxTotalHeaderLength True src+ x `shouldBe` ["Status: 200", "Content-Type: text/plain"] - it "can handle a nasty case (1)" $ do- src <- mkSourceFunc ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource- x <- headerLines defaultMaxTotalHeaderLength True src- x `shouldBe` ["Status: 200", "Content-Type: text/plain"]+ it "can handle a normal case" $+ parseHeaderLine ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] - it "can handle a nasty case (1)" $ do- src <- mkSourceFunc ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] >>= mkSource- x <- headerLines defaultMaxTotalHeaderLength True src- x `shouldBe` ["Status: 200", "Content-Type: text/plain"]+ it "can handle a nasty case (1)" $ do+ parseHeaderLine ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"]+ parseHeaderLine ["Status: 200\r\n", "Content-Type: text/plain", "\r\n\r\n"] - it "can handle a nasty case (1)" $ do- src <- mkSourceFunc ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] >>= mkSource- x <- headerLines defaultMaxTotalHeaderLength True src- x `shouldBe` ["Status: 200", "Content-Type: text/plain"]+ it "can handle a nasty case (2)" $ do+ parseHeaderLine+ ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] - it "can handle an illegal case (1)" $ do- src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource- x <- headerLines defaultMaxTotalHeaderLength True src- x `shouldBe` []- y <- headerLines defaultMaxTotalHeaderLength True src- y `shouldBe` ["Status: 200", "Content-Type: text/plain"]+ it "can handle a nasty case (3)" $ do+ parseHeaderLine+ ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] - -- Length is 39, this shouldn't fail- let testLengthHeaders = ["Sta", "tus: 200\r", "\n", "Content-Type: ", "text/plain\r\n\r\n"]- it "doesn't throw on correct length" $ do- src <- mkSourceFunc testLengthHeaders >>= mkSource- x <- headerLines 39 True src- x `shouldBe` ["Status: 200", "Content-Type: text/plain"]- -- Length is still 39, this should fail- it "throws error on correct length too long" $ do- src <- mkSourceFunc testLengthHeaders >>= mkSource- headerLines 38 True src `shouldThrow` (== OverLargeHeader)+ it "can handle a stupid case (3)" $+ parseHeaderLine $+ S8.pack . (: []) <$> "Status: 200\r\nContent-Type: text/plain\r\n\r\n" + it "can (not) handle an illegal case (1)" $ do+ let chunks = ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"]+ src <- mkSourceFunc chunks >>= mkSource+ x <- headerLines defaultMaxTotalHeaderLength True src+ x `shouldBe` []+ y <- headerLines defaultMaxTotalHeaderLength True src+ y `shouldBe` ["Status:", " 200", "Content-Type: text/plain"]++ let testLengthHeaders = ["Sta", "tus: 200\r", "\n", "Content-Type: ", "text/plain\r\n\r\n"]+ headerLength = getSum $ foldMap (Sum . S.length) testLengthHeaders+ testLength = headerLength - 2 -- Because the second CRLF at the end isn't counted+ -- Length is 39, this shouldn't fail+ it "doesn't throw on correct length" $ do+ src <- mkSourceFunc testLengthHeaders >>= mkSource+ x <- headerLines testLength True src+ x `shouldBe` ["Status: 200", "Content-Type: text/plain"]+ -- Length is still 39, this should fail+ it "throws error on correct length too long" $ do+ src <- mkSourceFunc testLengthHeaders >>= mkSource+ headerLines (testLength - 1) True src `shouldThrow` (== OverLargeHeader) where blankSafe = headerLinesList ["f", "oo\n", "bar\nbaz\n\r\n"] whiteSafe = headerLinesList ["foo\r\nbar\r\nbaz\r\n\r\n hi there"]@@ -121,7 +131,7 @@ x <- readIORef ref case x of [] -> return S.empty- y:z -> do+ y : z -> do writeIORef ref z return y src' <- mkSource src@@ -140,7 +150,7 @@ then loop front 0 else do let (x, _) = S.splitAt len bs- loop (front . (x:)) (len - S.length x)+ loop (front . (x :)) (len - S.length x) overLargeHeader :: Selector InvalidRequest overLargeHeader e = e == OverLargeHeader@@ -153,7 +163,7 @@ reader ref = do xss <- readIORef ref case xss of- [] -> return S.empty- (x:xs) -> do+ [] -> return S.empty+ (x : xs) -> do writeIORef ref xs return x
test/ResponseHeaderSpec.hs view
@@ -4,9 +4,9 @@ import Data.ByteString import qualified Network.HTTP.Types as H-import Network.Wai.Handler.Warp.ResponseHeader-import Network.Wai.Handler.Warp.Response import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.Response+import Network.Wai.Handler.Warp.ResponseHeader import Test.Hspec main :: IO ()@@ -21,9 +21,9 @@ it "adds Server if not exist" $ do let hdrs = [] rspidxhdr = indexResponseHeader hdrs- addServer "MyServer" rspidxhdr hdrs `shouldBe` [("Server","MyServer")]+ addServer "MyServer" rspidxhdr hdrs `shouldBe` [("Server", "MyServer")] it "does not add Server if exists" $ do- let hdrs = [("Server","MyServer")]+ let hdrs = [("Server", "MyServer")] rspidxhdr = indexResponseHeader hdrs addServer "MyServer2" rspidxhdr hdrs `shouldBe` hdrs it "does not add Server if empty" $ do@@ -31,18 +31,19 @@ rspidxhdr = indexResponseHeader hdrs addServer "" rspidxhdr hdrs `shouldBe` hdrs it "deletes Server " $ do- let hdrs = [("Server","MyServer")]+ let hdrs = [("Server", "MyServer")] rspidxhdr = indexResponseHeader hdrs addServer "" rspidxhdr hdrs `shouldBe` [] headers :: H.ResponseHeaders-headers = [- ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")- , ("Content-Length", "151")- , ("Server", "Mighttpd/2.5.8")- , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")- , ("Content-Type", "text/html")- ]+headers =+ [ ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")+ , ("Content-Length", "151")+ , ("Server", "Mighttpd/2.5.8")+ , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")+ , ("Content-Type", "text/html")+ ] composedHeader :: ByteString-composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Length: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"+composedHeader =+ "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Length: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"
test/ResponseSpec.hs view
@@ -10,16 +10,20 @@ import Network.Wai hiding (responseHeaders) import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp.Response-import RunSpec (withApp, msWrite, msRead, withMySocket)+import RunSpec (msRead, msWrite, withApp, withMySocket) import Test.Hspec main :: IO () main = hspec spec -testRange :: S.ByteString -- ^ range value- -> String -- ^ expected output- -> Maybe String -- ^ expected content-range value- -> Spec+testRange+ :: S.ByteString+ -- ^ range value+ -> String+ -- ^ expected output+ -> Maybe String+ -- ^ expected content-range value+ -> Spec testRange range out crange = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do msWrite ms "GET / HTTP/1.0\r\n" msWrite ms "Range: bytes="@@ -36,14 +40,19 @@ title = show (range, out, crange) toHeader s = case break (== ':') s of- (x, ':':y) -> Just (x, dropWhile (== ' ') y)+ (x, ':' : y) -> Just (x, dropWhile (== ' ') y) _ -> Nothing -testPartial :: Integer -- ^ file size- -> Integer -- ^ offset- -> Integer -- ^ byte count- -> String -- ^ expected output- -> Spec+testPartial+ :: Integer+ -- ^ file size+ -> Integer+ -- ^ offset+ -> Integer+ -- ^ byte count+ -> String+ -- ^ expected output+ -> Spec testPartial size offset count out = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do msWrite ms "GET / HTTP/1.0\r\n\r\n" threadDelay 10000@@ -57,21 +66,22 @@ title = show (offset, count, out) toHeader s = case break (== ':') s of- (x, ':':y) -> Just (x, dropWhile (== ' ') y)+ (x, ':' : y) -> Just (x, dropWhile (== ' ') y) _ -> Nothing- range = "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size+ range =+ "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size spec :: Spec spec = do-{- http-client does not support this.- describe "preventing response splitting attack" $ do- it "sanitizes header values" $ do- let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello"- withApp defaultSettings app $ \port -> do- res <- sendGET $ "http://127.0.0.1:" ++ show port- getHeaderValue "foo" (responseHeaders res) `shouldBe`- Just "foo bar" -- HTTP inserts two spaces for \r\n.--}+ {- http-client does not support this.+ describe "preventing response splitting attack" $ do+ it "sanitizes header values" $ do+ let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello"+ withApp defaultSettings app $ \port -> do+ res <- sendGET $ "http://127.0.0.1:" ++ show port+ getHeaderValue "foo" (responseHeaders res) `shouldBe`+ Just "foo bar" -- HTTP inserts two spaces for \r\n.+ -} describe "sanitizeHeaderValue" $ do it "doesn't alter valid multiline header values" $ do
test/RunSpec.hs view
@@ -4,10 +4,8 @@ module RunSpec (main, spec, withApp, MySocket, msWrite, msRead, withMySocket) where import Control.Concurrent (forkIO, killThread, threadDelay)-import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Control.Concurrent.STM-import qualified UnliftIO.Exception as E-import UnliftIO.Exception (bracket, try, IOException, onException) import Control.Monad (forM_, replicateM_, unless) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.ByteString (ByteString)@@ -25,6 +23,8 @@ import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) import Test.Hspec+import UnliftIO.Exception (IOException, bracket, onException, try)+import qualified UnliftIO.Exception as E import HTTP @@ -35,35 +35,35 @@ type CounterApplication = Counter -> Application data MySocket = MySocket- { msSocket :: !Socket- , msBuffer :: !(I.IORef ByteString)- }+ { msSocket :: !Socket+ , msBuffer :: !(I.IORef ByteString)+ } msWrite :: MySocket -> ByteString -> IO () msWrite = sendAll . msSocket msRead :: MySocket -> Int -> IO ByteString msRead (MySocket s ref) expected = do- bs <- I.readIORef ref- inner (bs:) (S.length bs)+ bs <- I.readIORef ref+ inner (bs :) (S.length bs) where inner front total =- case compare total expected of- EQ -> do- I.writeIORef ref mempty- pure $ S.concat $ front []- GT -> do- let bs = S.concat $ front []- (x, y) = S.splitAt expected bs- I.writeIORef ref y- pure x- LT -> do- bs <- safeRecv s 4096- if S.null bs- then do- I.writeIORef ref mempty- pure $ S.concat $ front []- else inner (front . (bs:)) (total + S.length bs)+ case compare total expected of+ EQ -> do+ I.writeIORef ref mempty+ pure $ S.concat $ front []+ GT -> do+ let bs = S.concat $ front []+ (x, y) = S.splitAt expected bs+ I.writeIORef ref y+ pure x+ LT -> do+ bs <- safeRecv s 4096+ if S.null bs+ then do+ I.writeIORef ref mempty+ pure $ S.concat $ front []+ else inner (front . (bs :)) (total + S.length bs) msClose :: MySocket -> IO () msClose = Network.Socket.close . msSocket@@ -72,19 +72,22 @@ connectTo port = do s <- fst <$> getSocketTCP "127.0.0.1" port ref <- I.newIORef mempty- return MySocket {- msSocket = s- , msBuffer = ref- }+ return+ MySocket+ { msSocket = s+ , msBuffer = ref+ } withMySocket :: (MySocket -> IO a) -> Int -> IO a withMySocket body port = bracket (connectTo port) msClose body incr :: MonadIO m => Counter -> m () incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->- (case ecount of+ ( case ecount of Left s -> Left s- Right i -> Right $ i + 1, ())+ Right i -> Right $ i + 1+ , ()+ ) err :: (MonadIO m, Show a) => Counter -> a -> m () err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg@@ -94,12 +97,12 @@ body <- consumeBody $ getRequestBodyChunk req case () of ()- | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"- -> err icount ("Invalid hello" :: String, body)- | requestMethod req == "GET" && L.fromChunks body /= ""- -> err icount ("Invalid GET" :: String, body)- | requestMethod req `notElem` ["GET", "POST"]- -> err icount ("Invalid request method (readBody)" :: String, requestMethod req)+ | pathInfo req == ["hello"] && L.fromChunks body /= "Hello" ->+ err icount ("Invalid hello" :: String, body)+ | requestMethod req == "GET" && L.fromChunks body /= "" ->+ err icount ("Invalid GET" :: String, body)+ | requestMethod req `notElem` ["GET", "POST"] ->+ err icount ("Invalid request method (readBody)" :: String, requestMethod req) | otherwise -> incr icount f $ responseLBS status200 [] "Read the body" @@ -135,25 +138,31 @@ withApp settings app f = do port <- RunSpec.getPort baton <- newEmptyMVar- let settings' = setPort port- $ setHost "127.0.0.1"- $ setBeforeMainLoop (putMVar baton ())- settings+ let settings' =+ setPort port $+ setHost "127.0.0.1" $+ setBeforeMainLoop+ (putMVar baton ())+ settings bracket (forkIO $ runSettings settings' app `onException` putMVar baton ()) killThread- (const $ do+ ( const $ do takeMVar baton -- use timeout to make sure we don't take too long mres <- timeout (60 * 1000 * 1000) (f port) case mres of- Nothing -> error "Timeout triggered, too slow!"- Just a -> pure a)+ Nothing -> error "Timeout triggered, too slow!"+ Just a -> pure a+ ) -runTest :: Int -- ^ expected number of requests- -> CounterApplication- -> [ByteString] -- ^ chunks to send- -> IO ()+runTest+ :: Int+ -- ^ expected number of requests+ -> CounterApplication+ -> [ByteString]+ -- ^ chunks to send+ -> IO () runTest expected app chunks = do ref <- I.newIORef (Right 0) withApp defaultSettings (app ref) $ withMySocket $ \ms -> do@@ -167,9 +176,10 @@ dummyApp :: Application dummyApp _ f = f $ responseLBS status200 [] "foo" -runTerminateTest :: InvalidRequest- -> ByteString- -> IO ()+runTerminateTest+ :: InvalidRequest+ -> ByteString+ -> IO () runTerminateTest expected input = do ref <- I.newIORef Nothing let onExc _ = I.writeIORef ref . Just@@ -197,77 +207,108 @@ describe "non-pipelining" $ do it "no body, read" $ runTest 5 readBody $ replicate 5 singleGet it "no body, ignore" $ runTest 5 ignoreBody $ replicate 5 singleGet- it "has body, read" $ runTest 2 readBody- [ singlePostHello- , singleGet- ]- it "has body, ignore" $ runTest 2 ignoreBody- [ singlePostHello- , singleGet- ]- it "chunked body, read" $ runTest 2 readBody $- singleChunkedPostHello ++ [singleGet]- it "chunked body, ignore" $ runTest 2 ignoreBody $- singleChunkedPostHello ++ [singleGet]+ it "has body, read" $+ runTest+ 2+ readBody+ [ singlePostHello+ , singleGet+ ]+ it "has body, ignore" $+ runTest+ 2+ ignoreBody+ [ singlePostHello+ , singleGet+ ]+ it "chunked body, read" $+ runTest 2 readBody $+ singleChunkedPostHello ++ [singleGet]+ it "chunked body, ignore" $+ runTest 2 ignoreBody $+ singleChunkedPostHello ++ [singleGet] describe "pipelining" $ do it "no body, read" $ runTest 5 readBody [S.concat $ replicate 5 singleGet] it "no body, ignore" $ runTest 5 ignoreBody [S.concat $ replicate 5 singleGet]- it "has body, read" $ runTest 2 readBody $ return $ S.concat- [ singlePostHello- , singleGet- ]- it "has body, ignore" $ runTest 2 ignoreBody $ return $ S.concat- [ singlePostHello- , singleGet- ]- it "chunked body, read" $ runTest 2 readBody $ return $ S.concat- [ S.concat singleChunkedPostHello- , singleGet- ]- it "chunked body, ignore" $ runTest 2 ignoreBody $ return $ S.concat- [ S.concat singleChunkedPostHello- , singleGet- ]+ it "has body, read" $+ runTest 2 readBody $+ return $+ S.concat+ [ singlePostHello+ , singleGet+ ]+ it "has body, ignore" $+ runTest 2 ignoreBody $+ return $+ S.concat+ [ singlePostHello+ , singleGet+ ]+ it "chunked body, read" $+ runTest 2 readBody $+ return $+ S.concat+ [ S.concat singleChunkedPostHello+ , singleGet+ ]+ it "chunked body, ignore" $+ runTest 2 ignoreBody $+ return $+ S.concat+ [ S.concat singleChunkedPostHello+ , singleGet+ ] describe "no hanging" $ do- it "has body, read" $ runTest 1 readBody $ map S.singleton $ S.unpack singlePostHello+ it "has body, read" $+ runTest 1 readBody $+ map S.singleton $+ S.unpack singlePostHello it "double connect" $ runTest 1 doubleConnect [singlePostHello] describe "connection termination" $ do--- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello"- it "IncompleteHeaders" $+ -- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello"+ it "IncompleteHeaders" $ do+ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r" runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n"+ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r"+ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-lengt" describe "special input" $ do+ let appWithSocket f = do+ iheaders <- I.newIORef []+ let app req respond = do+ liftIO $ I.writeIORef iheaders $ requestHeaders req+ respond $ responseLBS status200 [] ""+ withApp defaultSettings app $ withMySocket $ f iheaders+ it "multiline headers" $ do- iheaders <- I.newIORef []- let app req f = do- liftIO $ I.writeIORef iheaders $ requestHeaders req- f $ responseLBS status200 [] ""- withApp defaultSettings app $ withMySocket $ \ms -> do- let input = S.concat- [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"- ]+ appWithSocket $ \iheaders ms -> do+ let input = "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n" msWrite ms input threadDelay 5000 headers <- I.readIORef iheaders- headers `shouldBe`- [ ("foo", "bar baz\tbin")- ]+ headers+ `shouldBe` [ ("foo", "bar")+ , (" baz", "")+ , ("\tbin", "")+ ] it "no space between colon and value" $ do- iheaders <- I.newIORef []- let app req f = do- liftIO $ I.writeIORef iheaders $ requestHeaders req- f $ responseLBS status200 [] ""- withApp defaultSettings app $ withMySocket $ \ms -> do- let input = S.concat- [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"- ]+ appWithSocket $ \iheaders ms -> do+ let input = "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n" msWrite ms input threadDelay 5000 headers <- I.readIORef iheaders- headers `shouldBe`- [ ("foo", "bar")- ]+ headers `shouldBe` [("foo", "bar")]+ it "does not recognize multiline headers" $ do+ appWithSocket $ \iheaders ms -> do+ msWrite ms "GET / HTTP/1.1\r\nfoo: and\r\n"+ msWrite ms " baz as well\r\n\r\n"+ threadDelay 5000+ headers <- I.readIORef iheaders+ headers+ `shouldBe` [ ("foo", "and")+ , (" baz as well", "")+ ] describe "chunked bodies" $ do it "works" $ do@@ -275,81 +316,92 @@ ifront <- I.newIORef id let app req f = do bss <- consumeBody $ getRequestBodyChunk req- liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ()) atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] "" withApp defaultSettings app $ withMySocket $ \ms -> do- let input = S.concat- [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"- , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"- , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"- , "b\r\nHello World\r\n0\r\n\r\n"- ]+ let input =+ S.concat+ [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"+ , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"+ , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"+ , "b\r\nHello World\r\n0\r\n\r\n"+ ] msWrite ms input atomically $ do- count <- readTVar countVar- check $ count == 2+ count <- readTVar countVar+ check $ count == 2 front <- I.readIORef ifront- front [] `shouldBe`- [ "Hello World\nBye"- , "Hello World"- ]+ front []+ `shouldBe` [ "Hello World\nBye"+ , "Hello World"+ ] it "lots of chunks" $ do ifront <- I.newIORef id countVar <- newTVarIO (0 :: Int) let app req f = do bss <- consumeBody $ getRequestBodyChunk req- I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())+ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ()) atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] "" withApp defaultSettings app $ withMySocket $ \ms -> do- let input = concat $ replicate 2 $- ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++- replicate 50 "5\r\n12345\r\n" ++- ["0\r\n\r\n"]+ let input =+ concat $+ replicate 2 $+ ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"]+ ++ replicate 50 "5\r\n12345\r\n"+ ++ ["0\r\n\r\n"] mapM_ (msWrite ms) input atomically $ do- count <- readTVar countVar- check $ count == 2+ count <- readTVar countVar+ check $ count == 2 front <- I.readIORef ifront front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")--- For some reason, the following test on Windows causes the socket--- to be killed prematurely. Worth investigating in the future if possible.+ -- For some reason, the following test on Windows causes the socket+ -- to be killed prematurely. Worth investigating in the future if possible. it "in chunks" $ do ifront <- I.newIORef id countVar <- newTVarIO (0 :: Int) let app req f = do bss <- consumeBody $ getRequestBodyChunk req- liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ()) atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] "" withApp defaultSettings app $ withMySocket $ \ms -> do- let input = S.concat- [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"- , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"- , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"- , "b\r\nHello World\r\n0\r\n\r\n"- ]+ let input =+ S.concat+ [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"+ , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"+ , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"+ , "b\r\nHello World\r\n0\r\n\r\n"+ ] mapM_ (msWrite ms . S.singleton) $ S.unpack input atomically $ do- count <- readTVar countVar- check $ count == 2+ count <- readTVar countVar+ check $ count == 2 front <- I.readIORef ifront- front [] `shouldBe`- [ "Hello World\nBye"- , "Hello World"- ]+ front []+ `shouldBe` [ "Hello World\nBye"+ , "Hello World"+ ] it "timeout in request body" $ do ifront <- I.newIORef id let app req f = do- bss <- consumeBody (getRequestBodyChunk req) `onException`- liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))- liftIO $ threadDelay 4000000 `E.catch` \e -> do- I.atomicModifyIORef ifront (\front ->- ( front . ((S8.pack $ "threadDelay interrupted: " ++ show e):)- , ()))- E.throwIO (e :: E.SomeException)- liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())+ bss <-+ consumeBody (getRequestBodyChunk req)+ `onException` liftIO+ (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted" :), ())))+ liftIO $+ threadDelay 4000000 `E.catch` \e -> do+ I.atomicModifyIORef+ ifront+ ( \front ->+ ( front . ((S8.pack $ "threadDelay interrupted: " ++ show e) :)+ , ()+ )+ )+ E.throwIO (e :: E.SomeException)+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ()) f $ responseLBS status200 [] "" withApp (setTimeout 1 defaultSettings) app $ withMySocket $ \ms -> do let bs1 = S.replicate 2048 88@@ -384,13 +436,18 @@ msWrite ms "67890" timeout 100000 (msRead ms 10) `shouldReturn` Just "6677889900" it "only one date and server header" $ do- let app _ f = f $ responseLBS status200- [ ("server", "server")- , ("date", "date")- ] ""- getValues key = map snd- . filter (\(key', _) -> key == key')- . responseHeaders+ let app _ f =+ f $+ responseLBS+ status200+ [ ("server", "server")+ , ("date", "date")+ ]+ ""+ getValues key =+ map snd+ . filter (\(key', _) -> key == key')+ . responseHeaders withApp defaultSettings app $ \port -> do res <- sendGET $ "http://127.0.0.1:" ++ show port getValues hServer res `shouldBe` ["server"]@@ -399,20 +456,20 @@ it "streaming echo #249" $ do countVar <- newTVarIO (0 :: Int) let app req f = f $ responseStream status200 [] $ \write _ -> do- let loop = do- bs <- getRequestBodyChunk req- unless (S.null bs) $ do- write $ byteString bs- atomically $ modifyTVar countVar (+ 1)- loop- loop+ let loop = do+ bs <- getRequestBodyChunk req+ unless (S.null bs) $ do+ write $ byteString bs+ atomically $ modifyTVar countVar (+ 1)+ loop+ loop withApp defaultSettings app $ withMySocket $ \ms -> do msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n" threadDelay 10000 msWrite ms "5\r\nhello\r\n0\r\n\r\n" atomically $ do- count <- readTVar countVar- check $ count >= 1+ count <- readTVar countVar+ check $ count >= 1 bs <- safeRecv (msSocket ms) 4096 -- must not use msRead S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK" @@ -441,11 +498,13 @@ it "file, no range" $ withApp defaultSettings app $ \port -> do bs <- S.readFile fp res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"]- getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just (S8.pack $ show $ S.length bs)+ getHeaderValue hContentLength (responseHeaders res)+ `shouldBe` Just (S8.pack $ show $ S.length bs) it "file, with range" $ withApp defaultSettings app $ \port -> do- res <- sendHEADwH- (concat ["http://127.0.0.1:", show port, "/file"])- [(hRange, "bytes=0-1")]+ res <-+ sendHEADwH+ (concat ["http://127.0.0.1:", show port, "/file"])+ [(hRange, "bytes=0-1")] getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just "2" consumeBody :: IO ByteString -> IO [ByteString]@@ -456,4 +515,4 @@ bs <- body if S.null bs then return $ front []- else loop $ front . (bs:)+ else loop $ front . (bs :)
test/SendFileSpec.hs view
@@ -20,40 +20,44 @@ spec :: Spec spec = do- describe "packHeader" $ do- it "returns how much the buffer is consumed (1)" $- tryPackHeader 10 ["foo"] `shouldReturn` 3- it "returns how much the buffer is consumed (2)" $- tryPackHeader 10 ["foo", "bar"] `shouldReturn` 6- it "returns how much the buffer is consumed (3)" $- tryPackHeader 10 ["0123456789"] `shouldReturn` 0- it "returns how much the buffer is consumed (4)" $- tryPackHeader 10 ["01234", "56789"] `shouldReturn` 0- it "returns how much the buffer is consumed (5)" $- tryPackHeader 10 ["01234567890", "12"] `shouldReturn` 3- it "returns how much the buffer is consumed (6)" $- tryPackHeader 10 ["012345678901234567890123456789012", "34"] `shouldReturn` 5+ describe "packHeader" $ do+ it "returns how much the buffer is consumed (1)" $+ tryPackHeader 10 ["foo"] `shouldReturn` 3+ it "returns how much the buffer is consumed (2)" $+ tryPackHeader 10 ["foo", "bar"] `shouldReturn` 6+ it "returns how much the buffer is consumed (3)" $+ tryPackHeader 10 ["0123456789"] `shouldReturn` 0+ it "returns how much the buffer is consumed (4)" $+ tryPackHeader 10 ["01234", "56789"] `shouldReturn` 0+ it "returns how much the buffer is consumed (5)" $+ tryPackHeader 10 ["01234567890", "12"] `shouldReturn` 3+ it "returns how much the buffer is consumed (6)" $+ tryPackHeader 10 ["012345678901234567890123456789012", "34"] `shouldReturn` 5 - it "sends headers correctly (1)" $- tryPackHeader2 10 ["foo"] "" `shouldReturn` True- it "sends headers correctly (2)" $- tryPackHeader2 10 ["foo", "bar"] "" `shouldReturn` True- it "sends headers correctly (3)" $- tryPackHeader2 10 ["0123456789"] "0123456789" `shouldReturn` True- it "sends headers correctly (4)" $- tryPackHeader2 10 ["01234", "56789"] "0123456789" `shouldReturn` True- it "sends headers correctly (5)" $- tryPackHeader2 10 ["01234567890", "12"] "0123456789" `shouldReturn` True- it "sends headers correctly (6)" $- tryPackHeader2 10 ["012345678901234567890123456789012", "34"] "012345678901234567890123456789" `shouldReturn` True+ it "sends headers correctly (1)" $+ tryPackHeader2 10 ["foo"] "" `shouldReturn` True+ it "sends headers correctly (2)" $+ tryPackHeader2 10 ["foo", "bar"] "" `shouldReturn` True+ it "sends headers correctly (3)" $+ tryPackHeader2 10 ["0123456789"] "0123456789" `shouldReturn` True+ it "sends headers correctly (4)" $+ tryPackHeader2 10 ["01234", "56789"] "0123456789" `shouldReturn` True+ it "sends headers correctly (5)" $+ tryPackHeader2 10 ["01234567890", "12"] "0123456789" `shouldReturn` True+ it "sends headers correctly (6)" $+ tryPackHeader2+ 10+ ["012345678901234567890123456789012", "34"]+ "012345678901234567890123456789"+ `shouldReturn` True - describe "readSendFile" $ do- it "sends a file correctly (1)" $- tryReadSendFile 10 0 1474 ["foo"] `shouldReturn` ExitSuccess- it "sends a file correctly (2)" $- tryReadSendFile 10 0 1474 ["012345678", "901234"] `shouldReturn` ExitSuccess- it "sends a file correctly (3)" $- tryReadSendFile 10 20 100 ["012345678", "901234"] `shouldReturn` ExitSuccess+ describe "readSendFile" $ do+ it "sends a file correctly (1)" $+ tryReadSendFile 10 0 1474 ["foo"] `shouldReturn` ExitSuccess+ it "sends a file correctly (2)" $+ tryReadSendFile 10 0 1474 ["012345678", "901234"] `shouldReturn` ExitSuccess+ it "sends a file correctly (3)" $+ tryReadSendFile 10 20 100 ["012345678", "901234"] `shouldReturn` ExitSuccess tryPackHeader :: Int -> [ByteString] -> IO Int tryPackHeader siz hdrs = bracket (allocateBuffer siz) freeBuffer $ \buf ->@@ -95,20 +99,20 @@ checkFile :: FilePath -> ByteString -> IO Bool checkFile path bs = do exist <- doesFileExist path- if exist then do- bs' <- BS.readFile path- return $ bs == bs'- else- return $ bs == ""+ if exist+ then do+ bs' <- BS.readFile path+ return $ bs == bs'+ else return $ bs == "" compareFiles :: FilePath -> FilePath -> IO ExitCode compareFiles file1 file2 = system $ "cmp -s " ++ file1 ++ " " ++ file2 copyfile :: FilePath -> FilePath -> Integer -> Integer -> IO () copyfile src dst off len =- IO.withBinaryFile src IO.ReadMode $ \h -> do- IO.hSeek h IO.AbsoluteSeek off- BS.hGet h (fromIntegral len) >>= BS.appendFile dst+ IO.withBinaryFile src IO.ReadMode $ \h -> do+ IO.hSeek h IO.AbsoluteSeek off+ BS.hGet h (fromIntegral len) >>= BS.appendFile dst removeFileIfExists :: FilePath -> IO () removeFileIfExists file = do
test/WithApplicationSpec.hs view
@@ -2,41 +2,45 @@ module WithApplicationSpec where -import Network.HTTP.Types-import Network.Wai-import System.Environment-import System.Process-import Test.Hspec-import UnliftIO.Exception+import Network.HTTP.Types+import Network.Wai+import System.Environment+import System.Process+import Test.Hspec+import UnliftIO.Exception -import Network.Wai.Handler.Warp.WithApplication+import Network.Wai.Handler.Warp.WithApplication -- All these tests assume the "curl" process can be called directly. spec :: Spec spec = do- runIO $ do- unsetEnv "http_proxy"- unsetEnv "https_proxy"- describe "\"curl\" dependency" $- let msg = "All \"WithApplication\" tests assume the \"curl\" process can be called directly."- underline = replicate (length msg) '^'- in it (msg ++ "\n " ++ underline) True- describe "withApplication" $ do- it "runs a wai Application while executing the given action" $ do- let mkApp = return $ \ _request respond -> respond $ responseLBS ok200 [] "foo"- withApplication mkApp $ \ port -> do- output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""- output `shouldBe` "foo"+ runIO $ do+ unsetEnv "http_proxy"+ unsetEnv "https_proxy"+ describe "\"curl\" dependency" $+ let msg =+ "All \"WithApplication\" tests assume the \"curl\" process can be called directly."+ underline = replicate (length msg) '^'+ in it (msg ++ "\n " ++ underline) True+ describe "withApplication" $ do+ it "runs a wai Application while executing the given action" $ do+ let mkApp = return $ \_request respond -> respond $ responseLBS ok200 [] "foo"+ withApplication mkApp $ \port -> do+ output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""+ output `shouldBe` "foo" - it "does not propagate exceptions from the server to the executing thread" $ do- let mkApp = return $ \ _request _respond -> throwString "foo"- withApplication mkApp $ \ port -> do- output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""- output `shouldContain` "Something went wron"+ it "does not propagate exceptions from the server to the executing thread" $ do+ let mkApp = return $ \_request _respond -> throwString "foo"+ withApplication mkApp $ \port -> do+ output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""+ output `shouldContain` "Something went wron" - describe "testWithApplication" $ do- it "propagates exceptions from the server to the executing thread" $ do- let mkApp = return $ \ _request _respond -> throwString "foo"- testWithApplication mkApp (\ port -> do- readProcess "curl" ["-s", "localhost:" ++ show port] "")- `shouldThrow` (\(StringException str _) -> str == "foo")+ describe "testWithApplication" $ do+ it "propagates exceptions from the server to the executing thread" $ do+ let mkApp = return $ \_request _respond -> throwString "foo"+ testWithApplication+ mkApp+ ( \port -> do+ readProcess "curl" ["-s", "localhost:" ++ show port] ""+ )+ `shouldThrow` (\(StringException str _) -> str == "foo")
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 3.3.31+Version: 3.4.0 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE@@ -48,7 +48,7 @@ , hashable , http-date , http-types >= 0.12- , http2 >= 5.0 && < 5.1+ , http2 >= 5.1 && < 5.2 , iproute >= 1.3.1 , recv >= 0.1.0 && < 0.2.0 , simple-sendfile >= 0.2.7 && < 0.3@@ -57,7 +57,7 @@ , text , time-manager , vault >= 0.3- , wai >= 3.2 && < 3.3+ , wai >= 3.2.4 && < 3.3 , word8 , unliftio if flag(x509)@@ -139,6 +139,8 @@ ExceptionSpec FdCacheSpec FileSpec+ HTTP+ PackIntSpec ReadIntSpec RequestSpec ResponseHeaderSpec@@ -146,7 +148,6 @@ RunSpec SendFileSpec WithApplicationSpec- HTTP Network.Wai.Handler.Warp Network.Wai.Handler.Warp.Buffer Network.Wai.Handler.Warp.Conduit@@ -201,7 +202,7 @@ , http-client , http-date , http-types >= 0.12- , http2 >= 5.0 && < 5.1+ , http2 >= 5.1 && < 5.2 , iproute >= 1.3.1 , network , process@@ -237,27 +238,42 @@ Benchmark parser Type: exitcode-stdio-1.0 Main-Is: Parser.hs- other-modules: Network.Wai.Handler.Warp.Date+ other-modules: Network.Wai.Handler.Warp.Conduit+ Network.Wai.Handler.Warp.Date Network.Wai.Handler.Warp.FdCache Network.Wai.Handler.Warp.FileInfoCache Network.Wai.Handler.Warp.HashMap+ Network.Wai.Handler.Warp.Header Network.Wai.Handler.Warp.Imports Network.Wai.Handler.Warp.MultiMap+ Network.Wai.Handler.Warp.ReadInt+ Network.Wai.Handler.Warp.Request+ Network.Wai.Handler.Warp.RequestHeader+ Network.Wai.Handler.Warp.Settings Network.Wai.Handler.Warp.Types+ Paths_warp HS-Source-Dirs: bench . Build-Depends: base >= 4.8 && < 5+ , array , auto-update , bytestring+ , case-insensitive , containers , gauge+ , ghc-prim , hashable , http-date , http-types , network , network , recv+ , streaming-commons+ , text , time-manager , unliftio+ , vault+ , wai+ , word8 if flag(x509) Build-Depends: crypton-x509 if impl(ghc < 8)