This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-server".
The branch, master has been updated
via ef0c08e562f6522a6e5e0186ab66a4980efa3f12 (commit)
from 18b1037d8d450a59d5969ef40b2af23f06141f82 (commit)
Summary of changes:
src/Snap/Internal/Http/Parser.hs | 190 ++++++++++++--------
.../Snap/Internal/Http/Parser/Benchmark.hs | 57 ++-----
test/snap-server-testsuite.cabal | 9 +
3 files changed, 138 insertions(+), 118 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit ef0c08e562f6522a6e5e0186ab66a4980efa3f12
Author: Gregory Collins <[email protected]>
Date: Fri Feb 11 10:46:59 2011 -0500
Replace attoparsec parser with a hand-rolled one
diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs
index 296a903..e07e08a 100644
--- a/src/Snap/Internal/Http/Parser.hs
+++ b/src/Snap/Internal/Http/Parser.hs
@@ -16,16 +16,16 @@ module Snap.Internal.Http.Parser
------------------------------------------------------------------------------
-import Control.Applicative
import Control.Arrow (second)
import Control.Monad (liftM)
import Control.Monad.Trans
import Data.Attoparsec hiding (many, Result(..))
import Data.Attoparsec.Enumerator
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as S
-import Data.ByteString.Internal (c2w, w2c)
-import qualified Data.ByteString.Lazy as L
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as S
+import qualified Data.ByteString.Unsafe as S
+import Data.ByteString.Internal (w2c)
+import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Nums.Careless.Hex as Cvt
import Data.Char
import Data.List (foldl')
@@ -38,7 +38,7 @@ import Prelude hiding (head, take, takeWhile)
import Snap.Internal.Http.Types
import Snap.Internal.Debug
import Snap.Internal.Iteratee.Debug
-import Snap.Internal.Parsing
+import Snap.Internal.Parsing hiding (pHeaders)
import Snap.Iteratee hiding (map, take)
@@ -66,7 +66,109 @@ instance Show IRequest where
------------------------------------------------------------------------------
parseRequest :: (Monad m) => Iteratee ByteString m (Maybe IRequest)
-parseRequest = iterParser pRequest
+parseRequest = do
+ eof <- isEOF
+ if eof
+ then return Nothing
+ else do
+ line <- pLine
+ if S.null line
+ then parseRequest
+ else do
+ let (!mStr,!s) = bSp line
+ let (!uri,!vStr) = bSp s
+
+ !method <- methodFromString mStr
+
+ let ver@(!_,!_) = pVer vStr
+
+ hdrs <- pHeaders
+ return $ Just $ IRequest method uri ver hdrs
+
+ where
+ pVer s = if S.isPrefixOf "HTTP/" s
+ then let (a,b) = bDot $ S.drop 5 s
+ in (read $ S.unpack a, read $ S.unpack b)
+ else (1,0)
+
+ isSp = (== ' ')
+ bSp = splitWith isSp
+ isDot = (== '.')
+ bDot = splitWith isDot
+
+
+------------------------------------------------------------------------------
+pLine :: (Monad m) => Iteratee ByteString m ByteString
+pLine = continue $ k S.empty
+ where
+ k _ EOF = error "FIXME: parse error: expected line ending in crlf"
+ k !pre (Chunks xs) =
+ if S.null b
+ then continue $ k a
+ else yield a (Chunks [S.drop 2 b])
+ where
+ (!a,!b) = S.breakSubstring "\r\n" s
+ !s = S.append pre s'
+ !s = S.concat xs
+
+
+------------------------------------------------------------------------------
+splitWith :: (Char -> Bool) -> ByteString -> (ByteString,ByteString)
+splitWith !f !s = let (!a,!b) = S.break f s
+ !b' = S.dropWhile f b
+ in (a, b')
+
+
+------------------------------------------------------------------------------
+pHeaders :: Monad m => Iteratee ByteString m [(ByteString,ByteString)]
+pHeaders = do
+ f <- go id
+ return $! f []
+ where
+ go !dlistSoFar = {-# SCC "pHeaders/go" #-} do
+ line <- pLine
+ if S.null line
+ then return dlistSoFar
+ else do
+ let (!k,!v) = pOne line
+ vf <- pCont id
+ let vs = vf []
+ let !v' = S.concat (v:vs)
+ go (dlistSoFar . ((k,v'):))
+
+ where
+ pOne s = let (k,v) = splitWith (== ':') s
+ in (trim k, trim v)
+
+ isCont c = c == ' ' || c == '\t'
+
+ pCont !dlist = do
+ mbS <- peek
+ maybe (return dlist)
+ (\s -> if S.null s
+ then head >> pCont dlist
+ else if isCont $ w2c $ S.unsafeHead s
+ then procCont dlist
+ else return dlist)
+ mbS
+
+ procCont !dlist = do
+ line <- pLine
+ let !t = trim line
+ pCont (dlist . (" ":) . (t:))
+
+
+------------------------------------------------------------------------------
+methodFromString :: (Monad m) => ByteString -> Iteratee ByteString m Method
+methodFromString "GET" = return GET
+methodFromString "POST" = return POST
+methodFromString "HEAD" = return HEAD
+methodFromString "PUT" = return PUT
+methodFromString "DELETE" = return DELETE
+methodFromString "TRACE" = return TRACE
+methodFromString "OPTIONS" = return OPTIONS
+methodFromString "CONNECT" = return CONNECT
+methodFromString s = fail $ "Bad method '" ++ S.unpack s ++ "'"
------------------------------------------------------------------------------
@@ -83,28 +185,13 @@ chunkParserToEnumeratee :: (MonadIO m) =>
Iteratee ByteString m (Maybe ByteString)
-> Enumeratee ByteString ByteString m a
chunkParserToEnumeratee getChunk client = do
- debug $ "chunkParserToEnumeratee: getting chunk"
mbB <- getChunk
- debug $ "chunkParserToEnumeratee: getChunk was " ++ show mbB
- mbX <- peek
- debug $ "chunkParserToEnumeratee: .. and peek is " ++ show mbX
-
-
maybe finishIt sendBS mbB
where
- whatWasReturn (Continue _) = "continue"
- whatWasReturn (Yield _ z) = "yield, with remainder " ++ show z
- whatWasReturn (Error e) = "error, with " ++ show e
-
sendBS s = do
- step' <- lift $ runIteratee $ enumBS s client
- debug $ "chunkParserToEnumeratee: after sending "
- ++ show s ++ ", return was "
- ++ whatWasReturn step'
- mbX <- peek
- debug $ "chunkParserToEnumeratee: .. and peek is " ++ show mbX
- chunkParserToEnumeratee getChunk step'
+ step <- lift $ runIteratee $ enumBS s client
+ chunkParserToEnumeratee getChunk step
finishIt = lift $ runIteratee $ enumEOF client
@@ -113,57 +200,6 @@ chunkParserToEnumeratee getChunk client = do
-- parse functions
------------------------------------------------------------------------------
--- theft alert: many of these routines adapted from Johan Tibell's hyena
--- package
-
-
-------------------------------------------------------------------------------
--- | Parser for the internal request data type.
-pRequest :: Parser (Maybe IRequest)
-pRequest = (Just <$> pRequest') <|>
- (option "" crlf *> endOfInput *> pure Nothing)
-
-
-------------------------------------------------------------------------------
-pRequest' :: Parser IRequest
-pRequest' = IRequest
- <$> (option "" crlf *> pMethod) <* sp
- <*> pUri <* sp
- <*> pVersion <* crlf
- <*> pHeaders <* crlf
-
- -- note: the optional crlf is at the beginning because some older browsers
- -- send an extra crlf after a POST body
-
-
-------------------------------------------------------------------------------
--- | Parser for the request method.
-pMethod :: Parser Method
-pMethod = (OPTIONS <$ string "OPTIONS")
- <|> (GET <$ string "GET")
- <|> (HEAD <$ string "HEAD")
- <|> word8 (c2w 'P') *> ((POST <$ string "OST") <|>
- (PUT <$ string "UT"))
- <|> (DELETE <$ string "DELETE")
- <|> (TRACE <$ string "TRACE")
- <|> (CONNECT <$ string "CONNECT")
-
-
-------------------------------------------------------------------------------
--- | Parser for the request URI.
-pUri :: Parser ByteString
-pUri = takeWhile (not . isSpace . w2c)
-
-
-------------------------------------------------------------------------------
--- | Parser for the request's HTTP protocol version.
-pVersion :: Parser (Int, Int)
-pVersion = string "HTTP/" *>
- liftA2 (,) (digit' <* word8 (c2w '.')) digit'
- where
- digit' = fmap digitToInt digit
-
-
------------------------------------------------------------------------------
pGetTransferChunk :: Parser (Maybe ByteString)
pGetTransferChunk = do
@@ -215,10 +251,10 @@ parseUrlEncoded s = foldl' (\m (k,v) -> Map.insertWith'
(++) k [v] m)
Map.empty
decoded
where
- breakApart = (second (S.drop 1)) . S.break (== (c2w '='))
+ breakApart = (second (S.drop 1)) . S.break (== '=')
parts :: [(ByteString,ByteString)]
- parts = map breakApart $ S.split (c2w '&') s
+ parts = map breakApart $ S.split '&' s
urldecode = parseToCompletion pUrlEscaped
diff --git a/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs
b/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs
index a5b1fbf..260efe2 100644
--- a/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs
+++ b/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs
@@ -7,49 +7,24 @@ module Snap.Internal.Http.Parser.Benchmark
( benchmarks )
where
-import qualified Control.Exception as E
-import "monads-fd" Control.Monad.Identity
-import Criterion.Main hiding (run)
-import Data.Attoparsec hiding (Result(..))
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Lazy.Char8 as L
-import Snap.Internal.Http.Parser
-import Snap.Internal.Http.Parser.Data
-import qualified Snap.Iteratee as SI
-import Snap.Iteratee hiding (take)
-
-parseGet :: IO ()
-parseGet = do
- step <- runIteratee parseRequest
- run_ $ enumBS parseGetData step
- return ()
-
-
--- FIXME: writeChunkedTransferEncoding went away
-{-
-parseChunked :: IO ()
-parseChunked = do
- sstep <- runIteratee stream2stream
- c <- toChunked parseChunkedData
- cstep <- runIteratee $ readChunkedTransferEncoding sstep
- let i = enumBS c cstep
- f <- run_ i
+import qualified Control.Exception as E
+import Control.Monad.Identity
+import Criterion.Main hiding (run)
+import Data.Attoparsec hiding (Result(..))
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy.Char8 as L
+import Snap.Internal.Http.Parser
+import Snap.Internal.Http.Parser.Data
+import qualified Snap.Iteratee as SI
+import Snap.Iteratee hiding (take)
+
+parseGet :: S.ByteString -> Identity ()
+parseGet s = do
+ !_ <- run_ $ enumBS s $$ parseRequest
return ()
--- utils
-toChunked :: L.ByteString -> IO ByteString
-toChunked lbs = do
- sstep <- runIteratee stream2stream
- cstep <- runIteratee $ joinI $ writeChunkedTransferEncoding sstep
- run_ $ enumLBS lbs cstep
--}
benchmarks = bgroup "parser"
- [ bench "firefoxget" $ whnfIO parseGet
--- , bench "readChunkedTransferEncoding" $ whnfIO parseChunked
+ [ bench "firefoxget" $ whnf (runIdentity . parseGet) parseGetData
]
-
-
-stream2stream :: (Monad m) => Iteratee ByteString m ByteString
-stream2stream = liftM S.concat consume
diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal
index 5982710..47aa24b 100644
--- a/test/snap-server-testsuite.cabal
+++ b/test/snap-server-testsuite.cabal
@@ -73,6 +73,7 @@ Executable testsuite
if flag(portable) || os(windows)
cpp-options: -DPORTABLE
+ ghc-prof-options: -prof -auto-all
ghc-options: -O2 -Wall -fhpc -fwarn-tabs
-funbox-strict-fields -threaded
-fno-warn-unused-do-bind
@@ -213,11 +214,19 @@ Executable testserver
ghc-options: -O2 -Wall -fwarn-tabs
-funbox-strict-fields -threaded
-fno-warn-unused-do-bind
+ ghc-prof-options: -prof -auto-all
Executable benchmark
hs-source-dirs: benchmark common ../src
main-is: Benchmark.hs
+
+ ghc-options: -O2 -Wall -fwarn-tabs
+ -funbox-strict-fields -threaded
+ -fno-warn-unused-do-bind
+
+ ghc-prof-options: -prof -auto-all
+
build-depends:
base >= 4 && < 5,
network == 2.3.*,
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
