diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/Network/Wai/Handler/Warp.hs b/Network/Wai/Handler/Warp.hs --- a/Network/Wai/Handler/Warp.hs +++ b/Network/Wai/Handler/Warp.hs @@ -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 . --- --- 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. diff --git a/Network/Wai/Handler/Warp/Buffer.hs b/Network/Wai/Handler/Warp/Buffer.hs --- a/Network/Wai/Handler/Warp/Buffer.hs +++ b/Network/Wai/Handler/Warp/Buffer.hs @@ -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 + } ---------------------------------------------------------------- diff --git a/Network/Wai/Handler/Warp/Conduit.hs b/Network/Wai/Handler/Warp/Conduit.hs --- a/Network/Wai/Handler/Warp/Conduit.hs +++ b/Network/Wai/Handler/Warp/Conduit.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Counter.hs b/Network/Wai/Handler/Warp/Counter.hs --- a/Network/Wai/Handler/Warp/Counter.hs +++ b/Network/Wai/Handler/Warp/Counter.hs @@ -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) diff --git a/Network/Wai/Handler/Warp/Date.hs b/Network/Wai/Handler/Warp/Date.hs --- a/Network/Wai/Handler/Warp/Date.hs +++ b/Network/Wai/Handler/Warp/Date.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/FdCache.hs b/Network/Wai/Handler/Warp/FdCache.hs --- a/Network/Wai/Handler/Warp/FdCache.hs +++ b/Network/Wai/Handler/Warp/FdCache.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/File.hs b/Network/Wai/Handler/Warp/File.hs --- a/Network/Wai/Handler/Warp/File.hs +++ b/Network/Wai/Handler/Warp/File.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/FileInfoCache.hs b/Network/Wai/Handler/Warp/FileInfoCache.hs --- a/Network/Wai/Handler/Warp/FileInfoCache.hs +++ b/Network/Wai/Handler/Warp/FileInfoCache.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP1.hs b/Network/Wai/Handler/Warp/HTTP1.hs --- a/Network/Wai/Handler/Warp/HTTP1.hs +++ b/Network/Wai/Handler/Warp/HTTP1.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP2.hs b/Network/Wai/Handler/Warp/HTTP2.hs --- a/Network/Wai/Handler/Warp/HTTP2.hs +++ b/Network/Wai/Handler/Warp/HTTP2.hs @@ -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 () diff --git a/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs b/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs --- a/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs +++ b/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP2/Request.hs b/Network/Wai/Handler/Warp/HTTP2/Request.hs --- a/Network/Wai/Handler/Warp/HTTP2/Request.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Request.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP2/Response.hs b/Network/Wai/Handler/Warp/HTTP2/Response.hs --- a/Network/Wai/Handler/Warp/HTTP2/Response.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Response.hs @@ -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) ---------------------------------------------------------------- diff --git a/Network/Wai/Handler/Warp/HTTP2/Types.hs b/Network/Wai/Handler/Warp/HTTP2/Types.hs --- a/Network/Wai/Handler/Warp/HTTP2/Types.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Types.hs @@ -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. -- diff --git a/Network/Wai/Handler/Warp/HashMap.hs b/Network/Wai/Handler/Warp/HashMap.hs --- a/Network/Wai/Handler/Warp/HashMap.hs +++ b/Network/Wai/Handler/Warp/HashMap.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Header.hs b/Network/Wai/Handler/Warp/Header.hs --- a/Network/Wai/Handler/Warp/Header.hs +++ b/Network/Wai/Handler/Warp/Header.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/IO.hs b/Network/Wai/Handler/Warp/IO.hs --- a/Network/Wai/Handler/Warp/IO.hs +++ b/Network/Wai/Handler/Warp/IO.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Imports.hs b/Network/Wai/Handler/Warp/Imports.hs --- a/Network/Wai/Handler/Warp/Imports.hs +++ b/Network/Wai/Handler/Warp/Imports.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Internal.hs b/Network/Wai/Handler/Warp/Internal.hs --- a/Network/Wai/Handler/Warp/Internal.hs +++ b/Network/Wai/Handler/Warp/Internal.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/MultiMap.hs b/Network/Wai/Handler/Warp/MultiMap.hs --- a/Network/Wai/Handler/Warp/MultiMap.hs +++ b/Network/Wai/Handler/Warp/MultiMap.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/Wai/Handler/Warp/PackInt.hs b/Network/Wai/Handler/Warp/PackInt.hs --- a/Network/Wai/Handler/Warp/PackInt.hs +++ b/Network/Wai/Handler/Warp/PackInt.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/ReadInt.hs b/Network/Wai/Handler/Warp/ReadInt.hs --- a/Network/Wai/Handler/Warp/ReadInt.hs +++ b/Network/Wai/Handler/Warp/ReadInt.hs @@ -1,19 +1,22 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} -- Copyright : Erik de Castro Lopo -- 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 diff --git a/Network/Wai/Handler/Warp/Request.hs b/Network/Wai/Handler/Warp/Request.hs --- a/Network/Wai/Handler/Warp/Request.hs +++ b/Network/Wai/Handler/Warp/Request.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/RequestHeader.hs b/Network/Wai/Handler/Warp/RequestHeader.hs --- a/Network/Wai/Handler/Warp/RequestHeader.hs +++ b/Network/Wai/Handler/Warp/RequestHeader.hs @@ -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') diff --git a/Network/Wai/Handler/Warp/Response.hs b/Network/Wai/Handler/Warp/Response.hs --- a/Network/Wai/Handler/Warp/Response.hs +++ b/Network/Wai/Handler/Warp/Response.hs @@ -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 = diff --git a/Network/Wai/Handler/Warp/ResponseHeader.hs b/Network/Wai/Handler/Warp/ResponseHeader.hs --- a/Network/Wai/Handler/Warp/ResponseHeader.hs +++ b/Network/Wai/Handler/Warp/ResponseHeader.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Run.hs b/Network/Wai/Handler/Warp/Run.hs --- a/Network/Wai/Handler/Warp/Run.hs +++ b/Network/Wai/Handler/Warp/Run.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/SendFile.hs b/Network/Wai/Handler/Warp/SendFile.hs --- a/Network/Wai/Handler/Warp/SendFile.hs +++ b/Network/Wai/Handler/Warp/SendFile.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Settings.hs b/Network/Wai/Handler/Warp/Settings.hs --- a/Network/Wai/Handler/Warp/Settings.hs +++ b/Network/Wai/Handler/Warp/Settings.hs @@ -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. diff --git a/Network/Wai/Handler/Warp/Types.hs b/Network/Wai/Handler/Warp/Types.hs --- a/Network/Wai/Handler/Warp/Types.hs +++ b/Network/Wai/Handler/Warp/Types.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Windows.hs b/Network/Wai/Handler/Warp/Windows.hs --- a/Network/Wai/Handler/Warp/Windows.hs +++ b/Network/Wai/Handler/Warp/Windows.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/WithApplication.hs b/Network/Wai/Handler/Warp/WithApplication.hs --- a/Network/Wai/Handler/Warp/WithApplication.hs +++ b/Network/Wai/Handler/Warp/WithApplication.hs @@ -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. -- diff --git a/bench/Parser.hs b/bench/Parser.hs --- a/bench/Parser.hs +++ b/bench/Parser.hs @@ -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" + ] diff --git a/test/ConduitSpec.hs b/test/ConduitSpec.hs --- a/test/ConduitSpec.hs +++ b/test/ConduitSpec.hs @@ -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 diff --git a/test/ExceptionSpec.hs b/test/ExceptionSpec.hs --- a/test/ExceptionSpec.hs +++ b/test/ExceptionSpec.hs @@ -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 diff --git a/test/FdCacheSpec.hs b/test/FdCacheSpec.hs --- a/test/FdCacheSpec.hs +++ b/test/FdCacheSpec.hs @@ -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 () diff --git a/test/FileSpec.hs b/test/FileSpec.hs --- a/test/FileSpec.hs +++ b/test/FileSpec.hs @@ -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 diff --git a/test/HTTP.hs b/test/HTTP.hs --- a/test/HTTP.hs +++ b/test/HTTP.hs @@ -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 diff --git a/test/PackIntSpec.hs b/test/PackIntSpec.hs new file mode 100644 --- /dev/null +++ b/test/PackIntSpec.hs @@ -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') diff --git a/test/ReadIntSpec.hs b/test/ReadIntSpec.hs --- a/test/ReadIntSpec.hs +++ b/test/ReadIntSpec.hs @@ -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 diff --git a/test/RequestSpec.hs b/test/RequestSpec.hs --- a/test/RequestSpec.hs +++ b/test/RequestSpec.hs @@ -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 diff --git a/test/ResponseHeaderSpec.hs b/test/ResponseHeaderSpec.hs --- a/test/ResponseHeaderSpec.hs +++ b/test/ResponseHeaderSpec.hs @@ -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" diff --git a/test/ResponseSpec.hs b/test/ResponseSpec.hs --- a/test/ResponseSpec.hs +++ b/test/ResponseSpec.hs @@ -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 diff --git a/test/RunSpec.hs b/test/RunSpec.hs --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -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 :) diff --git a/test/SendFileSpec.hs b/test/SendFileSpec.hs --- a/test/SendFileSpec.hs +++ b/test/SendFileSpec.hs @@ -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 diff --git a/test/WithApplicationSpec.hs b/test/WithApplicationSpec.hs --- a/test/WithApplicationSpec.hs +++ b/test/WithApplicationSpec.hs @@ -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") diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -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)