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