git.iko.soy/typeable/attoparsec
on master help sign in
More warp-related benchmarking
9619ef4Bryan O'Sullivan
.hgignore+1
compare with master
unifiedsplit
@@ -6,6 +6,7 @@ benchmarks/Arse
6benchmarks/dist
6benchmarks/dist
7benchmarks/med.txt
7benchmarks/med.txt
8benchmarks/tiny
8benchmarks/tiny
9+benchmarks/warp-[0-9]*
9cabal.sandbox.config
10cabal.sandbox.config
10examples/c-http
11examples/c-http
11examples/http_parser.[ch]
12examples/http_parser.[ch]
attoparsec.cabal+4−4
@@ -108,7 +108,7 @@ test-suite tests
108
108
109benchmark benchmarks
109benchmark benchmarks
110 type: exitcode-stdio-1.0
110 type: exitcode-stdio-1.0
111− hs-source-dirs: benchmarks, .
111+ hs-source-dirs: benchmarks benchmarks/warp-3.0.1.1 .
112 ghc-options: -O2 -Wall -rtsopts
112 ghc-options: -O2 -Wall -rtsopts
113 main-is: Benchmarks.hs
113 main-is: Benchmarks.hs
114 other-modules:
114 other-modules:
@@ -118,7 +118,6 @@ benchmark benchmarks
118 Links
118 Links
119 Numbers
119 Numbers
120 Warp
120 Warp
121− Warp.ReadInt
122 ghc-options: -O2 -Wall
121 ghc-options: -O2 -Wall
123
122
124 if flag(developer)
123 if flag(developer)
@@ -128,17 +127,18 @@ benchmark benchmarks
128 array,
127 array,
129 base == 4.*,
128 base == 4.*,
130 bytestring >= 0.10.4.0,
129 bytestring >= 0.10.4.0,
130+ case-insensitive,
131 criterion >= 1.0,
131 criterion >= 1.0,
132 deepseq >= 1.1,
132 deepseq >= 1.1,
133 directory,
133 directory,
134 filepath,
134 filepath,
135 ghc-prim,
135 ghc-prim,
136+ http-types,
136 parsec >= 3.1.2,
137 parsec >= 3.1.2,
137 scientific,
138 scientific,
138 text >= 1.1.1.0,
139 text >= 1.1.1.0,
139 unordered-containers,
140 unordered-containers,
140− vector,
141+ vector
141− warp
142
142
143source-repository head
143source-repository head
144 type: git
144 type: git
benchmarks/HeadersByteString.hs+8−6
@@ -4,8 +4,9 @@ module HeadersByteString (headers) where
4
4
5import Common (pathTo, rechunkBS)
5import Common (pathTo, rechunkBS)
6import Control.Applicative
6import Control.Applicative
7−import Criterion.Main (bench, bgroup, nf)
7+import Criterion.Main (bench, bgroup, nf, nfIO)
8import Criterion.Types (Benchmark)
8import Criterion.Types (Benchmark)
9+import Network.Wai.Handler.Warp.RequestHeader (parseHeaderLines)
9import qualified Data.Attoparsec.ByteString.Char8 as B
10import qualified Data.Attoparsec.ByteString.Char8 as B
10import qualified Data.Attoparsec.ByteString.Lazy as BL
11import qualified Data.Attoparsec.ByteString.Lazy as BL
11import qualified Data.ByteString.Char8 as B
12import qualified Data.ByteString.Char8 as B
@@ -17,11 +18,11 @@ header = do
17
18
18bodyLine = B.takeTill (\c -> c == '\r' || c == '\n') <* B.endOfLine
19bodyLine = B.takeTill (\c -> c == '\r' || c == '\n') <* B.endOfLine
19
20
20−requestLine =
21+requestLine = do
21− (,,) <$>
22+ m <- (method <* B.skipSpace)
22− (method <* B.skipSpace) <*>
23− (B.takeTill B.isSpace <* B.skipSpace) <*>
23+ (p,q) <- B.break (=='?') <$> (B.takeTill B.isSpace <* B.skipSpace)
24− httpVersion
24+ v <- httpVersion
25+ return (m,p,q,v)
25 where method = "GET" <|> "POST"
26 where method = "GET" <|> "POST"
26
27
27httpVersion = "HTTP/" *> ((,) <$> (int <* B.char '.') <*> int)
28httpVersion = "HTTP/" *> ((,) <$> (int <* B.char '.') <*> int)
@@ -47,6 +48,7 @@ headers = do
47 return $ bgroup "headers" [
48 return $ bgroup "headers" [
48 bgroup "B" [
49 bgroup "B" [
49 bench "request" $ nf (B.parseOnly request) req
50 bench "request" $ nf (B.parseOnly request) req
51+ , bench "warp" $ nfIO (parseHeaderLines [req])
50 , bench "response" $ nf (B.parseOnly response) resp
52 , bench "response" $ nf (B.parseOnly response) resp
51 ]
53 ]
52 , bgroup "BL" [
54 , bgroup "BL" [
benchmarks/Warp.hs+1−1
@@ -5,7 +5,7 @@ module Warp (benchmarks) where
5import Criterion.Main (bench, bgroup, nf)
5import Criterion.Main (bench, bgroup, nf)
6import Criterion.Types (Benchmark)
6import Criterion.Types (Benchmark)
7import Data.ByteString (ByteString)
7import Data.ByteString (ByteString)
8−import Warp.ReadInt (readInt)
8+import Network.Wai.Handler.Warp.ReadInt (readInt)
9import qualified Data.Attoparsec.ByteString.Char8 as B
9import qualified Data.Attoparsec.ByteString.Char8 as B
10
10
11benchmarks :: Benchmark
11benchmarks :: Benchmark
benchmarks/attoparsec-benchmarks.cabal+3−4
@@ -14,9 +14,9 @@ executable attoparsec-benchmarks
14 HeadersText
14 HeadersText
15 Links
15 Links
16 Numbers
16 Numbers
17+ Network.Wai.Handler.Warp.ReadInt
17 Warp
18 Warp
18− Warp.ReadInt
19− hs-source-dirs: .. .
19+ hs-source-dirs: .. . warp-3.0.1.1
20 ghc-options: -O2 -Wall -rtsopts
20 ghc-options: -O2 -Wall -rtsopts
21 build-depends:
21 build-depends:
22 array,
22 array,
@@ -31,5 +31,4 @@ executable attoparsec-benchmarks
31 scientific >= 0.3.1,
31 scientific >= 0.3.1,
32 text >= 1.1.1.0,
32 text >= 1.1.1.0,
33 unordered-containers,
33 unordered-containers,
34− vector,
34+ vector
35− warp
benchmarks/warp-3.0.1.1/LICENSEnew file+20
@@ -0,0 +1,20 @@
1+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
2+
3+Permission is hereby granted, free of charge, to any person obtaining
4+a copy of this software and associated documentation files (the
5+"Software"), to deal in the Software without restriction, including
6+without limitation the rights to use, copy, modify, merge, publish,
7+distribute, sublicense, and/or sell copies of the Software, and to
8+permit persons to whom the Software is furnished to do so, subject to
9+the following conditions:
10+
11+The above copyright notice and this permission notice shall be
12+included in all copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
17+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
18+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
19+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
20+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
benchmarks/Warp/ReadInt.hs → benchmarks/warp-3.0.1.1/Network/Wai/Handler/Warp/ReadInt.hsrenamed+1−1
@@ -5,7 +5,7 @@
5-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>
5-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>
6-- License : BSD3
6-- License : BSD3
7
7
8−module Warp.ReadInt (
8+module Network.Wai.Handler.Warp.ReadInt (
9 readInt
9 readInt
10 , readInt64
10 , readInt64
11 ) where
11 ) where
benchmarks/warp-3.0.1.1/Network/Wai/Handler/Warp/RequestHeader.hsnew file+172
@@ -0,0 +1,172 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE BangPatterns #-}
4+
5+module Network.Wai.Handler.Warp.RequestHeader (
6+ parseHeaderLines
7+ , parseByteRanges
8+ ) where
9+
10+import Control.Exception (Exception, throwIO)
11+import Control.Monad (when)
12+import Data.Typeable (Typeable)
13+import qualified Data.ByteString as S
14+import qualified Data.ByteString.Char8 as B (unpack, readInteger)
15+import Data.ByteString.Internal (ByteString(..), memchr)
16+import qualified Data.CaseInsensitive as CI
17+import Data.Word (Word8)
18+import Foreign.ForeignPtr (withForeignPtr)
19+import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)
20+import Foreign.Storable (peek)
21+import qualified Network.HTTP.Types as H
22+-- import Network.Wai.Handler.Warp.Types
23+import qualified Network.HTTP.Types.Header as HH
24+-- $setup
25+-- >>> :set -XOverloadedStrings
26+
27+data InvalidRequest = NotEnoughLines [String]
28+ | BadFirstLine String
29+ | NonHttp
30+ | IncompleteHeaders
31+ | ConnectionClosedByPeer
32+ | OverLargeHeader
33+ deriving (Eq, Typeable, Show)
34+
35+instance Exception InvalidRequest
36+
37+----------------------------------------------------------------
38+
39+parseHeaderLines :: [ByteString]
40+ -> IO (H.Method
41+ ,ByteString -- Path
42+ ,ByteString -- Path, parsed
43+ ,ByteString -- Query
44+ ,H.HttpVersion
45+ ,H.RequestHeaders
46+ )
47+parseHeaderLines [] = throwIO $ NotEnoughLines []
48+parseHeaderLines (firstLine:otherLines) = do
49+ (method, path', query, httpversion) <- parseRequestLine firstLine
50+ let path = H.extractPath path'
51+ hdr = map parseHeader otherLines
52+ return (method, path', path, query, httpversion, hdr)
53+
54+----------------------------------------------------------------
55+
56+-- |
57+--
58+-- >>> parseRequestLine "GET / HTTP/1.1"
59+-- ("GET","/","",HTTP/1.1)
60+-- >>> parseRequestLine "POST /cgi/search.cgi?key=foo HTTP/1.0"
61+-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)
62+-- >>> parseRequestLine "GET "
63+-- *** Exception: Warp: Invalid first line of request: "GET "
64+-- >>> parseRequestLine "GET /NotHTTP UNKNOWN/1.1"
65+-- *** Exception: Warp: Request line specified a non-HTTP request
66+parseRequestLine :: ByteString
67+ -> IO (H.Method
68+ ,ByteString -- Path
69+ ,ByteString -- Query
70+ ,H.HttpVersion)
71+parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do
72+ when (len < 14) $ throwIO baderr
73+ let methodptr = ptr `plusPtr` off
74+ limptr = methodptr `plusPtr` len
75+ lim0 = fromIntegral len
76+
77+ pathptr0 <- memchr methodptr 32 lim0 -- ' '
78+ when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $
79+ throwIO baderr
80+ let pathptr = pathptr0 `plusPtr` 1
81+ lim1 = fromIntegral (limptr `minusPtr` pathptr0)
82+
83+ httpptr0 <- memchr pathptr 32 lim1 -- ' '
84+ when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $
85+ throwIO baderr
86+ let httpptr = httpptr0 `plusPtr` 1
87+ lim2 = fromIntegral (httpptr0 `minusPtr` pathptr)
88+
89+ checkHTTP httpptr
90+ !hv <- httpVersion httpptr
91+ queryptr <- memchr pathptr 63 lim2 -- '?'
92+
93+ let !method = bs ptr methodptr pathptr0
94+ !path
95+ | queryptr == nullPtr = bs ptr pathptr httpptr0
96+ | otherwise = bs ptr pathptr queryptr
97+ !query
98+ | queryptr == nullPtr = S.empty
99+ | otherwise = bs ptr queryptr httpptr0
100+
101+ return (method,path,query,hv)
102+ where
103+ baderr = BadFirstLine $ B.unpack requestLine
104+ check :: Ptr Word8 -> Int -> Word8 -> IO ()
105+ check p n w = do
106+ w0 <- peek $ p `plusPtr` n
107+ when (w0 /= w) $ throwIO NonHttp
108+ checkHTTP httpptr = do
109+ check httpptr 0 72 -- 'H'
110+ check httpptr 1 84 -- 'T'
111+ check httpptr 2 84 -- 'T'
112+ check httpptr 3 80 -- 'P'
113+ check httpptr 4 47 -- '/'
114+ check httpptr 6 46 -- '.'
115+ httpVersion httpptr = do
116+ major <- peek $ httpptr `plusPtr` 5
117+ minor <- peek $ httpptr `plusPtr` 7
118+ return $ if major == (49 :: Word8) && minor == (49 :: Word8) then
119+ H.http11
120+ else
121+ H.http10
122+ bs ptr p0 p1 = PS fptr o l
123+ where
124+ o = p0 `minusPtr` ptr
125+ l = p1 `minusPtr` p0
126+
127+----------------------------------------------------------------
128+
129+-- |
130+--
131+-- >>> parseHeader "Content-Length:47"
132+-- ("Content-Length","47")
133+-- >>> parseHeader "Accept-Ranges: bytes"
134+-- ("Accept-Ranges","bytes")
135+-- >>> parseHeader "Host: example.com:8080"
136+-- ("Host","example.com:8080")
137+-- >>> parseHeader "NoSemiColon"
138+-- ("NoSemiColon","")
139+
140+parseHeader :: ByteString -> H.Header
141+parseHeader s =
142+ let (k, rest) = S.breakByte 58 s -- ':'
143+ rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest
144+ in (CI.mk k, rest')
145+
146+parseByteRanges :: S.ByteString -> Maybe HH.ByteRanges
147+parseByteRanges bs1 = do
148+ bs2 <- stripPrefix "bytes=" bs1
149+ (r, bs3) <- range bs2
150+ ranges (r:) bs3
151+ where
152+ range bs2 =
153+ case stripPrefix "-" bs2 of
154+ Just bs3 -> do
155+ (i, bs4) <- B.readInteger bs3
156+ Just (HH.ByteRangeSuffix i, bs4)
157+ Nothing -> do
158+ (i, bs3) <- B.readInteger bs2
159+ bs4 <- stripPrefix "-" bs3
160+ case B.readInteger bs4 of
161+ Nothing -> Just (HH.ByteRangeFrom i, bs4)
162+ Just (j, bs5) -> Just (HH.ByteRangeFromTo i j, bs5)
163+ ranges front bs3 =
164+ case stripPrefix "," bs3 of
165+ Nothing -> Just (front [])
166+ Just bs4 -> do
167+ (r, bs5) <- range bs4
168+ ranges (front . (r:)) bs5
169+
170+ stripPrefix x y
171+ | x `S.isPrefixOf` y = Just (S.drop (S.length x) y)
172+ | otherwise = Nothing