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 created
at 421c907b2befe00bbf2d7ae90e9d8d1c3eb3c9b8 (commit)
- Log -----------------------------------------------------------------
commit 421c907b2befe00bbf2d7ae90e9d8d1c3eb3c9b8
Author: Gregory Collins <[email protected]>
Date: Sun Nov 21 16:03:43 2010 +0100
Compiles with libev backend now
diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs
index a0f0beb..4621508 100644
--- a/src/Snap/Http/Server/Config.hs
+++ b/src/Snap/Http/Server/Config.hs
@@ -48,7 +48,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
@@ -173,7 +173,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
}
diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs
index 15d4b66..4902d65 100644
--- a/src/Snap/Internal/Http/Parser.hs
+++ b/src/Snap/Internal/Http/Parser.hs
@@ -8,7 +8,7 @@ module Snap.Internal.Http.Parser
( IRequest(..)
, parseRequest
, readChunkedTransferEncoding
- , parserToIteratee
+ , iterParser
, parseCookie
, parseUrlEncoded
, writeChunkedTransferEncoding
@@ -40,10 +40,11 @@ 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
-import Snap.Iteratee hiding (take, map)
+import Snap.Iteratee hiding (map, take)
------------------------------------------------------------------------------
@@ -69,18 +70,15 @@ instance Show IRequest where
------------------------------------------------------------------------------
-parseRequest :: (Monad m) => Iteratee m (Maybe IRequest)
+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 (iterParser pGetTransferChunk)
- iter
- return i
+ Enumeratee ByteString ByteString m a
+readChunkedTransferEncoding =
+ chunkParserToEnumeratee (iterParser pGetTransferChunk)
------------------------------------------------------------------------------
@@ -107,6 +105,8 @@ toHex n' = s
-- chunked transfer-encoding. Example usage:
--
--
+-- > FIXME this text is now wrong
+--
-- > > (writeChunkedTransferEncoding
-- > (enumLBS (L.fromChunks ["foo","bar","quux"]))
-- > stream2stream) >>=
@@ -115,98 +115,76 @@ 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 :: (Monad m) =>
+ Iteratee ByteString m (Maybe ByteString)
+ -> Enumeratee ByteString ByteString m a
+chunkParserToEnumeratee getChunk client = do
mbB <- getChunk
- maybe (finishIt client) (sendBS client) mbB
+ maybe finishIt sendBS mbB
where
- sendBS iter s = do
- v <- lift $ runIter iter (Chunk $ toWrap $ L.fromChunks [s])
-
- case v of
- (Done _ (EOF (Just e))) -> throwErr e
-
- (Done x _) -> return x
-
- (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
-
- sendEof iter = do
- v <- runIter iter (EOF Nothing)
+ sendBS s = do
+ step' <- lift $ runIteratee $ enumBS s client
+ 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
------------------------------------------------------------------------------
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index e099cda..e09d3b7 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -37,11 +37,11 @@ import System.Posix.Types (FileOffset)
import Text.Show.ByteString hiding (runPut)
------------------------------------------------------------------------------
import System.FastLogger
-import Snap.Internal.Http.Types hiding (Enumerator)
+import Snap.Internal.Http.Types
import Snap.Internal.Http.Parser
import Snap.Internal.Http.Server.Date
import Snap.Internal.Iteratee.Debug
-import Snap.Iteratee hiding (foldl', head, take, mapM_, FileOffset)
+import Snap.Iteratee hiding (head, take, map)
import qualified Snap.Iteratee as I
#ifdef LIBEV
@@ -65,9 +65,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 ServerState = ServerState
{ _forceConnectionClose :: Bool
@@ -90,7 +90,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 lip lp rip rp la le m = evalStateT m st
where
st = ServerState False lh lip lp rip rp la le
@@ -278,8 +278,8 @@ runHTTP :: ByteString -- ^ local host
name
-> Int -- ^ remote port
-> Maybe Logger -- ^ access logger
-> Maybe Logger -- ^ error logger
- -> 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
@@ -304,7 +304,9 @@ runHTTP lh lip lp rip rp alog elog
httpSession writeEnd buf onSendFile tickle
handler
let iter = iterateeDebugWrapper "httpSession iteratee" iter1
- readEnd iter >>= run
+
+ step <- liftIO $ runIteratee iter
+ run_ $ readEnd step
debug "runHTTP/go: finished"
@@ -330,7 +332,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
@@ -339,9 +341,11 @@ 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
@@ -377,8 +381,10 @@ httpSession writeEnd' ibuf onSendFile tickle handler = do
srqEnum <- liftIO $ readIORef $ rqBody req'
let (SomeEnumerator rqEnum) = srqEnum
- lift $ joinIM
- $ rqEnum (iterateeDebugWrapper "httpSession/skipToEof"
skipToEof)
+
+ skipStep <- liftIO $ runIteratee $
+ iterateeDebugWrapper "httpSession/skipToEof" skipToEof
+ lift $ rqEnum skipStep
liftIO $ debug $ "Server.httpSession: request body skipped, " ++
"sending response"
@@ -408,7 +414,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
@@ -426,8 +432,8 @@ 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 ()
------------------------------------------------------------------------------
@@ -463,7 +469,7 @@ receiveRequest = do
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
@@ -473,27 +479,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
+ e :: Enumerator ByteString IO a
+ e st = do
+ st' <- lift $
+ runIteratee $
+ iterateeDebugWrapper "rqBody iterator" $
+ returnI st
- noContentLength :: ServerMonad ()
- noContentLength = do
- liftIO $ debug ("receiveRequest/setEnumerator: " ++
- "request did NOT have content-length")
+ joinI $ takeExactly len st'
- -- FIXME: should we not just read everything?
- let e = return . joinI . I.take 0
-
- 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
@@ -520,18 +527,21 @@ 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 <- lift $ 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 >==> enumEOF
+ 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 }
@@ -550,7 +560,7 @@ receiveRequest = do
(Map.lookup "host" hdrs))
-- will override in "setEnumerator"
- enum <- liftIO $ newIORef $ SomeEnumerator return
+ enum <- liftIO $ newIORef $ SomeEnumerator (enumBS "")
return $ Request serverName
@@ -610,8 +620,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'
@@ -630,26 +641,41 @@ sendResponse req rsp' writeEnd onSendFile = do
--------------------------------------------------------------------------
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 >==> enumEOF
let hl = fromIntegral $ S.length hs
debug $ "sendResponse: whenEnum: enumerating bytes"
- (x,bs) <- joinIM $ enum (countBytes writeEnd)
+
+ outstep <- lift $ runIteratee $ 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
@@ -711,8 +737,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' <- takeExactly cl step
+ enum step'
--------------------------------------------------------------------------
diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs
b/src/Snap/Internal/Http/Server/LibevBackend.hs
index d5dd7dc..03d7da4 100644
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -33,14 +33,14 @@ module Snap.Internal.Http.Server.LibevBackend
---------------------------
------------------------------------------------------------------------------
-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, w2c)
-import qualified Data.ByteString.Unsafe as B
-import qualified Data.ByteString as B
+import qualified Data.ByteString.Unsafe as S
+import qualified Data.ByteString as S
import Data.IORef
import Data.Typeable
import Foreign hiding (new)
@@ -55,7 +55,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
@@ -324,7 +324,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)
@@ -606,7 +606,7 @@ getHostAddr :: Int
getHostAddr p s = do
h <- if s == "*"
then return iNADDR_ANY
- else inet_addr (map w2c . B.unpack $ s)
+ else inet_addr (map w2c . S.unpack $ s)
return $ SockAddrInet (fromIntegral p) h
@@ -654,7 +654,7 @@ recvData conn n = do
if sz == 0
then return ""
- else B.packCStringLen ((castPtr cstr),(fromEnum sz))
+ else S.packCStringLen ((castPtr cstr),(fromEnum sz))
where
io = _connReadIOObj conn
@@ -689,9 +689,9 @@ recvData conn n = do
sendData :: Connection -> ByteString -> IO ()
sendData conn bs = do
- let len = B.length bs
+ let len = S.length bs
dbg $ "entered w/ " ++ show len ++ " bytes"
- written <- B.unsafeUseAsCString bs $ \cstr ->
+ written <- S.unsafeUseAsCString bs $ \cstr ->
throwErrnoIfMinus1RetryMayBlock
"sendData"
(c_write fd cstr (toEnum len))
@@ -701,14 +701,14 @@ sendData conn bs = do
tickleTimeout conn
let n = fromEnum written
- let last10 = B.drop (n-10) $ B.take n bs
+ let last10 = S.drop (n-10) $ S.take n bs
dbg $ "wrote " ++ show written ++ " bytes, last 10='" ++ show last10 ++ "'"
if n < len
then do
dbg $ "short write, need to write " ++ show (len-n) ++ " more bytes"
- sendData conn $ B.drop n bs
+ sendData conn $ S.drop n bs
else return ()
where
@@ -740,27 +740,32 @@ sendData conn bs = do
dbg "waitForLock: took mvar"
-getReadEnd :: Connection -> Enumerator IO a
+getReadEnd :: Connection -> Enumerator ByteString IO a
getReadEnd = enumerate
-getWriteEnd :: Connection -> Iteratee IO ()
+getWriteEnd :: Connection -> Iteratee ByteString IO ()
getWriteEnd = writeOut
-enumerate :: (MonadIO m) => Connection -> Enumerator m a
+enumerate :: (MonadIO m) => Connection -> Enumerator ByteString m a
enumerate conn = loop
where
- recvIt = liftIO . recvData conn bLOCKSIZE
+ recvIt :: (MonadIO m) => Iteratee ByteString m ByteString
+ recvIt = liftIO $ recvData conn bLOCKSIZE
loop f = 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 B.null s
+ let iter = if S.null s
then enumEOF f
- else enumBS f s
+ else enumBS s f
f' <- lift $ runIteratee iter
case f' of
@@ -769,7 +774,7 @@ enumerate conn = loop
(Error e) -> throwError e
-writeOut :: (MonadIO m) => Connection -> Iteratee m ()
+writeOut :: (MonadIO m) => Connection -> Iteratee ByteString m ()
writeOut conn = loop
where
sendIt = liftIO . sendData conn
commit 0b48ca4a2b5026038675638243add0f32a0aaf7f
Author: Gregory Collins <[email protected]>
Date: Tue Nov 16 08:25:15 2010 +0100
Checkpoint
diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs
index 2510ae2..15d4b66 100644
--- a/src/Snap/Internal/Http/Parser.hs
+++ b/src/Snap/Internal/Http/Parser.hs
@@ -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,7 +34,6 @@ 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)
@@ -43,8 +42,8 @@ import Data.Vector.Unboxed (Vector)
import Data.Word (Word8, Word64)
import Prelude hiding (take, takeWhile)
------------------------------------------------------------------------------
-import Snap.Internal.Http.Types hiding (Enumerator)
-import Snap.Iteratee hiding (take, foldl', filter)
+import Snap.Internal.Http.Types
+import Snap.Iteratee hiding (take, map)
------------------------------------------------------------------------------
@@ -71,7 +70,7 @@ instance Show IRequest where
------------------------------------------------------------------------------
parseRequest :: (Monad m) => Iteratee m (Maybe IRequest)
-parseRequest = parserToIteratee pRequest
+parseRequest = iterParser pRequest
------------------------------------------------------------------------------
@@ -79,7 +78,7 @@ readChunkedTransferEncoding :: (Monad m) =>
Iteratee m a
-> m (Iteratee m a)
readChunkedTransferEncoding iter = do
- i <- chunkParserToEnumerator (parserToIteratee pGetTransferChunk)
+ i <- chunkParserToEnumerator (iterParser pGetTransferChunk)
iter
return i
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 2683a97..e099cda 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -22,7 +22,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)
diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs
b/src/Snap/Internal/Http/Server/LibevBackend.hs
index fdb8cb9..d5dd7dc 100644
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -42,7 +42,6 @@ import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString as B
import Data.IORef
-import Data.Iteratee.WrappedByteString
import Data.Typeable
import Foreign hiding (new)
import Foreign.C.Error
@@ -750,31 +749,35 @@ getWriteEnd = writeOut
enumerate :: (MonadIO m) => Connection -> Enumerator m a
-enumerate = loop
+enumerate conn = loop
where
- loop conn f = do
- s <- liftIO $ recvData conn bLOCKSIZE
- sendOne conn f s
+ recvIt = liftIO . recvData conn bLOCKSIZE
- sendOne conn f s = do
- v <- runIter f (if B.null s
- then EOF Nothing
- else Chunk $ WrapBS s)
- case v of
- r@(Done _ _) -> return $ liftI r
- (Cont k Nothing) -> loop conn k
- (Cont _ (Just e)) -> return $ throwErr e
+ loop f = do
+ s <- recvIt
+ sendOne f s
+
+ sendOne f s = do
+ let iter = if B.null s
+ then enumEOF f
+ else enumBS f s
+ f' <- lift $ runIteratee iter
+
+ case f' of
+ (Yield x st) -> yield x st
+ r@(Continue _) -> loop r
+ (Error e) -> throwError e
writeOut :: (MonadIO m) => Connection -> Iteratee m ()
-writeOut conn = IterateeG out
+writeOut conn = loop
where
- out c@(EOF _) = return $ Done () c
-
- out (Chunk s) = do
- let x = unWrap s
+ sendIt = liftIO . sendData conn
- liftIO $ sendData conn x
+ loop = continue k
- return $ Cont (writeOut conn) Nothing
+ k EOF = yield () EOF
+ k (Chunks xs) = do
+ sendIt $ S.concat xs
+ loop
commit 2c5c2df962ae8746d08f9a1ef00bed4e8cebe7d7
Author: Gregory Collins <[email protected]>
Date: Tue Nov 16 08:10:32 2010 +0100
Change cabal deps
diff --git a/snap-server.cabal b/snap-server.cabal
index cff0183..1ef8480 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-iteratee >= 0.1.1 && <0.2,
+ attoparsec-enumerator == 0.2.*,
base >= 4 && < 5,
binary >=0.5 && <0.6,
bytestring,
@@ -117,10 +117,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,
diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal
index 4365796..456fd2b 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-iteratee >= 0.1.1 && <0.2,
+ attoparsec-enumerator == 0.2.*,
base >= 4 && < 5,
binary >= 0.5 && < 0.6,
bytestring,
@@ -29,17 +29,17 @@ Executable testsuite
containers,
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,
- iteratee >= 0.3.1 && < 0.4,
snap-core >= 0.3 && <0.4,
template-haskell,
test-framework >= 0.3.1 && <0.4,
@@ -80,7 +80,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.*,
base >= 4 && < 5,
bytestring,
bytestring-nums >= 0.3.1 && < 0.4,
@@ -89,13 +89,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,
@@ -158,7 +158,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.*,
base >= 4 && < 5,
binary >= 0.5 && < 0.6,
bytestring,
@@ -167,12 +167,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,
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
