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 UnliftIO (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 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 !Int -- running total byte count (excluding current header chunk) 213 !Int -- current header chunk byte count 214 BSEndoList -- previously parsed lines 215 BSEndo -- bytestrings to be prepended 216 217---------------------------------------------------------------- 218 219{- FIXME 220close :: Sink ByteString IO a 221close = throwIO IncompleteHeaders 222-} 223 224push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString] 225push maxTotalHeaderLength src (THStatus totalLen chunkLen lines prepend) bs' 226 -- Too many bytes 227 | currentTotal > maxTotalHeaderLength = throwIO OverLargeHeader 228 | otherwise = push' mNL 229 where 230 currentTotal = totalLen + chunkLen 231 -- bs: current header chunk, plus maybe (parts of) next header 232 bs = prepend bs' 233 bsLen = S.length bs 234 -- Maybe newline 235 -- Returns: Maybe 236 -- ( length of this chunk up to newline 237 -- , position of newline in relation to entire current header 238 -- , is this part of a multiline header 239 -- ) 240 mNL = do 241 -- 10 is the code point for newline (\n) 242 chunkNL <- S.elemIndex 10 bs' 243 let headerNL = chunkNL + S.length (prepend "") 244 chunkNLlen = chunkNL + 1 245 -- check if there are two more bytes in the bs 246 -- if so, see if the second of those is a horizontal space 247 if bsLen > headerNL + 1 then 248 let c = S.index bs (headerNL + 1) 249 b = case headerNL of 250 0 -> True 251 1 -> S.index bs 0 == 13 252 _ -> False 253 isMultiline = not b && (c == 32 || c == 9) 254 in Just (chunkNLlen, headerNL, isMultiline) 255 else 256 Just (chunkNLlen, headerNL, False) 257 258 {-# INLINE push' #-} 259 push' :: Maybe (Int, Int, Bool) -> IO [ByteString] 260 -- No newline find in this chunk. Add it to the prepend, 261 -- update the length, and continue processing. 262 push' Nothing = do 263 bst <- readSource' src 264 when (S.null bst) $ throwIO IncompleteHeaders 265 push maxTotalHeaderLength src status bst 266 where 267 prepend' = S.append bs 268 thisChunkLen = S.length bs' 269 newChunkLen = chunkLen + thisChunkLen 270 status = THStatus totalLen newChunkLen lines prepend' 271 -- Found a newline, but next line continues as a multiline header 272 push' (Just (chunkNLlen, end, True)) = 273 push maxTotalHeaderLength src status rest 274 where 275 rest = S.drop (end + 1) bs 276 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs) 277 -- If we'd just update the entire current chunk up to newline 278 -- we wouldn't count all the dropped newlines in between. 279 -- So update 'chunkLen' with current chunk up to newline 280 -- and use 'chunkLen' later on to add to 'totalLen'. 281 newChunkLen = chunkLen + chunkNLlen 282 status = THStatus totalLen newChunkLen lines prepend' 283 -- Found a newline at position end. 284 push' (Just (chunkNLlen, end, False)) 285 -- leftover 286 | S.null line = do 287 when (start < bsLen) $ leftoverSource src (SU.unsafeDrop start bs) 288 return (lines []) 289 -- more headers 290 | otherwise = let lines' = lines . (line:) 291 newTotalLength = totalLen + chunkLen + chunkNLlen 292 status = THStatus newTotalLength 0 lines' id 293 in if start < bsLen then 294 -- more bytes in this chunk, push again 295 let bs'' = SU.unsafeDrop start bs 296 in push maxTotalHeaderLength src status bs'' 297 else do 298 -- no more bytes in this chunk, ask for more 299 bst <- readSource' src 300 when (S.null bs) $ throwIO IncompleteHeaders 301 push maxTotalHeaderLength src status bst 302 where 303 start = end + 1 -- start of next chunk 304 line = SU.unsafeTake (checkCR bs end) bs 305 306{-# INLINE checkCR #-} 307checkCR :: ByteString -> Int -> Int 308checkCR bs pos = if pos > 0 && 13 == S.index bs p then p else pos -- 13 is CR (\r) 309 where 310 !p = pos - 1 311 312pauseTimeoutKey :: Vault.Key (IO ()) 313pauseTimeoutKey = unsafePerformIO Vault.newKey 314{-# NOINLINE pauseTimeoutKey #-} 315 316getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo) 317getFileInfoKey = unsafePerformIO Vault.newKey 318{-# NOINLINE getFileInfoKey #-} 319 320getClientCertificateKey :: Vault.Key (Maybe CertificateChain) 321getClientCertificateKey = unsafePerformIO Vault.newKey 322{-# NOINLINE getClientCertificateKey #-} 323