1{-# LANGUAGE ForeignFunctionInterface #-} 2{-# LANGUAGE CPP #-} 3 4module Network.Sendfile.BSD ( 5 sendfile 6 , sendfileFd 7 , sendfileWithHeader 8 , sendfileFdWithHeader 9 ) where 10 11import Control.Concurrent 12import Control.Exception 13import Control.Monad 14import Data.ByteString (ByteString) 15import qualified Data.ByteString as BS 16import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno) 17import Foreign.C.Types 18import Foreign.Marshal (alloca) 19import Foreign.Ptr (Ptr, nullPtr) 20import Foreign.Storable (peek, poke) 21import Network.Sendfile.IOVec 22import Network.Sendfile.Types 23import Network.Socket 24import Network.Socket.ByteString 25import System.Posix.IO ( OpenMode(..) 26 , OpenFileFlags(..) 27 , defaultFileFlags 28 , closeFd 29 ) 30import System.Posix.Types 31 32#include <sys/types.h> 33 34entire :: COff 35entire = 0 36 37-- | 38-- Simple binding for sendfile() of BSD and MacOS. 39-- 40-- - Used system calls: open(), sendfile(), and close(). 41-- 42-- The fourth action argument is called when a file is sent as chunks. 43-- Chucking is inevitable if the socket is non-blocking (this is the 44-- default) and the file is large. The action is called after a chunk 45-- is sent and bofore waiting the socket to be ready for writing. 46 47sendfile :: Socket -> FilePath -> FileRange -> IO () -> IO () 48sendfile sock path range hook = bracket setup teardown $ \fd -> 49 sendfileFd sock fd range hook 50 where 51 setup = openFd path ReadOnly defaultFileFlags{nonBlock=True} 52 teardown = closeFd 53 54-- | 55-- Simple binding for sendfile() of BSD and MacOS. 56-- 57-- - Used system calls: sendfile() 58-- 59-- The fourth action argument is called when a file is sent as chunks. 60-- Chucking is inevitable if the socket is non-blocking (this is the 61-- default) and the file is large. The action is called after a chunk 62-- is sent and bofore waiting the socket to be ready for writing. 63 64sendfileFd :: Socket -> Fd -> FileRange -> IO () -> IO () 65sendfileFd sock fd range hook = do 66#if MIN_VERSION_network(3,1,0) 67 withFdSocket sock $ \s -> do 68 let dst = Fd s 69#elif MIN_VERSION_network(3,0,0) 70 dst <- Fd <$> fdSocket sock 71#else 72 let dst = Fd $ fdSocket sock 73#endif 74 alloca $ \sentp -> do 75 let (off,len) = case range of 76 EntireFile -> (0, entire) 77 PartOfFile off' len' -> (fromInteger off', fromInteger len') 78 sendloop dst fd off len sentp hook 79 80sendloop :: Fd -> Fd -> COff -> COff -> Ptr COff -> IO () -> IO () 81sendloop dst src off len sentp hook = do 82 rc <- sendFile src dst off len sentp nullPtr 83 when (rc /= 0) $ do 84 errno <- getErrno 85 if errno `elem` [eAGAIN, eINTR] then do 86 sent <- peek sentp 87 hook 88 -- Parallel IO manager use edge-trigger mode. 89 -- So, calling threadWaitWrite only when errnor is eAGAIN. 90 when (errno == eAGAIN) $ threadWaitWrite dst 91 let newoff = off + sent 92 newlen = if len == entire then entire else len - sent 93 sendloop dst src newoff newlen sentp hook 94 else 95 throwErrno "Network.SendFile.MacOS.sendloop" 96 97---------------------------------------------------------------- 98 99-- | 100-- Simple binding for sendfile() of BSD and MacOS. 101-- 102-- - Used system calls: open(), sendfile(), and close(). 103-- 104-- The fifth header is also sent with sendfile(). If the file is 105-- small enough, the header and the file is send in a single TCP packet 106-- on FreeBSD. MacOS sends the header and the file separately but it is 107-- fast. 108-- 109-- The fourth action argument is called when a file is sent as chunks. 110-- Chucking is inevitable if the socket is non-blocking (this is the 111-- default) and the file is large. The action is called after a chunk 112-- is sent and bofore waiting the socket to be ready for writing. 113 114sendfileWithHeader :: Socket -> FilePath -> FileRange -> IO () -> [ByteString] -> IO () 115sendfileWithHeader sock path range hook hdr = 116 bracket setup teardown $ \fd -> sendfileFdWithHeader sock fd range hook hdr 117 where 118 setup = openFd path ReadOnly defaultFileFlags{nonBlock=True} 119 teardown = closeFd 120 121-- | 122-- Simple binding for sendfile() of BSD and MacOS. 123-- 124-- - Used system calls: sendfile() 125-- 126-- The fifth header is also sent with sendfile(). If the file is 127-- small enough, the header and the file is send in a single TCP packet 128-- on FreeBSD. MacOS sends the header and the file separately but it is 129-- fast. 130-- 131-- The fourth action argument is called when a file is sent as chunks. 132-- Chucking is inevitable if the socket is non-blocking (this is the 133-- default) and the file is large. The action is called after a chunk 134-- is sent and bofore waiting the socket to be ready for writing. 135 136sendfileFdWithHeader :: Socket -> Fd -> FileRange -> IO () -> [ByteString] -> IO () 137sendfileFdWithHeader sock fd range hook hdr = do 138#if MIN_VERSION_network(3,1,0) 139 withFdSocket sock $ \s -> do 140 let dst = Fd s 141#elif MIN_VERSION_network(3,0,0) 142 dst <- Fd <$> fdSocket sock 143#else 144 let dst = Fd $ fdSocket sock 145#endif 146 alloca $ \sentp -> 147 if isFreeBSD && hlen >= 8192 then do 148 -- If the length of the header is larger than 8191, 149 -- threadWaitWrite does not come back on FreeBSD, sigh. 150 -- We use writev() for the header and sendfile() for the file. 151 sendMany sock hdr 152 sendfileFd sock fd range hook 153 else do 154 -- On MacOS, the header and the body are sent separately. 155 -- But it's fast. the writev() and sendfile() combination 156 -- is also fast. 157 let (off,len) = case range of 158 EntireFile -> (0,entire) 159 PartOfFile off' len' -> (fromInteger off' 160 ,fromInteger len' + hlen) 161 mrc <- sendloopHeader dst fd off len sentp hdr hlen 162 case mrc of 163 Nothing -> return () 164 Just (newoff,newlen) -> do 165 threadWaitWrite dst 166 sendloop dst fd newoff newlen sentp hook 167 where 168 hlen = fromIntegral . sum . map BS.length $ hdr 169 170sendloopHeader :: Fd -> Fd -> COff -> COff -> Ptr COff -> [ByteString] -> COff -> IO (Maybe (COff, COff)) 171sendloopHeader dst src off len sentp hdr hlen = do 172 rc <- withSfHdtr hdr $ sendFile src dst off len sentp 173 if rc == 0 then 174 return Nothing 175 else do 176 errno <- getErrno 177 if errno `elem` [eAGAIN, eINTR] then do 178 sent <- peek sentp 179 if sent >= hlen then do 180 let newoff = off + sent - hlen 181 if len == entire then 182 return $ Just (newoff, entire) 183 else 184 return $ Just (newoff, len - sent) 185 else do 186 -- Parallel IO manager use edge-trigger mode. 187 -- So, calling threadWaitWrite only when errnor is eAGAIN. 188 when (errno == eAGAIN) $ threadWaitWrite dst 189 let newlen = if len == entire then entire else len - sent 190 newhdr = remainingChunks (fromIntegral sent) hdr 191 newhlen = hlen - sent 192 sendloopHeader dst src off newlen sentp newhdr newhlen 193 else 194 throwErrno "Network.SendFile.MacOS.sendloopHeader" 195 196---------------------------------------------------------------- 197 198#ifdef OS_MacOS 199-- Shuffle the order of arguments for currying. 200sendFile :: Fd -> Fd -> COff -> COff -> Ptr COff -> Ptr SfHdtr -> IO CInt 201sendFile fd s off len sentp hdrp = do 202 poke sentp len 203 c_sendfile fd s off sentp hdrp 0 204 205foreign import ccall unsafe "sys/uio.h sendfile" 206 c_sendfile :: Fd -> Fd -> COff -> Ptr COff -> Ptr SfHdtr -> CInt -> IO CInt 207 208isFreeBSD :: Bool 209isFreeBSD = False 210#else 211-- Let's don't use CSize for 'len' and use COff for convenience. 212-- Shuffle the order of arguments for currying. 213sendFile :: Fd -> Fd -> COff -> COff -> Ptr COff -> Ptr SfHdtr -> IO CInt 214sendFile fd s off len sentp hdrp = 215 c_sendfile fd s off (fromIntegral len) hdrp sentp 0 216 217foreign import ccall unsafe "sys/uio.h sendfile" 218 c_sendfile :: Fd -> Fd -> COff -> CSize -> Ptr SfHdtr -> Ptr COff -> CInt -> IO CInt 219 220isFreeBSD :: Bool 221isFreeBSD = True 222#endif 223