{-# OPTIONS_GHC -optc-D_FILE_OFFSET_BITS=64 #-}
{-# 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




isLargeSize :: Bool
isLargeSize :: Bool
isLargeSize = CSize -> Int
forall a. Storable a => a -> Int
sizeOf (CSize
0 :: CSize) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8

safeSize :: CSize
safeSize :: CSize
safeSize
  | Bool
isLargeSize = CSize
2CSize -> Int -> CSize
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
60 :: Int)
  | Bool
otherwise   = CSize
2CSize -> Int -> CSize
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
30 :: Int)

----------------------------------------------------------------

-- |
-- Simple binding for sendfile() of Linux.
-- Used system calls:
--
--  - EntireFile -- open(), stat(), sendfile(), and close()
--
--  - PartOfFile -- open(), sendfile(), and close()
--
-- If the size of the file is unknown when sending the entire file,
-- specifying PartOfFile is much faster.
--
-- The fourth action argument is called when a file is sent as chunks.
-- Chucking is inevitable if the socket is non-blocking (this is the
-- default) and the file is large. The action is called after a chunk
-- is sent and before waiting the socket to be ready for writing.

sendfile :: Socket -> FilePath -> FileRange -> IO () -> IO ()
sendfile :: Socket -> FilePath -> FileRange -> IO () -> IO ()
sendfile Socket
sock FilePath
path FileRange
range IO ()
hook = IO Fd -> (Fd -> IO ()) -> (Fd -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Fd
setup Fd -> IO ()
teardown ((Fd -> IO ()) -> IO ()) -> (Fd -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Fd
fd ->
    Socket -> Fd -> FileRange -> IO () -> IO ()
sendfileFd Socket
sock Fd
fd FileRange
range IO ()
hook
  where
    setup :: IO Fd
setup = FilePath -> OpenMode -> OpenFileFlags -> IO Fd
openFd FilePath
path OpenMode
ReadOnly OpenFileFlags
defaultFileFlags{nonBlock=True}
    teardown :: Fd -> IO ()
teardown = Fd -> IO ()
closeFd

sendfile' :: Fd -> ByteString -> FileRange -> IO () -> IO ()
sendfile' :: Fd -> ByteString -> FileRange -> IO () -> IO ()
sendfile' Fd
dst ByteString
path FileRange
range IO ()
hook = IO Fd -> (Fd -> IO ()) -> (Fd -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Fd
setup Fd -> IO ()
teardown ((Fd -> IO ()) -> IO ()) -> (Fd -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Fd
src ->
    Fd -> Fd -> FileRange -> IO () -> IO ()
sendfileFd' Fd
dst Fd
src FileRange
range IO ()
hook
  where
    setup :: IO Fd
setup = ByteString -> OpenMode -> OpenFileFlags -> IO Fd
openFdBS ByteString
path OpenMode
ReadOnly OpenFileFlags
defaultFileFlags{nonBlock=True}
    teardown :: Fd -> IO ()
teardown = Fd -> IO ()
closeFd

-- |
-- Simple binding for sendfile() of Linux.
-- Used system calls:
--
--  - EntireFile -- stat() and sendfile()
--
--  - PartOfFile -- sendfile()
--
-- If the size of the file is unknown when sending the entire file,
-- specifying PartOfFile is much faster.
--
-- The fourth action argument is called when a file is sent as chunks.
-- Chucking is inevitable if the socket is non-blocking (this is the
-- default) and the file is large. The action is called after a chunk
-- is sent and before waiting the socket to be ready for writing.
sendfileFd :: Socket -> Fd -> FileRange -> IO () -> IO ()
sendfileFd :: Socket -> Fd -> FileRange -> IO () -> IO ()
sendfileFd Socket
sock Fd
fd FileRange
range IO ()
hook = do

{-# LINE 97 "Network/Sendfile/Linux.hsc" #-}
  withFdSocket sock $ \s -> do
    let dst = Fd s

{-# LINE 104 "Network/Sendfile/Linux.hsc" #-}
    sendfileFd' dst fd range hook

sendfileFd' :: Fd -> Fd -> FileRange -> IO () -> IO ()
sendfileFd' :: Fd -> Fd -> FileRange -> IO () -> IO ()
sendfileFd' Fd
dst Fd
src FileRange
range IO ()
hook =
    (Ptr COff -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr COff -> IO ()) -> IO ()) -> (Ptr COff -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr COff
offp -> case FileRange
range of
        FileRange
EntireFile -> do
            Ptr COff -> COff -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr COff
offp COff
0
            -- System call is very slow. Use PartOfFile instead.
            COff
len <- FileStatus -> COff
fileSize (FileStatus -> COff) -> IO FileStatus -> IO COff
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fd -> IO FileStatus
getFdStatus Fd
src
            let len' :: CSize
len' = COff -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral COff
len
            Fd -> Fd -> Ptr COff -> CSize -> IO () -> IO ()
sendfileloop Fd
dst Fd
src Ptr COff
offp CSize
len' IO ()
hook
        PartOfFile Integer
off Integer
len -> do
            Ptr COff -> COff -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr COff
offp (Integer -> COff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
off)
            let len' :: CSize
len' = Integer -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
len
            Fd -> Fd -> Ptr COff -> CSize -> IO () -> IO ()
sendfileloop Fd
dst Fd
src Ptr COff
offp CSize
len' IO ()
hook

sendfileloop :: Fd -> Fd -> Ptr COff -> CSize -> IO () -> IO ()
sendfileloop :: Fd -> Fd -> Ptr COff -> CSize -> IO () -> IO ()
sendfileloop Fd
dst Fd
src Ptr COff
offp CSize
len IO ()
hook = do
    -- Multicore IO manager use edge-trigger mode.
    -- So, calling threadWaitWrite only when errnor is eAGAIN.
    let toSend :: CSize
toSend
          | CSize
len CSize -> CSize -> Bool
forall a. Ord a => a -> a -> Bool
> CSize
safeSize = CSize
safeSize
          | Bool
otherwise      = CSize
len
    CSsize
bytes <- Fd -> Fd -> Ptr COff -> CSize -> IO CSsize
c_sendfile Fd
dst Fd
src Ptr COff
offp CSize
toSend
    case CSsize
bytes of
        -1 -> do
            Errno
errno <- IO Errno
getErrno
            if Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eAGAIN then do
                Fd -> IO ()
threadWaitWrite Fd
dst
                Fd -> Fd -> Ptr COff -> CSize -> IO () -> IO ()
sendfileloop Fd
dst Fd
src Ptr COff
offp CSize
len IO ()
hook
              else
                FilePath -> IO ()
forall a. FilePath -> IO a
throwErrno FilePath
"Network.SendFile.Linux.sendfileloop"
        CSsize
0  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- the file is truncated
        CSsize
_  -> do
            IO ()
hook
            let left :: CSize
left = CSize
len CSize -> CSize -> CSize
forall a. Num a => a -> a -> a
- CSsize -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSsize
bytes
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CSize
left CSize -> CSize -> Bool
forall a. Eq a => a -> a -> Bool
/= CSize
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Fd -> Fd -> Ptr COff -> CSize -> IO () -> IO ()
sendfileloop Fd
dst Fd
src Ptr COff
offp CSize
left IO ()
hook

-- Dst Src in order. take care
foreign import ccall unsafe "sendfile"
    c_sendfile :: Fd -> Fd -> Ptr COff -> CSize -> IO CSsize

----------------------------------------------------------------

-- |
-- Simple binding for send() and sendfile() of Linux.
-- Used system calls:
--
--  - EntireFile -- send(), open(), stat(), sendfile(), and close()
--
--  - PartOfFile -- send(), open(), sendfile(), and close()
--
-- The fifth header is sent with send() + the MSG_MORE flag. If the
-- file is small enough, the header and the file is send in a single
-- TCP packet.
--
-- If the size of the file is unknown when sending the entire file,
-- specifying PartOfFile is much faster.
--
-- The fourth action argument is called when a file is sent as chunks.
-- Chucking is inevitable if the socket is non-blocking (this is the
-- default) and the file is large. The action is called after a chunk
-- is sent and before waiting the socket to be ready for writing.

sendfileWithHeader :: Socket -> FilePath -> FileRange -> IO () -> [ByteString] -> IO ()
sendfileWithHeader :: Socket -> FilePath -> FileRange -> IO () -> [ByteString] -> IO ()
sendfileWithHeader Socket
sock FilePath
path FileRange
range IO ()
hook [ByteString]
hdr = do
    -- Copying is much faster than syscall.
    Socket -> ByteString -> IO ()
sendMsgMore Socket
sock (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat [ByteString]
hdr
    Socket -> FilePath -> FileRange -> IO () -> IO ()
sendfile Socket
sock FilePath
path FileRange
range IO ()
hook

-- |
-- Simple binding for send() and sendfile() of Linux.
-- Used system calls:
--
--  - EntireFile -- send(), stat() and sendfile()
--
--  - PartOfFile -- send() and sendfile()
--
-- The fifth header is sent with send() + the MSG_MORE flag. If the
-- file is small enough, the header and the file is send in a single
-- TCP packet.
--
-- If the size of the file is unknown when sending the entire file,
-- specifying PartOfFile is much faster.
--
-- The fourth action argument is called when a file is sent as chunks.
-- Chucking is inevitable if the socket is non-blocking (this is the
-- default) and the file is large. The action is called after a chunk
-- is sent and before waiting the socket to be ready for writing.

sendfileFdWithHeader :: Socket -> Fd -> FileRange -> IO () -> [ByteString] -> IO ()
sendfileFdWithHeader :: Socket -> Fd -> FileRange -> IO () -> [ByteString] -> IO ()
sendfileFdWithHeader Socket
sock Fd
fd FileRange
range IO ()
hook [ByteString]
hdr = do
    -- Copying is much faster than syscall.
    Socket -> ByteString -> IO ()
sendMsgMore Socket
sock (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat [ByteString]
hdr
    Socket -> Fd -> FileRange -> IO () -> IO ()
sendfileFd Socket
sock Fd
fd FileRange
range IO ()
hook

sendMsgMore :: Socket -> ByteString -> IO ()
sendMsgMore :: Socket -> ByteString -> IO ()
sendMsgMore Socket
sock ByteString
bs = ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do

{-# LINE 203 "Network/Sendfile/Linux.hsc" #-}
  withFdSocket sock $ \fd -> do
    let s = Fd fd

{-# LINE 210 "Network/Sendfile/Linux.hsc" #-}
    let buf = castPtr (ptr `plusPtr` off)
        siz = fromIntegral len
    sendloop s buf siz
  where
    PS ForeignPtr Word8
fptr Int
off Int
len = ByteString
bs

sendloop :: Fd -> Ptr CChar -> CSize -> IO ()
sendloop :: Fd -> Ptr CChar -> CSize -> IO ()
sendloop Fd
s Ptr CChar
buf CSize
len = do
    CSsize
bytes <- Fd -> Ptr CChar -> CSize -> CInt -> IO CSsize
c_send Fd
s Ptr CChar
buf CSize
len (CInt
32768)
{-# LINE 219 "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