@@ -1,16 +1,23 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
22
33module Network.Wai.Handler.Warp.SendFile where
44
55import Control.Monad (when, void)
66import Data.ByteString.Internal
7−import Foreign.ForeignPtr (newForeignPtr_)
7+import Data.Word (Word8)
8+import Foreign.ForeignPtr (newForeignPtr_, withForeignPtr)
89import Network.Sendfile
910import Network.Socket (Socket)
1011import Network.Wai.Handler.Warp.Buffer
1112import Network.Wai.Handler.Warp.Types
1213import qualified System.IO as IO
1314
15+#ifndef WINDOWS
16+import Foreign.C.Types
17+import Foreign.Ptr (Ptr, castPtr, plusPtr)
18+import System.Posix.Types
19+#endif
20+
1421defaultSendFile :: Socket -> SendFile
1522#ifdef SENDFILEFD
1623defaultSendFile s fid off len act hdr = case mfid of
@@ -26,20 +33,88 @@ defaultSendFile s fid off len act hdr =
2633 path = fileIdPath fid
2734#endif
2835
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+
2960readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile
30−readSendFile buf siz send fid offset len hook headers = do
31− mapM_ send headers
61+readSendFile buf siz send fid off0 len0 hook headers = do
3262 fptr <- newForeignPtr_ buf
63+ hn <- packHeader buf siz send hook headers 0
64+ let room = siz - hn
65+ buf' = buf `plusPtr` hn
3366 IO.withBinaryFile path IO.ReadMode $ \h -> do
34− IO.hSeek h IO.AbsoluteSeek offset
35− loop fptr h $ fromIntegral len
67+ IO.hSeek h IO.AbsoluteSeek off0
68+ n <- IO.hGetBufSome h buf' room
69+ let bs = PS fptr 0 (hn + n)
70+ len = len0 - fromIntegral n
71+ send bs
72+ hook
73+ loop fptr h len
3674 where
3775 path = fileIdPath fid
38− loop _ _ remaining | remaining <= 0 = return ()
39− loop fptr h remaining = do
76+ loop fptr h len
77+ | len <= 0 = return ()
78+ | otherwise = do
4079 n <- IO.hGetBufSome h buf siz
4180 when (n /= 0) $ do
4281 let bs = PS fptr 0 n
4382 send bs
4483 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