1{-# LANGUAGE BangPatterns #-} 2{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE CPP #-} 4{-# LANGUAGE DeriveDataTypeable #-} 5{-# OPTIONS_GHC -fno-warn-deprecations #-} 6 7module Network.Wai.Handler.Warp.Request ( 8 recvRequest 9 , headerLines 10 , pauseTimeoutKey 11 , getFileInfoKey 12 , getClientCertificateKey 13 , NoKeepAliveRequest (..) 14 ) where 15 16import qualified Control.Concurrent as Conc (yield) 17import Control.Exception (throwIO, Exception) 18import Data.Array ((!)) 19import qualified Data.ByteString as S 20import qualified Data.ByteString.Unsafe as SU 21import qualified Data.CaseInsensitive as CI 22import qualified Data.IORef as I 23import Data.Typeable (Typeable) 24import qualified Data.Vault.Lazy as Vault 25import Data.X509 26import qualified Network.HTTP.Types as H 27import Network.Socket (SockAddr) 28import Network.Wai 29import Network.Wai.Handler.Warp.Types 30import Network.Wai.Internal 31import Prelude hiding (lines) 32import System.IO.Unsafe (unsafePerformIO) 33import qualified System.TimeManager as Timeout 34 35import Network.Wai.Handler.Warp.Conduit 36import Network.Wai.Handler.Warp.FileInfoCache 37import Network.Wai.Handler.Warp.Header 38import Network.Wai.Handler.Warp.Imports hiding (readInt, lines) 39import Network.Wai.Handler.Warp.ReadInt 40import Network.Wai.Handler.Warp.RequestHeader 41import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, settingsMaxTotalHeaderLength) 42 43---------------------------------------------------------------- 44 45-- | Receiving a HTTP request from 'Connection' and parsing its header 46-- to create 'Request'. 47recvRequest :: Bool -- ^ first request on this connection? 48 -> Settings 49 -> Connection 50 -> InternalInfo 51 -> Timeout.Handle 52 -> SockAddr -- ^ Peer's address. 53 -> Source -- ^ Where HTTP request comes from. 54 -> Transport 55 -> IO (Request 56 ,Maybe (I.IORef Int) 57 ,IndexedHeader 58 ,IO ByteString) -- ^ 59 -- 'Request' passed to 'Application', 60 -- how many bytes remain to be consumed, if known 61 -- 'IndexedHeader' of HTTP request for internal use, 62 -- Body producing action used for flushing the request body 63 64recvRequest firstRequest settings conn ii th addr src transport = do 65 hdrlines <- headerLines (settingsMaxTotalHeaderLength settings) firstRequest src 66 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines 67 let idxhdr = indexRequestHeader hdr 68 expect = idxhdr ! fromEnum ReqExpect 69 cl = idxhdr ! fromEnum ReqContentLength 70 te = idxhdr ! fromEnum ReqTransferEncoding 71 handle100Continue = handleExpect conn httpversion expect 72 rawPath = if settingsNoParsePath settings then unparsedPath else path 73 vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) 74 $ Vault.insert getFileInfoKey (getFileInfo ii) 75 $ Vault.insert getClientCertificateKey (getTransportClientCertificate transport) 76 Vault.empty 77 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te 78 -- body producing function which will produce '100-continue', if needed 79 rbody' <- timeoutBody remainingRef th rbody handle100Continue 80 -- body producing function which will never produce 100-continue 81 rbodyFlush <- timeoutBody remainingRef th rbody (return ()) 82 let req = Request { 83 requestMethod = method 84 , httpVersion = httpversion 85 , pathInfo = H.decodePathSegments path 86 , rawPathInfo = rawPath 87 , rawQueryString = query 88 , queryString = H.parseQuery query 89 , requestHeaders = hdr 90 , isSecure = isTransportSecure transport 91 , remoteHost = addr 92 , requestBody = rbody' 93 , vault = vaultValue 94 , requestBodyLength = bodyLength 95 , requestHeaderHost = idxhdr ! fromEnum ReqHost 96 , requestHeaderRange = idxhdr ! fromEnum ReqRange 97 , requestHeaderReferer = idxhdr ! fromEnum ReqReferer 98 , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent 99 } 100 return (req, remainingRef, idxhdr, rbodyFlush) 101 102---------------------------------------------------------------- 103 104headerLines :: Int -> Bool -> Source -> IO [ByteString] 105headerLines maxTotalHeaderLength firstRequest src = do 106 bs <- readSource src 107 if S.null bs 108 -- When we're working on a keep-alive connection and trying to 109 -- get the second or later request, we don't want to treat the 110 -- lack of data as a real exception. See the http1 function in 111 -- the Run module for more details. 112 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest 113 else push maxTotalHeaderLength src (THStatus 0 id id) bs 114 115data NoKeepAliveRequest = NoKeepAliveRequest 116 deriving (Show, Typeable) 117instance Exception NoKeepAliveRequest 118 119---------------------------------------------------------------- 120 121handleExpect :: Connection 122 -> H.HttpVersion 123 -> Maybe HeaderValue 124 -> IO () 125handleExpect conn ver (Just "100-continue") = do 126 connSendAll conn continue 127 Conc.yield 128 where 129 continue 130 | ver == H.http11 = "HTTP/1.1 100 Continue\r\n\r\n" 131 | otherwise = "HTTP/1.0 100 Continue\r\n\r\n" 132handleExpect _ _ _ = return () 133 134---------------------------------------------------------------- 135 136bodyAndSource :: Source 137 -> Maybe HeaderValue -- ^ content length 138 -> Maybe HeaderValue -- ^ transfer-encoding 139 -> IO (IO ByteString 140 ,Maybe (I.IORef Int) 141 ,RequestBodyLength 142 ) 143bodyAndSource src cl te 144 | chunked = do 145 csrc <- mkCSource src 146 return (readCSource csrc, Nothing, ChunkedBody) 147 | otherwise = do 148 isrc@(ISource _ remaining) <- mkISource src len 149 return (readISource isrc, Just remaining, bodyLen) 150 where 151 len = toLength cl 152 bodyLen = KnownLength $ fromIntegral len 153 chunked = isChunked te 154 155toLength :: Maybe HeaderValue -> Int 156toLength Nothing = 0 157toLength (Just bs) = readInt bs 158 159isChunked :: Maybe HeaderValue -> Bool 160isChunked (Just bs) = CI.foldCase bs == "chunked" 161isChunked _ = False 162 163---------------------------------------------------------------- 164 165timeoutBody :: Maybe (I.IORef Int) -- ^ remaining 166 -> Timeout.Handle 167 -> IO ByteString 168 -> IO () 169 -> IO (IO ByteString) 170timeoutBody remainingRef timeoutHandle rbody handle100Continue = do 171 isFirstRef <- I.newIORef True 172 173 let checkEmpty = 174 case remainingRef of 175 Nothing -> return . S.null 176 Just ref -> \bs -> if S.null bs 177 then return True 178 else do 179 x <- I.readIORef ref 180 return $! x <= 0 181 182 return $ do 183 isFirst <- I.readIORef isFirstRef 184 185 when isFirst $ do 186 -- Only check if we need to produce the 100 Continue status 187 -- when asking for the first chunk of the body 188 handle100Continue 189 -- Timeout handling was paused after receiving the full request 190 -- headers. Now we need to resume it to avoid a slowloris 191 -- attack during request body sending. 192 Timeout.resume timeoutHandle 193 I.writeIORef isFirstRef False 194 195 bs <- rbody 196 197 -- As soon as we finish receiving the request body, whether 198 -- because the application is not interested in more bytes, or 199 -- because there is no more data available, pause the timeout 200 -- handler again. 201 isEmpty <- checkEmpty bs 202 when isEmpty (Timeout.pause timeoutHandle) 203 204 return bs 205 206---------------------------------------------------------------- 207 208type BSEndo = ByteString -> ByteString 209type BSEndoList = [ByteString] -> [ByteString] 210 211data THStatus = THStatus 212 {-# UNPACK #-} !Int -- running total byte count 213 BSEndoList -- previously parsed lines 214 BSEndo -- bytestrings to be prepended 215 216---------------------------------------------------------------- 217 218{- FIXME 219close :: Sink ByteString IO a 220close = throwIO IncompleteHeaders 221-} 222 223push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString] 224push maxTotalHeaderLength src (THStatus len lines prepend) bs' 225 -- Too many bytes 226 | len > maxTotalHeaderLength = throwIO OverLargeHeader 227 | otherwise = push' mnl 228 where 229 bs = prepend bs' 230 bsLen = S.length bs 231 mnl = do 232 nl <- S.elemIndex 10 bs 233 -- check if there are two more bytes in the bs 234 -- if so, see if the second of those is a horizontal space 235 if bsLen > nl + 1 then 236 let c = S.index bs (nl + 1) 237 b = case nl of 238 0 -> True 239 1 -> S.index bs 0 == 13 240 _ -> False 241 in Just (nl, not b && (c == 32 || c == 9)) 242 else 243 Just (nl, False) 244 245 {-# INLINE push' #-} 246 push' :: Maybe (Int, Bool) -> IO [ByteString] 247 -- No newline find in this chunk. Add it to the prepend, 248 -- update the length, and continue processing. 249 push' Nothing = do 250 bst <- readSource' src 251 when (S.null bst) $ throwIO IncompleteHeaders 252 push maxTotalHeaderLength src status bst 253 where 254 len' = len + bsLen 255 prepend' = S.append bs 256 status = THStatus len' lines prepend' 257 -- Found a newline, but next line continues as a multiline header 258 push' (Just (end, True)) = push maxTotalHeaderLength src status rest 259 where 260 rest = S.drop (end + 1) bs 261 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs) 262 len' = len + end 263 status = THStatus len' lines prepend' 264 -- Found a newline at position end. 265 push' (Just (end, False)) 266 -- leftover 267 | S.null line = do 268 when (start < bsLen) $ leftoverSource src (SU.unsafeDrop start bs) 269 return (lines []) 270 -- more headers 271 | otherwise = let len' = len + start 272 lines' = lines . (line:) 273 status = THStatus len' lines' id 274 in if start < bsLen then 275 -- more bytes in this chunk, push again 276 let bs'' = SU.unsafeDrop start bs 277 in push maxTotalHeaderLength src status bs'' 278 else do 279 -- no more bytes in this chunk, ask for more 280 bst <- readSource' src 281 when (S.null bs) $ throwIO IncompleteHeaders 282 push maxTotalHeaderLength src status bst 283 where 284 start = end + 1 -- start of next chunk 285 line = SU.unsafeTake (checkCR bs end) bs 286 287{-# INLINE checkCR #-} 288checkCR :: ByteString -> Int -> Int 289checkCR bs pos = if pos > 0 && 13 == S.index bs p then p else pos -- 13 is CR 290 where 291 !p = pos - 1 292 293pauseTimeoutKey :: Vault.Key (IO ()) 294pauseTimeoutKey = unsafePerformIO Vault.newKey 295{-# NOINLINE pauseTimeoutKey #-} 296 297getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo) 298getFileInfoKey = unsafePerformIO Vault.newKey 299{-# NOINLINE getFileInfoKey #-} 300 301getClientCertificateKey :: Vault.Key (Maybe CertificateChain) 302getClientCertificateKey = unsafePerformIO Vault.newKey 303{-# NOINLINE getClientCertificateKey #-} 304