git.iko.soy/typeable/wai
on master help sign in
implementing preadSendFile.
f70fe24Kazu Yamamoto
warp/Network/Wai/Handler/Warp/SendFile.hs+84−9
compare with master
unifiedsplit
@@ -1,16 +1,23 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
2
2
3module Network.Wai.Handler.Warp.SendFile where
3module Network.Wai.Handler.Warp.SendFile where
4
4
5import Control.Monad (when, void)
5import Control.Monad (when, void)
6import Data.ByteString.Internal
6import Data.ByteString.Internal
7+import Data.Word (Word8)
7−import Foreign.ForeignPtr (newForeignPtr_)
8+import Foreign.ForeignPtr (newForeignPtr_, withForeignPtr)
8import Network.Sendfile
9import Network.Sendfile
9import Network.Socket (Socket)
10import Network.Socket (Socket)
10import Network.Wai.Handler.Warp.Buffer
11import Network.Wai.Handler.Warp.Buffer
11import Network.Wai.Handler.Warp.Types
12import Network.Wai.Handler.Warp.Types
12import qualified System.IO as IO
13import qualified System.IO as IO
13
14
15+#ifndef WINDOWS
16+import Foreign.C.Types
17+import Foreign.Ptr (Ptr, castPtr, plusPtr)
18+import System.Posix.Types
19+#endif
20+
14defaultSendFile :: Socket -> SendFile
21defaultSendFile :: Socket -> SendFile
15#ifdef SENDFILEFD
22#ifdef SENDFILEFD
16defaultSendFile s fid off len act hdr = case mfid of
23defaultSendFile s fid off len act hdr = case mfid of
@@ -26,20 +33,88 @@ defaultSendFile s fid off len act hdr =
26 path = fileIdPath fid
33 path = fileIdPath fid
27#endif
34#endif
28
35
36+packHeader :: Buffer -> BufSize -> (ByteString -> IO ())
37+ -> IO () -> [ByteString]
38+ -> Int
39+ -> IO Int
40+packHeader _ _ _ _ [] n = return n
41+packHeader buf siz send hook (PS bsfp off len : bss) n
42+ | len < room = withForeignPtr bsfp $ \bsp -> do
43+ let dst = buf `plusPtr` n
44+ src = bsp `plusPtr` off
45+ memcpy dst src len
46+ packHeader buf siz send hook bss (n + len)
47+ | otherwise = withForeignPtr bsfp $ \bsp -> do
48+ let dst = buf `plusPtr` n
49+ src = bsp `plusPtr` off
50+ memcpy dst src room
51+ fptr <- newForeignPtr_ buf
52+ let entire = PS fptr 0 siz
53+ bs = PS bsfp (off + room) (len - room)
54+ send entire
55+ hook
56+ packHeader buf siz send hook (bs:bss) 0
57+ where
58+ room = siz - n
59+
29readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile
60readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile
30−readSendFile buf siz send fid offset len hook headers = do
61+readSendFile buf siz send fid off0 len0 hook headers = do
31− mapM_ send headers
32 fptr <- newForeignPtr_ buf
62 fptr <- newForeignPtr_ buf
63+ hn <- packHeader buf siz send hook headers 0
64+ let room = siz - hn
65+ buf' = buf `plusPtr` hn
33 IO.withBinaryFile path IO.ReadMode $ \h -> do
66 IO.withBinaryFile path IO.ReadMode $ \h -> do
34− IO.hSeek h IO.AbsoluteSeek offset
67+ IO.hSeek h IO.AbsoluteSeek off0
68+ n <- IO.hGetBufSome h buf' room
69+ let bs = PS fptr 0 (hn + n)
35− loop fptr h $ fromIntegral len
70+ len = len0 - fromIntegral n
71+ send bs
72+ hook
73+ loop fptr h len
36 where
74 where
37 path = fileIdPath fid
75 path = fileIdPath fid
38− loop _ _ remaining | remaining <= 0 = return ()
76+ loop fptr h len
39− loop fptr h remaining = do
77+ | len <= 0 = return ()
78+ | otherwise = do
40 n <- IO.hGetBufSome h buf siz
79 n <- IO.hGetBufSome h buf siz
41 when (n /= 0) $ do
80 when (n /= 0) $ do
42 let bs = PS fptr 0 n
81 let bs = PS fptr 0 n
43 send bs
82 send bs
44 void $ hook
83 void $ hook
45− loop fptr h $ remaining - n
84+ loop fptr h $ len - fromIntegral n
85+
86+#ifndef WINDOWS
87+preadSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile
88+preadSendFile buf siz send fid off0 len0 hook headers = do
89+ fptr <- newForeignPtr_ buf
90+ hn <- packHeader buf siz send hook headers 0
91+ let room = siz - hn
92+ buf' = buf `plusPtr` hn
93+ n <- positionRead fd buf' (mini room len0) off0
94+ let bs = PS fptr 0 (hn + n)
95+ n' = fromIntegral n
96+ send bs
97+ hook
98+ loop fptr (len0 - n') (off0 + n')
99+ where
100+ Just fd = fileIdFd fid -- fixme
101+ mini i n
102+ | fromIntegral i < n = i
103+ | otherwise = fromIntegral n
104+ loop fptr len off
105+ | len <= 0 = return ()
106+ | otherwise = do
107+ n <- positionRead fd buf (mini siz len) off
108+ let bs = PS fptr 0 n
109+ n' = fromIntegral n
110+ send bs
111+ hook
112+ loop fptr (len - n') (off + n')
113+
114+positionRead :: Fd -> Ptr Word8 -> Int -> Integer -> IO Int
115+positionRead (Fd fd) buf siz off =
116+ fromIntegral <$> c_pread fd (castPtr buf) (fromIntegral siz) (fromIntegral off)
117+
118+foreign import ccall unsafe "pread"
119+ c_pread :: CInt -> Ptr CChar -> ByteCount -> FileOffset -> IO ByteCount -- fixme
120+#endif