1 {-# LANGUAGE BangPatterns             #-}
    2 {-# LANGUAGE CPP                      #-}
    3 {-# LANGUAGE ForeignFunctionInterface #-}
    4 
    5 ------------------------------------------------------------------------------
    6 -- | Linux system-dependent code for 'sendfile'.
    7 module System.SendFile.Linux
    8   ( sendFile
    9   , sendFileImpl
   10   , sendFileMode
   11   ) where
   12 
   13 ------------------------------------------------------------------------------
   14 import           Control.Concurrent (threadWaitWrite)
   15 import           Data.Int           (Int64)
   16 import           Data.Word          (Word64)
   17 import           Foreign.C.Error    (throwErrnoIfMinus1RetryMayBlock)
   18 #if __GLASGOW_HASKELL__ >= 703
   19 import           Foreign.C.Types    (CInt (..), CSize (..))
   20 #else
   21 import           Foreign.C.Types    (CSize)
   22 #endif
   23 import           Foreign.Marshal    (alloca)
   24 import           Foreign.Ptr        (Ptr, nullPtr)
   25 import           Foreign.Storable   (poke)
   26 #if __GLASGOW_HASKELL__ >= 703
   27 import           System.Posix.Types (COff (..), CSsize (..), Fd (..))
   28 #else
   29 import           System.Posix.Types (COff, CSsize, Fd)
   30 #endif
   31 
   32 
   33 ------------------------------------------------------------------------------
   34 sendFile :: Fd -> Fd -> Word64 -> Word64 -> IO Int64
   35 sendFile = sendFileImpl c_sendfile threadWaitWrite
   36 {-# INLINE sendFile #-}
   37 
   38 
   39 ------------------------------------------------------------------------------
   40 sendFileImpl :: (Fd -> Fd -> Ptr COff -> CSize -> IO CSsize)
   41              -> (Fd -> IO ())
   42              -> Fd -> Fd -> Word64 -> Word64 -> IO Int64
   43 sendFileImpl !raw_sendfile !wait out_fd in_fd off count
   44   | count <= 0 = return 0
   45   | off   == 0 = do
   46         nsent <- sendfile raw_sendfile wait out_fd in_fd nullPtr bytes
   47         return $! fromIntegral nsent
   48   | otherwise  = alloca $ \poff -> do
   49         poke poff (fromIntegral off)
   50         nsent <- sendfile raw_sendfile wait out_fd in_fd poff bytes
   51         return $! fromIntegral nsent
   52     where
   53       bytes = fromIntegral count
   54 {-# INLINE sendFileImpl #-}
   55 
   56 
   57 ------------------------------------------------------------------------------
   58 sendfile :: (Fd -> Fd -> Ptr COff -> CSize -> IO CSsize)
   59          -> (Fd -> IO ())
   60          -> Fd -> Fd -> Ptr COff -> CSize -> IO CSsize
   61 sendfile raw_sendfile wait out_fd in_fd poff bytes =
   62     throwErrnoIfMinus1RetryMayBlock
   63             "sendfile"
   64             (raw_sendfile out_fd in_fd poff bytes)
   65             (wait out_fd)
   66 {-# INLINE sendfile #-}
   67 
   68 
   69 ------------------------------------------------------------------------------
   70 -- sendfile64 gives LFS support
   71 foreign import ccall unsafe "sys/sendfile.h sendfile64" c_sendfile
   72     :: Fd -> Fd -> Ptr COff -> CSize -> IO CSsize
   73 
   74 
   75 ------------------------------------------------------------------------------
   76 sendFileMode :: String
   77 sendFileMode = "LINUX_SENDFILE"