diff --git a/Network/Wai/Handler/Warp/Buffer.hs b/Network/Wai/Handler/Warp/Buffer.hs --- a/Network/Wai/Handler/Warp/Buffer.hs +++ b/Network/Wai/Handler/Warp/Buffer.hs @@ -7,9 +7,10 @@ import Foreign.Ptr (Ptr, plusPtr) type Buffer = Ptr Word8 +type BufSize = Int -- FIXME come up with good values here -bufferSize :: Int +bufferSize :: BufSize bufferSize = 4096 allocateBuffer :: Int -> IO Buffer @@ -18,7 +19,7 @@ freeBuffer :: Buffer -> IO () freeBuffer = free -toBlazeBuffer :: Buffer -> Int -> IO B.Buffer +toBlazeBuffer :: Buffer -> BufSize -> IO B.Buffer toBlazeBuffer ptr size = do fptr <- newForeignPtr_ ptr return $ B.Buffer fptr ptr ptr (ptr `plusPtr` size) diff --git a/Network/Wai/Handler/Warp/IO.hs b/Network/Wai/Handler/Warp/IO.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/IO.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE BangPatterns #-} + +module Network.Wai.Handler.Warp.IO where + +import Blaze.ByteString.Builder.Internal.Types (Builder(..), BuildSignal(..), BufRange(..), runBuildStep, buildStep) +import Data.ByteString.Internal (ByteString(..)) +import Foreign.ForeignPtr (newForeignPtr_) +import Foreign.Ptr (plusPtr, minusPtr) +import Network.Wai.Handler.Warp.Buffer + +toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO () +toBufIOWith buf !size io (Builder build) = loop firstStep + where + firstStep = build (buildStep finalStep) + finalStep (BufRange p _) = return $ Done p () + bufRange = BufRange buf (buf `plusPtr` size) + runIO ptr = toBS buf (ptr `minusPtr` buf) >>= io + loop step = do + signal <- runBuildStep step bufRange + case signal of + Done ptr _ -> runIO ptr + BufferFull minSize ptr next + | size < minSize -> error "toBufIOWith: BufferFull: minSize" + | otherwise -> do + runIO ptr + loop next + InsertByteString ptr bs next -> do + runIO ptr + io bs + loop next + +toBS :: Buffer -> Int -> IO ByteString +toBS ptr siz = do + fptr <- newForeignPtr_ ptr + return $ PS fptr 0 siz diff --git a/Network/Wai/Handler/Warp/Response.hs b/Network/Wai/Handler/Warp/Response.hs --- a/Network/Wai/Handler/Warp/Response.hs +++ b/Network/Wai/Handler/Warp/Response.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Response ( sendResponse @@ -10,7 +11,7 @@ , defaultServerValue ) where -import Blaze.ByteString.Builder (fromByteString, Builder, toByteStringIO, flush) +import Blaze.ByteString.Builder (fromByteString, Builder, flush) import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator) import Control.Applicative import Control.Exception @@ -24,13 +25,19 @@ import Data.Function (on) import Data.List (deleteBy) import Data.Maybe (isJust, listToMaybe) +#if MIN_VERSION_base(4,5,0) +import Data.Monoid ((<>)) +#else import Data.Monoid (mappend) +#endif import Data.Version (showVersion) import Network.HTTP.Attoparsec (parseByteRanges) import qualified Network.HTTP.Types as H import Network.Wai import qualified Network.Wai.Handler.Warp.Date as D import Network.Wai.Handler.Warp.Header +import Network.Wai.Handler.Warp.Buffer (toBlazeBuffer) +import Network.Wai.Handler.Warp.IO (toBufIOWith) import Network.Wai.Handler.Warp.ResponseHeader import qualified Network.Wai.Handler.Warp.Timeout as T import Network.Wai.Handler.Warp.Types @@ -39,6 +46,11 @@ import qualified Paths_warp import qualified System.PosixCompat.Files as P +#if !MIN_VERSION_base(4,5,0) +(<>) :: Monoid m => m -> m -> m +(<>) = mappend +#endif + -- $setup -- >>> :set -XOverloadedStrings @@ -199,20 +211,22 @@ ---------------------------------------------------------------- -sendRsp conn ver s hs (RspBuilder b needsChunked) = do +sendRsp conn ver s hs (RspBuilder body needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked - let body - | needsChunked = header `mappend` chunkedTransferEncoding b - `mappend` chunkedTransferTerminator - | otherwise = header `mappend` b - flip toByteStringIO body $ \bs -> connSendAll conn bs + let hdrBdy + | needsChunked = header <> chunkedTransferEncoding body + <> chunkedTransferTerminator + | otherwise = header <> body + buffer = connBuffer conn + size = connBufferSize conn + toBufIOWith buffer size (connSendAll conn) hdrBdy ---------------------------------------------------------------- sendRsp conn ver s hs (RspSource withBodyFlush needsChunked th) = withBodyFlush $ \bodyFlush -> do header <- composeHeaderBuilder ver s hs needsChunked let src = yield header >> cbody bodyFlush - buffer = connBuffer conn + buffer <- toBlazeBuffer (connBuffer conn) (connBufferSize conn) src $$ unsafeBuilderToByteString (return buffer) =$ connSink conn th where cbody bodyFlush = if needsChunked then body $= chunk else body diff --git a/Network/Wai/Handler/Warp/Run.hs b/Network/Wai/Handler/Warp/Run.hs --- a/Network/Wai/Handler/Warp/Run.hs +++ b/Network/Wai/Handler/Warp/Run.hs @@ -45,14 +45,14 @@ socketConnection :: Socket -> IO Connection socketConnection s = do buf <- allocateBuffer bufferSize - blazeBuf <- toBlazeBuffer buf bufferSize return Connection { connSendMany = Sock.sendMany s , connSendAll = Sock.sendAll s , connSendFile = defaultSendFile s , connClose = sClose s >> freeBuffer buf , connRecv = receive s buf bufferSize - , connBuffer = blazeBuf + , connBuffer = buf + , connBufferSize = bufferSize , connSendFileOverride = Override s } diff --git a/Network/Wai/Handler/Warp/Types.hs b/Network/Wai/Handler/Warp/Types.hs --- a/Network/Wai/Handler/Warp/Types.hs +++ b/Network/Wai/Handler/Warp/Types.hs @@ -9,10 +9,10 @@ import Data.Typeable (Typeable) import Network.HTTP.Types.Header import Network.Socket (Socket) -import qualified Blaze.ByteString.Builder.Internal.Buffer as B (Buffer) import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F import qualified Network.Wai.Handler.Warp.Timeout as T +import Network.Wai.Handler.Warp.Buffer (Buffer,BufSize) ---------------------------------------------------------------- @@ -66,7 +66,8 @@ , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO () -- ^ filepath, offset, length, hook action, HTTP headers , connClose :: IO () , connRecv :: IO ByteString - , connBuffer :: B.Buffer + , connBuffer :: Buffer + , connBufferSize :: BufSize , connSendFileOverride :: ConnSendFileOverride } diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 2.0.1 +Version: 2.0.2 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE @@ -59,6 +59,7 @@ Network.Wai.Handler.Warp.Date Network.Wai.Handler.Warp.FdCache Network.Wai.Handler.Warp.Header + Network.Wai.Handler.Warp.IO Network.Wai.Handler.Warp.IORef Network.Wai.Handler.Warp.ReadInt Network.Wai.Handler.Warp.Recv