git.iko.soy/typeable/wai
on wai-handler-webkit/3.0.0 help sign in
typeable/wai/warp/bench/Parser.hs
215 lines 7.7 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE BangPatterns #-}
4module Main where
6import Control.Exception (throwIO, throw)
7import Control.Monad
8import qualified Data.ByteString as S
9--import Data.ByteString.Char8 (ByteString)
10import qualified Data.ByteString.Char8 as B (unpack)
11import qualified Network.HTTP.Types as H
12import Network.Wai.Handler.Warp.Types
13import Prelude hiding (lines)
15import Data.ByteString.Internal
16import Data.Word
17import Foreign.ForeignPtr
18import Foreign.Ptr
19import Foreign.Storable
21import Criterion.Main
23-- $setup
24-- >>> :set -XOverloadedStrings
26----------------------------------------------------------------
28main :: IO ()
29main = do
30 let requestLine1 = "GET http://www.example.com HTTP/1.1"
31 let requestLine2 = "GET http://www.example.com/cgi-path/search.cgi?key=parser HTTP/1.0"
32 defaultMain [
33 bgroup "requestLine1" [
34 bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine1
35 , bench "parseRequestLine2" $ parseRequestLine2 requestLine1
36 , bench "parseRequestLine1" $ parseRequestLine1 requestLine1
37 , bench "parseRequestLine0" $ parseRequestLine0 requestLine1
38 ]
39 , bgroup "requestLine2" [
40 bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine2
41 , bench "parseRequestLine2" $ parseRequestLine2 requestLine2
42 , bench "parseRequestLine1" $ parseRequestLine1 requestLine2
43 , bench "parseRequestLine0" $ parseRequestLine0 requestLine2
44 ]
45 ]
47----------------------------------------------------------------
49-- |
50--
51-- >>> parseRequestLine3 "GET / HTTP/1.1"
52-- ("GET","/","",HTTP/1.1)
53-- >>> parseRequestLine3 "POST /cgi/search.cgi?key=foo HTTP/1.0"
54-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)
55-- >>> parseRequestLine3 "GET "
56-- *** Exception: BadFirstLine "GET "
57-- >>> parseRequestLine3 "GET /NotHTTP UNKNOWN/1.1"
58-- *** Exception: NonHttp
59parseRequestLine3 :: ByteString
60 -> (H.Method
61 ,ByteString -- Path
62 ,ByteString -- Query
63 ,H.HttpVersion)
64parseRequestLine3 requestLine = ret
65 where
66 (!method,!rest) = S.breakByte 32 requestLine -- ' '
67 (!pathQuery,!httpVer')
68 | rest == "" = throw badmsg
69 | otherwise = S.breakByte 32 (S.drop 1 rest) -- ' '
70 (!path,!query) = S.breakByte 63 pathQuery -- '?'
71 !httpVer = S.drop 1 httpVer'
72 (!http,!ver)
73 | httpVer == "" = throw badmsg
74 | otherwise = S.breakByte 47 httpVer -- '/'
75 !hv | http /= "HTTP" = throw NonHttp
76 | ver == "/1.1" = H.http11
77 | otherwise = H.http10
78 !ret = (method,path,query,hv)
79 badmsg = BadFirstLine $ B.unpack requestLine
81----------------------------------------------------------------
83-- |
84--
85-- >>> parseRequestLine2 "GET / HTTP/1.1"
86-- ("GET","/","",HTTP/1.1)
87-- >>> parseRequestLine2 "POST /cgi/search.cgi?key=foo HTTP/1.0"
88-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)
89-- >>> parseRequestLine2 "GET "
90-- *** Exception: BadFirstLine "GET "
91-- >>> parseRequestLine2 "GET /NotHTTP UNKNOWN/1.1"
92-- *** Exception: NonHttp
93parseRequestLine2 :: ByteString
94 -> IO (H.Method
95 ,ByteString -- Path
96 ,ByteString -- Query
97 ,H.HttpVersion)
98parseRequestLine2 requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do
99 when (len < 14) $ throwIO baderr
100 let methodptr = ptr `plusPtr` off
101 limptr = methodptr `plusPtr` len
102 lim0 = fromIntegral len
104 pathptr0 <- memchr methodptr 32 lim0 -- ' '
105 when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $
106 throwIO baderr
107 let pathptr = pathptr0 `plusPtr` 1
108 lim1 = fromIntegral (limptr `minusPtr` pathptr0)
110 httpptr0 <- memchr pathptr 32 lim1 -- ' '
111 when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $
112 throwIO baderr
113 let httpptr = httpptr0 `plusPtr` 1
114 lim2 = fromIntegral (httpptr0 `minusPtr` pathptr)
116 checkHTTP httpptr
117 !hv <- httpVersion httpptr
118 queryptr <- memchr pathptr 63 lim2 -- '?'
120 let !method = bs ptr methodptr pathptr0
121 !path
122 | queryptr == nullPtr = bs ptr pathptr httpptr0
123 | otherwise = bs ptr pathptr queryptr
124 !query
125 | queryptr == nullPtr = S.empty
126 | otherwise = bs ptr queryptr httpptr0
128 return (method,path,query,hv)
129 where
130 baderr = BadFirstLine $ B.unpack requestLine
131 check :: Ptr Word8 -> Int -> Word8 -> IO ()
132 check p n w = do
133 w0 <- peek $ p `plusPtr` n
134 when (w0 /= w) $ throwIO NonHttp
135 checkHTTP httpptr = do
136 check httpptr 0 72 -- 'H'
137 check httpptr 1 84 -- 'T'
138 check httpptr 2 84 -- 'T'
139 check httpptr 3 80 -- 'P'
140 check httpptr 4 47 -- '/'
141 check httpptr 6 46 -- '.'
142 httpVersion httpptr = do
143 major <- peek $ httpptr `plusPtr` 5
144 minor <- peek $ httpptr `plusPtr` 7
145 if major == (49 :: Word8) && minor == (49 :: Word8) then
146 return H.http11
147 else
148 return H.http10
149 bs ptr p0 p1 = PS fptr o l
150 where
151 o = p0 `minusPtr` ptr
152 l = p1 `minusPtr` p0
154----------------------------------------------------------------
156-- |
157--
158-- >>> parseRequestLine1 "GET / HTTP/1.1"
159-- ("GET","/","",HTTP/1.1)
160-- >>> parseRequestLine1 "POST /cgi/search.cgi?key=foo HTTP/1.0"
161-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)
162-- >>> parseRequestLine1 "GET "
163-- *** Exception: BadFirstLine "GET "
164-- >>> parseRequestLine1 "GET /NotHTTP UNKNOWN/1.1"
165-- *** Exception: NonHttp
166parseRequestLine1 :: ByteString
167 -> IO (H.Method
168 ,ByteString -- Path
169 ,ByteString -- Query
170 ,H.HttpVersion)
171parseRequestLine1 requestLine = do
172 let (!method,!rest) = S.breakByte 32 requestLine -- ' '
173 (!pathQuery,!httpVer') = S.breakByte 32 (S.drop 1 rest) -- ' '
174 !httpVer = S.drop 1 httpVer'
175 when (rest == "" || httpVer == "") $
176 throwIO $ BadFirstLine $ B.unpack requestLine
177 let (!path,!query) = S.breakByte 63 pathQuery -- '?'
178 (!http,!ver) = S.breakByte 47 httpVer -- '/'
179 when (http /= "HTTP") $ throwIO NonHttp
180 let !hv | ver == "/1.1" = H.http11
181 | otherwise = H.http10
182 return $! (method,path,query,hv)
184----------------------------------------------------------------
186-- |
187--
188-- >>> parseRequestLine0 "GET / HTTP/1.1"
189-- ("GET","/","",HTTP/1.1)
190-- >>> parseRequestLine0 "POST /cgi/search.cgi?key=foo HTTP/1.0"
191-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)
192-- >>> parseRequestLine0 "GET "
193-- *** Exception: BadFirstLine "GET "
194-- >>> parseRequestLine0 "GET /NotHTTP UNKNOWN/1.1"
195-- *** Exception: NonHttp
196parseRequestLine0 :: ByteString
197 -> IO (H.Method
198 ,ByteString -- Path
199 ,ByteString -- Query
200 ,H.HttpVersion)
201parseRequestLine0 s =
202 case filter (not . S.null) $ S.splitWith (\c -> c == 32 || c == 9) s of -- '
203 (method':query:http'') -> do
204 let !method = method'
205 !http' = S.concat http''
206 (!hfirst, !hsecond) = S.splitAt 5 http'
207 if hfirst == "HTTP/"
208 then let (!rpath, !qstring) = S.breakByte 63 query -- '?'
209 !hv =
210 case hsecond of
211 "1.1" -> H.http11
212 _ -> H.http10
213 in return $! (method, rpath, qstring, hv)
214 else throwIO NonHttp
215 _ -> throwIO $ BadFirstLine $ B.unpack s