module Network.Sendfile.Linux (
sendfile
, sendfileWithHeader
) where
import Control.Applicative
import Control.Exception
import Control.Monad
import Data.ByteString as B
import Data.ByteString.Unsafe
import Data.Int
import Foreign.C.Error (eAGAIN, getErrno, throwErrno)
import Foreign.C.Types
import Foreign.Marshal (alloca)
import Foreign.Ptr (Ptr)
import Foreign.Storable (poke)
import GHC.Conc (threadWaitWrite)
import Network.Sendfile.Types
import Network.Socket
import Network.Socket.Internal (throwSocketErrorIfMinus1RetryMayBlock)
import System.Posix.Files
import System.Posix.IO
import System.Posix.Types
sendfile :: Socket -> FilePath -> FileRange -> IO () -> IO ()
sendfile sock path range hook = bracket setup teardown $ \fd ->
alloca $ \offp -> case range of
EntireFile -> do
poke offp 0
len <- fileSize <$> getFdStatus fd
let len' = fromIntegral len
sendloop dst fd offp len' hook
PartOfFile off len -> do
poke offp (fromIntegral off)
let len' = fromIntegral len
sendloop dst fd offp len' hook
where
setup = openFd path ReadOnly Nothing defaultFileFlags
teardown = closeFd
dst = Fd $ fdSocket sock
sendloop :: Fd -> Fd -> Ptr COff -> CSize -> IO () -> IO ()
sendloop dst src offp len hook = do
bytes <- c_sendfile dst src offp len
case bytes of
1 -> do
errno <- getErrno
if errno == eAGAIN then
loop len
else
throwErrno "Network.SendFile.Linux.sendloop"
0 -> return ()
_ -> loop (len fromIntegral bytes)
where
loop 0 = return ()
loop left = do
hook
threadWaitWrite dst
sendloop dst src offp left hook
foreign import ccall unsafe "sendfile"
c_sendfile :: Fd -> Fd -> Ptr COff -> CSize -> IO (Int32)
sendfileWithHeader :: Socket -> FilePath -> FileRange -> IO () -> [ByteString] -> IO ()
sendfileWithHeader sock path range hook hdr = do
sendAllMsgMore sock $ B.concat hdr
sendfile sock path range hook
sendAllMsgMore :: Socket -> ByteString -> IO ()
sendAllMsgMore sock bs = do
sent <- sendMsgMore sock bs
when (sent < B.length bs) $ sendAllMsgMore sock (B.drop sent bs)
sendMsgMore :: Socket -> ByteString -> IO Int
sendMsgMore (MkSocket s _ _ _ _) xs =
unsafeUseAsCStringLen xs $ \(str, len) ->
fromIntegral <$> throwSocketErrorIfMinus1RetryMayBlock
"sendMsgMore"
(threadWaitWrite (fromIntegral s))
(c_send s str (fromIntegral len) (32768))
foreign import ccall unsafe "send"
c_send :: CInt -> Ptr CChar -> CSize -> CInt -> IO (Int32)