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