git.iko.soy/typeable/wai
on master help sign in
Merge branch 'buffer' into 'kazu-master'.
commitdb94f798464dba1c40fcf2cdbe8094454f6bbe34 authorKazu Yamamoto <kazu@iij.ad.jp> dateWed 10 Jun 2015, 16:22 (11 years ago) parent9de9805f840e0f
5 files changed+83−48
compare with master
unifiedsplit
warp-tls/Network/Wai/Handler/WarpTLS.hs+3−6 warp/Network/Wai/Handler/Warp/Buffer.hs+61−5 warp/Network/Wai/Handler/Warp/Recv.hs+12−30 warp/Network/Wai/Handler/Warp/Run.hs+4−4 warp/Network/Wai/Handler/Warp/Types.hs+3−3
warp-tls/Network/Wai/Handler/WarpTLS.hs+3−6
@@ -272,10 +272,9 @@ httpOverTls TLSSettings{..} s cachedRef params = do
272272 ctx <- TLS.contextNew backend params gen
273273 TLS.contextHookSetLogging ctx tlsLogging
274274 TLS.handshake ctx
275− readBuf <- allocateBuffer bufferSize
276275 writeBuf <- allocateBuffer bufferSize
277276 tls <- getTLSinfo ctx
278− return (conn ctx readBuf writeBuf, tls)
277+ return (conn ctx writeBuf, tls)
279278 where
280279 backend = TLS.Backend {
281280 TLS.backendFlush = return ()
@@ -283,14 +282,13 @@ httpOverTls TLSSettings{..} s cachedRef params = do
283282 , TLS.backendSend = sendAll s
284283 , TLS.backendRecv = recvTLS cachedRef s
285284 }
286− conn ctx readBuf writeBuf = Connection {
285+ conn ctx writeBuf = Connection {
287286 connSendMany = TLS.sendData ctx . L.fromChunks
288287 , connSendAll = TLS.sendData ctx . L.fromChunks . return
289288 , connSendFile = sendfile
290289 , connClose = close
291290 , connRecv = recv
292291 , connSendFileOverride = NotOverride
293− , connReadBuffer = readBuf
294292 , connWriteBuffer = writeBuf
295293 , connBufferSize = bufferSize
296294 }
@@ -310,8 +308,7 @@ httpOverTls TLSSettings{..} s cachedRef params = do
310308 void $ tickle' -- This tickles the Timer. It MUST be called per chunk.
311309 loop h $ remaining - B.length x
312310
313− close = freeBuffer readBuf `finally`
314− freeBuffer writeBuf `finally`
311+ close = freeBuffer writeBuf `finally`
315312 void (tryIO $ TLS.bye ctx) `finally`
316313 TLS.contextClose ctx
317314
warp/Network/Wai/Handler/Warp/Buffer.hs+61−5
@@ -1,17 +1,73 @@
11module Network.Wai.Handler.Warp.Buffer where
22
3+import Control.Monad (when)
34import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..))
45import Data.Word (Word8)
5−import Foreign.ForeignPtr (newForeignPtr_)
6−import Foreign.Marshal.Alloc (mallocBytes, free)
7−import Foreign.Ptr (Ptr, plusPtr)
6+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
7+import Data.ByteString (ByteString, empty, length)
8+import Data.ByteString.Internal (ByteString(PS), mallocByteString)
9+import Data.ByteString.Unsafe (unsafeTake, unsafeDrop)
10+import Foreign.ForeignPtr (newForeignPtr, newForeignPtr_, withForeignPtr)
11+import Foreign.Marshal.Alloc (mallocBytes, free, finalizerFree)
12+import Foreign.Ptr (Ptr, castPtr, plusPtr)
13+
14+largeBufferSize :: Int
15+largeBufferSize = 16384
16+minBufferSize :: Int
17+minBufferSize = 2048
18+
19+type BufferPool = IORef ByteString
20+
21+newBufferPool :: IO BufferPool
22+newBufferPool = newIORef Data.ByteString.empty
23+
24+mallocBuffer :: Int -> IO ByteString
25+mallocBuffer size = do
26+ ptr <- mallocBytes size
27+ fptr <- newForeignPtr finalizerFree ptr
28+ return $! PS fptr 0 size
29+{-# INLINE mallocBuffer #-}
30+
31+createBuffer :: Int -> IO ByteString
32+createBuffer size = do
33+ fptr <- mallocByteString size
34+ return $! PS fptr 0 size
35+{-# INLINE createBuffer #-}
36+
37+usefulBuffer :: ByteString -> Bool
38+usefulBuffer buffer = Data.ByteString.length buffer >= minBufferSize
39+{-# INLINE usefulBuffer #-}
40+
41+getBuffer :: BufferPool -> IO ByteString
42+getBuffer pool = do
43+ buffer <- readIORef pool
44+ if usefulBuffer buffer then return buffer else mallocBuffer largeBufferSize
45+{-# INLINE getBuffer #-}
46+
47+putBuffer :: BufferPool -> ByteString -> IO ()
48+putBuffer pool buffer = when (usefulBuffer buffer) $ writeIORef pool buffer
49+{-# INLINE putBuffer #-}
50+
51+withForeignBuffer :: ByteString -> ((Ptr Word8, Int) -> IO Int) -> IO Int
52+withForeignBuffer (PS ps s l) f = withForeignPtr ps $ \p -> f (castPtr p `plusPtr` s, l)
53+{-# INLINE withForeignBuffer #-}
54+
55+withBufferPool :: BufferPool -> ((Ptr Word8, Int) -> IO Int) -> IO ByteString
56+withBufferPool pool f = do
57+ buffer <- getBuffer pool
58+ consumed <- withForeignBuffer buffer f
59+ putBuffer pool $! unsafeDrop consumed buffer
60+ return $! unsafeTake consumed buffer
61+{-# INLINE withBufferPool #-}
862
963type Buffer = Ptr Word8
1064type BufSize = Int
1165
12−-- FIXME come up with good values here
66+-- 2^14 = 1024 * 16
67+-- The maximum size of TLS record
68+-- The maximum size of HTTP/2 frame payload (excluding frame header)
1369bufferSize :: BufSize
14−bufferSize = 4096
70+bufferSize = 16384
1571
1672allocateBuffer :: Int -> IO Buffer
1773allocateBuffer = mallocBytes
warp/Network/Wai/Handler/Warp/Recv.hs+12−30
@@ -8,18 +8,15 @@ module Network.Wai.Handler.Warp.Recv (
88#if __GLASGOW_HASKELL__ < 709
99import Control.Applicative ((<$>))
1010#endif
11−import Control.Monad (void)
12−import qualified Data.ByteString as BS (empty)
13−import Data.ByteString.Internal (ByteString(..), mallocByteString)
11+import Data.ByteString (ByteString)
1412import Data.Word (Word8)
1513import Foreign.C.Error (eAGAIN, getErrno, throwErrno)
1614import Foreign.C.Types
17−import Foreign.ForeignPtr (withForeignPtr)
1815import Foreign.Ptr (Ptr, castPtr)
1916import GHC.Conc (threadWaitRead)
2017import Network.Socket (Socket, fdSocket)
21−import System.Posix.Types (Fd(..))
2218import Network.Wai.Handler.Warp.Buffer
19+import System.Posix.Types (Fd(..))
2320
2421#ifdef mingw32_HOST_OS
2522import GHC.IO.FD (FD(..), readRawBufferPtr)
@@ -28,37 +25,25 @@ import Network.Wai.Handler.Warp.Windows
2825
2926----------------------------------------------------------------
3027
31−receive :: Socket -> Buffer -> Int -> IO ByteString
32−receive sock buf size = do
33− bytes <- fromIntegral <$> receiveloop sock' buf' size'
34− if bytes == 0 then
35− return BS.empty
36− else do
37− fptr <- mallocByteString bytes
38− void $ withForeignPtr fptr $ \ptr ->
39− c_memcpy ptr buf (fromIntegral bytes)
40− return $! PS fptr 0 bytes
41− where
42− sock' = fdSocket sock
43− buf' = castPtr buf
44− size' = fromIntegral size
28+receive :: Socket -> BufferPool -> IO ByteString
29+receive sock pool = withBufferPool pool $ \ (ptr, size) -> do
30+ let sock' = fdSocket sock
31+ size' = fromIntegral size
32+ received <- fromIntegral <$> receiveloop sock' ptr size'
33+ return received
4534
46−#ifdef mingw32_HOST_OS
4735receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt
48−#else
49−receiveloop :: CInt -> Ptr CChar -> CSize -> IO CInt
50−#endif
51−receiveloop sock buf size = do
36+receiveloop sock ptr size = do
5237#ifdef mingw32_HOST_OS
53− bytes <- windowsThreadBlockHack $ fmap fromIntegral $ readRawBufferPtr "recv" (FD sock 1) buf 0 size
38+ bytes <- windowsThreadBlockHack $ fmap fromIntegral $ readRawBufferPtr "recv" (FD sock 1) (castPtr ptr) 0 size
5439#else
55− bytes <- c_recv sock buf size 0
40+ bytes <- c_recv sock (castPtr ptr) size 0
5641#endif
5742 if bytes == -1 then do
5843 errno <- getErrno
5944 if errno == eAGAIN then do
6045 threadWaitRead (Fd sock)
61− receiveloop sock buf size
46+ receiveloop sock ptr size
6247 else
6348 throwErrno "receiveloop"
6449 else
@@ -67,6 +52,3 @@ receiveloop sock buf size = do
6752-- fixme: the type of the return value
6853foreign import ccall unsafe "recv"
6954 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
70−
71−foreign import ccall unsafe "string.h memcpy"
72− c_memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)
warp/Network/Wai/Handler/Warp/Run.hs+4−4
@@ -48,15 +48,15 @@ import Network.Socket (fdSocket)
4848-- | Default action value for 'Connection'.
4949socketConnection :: Socket -> IO Connection
5050socketConnection s = do
51− readBuf <- allocateBuffer bufferSize
51+ bufferPool <- newBufferPool
5252 writeBuf <- allocateBuffer bufferSize
5353 return Connection {
5454 connSendMany = Sock.sendMany s
5555 , connSendAll = Sock.sendAll s
5656 , connSendFile = defaultSendFile s
57− , connClose = sClose s >> freeBuffer readBuf >> freeBuffer writeBuf
58− , connRecv = receive s readBuf bufferSize
59− , connReadBuffer = readBuf
57+ , connClose = sClose s >> freeBuffer writeBuf
58+ , connRecv = receive s bufferPool
59+ , connBufferPool = bufferPool
6060 , connWriteBuffer = writeBuf
6161 , connBufferSize = bufferSize
6262 , connSendFileOverride = Override s
warp/Network/Wai/Handler/Warp/Types.hs+3−3
@@ -12,7 +12,7 @@ import Data.Typeable (Typeable)
1212import Data.Word (Word16)
1313import Network.HTTP.Types.Header
1414import Network.Socket (Socket)
15−import Network.Wai.Handler.Warp.Buffer (Buffer,BufSize)
15+import Network.Wai.Handler.Warp.Buffer (Buffer,BufSize,BufferPool)
1616import qualified Network.Wai.Handler.Warp.Date as D
1717import qualified Network.Wai.Handler.Warp.FdCache as F
1818import qualified Network.Wai.Handler.Warp.Timeout as T
@@ -79,9 +79,9 @@ data Connection = Connection
7979 , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO () -- ^ filepath, offset, length, hook action, HTTP headers
8080 , connClose :: IO ()
8181 , connRecv :: IO ByteString
82− , connReadBuffer :: Buffer
82+ , connBufferPool :: BufferPool
8383 , connWriteBuffer :: Buffer
84− , connBufferSize :: BufSize
84+ , connBufferSize :: BufSize -- ^ The size of 'connWriteBuffer'
8585 , connSendFileOverride :: ConnSendFileOverride
8686 }
8787