git.iko.soy/typeable/wai
on master help sign in
implementing pointer version oof parseRequest.
7edd143Kazu Yamamoto
warp/bench/Parser.hs+78−5
compare with master
unifiedsplit
@@ -6,12 +6,18 @@ module Main where
6import Control.Exception (throwIO)
6import Control.Exception (throwIO)
7import Control.Monad
7import Control.Monad
8import qualified Data.ByteString as S
8import qualified Data.ByteString as S
9−import Data.ByteString.Char8 (ByteString)
9+--import Data.ByteString.Char8 (ByteString)
10import qualified Data.ByteString.Char8 as B (unpack)
10import qualified Data.ByteString.Char8 as B (unpack)
11import qualified Network.HTTP.Types as H
11import qualified Network.HTTP.Types as H
12import Network.Wai.Handler.Warp.Types
12import Network.Wai.Handler.Warp.Types
13import Prelude hiding (lines)
13import Prelude hiding (lines)
14
14
15+import Data.ByteString.Internal
16+import Data.Word
17+import Foreign.ForeignPtr
18+import Foreign.Ptr
19+import Foreign.Storable
20+
15import Criterion.Main
21import Criterion.Main
16
22
17-- $setup
23-- $setup
@@ -25,24 +31,91 @@ main = do
25 let requestLine2 = "GET http://www.example.com/cgi-path/search.cgi?key=parser HTTP/1.0"
31 let requestLine2 = "GET http://www.example.com/cgi-path/search.cgi?key=parser HTTP/1.0"
26 defaultMain [
32 defaultMain [
27 bgroup "requestLine1" [
33 bgroup "requestLine1" [
34+ bench "parseRequestLine2" $ parseRequestLine1 requestLine1
28− bench "parseRequestLine1" $ parseRequestLine1 requestLine1
35+ , bench "parseRequestLine1" $ parseRequestLine1 requestLine1
29 , bench "parseRequestLine0" $ parseRequestLine0 requestLine1
36 , bench "parseRequestLine0" $ parseRequestLine0 requestLine1
30 ]
37 ]
31 , bgroup "requestLine2" [
38 , bgroup "requestLine2" [
39+ bench "parseRequestLine2" $ parseRequestLine1 requestLine2
32− bench "parseRequestLine1" $ parseRequestLine1 requestLine2
40+ , bench "parseRequestLine1" $ parseRequestLine1 requestLine2
33 , bench "parseRequestLine0" $ parseRequestLine0 requestLine2
41 , bench "parseRequestLine0" $ parseRequestLine0 requestLine2
34 ]
42 ]
35 ]
43 ]
36
44
37----------------------------------------------------------------
45----------------------------------------------------------------
38
46
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
39parseRequestLine2 :: ByteString
57parseRequestLine2 :: ByteString
40 -> IO (H.Method
58 -> IO (H.Method
41 ,ByteString -- Path
59 ,ByteString -- Path
42 ,ByteString -- Query
60 ,ByteString -- Query
43 ,H.HttpVersion)
61 ,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
44
85
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
46
119
47----------------------------------------------------------------
120----------------------------------------------------------------
48
121
@@ -105,4 +178,4 @@ parseRequestLine0 s =
105 _ -> H.http10
178 _ -> H.http10
106 in return $! (method, rpath, qstring, hv)
179 in return $! (method, rpath, qstring, hv)
107 else throwIO NonHttp
180 else throwIO NonHttp
108− _ -> throwIO $ BadFirstLine $ B.unpack s
181+ _ -> throwIO $ BadFirstLine $ B.unpack s