diff --git a/sendfile.cabal b/sendfile.cabal --- a/sendfile.cabal +++ b/sendfile.cabal @@ -1,5 +1,5 @@ name: sendfile -version: 0.6.2 +version: 0.7.0 stability: provisional synopsis: A portable sendfile library description: A library which exposes zero-copy sendfile functionality in a portable way. If a platform does not support sendfile, a fallback implementation in haskell is provided. @@ -22,10 +22,10 @@ library hs-source-dirs: src - exposed-modules: Network.Socket.SendFile + exposed-modules: Network.Socket.SendFile, Network.Socket.SendFile.Iter, Network.Socket.SendFile.Internal - other-modules: Network.Socket.SendFile.Internal - +-- other-modules: + build-depends: base >= 3 && < 5, network >= 2 && < 3 diff --git a/src/Network/Socket/SendFile.hs b/src/Network/Socket/SendFile.hs --- a/src/Network/Socket/SendFile.hs +++ b/src/Network/Socket/SendFile.hs @@ -8,15 +8,25 @@ module Network.Socket.SendFile ( ByteCount, Offset, + Iter(..), runIter, -- * Safe functions (recommended) sendFile, + sendFileIterWith, sendFile', + sendFileIterWith', + -- * Unsafe functions + -- | These functions are unsafe simply because there is no guarantee that the 'Handle' used for output is actually bound to a 'Socket'. If it is not, it will result in a runtime error. unsafeSendFile, + unsafeSendFileIterWith, unsafeSendFile', + unsafeSendFileIterWith', -- * Utility functions sendFileMode ) where -import qualified Network.Socket.SendFile.Internal (sendFile, sendFile', unsafeSendFile, unsafeSendFile', sendFileMode) +import qualified Network.Socket.SendFile.Internal (sendFile, sendFileIterWith, sendFile', sendFileIterWith', + unsafeSendFile, unsafeSendFileIterWith, unsafeSendFile', unsafeSendFileIterWith', + sendFileMode) +import Network.Socket.SendFile.Iter (Iter(..), runIter) import Network.Socket (Socket) import System.IO (Handle) @@ -33,6 +43,17 @@ -> IO () sendFile = Network.Socket.SendFile.Internal.sendFile +-- | The simplest interface. Simply give it an output `Socket` and the `FilePath` to the input file. +-- +-- This variant takes a function to drive the iteration loop. See 'Iter' for more information. +sendFileIterWith + :: (IO Iter -> IO a) + -> Socket -- ^ The output socket + -> FilePath -- ^ The path where the input file resides + -> ByteCount -- ^ Maximum bytes to send per block (may send less) + -> IO a +sendFileIterWith = Network.Socket.SendFile.Internal.sendFileIterWith + -- | A more powerful interface than sendFile which accepts a starting offset, and the bytecount to send; the offset and the count must be a positive integer. The initial position of the input file handle matters not since the offset is absolute, and the final position may be different depending on the platform -- no assumptions can be made. sendFile' :: Socket -- ^ The output socket @@ -42,6 +63,19 @@ -> IO () sendFile' = Network.Socket.SendFile.Internal.sendFile' +-- | A more powerful interface than sendFile which accepts a starting offset, and the bytecount to send; the offset and the count must be a positive integer. The initial position of the input file handle matters not since the offset is absolute, and the final position may be different depending on the platform -- no assumptions can be made. +-- +-- This variant takes a function to drive the iteration loop. See 'Iter' for more information. +sendFileIterWith' + :: (IO Iter -> IO a) + -> Socket -- ^ The output socket + -> FilePath -- ^ The input file handle + -> ByteCount -- ^ Maximum bytes to send per block (may send less) + -> Offset -- ^ The offset to start at + -> ByteCount -- ^ The number of bytes to send + -> IO a +sendFileIterWith' = Network.Socket.SendFile.Internal.sendFileIterWith' + -- | The unsafe version of sendFile which accepts a `Handle` instead of a `Socket` for the output. It will flush the output handle before sending any file data. unsafeSendFile :: Handle -- ^ The output handle @@ -49,6 +83,17 @@ -> IO () unsafeSendFile = Network.Socket.SendFile.Internal.unsafeSendFile +-- | The unsafe version of sendFile which accepts a `Handle` instead of a `Socket` for the output. It will flush the output handle before sending any file data. +-- +-- This variant takes a function to drive the iteration loop. See 'Iter' for more information. +unsafeSendFileIterWith + :: (IO Iter -> IO a) + -> Handle -- ^ The output handle + -> FilePath -- ^ The path where the input file resides + -> ByteCount -- ^ Maximum bytes to send per block (may send less) + -> IO a +unsafeSendFileIterWith = Network.Socket.SendFile.Internal.unsafeSendFileIterWith + -- | The unsafe version of sendFile' which accepts a `Handle` instead of a `Socket` for the output. It will flush the output handle before sending any file data. unsafeSendFile' :: Handle -- ^ The output handle @@ -58,9 +103,22 @@ -> IO () unsafeSendFile' = Network.Socket.SendFile.Internal.unsafeSendFile' +-- | The unsafe version of sendFile' which accepts a `Handle` instead of a `Socket` for the output. It will flush the output handle before sending any file data. +-- +-- This variant takes a function to drive the iteration loop. See 'Iter' for more information. +unsafeSendFileIterWith' + :: (IO Iter -> IO a) + -> Handle -- ^ The output handle + -> FilePath -- ^ The input filepath + -> ByteCount -- ^ The number of bytes to send + -> Offset -- ^ The offset to start at + -> ByteCount -- ^ The number of bytes to send + -> IO a +unsafeSendFileIterWith' = Network.Socket.SendFile.Internal.unsafeSendFileIterWith' + -- | Returns the mode that sendfile was compiled with. Mainly for debugging use. --- | Possible values are 'WIN32_SENDFILE', 'LINUX_SENDFILE', 'FREEBSD_SENDFILE', --- | 'DARWIN_SENDFILE', and 'PORTABLE_SENDFILE'. +-- Possible values are 'WIN32_SENDFILE', 'LINUX_SENDFILE', 'FREEBSD_SENDFILE', +-- 'DARWIN_SENDFILE', and 'PORTABLE_SENDFILE'. sendFileMode :: String -- ^ The mode that sendfile was compiled with sendFileMode = Network.Socket.SendFile.Internal.sendFileMode diff --git a/src/Network/Socket/SendFile/Darwin.hsc b/src/Network/Socket/SendFile/Darwin.hsc --- a/src/Network/Socket/SendFile/Darwin.hsc +++ b/src/Network/Socket/SendFile/Darwin.hsc @@ -1,58 +1,77 @@ {-# LANGUAGE ForeignFunctionInterface #-} -- | Darwin system-dependent code for 'sendfile'. -module Network.Socket.SendFile.Darwin (_sendFile) where +module Network.Socket.SendFile.Darwin (_sendFile, sendFileIter, sendfile) where + import Data.Int (Int64) -import Foreign.C.Error (eAGAIN, getErrno, throwErrno) +import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno) import Foreign.C.Types (CInt) import Foreign.Marshal (alloca) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable (peek, poke) +import Network.Socket.SendFile.Iter (Iter(..), runIter) import System.Posix.Types (Fd) -import Control.Concurrent (threadWaitWrite) -{- - This is based on Linux.hsc (from version 0.5), although the - calling convention for Darwin's sendfile() is closer to that - of FreeBSD. --} - _sendFile :: Fd -> Fd -> Int64 -> Int64 -> IO () -_sendFile out_fd in_fd off count = do - alloca $ \pbytes -> do - rsendfile out_fd in_fd pbytes off count +_sendFile out_fd in_fd off count = + do _ <- runIter (sendFileIter out_fd in_fd count off count) -- set blockSize == count. ie. send it all if we can. + return () -rsendfile :: Fd -> Fd -> Ptr Int64 -> Int64 -> Int64 -> IO () -rsendfile _ _ _ _ 0 = return () -rsendfile out_fd in_fd pbytes off remaining = do - let bytes = min remaining maxBytes - sbytes <- sendfile out_fd in_fd pbytes off bytes 0 - rsendfile out_fd in_fd pbytes off (remaining - sbytes) +-- | a way to send things in chunks +sendFileIter :: Fd -- ^ file descriptor corresponding to network socket + -> Fd -- ^ file descriptor corresponding to file + -> Int64 -- ^ maximum number of bytes to send at once + -> Int64 -- ^ offset into file + -> Int64 -- ^ total number of bytes to send + -> IO Iter +sendFileIter out_fd in_fd blockSize off remaining = + sendFileIterI out_fd in_fd (min blockSize maxBytes) off remaining -{- - Unlike the Linux implementation we track any re-sends due - to getting eAGAIN. If this wasn't done then the call would - appear to hang. The alternative would be to just - return bytes - but I am unclear whether there are occasions this may - be wrong. --} +sendFileIterI :: Fd -- ^ file descriptor corresponding to network socket + -> Fd -- ^ file descriptor corresponding to file + -> Int64 -- ^ maximum number of bytes to send at once + -> Int64 -- ^ offset into file + -> Int64 -- ^ total number of bytes to send +-- -> Ptr Int64 -- ^ sent bytes ptr + -> IO Iter +sendFileIterI _out_fd _in_fd _blockSize _off 0 = return (Done 0) +sendFileIterI out_fd in_fd blockSize off remaining = + do let bytes = min remaining blockSize + (wouldBlock, nsent) <- alloca $ \len -> + do poke len bytes + sendfileI out_fd in_fd off len + let cont = sendFileIterI out_fd in_fd blockSize (off + nsent) (remaining `safeMinus` nsent) + case wouldBlock of + True -> return (WouldBlock (fromIntegral nsent) out_fd cont) + False -> return (Sent (fromIntegral nsent) cont) -sendfile :: Fd -> Fd -> Ptr Int64 -> Int64 -> Int64 -> Int64 -> IO Int64 -sendfile out_fd in_fd pbytes off bytes ctr = do - poke pbytes bytes - -- Copying Linux implementation for thread synchronization, - -- is this sensible? - threadWaitWrite out_fd - status <- c_sendfile out_fd in_fd off pbytes - nsent <- peek pbytes - if status == 0 - then return $ (fromIntegral nsent) + ctr - else do errno <- getErrno - if errno == eAGAIN - -- is it correct to reduce bytes by nsent here? - then let nremaining = max 0 (bytes - (fromIntegral nsent)) - in sendfile out_fd in_fd pbytes (off + nsent) nremaining (ctr + (fromIntegral nsent)) - else throwErrno "Network.Socket.SendFile.Darwin" + +-- | low-level wrapper around sendfile +-- non-blocking +-- returns number of bytes written and if EAGAIN/EINTR +-- does not call 'threadWaitWrite' +sendfile :: Fd -> Fd -> Int64 -> Int64 -> IO (Bool, Int64) +sendfile out_fd in_fd off count = + alloca $ \len -> + do poke len count + sendfileI out_fd in_fd off len + +-- NOTE: should we retry automatically on EINTR (but not EAGAIN) +sendfileI :: Fd -> Fd -> Int64 -> Ptr Int64 -> IO (Bool, Int64) +sendfileI out_fd in_fd off len = + do status <- c_sendfile out_fd in_fd off len + if (status == 0) + then do nsent <- peek len + return $ (False, nsent) + else do errno <- getErrno + if (errno == eAGAIN) || (errno == eINTR) + then do nsent <- peek len + return (True, nsent) + else throwErrno "Network.Socket.SendFile.Darwin.sendfileI" + +safeMinus :: (Ord a, Num a) => a -> a -> a +safeMinus x y + | y >= x = 0 + | otherwise = x - y -- max num of bytes in one send maxBytes :: Int64 diff --git a/src/Network/Socket/SendFile/FreeBSD.hs b/src/Network/Socket/SendFile/FreeBSD.hs --- a/src/Network/Socket/SendFile/FreeBSD.hs +++ b/src/Network/Socket/SendFile/FreeBSD.hs @@ -1,38 +1,67 @@ {-# LANGUAGE ForeignFunctionInterface #-} -- | FreeBSD system-dependent code for 'sendfile'. -module Network.Socket.SendFile.FreeBSD (_sendFile) where -import Control.Concurrent (threadWaitWrite) +module Network.Socket.SendFile.FreeBSD (_sendFile, sendFileIter, sendfile) where +import Data.Int (Int64) import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno) import Foreign.C.Types (CInt, CSize) import Foreign.Marshal.Alloc (alloca) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable (peek) +import Network.Socket.SendFile.Iter (Iter(..), runIter) import System.Posix.Types (COff, Fd) -_sendFile :: Fd -> Fd -> Integer -> Integer -> IO () +-- | automatically loop and send everything +_sendFile :: Fd -> Fd -> Int64 -> Int64 -> IO () _sendFile out_fd in_fd off count = - alloca $ \sbytes -> do - rsendfile out_fd in_fd (fromIntegral off) (fromIntegral count) sbytes + do _ <- runIter (sendFileIter out_fd in_fd (fromIntegral count) (fromIntegral off) (fromIntegral count)) -- set blockSize == count. ie. send it all if we can. + return () -rsendfile :: Fd -> Fd -> COff -> CSize -> Ptr COff -> IO () -rsendfile _ _ _ 0 _ = return () -rsendfile out_fd in_fd off remaining sbytes = - do let bytes = min remaining maxBytes - sent <- sendfile out_fd in_fd off bytes sbytes 0 - rsendfile out_fd in_fd (off + sent) (remaining `safeMinus` (fromIntegral sent)) sbytes +sendFileIter :: Fd -- ^ file descriptor corresponding to network socket + -> Fd -- ^ file descriptor corresponding to file + -> Int64 -- ^ maximum number of bytes to send at once + -> Int64 -- ^ offset into file + -> Int64 -- ^ total number of bytes to send + -> IO Iter +sendFileIter out_fd in_fd blockSize off count = + sendFileIterI out_fd in_fd (min (fromIntegral blockSize) maxBytes) (fromIntegral off) (fromIntegral count) -sendfile :: Fd -> Fd -> COff -> CSize -> Ptr COff -> COff -> IO COff -sendfile out_fd in_fd off count sbytes totalSent = - do threadWaitWrite out_fd - res <- c_sendfile_freebsd in_fd out_fd off count nullPtr sbytes 0 - if (res == 0) - then do nbytes <- peek sbytes - return (totalSent + nbytes) +sendFileIterI :: Fd -- ^ file descriptor corresponding to network socket + -> Fd -- ^ file descriptor corresponding to file + -> CSize -- ^ maximum number of bytes to send at once + -> COff -- ^ offset into file + -> CSize -- ^ total number of bytes to send + -> IO Iter +sendFileIterI _out_fd _in_fd _blockSize _off 0 = return (Done 0) +sendFileIterI out_fd in_fd blockSize off remaining = + do let bytes = min remaining blockSize + (wouldBlock, nsent) <- alloca $ \sbytes -> sendfileI out_fd in_fd off bytes sbytes + let cont = sendFileIterI out_fd in_fd blockSize (off + nsent) (remaining `safeMinus` (fromIntegral nsent)) + case wouldBlock of + True -> return (WouldBlock (fromIntegral nsent) out_fd cont) + False -> return (Sent (fromIntegral nsent) cont) + +-- | low-level wrapper around sendfile +-- non-blocking +-- returns number of bytes written and if EAGAIN +-- does not call 'threadWaitWrite' +sendfile :: Fd -> Fd -> Int64 -> Int64 -> IO (Bool, Int64) +sendfile out_fd in_fd off count = + alloca $ \sbytes -> + do (wb, sent) <- sendfileI out_fd in_fd (fromIntegral off) (fromIntegral count) sbytes + return (wb, fromIntegral sent) + +-- NOTE: should we retry automatically on EINTR (but not EAGAIN) +sendfileI :: Fd -> Fd -> COff -> CSize -> Ptr COff -> IO (Bool, COff) +sendfileI out_fd in_fd off count sbytes = + do status <- c_sendfile out_fd in_fd off count sbytes + if (status == 0) + then do nsent <- peek sbytes + return (False, nsent) else do errno <- getErrno if (errno == eAGAIN) || (errno == eINTR) - then do nbytes <- peek sbytes - sendfile out_fd in_fd (off + nbytes) (count `safeMinus` (fromIntegral nbytes)) sbytes (totalSent + nbytes) - else throwErrno "Network.Socket.SendFile.FreeBSD.sendfile" + then do nsent <- peek sbytes + return (True, nsent) + else throwErrno "Network.Socket.SendFile.FreeBSD.sendfileI" safeMinus :: (Ord a, Num a) => a -> a -> a safeMinus x y @@ -45,3 +74,6 @@ foreign import ccall unsafe "sys/uio.h sendfile" c_sendfile_freebsd :: Fd -> Fd -> COff -> CSize -> Ptr () -> Ptr COff -> CInt -> IO CInt + +c_sendfile :: Fd -> Fd -> COff -> CSize -> Ptr COff -> IO CInt +c_sendfile out_fd in_fd off count sbytes = c_sendfile_freebsd in_fd out_fd off count nullPtr sbytes 0 diff --git a/src/Network/Socket/SendFile/Internal.hs b/src/Network/Socket/SendFile/Internal.hs --- a/src/Network/Socket/SendFile/Internal.hs +++ b/src/Network/Socket/SendFile/Internal.hs @@ -1,62 +1,76 @@ {-# LANGUAGE CPP, RecordWildCards #-} module Network.Socket.SendFile.Internal ( sendFile, + sendFileIterWith, sendFile', + sendFileIterWith', unsafeSendFile, + unsafeSendFileIterWith, unsafeSendFile', + unsafeSendFileIterWith', sendFileMode, ) where #if defined(PORTABLE_SENDFILE) -import Data.ByteString.Char8 (hGet, hPutStr, length, ByteString) -import Network.Socket.ByteString (sendAll) -import Network.Socket (Socket(..)) +import Data.ByteString.Char8 (hGet, hPut, length, ByteString) +import qualified Data.ByteString.Char8 as C +import Network.Socket.ByteString (send) +import Network.Socket (Socket(..), fdSocket) +import Network.Socket.SendFile.Iter (runIter) import Prelude hiding (length) -import System.IO (Handle, IOMode(..), SeekMode(..), hFileSize, hSeek, withBinaryFile) +import System.IO (Handle, IOMode(..), SeekMode(..), hFileSize, hIsEOF, hSeek, withBinaryFile) +import System.Posix.Types (Fd(..)) #else import Network.Socket (Socket(..), fdSocket) import System.IO (Handle, IOMode(..), hFileSize, withBinaryFile) import System.Posix.Types (Fd(..)) -#endif #ifdef __GLASGOW_HASKELL__ #if __GLASGOW_HASKELL__ >= 611 -import GHC.IO.Handle.Internals (withHandle, flushWriteBuffer) -import GHC.IO.Handle.Types (Handle__(..), HandleType(..)) +import GHC.IO.Handle.Internals (withHandle_) +import GHC.IO.Handle.Types (Handle__(..)) import qualified GHC.IO.FD as FD -- import qualified GHC.IO.Handle.FD as FD import GHC.IO.Exception import Data.Typeable (cast) -import System.IO (hFlush) -import System.IO.Error #else import GHC.IOBase import GHC.Handle hiding (fdToHandle) import qualified GHC.Handle #endif #endif +#endif +import Network.Socket.SendFile.Iter (Iter(..)) +import System.IO (hFlush) + +#ifdef __GLASGOW_HASKELL__ +#if __GLASGOW_HASKELL__ >= 611 +import System.IO.Error +#endif +#endif + #if defined(WIN32_SENDFILE) -import Network.Socket.SendFile.Win32 (_sendFile) +import Network.Socket.SendFile.Win32 (_sendFile, sendFileIter) sendFileMode :: String sendFileMode = "WIN32_SENDFILE" #endif #if defined(LINUX_SENDFILE) -import Network.Socket.SendFile.Linux (_sendFile) +import Network.Socket.SendFile.Linux (_sendFile, sendFileIter) sendFileMode :: String sendFileMode = "LINUX_SENDFILE" #endif #if defined(FREEBSD_SENDFILE) -import Network.Socket.SendFile.FreeBSD (_sendFile) +import Network.Socket.SendFile.FreeBSD (_sendFile, sendFileIter) sendFileMode :: String sendFileMode = "FREEBSD_SENDFILE" #endif #if defined(DARWIN_SENDFILE) -import Network.Socket.SendFile.Darwin (_sendFile) +import Network.Socket.SendFile.Darwin (_sendFile, sendFileIter) sendFileMode :: String sendFileMode = "DARWIN_SENDFILE" @@ -66,59 +80,186 @@ sendFileMode :: String sendFileMode = "PORTABLE_SENDFILE" +sendFileIterWith'' :: (IO Iter -> IO a) -> Socket -> Handle -> Integer -> Integer -> Integer -> IO a +sendFileIterWith'' stepper = + wrapSendFile' $ \outs inp blockSize off count -> + do hSeek inp AbsoluteSeek off + stepper (sendFileIterS outs inp blockSize {- off -} count Nothing) + sendFile'' :: Socket -> Handle -> Integer -> Integer -> IO () -sendFile'' = wrapSendFile' $ \outs inp off count -> do - hSeek inp AbsoluteSeek off - rsend (sendAll outs) inp count +sendFile'' outs inh off count = + do _ <- sendFileIterWith'' runIter outs inh count off count + return () +unsafeSendFileIterWith'' :: (IO Iter -> IO a) -> Handle -> Handle -> Integer -> Integer -> Integer -> IO a +unsafeSendFileIterWith'' stepper = + wrapSendFile' $ \outp inp blockSize off count -> + do hSeek inp AbsoluteSeek off + a <- stepper (unsafeSendFileIter outp inp blockSize count Nothing) + hFlush outp + return a + unsafeSendFile'' :: Handle -> Handle -> Integer -> Integer -> IO () -unsafeSendFile'' = wrapSendFile' $ \outp inp off count -> do - hSeek inp AbsoluteSeek off - rsend (hPutStr outp) inp count - hFlush outp -- match the behavior that all data is "flushed to the os" of native implementations +unsafeSendFile'' outh inh off count = + do _ <- unsafeSendFileIterWith'' runIter outh inh count off count + return () -rsend :: (ByteString -> IO ()) -> Handle -> Integer -> IO () -rsend write inp n = do - loop n - where - loop 0 = return () - loop reqBytes = do - let bytes = min 32768 reqBytes :: Integer - buf <- hGet inp (fromIntegral bytes) - write buf - loop $ reqBytes - (fromIntegral $ length buf) +sendFileIterS :: Socket -- ^ output network socket + -> Handle -- ^ input handle + -> Integer -- ^ maximum number of bytes to send at once + -> Integer -- ^ total number of bytes to send + -> Maybe ByteString + -> IO Iter +sendFileIterS _socket _inh _blockSize {- _off -} 0 _ = return (Done 0) +sendFileIterS socket inh blockSize {- off -} remaining mBuf = + do buf <- nextBlock + nsent <- send socket buf + let leftOver = + if nsent < (C.length buf) + then Just (C.drop nsent buf) + else Nothing + let cont = sendFileIterS socket inh blockSize {- (off + (fromIntegral nsent)) -} (remaining `safeMinus` (fromIntegral nsent)) leftOver + if nsent < (length buf) + then return (WouldBlock (fromIntegral nsent) (Fd $ fdSocket socket) cont) + else return (Sent (fromIntegral nsent) cont) + where + nextBlock = + case mBuf of + (Just b) -> return b + Nothing -> + do eof <- hIsEOF inh + if eof + then ioError (mkIOError eofErrorType ("Reached EOF but was hoping to read " ++ show remaining ++ " more byte(s).") (Just inh) Nothing) + else do let bytes = min 32768 (min blockSize remaining) + hGet inh (fromIntegral bytes) -- we could check that we got fewer bytes than requested here, but we will send what we got and catch the EOF next time around + +safeMinus :: (Ord a, Num a) => a -> a -> a +safeMinus x y + | y > x = error $ "y > x " ++ show (y,x) + | otherwise = x - y + + +unsafeSendFileIter :: Handle -- ^ output handle + -> Handle -- ^ input handle + -> Integer -- ^ maximum number of bytes to send at once +-- -> Integer -- ^ offset into file + -> Integer -- ^ total number of bytes to send + -> Maybe ByteString + -> IO Iter +unsafeSendFileIter _outh _inh _blockSize 0 _mBuf = return (Done 0) +unsafeSendFileIter outh inh blockSize remaining mBuf = + do buf <- nextBlock + hPut outh buf -- eventually this should use a non-blocking version of hPut + let nsent = length buf +{- + leftOver = + if nsent < (C.length buf) + then Just (C.drop nsent buf) + else Nothing +-} + cont = unsafeSendFileIter outh inh blockSize {- (off + (fromIntegral nsent)) -} (remaining - (fromIntegral nsent)) Nothing + if nsent < (length buf) + then do error "unsafeSendFileIter: internal error" -- return (WouldBlock (fromIntegral nsent) (Fd $ fdSocket socket) cont) + else return (Sent (fromIntegral nsent) cont) + where + nextBlock = + case mBuf of + (Just b) -> return b + Nothing -> + do eof <- hIsEOF inh + if eof + then ioError (mkIOError eofErrorType ("Reached EOF but was hoping to read " ++ show remaining ++ " more byte(s).") (Just inh) Nothing) + else do let bytes = min 32768 (min blockSize remaining) + hGet inh (fromIntegral bytes) -- we could check that we got fewer bytes than requested here, but we will send what we got and catch the EOF next time around + #else sendFile'' :: Socket -> Handle -> Integer -> Integer -> IO () -sendFile'' outs inp off count = +sendFile'' outs inh off count = do let out_fd = Fd (fdSocket outs) - in_fd <- handleToFd inp - wrapSendFile' _sendFile out_fd in_fd off count + withFd inh $ \in_fd -> + wrapSendFile' (\out_fd_ in_fd_ _blockSize_ off_ count_ -> _sendFile out_fd_ in_fd_ off_ count_) + out_fd in_fd count off count +sendFileIterWith'' :: (IO Iter -> IO a) -> Socket -> Handle -> Integer -> Integer -> Integer -> IO a +sendFileIterWith'' stepper outs inp blockSize off count = + do let out_fd = Fd (fdSocket outs) + withFd inp $ \in_fd -> + stepper $ wrapSendFile' sendFileIter out_fd in_fd blockSize off count + + unsafeSendFile'' :: Handle -> Handle -> Integer -> Integer -> IO () unsafeSendFile'' outp inp off count = do hFlush outp - out_fd <- handleToFd outp - in_fd <- handleToFd inp - wrapSendFile' _sendFile out_fd in_fd off count - + withFd outp $ \out_fd -> + withFd inp $ \in_fd -> + wrapSendFile' (\out_fd_ in_fd_ _blockSize_ off_ count_ -> _sendFile out_fd_ in_fd_ off_ count_) + out_fd in_fd count off count +-- wrapSendFile' _sendFile out_fd in_fd off count + +unsafeSendFileIterWith'' :: (IO Iter -> IO a) -> Handle -> Handle -> Integer -> Integer -> Integer -> IO a +unsafeSendFileIterWith'' stepper outp inp blockSize off count = + do hFlush outp + withFd outp $ \out_fd -> + withFd inp $ \in_fd -> + stepper $ wrapSendFile' sendFileIter out_fd in_fd blockSize off count + +-- The Fd should not be used after the action returns because the +-- Handler may be garbage collected and than will cause the finalizer +-- to close the fd. +withFd :: Handle -> (Fd -> IO a) -> IO a +#ifdef __GLASGOW_HASKELL__ +#if __GLASGOW_HASKELL__ >= 611 +withFd h f = withHandle_ "withFd" h $ \ Handle__{..} -> do + case cast haDevice of + Nothing -> ioError (ioeSetErrorString (mkIOError IllegalOperation + "withFd" (Just h) Nothing) + "handle is not a file descriptor") + Just fd -> f (Fd (fromIntegral (FD.fdFD fd))) +#else +withFd h f = + withHandle_ "withFd" h $ \ h_ -> + f (Fd (fromIntegral (haFD h_))) #endif +#endif + +#endif + sendFile :: Socket -> FilePath -> IO () -sendFile outs infp = withBinaryFile infp ReadMode $ \inp -> do - count <- hFileSize inp - sendFile'' outs inp 0 count +sendFile outs infp = + withBinaryFile infp ReadMode $ \inp -> do + count <- hFileSize inp + sendFile'' outs inp 0 count +sendFileIterWith :: (IO Iter -> IO a) -> Socket -> FilePath -> Integer -> IO a +sendFileIterWith stepper outs infp blockSize = + withBinaryFile infp ReadMode $ \inp -> do + count <- hFileSize inp + sendFileIterWith'' stepper outs inp blockSize 0 count + sendFile' :: Socket -> FilePath -> Integer -> Integer -> IO () sendFile' outs infp offset count = withBinaryFile infp ReadMode $ \inp -> sendFile'' outs inp offset count +sendFileIterWith' :: (IO Iter -> IO a) -> Socket -> FilePath -> Integer -> Integer -> Integer -> IO a +sendFileIterWith' stepper outs infp blockSize offset count = + withBinaryFile infp ReadMode $ \inp -> + sendFileIterWith'' stepper outs inp blockSize offset count + unsafeSendFile :: Handle -> FilePath -> IO () -unsafeSendFile outp infp = +unsafeSendFile outp infp = withBinaryFile infp ReadMode $ \inp -> do count <- hFileSize inp unsafeSendFile'' outp inp 0 count +unsafeSendFileIterWith :: (IO Iter -> IO a) -> Handle -> FilePath -> Integer -> IO a +unsafeSendFileIterWith stepper outp infp blockSize = + withBinaryFile infp ReadMode $ \inp -> do + count <- hFileSize inp + unsafeSendFileIterWith'' stepper outp inp blockSize 0 count + + unsafeSendFile' :: Handle -- ^ The output handle -> FilePath -- ^ The input filepath @@ -128,29 +269,25 @@ unsafeSendFile' outp infp offset count = withBinaryFile infp ReadMode $ \inp -> do unsafeSendFile'' outp inp offset count - + +unsafeSendFileIterWith' + :: (IO Iter -> IO a) + -> Handle -- ^ The output handle + -> FilePath -- ^ The input filepath + -> Integer -- ^ maximum block size + -> Integer -- ^ The offset to start at + -> Integer -- ^ The number of bytes to send + -> IO a +unsafeSendFileIterWith' stepper outp infp blockSize offset count = + withBinaryFile infp ReadMode $ \inp -> do + unsafeSendFileIterWith'' stepper outp inp blockSize offset count + -- | wraps sendFile' to check arguments -wrapSendFile' :: Integral i => (a -> b -> i -> i -> IO ()) -> a -> b -> Integer -> Integer -> IO () -wrapSendFile' fun outp inp off count - | off < 0 = error "SendFile - offset must be a positive integer" - | count < 0 = error "SendFile - count must be a positive integer" - | count == 0 = return () -- Send nothing -- why do the work? Also, Windows and FreeBSD treat '0' as 'send the whole file'. - | otherwise = fun outp inp (fromIntegral off) (fromIntegral count) +wrapSendFile' :: Integral i => (a -> b -> i -> i -> i -> IO c) -> a -> b -> Integer -> Integer -> Integer -> IO c +wrapSendFile' fun outp inp blockSize off count +-- | count == 0 = return () -- Send nothing -- why do the work? Also, Windows and FreeBSD treat '0' as 'send the whole file'. + | count < 0 = error "SendFile - count must be a positive integer" + | (count /= 0) && (blockSize <= 0) = error "SendFile - blockSize must be a positive integer greater than 1" + | off < 0 = error "SendFile - offset must be a positive integer" + | otherwise = fun outp inp (fromIntegral blockSize) (fromIntegral off) (fromIntegral count) -#if !defined(PORTABLE_SENDFILE) -handleToFd :: Handle -> IO Fd -#ifdef __GLASGOW_HASKELL__ -#if __GLASGOW_HASKELL__ >= 611 -handleToFd h = withHandle "handleToFd" h $ \ Handle__{..} -> do - case cast haDevice of - Nothing -> ioError (ioeSetErrorString (mkIOError IllegalOperation - "handleToFd" (Just h) Nothing) - "handle is not a file descriptor") - Just fd -> do - return (Handle__{..} , Fd (fromIntegral (FD.fdFD fd))) -#else -handleToFd h = withHandle "handleToFd" h $ \ h_ -> do - return (h_, Fd (fromIntegral (haFD h_))) -#endif -#endif -#endif diff --git a/src/Network/Socket/SendFile/Iter.hs b/src/Network/Socket/SendFile/Iter.hs new file mode 100644 --- /dev/null +++ b/src/Network/Socket/SendFile/Iter.hs @@ -0,0 +1,108 @@ +module Network.Socket.SendFile.Iter where + +import Control.Concurrent (threadWaitWrite) +import Data.Int (Int64) +import System.Posix.Types (Fd) + +-- | An iteratee for sendfile +-- +-- In general, a whole file is not sent by a single call to +-- sendfile(), but a series of calls which send successive pieces. +-- +-- The high-level API in this sendfile library has calls which will +-- send the entire file (or an entire requested offset+length), before +-- returning. +-- +-- However, there are instances where you want to be a bit more +-- involved in the sending loop. For example, if you want to tickle a +-- timeout after each chunk is sent or update a progress bar. +-- +-- The 'Iter' type gives you that power with out requiring you to +-- manage all the low-level details of the sendfile loop. The +-- interface is simple and consistant across all platforms. +-- +-- A call to sendfile() can result in three different states: +-- +-- (1) the requested number of bytes for that iteration was sent +-- successfully, there are more bytes left to send. +-- +-- (2) some (possibly 0) bytes were sent, but the file descriptor +-- would now block if more bytes were written. There are more bytes +-- left to send. +-- +-- (2) All the bytes were sent, and there is nothing left to send. +-- +-- We handle these three cases by using a type with three +-- constructors: +-- +-- @ +-- data Iter +-- = Sent Int64 (IO Iter) +-- | WouldBlock Int64 Fd (IO Iter) +-- | Done Int64 +-- @ +-- +-- All three constructors provide an 'Int64' which represents the +-- number of bytes sent for that particular iteration. (Not the total +-- byte count). +-- +-- The 'Sent' and 'WouldBlock' constructors provide 'IO' 'Iter' as their +-- final argument. Running this IO action will send the next block of +-- data. +-- +-- The 'WouldBlock' constructor also provides the 'Fd' for the output +-- socket. You should not send anymore data until the 'Fd' would not +-- block. The easiest way to do that is to use 'threadWaitWrite' to +-- suspend the thread until the 'Fd' is available. +-- +-- A very simple function to drive the Iter might look like: +-- +-- @ +-- runIter :: IO Iter -> IO () +-- runIter iter = +-- do r <- iter +-- case r of +-- (Done _n) -> return () +-- (Sent _n cont) -> runIter cont +-- (WouldBlock _n fd cont) -> +-- do threadWaitWrite fd +-- runIter cont +-- @ +-- +-- You would use it as the first argument to a *IterWith function, e.g. +-- +-- @ +-- sendFileIterWith runIter outputSocket \"\/path\/to\/file\" 2^16 +-- @ +-- +-- The 'runIter' function provided by this module is similar, but also returns the total number of bytes sent. +-- +-- NOTE: You must not use the 'Fd' or the 'IO' 'Iter' after the call +-- to *IterWith has returned. When the *IterWith functions return, +-- the file descriptors may be closed due to finalizers running. +data Iter + = Sent Int64 (IO Iter) -- ^ number of bytes sent this pass and a continuation to send more + | WouldBlock Int64 Fd (IO Iter) -- ^ number of bytes sent, Fd that blocked, continuation to send more. NOTE: The Fd should not be used outside the running of the Iter as it may be freed when the Iter is done + | Done Int64 -- ^ number of bytes sent, no more to send + +-- | A simple function to drive the *IterWith functions. +-- It returns the total number of bytes sent. +runIter :: IO Iter -> IO Int64 +runIter = runIter' 0 + where + runIter' :: Int64 -> IO Iter -> IO Int64 + runIter' acc iter = + do r <- iter + case r of + (Sent n cont) -> + do let acc' = (acc + n) +-- putStrLn $ "Sent " ++ show acc' + acc' `seq` runIter' acc' cont + (Done n) -> + do -- putStrLn $ "Done " ++ show (acc + n) + return (acc + n) + (WouldBlock n fd cont) -> + do threadWaitWrite fd + let acc' = (acc + n) +-- putStrLn $ "WouldBlock " ++ (show acc') + acc' `seq` runIter' acc' cont diff --git a/src/Network/Socket/SendFile/Linux.hsc b/src/Network/Socket/SendFile/Linux.hsc --- a/src/Network/Socket/SendFile/Linux.hsc +++ b/src/Network/Socket/SendFile/Linux.hsc @@ -1,40 +1,76 @@ {-# LANGUAGE ForeignFunctionInterface #-} -- | Linux system-dependent code for 'sendfile'. -module Network.Socket.SendFile.Linux (_sendFile) where -import Data.Int -import Data.Word +module Network.Socket.SendFile.Linux (_sendFile, sendFileIter, sendfile) where + +import Data.Int (Int32, Int64) +import Data.Word (Word32) import Foreign.C.Error (eAGAIN, getErrno, throwErrno) import Foreign.Marshal (alloca) import Foreign.Ptr (Ptr) import Foreign.Storable(poke) +import Network.Socket.SendFile.Iter (Iter(..), runIter) import System.Posix.Types (Fd) -import Control.Concurrent (threadWaitWrite) - #include +-- | automatically loop and send everything _sendFile :: Fd -> Fd -> Int64 -> Int64 -> IO () -_sendFile out_fd in_fd off count = do - alloca $ \poff -> do - poke poff off - rsendfile out_fd in_fd poff count +_sendFile out_fd in_fd off count = + do _ <- runIter (sendFileIter out_fd in_fd count off count) -- set blockSize == count. ie. send it all if we can. + return () -rsendfile :: Fd -> Fd -> Ptr Int64 -> Int64 -> IO () -rsendfile _ _ _ 0 = return () -rsendfile out_fd in_fd poff remaining = do - let bytes = min remaining maxBytes - sbytes <- sendfile out_fd in_fd poff bytes - rsendfile out_fd in_fd poff (remaining - sbytes) - -sendfile :: Fd -> Fd -> Ptr Int64 -> Int64 -> IO Int64 -sendfile out_fd in_fd poff bytes = do - threadWaitWrite out_fd - sbytes <- c_sendfile out_fd in_fd poff (fromIntegral bytes) +-- | a way to send things in chunks +sendFileIter :: Fd -- ^ file descriptor corresponding to network socket + -> Fd -- ^ file descriptor corresponding to file + -> Int64 -- ^ maximum number of bytes to send at once + -> Int64 -- ^ offset into file + -> Int64 -- ^ total number of bytes to send + -> IO Iter +sendFileIter out_fd in_fd blockSize off remaining = +-- alloca $ \poff -> +-- do poke poff off + sendFileIterI out_fd in_fd (min blockSize maxBytes) off remaining + +sendFileIterI :: Fd -- ^ file descriptor corresponding to network socket + -> Fd -- ^ file descriptor corresponding to file + -> Int64 -- ^ maximum number of bytes to send at once + -> Int64 -- ^ offset into file + -> Int64 -- ^ total number of bytes to send + -> IO Iter +sendFileIterI _out_fd _in_fd _blockSize _off 0 = return (Done 0) +sendFileIterI out_fd in_fd blockSize off remaining = + do let bytes = min remaining blockSize + (wouldBlock, sbytes) <- sendfile out_fd in_fd off bytes + let cont = sendFileIterI out_fd in_fd blockSize (off + sbytes) (remaining `safeMinus` sbytes) + case wouldBlock of + True -> return (WouldBlock sbytes out_fd cont) + False -> return (Sent sbytes cont) + +-- | low-level wrapper around sendfile +-- non-blocking +-- returns number of bytes written and whether the fd would block (aka, EAGAIN) +-- does not call 'threadWaitWrite' +sendfile :: Fd -> Fd -> Int64 -> Int64 -> IO (Bool, Int64) +sendfile out_fd in_fd off bytes = + alloca $ \poff -> + do poke poff off + sendfileI out_fd in_fd poff bytes + +-- low-level wrapper around linux sendfile +sendfileI :: Fd -> Fd -> Ptr Int64 -> Int64 -> IO (Bool, Int64) +sendfileI out_fd in_fd poff bytes = do + sbytes <- {-# SCC "c_sendfile" #-} c_sendfile out_fd in_fd poff (fromIntegral bytes) if sbytes <= -1 then do errno <- getErrno if errno == eAGAIN - then sendfile out_fd in_fd poff bytes - else throwErrno "Network.Socket.SendFile.Linux" - else return (fromIntegral sbytes) + then return (True, 0) + else throwErrno "Network.Socket.SendFile.Linux.sendfileI" + else return (False, fromIntegral sbytes) + +safeMinus :: (Ord a, Num a) => a -> a -> a +safeMinus x y + | y > x = error $ "y > x " ++ show (y,x) + | otherwise = x - y + -- max num of bytes in one send maxBytes :: Int64 diff --git a/src/Network/Socket/SendFile/Win32.hsc b/src/Network/Socket/SendFile/Win32.hsc --- a/src/Network/Socket/SendFile/Win32.hsc +++ b/src/Network/Socket/SendFile/Win32.hsc @@ -1,6 +1,6 @@ {-# LANGUAGE ForeignFunctionInterface #-} -- | Win32 system-dependent code for 'TransmitFile'. -module Network.Socket.SendFile.Win32 (_sendFile) where +module Network.Socket.SendFile.Win32 (_sendFile, sendFileIter) where import Data.Bits ((.|.)) import Data.Int import Foreign.C.Error (throwErrnoIf) @@ -8,6 +8,7 @@ import Foreign.Marshal.Alloc (alloca) import Foreign.Ptr (IntPtr, Ptr, intPtrToPtr, nullPtr) import Foreign.Storable (peek) +import Network.Socket.SendFile.Iter (Iter(..),runIter) import System.Posix.Types (Fd) import System.Win32.Types (DWORD, HANDLE, failIfZero) @@ -17,10 +18,35 @@ type SOCKET = Fd _sendFile :: Fd -> Fd -> Int64 -> Int64 -> IO () -_sendFile out_fd in_fd off count = do - in_hdl <- get_osfhandle in_fd - rtransmitFile out_fd in_hdl off count +_sendFile out_fd in_fd off count = + do _ <- runIter (sendFileIter out_fd in_fd (fromIntegral count) (fromIntegral off) (fromIntegral count)) -- set blockSize == count. ie. send it all if we can. + return () +sendFileIter :: Fd -- ^ file descriptor corresponding to network socket + -> Fd -- ^ file descriptor corresponding to file + -> Int64 -- ^ maximum number of bytes to send at once + -> Int64 -- ^ offset into file + -> Int64 -- ^ total number of bytes to send + -> IO Iter +sendFileIter out_fd in_fd blockSize off count = + do in_hdl <- get_osfhandle in_fd + sendFileIterI out_fd in_hdl (min (fromIntegral blockSize) maxBytes) (fromIntegral off) (fromIntegral count) + +sendFileIterI :: SOCKET -- ^ file descriptor corresponding to network socket + -> HANDLE -- ^ file descriptor corresponding to file + -> Int64 -- ^ maximum number of bytes to send at once + -> Int64 -- ^ offset into file + -> Int64 -- ^ total number of bytes to send + -> IO Iter +sendFileIterI _out_fd _in_fd _blockSize _off 0 = return (Done 0) +sendFileIterI out_fd in_fd blockSize off remaining = + do let bytes = min remaining blockSize + (wouldBlock, nsent) <- sendfileI out_fd in_fd off bytes + let cont = sendFileIterI out_fd in_fd blockSize (off + nsent) (remaining `safeMinus` (fromIntegral nsent)) + case wouldBlock of + True -> return (WouldBlock (fromIntegral nsent) out_fd cont) + False -> return (Sent (fromIntegral nsent) cont) + get_osfhandle :: Fd -- ^ User file descriptor. -> IO HANDLE -- ^ The operating-system file handle. get_osfhandle fd = do @@ -36,25 +62,23 @@ -> DWORD -- ^ the move method -> IO Int64 -- ^ the new absolute offset setFilePointerEx hdl off meth = alloca $ \res -> do - failIfZero + _ <- failIfZero "Network.Socket.SendFile.Win32.setFilePointerEx" (c_SetFilePointerEx hdl off res meth) peek res -rtransmitFile :: SOCKET -> HANDLE -> Int64 -> Int64 -> IO () -rtransmitFile _ _ _ 0 = return () -rtransmitFile out_fd in_hdl off remaining = do - let bytes = min remaining maxBytes - setFilePointerEx in_hdl off (#const FILE_BEGIN) - transmitFile out_fd in_hdl (fromIntegral bytes) - rtransmitFile out_fd in_hdl (off + bytes) (remaining - bytes) +sendfileI :: SOCKET -> HANDLE -> Int64 -> Int64 -> IO (Bool, Int64) +sendfileI out_fd in_hdl off count = + do _ <- setFilePointerEx in_hdl off (#const FILE_BEGIN) + transmitFile out_fd in_hdl (fromIntegral count) + return (False, count) transmitFile :: SOCKET -- ^ A handle to a connected socket. -> HANDLE -- ^ A handle to the open file that the TransmitFile function transmits. -> DWORD -- ^ The number of bytes in the file to transmit. -> IO () transmitFile out_fd in_hdl count = do - failIfZero + _ <- failIfZero "Network.Socket.SendFile.Win32.transmitFile" (c_TransmitFile out_fd in_hdl count 0 nullPtr nullPtr (#{const TF_USE_KERNEL_APC} .|. #{const TF_WRITE_BEHIND})) return () @@ -62,6 +86,11 @@ -- If the TransmitFile function is called with the lpOverlapped parameter -- set to NULL, the operation is executed as synchronous I/O. The function -- will not complete until the file has been sent. + +safeMinus :: (Ord a, Num a) => a -> a -> a +safeMinus x y + | y >= x = 0 + | otherwise = x - y -- max num of bytes in one send -- Windows will complain of an "invalid argument" if you use the maxBound of a DWORD, despite the fact that the count parameter is a DWORD; so the upper bound of a 32-bit integer seems to be the real limit, similar to Linux.