@@ -6,12 +6,18 @@ module Main where
66import Control.Exception (throwIO)
77import Control.Monad
88import qualified Data.ByteString as S
9−import Data.ByteString.Char8 (ByteString)
9+--import Data.ByteString.Char8 (ByteString)
1010import qualified Data.ByteString.Char8 as B (unpack)
1111import qualified Network.HTTP.Types as H
1212import Network.Wai.Handler.Warp.Types
1313import Prelude hiding (lines)
1414
15+import Data.ByteString.Internal
16+import Data.Word
17+import Foreign.ForeignPtr
18+import Foreign.Ptr
19+import Foreign.Storable
20+
1521import Criterion.Main
1622
1723-- $setup
@@ -25,24 +31,91 @@ main = do
2531 let requestLine2 = "GET http://www.example.com/cgi-path/search.cgi?key=parser HTTP/1.0"
2632 defaultMain [
2733 bgroup "requestLine1" [
28− bench "parseRequestLine1" $ parseRequestLine1 requestLine1
34+ bench "parseRequestLine2" $ parseRequestLine1 requestLine1
35+ , bench "parseRequestLine1" $ parseRequestLine1 requestLine1
2936 , bench "parseRequestLine0" $ parseRequestLine0 requestLine1
3037 ]
3138 , bgroup "requestLine2" [
32− bench "parseRequestLine1" $ parseRequestLine1 requestLine2
39+ bench "parseRequestLine2" $ parseRequestLine1 requestLine2
40+ , bench "parseRequestLine1" $ parseRequestLine1 requestLine2
3341 , bench "parseRequestLine0" $ parseRequestLine0 requestLine2
3442 ]
3543 ]
3644
3745----------------------------------------------------------------
3846
47+-- |
48+--
49+-- >>> parseRequestLine2 "GET / HTTP/1.1"
50+-- ("GET","/","",HTTP/1.1)
51+-- >>> parseRequestLine2 "POST /cgi/search.cgi?key=foo HTTP/1.0"
52+-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)
53+-- >>> parseRequestLine2 "GET "
54+-- *** Exception: BadFirstLine "GET "
55+-- >>> parseRequestLine2 "GET /NotHTTP UNKNOWN/1.1"
56+-- *** Exception: NonHttp
3957parseRequestLine2 :: ByteString
4058 -> IO (H.Method
4159 ,ByteString -- Path
4260 ,ByteString -- Query
4361 ,H.HttpVersion)
62+parseRequestLine2 requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do
63+ when (len < 14) $ throwIO baderr
64+ let methodptr = ptr `plusPtr` off
65+ limptr = methodptr `plusPtr` len
66+ lim0 = fromIntegral len
67+
68+ pathptr0 <- memchr methodptr 32 lim0 -- ' '
69+ when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $
70+ throwIO baderr
71+ let pathptr = pathptr0 `plusPtr` 1
72+ lim1 = fromIntegral (limptr `minusPtr` pathptr0)
73+
74+ httpptr0 <- memchr pathptr 32 lim1 -- ' '
75+ when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $
76+ throwIO baderr
77+ let httpptr = httpptr0 `plusPtr` 1
78+ lim2 = fromIntegral (httpptr0 `minusPtr` pathptr)
79+
80+ checkHTTP httpptr
81+ hv <- httpVersion httpptr
82+ queryptr <- memchr pathptr 63 lim2 -- '?'
83+
84+ method <- bs methodptr pathptr0
4485
45−parseRequestLine2 requestLine = undefined
86+ path <- if queryptr == nullPtr then
87+ bs pathptr httpptr0
88+ else
89+ bs pathptr queryptr
90+ query <- if queryptr == nullPtr then
91+ return $ S.empty
92+ else
93+ bs queryptr httpptr0
94+ return (method,path,query,hv)
95+ where
96+ baderr = BadFirstLine $ B.unpack requestLine
97+ check :: Ptr Word8 -> Int -> Word8 -> IO ()
98+ check p n w = do
99+ w0 <- peek $ p `plusPtr` n
100+ when (w0 /= w) $ throwIO NonHttp
101+ checkHTTP httpptr = do
102+ check httpptr 0 72 -- 'H'
103+ check httpptr 1 84 -- 'T'
104+ check httpptr 2 84 -- 'T'
105+ check httpptr 3 80 -- 'P'
106+ check httpptr 4 47 -- '/'
107+ check httpptr 6 46 -- '.'
108+ httpVersion httpptr = do
109+ major <- peek $ httpptr `plusPtr` 5
110+ minor <- peek $ httpptr `plusPtr` 7
111+ if major == (49 :: Word8) && minor == (49 :: Word8) then
112+ return H.http11
113+ else
114+ return H.http10
115+ bs p0 p1 = do
116+ p <- newForeignPtr_ p0
117+ let l = p1 `minusPtr` p0
118+ return $ PS p 0 l
46119
47120----------------------------------------------------------------
48121
@@ -105,4 +178,4 @@ parseRequestLine0 s =
105178 _ -> H.http10
106179 in return $! (method, rpath, qstring, hv)
107180 else throwIO NonHttp
108− _ -> throwIO $ BadFirstLine $ B.unpack s
181+ _ -> throwIO $ BadFirstLine $ B.unpack s