git.iko.soy/typeable/wai
on master help sign in
making use of copy and toBS.
commit8e8d88bf55607023c8da0f2803aea2997378d789 authorKazu Yamamoto <kazu@iij.ad.jp> dateTue 16 Jun 2015, 16:59 (11 years ago) parent2d425c8
4 files changed+45−45
compare with master
unifiedsplit
warp/Network/Wai/Handler/Warp/Buffer.hs+21−6 warp/Network/Wai/Handler/Warp/IO.hs+1−6 warp/Network/Wai/Handler/Warp/ResponseHeader.hs+2−10 warp/Network/Wai/Handler/Warp/SendFile.hs+21−23
warp/Network/Wai/Handler/Warp/Buffer.hs+21−6
@@ -1,14 +1,17 @@
1+{-# LANGUAGE BangPatterns #-}
2+
13module Network.Wai.Handler.Warp.Buffer where
24
35import Control.Monad (when)
4−import Data.ByteString (ByteString, empty, length)
5−import Data.ByteString.Internal (ByteString(PS), mallocByteString)
6+import qualified Data.ByteString as BS
7+import Data.ByteString.Internal
68import Data.ByteString.Unsafe (unsafeTake, unsafeDrop)
79import Data.IORef (newIORef, readIORef, writeIORef)
810import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..))
9−import Foreign.ForeignPtr (newForeignPtr, newForeignPtr_, withForeignPtr)
11+import Data.Word (Word8)
12+import Foreign.ForeignPtr
1013import Foreign.Marshal.Alloc (mallocBytes, free, finalizerFree)
11−import Foreign.Ptr (castPtr, plusPtr)
14+import Foreign.Ptr (Ptr, castPtr, plusPtr)
1215import Network.Wai.Handler.Warp.Types
1316
1417largeBufferSize :: Int
@@ -18,7 +21,7 @@ minBufferSize :: Int
1821minBufferSize = 2048
1922
2023newBufferPool :: IO BufferPool
21−newBufferPool = newIORef Data.ByteString.empty
24+newBufferPool = newIORef BS.empty
2225
2326mallocBuffer :: Int -> IO ByteString
2427mallocBuffer size = do
@@ -34,7 +37,7 @@ createBuffer size = do
3437{-# INLINE createBuffer #-}
3538
3639usefulBuffer :: ByteString -> Bool
37−usefulBuffer buffer = Data.ByteString.length buffer >= minBufferSize
40+usefulBuffer buffer = BS.length buffer >= minBufferSize
3841{-# INLINE usefulBuffer #-}
3942
4043getBuffer :: BufferPool -> IO ByteString
@@ -75,3 +78,15 @@ toBlazeBuffer :: Buffer -> BufSize -> IO B.Buffer
7578toBlazeBuffer ptr size = do
7679 fptr <- newForeignPtr_ ptr
7780 return $ B.Buffer fptr ptr ptr (ptr `plusPtr` size)
81+
82+{-# INLINE copy #-}
83+copy :: Ptr Word8 -> ByteString -> IO (Ptr Word8)
84+copy !ptr (PS fp o l) = withForeignPtr fp $ \p -> do
85+ memcpy ptr (p `plusPtr` o) (fromIntegral l)
86+ return $! ptr `plusPtr` l
87+
88+{-# INLINE toBS #-}
89+toBS :: Buffer -> Int -> IO ByteString
90+toBS ptr siz = do
91+ fptr <- newForeignPtr_ ptr
92+ return $ PS fptr 0 siz
warp/Network/Wai/Handler/Warp/IO.hs+1−6
@@ -4,7 +4,7 @@
44module Network.Wai.Handler.Warp.IO where
55
66import Data.ByteString.Internal (ByteString(..))
7−import Foreign.ForeignPtr (newForeignPtr_)
7+import Network.Wai.Handler.Warp.Buffer
88import Network.Wai.Handler.Warp.Types
99
1010-- Support for doctest, where cabal macros are not available
@@ -63,8 +63,3 @@ toBufIOWith buf !size io (Builder build) = loop firstStep
6363 loop next
6464
6565#endif /* !MIN_VERSION_blaze_builder(0,4,0) */
66−
67−toBS :: Buffer -> Int -> IO ByteString
68−toBS ptr siz = do
69− fptr <- newForeignPtr_ ptr
70− return $ PS fptr 0 siz
warp/Network/Wai/Handler/Warp/ResponseHeader.hs+2−10
@@ -6,14 +6,14 @@ module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where
66import Control.Monad
77import Data.ByteString (ByteString)
88import qualified Data.ByteString as S
9−import Data.ByteString.Internal (ByteString(..), create, memcpy)
9+import Data.ByteString.Internal (create)
1010import qualified Data.CaseInsensitive as CI
1111import Data.List (foldl')
1212import Data.Word (Word8)
13−import Foreign.ForeignPtr
1413import Foreign.Ptr
1514import GHC.Storable
1615import qualified Network.HTTP.Types as H
16+import Network.Wai.Handler.Warp.Buffer (copy)
1717
1818----------------------------------------------------------------
1919
@@ -27,12 +27,6 @@ composeHeader !httpversion !status !responseHeaders = create len $ \ptr -> do
2727 fieldLength !l !(k,v) = l + S.length (CI.original k) + S.length v + 4
2828 !slen = S.length $ H.statusMessage status
2929
30−{-# INLINE copy #-}
31−copy :: Ptr Word8 -> ByteString -> IO (Ptr Word8)
32−copy !ptr (PS fp o l) = withForeignPtr fp $ \p -> do
33− memcpy ptr (p `plusPtr` o) (fromIntegral l)
34− return $! ptr `plusPtr` l
35−
3630httpVer11 :: ByteString
3731httpVer11 = "HTTP/1.1 "
3832
@@ -90,5 +84,3 @@ cr :: Word8
9084cr = 13
9185lf :: Word8
9286lf = 10
93−
94−
warp/Network/Wai/Handler/Warp/SendFile.hs+21−23
@@ -6,10 +6,12 @@ module Network.Wai.Handler.Warp.SendFile (
66 , packHeader -- for testing
77 ) where
88
9+import Control.Monad (void)
10+import qualified Data.ByteString as BS
911import Data.ByteString.Internal
10−import Foreign.ForeignPtr (newForeignPtr_, withForeignPtr)
1112import Network.Sendfile
1213import Network.Socket (Socket)
14+import Network.Wai.Handler.Warp.Buffer
1315import Network.Wai.Handler.Warp.Types
1416
1517#ifdef WINDOWS
@@ -50,23 +52,21 @@ packHeader :: Buffer -> BufSize -> (ByteString -> IO ())
5052 -> Int
5153 -> IO Int
5254packHeader _ _ _ _ [] n = return n
53−packHeader buf siz send hook (PS bsfp off len : bss) n
54− | len < room = withForeignPtr bsfp $ \bsp -> do
55+packHeader buf siz send hook (bs:bss) n
56+ | len < room = do
5557 let dst = buf `plusPtr` n
56− src = bsp `plusPtr` off
57− memcpy dst src len
58+ void $ copy dst bs
5859 packHeader buf siz send hook bss (n + len)
59− | otherwise = withForeignPtr bsfp $ \bsp -> do
60+ | otherwise = do
6061 let dst = buf `plusPtr` n
61− src = bsp `plusPtr` off
62− memcpy dst src room
63− fptr <- newForeignPtr_ buf
64− let entire = PS fptr 0 siz
65− bs = PS bsfp (off + room) (len - room)
62+ (bs1, bs2) = BS.splitAt room bs
63+ void $ copy dst bs1
64+ entire <- toBS buf siz
6665 send entire
6766 hook
68− packHeader buf siz send hook (bs:bss) 0
67+ packHeader buf siz send hook (bs2:bss) 0
6968 where
69+ len = BS.length bs
7070 room = siz - n
7171
7272mini :: Int -> Integer -> Int
@@ -77,15 +77,14 @@ mini i n
7777#ifdef WINDOWS
7878readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile
7979readSendFile buf siz send fid off0 len0 hook headers = do
80− fptr <- newForeignPtr_ buf
8180 hn <- packHeader buf siz send hook headers 0
8281 let room = siz - hn
8382 buf' = buf `plusPtr` hn
8483 IO.withBinaryFile path IO.ReadMode $ \h -> do
8584 IO.hSeek h IO.AbsoluteSeek off0
8685 n <- IO.hGetBufSome h buf' (mini room len0)
87− let bs = PS fptr 0 (hn + n)
88− n' = fromIntegral n
86+ bs <- toBSD buf (hn + n)
87+ let n' = fromIntegral n
8988 send bs
9089 hook
9190 loop h fptr (len0 - n')
@@ -105,16 +104,15 @@ readSendFile buf siz send fid off0 len0 hook headers = do
105104readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile
106105readSendFile buf siz send fid off0 len0 hook headers =
107106 bracket setup teardown $ \fd -> do
108− fptr <- newForeignPtr_ buf
109107 hn <- packHeader buf siz send hook headers 0
110108 let room = siz - hn
111109 buf' = buf `plusPtr` hn
112110 n <- positionRead fd buf' (mini room len0) off0
113− let bs = PS fptr 0 (hn + n)
114− n' = fromIntegral n
111+ bs <- toBS buf (hn + n)
112+ let n' = fromIntegral n
115113 send bs
116114 hook
117− loop fd fptr (len0 - n') (off0 + n')
115+ loop fd (len0 - n') (off0 + n')
118116 where
119117 path = fileIdPath fid
120118 setup = case fileIdFd fid of
@@ -123,15 +121,15 @@ readSendFile buf siz send fid off0 len0 hook headers =
123121 teardown fd = case fileIdFd fid of
124122 Just _ -> return ()
125123 Nothing -> closeFd fd
126− loop fd fptr len off
124+ loop fd len off
127125 | len <= 0 = return ()
128126 | otherwise = do
129127 n <- positionRead fd buf (mini siz len) off
130− let bs = PS fptr 0 n
131− n' = fromIntegral n
128+ bs <- toBS buf n
129+ let n' = fromIntegral n
132130 send bs
133131 hook
134− loop fd fptr (len - n') (off + n')
132+ loop fd (len - n') (off + n')
135133
136134positionRead :: Fd -> Ptr Word8 -> Int -> Integer -> IO Int
137135positionRead (Fd fd) buf siz off =