{-# LINE 1 "Network/Sendfile/Linux.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}
module Network.Sendfile.Linux (
sendfile
, sendfile'
, sendfileFd
, sendfileFd'
, sendfileWithHeader
, sendfileFdWithHeader
) where
import Control.Exception
import Control.Monad
import Data.ByteString as B
import Data.ByteString.Internal
import Foreign.C.Error (eAGAIN, getErrno, throwErrno)
import Foreign.C.Types
import Foreign.Marshal (alloca)
import Foreign.Ptr (Ptr, plusPtr, castPtr)
import Foreign.ForeignPtr
import Foreign.Storable (poke, sizeOf)
import GHC.Conc (threadWaitWrite)
import Network.Sendfile.Types
import Network.Socket
import System.Posix.Files
import System.Posix.IO ( OpenMode(..)
, OpenFileFlags(..)
, defaultFileFlags
, closeFd
)
import System.Posix.Types
isLargeOffset :: Bool
isLargeOffset = sizeOf (0 :: COff) == 8
isLargeSize :: Bool
isLargeSize = sizeOf (0 :: CSize) == 8
safeSize :: CSize
safeSize
| isLargeSize = 2^(60 :: Int)
| otherwise = 2^(30 :: Int)
sendfile :: Socket -> FilePath -> FileRange -> IO () -> IO ()
sendfile sock path range hook = bracket setup teardown $ \fd ->
sendfileFd sock fd range hook
where
setup = openFd path ReadOnly defaultFileFlags{nonBlock=True}
teardown = closeFd
sendfile' :: Fd -> ByteString -> FileRange -> IO () -> IO ()
sendfile' dst path range hook = bracket setup teardown $ \src ->
sendfileFd' dst src range hook
where
setup = openFdBS path ReadOnly defaultFileFlags{nonBlock=True}
teardown = closeFd
sendfileFd :: Socket -> Fd -> FileRange -> IO () -> IO ()
sendfileFd sock fd range hook = do
{-# LINE 98 "Network/Sendfile/Linux.hsc" #-}
withFdSocket sock $ \s -> do
let dst = Fd s
{-# LINE 105 "Network/Sendfile/Linux.hsc" #-}
sendfileFd' dst fd range hook
sendfileFd' :: Fd -> Fd -> FileRange -> IO () -> IO ()
sendfileFd' dst src range hook =
alloca $ \offp -> case range of
EntireFile -> do
poke offp 0
len <- fileSize <$> getFdStatus src
let len' = fromIntegral len
sendfileloop dst src offp len' hook
PartOfFile off len -> do
poke offp (fromIntegral off)
let len' = fromIntegral len
sendfileloop dst src offp len' hook
sendfileloop :: Fd -> Fd -> Ptr COff -> CSize -> IO () -> IO ()
sendfileloop dst src offp len hook = do
let toSend
| len > safeSize = safeSize
| otherwise = len
bytes <- c_sendfile dst src offp toSend
case bytes of
-1 -> do
errno <- getErrno
if errno == eAGAIN then do
threadWaitWrite dst
sendfileloop dst src offp len hook
else
throwErrno "Network.SendFile.Linux.sendfileloop"
0 -> return ()
_ -> do
hook
let left = len - fromIntegral bytes
when (left /= 0) $ sendfileloop dst src offp left hook
foreign import ccall unsafe "sendfile"
c_sendfile32 :: Fd -> Fd -> Ptr COff -> CSize -> IO CSsize
foreign import ccall unsafe "sendfile64"
c_sendfile64 :: Fd -> Fd -> Ptr COff -> CSize -> IO CSsize
c_sendfile :: Fd -> Fd -> Ptr COff -> CSize -> IO CSsize
c_sendfile
| isLargeOffset = c_sendfile64
| otherwise = c_sendfile32
sendfileWithHeader :: Socket -> FilePath -> FileRange -> IO () -> [ByteString] -> IO ()
sendfileWithHeader sock path range hook hdr = do
sendMsgMore sock $ B.concat hdr
sendfile sock path range hook
sendfileFdWithHeader :: Socket -> Fd -> FileRange -> IO () -> [ByteString] -> IO ()
sendfileFdWithHeader sock fd range hook hdr = do
sendMsgMore sock $ B.concat hdr
sendfileFd sock fd range hook
sendMsgMore :: Socket -> ByteString -> IO ()
sendMsgMore sock bs = withForeignPtr fptr $ \ptr -> do
{-# LINE 212 "Network/Sendfile/Linux.hsc" #-}
withFdSocket sock $ \fd -> do
let s = Fd fd
{-# LINE 219 "Network/Sendfile/Linux.hsc" #-}
let buf = castPtr (ptr `plusPtr` off)
siz = fromIntegral len
sendloop s buf siz
where
PS fptr off len = bs
sendloop :: Fd -> Ptr CChar -> CSize -> IO ()
sendloop s buf len = do
bytes <- c_send s buf len (32768)
{-# LINE 228 "Network/Sendfile/Linux.hsc" #-}
if bytes == -1 then do
errno <- getErrno
if errno == eAGAIN then do
threadWaitWrite s
sendloop s buf len
else
throwErrno "Network.SendFile.Linux.sendloop"
else do
let sent = fromIntegral bytes
when (sent /= len) $ do
let left = len - sent
ptr = buf `plusPtr` fromIntegral bytes
sendloop s ptr left
foreign import ccall unsafe "send"
c_send :: Fd -> Ptr CChar -> CSize -> CInt -> IO CSsize