@@ -1,29 +1,143 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
22
3−module Network.Wai.Handler.Warp.SendFile where
3+module Network.Wai.Handler.Warp.SendFile (
4+ defaultSendFile
5+ , readSendFile
6+ , packHeader -- for testing
7+ ) where
48
5−import Data.ByteString (ByteString)
9+import Data.ByteString.Internal
10+import Foreign.ForeignPtr (newForeignPtr_, withForeignPtr)
611import Network.Sendfile
712import Network.Socket (Socket)
8−import qualified Network.Wai.Handler.Warp.FdCache as F
13+import Network.Wai.Handler.Warp.Buffer
914import Network.Wai.Handler.Warp.Types
1015
11−defaultSendFile :: Socket -> FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO ()
12−defaultSendFile s path off len act hdr = sendfileWithHeader s path (PartOfFile off len) act hdr
16+#ifdef WINDOWS
17+import Control.Monad (when)
18+import qualified System.IO as IO
19+import Foreign.Ptr (plusPtr)
20+#else
21+# if __GLASGOW_HASKELL__ < 709
22+import Control.Applicative ((<$>))
23+# endif
24+import Data.Word (Word8)
25+import Control.Exception
26+import Foreign.C.Types
27+import Foreign.Ptr (Ptr, castPtr, plusPtr)
28+import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)
29+import System.Posix.Types
30+#endif
31+
32+----------------------------------------------------------------
1333
34+defaultSendFile :: Socket -> Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile
35+#ifdef SENDFILEFD
36+defaultSendFile s _ _ _ fid off len act hdr = case mfid of
37+ -- settingsFdCacheDuration is 0
38+ Nothing -> sendfileWithHeader s path (PartOfFile off len) act hdr
39+ Just fd -> sendfileFdWithHeader s fd (PartOfFile off len) act hdr
40+ where
41+ mfid = fileIdFd fid
42+ path = fileIdPath fid
43+#else
44+defaultSendFile _ = readSendFile
45+#endif
1446
15−#if SENDFILEFD
16−setSendFile :: Connection -> Maybe F.MutableFdCache -> Connection
17−setSendFile conn Nothing = conn
18−setSendFile conn (Just fdcs) = case connSendFileOverride conn of
19− NotOverride -> conn
20− Override s -> conn { connSendFile = sendFile fdcs s }
47+----------------------------------------------------------------
2148
22−sendFile :: F.MutableFdCache -> Socket -> FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO ()
23−sendFile fdcs s path off len act hdr = do
24− (fd, fresher) <- F.getFd fdcs path
25− sendfileFdWithHeader s fd (PartOfFile off len) (act>>fresher) hdr
49+packHeader :: Buffer -> BufSize -> (ByteString -> IO ())
50+ -> IO () -> [ByteString]
51+ -> Int
52+ -> IO Int
53+packHeader _ _ _ _ [] n = return n
54+packHeader buf siz send hook (PS bsfp off len : bss) n
55+ | len < room = withForeignPtr bsfp $ \bsp -> do
56+ let dst = buf `plusPtr` n
57+ src = bsp `plusPtr` off
58+ memcpy dst src len
59+ packHeader buf siz send hook bss (n + len)
60+ | otherwise = withForeignPtr bsfp $ \bsp -> do
61+ let dst = buf `plusPtr` n
62+ src = bsp `plusPtr` off
63+ memcpy dst src room
64+ fptr <- newForeignPtr_ buf
65+ let entire = PS fptr 0 siz
66+ bs = PS bsfp (off + room) (len - room)
67+ send entire
68+ hook
69+ packHeader buf siz send hook (bs:bss) 0
70+ where
71+ room = siz - n
72+
73+mini :: Int -> Integer -> Int
74+mini i n
75+ | fromIntegral i < n = i
76+ | otherwise = fromIntegral n
77+
78+#ifdef WINDOWS
79+readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile
80+readSendFile buf siz send fid off0 len0 hook headers = do
81+ fptr <- newForeignPtr_ buf
82+ hn <- packHeader buf siz send hook headers 0
83+ let room = siz - hn
84+ buf' = buf `plusPtr` hn
85+ IO.withBinaryFile path IO.ReadMode $ \h -> do
86+ IO.hSeek h IO.AbsoluteSeek off0
87+ n <- IO.hGetBufSome h buf' (mini room len0)
88+ let bs = PS fptr 0 (hn + n)
89+ n' = fromIntegral n
90+ send bs
91+ hook
92+ loop h fptr (len0 - n')
93+ where
94+ path = fileIdPath fid
95+ loop h fptr len
96+ | len <= 0 = return ()
97+ | otherwise = do
98+ n <- IO.hGetBufSome h buf (mini siz len)
99+ when (n /= 0) $ do
100+ let bs = PS fptr 0 n
101+ n' = fromIntegral n
102+ send bs
103+ hook
104+ loop h fptr (len - n')
26105#else
27−setSendFile :: Connection -> Maybe F.MutableFdCache -> Connection
28−setSendFile conn _ = conn
106+readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile
107+readSendFile buf siz send fid off0 len0 hook headers =
108+ bracket setup teardown $ \fd -> do
109+ fptr <- newForeignPtr_ buf
110+ hn <- packHeader buf siz send hook headers 0
111+ let room = siz - hn
112+ buf' = buf `plusPtr` hn
113+ n <- positionRead fd buf' (mini room len0) off0
114+ let bs = PS fptr 0 (hn + n)
115+ n' = fromIntegral n
116+ send bs
117+ hook
118+ loop fd fptr (len0 - n') (off0 + n')
119+ where
120+ path = fileIdPath fid
121+ setup = case fileIdFd fid of
122+ Just fd -> return fd
123+ Nothing -> openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}
124+ teardown fd = case fileIdFd fid of
125+ Just _ -> return ()
126+ Nothing -> closeFd fd
127+ loop fd fptr len off
128+ | len <= 0 = return ()
129+ | otherwise = do
130+ n <- positionRead fd buf (mini siz len) off
131+ let bs = PS fptr 0 n
132+ n' = fromIntegral n
133+ send bs
134+ hook
135+ loop fd fptr (len - n') (off + n')
136+
137+positionRead :: Fd -> Ptr Word8 -> Int -> Integer -> IO Int
138+positionRead (Fd fd) buf siz off =
139+ fromIntegral <$> c_pread fd (castPtr buf) (fromIntegral siz) (fromIntegral off)
140+
141+foreign import ccall unsafe "pread"
142+ c_pread :: CInt -> Ptr CChar -> ByteCount -> FileOffset -> IO ByteCount -- fixme
29143#endif