Skip to content
Browse files

Change snap-server to use 'enumerator' instead of 'iteratee'

  • Loading branch information...
1 parent 5e4850d commit 61c5f5ae83b1b6906ab331ea25af0e45c617d2ea @gregorycollins gregorycollins committed Nov 28, 2010
View
6 snap-server.cabal
@@ -118,7 +118,7 @@ Library
build-depends:
array >= 0.2 && <0.4,
attoparsec >= 0.8.1 && < 0.9,
- attoparsec-iteratee >= 0.1.1 && <0.2,
+ attoparsec-enumerator >= 0.2.0.1 && < 0.3,
base >= 4 && < 5,
binary >=0.5 && <0.6,
bytestring,
@@ -128,10 +128,10 @@ Library
containers,
directory-tree,
dlist >= 0.5 && < 0.6,
+ enumerator == 0.4.*,
filepath,
- iteratee >= 0.3.1 && <0.4,
MonadCatchIO-transformers >= 0.2.1 && < 0.3,
- monads-fd < 0.1.0.3,
+ monads-fd >= 0.1.0.4 && <0.2,
murmur-hash >= 0.1 && < 0.2,
network == 2.2.1.*,
old-locale,
View
4 src/Snap/Http/Server/Config.hs
@@ -50,7 +50,7 @@ import Data.List
import Data.Monoid
import Prelude hiding (catch)
import Snap.Types
-import Snap.Iteratee ((>.), enumBS)
+import Snap.Iteratee ((>==>), enumBS)
import System.Console.GetOpt
import System.Environment hiding (getEnv)
#ifndef PORTABLE
@@ -195,7 +195,7 @@ defaultConfig = Config
finishWith $ setContentType "text/plain; charset=utf-8"
. setContentLength (fromIntegral $ B.length msg)
. setResponseStatus 500 "Internal Server Error"
- . modifyResponseBody (>. enumBS msg)
+ . modifyResponseBody (>==> enumBS msg)
$ emptyResponse
, other = Nothing
}
View
151 src/Snap/Internal/Http/Parser.hs
@@ -8,7 +8,7 @@ module Snap.Internal.Http.Parser
( IRequest(..)
, parseRequest
, readChunkedTransferEncoding
- , parserToIteratee
+ , iterParser
, parseCookie
, parseUrlEncoded
, writeChunkedTransferEncoding
@@ -22,7 +22,7 @@ import Control.Arrow (second)
import Control.Monad (liftM)
import "monads-fd" Control.Monad.Trans
import Data.Attoparsec hiding (many, Result(..))
-import Data.Attoparsec.Iteratee
+import Data.Attoparsec.Enumerator
import Data.Bits
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
@@ -34,17 +34,19 @@ import Data.DList (DList)
import qualified Data.DList as D
import Data.List (foldl')
import Data.Int
-import Data.Iteratee.WrappedByteString
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import qualified Data.Vector.Unboxed as Vec
import Data.Vector.Unboxed (Vector)
import Data.Word (Word8, Word64)
-import Prelude hiding (take, takeWhile)
+import Prelude hiding (head, take, takeWhile)
+import qualified Prelude
------------------------------------------------------------------------------
-import Snap.Internal.Http.Types hiding (Enumerator)
-import Snap.Iteratee hiding (take, foldl', filter)
+import Snap.Internal.Http.Types
+import Snap.Internal.Debug
+import Snap.Internal.Iteratee.Debug
+import Snap.Iteratee hiding (map, take)
------------------------------------------------------------------------------
@@ -70,18 +72,17 @@ instance Show IRequest where
------------------------------------------------------------------------------
-parseRequest :: (Monad m) => Iteratee m (Maybe IRequest)
-parseRequest = parserToIteratee pRequest
+parseRequest :: (Monad m) => Iteratee ByteString m (Maybe IRequest)
+parseRequest = iterParser pRequest
------------------------------------------------------------------------------
-readChunkedTransferEncoding :: (Monad m) =>
- Iteratee m a
- -> m (Iteratee m a)
-readChunkedTransferEncoding iter = do
- i <- chunkParserToEnumerator (parserToIteratee pGetTransferChunk)
- iter
- return i
+readChunkedTransferEncoding :: (MonadIO m) =>
+ Enumeratee ByteString ByteString m a
+readChunkedTransferEncoding =
+ chunkParserToEnumeratee $
+ iterateeDebugWrapper "pGetTransferChunk" $
+ iterParser pGetTransferChunk
------------------------------------------------------------------------------
@@ -108,6 +109,8 @@ toHex n' = s
-- chunked transfer-encoding. Example usage:
--
--
+-- > FIXME this text is now wrong
+--
-- > > (writeChunkedTransferEncoding
-- > (enumLBS (L.fromChunks ["foo","bar","quux"]))
-- > stream2stream) >>=
@@ -116,98 +119,91 @@ toHex n' = s
-- >
-- > Chunk "a\r\nfoobarquux\r\n0\r\n\r\n" Empty
--
-writeChunkedTransferEncoding :: Enumerator IO a
-writeChunkedTransferEncoding it = do
- let out = wrap it
- return out
+writeChunkedTransferEncoding :: Enumeratee ByteString ByteString IO a
+writeChunkedTransferEncoding = checkDone start
where
- wrap iter = bufIt (0,D.empty) iter
+ start = bufIt 0 D.empty
bufSiz = 16284
sendOut :: DList ByteString
- -> Iteratee IO a
- -> IO (Iteratee IO a)
- sendOut dl iter = do
+ -> (Stream ByteString -> Iteratee ByteString IO a)
+ -> Iteratee ByteString IO (Step ByteString IO a)
+ sendOut dl k = do
let chunks = D.toList dl
let bs = L.fromChunks chunks
let n = L.length bs
if n == 0
- then return iter
+ then return $ Continue k
else do
let o = L.concat [ L.fromChunks [ toHex (toEnum . fromEnum $ n)
, "\r\n" ]
, bs
, "\r\n" ]
- enumLBS o iter
-
+ lift $ runIteratee $ enumLBS o (Continue k)
- bufIt (n,dl) iter = IterateeG $ \s -> do
- case s of
- (EOF Nothing) -> do
- i' <- sendOut dl iter
- j <- liftM liftI $ runIter i' (Chunk (WrapBS "0\r\n\r\n"))
- runIter j (EOF Nothing)
- (EOF e) -> return $ Cont undefined e
+
+ bufIt :: Int
+ -> DList ByteString
+ -> (Stream ByteString -> Iteratee ByteString IO a)
+ -> Iteratee ByteString IO (Step ByteString IO a)
+ bufIt n dl k = do
+ mbS <- head
+ case mbS of
+ Nothing -> do
+ step <- sendOut dl k
+ step' <- lift $ runIteratee $ enumBS "0\r\n\r\n" step
+ lift $ runIteratee $ enumEOF step'
- (Chunk (WrapBS x)) -> do
- let m = S.length x
+ (Just s) -> do
+ let m = S.length s
- if m == 0
- then return $ Cont (bufIt (n,dl) iter) Nothing
- else do
- let n' = m + n
- let dl' = D.snoc dl x
+ if m == 0
+ then bufIt n dl k
+ else do
+ let n' = m + n
+ let dl' = D.snoc dl s
- if n' > bufSiz
- then do
- i' <- sendOut dl' iter
- return $ Cont (bufIt (0,D.empty) i') Nothing
- else return $ Cont (bufIt (n',dl') iter) Nothing
+ if n' > bufSiz
+ then do
+ step <- sendOut dl' k
+ checkDone start step
+ else bufIt n' dl' k
------------------------------------------------------------------------------
-chunkParserToEnumerator :: (Monad m) =>
- Iteratee m (Maybe ByteString)
- -> Iteratee m a
- -> m (Iteratee m a)
-chunkParserToEnumerator getChunk client = return $ do
+chunkParserToEnumeratee :: (MonadIO m) =>
+ Iteratee ByteString m (Maybe ByteString)
+ -> Enumeratee ByteString ByteString m a
+chunkParserToEnumeratee getChunk client = do
+ debug $ "chunkParserToEnumeratee: getting chunk"
mbB <- getChunk
- maybe (finishIt client) (sendBS client) mbB
-
- where
- sendBS iter s = do
- v <- lift $ runIter iter (Chunk $ toWrap $ L.fromChunks [s])
+ debug $ "chunkParserToEnumeratee: getChunk was " ++ show mbB
+ mbX <- peek
+ debug $ "chunkParserToEnumeratee: .. and peek is " ++ show mbX
- case v of
- (Done _ (EOF (Just e))) -> throwErr e
- (Done x _) -> return x
+ maybe finishIt sendBS mbB
- (Cont _ (Just e)) -> throwErr e
-
- (Cont k Nothing) -> joinIM $
- chunkParserToEnumerator getChunk k
-
- finishIt iter = do
- e <- lift $ sendEof iter
-
- case e of
- Left x -> throwErr x
- Right x -> return x
+ where
+ whatWasReturn (Continue _) = "continue"
+ whatWasReturn (Yield _ z) = "yield, with remainder " ++ show z
+ whatWasReturn (Error e) = "error, with " ++ show e
- sendEof iter = do
- v <- runIter iter (EOF Nothing)
+ 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'
- return $ case v of
- (Done _ (EOF (Just e))) -> Left e
- (Done x _) -> Right x
- (Cont _ (Just e)) -> Left e
- (Cont _ _) -> Left $ Err $ "divergent iteratee"
+ finishIt = lift $ runIteratee $ enumEOF client
------------------------------------------------------------------------------
@@ -252,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)
------------------------------------------------------------------------------
View
164 src/Snap/Internal/Http/Server.hs
@@ -21,7 +21,6 @@ import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Nums.Careless.Int as Cvt
import Data.Int
import Data.IORef
-import Data.Iteratee.WrappedByteString (unWrap)
import Data.List (foldl')
import qualified Data.Map as Map
import Data.Maybe (fromJust, catMaybes, fromMaybe)
@@ -37,8 +36,8 @@ import System.Posix.Types (FileOffset)
import Text.Show.ByteString hiding (runPut)
------------------------------------------------------------------------------
import System.FastLogger
+import Snap.Internal.Http.Types
import Snap.Internal.Debug
-import Snap.Internal.Http.Types hiding (Enumerator)
import Snap.Internal.Http.Parser
import Snap.Internal.Http.Server.Date
@@ -49,7 +48,7 @@ import Snap.Internal.Http.Server.SimpleBackend
import Snap.Internal.Http.Server.LibevBackend
import Snap.Internal.Iteratee.Debug
-import Snap.Iteratee hiding (foldl', head, take, FileOffset)
+import Snap.Iteratee hiding (head, take, map)
import qualified Snap.Iteratee as I
import qualified Paths_snap_server as V
@@ -65,9 +64,9 @@ import qualified Paths_snap_server as V
-- hidden inside the Snap monad
type ServerHandler = (ByteString -> IO ())
-> Request
- -> Iteratee IO (Request,Response)
+ -> Iteratee ByteString IO (Request,Response)
-type ServerMonad = StateT ServerState (Iteratee IO)
+type ServerMonad = StateT ServerState (Iteratee ByteString IO)
data ListenPort = HttpPort ByteString Int -- (bind address, port)
| HttpsPort ByteString Int FilePath FilePath -- (bind address, port, path to certificate, path to key)
@@ -97,7 +96,7 @@ runServerMonad :: ByteString -- ^ local host name
-> (Request -> Response -> IO ()) -- ^ access log function
-> (ByteString -> IO ()) -- ^ error log function
-> ServerMonad a -- ^ monadic action to run
- -> Iteratee IO a
+ -> Iteratee ByteString IO a
runServerMonad lh s la le m = evalStateT m st
where
st = ServerState False lh s la le
@@ -221,8 +220,8 @@ runHTTP :: Maybe Logger -- ^ access logger
-> ServerHandler -- ^ handler procedure
-> ByteString -- ^ local host name
-> SessionInfo -- ^ session port information
- -> Enumerator IO () -- ^ read end of socket
- -> Iteratee IO () -- ^ write end of socket
+ -> Enumerator ByteString IO () -- ^ read end of socket
+ -> Iteratee ByteString IO () -- ^ write end of socket
-> (FilePath -> Int64 -> Int64 -> IO ())
-- ^ sendfile end
-> IO () -- ^ timeout tickler
@@ -243,7 +242,13 @@ runHTTP alog elog handler lh sinfo readEnd writeEnd onSendFile tickle =
httpSession writeEnd buf onSendFile tickle
handler
let iter = iterateeDebugWrapper "httpSession iteratee" iter1
- readEnd iter >>= run
+
+ debug "runHTTP/go: prepping iteratee for start"
+
+ step <- liftIO $ runIteratee iter
+
+ debug "runHTTP/go: running..."
+ run_ $ readEnd step
debug "runHTTP/go: finished"
@@ -269,7 +274,7 @@ logError s = gets _logError >>= (\l -> liftIO $ l s)
------------------------------------------------------------------------------
-- | Runs an HTTP session.
-httpSession :: Iteratee IO () -- ^ write end of socket
+httpSession :: Iteratee ByteString IO () -- ^ write end of socket
-> ForeignPtr CChar -- ^ iteratee buffer
-> (FilePath -> Int64 -> Int64 -> IO ())
-- ^ sendfile continuation
@@ -278,12 +283,15 @@ httpSession :: Iteratee IO () -- ^ write end of socket
-> ServerMonad ()
httpSession writeEnd' ibuf onSendFile tickle handler = do
- writeEnd1 <- liftIO $ I.unsafeBufferIterateeWithBuffer ibuf writeEnd'
+ let writeEnd1 = I.unsafeBufferIterateeWithBuffer ibuf writeEnd'
+ let writeEndI = iterateeDebugWrapper "writeEnd" writeEnd1
- let writeEnd = iterateeDebugWrapper "writeEnd" writeEnd1
+ -- everything downstream expects a Step here
+ writeEnd <- liftIO $ runIteratee writeEndI
liftIO $ debug "Server.httpSession: entered"
mreq <- receiveRequest
+ liftIO $ debug "Server.httpSession: receiveRequest finished"
-- successfully got a request, so restart timer
liftIO tickle
@@ -314,10 +322,16 @@ httpSession writeEnd' ibuf onSendFile tickle handler = do
liftIO $ debug "Server.httpSession: handled, skipping request body"
- srqEnum <- liftIO $ readIORef $ rqBody req'
- let (SomeEnumerator rqEnum) = srqEnum
- lift $ joinIM
- $ rqEnum (iterateeDebugWrapper "httpSession/skipToEof" skipToEof)
+ if rspTransformingRqBody rsp
+ then liftIO $ debug "Server.httpSession: not skipping request body, transforming."
+ else do
+ srqEnum <- liftIO $ readIORef $ rqBody req'
+ let (SomeEnumerator rqEnum) = srqEnum
+
+ skipStep <- liftIO $ runIteratee $
+ iterateeDebugWrapper "httpSession/skipToEof" skipToEof
+ lift $ rqEnum skipStep
+
liftIO $ debug $ "Server.httpSession: request body skipped, " ++
"sending response"
@@ -347,7 +361,7 @@ httpSession writeEnd' ibuf onSendFile tickle handler = do
------------------------------------------------------------------------------
checkExpect100Continue :: Request
- -> Iteratee IO ()
+ -> Step ByteString IO ()
-> ServerMonad ()
checkExpect100Continue req writeEnd = do
let mbEx = getHeaders "Expect" req
@@ -365,14 +379,17 @@ checkExpect100Continue req writeEnd = do
putAscii '.'
showp minor
putByteString " 100 Continue\r\n\r\n"
- iter <- liftIO $ enumLBS hl writeEnd
- liftIO $ run iter
+ liftIO $ runIteratee $ (enumLBS hl >==> enumEOF) writeEnd
+ return ()
------------------------------------------------------------------------------
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
@@ -396,13 +413,12 @@ 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: " ++
"input in chunked encoding"
- let e = readChunkedTransferEncoding
+ let e = joinI . readChunkedTransferEncoding
liftIO $ writeIORef (rqBody req)
(SomeEnumerator e)
else maybe noContentLength hasContentLength mbCL
@@ -412,27 +428,28 @@ receiveRequest = do
((== ["chunked"]) . map toCI)
(Map.lookup "transfer-encoding" hdrs)
- hasContentLength :: Int -> ServerMonad ()
- hasContentLength l = do
+ hasContentLength :: Int64 -> ServerMonad ()
+ hasContentLength len = do
liftIO $ debug $ "receiveRequest/setEnumerator: " ++
- "request had content-length " ++ Prelude.show l
+ "request had content-length " ++ Prelude.show len
liftIO $ writeIORef (rqBody req) (SomeEnumerator e)
liftIO $ debug "receiveRequest/setEnumerator: body enumerator set"
where
- e :: Enumerator IO a
- e it = return $ joinI $ I.take l $
- iterateeDebugWrapper "rqBody iterator" it
-
- noContentLength :: ServerMonad ()
- noContentLength = do
- liftIO $ debug ("receiveRequest/setEnumerator: " ++
- "request did NOT have content-length")
+ e :: Enumerator ByteString IO a
+ e st = do
+ st' <- lift $
+ runIteratee $
+ iterateeDebugWrapper "rqBody iterator" $
+ returnI st
- -- FIXME: should we not just read everything?
- let e = return . joinI . I.take 0
+ joinI $ takeExactly len st'
- liftIO $ writeIORef (rqBody req) (SomeEnumerator e)
- liftIO $ debug "receiveRequest/setEnumerator: body enumerator set"
+ noContentLength :: ServerMonad ()
+ noContentLength = liftIO $ do
+ debug ("receiveRequest/setEnumerator: " ++
+ "request did NOT have content-length")
+ writeIORef (rqBody req) (SomeEnumerator returnI)
+ debug "receiveRequest/setEnumerator: body enumerator set"
hdrs = rqHeaders req
@@ -459,18 +476,23 @@ receiveRequest = do
liftIO $ debug "parseForm: reading POST body"
senum <- liftIO $ readIORef $ rqBody req
let (SomeEnumerator enum) = senum
- let i = joinI $ takeNoMoreThan maximumPOSTBodySize stream2stream
- iter <- liftIO $ enum i
- body <- liftM unWrap $ lift iter
+ consumeStep <- liftIO $ runIteratee consume
+ step <- liftIO $
+ runIteratee $
+ joinI $ takeNoMoreThan maximumPOSTBodySize consumeStep
+ body <- liftM S.concat $ lift $ enum step
let newParams = parseUrlEncoded body
liftIO $ debug "parseForm: stuffing 'enumBS body' into request"
- let e = enumBS body >. enumEof
-
- liftIO $ writeIORef (rqBody req) $ SomeEnumerator $
- e . iterateeDebugWrapper "regurgitate body"
+ let e = enumBS body >==> I.joinI . I.take 0
+ let e' = \st -> do
+ let ii = iterateeDebugWrapper "regurgitate body" (returnI st)
+ st' <- lift $ runIteratee ii
+ e st'
+
+ liftIO $ writeIORef (rqBody req) $ SomeEnumerator e'
return $ req { rqParams = rqParams req `mappend` newParams }
@@ -490,7 +512,7 @@ receiveRequest = do
(Map.lookup "host" hdrs))
-- will override in "setEnumerator"
- enum <- liftIO $ newIORef $ SomeEnumerator return
+ enum <- liftIO $ newIORef $ SomeEnumerator (enumBS "")
return $ Request serverName
@@ -548,8 +570,9 @@ receiveRequest = do
-- Response must be well-formed here
sendResponse :: forall a . Request
-> Response
- -> Iteratee IO a
- -> (FilePath -> Int64 -> Int64 -> IO a)
+ -> Step ByteString IO a -- ^ iteratee write end
+ -> (FilePath -> Int64 -> Int64 -> IO a) -- ^ function to call on
+ -- sendfile
-> ServerMonad (Int64, a)
sendResponse req rsp' writeEnd onSendFile = do
rsp <- fixupResponse rsp'
@@ -562,32 +585,51 @@ sendResponse req rsp' writeEnd onSendFile = do
(SendFile f (Just (st,_))) ->
lift $ whenSendFile headerString rsp f st
+ debug "sendResponse: response sent"
+
return $! (bs,x)
where
--------------------------------------------------------------------------
whenEnum :: ByteString
-> Response
- -> (forall x . Enumerator IO x)
- -> Iteratee IO (a,Int64)
+ -> (forall x . Enumerator ByteString IO x)
+ -> Iteratee ByteString IO (a,Int64)
whenEnum hs rsp e = do
+ -- "enum" here has to be run in the context of the READ iteratee, even
+ -- though it's writing to the output, because we may be transforming
+ -- the input. That's why we check if we're transforming the request
+ -- body here, and if not, send EOF to the write end; so that it doesn't
+ -- join up with the read iteratee and try to get more data from the
+ -- socket.
let enum = if rspTransformingRqBody rsp
- then enumBS hs >. e
- else enumBS hs >. e >. enumEof
+ then enumBS hs >==> e
+ else enumBS hs >==> e >==> (joinI . I.take 0)
let hl = fromIntegral $ S.length hs
debug $ "sendResponse: whenEnum: enumerating bytes"
- (x,bs) <- joinIM $ enum (countBytes writeEnd)
+
+ outstep <- lift $ runIteratee $
+ iterateeDebugWrapper "countBytes writeEnd" $
+ countBytes $ returnI writeEnd
+ (x,bs) <- enum outstep
debug $ "sendResponse: whenEnum: " ++ Prelude.show bs ++ " bytes enumerated"
return (x, bs-hl)
--------------------------------------------------------------------------
+ whenSendFile :: ByteString -- ^ headers
+ -> Response
+ -> FilePath -- ^ file to send
+ -> Int64 -- ^ start byte offset
+ -> Iteratee ByteString IO (a,Int64)
whenSendFile hs r f start = do
- -- guaranteed to have a content length here.
- joinIM $ (enumBS hs >. enumEof) writeEnd
+ -- Guaranteed to have a content length here. Sending EOF through to the
+ -- write end guarantees that we flush the buffer before we send the
+ -- file with sendfile().
+ lift $ runIteratee $ (enumBS hs >==> enumEOF) writeEnd
let !cl = fromJust $ rspContentLength r
x <- liftIO $ onSendFile f start cl
@@ -624,7 +666,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 }
@@ -649,8 +694,11 @@ sendResponse req rsp' writeEnd onSendFile = do
return $ r' { rspBody = b }
where
- i :: forall z . Enumerator IO z -> Enumerator IO z
- i enum iter = enum (joinI $ takeExactly cl iter)
+ i :: forall z . Enumerator ByteString IO z
+ -> Enumerator ByteString IO z
+ i enum step = do
+ step' <- lift $ runIteratee $ joinI $ takeExactly cl step
+ enum step'
--------------------------------------------------------------------------
View
4 src/Snap/Internal/Http/Server/Backend.hs
@@ -24,8 +24,8 @@ data SessionInfo = SessionInfo
}
type SessionHandler = SessionInfo -- ^ session port information
- -> Enumerator IO () -- ^ read end of socket
- -> Iteratee IO () -- ^ write end of socket
+ -> Enumerator ByteString IO () -- ^ read end of socket
+ -> Iteratee ByteString IO () -- ^ write end of socket
-> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile end
-> IO () -- ^ timeout tickler
-> IO ()
View
94 src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -31,16 +31,15 @@ libEvEventLoop _ _ _ _ = throwIO $ LibevException "libev event loop is not suppo
---------------------------
------------------------------------------------------------------------------
-import Control.Concurrent
+import Control.Concurrent hiding (yield)
import Control.Exception
import Control.Monad
import "monads-fd" Control.Monad.Trans
import Data.ByteString (ByteString)
import Data.ByteString.Internal (c2w)
-import qualified Data.ByteString as B
+import qualified Data.ByteString as S
import Data.Maybe
import Data.IORef
-import Data.Iteratee.WrappedByteString
import Data.Typeable
import Foreign hiding (new)
import Foreign.C.Types
@@ -53,7 +52,7 @@ import Prelude hiding (catch)
-- FIXME: should be HashSet, make that later.
import qualified Data.Concurrent.HashMap as H
import Data.Concurrent.HashMap (HashMap)
-import Snap.Iteratee
+import Snap.Iteratee hiding (map)
import Snap.Internal.Debug
import Snap.Internal.Http.Server.Date
import Snap.Internal.Http.Server.Backend
@@ -223,7 +222,9 @@ acceptCallback back handler elog cpu sock _loopPtr _ioPtr _ = do
where
go = runSession back handler sock
cleanup = [ Handler $ \(_ :: TimeoutException) -> return ()
- , Handler $ \(e :: SomeException) -> elog $ B.concat [ "libev.acceptCallback: ", B.pack . map c2w $ show e ]
+ , Handler $ \(e :: SomeException) ->
+ elog $ S.concat [ "libev.acceptCallback: "
+ , S.pack . map c2w $ show e ]
]
@@ -272,7 +273,7 @@ getAddr :: SockAddr -> IO (ByteString, Int)
getAddr addr =
case addr of
SockAddrInet p ha -> do
- s <- liftM (B.pack . map c2w) (inet_ntoa ha)
+ s <- liftM (S.pack . map c2w) (inet_ntoa ha)
return (s, fromIntegral p)
a -> throwIO $ AddressNotSupportedException (show a)
@@ -492,7 +493,8 @@ runSession backend handler lsock fd = do
ioWriteCb
tid
- bracket (Listen.createSession lsock bLOCKSIZE fd $ waitForLock True conn)
+ bracket (Listen.createSession lsock bLOCKSIZE fd $
+ waitForLock True conn)
(\session -> block $ do
debug "runSession: thread killed, closing socket"
@@ -528,8 +530,8 @@ bLOCKSIZE = 8192
-- About timeouts
--
-- It's not good enough to restart the timer from io(Read|Write)Callback,
--- because those seem to be edge-triggered. I've definitely had where after
--- 20 seconds they still weren't being re-awakened.
+-- because those seem to be edge-triggered. I've definitely had where after 20
+-- seconds they still weren't being re-awakened.
--
data TimeoutException = TimeoutException
@@ -568,7 +570,8 @@ waitForLock readLock conn = do
dbg "waitForLock: took mvar"
where
- dbg s = debug $ "Backend.recvData(" ++ show (_rawSocket conn) ++ "): " ++ s
+ dbg s = debug $ "Backend.recvData(" ++ show (_rawSocket conn) ++ "): "
+ ++ s
io = if readLock
then (_connReadIOObj conn)
else (_connWriteIOObj conn)
@@ -596,9 +599,13 @@ sendFile c s fp start sz = do
ListenHttp _ -> bracket (openFd fp ReadOnly Nothing defaultFileFlags)
(closeFd)
(go start sz)
- _ -> enumFilePartial fp (start,start+sz) (writeOut c s) >>= run
+ _ -> do
+ step <- runIteratee $ writeOut c s
+ run_ $ enumFilePartial fp (start,start+sz) step
#else
- enumFilePartial fp (start,start+sz) (writeOut c s) >>= run
+ step <- runIteratee $ writeOut c s
+
+ run_ $ enumFilePartial fp (start,start+sz) step
return ()
#endif
@@ -625,37 +632,52 @@ sendFile c s fp start sz = do
lock = _loopLock b
asy = _asyncObj b
-enumerate :: (MonadIO m) => Connection -> NetworkSession -> Enumerator m a
+enumerate :: (MonadIO m)
+ => Connection
+ -> NetworkSession
+ -> Enumerator ByteString m a
enumerate conn session = loop
where
- loop f = do
- s <- liftIO $ recvData
- sendOne f s
-
- sendOne f s = do
- v <- runIter f (if isNothing s
- then EOF Nothing
- else Chunk $ WrapBS $ fromJust s)
- case v of
- r@(Done _ _) -> return $ liftI r
- (Cont k Nothing) -> loop k
- (Cont _ (Just e)) -> return $ throwErr e
+ dbg s = debug $ "LibevBackend.enumerate(" ++ show (_socket session)
+ ++ "): " ++ s
+
+ loop (Continue k) = do
+ m <- liftIO $ recvData
+ let s = fromMaybe "" m
+ 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
recvData = Listen.recv (_listenSocket conn) (waitForLock True conn) session
-writeOut :: (MonadIO m) => Connection -> NetworkSession -> Iteratee m ()
-writeOut conn session = IterateeG out
- where
- iteratee = IterateeG out
-
- out c@(EOF _) = return $ Done () c
- out (Chunk s) = do
- let x = unWrap s
-
- liftIO $ sendData x
+writeOut :: (MonadIO m)
+ => Connection
+ -> NetworkSession
+ -> Iteratee ByteString m ()
+writeOut conn session = loop
+ where
+ loop = continue k
- return $ Cont iteratee Nothing
+ k EOF = yield () EOF
+ k (Chunks xs) = do
+ liftIO $ sendData $ S.concat xs
+ loop
sendData = Listen.send (_listenSocket conn)
(tickleTimeout conn)
View
124 src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -14,12 +14,12 @@ module Snap.Internal.Http.Server.SimpleBackend
------------------------------------------------------------------------------
import "monads-fd" Control.Monad.Trans
-import Control.Concurrent
+import Control.Concurrent hiding (yield)
import Control.Exception
import Control.Monad
-import qualified Data.ByteString as B
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as S
import Data.ByteString.Internal (c2w)
-import Data.Iteratee.WrappedByteString
import Data.Maybe
import Data.Typeable
import Data.Word
@@ -36,7 +36,7 @@ import qualified Snap.Internal.Http.Server.TimeoutTable as TT
import Snap.Internal.Http.Server.TimeoutTable (TimeoutTable)
import Snap.Internal.Http.Server.Backend
import qualified Snap.Internal.Http.Server.ListenHelpers as Listen
-import Snap.Iteratee hiding (foldl')
+import Snap.Iteratee hiding (map)
#if defined(HAS_SENDFILE)
import qualified System.SendFile as SF
@@ -73,7 +73,7 @@ simpleEventLoop sockets cap elog handler = do
newLoop :: [ListenSocket]
-> SessionHandler
- -> (B.ByteString -> IO ())
+ -> (S.ByteString -> IO ())
-> Int
-> IO EventLoopCpu
newLoop sockets handler elog cpu = do
@@ -91,7 +91,7 @@ stopLoop loop = block $ do
acceptThread :: SessionHandler
-> TimeoutTable
- -> (B.ByteString -> IO ())
+ -> (S.ByteString -> IO ())
-> Int
-> ListenSocket
-> IO ()
@@ -107,7 +107,7 @@ acceptThread handler tt elog cpu sock = loop
go = runSession handler tt sock
cleanup = [
- Handler $ \(e :: SomeException) -> elog $ B.concat [ "SimpleBackend.acceptThread: ", B.pack . map c2w $ show e]
+ Handler $ \(e :: SomeException) -> elog $ S.concat [ "SimpleBackend.acceptThread: ", S.pack . map c2w $ show e]
]
timeoutThread :: TimeoutTable -> MVar () -> IO ()
@@ -157,7 +157,7 @@ runSession handler tt lsock sock addr = do
case addr of
SockAddrInet p h -> do
h' <- inet_ntoa h
- return (fromIntegral p, B.pack $ map c2w h')
+ return (fromIntegral p, S.pack $ map c2w h')
x -> throwIO $ AddressNotSupportedException $ show x
laddr <- getSocketName sock
@@ -166,7 +166,7 @@ runSession handler tt lsock sock addr = do
case laddr of
SockAddrInet p h -> do
h' <- inet_ntoa h
- return (fromIntegral p, B.pack $ map c2w h')
+ return (fromIntegral p, S.pack $ map c2w h')
x -> throwIO $ AddressNotSupportedException $ show x
let sinfo = SessionInfo lhost lport rhost rport $ Listen.isSecure lsock
@@ -198,14 +198,23 @@ eatException :: IO a -> IO ()
eatException act = (act >> return ()) `catch` \(_::SomeException) -> return ()
------------------------------------------------------------------------------
-sendFile :: ListenSocket -> IO () -> CInt -> Iteratee IO () -> FilePath -> Int64 -> Int64 -> IO ()
+sendFile :: ListenSocket
+ -> IO ()
+ -> CInt
+ -> Iteratee ByteString IO ()
+ -> FilePath
+ -> Int64
+ -> Int64
+ -> IO ()
#if defined(HAS_SENDFILE)
sendFile lsock tickle sock writeEnd fp start sz =
case lsock of
ListenHttp _ -> bracket (openFd fp ReadOnly Nothing defaultFileFlags)
(closeFd)
(go start sz)
- _ -> enumFilePartial fp (start,start+sz) writeEnd >>= run
+ _ -> do
+ step <- runIteratee writeEnd
+ run_ $ enumFilePartial fp (start,start+sz) step
where
go off bytes fd
| bytes == 0 = return ()
@@ -219,7 +228,8 @@ sendFile lsock tickle sock writeEnd fp start sz =
#else
sendFile _ _ _ writeEnd fp start sz = do
-- no need to count bytes
- enumFilePartial fp (start,start+sz) writeEnd >>= run
+ step <- runIteratee writeEnd
+ run_ $ enumFilePartial fp (start,start+sz) step
return ()
#endif
@@ -229,26 +239,46 @@ tickleTimeout table tid thash = do
now <- getCurrentDateTime
TT.insert thash tid now table
-enumerate :: (MonadIO m) => ListenSocket -> NetworkSession -> Socket -> Enumerator m a
+enumerate :: (MonadIO m)
+ => ListenSocket
+ -> NetworkSession
+ -> Socket
+ -> Enumerator ByteString m a
enumerate port session sock = loop
where
- loop f = do
- debug $ "Backend.enumerate: reading from socket"
+ dbg s = debug $ "SimpleBackend.enumerate(" ++ show (_socket session)
+ ++ "): " ++ s
+
+ loop (Continue k) = do
+ dbg "reading from socket"
s <- liftIO $ timeoutRecv
case s of
- Nothing -> debug "Backend.enumerate: connection closed"
- Just s' -> debug $ "Backend.enumerate: got " ++ Prelude.show (B.length s')
- ++ " bytes from read end"
- sendOne f s
-
- sendOne f s = do
- v <- runIter f (if isNothing s
- then EOF Nothing
- else Chunk $ WrapBS $ fromJust s)
- case v of
- r@(Done _ _) -> return $ liftI r
- (Cont k Nothing) -> loop k
- (Cont _ (Just e)) -> return $ throwErr e
+ Nothing -> do
+ dbg "got EOF from socket"
+ sendOne k ""
+ Just s' -> do
+ dbg $ "got " ++ Prelude.show (S.length s')
+ ++ " bytes from read end"
+ 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
fd = fdSocket sock
#ifdef PORTABLE
@@ -258,25 +288,33 @@ enumerate port session sock = loop
#endif
-writeOut :: (MonadIO m) => ListenSocket -> NetworkSession -> Socket -> IO () -> Iteratee m ()
-writeOut port session sock tickle = iteratee
+writeOut :: (MonadIO m)
+ => ListenSocket
+ -> NetworkSession
+ -> Socket
+ -> IO ()
+ -> Iteratee ByteString m ()
+writeOut port session sock tickle = loop
where
- iteratee = IterateeG out
-
- out c@(EOF _) = return $ Done () c
-
- out (Chunk s) = do
- let x = unWrap s
+ dbg s = debug $ "SimpleBackend.writeOut(" ++ show (_socket session)
+ ++ "): " ++ s
- debug $ "Backend.writeOut: writing data " ++ show (B.length x)
- ee <- liftIO $ ((try $ timeoutSend x)
- :: IO (Either SomeException ()))
+ loop = continue k
+ k EOF = yield () EOF
+ k (Chunks xs) = do
+ let s = S.concat xs
+ let n = S.length s
+ dbg $ "got chunk with " ++ show n ++ " bytes"
+ ee <- liftIO $ try $ timeoutSend s
case ee of
- (Left e) -> do debug $ "Backend.writeOut: received error " ++ Prelude.show e
- return $ Done () (EOF $ Just $ Err $ show e)
- (Right _) -> do debug "Backend.writeOut: successfully sent data"
- return $ Cont iteratee Nothing
+ (Left (e::SomeException)) -> do
+ dbg $ "timeoutSend got error " ++ show e
+ throwError e
+ (Right _) -> do
+ let last10 = S.drop (n-10) s
+ dbg $ "wrote " ++ show n ++ " bytes, last 10=" ++ show last10
+ loop
fd = fdSocket sock
#ifdef PORTABLE
View
45 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
View
22 test/common/Test/Common/TestHandler.hs
@@ -5,13 +5,14 @@ module Test.Common.TestHandler (testHandler) where
import Control.Monad
+import Control.Monad.Trans
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
-import Data.Iteratee.WrappedByteString
import Data.Maybe
import Snap.Iteratee hiding (Enumerator)
+import qualified Snap.Iteratee as I
import Snap.Types
import Snap.Http.Server
import Snap.Util.FileServe
@@ -32,18 +33,21 @@ echoUriHandler = do
echoHandler :: Snap ()
-echoHandler = transformRequestBody return
+echoHandler = transformRequestBody returnI
rot13Handler :: Snap ()
-rot13Handler = transformRequestBody $ return . f
+rot13Handler = transformRequestBody f
where
- f i = IterateeG $ \ch -> do
- case ch of
- (EOF _) -> runIter i ch
- (Chunk (WrapBS s)) -> do
- i' <- liftM liftI $ runIter i $ Chunk $ WrapBS $ rot13 s
- return $ Cont (f i') Nothing
+ f origStep = do
+ mbX <- I.head
+ maybe (enumEOF origStep)
+ (feedStep origStep)
+ mbX
+
+ feedStep origStep x = do
+ step <- lift $ runIteratee $ enumBS (rot13 x) origStep
+ f step
bigResponseHandler :: Snap ()
View
17 test/snap-server-testsuite.cabal
@@ -24,7 +24,7 @@ Executable testsuite
QuickCheck >= 2,
array >= 0.3 && <0.4,
attoparsec >= 0.8.1 && < 0.9,
- attoparsec-iteratee >= 0.1.1 && <0.2,
+ attoparsec-enumerator >= 0.2.0.1 && < 0.3,
base >= 4 && < 5,
binary >= 0.5 && < 0.6,
bytestring,
@@ -34,18 +34,18 @@ Executable testsuite
directory,
directory-tree,
dlist >= 0.5 && < 0.6,
+ enumerator == 0.4.*,
filepath,
haskell98,
HTTP >= 4000.0.9 && < 4001,
HUnit >= 1.2 && < 2,
- monads-fd < 0.1.0.3,
+ monads-fd >= 0.1.0.4 && <0.2,
murmur-hash >= 0.1 && < 0.2,
network == 2.2.1.7,
network-bytestring >= 0.1.2 && < 0.2,
old-locale,
parallel > 2,
process,
- iteratee >= 0.3.1 && < 0.4,
snap-core >= 0.3 && <0.4,
template-haskell,
test-framework >= 0.3.1 && <0.4,
@@ -86,7 +86,7 @@ Executable pongserver
QuickCheck >= 2,
array >= 0.3 && <0.4,
attoparsec >= 0.8.1 && < 0.9,
- attoparsec-iteratee >= 0.1.1 && <0.2,
+ attoparsec-enumerator >= 0.2.0.1 && < 0.3,
base >= 4 && < 5,
bytestring,
bytestring-nums >= 0.3.1 && < 0.4,
@@ -95,13 +95,13 @@ Executable pongserver
containers,
directory-tree,
dlist >= 0.5 && < 0.6,
+ enumerator == 0.4.*,
filepath,
haskell98,
HUnit >= 1.2 && < 2,
- monads-fd < 0.1.0.3,
+ monads-fd >= 0.1.0.4 && <0.2,
old-locale,
parallel > 2,
- iteratee >= 0.3.1 && < 0.4,
MonadCatchIO-transformers >= 0.2.1 && < 0.3,
murmur-hash >= 0.1 && < 0.2,
network == 2.2.1.7,
@@ -164,7 +164,7 @@ Executable testserver
QuickCheck >= 2,
array >= 0.3 && <0.4,
attoparsec >= 0.8.1 && < 0.9,
- attoparsec-iteratee >= 0.1.1 && <0.2,
+ attoparsec-enumerator >= 0.2.0.1 && < 0.3,
base >= 4 && < 5,
binary >= 0.5 && < 0.6,
bytestring,
@@ -173,12 +173,13 @@ Executable testserver
containers,
directory-tree,
dlist >= 0.5 && < 0.6,
+ enumerator == 0.4.*,
filepath,
haskell98,
HTTP >= 4000.0.9 && < 4001,
HUnit >= 1.2 && < 2,
MonadCatchIO-transformers >= 0.2.1 && < 0.3,
- monads-fd < 0.1.0.3,
+ monads-fd >= 0.1.0.4 && <0.2,
murmur-hash >= 0.1 && < 0.2,
network == 2.2.1.7,
network-bytestring >= 0.1.2 && < 0.2,
View
242 test/suite/Snap/Internal/Http/Parser/Tests.hs
@@ -9,19 +9,19 @@ import qualified Control.Exception as E
import Control.Exception hiding (try, assert)
import Control.Monad
import Control.Monad.Identity
+import Control.Monad.Trans
import Control.Parallel.Strategies
import Data.Attoparsec hiding (Result(..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Internal (c2w)
import Data.IORef
-import Data.Iteratee.WrappedByteString
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
@@ -31,8 +31,10 @@ import Test.HUnit hiding (Test, path)
import Text.Printf
import Snap.Internal.Http.Parser
-import Snap.Internal.Http.Types hiding (Enumerator)
-import Snap.Iteratee hiding (foldl')
+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()
@@ -42,14 +44,11 @@ tests = [ testShow
, testCookie
, testChunked
, testBothChunked
- , testBothChunkedBuffered1
, testBothChunkedPipelined
, testBothChunkedEmpty
, testP2I
, testNull
, testPartial
- , testIterateeError
- , testIterateeError2
, testParseError
, testFormEncoded ]
@@ -58,16 +57,16 @@ 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
- i <- enumBS "z" (parserToIteratee emptyParser)
- l <- run i
+testP2I = testCase "parser/iterParser" $ do
+ i <- liftM (enumBS "z") $ runIteratee (iterParser emptyParser)
+ l <- run_ i
assertEqual "should be foo" "foo" l
@@ -79,45 +78,25 @@ forceErr e = f `seq` (return ())
testNull :: Test
-testNull = testCase "short parse" $ do
- f <- run (parseRequest)
+testNull = testCase "parser/shortParse" $ do
+ f <- run_ (parseRequest)
assertBool "should be Nothing" $ isNothing f
testPartial :: Test
-testPartial = testCase "partial parse" $ do
- i <- enumBS "GET / " parseRequest
- f <- E.try $ run i
+testPartial = testCase "parser/partial" $ do
+ i <- liftM (enumBS "GET / ") $ runIteratee parseRequest
+ f <- E.try $ run_ i
case f of (Left e) -> forceErr e
(Right x) -> assertFailure $ "expected exception, got " ++ show x
testParseError :: Test
-testParseError = testCase "parse error" $ do
- i <- enumBS "ZZZZZZZZZZ" parseRequest
- f <- E.try $ run i
-
- case f of (Left e) -> forceErr e
- (Right x) -> assertFailure $ "expected exception, got " ++ show x
-
-
-introduceError :: (Monad m) => Enumerator m a
-introduceError iter = return $ IterateeG $ \_ ->
- runIter iter (EOF (Just (Err "EOF")))
-
-testIterateeError :: Test
-testIterateeError = testCase "iteratee error" $ do
- i <- liftM liftI $ runIter parseRequest (EOF (Just (Err "foo")))
- f <- E.try $ run i
-
- case f of (Left e) -> forceErr e
- (Right x) -> assertFailure $ "expected exception, got " ++ show x
-
-testIterateeError2 :: Test
-testIterateeError2 = testCase "iteratee error 2" $ do
- i <- (enumBS "GET / " >. introduceError) parseRequest
- f <- E.try $ run i
+testParseError = testCase "parser/error" $ do
+ step <- runIteratee parseRequest
+ let i = enumBS "ZZZZZZZZZZ" step
+ f <- E.try $ run_ i
case f of (Left e) -> forceErr e
(Right x) -> assertFailure $ "expected exception, got " ++ show x
@@ -133,103 +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 Identity L.ByteString
- iter = runIdentity $ do
- i <- (readChunkedTransferEncoding stream2stream) >>= enum
- return $ liftM fromWrap i
testBothChunked :: Test
-testBothChunked = testProperty "chunk . unchunk == id" $
+testBothChunked = testProperty "parser/invertChunked" $
monadicIO $ forAllM arbitrary prop
where
prop s = do
- it <- QC.run $ writeChunkedTransferEncoding stream2stream
+ sstep <- QC.run $ runIteratee stream2stream
+ let it = joinI $ writeChunkedTransferEncoding sstep
- bs <- QC.run $
- enumBS s it
- >>= run >>= return . unWrap
+ bs <- QC.run $ runIteratee it >>= run_ . enumLBS s
- let enum = enumBS bs
+ let enum = enumLBS bs
- iter <- do
- i <- (readChunkedTransferEncoding stream2stream) >>= enum
- return $ liftM unWrap i
+ x <- QC.run $
+ runIteratee (joinI $ readChunkedTransferEncoding sstep) >>=
+ run_ . enum
- x <- run iter
QC.assert $ s == x
-testBothChunkedBuffered1 :: Test
-testBothChunkedBuffered1 = testProperty "testBothChunkedBuffered2" $
- monadicIO prop
- where
- prop = do
- sz <- QC.pick (choose (1000,4000))
- s' <- QC.pick $ resize sz arbitrary
- ntimes <- QC.pick (choose (4,7))
-
- let e = enumLBS s'
- let n = fromEnum $ L.length s'
-
- let enum = foldl' (>.) (enumBS "") (replicate ntimes e)
-
- (bufi,_) <- QC.run $ bufferIteratee stream2stream
- iter' <- QC.run $ writeChunkedTransferEncoding bufi
- let iter = I.joinI $ I.take n iter'
- let iters = replicate ntimes iter
-
- let mothra = foldM (\s it -> it >>= \t -> return $ s `mappend` t)
- mempty
- iters
-
- bs <- QC.run $ enum mothra
- >>= run >>= return . unWrap
-
-
- ----------------------------------------------------------------------
- -- 2nd pass, cancellation
- let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s
- (inputIter2,esc) <- QC.run $ bufferIteratee stream2stream
- QC.run $ writeIORef esc True
-
- iter2' <- QC.run $ writeChunkedTransferEncoding inputIter2
- let iter2 = I.joinI $ I.take n iter2'
- let iters2 = replicate ntimes iter2
-
- let mothra2 = foldM (\s it -> it >>= \t -> return $ s `mappend` t)
- mempty
- iters2
-
-
- bs2 <- QC.run $ enum mothra2
- >>= run >>= return . unWrap
-
-
- let e2 = enumBS bs2
- iters' <- QC.run $
- replicateM ntimes $
- readChunkedTransferEncoding stream2stream
- let godzilla2 = sequence $ map (>>= pcrlf) iters'
- outiter2 <- QC.run $ e2 godzilla2
- x2 <- QC.run $ liftM (map unWrap) $ run outiter2
-
- QC.assert $
- (map (L.fromChunks . (:[])) x2) == (replicate ntimes s')
-
-
testBothChunkedPipelined :: Test
-testBothChunkedPipelined = testProperty "testBothChunkedPipelined" $
+testBothChunkedPipelined = testProperty "parser/testBothChunkedPipelined" $
monadicIO prop
where
prop = do
@@ -241,80 +171,82 @@ testBothChunkedPipelined = testProperty "testBothChunkedPipelined" $
let e = enumLBS s'
let n = fromEnum $ L.length s'
- let enum = foldl' (>.) (enumBS "") (replicate ntimes e)
+ let enum = foldl' (>==>) (enumBS "") (replicate ntimes e)
- (bufi,_) <- QC.run $ bufferIteratee stream2stream
+ bufi <- QC.run $
+ unsafeBufferIteratee copyingStream2Stream >>= runIteratee
- iter' <- QC.run $ writeChunkedTransferEncoding bufi
+ iter' <- QC.run $ runIteratee $ joinI $
+ writeChunkedTransferEncoding bufi
let iter = I.joinI $ I.take n iter'
let iters = replicate ntimes iter
let mothra = foldM (\s it -> it >>= \t -> return $ s `mappend` t)
mempty
iters
- bs <- QC.run $ enum mothra
- >>= run >>= return . unWrap
+ bs <- QC.run $ runIteratee mothra >>= run_ . enum
let e2 = enumBS bs
- let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s
+ let pcrlf = \s -> iterParser $ string "\r\n" >> return s
- iters <- QC.run $
- replicateM ntimes $
- readChunkedTransferEncoding stream2stream
- let godzilla = sequence $ map (>>= pcrlf) iters
+ sstep <- QC.run $ runIteratee stream2stream
- iter <- QC.run $ e2 godzilla
+ let iters = replicate ntimes $ joinI $
+ readChunkedTransferEncoding sstep
+ let godzilla = sequence $ map (>>= pcrlf) iters
- x <- QC.run $ liftM (map unWrap) $ run iter
+ 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' = ""
let e = enumLBS s'
let n = fromEnum $ L.length s'
let ntimes = 5
- let enum = foldl' (>.) (enumBS "") (replicate ntimes e)
+ let enum = foldl' (>==>) (enumBS "") (replicate ntimes e)
- iter' <- writeChunkedTransferEncoding stream2stream
- let iter = I.joinI $ I.take n iter'
+ sstep <- runIteratee stream2stream
- let iters = replicate ntimes iter
+ step <- runIteratee $
+ joinI $
+ writeChunkedTransferEncoding sstep
+ iter <- liftM returnI $ runIteratee $ joinI $ I.take n step
+
+ let iters = replicate ntimes (iter :: Iteratee ByteString IO L.ByteString)
let mothra = foldM (\s it -> it >>= \t -> return $ s `mappend` t)
mempty
iters
- bs <- enum mothra
- >>= run >>= return . unWrap
-
- let e2 = enumBS bs
+ mothraStep <- runIteratee mothra
+ bs <- run_ $ enum mothraStep
- let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s
+ let e2 = enumLBS bs
- iters <- replicateM ntimes $
- readChunkedTransferEncoding stream2stream
- let godzilla = sequence $ map (>>= pcrlf) iters
+ let pcrlf = \s -> iterParser $ string "\r\n" >> return s
- iter <- e2 godzilla
+ let iters = replicate ntimes $ joinI $
+ readChunkedTransferEncoding sstep
+ godzilla <- runIteratee $ sequence $ map (>>= pcrlf) iters
- x <- liftM (map unWrap) $ run iter
+ 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
@@ -330,10 +262,24 @@ 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
assertEqual "foo1" (Just ["bar1"] ) $ Map.lookup "foo1" mp
assertEqual "foo2" (Just ["bar2 baz2"]) $ Map.lookup "foo2" mp
assertEqual "foo3" (Just ["foo bar"] ) $ Map.lookup "foo3" mp
+
+
+
+
+copyingStream2Stream = go []
+ where
+ go l = do
+ mbx <- I.head
+ maybe (return $ S.concat $ reverse l)
+ (\x -> let !z = S.copy x in go (z:l))
+ mbx
+
+stream2stream :: (Monad m) => Iteratee ByteString m L.ByteString
+stream2stream = liftM L.fromChunks consume
View
246 test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -24,10 +24,8 @@ 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.Typeable
@@ -46,8 +44,9 @@ import qualified Snap.Http.Server as Svr
import Snap.Internal.Debug
import Snap.Internal.Http.Types
import Snap.Internal.Http.Server
+import qualified Snap.Iteratee as I
+import Snap.Iteratee hiding (map)
import Snap.Internal.Http.Server.Backend
-import Snap.Iteratee
import Snap.Test.Common
import Snap.Types
@@ -138,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
@@ -204,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
@@ -233,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
@@ -255,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
@@ -277,35 +273,20 @@ 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
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
@@ -330,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)
@@ -382,7 +356,7 @@ sampleRequest3' =
-rsm :: ServerMonad a -> Iteratee IO a
+rsm :: ServerMonad a -> Iteratee ByteString IO a
rsm = runServerMonad "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58382 False) alog elog
where
alog = const . const . return $ ()
@@ -391,15 +365,12 @@ rsm = runServerMonad "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58382 F
testHttpResponse1 :: Test
testHttpResponse1 = testCase "server/HttpResponse1" $ do
- let onSendFile = \f start sz ->
- enumFilePartial f (start,start+sz) copyingStream2stream
- >>= run
-
- req <- mkRequest sampleRequest
+ 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 600 Test\r\n"
@@ -412,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"
@@ -438,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"
@@ -470,23 +442,22 @@ 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) })
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"
@@ -504,14 +475,14 @@ testHttpResponse4 = testCase "server/HttpResponse4" $ do
echoServer :: (ByteString -> IO ())
-> Request
- -> Iteratee IO (Request,Response)
+ -> Iteratee ByteString IO (Request,Response)
echoServer _ req = do