@@ -1,16 +1,20 @@
11{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns #-}
23
34module Network.Wai.Handler.Warp.RequestHeader (parseHeaderLines) where
45
56import Control.Exception (throwIO)
6−import Data.ByteString.Char8 (ByteString)
7+import Control.Monad (when)
78import qualified Data.ByteString as S
89import qualified Data.ByteString.Char8 as B (unpack)
10+import Data.ByteString.Internal (ByteString(..), memchr)
911import qualified Data.CaseInsensitive as CI
12+import Data.Word (Word8)
13+import Foreign.ForeignPtr (withForeignPtr)
14+import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)
15+import Foreign.Storable (peek)
1016import qualified Network.HTTP.Types as H
1117import Network.Wai.Handler.Warp.Types
12−import Prelude hiding (lines)
13−import Control.Monad
1418
1519-- $setup
1620-- >>> :set -XOverloadedStrings
@@ -39,8 +43,8 @@ parseHeaderLines (firstLine:otherLines) = do
3943-- ("GET","/","",HTTP/1.1)
4044-- >>> parseRequestLine "POST /cgi/search.cgi?key=foo HTTP/1.0"
4145-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)
42−-- >>> parseRequestLine "GET /NoHTTPVersion"
43−-- *** Exception: BadFirstLine "GET /NoHTTPVersion"
46+-- >>> parseRequestLine "GET "
47+-- *** Exception: BadFirstLine "GET "
4448-- >>> parseRequestLine "GET /NotHTTP UNKNOWN/1.1"
4549-- *** Exception: NonHttp
4650parseRequestLine :: ByteString
@@ -48,18 +52,61 @@ parseRequestLine :: ByteString
4852 ,ByteString -- Path
4953 ,ByteString -- Query
5054 ,H.HttpVersion)
51−parseRequestLine requestLine = do
52− let (method,rest) = S.breakByte 32 requestLine -- ' '
53− (pathQuery,httpVer') = S.breakByte 32 (S.drop 1 rest) -- ' '
54− httpVer = S.drop 1 httpVer'
55− when (rest == "" || httpVer == "") $
56− throwIO $ BadFirstLine $ B.unpack requestLine
57− let (path,query) = S.breakByte 63 pathQuery -- '?'
58− (http,ver) = S.breakByte 47 httpVer -- '/'
59− when (http /= "HTTP") $ throwIO NonHttp
60− let hv | ver == "/1.1" = H.http11
61− | otherwise = H.http10
62− return $ (method,path,query,hv)
55+parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do
56+ when (len < 14) $ throwIO baderr
57+ let methodptr = ptr `plusPtr` off
58+ limptr = methodptr `plusPtr` len
59+ lim0 = fromIntegral len
60+
61+ pathptr0 <- memchr methodptr 32 lim0 -- ' '
62+ when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $
63+ throwIO baderr
64+ let pathptr = pathptr0 `plusPtr` 1
65+ lim1 = fromIntegral (limptr `minusPtr` pathptr0)
66+
67+ httpptr0 <- memchr pathptr 32 lim1 -- ' '
68+ when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $
69+ throwIO baderr
70+ let httpptr = httpptr0 `plusPtr` 1
71+ lim2 = fromIntegral (httpptr0 `minusPtr` pathptr)
72+
73+ checkHTTP httpptr
74+ !hv <- httpVersion httpptr
75+ queryptr <- memchr pathptr 63 lim2 -- '?'
76+
77+ let !method = bs ptr methodptr pathptr0
78+ !path
79+ | queryptr == nullPtr = bs ptr pathptr httpptr0
80+ | otherwise = bs ptr pathptr queryptr
81+ !query
82+ | queryptr == nullPtr = S.empty
83+ | otherwise = bs ptr queryptr httpptr0
84+
85+ return (method,path,query,hv)
86+ where
87+ baderr = BadFirstLine $ B.unpack requestLine
88+ check :: Ptr Word8 -> Int -> Word8 -> IO ()
89+ check p n w = do
90+ w0 <- peek $ p `plusPtr` n
91+ when (w0 /= w) $ throwIO NonHttp
92+ checkHTTP httpptr = do
93+ check httpptr 0 72 -- 'H'
94+ check httpptr 1 84 -- 'T'
95+ check httpptr 2 84 -- 'T'
96+ check httpptr 3 80 -- 'P'
97+ check httpptr 4 47 -- '/'
98+ check httpptr 6 46 -- '.'
99+ httpVersion httpptr = do
100+ major <- peek $ httpptr `plusPtr` 5
101+ minor <- peek $ httpptr `plusPtr` 7
102+ if major == (49 :: Word8) && minor == (49 :: Word8) then
103+ return H.http11
104+ else
105+ return H.http10
106+ bs ptr p0 p1 = PS fptr o l
107+ where
108+ o = p0 `minusPtr` ptr
109+ l = p1 `minusPtr` p0
63110
64111----------------------------------------------------------------
65112