1 {-# LANGUAGE CPP                      #-}
    2 {-# LANGUAGE ForeignFunctionInterface #-}
    3 
    4 -- | Snap's unified interface to sendfile.
    5 -- Modified from sendfile 0.6.1
    6 
    7 module System.SendFile
    8   ( sendFile
    9   , sendFileMode
   10   , sendHeaders
   11   , sendHeadersImpl
   12   ) where
   13 
   14 #include <sys/socket.h>
   15 
   16 ------------------------------------------------------------------------------
   17 import           Control.Concurrent         (threadWaitWrite)
   18 import qualified Data.ByteString.Char8      as S
   19 import qualified Data.ByteString.Lazy.Char8 as L
   20 import qualified Data.ByteString.Unsafe     as S
   21 import           Data.Word                  (Word64)
   22 import           Foreign.C.Error            (throwErrnoIfMinus1RetryMayBlock)
   23 #if __GLASGOW_HASKELL__ >= 703
   24 import           Foreign.C.Types            (CChar (..), CInt (..), CSize (..))
   25 #else
   26 import           Foreign.C.Types            (CChar, CInt, CSize)
   27 #endif
   28 import           Foreign.Ptr                (Ptr, plusPtr)
   29 #if __GLASGOW_HASKELL__ >= 703
   30 import           System.Posix.Types         (Fd (..))
   31 #else
   32 import           System.Posix.Types         (COff, CSsize, Fd)
   33 #endif
   34 ------------------------------------------------------------------------------
   35 import           Data.ByteString.Builder    (Builder, toLazyByteString)
   36 ------------------------------------------------------------------------------
   37 #if defined(LINUX)
   38 import qualified System.SendFile.Linux      as SF
   39 #elif defined(FREEBSD)
   40 import qualified System.SendFile.FreeBSD    as SF
   41 #elif defined(OSX)
   42 import qualified System.SendFile.Darwin     as SF
   43 #endif
   44 
   45 
   46 ------------------------------------------------------------------------------
   47 sendFile :: Fd                  -- ^ out fd (i.e. the socket)
   48          -> Fd                  -- ^ in fd (i.e. the file)
   49          -> Word64              -- ^ offset in bytes
   50          -> Word64              -- ^ count in bytes
   51          -> IO ()
   52 sendFile out_fd in_fd = go
   53   where
   54     go offs count | offs `seq` count <= 0 = return $! ()
   55                   | otherwise = do
   56                         nsent <- fromIntegral `fmap`
   57                                  SF.sendFile out_fd in_fd
   58                                              offs count
   59                         go (offs + nsent)
   60                            (count - nsent)
   61 
   62 
   63 ------------------------------------------------------------------------------
   64 sendFileMode :: String
   65 sendFileMode = SF.sendFileMode
   66 
   67 
   68 ------------------------------------------------------------------------------
   69 {-# INLINE sendHeaders #-}
   70 sendHeaders :: Builder -> Fd -> IO ()
   71 sendHeaders = sendHeadersImpl c_send threadWaitWrite
   72 
   73 
   74 ------------------------------------------------------------------------------
   75 {-# INLINE sendHeadersImpl #-}
   76 sendHeadersImpl :: (Fd -> Ptr CChar -> CSize -> CInt -> IO CSize)
   77                 -> (Fd -> IO ())
   78                 -> Builder
   79                 -> Fd
   80                 -> IO ()
   81 sendHeadersImpl sendFunc waitFunc headers fd =
   82     sendFunc `seq` waitFunc `seq`
   83     S.unsafeUseAsCStringLen (S.concat $ L.toChunks
   84                                       $ toLazyByteString headers) $
   85          \(cstr, clen) -> go cstr (fromIntegral clen)
   86   where
   87 #if defined(LINUX)
   88     flags = (#const MSG_MORE)
   89 #else
   90     flags = 0
   91 #endif
   92 
   93     go cstr clen | cstr `seq` clen <= 0 = return $! ()
   94                  | otherwise = do
   95                        nsent <- throwErrnoIfMinus1RetryMayBlock
   96                                    "sendHeaders"
   97                                    (sendFunc fd cstr clen flags)
   98                                    (waitFunc fd)
   99                        let cstr' = plusPtr cstr (fromIntegral nsent)
  100                        go cstr' (clen - nsent)
  101 
  102 
  103 ------------------------------------------------------------------------------
  104 foreign import ccall unsafe "sys/socket.h send" c_send
  105     :: Fd -> Ptr CChar -> CSize -> CInt -> IO CSize