{-# OPTIONS_GHC -optc-D_FILE_OFFSET_BITS=64 #-}
{-# LINE 1 "Network/Sendfile/Linux.hsc" #-}
{-# LANGUAGE CApiFFI #-}
-- Let sendfile() take a 64-bit off_t also on 32-bit platforms.
{-# OPTIONS_GHC -optc-D_FILE_OFFSET_BITS=64 #-}



module Network.Sendfile.Linux (
    sendfile
  , sendfile'
  , sendfileFd
  , sendfileFd'
  , sendfileWithHeader
  , sendfileFdWithHeader
  ) where

import Control.Exception
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno)
import Foreign.C.Types
import Foreign.Marshal (alloca)
import Foreign.Ptr (Ptr, plusPtr)
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
  Socket -> (CInt -> IO ()) -> IO ()
forall r. Socket -> (CInt -> IO r) -> IO r
withFdSocket Socket
sock ((CInt -> IO ()) -> IO ()) -> (CInt -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CInt
s -> do
    let dst :: Fd
dst = CInt -> Fd
Fd CInt
s
    Fd -> Fd -> FileRange -> IO () -> IO ()
sendfileFd' Fd
dst Fd
fd FileRange
range IO ()
hook

sendfileFd' :: Fd -> Fd -> FileRange -> IO () -> IO ()
sendfileFd' :: Fd -> Fd -> FileRange -> IO () -> IO ()
sendfileFd' Fd
dst Fd
src FileRange
range IO ()
hook = do
  FileRange -> IO ()
checkRange FileRange
range
  (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.
            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
            sendfileloop dst src offp len 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)
            Fd -> Fd -> Ptr COff -> COff -> IO () -> IO ()
sendfileloop Fd
dst Fd
src Ptr COff
offp (Integer -> COff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
len) IO ()
hook

-- The remaining length is COff since CSize is 32-bit on 32-bit platforms.
sendfileloop :: Fd -> Fd -> Ptr COff -> COff -> IO () -> IO ()
sendfileloop :: Fd -> Fd -> Ptr COff -> COff -> IO () -> IO ()
sendfileloop Fd
dst Fd
src Ptr COff
offp COff
len IO ()
hook = do
    -- Multicore IO manager use edge-trigger mode.
    -- So, calling threadWaitWrite only when errnor is eAGAIN.
    let toSend :: CSize
toSend
          | COff
len COff -> COff -> Bool
forall a. Ord a => a -> a -> Bool
> CSize -> COff
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
safeSize = CSize
safeSize
          | Bool
otherwise                   = COff -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral COff
len
    bytes <- Fd -> Fd -> Ptr COff -> CSize -> IO CSsize
c_sendfile Fd
dst Fd
src Ptr COff
offp CSize
toSend
    case bytes of
        -1 -> do
            errno <- IO Errno
getErrno
            if errno == eAGAIN then do
                threadWaitWrite dst
                sendfileloop dst src offp len hook
              else if errno == eINTR then
                sendfileloop dst src offp len hook
              else
                throwErrno "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 :: COff
left = COff
len COff -> COff -> COff
forall a. Num a => a -> a -> a
- CSsize -> COff
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSsize
bytes
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (COff
left COff -> COff -> Bool
forall a. Eq a => a -> a -> Bool
/= COff
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Fd -> Fd -> Ptr COff -> COff -> IO () -> IO ()
sendfileloop Fd
dst Fd
src Ptr COff
offp COff
left IO ()
hook

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

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

-- |
-- Simple binding for send() and sendfile() of Linux.
-- Used system calls:
--
--  - EntireFile -- open(), send(), stat(), sendfile(), and close()
--
--  - PartOfFile -- open(), send(), 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 = 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 () -> [ByteString] -> IO ()
sendfileFdWithHeader Socket
sock Fd
fd FileRange
range IO ()
hook [ByteString]
hdr
  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

-- |
-- 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
    FileRange -> IO ()
checkRange FileRange
range
    -- 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 = ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
buf, Int
len) ->
    Socket -> (CInt -> IO ()) -> IO ()
forall r. Socket -> (CInt -> IO r) -> IO r
withFdSocket Socket
sock ((CInt -> IO ()) -> IO ()) -> (CInt -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CInt
fd -> Fd -> Ptr CChar -> CSize -> IO ()
sendloop (CInt -> Fd
Fd CInt
fd) Ptr CChar
buf (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)

sendloop :: Fd -> Ptr CChar -> CSize -> IO ()
sendloop :: Fd -> Ptr CChar -> CSize -> IO ()
sendloop Fd
s Ptr CChar
buf CSize
len = do
    bytes <- Fd -> Ptr CChar -> CSize -> CInt -> IO CSsize
c_send Fd
s Ptr CChar
buf CSize
len (CInt
32768)
{-# LINE 206 "Network/Sendfile/Linux.hsc" #-}
    if bytes == -1 then do
        errno <- getErrno
        if errno == eAGAIN then do
            threadWaitWrite s
            sendloop s buf len
          else if errno == eINTR then
            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