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, enumerator-work has been updated
via d6b4bfa4c07516e72fd4d62d9592cc1c1c1b5fef (commit)
from 88c1bf257d1c35c29ba087263ffdc73535620635 (commit)
Summary of changes:
snap-server.cabal | 2 +-
src/Snap/Internal/Http/Parser.hs | 28 ++-
src/Snap/Internal/Http/Server.hs | 32 ++-
src/Snap/Internal/Http/Server/LibevBackend.hs | 38 ++--
.../Snap/Internal/Http/Parser/Benchmark.hs | 45 +++--
test/snap-server-testsuite.cabal | 6 +-
test/suite/Snap/Internal/Http/Parser/Tests.hs | 79 ++++---
test/suite/Snap/Internal/Http/Server/Tests.hs | 229 ++++++++++----------
8 files changed, 255 insertions(+), 204 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 d6b4bfa4c07516e72fd4d62d9592cc1c1c1b5fef
Author: Gregory Collins <[email protected]>
Date: Mon Nov 22 21:23:35 2010 +0100
With libev backend, everything now passes except transformRequestBody
diff --git a/snap-server.cabal b/snap-server.cabal
index 1ef8480..636e70b 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -107,7 +107,7 @@ Library
build-depends:
array >= 0.2 && <0.4,
attoparsec >= 0.8.1 && < 0.9,
- attoparsec-enumerator == 0.2.*,
+ attoparsec-enumerator >= 0.2.0.1 && < 0.3,
base >= 4 && < 5,
binary >=0.5 && <0.6,
bytestring,
diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs
index 4902d65..b032e84 100644
--- a/src/Snap/Internal/Http/Parser.hs
+++ b/src/Snap/Internal/Http/Parser.hs
@@ -44,6 +44,8 @@ import Prelude hiding (head, take, takeWhile)
import qualified Prelude
------------------------------------------------------------------------------
import Snap.Internal.Http.Types
+import Snap.Internal.Debug
+import Snap.Internal.Iteratee.Debug
import Snap.Iteratee hiding (map, take)
@@ -75,10 +77,12 @@ parseRequest = iterParser pRequest
------------------------------------------------------------------------------
-readChunkedTransferEncoding :: (Monad m) =>
+readChunkedTransferEncoding :: (MonadIO m) =>
Enumeratee ByteString ByteString m a
readChunkedTransferEncoding =
- chunkParserToEnumeratee (iterParser pGetTransferChunk)
+ chunkParserToEnumeratee $
+ iterateeDebugWrapper "pGetTransferChunk" $
+ iterParser pGetTransferChunk
------------------------------------------------------------------------------
@@ -172,16 +176,31 @@ writeChunkedTransferEncoding = checkDone start
------------------------------------------------------------------------------
-chunkParserToEnumeratee :: (Monad m) =>
+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'
finishIt = lift $ runIteratee $ enumEOF client
@@ -229,7 +248,8 @@ pSpaces = takeWhile (isSpace . w2c)
------------------------------------------------------------------------------
-- | Parser for the internal request data type.
pRequest :: Parser (Maybe IRequest)
-pRequest = (Just <$> pRequest') <|> (endOfInput *> pure Nothing)
+pRequest = (Just <$> pRequest') <|>
+ (option "" crlf *> endOfInput *> pure Nothing)
------------------------------------------------------------------------------
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index e09d3b7..6318b5d 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -305,7 +305,11 @@ runHTTP lh lip lp rip rp alog elog
handler
let iter = iterateeDebugWrapper "httpSession iteratee" iter1
+ debug "runHTTP/go: prepping iteratee for start"
+
step <- liftIO $ runIteratee iter
+
+ debug "runHTTP/go: running..."
run_ $ readEnd step
debug "runHTTP/go: finished"
@@ -349,6 +353,7 @@ httpSession writeEnd' ibuf onSendFile tickle handler = do
liftIO $ debug "Server.httpSession: entered"
mreq <- receiveRequest
+ liftIO $ debug "Server.httpSession: receiveRequest finished"
-- successfully got a request, so restart timer
liftIO tickle
@@ -439,7 +444,10 @@ checkExpect100Continue req writeEnd = do
------------------------------------------------------------------------------
receiveRequest :: ServerMonad (Maybe Request)
receiveRequest = do
- mreq <- {-# SCC "receiveRequest/parseRequest" #-} lift parseRequest
+ debug "receiveRequest: entered"
+ mreq <- {-# SCC "receiveRequest/parseRequest" #-} lift $
+ iterateeDebugWrapper "parseRequest" parseRequest
+ debug "receiveRequest: parseRequest returned"
case mreq of
(Just ireq) -> do
@@ -463,8 +471,7 @@ receiveRequest = do
-- if no content-length and no chunked encoding, enumerate the entire
-- socket and close afterwards
setEnumerator :: Request -> ServerMonad ()
- setEnumerator req =
- {-# SCC "receiveRequest/setEnumerator" #-}
+ setEnumerator req = {-# SCC "receiveRequest/setEnumerator" #-} do
if isChunked
then do
liftIO $ debug $ "receiveRequest/setEnumerator: " ++
@@ -528,7 +535,9 @@ receiveRequest = do
senum <- liftIO $ readIORef $ rqBody req
let (SomeEnumerator enum) = senum
consumeStep <- liftIO $ runIteratee consume
- step <- lift $ takeNoMoreThan maximumPOSTBodySize consumeStep
+ step <- liftIO $
+ runIteratee $
+ joinI $ takeNoMoreThan maximumPOSTBodySize consumeStep
body <- liftM S.concat $ lift $ enum step
let newParams = parseUrlEncoded body
@@ -635,6 +644,8 @@ sendResponse req rsp' writeEnd onSendFile = do
(SendFile f (Just (st,_))) ->
lift $ whenSendFile headerString rsp f st
+ debug "sendResponse: response sent"
+
return $! (bs,x)
where
@@ -652,13 +663,15 @@ sendResponse req rsp' writeEnd onSendFile = do
-- socket.
let enum = if rspTransformingRqBody rsp
then enumBS hs >==> e
- else enumBS hs >==> e >==> enumEOF
+ else enumBS hs >==> e >==> (joinI . I.take 0)
let hl = fromIntegral $ S.length hs
debug $ "sendResponse: whenEnum: enumerating bytes"
- outstep <- lift $ runIteratee $ countBytes $ returnI writeEnd
+ outstep <- lift $ runIteratee $
+ iterateeDebugWrapper "countBytes writeEnd" $
+ countBytes $ returnI writeEnd
(x,bs) <- enum outstep
debug $ "sendResponse: whenEnum: " ++ Prelude.show bs ++ " bytes
enumerated"
@@ -712,7 +725,10 @@ sendResponse req rsp' writeEnd onSendFile = do
let r' = setHeader "Transfer-Encoding" "chunked" r
let origE = rspBodyToEnum $ rspBody r
- let e i = writeChunkedTransferEncoding i >>= origE
+ let e i = do
+ step <- lift $ runIteratee $ joinI $
+ writeChunkedTransferEncoding i
+ origE step
return $ r' { rspBody = Enum e }
@@ -740,7 +756,7 @@ sendResponse req rsp' writeEnd onSendFile = do
i :: forall z . Enumerator ByteString IO z
-> Enumerator ByteString IO z
i enum step = do
- step' <- takeExactly cl step
+ step' <- lift $ runIteratee $ joinI $ takeExactly cl step
enum step'
diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs
b/src/Snap/Internal/Http/Server/LibevBackend.hs
index eefc93a..04e9838 100644
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -752,27 +752,31 @@ getWriteEnd = writeOut
enumerate :: (MonadIO m) => Connection -> Enumerator ByteString m a
enumerate conn = loop
where
+ dbg s = debug $ "Backend.enumerate(" ++ show (_socketFd conn) ++ "): " ++ s
+
recvIt :: (MonadIO m) => Iteratee ByteString m ByteString
recvIt = liftIO $ recvData conn bLOCKSIZE
- loop f = do
+ loop (Continue k) = do
s <- recvIt
- sendOne f s
-
- sendOne :: (MonadIO m) =>
- Step ByteString m a
- -> ByteString
- -> Iteratee ByteString m a
- sendOne f s = do
- let iter = if S.null s
- then enumEOF f
- else enumBS s f
- f' <- lift $ runIteratee iter
-
- case f' of
- (Yield x st) -> yield x st
- r@(Continue _) -> loop r
- (Error e) -> throwError e
+ sendOne k s
+ loop x = returnI x
+
+ sendOne k s | S.null s = do
+ dbg "sending EOF to continuation"
+ enumEOF $ Continue k
+
+ | otherwise = do
+ dbg $ "sending " ++ show s ++ " to continuation"
+ step <- lift $ runIteratee $ k $ Chunks [s]
+ case step of
+ (Yield x st) -> do
+ dbg $ "got yield, remainder is " ++ show st
+ yield x st
+ r@(Continue _) -> do
+ dbg $ "got continue"
+ loop r
+ (Error e) -> throwError e
writeOut :: (MonadIO m) => Connection -> Iteratee ByteString m ()
diff --git a/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs
b/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs
index 76b9f54..88228f5 100644
--- a/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs
+++ b/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs
@@ -3,38 +3,49 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PackageImports #-}
-module Snap.Internal.Http.Parser.Benchmark
+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 Snap.Internal.Http.Parser
+import Data.Attoparsec hiding (Result(..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
-import qualified Snap.Iteratee as SI
-import qualified Control.Exception as E
-import Data.Attoparsec hiding (Result(..))
+import qualified Data.ByteString.Lazy.Char8 as L
+import Snap.Internal.Http.Parser
import Snap.Internal.Http.Parser.Data
-import "monads-fd" Control.Monad.Identity
-import Data.Iteratee
-import Data.Iteratee.WrappedByteString
-import Snap.Iteratee hiding (take, foldl', filter)
-import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Snap.Iteratee as SI
+import Snap.Iteratee hiding (take)
parseGet :: IO ()
-parseGet = SI.enumBS parseGetData parseRequest >>= SI.run >> return ()
+parseGet = do
+ step <- runIteratee parseRequest
+ run_ $ enumBS parseGetData step
+ return ()
+
parseChunked :: IO ()
parseChunked = do
- c <- toChunked parseChunkedData
- i <- SI.enumLBS c (readChunkedTransferEncoding stream2stream)
- f <- SI.run i
- return ()
+ sstep <- runIteratee stream2stream
+ c <- toChunked parseChunkedData
+ cstep <- runIteratee $ readChunkedTransferEncoding sstep
+ let i = enumBS c cstep
+ f <- run_ i
+ return ()
-- utils
-toChunked lbs = writeChunkedTransferEncoding stream2stream >>=
- enumLBS lbs >>= run >>= return . fromWrap
+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 ]
+
+
+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 456fd2b..b463cae 100644
--- a/test/snap-server-testsuite.cabal
+++ b/test/snap-server-testsuite.cabal
@@ -20,7 +20,7 @@ Executable testsuite
QuickCheck >= 2,
array >= 0.3 && <0.4,
attoparsec >= 0.8.1 && < 0.9,
- attoparsec-enumerator == 0.2.*,
+ attoparsec-enumerator >= 0.2.0.1 && < 0.3,
base >= 4 && < 5,
binary >= 0.5 && < 0.6,
bytestring,
@@ -80,7 +80,7 @@ Executable pongserver
QuickCheck >= 2,
array >= 0.3 && <0.4,
attoparsec >= 0.8.1 && < 0.9,
- attoparsec-enumerator == 0.2.*,
+ attoparsec-enumerator >= 0.2.0.1 && < 0.3,
base >= 4 && < 5,
bytestring,
bytestring-nums >= 0.3.1 && < 0.4,
@@ -158,7 +158,7 @@ Executable testserver
QuickCheck >= 2,
array >= 0.3 && <0.4,
attoparsec >= 0.8.1 && < 0.9,
- attoparsec-enumerator == 0.2.*,
+ attoparsec-enumerator >= 0.2.0.1 && < 0.3,
base >= 4 && < 5,
binary >= 0.5 && < 0.6,
bytestring,
diff --git a/test/suite/Snap/Internal/Http/Parser/Tests.hs
b/test/suite/Snap/Internal/Http/Parser/Tests.hs
index ae981d6..ecf7a84 100644
--- a/test/suite/Snap/Internal/Http/Parser/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Parser/Tests.hs
@@ -21,7 +21,7 @@ import Data.List
import qualified Data.Map as Map
import Data.Maybe (isNothing)
import Data.Monoid
-import Test.Framework
+import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.QuickCheck
@@ -32,6 +32,8 @@ import Text.Printf
import Snap.Internal.Http.Parser
import Snap.Internal.Http.Types
+import Snap.Internal.Debug
+import Snap.Internal.Iteratee.Debug
import Snap.Iteratee hiding (map, sequence)
import qualified Snap.Iteratee as I
import Snap.Test.Common()
@@ -55,14 +57,14 @@ emptyParser :: Parser ByteString
emptyParser = option "foo" $ string "bar"
testShow :: Test
-testShow = testCase "show" $ do
+testShow = testCase "parser/show" $ do
let i = IRequest GET "/" (1,1) []
let !b = show i `using` rdeepseq
return $ b `seq` ()
testP2I :: Test
-testP2I = testCase "parserToIteratee" $ do
+testP2I = testCase "parser/iterParser" $ do
i <- liftM (enumBS "z") $ runIteratee (iterParser emptyParser)
l <- run_ i
@@ -76,13 +78,13 @@ forceErr e = f `seq` (return ())
testNull :: Test
-testNull = testCase "short parse" $ do
+testNull = testCase "parser/shortParse" $ do
f <- run_ (parseRequest)
assertBool "should be Nothing" $ isNothing f
testPartial :: Test
-testPartial = testCase "partial parse" $ do
+testPartial = testCase "parser/partial" $ do
i <- liftM (enumBS "GET / ") $ runIteratee parseRequest
f <- E.try $ run_ i
@@ -91,7 +93,7 @@ testPartial = testCase "partial parse" $ do
testParseError :: Test
-testParseError = testCase "parse error" $ do
+testParseError = testCase "parser/error" $ do
step <- runIteratee parseRequest
let i = enumBS "ZZZZZZZZZZ" step
f <- E.try $ run_ i
@@ -110,47 +112,54 @@ transferEncodingChunked = f . L.toChunks
f l = L.concat $ (map toChunk l ++ ["0\r\n\r\n"])
+
-- | ensure that running the 'readChunkedTransferEncoding' iteratee against
-- 'transferEncodingChunked' returns the original string
testChunked :: Test
-testChunked = testProperty "chunked transfer encoding" prop_chunked
+testChunked = testProperty "parser/chunkedTransferEncoding" $
+ monadicIO $ forAllM arbitrary prop_chunked
where
- prop_chunked :: L.ByteString -> Bool
- prop_chunked s = runIdentity (run_ iter) == s
+ prop_chunked s = do
+ QC.run $ debug "=============================="
+ QC.run $ debug $ "input is " ++ show s
+ QC.run $ debug $ "chunked is " ++ show chunked
+ QC.run $ debug "------------------------------"
+ sstep <- QC.run $ runIteratee $ stream2stream
+ step <- QC.run $ runIteratee $
+ joinI $ readChunkedTransferEncoding sstep
+
+ out <- QC.run $ run_ $ enum step
+
+ QC.assert $ s == out
+ QC.run $ debug "==============================\n"
+
where
- enum = enumLBS (transferEncodingChunked s)
+ chunked = (transferEncodingChunked s)
+ enum = enumLBS chunked
- iter :: Iteratee ByteString Identity L.ByteString
- iter = runIdentity $ do
- sstep <- runIteratee consume
- step <- runIteratee $ joinI $
- readChunkedTransferEncoding sstep
- return $ liftM L.fromChunks $ enum step
testBothChunked :: Test
-testBothChunked = testProperty "chunk . unchunk == id" $
+testBothChunked = testProperty "parser/invertChunked" $
monadicIO $ forAllM arbitrary prop
where
prop s = do
sstep <- QC.run $ runIteratee stream2stream
let it = joinI $ writeChunkedTransferEncoding sstep
- bs <- QC.run $ runIteratee it >>= run_ . enumBS s
+ bs <- QC.run $ runIteratee it >>= run_ . enumLBS s
- let enum = enumBS bs
+ let enum = enumLBS bs
-
-
x <- QC.run $
runIteratee (joinI $ readChunkedTransferEncoding sstep) >>=
- run_ . enum
+ run_ . enum
QC.assert $ s == x
testBothChunkedPipelined :: Test
-testBothChunkedPipelined = testProperty "testBothChunkedPipelined" $
+testBothChunkedPipelined = testProperty "parser/testBothChunkedPipelined" $
monadicIO prop
where
prop = do
@@ -183,7 +192,7 @@ testBothChunkedPipelined = testProperty
"testBothChunkedPipelined" $
let pcrlf = \s -> iterParser $ string "\r\n" >> return s
sstep <- QC.run $ runIteratee stream2stream
-
+
let iters = replicate ntimes $ joinI $
readChunkedTransferEncoding sstep
let godzilla = sequence $ map (>>= pcrlf) iters
@@ -191,12 +200,12 @@ testBothChunkedPipelined = testProperty
"testBothChunkedPipelined" $
x <- QC.run $ runIteratee godzilla >>= run_ . e2
QC.assert $
- (map (L.fromChunks . (:[])) x) == (replicate ntimes s')
+ x == (replicate ntimes s')
testBothChunkedEmpty :: Test
-testBothChunkedEmpty = testCase "testBothChunkedEmpty" prop
+testBothChunkedEmpty = testCase "parser/testBothChunkedEmpty" prop
where
prop = do
let s' = ""
@@ -207,13 +216,13 @@ testBothChunkedEmpty = testCase "testBothChunkedEmpty"
prop
let enum = foldl' (>==>) (enumBS "") (replicate ntimes e)
sstep <- runIteratee stream2stream
-
+
step <- runIteratee $
joinI $
writeChunkedTransferEncoding sstep
iter <- liftM returnI $ runIteratee $ joinI $ I.take n step
- let iters = replicate ntimes (iter :: Iteratee ByteString IO
ByteString)
+ let iters = replicate ntimes (iter :: Iteratee ByteString IO
L.ByteString)
let mothra = foldM (\s it -> it >>= \t -> return $ s `mappend` t)
mempty
iters
@@ -221,23 +230,23 @@ testBothChunkedEmpty = testCase "testBothChunkedEmpty"
prop
mothraStep <- runIteratee mothra
bs <- run_ $ enum mothraStep
- let e2 = enumBS bs
+ let e2 = enumLBS bs
let pcrlf = \s -> iterParser $ string "\r\n" >> return s
- let iters = replicate ntimes $ joinI $
+ let iters = replicate ntimes $ joinI $
readChunkedTransferEncoding sstep
godzilla <- runIteratee $ sequence $ map (>>= pcrlf) iters
x <- run_ $ e2 godzilla
assertBool "empty chunked transfer" $
- (map (L.fromChunks . (:[])) x) == (replicate ntimes s')
+ x == (replicate ntimes s')
testCookie :: Test
testCookie =
- testCase "parseCookie" $ do
+ testCase "parser/parseCookie" $ do
assertEqual "cookie parsing" (Just [cv]) cv2
where
@@ -253,7 +262,7 @@ testCookie =
testFormEncoded :: Test
-testFormEncoded = testCase "formEncoded" $ do
+testFormEncoded = testCase "parser/formEncoded" $ do
let bs = "foo1=bar1&foo2=bar2+baz2&foo3=foo%20bar"
let mp = parseUrlEncoded bs
@@ -272,5 +281,5 @@ copyingStream2Stream = go []
(\x -> let !z = S.copy x in go (z:l))
mbx
-stream2stream :: (Monad m) => Iteratee ByteString m ByteString
-stream2stream = liftM S.concat consume
+stream2stream :: (Monad m) => Iteratee ByteString m L.ByteString
+stream2stream = liftM L.fromChunks consume
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index 3e885b5..65429a1 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -22,13 +22,10 @@ import Data.ByteString.Internal (c2w)
import Data.Char
import Data.Int
import Data.IORef
-import Data.Iteratee.WrappedByteString
import qualified Data.Map as Map
import Data.Maybe (fromJust)
-import Data.Monoid
import Data.Time.Calendar
import Data.Time.Clock
-import Data.Word
import qualified Network.HTTP as HTTP
import qualified Network.Socket.ByteString as N
import Prelude hiding (take)
@@ -43,7 +40,8 @@ import qualified Snap.Http.Server as Svr
import Snap.Internal.Debug
import Snap.Internal.Http.Types
import Snap.Internal.Http.Server
-import Snap.Iteratee
+import qualified Snap.Iteratee as I
+import Snap.Iteratee hiding (map)
import Snap.Test.Common
import Snap.Types
@@ -139,38 +137,36 @@ testMethodParsing =
ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT ]
-copyingStream2stream :: Iteratee IO (WrappedByteString Word8)
-copyingStream2stream = IterateeG (step mempty)
- where
- step acc (Chunk (WrapBS ls))
- | S.null ls = return $ Cont (IterateeG (step acc)) Nothing
- | otherwise = do
- let !ls' = S.copy ls
- let !bs' = WrapBS $! ls'
- return $ Cont (IterateeG (step (acc `mappend` bs')))
- Nothing
-
- step acc str = return $ Done acc str
-
mkRequest :: ByteString -> IO Request
mkRequest s = do
- iter <- enumBS s $ liftM fromJust $ rsm receiveRequest
- run iter
+ step <- runIteratee $ liftM fromJust $ rsm receiveRequest
+ let iter = enumBS s step
+ run_ iter
+
+
+testReceiveRequest :: Iteratee ByteString IO (Request,L.ByteString)
+testReceiveRequest = do
+ r <- liftM fromJust $ rsm receiveRequest
+ se <- liftIO $ readIORef (rqBody r)
+ let (SomeEnumerator e) = se
+ it <- liftM e $ lift $ runIteratee copyingStream2Stream
+ b <- it
+ return (r,b)
+
+
+testReceiveRequestIter :: ByteString
+ -> IO (Iteratee ByteString IO (Request,L.ByteString))
+testReceiveRequestIter req =
+ liftM (enumBS req) $ runIteratee testReceiveRequest
testHttpRequest1 :: Test
testHttpRequest1 =
testCase "server/HttpRequest1" $ do
- iter <- enumBS sampleRequest $
- do
- r <- liftM fromJust $ rsm receiveRequest
- se <- liftIO $ readIORef (rqBody r)
- let (SomeEnumerator e) = se
- b <- liftM fromWrap $ joinIM $ e copyingStream2stream
- return (r,b)
+ iter <- testReceiveRequestIter sampleRequest
- (req,body) <- run iter
+ (req,body) <- run_ iter
assertEqual "not secure" False $ rqIsSecure req
@@ -205,19 +201,16 @@ testHttpRequest1 =
testMultiRequest :: Test
testMultiRequest =
testCase "server/MultiRequest" $ do
- iter <- (enumBS sampleRequest >. enumBS sampleRequest) $
- do
- r1 <- liftM fromJust $ rsm receiveRequest
- se1 <- liftIO $ readIORef (rqBody r1)
- let (SomeEnumerator e1) = se1
- b1 <- liftM fromWrap $ joinIM $ e1 copyingStream2stream
- r2 <- liftM fromJust $ rsm receiveRequest
- se2 <- liftIO $ readIORef (rqBody r2)
- let (SomeEnumerator e2) = se2
- b2 <- liftM fromWrap $ joinIM $ e2 copyingStream2stream
- return (r1,b1,r2,b2)
-
- (req1,body1,req2,body2) <- run iter
+ let clientIter = do
+ (r1,b1) <- testReceiveRequest
+ (r2,b2) <- testReceiveRequest
+
+ return (r1,b1,r2,b2)
+
+ iter <- liftM (enumBS sampleRequest >==> enumBS sampleRequest) $
+ runIteratee clientIter
+
+ (req1,body1,req2,body2) <- run_ iter
assertEqual "parse body 1" "0123456789" body1
assertEqual "parse body 2" "0123456789" body2
@@ -234,8 +227,9 @@ testMultiRequest =
testOneMethod :: Method -> IO ()
testOneMethod m = do
- iter <- enumLBS txt $ liftM fromJust $ rsm receiveRequest
- req <- run iter
+ step <- runIteratee $ liftM fromJust $ rsm receiveRequest
+ let iter = enumLBS txt step
+ req <- run_ iter
assertEqual "method" m $ rqMethod req
@@ -256,9 +250,10 @@ expectException m = do
testPartialParse :: Test
testPartialParse = testCase "server/short" $ do
- iter <- enumBS sampleShortRequest $ liftM fromJust $ rsm receiveRequest
+ step <- runIteratee $ liftM fromJust $ rsm receiveRequest
+ let iter = enumBS sampleShortRequest step
- expectException $ run iter
+ expectException $ run_ iter
methodTestText :: Method -> L.ByteString
@@ -278,19 +273,11 @@ sampleRequest2 =
, "0123\r\n"
, "0\r\n\r\n" ]
-
testHttpRequest2 :: Test
testHttpRequest2 =
testCase "server/HttpRequest2" $ do
- iter <- enumBS sampleRequest2 $
- do
- r <- liftM fromJust $ rsm receiveRequest
- se <- liftIO $ readIORef (rqBody r)
- let (SomeEnumerator e) = se
- b <- liftM fromWrap $ joinIM $ e copyingStream2stream
- return (r,b)
-
- (_,body) <- run iter
+ iter <- testReceiveRequestIter sampleRequest2
+ (_,body) <- run_ iter
assertEqual "parse body" "01234567890123" body
@@ -298,15 +285,8 @@ testHttpRequest2 =
testHttpRequest3 :: Test
testHttpRequest3 =
testCase "server/HttpRequest3" $ do
- iter <- enumBS sampleRequest3 $
- do
- r <- liftM fromJust $ rsm receiveRequest
- se <- liftIO $ readIORef (rqBody r)
- let (SomeEnumerator e) = se
- b <- liftM fromWrap $ joinIM $ e copyingStream2stream
- return (r,b)
-
- (req,body) <- run iter
+ iter <- testReceiveRequestIter sampleRequest3
+ (req,body) <- run_ iter
assertEqual "no cookies" [] $ rqCookies req
@@ -331,15 +311,8 @@ testHttpRequest3 =
testHttpRequest3' :: Test
testHttpRequest3' =
testCase "server/HttpRequest3'" $ do
- iter <- enumBS sampleRequest3' $
- do
- r <- liftM fromJust $ rsm receiveRequest
- se <- liftIO $ readIORef (rqBody r)
- let (SomeEnumerator e) = se
- b <- liftM fromWrap $ joinIM $ e copyingStream2stream
- return (r,b)
-
- (req,body) <- run iter
+ iter <- testReceiveRequestIter sampleRequest3'
+ (req,body) <- run_ iter
assertEqual "post param 1"
(rqParam "postparam1" req)
@@ -383,7 +356,7 @@ sampleRequest3' =
-rsm :: ServerMonad a -> Iteratee IO a
+rsm :: ServerMonad a -> Iteratee ByteString IO a
rsm = runServerMonad "localhost" "127.0.0.1" 80 "127.0.0.1" 58382 alog elog
where
alog = const . const . return $ ()
@@ -392,15 +365,12 @@ rsm = runServerMonad "localhost" "127.0.0.1" 80
"127.0.0.1" 58382 alog elog
testHttpResponse1 :: Test
testHttpResponse1 = testCase "server/HttpResponse1" $ do
- let onSendFile = \f start sz ->
- enumFilePartial f (start,start+sz) copyingStream2stream
- >>= run
+ sstep <- runIteratee copyingStream2Stream
+ req <- mkRequest sampleRequest
- req <- mkRequest sampleRequest
-
- b <- run $ rsm $
- sendResponse req rsp1 copyingStream2stream onSendFile >>=
- return . fromWrap . snd
+ b <- run_ $ rsm $
+ sendResponse req rsp1 sstep testOnSendFile >>=
+ return . snd
assertEqual "http response" (L.concat [
"HTTP/1.0 600 Test\r\n"
@@ -413,21 +383,24 @@ testHttpResponse1 = testCase "server/HttpResponse1" $ do
rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $
setContentLength 10 $
setResponseStatus 600 "Test" $
- modifyResponseBody (>. (enumBS "0123456789")) $
- setResponseBody return $
+ modifyResponseBody (>==> (enumBS "0123456789")) $
+ setResponseBody returnI $
emptyResponse { rspHttpVersion = (1,0) }
-testHttpResponse2 :: Test
-testHttpResponse2 = testCase "server/HttpResponse2" $ do
- let onSendFile = \f st sz ->
- enumFilePartial f (st,st+sz) copyingStream2stream >>= run
- req <- mkRequest sampleRequest
+testOnSendFile :: FilePath -> Int64 -> Int64 -> IO L.ByteString
+testOnSendFile f st sz = do
+ sstep <- runIteratee copyingStream2Stream
+ run_ $ enumFilePartial f (st,st+sz) sstep
- b2 <- run $ rsm $
- sendResponse req rsp2 copyingStream2stream onSendFile >>=
- return . fromWrap . snd
+testHttpResponse2 :: Test
+testHttpResponse2 = testCase "server/HttpResponse2" $ do
+ sstep <- runIteratee copyingStream2Stream
+ req <- mkRequest sampleRequest
+ b2 <- run_ $ rsm $
+ sendResponse req rsp2 sstep testOnSendFile >>=
+ return . snd
assertEqual "http response" (L.concat [
"HTTP/1.0 600 Test\r\n"
@@ -439,22 +412,20 @@ testHttpResponse2 = testCase "server/HttpResponse2" $ do
rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $
setContentLength 10 $
setResponseStatus 600 "Test" $
- modifyResponseBody (>. (enumBS "0123456789")) $
- setResponseBody return $
+ modifyResponseBody (>==> (enumBS "0123456789")) $
+ setResponseBody returnI $
emptyResponse { rspHttpVersion = (1,0) }
rsp2 = rsp1 { rspContentLength = Nothing }
testHttpResponse3 :: Test
testHttpResponse3 = testCase "server/HttpResponse3" $ do
- let onSendFile = \f st sz ->
- enumFilePartial f (st,st+sz) copyingStream2stream >>= run
+ sstep <- runIteratee copyingStream2Stream
+ req <- mkRequest sampleRequest
- req <- mkRequest sampleRequest
-
- b3 <- run $ rsm $
- sendResponse req rsp3 copyingStream2stream onSendFile >>=
- return . fromWrap . snd
+ b3 <- run_ $ rsm $
+ sendResponse req rsp3 sstep testOnSendFile >>=
+ return . snd
assertEqual "http response" b3 $ L.concat [
"HTTP/1.1 600 Test\r\n"
@@ -471,8 +442,8 @@ testHttpResponse3 = testCase "server/HttpResponse3" $ do
rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $
setContentLength 10 $
setResponseStatus 600 "Test" $
- modifyResponseBody (>. (enumBS "0123456789")) $
- setResponseBody return $
+ modifyResponseBody (>==> (enumBS "0123456789")) $
+ setResponseBody returnI $
emptyResponse { rspHttpVersion = (1,0) }
rsp2 = rsp1 { rspContentLength = Nothing }
rsp3 = setContentType "text/plain" $ (rsp2 { rspHttpVersion = (1,1) })
@@ -480,14 +451,13 @@ testHttpResponse3 = testCase "server/HttpResponse3" $ do
testHttpResponse4 :: Test
testHttpResponse4 = testCase "server/HttpResponse4" $ do
- let onSendFile = \f st sz ->
- enumFilePartial f (st,st+sz) copyingStream2stream >>= run
+ sstep <- runIteratee copyingStream2Stream
req <- mkRequest sampleRequest
- b <- run $ rsm $
- sendResponse req rsp1 copyingStream2stream onSendFile >>=
- return . fromWrap . snd
+ b <- run_ $ rsm $
+ sendResponse req rsp1 sstep testOnSendFile >>=
+ return . snd
assertEqual "http response" (L.concat [
"HTTP/1.0 304 Test\r\n"
@@ -505,14 +475,14 @@ testHttpResponse4 = testCase "server/HttpResponse4" $ do
echoServer :: (ByteString -> IO ())
-> Request
- -> Iteratee IO (Request,Response)
+ -> Iteratee ByteString IO (Request,Response)
echoServer _ req = do
se <- liftIO $ readIORef (rqBody req)
let (SomeEnumerator enum) = se
- let i = joinIM $ enum copyingStream2stream
- b <- liftM fromWrap i
+ i <- liftM enum $ lift $ runIteratee copyingStream2Stream
+ b <- i
let cl = L.length b
- liftIO $ writeIORef (rqBody req) (SomeEnumerator $ return . joinI . take 0)
+ liftIO $ writeIORef (rqBody req) (SomeEnumerator $ joinI . I.take 0)
return (req, rsp b cl)
where
rsp s cl = emptyResponse { rspBody = Enum $ enumLBS s
@@ -529,8 +499,8 @@ echoServer2 _ req = do
testHttp1 :: Test
-testHttp1 = testCase "server/http session" $ do
- let enumBody = enumBS sampleRequest >. enumBS sampleRequest2
+testHttp1 = testCase "server/httpSession" $ do
+ let enumBody = enumBS sampleRequest >==> enumBS sampleRequest2
ref <- newIORef ""
@@ -561,18 +531,25 @@ testHttp1 = testCase "server/http session" $ do
_ -> False
+ when (not ok) $ do
+ putStrLn "server/httpSession fail!!!! got:"
+ LC.putStrLn s
+
assertBool "pipelined responses" ok
mkIter :: IORef L.ByteString
- -> (Iteratee IO (), FilePath -> Int64 -> Int64 -> IO ())
+ -> (Iteratee ByteString IO (), FilePath -> Int64 -> Int64 -> IO ())
mkIter ref = (iter, \f st sz -> onF f st sz iter)
where
iter = do
- x <- copyingStream2stream
- liftIO $ modifyIORef ref $ \s -> L.append s (fromWrap x)
+ x <- copyingStream2Stream
+ liftIO $ modifyIORef ref $ \s -> L.append s x
- onF f st sz i = enumFilePartial f (st,st+sz) i >>= run
+ onF f st sz i = do
+ step <- runIteratee i
+ let it = enumFilePartial f (st,st+sz) step
+ run_ it
testChunkOn1_0 :: Test
@@ -620,7 +597,7 @@ sampleRequest4 =
testHttp2 :: Test
testHttp2 = testCase "server/connection: close" $ do
- let enumBody = enumBS sampleRequest4 >. enumBS sampleRequest2
+ let enumBody = enumBS sampleRequest4 >==> enumBS sampleRequest2
ref <- newIORef ""
@@ -806,13 +783,17 @@ testServerStartupShutdown = testCase
"server/startup/shutdown" $ do
where
go tid = do
+ debug $ "testServerStartupShutdown: waiting a bit"
waitabit
-
+ debug $ "testServerStartupShutdown: sending http request"
rsp <- HTTP.simpleHTTP (HTTP.getRequest "http://localhost:8145/";)
+ debug $ "testServerStartupShutdown: grabbing response"
doc <- HTTP.getResponseBody rsp
assertEqual "server" "PONG" doc
+ debug $ "testServerStartupShutdown: killing thread"
killThread tid
+ debug $ "testServerStartupShutdown: kill signal sent to thread"
waitabit
expectException $ HTTP.simpleHTTP
@@ -875,3 +856,13 @@ testServerShutdownWithOpenConns = testCase
"server/shutdown-open-conns" $ do
seconds :: Int
seconds = (10::Int) ^ (6::Int)
+
+
+copyingStream2Stream :: (Monad m) => Iteratee ByteString m L.ByteString
+copyingStream2Stream = go []
+ where
+ go l = do
+ mbx <- I.head
+ maybe (return $ L.fromChunks $ reverse l)
+ (\x -> let !z = S.copy x in go (z:l))
+ mbx
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
