diff --git a/Network/Sendfile.hs b/Network/Sendfile.hs --- a/Network/Sendfile.hs +++ b/Network/Sendfile.hs @@ -6,14 +6,18 @@ are the bottleneck of web servers. -} -module Network.Sendfile (sendfile, FileRange(..)) where +module Network.Sendfile ( + sendfile + , sendfileWithHeader + , FileRange(..) + ) where import Network.Sendfile.Types #ifdef OS_BSD import Network.Sendfile.BSD #elif OS_MacOS -import Network.Sendfile.MacOS +import Network.Sendfile.BSD #elif OS_Linux import Network.Sendfile.Linux #elif OS_Windows diff --git a/Network/Sendfile/BSD.hsc b/Network/Sendfile/BSD.hsc --- a/Network/Sendfile/BSD.hsc +++ b/Network/Sendfile/BSD.hsc @@ -1,75 +1,166 @@ {-# LANGUAGE ForeignFunctionInterface #-} -module Network.Sendfile.BSD (sendfile) where +module Network.Sendfile.BSD ( + sendfile + , sendfileWithHeader + ) where import Control.Concurrent import Control.Exception import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno) -import Foreign.C.Types (CInt, CSize) +import Foreign.C.Types import Foreign.Marshal (alloca) import Foreign.Ptr (Ptr, nullPtr) -import Foreign.Storable (peek) +import Foreign.Storable (peek, poke) +import Network.Sendfile.IOVec import Network.Sendfile.Types import Network.Socket +import Network.Socket.ByteString import System.Posix.IO -import System.Posix.Types (Fd(..), COff) +import System.Posix.Types -{-| - Simple binding for sendfile() of BSD. +#include - - Used system calls: open(), sendfile(), and close(). +entire :: COff +entire = 0 - 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 bofore waiting the socket to be ready for writing. --} +-- | +-- Simple binding for sendfile() of BSD and MacOS. +-- +-- - Used system calls: open(), sendfile(), and close(). +-- +-- 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 bofore waiting the socket to be ready for writing. + sendfile :: Socket -> FilePath -> FileRange -> IO () -> IO () -sendfile sock path range hook = bracket - (openFd path ReadOnly Nothing defaultFileFlags) - closeFd - sendfile' +sendfile sock path range hook = bracket setup teardown $ \fd -> + alloca $ \sentp -> do + let (off,len) = case range of + EntireFile -> (0, entire) + PartOfFile off' len' -> (fromInteger off', fromInteger len') + sendloop dst fd off len sentp hook where + setup = openFd path ReadOnly Nothing defaultFileFlags + teardown = closeFd dst = Fd $ fdSocket sock - sendfile' fd = alloca $ \lenp -> - case range of - EntireFile -> sendEntire dst fd 0 lenp hook - PartOfFile off len -> do - let off' = fromInteger off - len' = fromInteger len - sendPart dst fd off' len' lenp hook -sendEntire :: Fd -> Fd -> COff -> Ptr COff -> IO () -> IO () -sendEntire dst src off lenp hook = do - rc <- c_sendfile src dst off 0 lenp +sendloop :: Fd -> Fd -> COff -> COff -> Ptr COff -> IO () -> IO () +sendloop dst src off len sentp hook = do + rc <- sendFile src dst off len sentp nullPtr when (rc /= 0) $ do errno <- getErrno - if errno `elem` [eAGAIN, eINTR] - then do - sent <- peek lenp - hook - threadWaitWrite dst - sendEntire dst src (off + sent) lenp hook - else throwErrno "Network.SendFile.BSD.sendEntire" + if errno `elem` [eAGAIN, eINTR] then do + sent <- peek sentp + hook + threadWaitWrite dst + let newoff = off + sent + newlen = if len == entire then entire else len - sent + sendloop dst src newoff newlen sentp hook + else + throwErrno "Network.SendFile.MacOS.sendloop" -sendPart :: Fd -> Fd -> COff -> CSize -> Ptr COff -> IO () -> IO () -sendPart dst src off len lenp hook = do - rc <- c_sendfile src dst off len lenp - when (rc /= 0) $ do +---------------------------------------------------------------- + +-- | +-- Simple binding for sendfile() of BSD and MacOS. +-- +-- - Used system calls: open(), sendfile(), and close(). +-- +-- The fifth header is also sent with sendfile(). If the file is +-- small enough, the header and the file is send in a single TCP packet +-- on FreeBSD. MacOS sends the header and the file separately but it is +-- fast. +-- +-- 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 bofore waiting the socket to be ready for writing. + +sendfileWithHeader :: Socket -> FilePath -> FileRange -> IO () -> [ByteString] -> IO () +sendfileWithHeader sock path range hook hdr = + bracket setup teardown $ \fd -> alloca $ \sentp -> + if isFreeBSD && hlen >= 8192 then do + -- If the length of the header is larger than 8191, + -- threadWaitWrite does not come back on FreeBSD, sigh. + -- We use writev() for the header and sendfile() for the file. + sendMany sock hdr + hook + sendfile sock path range hook + else do + -- On MacOS, the header and the body are sent separately. + -- But it's fast. the writev() and sendfile() combination + -- is also fast. + let (off,len) = case range of + EntireFile -> (0,entire) + PartOfFile off' len' -> (fromInteger off' + ,fromInteger len' + hlen) + mrc <- sendloopHeader dst fd off len sentp hook hdr hlen + case mrc of + Nothing -> return () + Just (newoff,newlen) -> do + hook + threadWaitWrite dst + sendloop dst fd newoff newlen sentp hook + where + setup = openFd path ReadOnly Nothing defaultFileFlags + teardown = closeFd + dst = Fd $ fdSocket sock + hlen = fromIntegral . sum . map BS.length $ hdr + +sendloopHeader :: Fd -> Fd -> COff -> COff -> Ptr COff -> IO () -> [ByteString] -> COff -> IO (Maybe (COff, COff)) +sendloopHeader dst src off len sentp hook hdr hlen = do + rc <- withSfHdtr hdr $ sendFile src dst off len sentp + if rc == 0 then + return Nothing + else do errno <- getErrno - if errno `elem` [eAGAIN, eINTR] - then do - sent <- peek lenp - let off' = off + sent - len' = len - fromIntegral sent + if errno `elem` [eAGAIN, eINTR] then do + sent <- peek sentp + if sent >= hlen then do + let newoff = off + sent - hlen + if len == entire then + return $ Just (newoff, entire) + else + return $ Just (newoff, len - sent) + else do hook threadWaitWrite dst - sendPart dst src off' len' lenp hook - else throwErrno "Network.SendFile.BSD.sendPart" + let newlen = if len == entire then entire else len - sent + newhdr = remainingChunks (fromIntegral sent) hdr + newhlen = hlen - sent + sendloopHeader dst src off newlen sentp hook newhdr newhlen + else + throwErrno "Network.SendFile.MacOS.sendloopHeader" -c_sendfile :: Fd -> Fd -> COff -> CSize -> Ptr COff -> IO CInt -c_sendfile fd s offset len lenp = c_sendfile' fd s offset len nullPtr lenp 0 +---------------------------------------------------------------- -foreign import ccall unsafe "sys/uio.h sendfile" c_sendfile' - :: Fd -> Fd -> COff -> CSize -> Ptr () -> Ptr COff -> CInt -> IO CInt +#ifdef OS_MacOS +-- Shuffle the order of arguments for currying. +sendFile :: Fd -> Fd -> COff -> COff -> Ptr COff -> Ptr SfHdtr -> IO CInt +sendFile fd s off len sentp hdrp = do + poke sentp len + c_sendfile fd s off sentp hdrp 0 + +foreign import ccall unsafe "sys/uio.h sendfile" + c_sendfile :: Fd -> Fd -> COff -> Ptr COff -> Ptr SfHdtr -> CInt -> IO CInt + +isFreeBSD :: Bool +isFreeBSD = False +#else +-- Let's don't use CSize for 'len' and use COff for convenience. +-- Shuffle the order of arguments for currying. +sendFile :: Fd -> Fd -> COff -> COff -> Ptr COff -> Ptr SfHdtr -> IO CInt +sendFile fd s off len sentp hdrp = + c_sendfile fd s off (fromIntegral len) hdrp sentp 0 + +foreign import ccall unsafe "sys/uio.h sendfile" + c_sendfile :: Fd -> Fd -> COff -> CSize -> Ptr SfHdtr -> Ptr COff -> CInt -> IO CInt + +isFreeBSD :: Bool +isFreeBSD = True +#endif diff --git a/Network/Sendfile/Fallback.hs b/Network/Sendfile/Fallback.hs --- a/Network/Sendfile/Fallback.hs +++ b/Network/Sendfile/Fallback.hs @@ -1,4 +1,7 @@ -module Network.Sendfile.Fallback (sendfile) where +module Network.Sendfile.Fallback ( + sendfile + , sendfileWithHeader + ) where import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.ByteString (ByteString) @@ -6,18 +9,20 @@ import Data.Conduit.Binary as EB import Network.Sendfile.Types import Network.Socket +import Network.Socket.ByteString import qualified Network.Socket.ByteString as SB -{-| - Sendfile emulation using enumerator. +-- | +-- Sendfile emulation using conduit. +-- Used system calls: +-- +-- - Used system calls: open(), stat(), read(), send() and close(). - - Used system calls: open(), stat(), read(), send() and close(). --} sendfile :: Socket -> FilePath -> FileRange -> IO () -> IO () -sendfile s fp EntireFile hook = - runResourceT $ sourceFile fp $$ sinkSocket s hook -sendfile s fp (PartOfFile off len) hook = - runResourceT $ EB.sourceFileRange fp (Just off) (Just len) $$ sinkSocket s hook +sendfile sock path EntireFile hook = + runResourceT $ sourceFile path $$ sinkSocket sock hook +sendfile sock path (PartOfFile off len) hook = + runResourceT $ EB.sourceFileRange path (Just off) (Just len) $$ sinkSocket sock hook -- See sinkHandle. sinkSocket :: MonadIO m => Socket -> IO () -> Sink ByteString m () @@ -28,3 +33,15 @@ liftIO hook return (NeedInput push close) close = return () + +-- | +-- Sendfile emulation using conduit. +-- Used system calls: +-- +-- - Used system calls: open(), stat(), read(), writev(), send() and close(). + +sendfileWithHeader :: Socket -> FilePath -> FileRange -> IO () -> [ByteString] -> IO () +sendfileWithHeader sock path range hook hdr = do + sendMany sock hdr + hook + sendfile sock path range hook diff --git a/Network/Sendfile/IOVec.hsc b/Network/Sendfile/IOVec.hsc new file mode 100644 --- /dev/null +++ b/Network/Sendfile/IOVec.hsc @@ -0,0 +1,94 @@ +{- Original: Network/Socket/ByteString/* -} + +-- | Support module for the POSIX writev system call. +module Network.Sendfile.IOVec ( + IOVec(..) + , SfHdtr(..) + , withSfHdtr + , remainingChunks + ) where + +import Control.Monad (zipWithM_) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Foreign.C.Types (CChar, CInt, CSize) +import Foreign.Marshal (alloca) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Ptr (Ptr, nullPtr, plusPtr) +import Foreign.Storable (Storable(..)) + +#include +#include + +---------------------------------------------------------------- + +data IOVec = IOVec { + iovBase :: Ptr CChar + , iovLen :: CSize + } + +instance Storable IOVec where + sizeOf _ = (#const sizeof(struct iovec)) + alignment _ = alignment (undefined :: CInt) + + peek p = do + base <- (#peek struct iovec, iov_base) p + len <- (#peek struct iovec, iov_len) p + return $ IOVec base len + + poke p iov = do + (#poke struct iovec, iov_base) p (iovBase iov) + (#poke struct iovec, iov_len) p (iovLen iov) + +---------------------------------------------------------------- + +data SfHdtr = SfHdtr { + sfhdtrHdr :: Ptr IOVec + , sfhdtrHdrLen :: CInt + } + +instance Storable SfHdtr where + sizeOf _ = (#const sizeof(struct sf_hdtr)) + alignment _ = alignment (undefined :: CInt) + + peek p = do + hdr <- (#peek struct sf_hdtr, headers) p + hlen <- (#peek struct sf_hdtr, hdr_cnt) p + return $ SfHdtr hdr hlen + + poke p sfhdtr = do + (#poke struct sf_hdtr, headers) p (sfhdtrHdr sfhdtr) + (#poke struct sf_hdtr, hdr_cnt) p (sfhdtrHdrLen sfhdtr) + (#poke struct sf_hdtr, trailers) p nullPtr + (#poke struct sf_hdtr, trl_cnt) p (0 :: CInt) + +---------------------------------------------------------------- + +withIOVec :: [ByteString] -> ((Ptr IOVec, Int) -> IO a) -> IO a +withIOVec cs f = + allocaArray csLen $ \aPtr -> do + zipWithM_ pokeIov (ptrs aPtr) cs + f (aPtr, csLen) + where + csLen = length cs + ptrs = iterate (`plusPtr` sizeOf (undefined :: IOVec)) + pokeIov ptr s = + unsafeUseAsCStringLen s $ \(sPtr, sLen) -> + poke ptr $ IOVec sPtr (fromIntegral sLen) + +withSfHdtr :: [ByteString] -> (Ptr SfHdtr -> IO a) -> IO a +withSfHdtr cs f = withIOVec cs $ \(iovecp,len) -> + alloca $ \sfhdtrp -> do + poke sfhdtrp $ SfHdtr iovecp (fromIntegral len) + f sfhdtrp + +---------------------------------------------------------------- + +remainingChunks :: Int -> [ByteString] -> [ByteString] +remainingChunks _ [] = [] +remainingChunks i (x:xs) + | i < len = BS.drop i x : xs + | otherwise = let i' = i - len in i' `seq` remainingChunks i' xs + where + len = BS.length x diff --git a/Network/Sendfile/Linux.hsc b/Network/Sendfile/Linux.hsc --- a/Network/Sendfile/Linux.hsc +++ b/Network/Sendfile/Linux.hsc @@ -1,77 +1,134 @@ {-# LANGUAGE ForeignFunctionInterface #-} -module Network.Sendfile.Linux (sendfile) where +module Network.Sendfile.Linux ( + sendfile + , sendfileWithHeader + ) where import Control.Applicative -import Control.Concurrent import Control.Exception +import Control.Monad +import Data.ByteString as B +import Data.ByteString.Unsafe import Data.Int -import Data.Word import Foreign.C.Error (eAGAIN, getErrno, throwErrno) +import Foreign.C.Types import Foreign.Marshal (alloca) import Foreign.Ptr (Ptr) import Foreign.Storable (poke) +import GHC.Conc (threadWaitWrite) import Network.Sendfile.Types import Network.Socket +import Network.Socket.Internal (throwSocketErrorIfMinus1RetryMayBlock) import System.Posix.Files import System.Posix.IO -import System.Posix.Types (Fd(..)) +import System.Posix.Types #include - -{-| - Simple binding for sendfile() of Linux. - Used system calls: +#include - - 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. +-- | +-- 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 bofore waiting the socket to be ready for writing. - 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 bofore waiting the socket to be ready for writing. --} sendfile :: Socket -> FilePath -> FileRange -> IO () -> IO () -sendfile sock path range hook = bracket - (openFd path ReadOnly Nothing defaultFileFlags) - closeFd - sendfile' +sendfile sock path range hook = bracket setup teardown $ \fd -> + alloca $ \offp -> case range of + EntireFile -> do + poke offp 0 + -- System call is very slow. Use PartOfFile instead. + len <- fileSize <$> getFdStatus fd + let len' = fromIntegral len + sendloop dst fd offp len' hook + PartOfFile off len -> do + poke offp (fromIntegral off) + let len' = fromIntegral len + sendloop dst fd offp len' hook where + setup = openFd path ReadOnly Nothing defaultFileFlags + teardown = closeFd dst = Fd $ fdSocket sock - sendfile' fd = alloca $ \offp -> do - case range of - EntireFile -> do - poke offp 0 - -- System call is very slow. Use PartOfFile instead. - len <- fileSize <$> getFdStatus fd - let len' = fromIntegral len - sendPart dst fd offp len' hook - PartOfFile off len -> do - poke offp (fromIntegral off) - let len' = fromIntegral len - sendPart dst fd offp len' hook -sendPart :: Fd -> Fd -> Ptr (#type off_t) -> (#type size_t) -> IO () -> IO () -sendPart dst src offp len hook = do - do bytes <- c_sendfile dst src offp len - case bytes of - -1 -> do errno <- getErrno - if errno == eAGAIN - then loop len - else throwErrno "Network.SendFile.Linux.sendPart" - 0 -> return () -- the file is truncated - _ -> loop (len - fromIntegral bytes) +sendloop :: Fd -> Fd -> Ptr COff -> CSize -> IO () -> IO () +sendloop dst src offp len hook = do + bytes <- c_sendfile dst src offp len + case bytes of + -1 -> do + errno <- getErrno + if errno == eAGAIN then + loop len + else + throwErrno "Network.SendFile.Linux.sendloop" + 0 -> return () -- the file is truncated + _ -> loop (len - fromIntegral bytes) where - loop left - | left == 0 = return () - | otherwise = do - hook - threadWaitWrite dst - sendPart dst src offp left hook + loop 0 = return () + loop left = do + hook + threadWaitWrite dst + sendloop dst src offp left hook -- Dst Src in order. take care -foreign import ccall unsafe "sendfile" c_sendfile - :: Fd -> Fd -> Ptr (#type off_t) -> (#type size_t) -> IO (#type ssize_t) +foreign import ccall unsafe "sendfile" + c_sendfile :: Fd -> Fd -> Ptr COff -> CSize -> IO (#type ssize_t) + +---------------------------------------------------------------- + +-- | +-- 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 bofore waiting the socket to be ready for writing. + +sendfileWithHeader :: Socket -> FilePath -> FileRange -> IO () -> [ByteString] -> IO () +sendfileWithHeader sock path range hook hdr = do + -- Copying is much faster than syscall. + sendAllMsgMore sock hook $ B.concat hdr + hook + sendfile sock path range hook + +sendAllMsgMore :: Socket -> IO () -> ByteString -> IO () +sendAllMsgMore sock hook bs = do + sent <- sendMsgMore sock bs + when (sent < B.length bs) $ do + hook + sendAllMsgMore sock hook (B.drop sent bs) + +sendMsgMore :: Socket -> ByteString -> IO Int +sendMsgMore (MkSocket s _ _ _ _) xs = + unsafeUseAsCStringLen xs $ \(str, len) -> + fromIntegral <$> throwSocketErrorIfMinus1RetryMayBlock + "sendMsgMore" + (threadWaitWrite (fromIntegral s)) + (c_send s str (fromIntegral len) (#const MSG_MORE)) + +foreign import ccall unsafe "send" + c_send :: CInt -> Ptr CChar -> CSize -> CInt -> IO (#type ssize_t) diff --git a/Network/Sendfile/MacOS.hsc b/Network/Sendfile/MacOS.hsc deleted file mode 100644 --- a/Network/Sendfile/MacOS.hsc +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} - -module Network.Sendfile.MacOS (sendfile) where - -import Control.Concurrent -import Control.Exception -import Control.Monad -import Data.Int -import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno) -#if __GLASGOW_HASKELL__ >= 703 -import Foreign.C.Types (CInt(CInt)) -#else -import Foreign.C.Types (CInt) -#endif -import Foreign.Marshal (alloca) -import Foreign.Ptr (Ptr, nullPtr) -import Foreign.Storable (peek, poke) -import Network.Sendfile.Types -import Network.Socket -import System.Posix.IO -import System.Posix.Types (Fd(..)) - -#include - -{-| - Simple binding for sendfile() of MacOS. - - - Used system calls: open(), sendfile(), and close(). - - 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 bofore waiting the socket to be ready for writing. --} -sendfile :: Socket -> FilePath -> FileRange -> IO () -> IO () -sendfile sock path range hook = bracket - (openFd path ReadOnly Nothing defaultFileFlags) - closeFd - sendfile' - where - dst = Fd $ fdSocket sock - sendfile' fd = alloca $ \lenp -> do - case range of - EntireFile -> do - poke lenp 0 - sendEntire dst fd 0 lenp hook - PartOfFile off len -> do - let off' = fromInteger off - poke lenp (fromInteger len) - sendPart dst fd off' lenp hook - -sendEntire :: Fd -> Fd -> (#type off_t) -> Ptr (#type off_t) -> IO () -> IO () -sendEntire dst src off lenp hook = do - do rc <- c_sendfile src dst off lenp - when (rc /= 0) $ do - errno <- getErrno - if errno `elem` [eAGAIN, eINTR] - then do - sent <- peek lenp - poke lenp 0 - hook - threadWaitWrite dst - sendEntire dst src (off + sent) lenp hook - else throwErrno "Network.SendFile.MacOS.sendEntire" - -sendPart :: Fd -> Fd -> (#type off_t) -> Ptr (#type off_t) -> IO () -> IO () -sendPart dst src off lenp hook = do - do len <- peek lenp - rc <- c_sendfile src dst off lenp - when (rc /= 0) $ do - errno <- getErrno - if errno `elem` [eAGAIN, eINTR] - then do - sent <- peek lenp - poke lenp (len - sent) - hook - threadWaitWrite dst - sendPart dst src (off + sent) lenp hook - else throwErrno "Network.SendFile.MacOS.sendPart" - -c_sendfile :: Fd -> Fd -> (#type off_t) -> Ptr (#type off_t) -> IO CInt -c_sendfile fd s offset lenp = c_sendfile' fd s offset lenp nullPtr 0 - -foreign import ccall unsafe "sys/uio.h sendfile" c_sendfile' - :: Fd -> Fd -> (#type off_t) -> Ptr (#type off_t) -> Ptr () -> CInt -> IO CInt diff --git a/Network/Sendfile/Types.hs b/Network/Sendfile/Types.hs --- a/Network/Sendfile/Types.hs +++ b/Network/Sendfile/Types.hs @@ -1,8 +1,8 @@ module Network.Sendfile.Types where -{-| - File range for 'sendfile'. --} +-- | +-- File range for 'sendfile'. + data FileRange = EntireFile | PartOfFile { rangeOffset :: Integer diff --git a/simple-sendfile.cabal b/simple-sendfile.cabal --- a/simple-sendfile.cabal +++ b/simple-sendfile.cabal @@ -1,5 +1,5 @@ Name: simple-sendfile -Version: 0.2.3 +Version: 0.2.4 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -9,37 +9,61 @@ This library tries to call minimum system calls which are the bottleneck of web servers. Category: Network -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.10 Build-Type: Simple +Extra-Source-Files: test/setup.sh Library - if impl(ghc >= 6.12) - GHC-Options: -Wall -fno-warn-unused-do-bind - else - GHC-Options: -Wall + Default-Language: Haskell2010 + GHC-Options: -Wall Exposed-Modules: Network.Sendfile Other-Modules: Network.Sendfile.Types - Build-Depends: base >= 4 && < 5, network + Build-Depends: base >= 4 && < 5 + , network + , bytestring -- NetBSD and OpenBSD don't have sendfile if os(freebsd) - CPP-Options: -DOS_BSD - Other-Modules: Network.Sendfile.BSD - Build-Depends: unix + CPP-Options: -DOS_BSD + Other-Modules: Network.Sendfile.BSD + Network.Sendfile.IOVec + Build-Depends: unix else if os(darwin) - CPP-Options: -DOS_MacOS - Other-Modules: Network.Sendfile.MacOS - Build-Depends: unix + CPP-Options: -DOS_MacOS + Other-Modules: Network.Sendfile.BSD + Network.Sendfile.IOVec + Build-Depends: unix else if os(linux) - CPP-Options: -DOS_Linux - Other-Modules: Network.Sendfile.Linux - Build-Depends: unix + CPP-Options: -DOS_Linux + Other-Modules: Network.Sendfile.Linux + Build-Depends: unix else - Other-Modules: Network.Sendfile.Fallback - Build-Depends: bytestring >= 0.9 && < 0.10 - , conduit >= 0.4.1 && < 0.5 - , transformers >= 0.2.2 && < 0.4 + Other-Modules: Network.Sendfile.Fallback + Build-Depends: bytestring >= 0.9 && < 0.10 + , conduit >= 0.4.1 && < 0.5 + , transformers >= 0.2.2 && < 0.4 + +Test-Suite spec + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + Hs-Source-Dirs: test + Main-Is: Spec.hs + GHC-Options: -Wall + Other-Modules: SendfileSpec + Build-Depends: base + , HUnit + , bytestring + , conduit + , directory + , hspec + , hspec-discover + , hspec-shouldbe + , network + , network-conduit + , process + , simple-sendfile + , unix Source-Repository head Type: git diff --git a/test/SendfileSpec.hs b/test/SendfileSpec.hs new file mode 100644 --- /dev/null +++ b/test/SendfileSpec.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SendfileSpec where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.ByteString.Char8 as BS +import Data.Conduit +import Data.Conduit.Binary as CB +import Data.Conduit.List as CL +import Data.Conduit.Network +import Data.IORef +import Network.Sendfile +import Network.Socket +import System.Directory +import System.Exit +import System.IO +import System.Process +import Test.Hspec.ShouldBe +import System.Posix.Files +import System.Timeout + +---------------------------------------------------------------- + +spec :: Spec +spec = do + describe "sendfile" $ do + it "sends an entire file" $ do + sendFile EntireFile `shouldReturn` ExitSuccess + it "sends a part of file" $ do + sendFile (PartOfFile 2000 1000000) `shouldReturn` ExitSuccess + it "terminates even if length is over" $ do + shouldTerminate $ sendIllegal (PartOfFile 2000 5000000) + it "terminates even if offset is over" $ do + shouldTerminate $ sendIllegal (PartOfFile 5000000 6000000) + it "terminates even if the file is truncated" $ do + shouldTerminate truncateFile + describe "sendfileWithHeader" $ do + it "sends an header and an entire file" $ do + sendFileH EntireFile `shouldReturn` ExitSuccess + it "sends an header and a part of file" $ do + sendFileH (PartOfFile 2000 1000000) `shouldReturn` ExitSuccess + it "sends a large header and an entire file" $ do + sendFileHLarge EntireFile `shouldReturn` ExitSuccess + it "sends a large header and a part of file" $ do + sendFileHLarge (PartOfFile 2000 1000000) `shouldReturn` ExitSuccess + it "terminates even if length is over" $ do + shouldTerminate $ sendIllegalH (PartOfFile 2000 5000000) + it "terminates even if offset is over" $ do + shouldTerminate $ sendIllegalH (PartOfFile 5000000 6000000) + it "terminates even if the file is truncated" $ do + shouldTerminate truncateFileH + where + fiveSecs = 5000000 + shouldTerminate body = timeout fiveSecs body `shouldReturn` Just () + +---------------------------------------------------------------- + +sendFile :: FileRange -> IO ExitCode +sendFile range = sendFileCore range [] + +sendFileH :: FileRange -> IO ExitCode +sendFileH range = sendFileCore range headers + where + headers = [ + BS.replicate 100 'a' + , "\n" + , BS.replicate 200 'b' + , "\n" + , BS.replicate 300 'c' + , "\n" + ] + +sendFileHLarge :: FileRange -> IO ExitCode +sendFileHLarge range = sendFileCore range headers + where + headers = [ + BS.replicate 10000 'a' + , "\n" + , BS.replicate 20000 'b' + , "\n" + , BS.replicate 30000 'c' + , "\n" + ] + +sendFileCore :: FileRange -> [ByteString] -> IO ExitCode +sendFileCore range headers = bracket setup teardown $ \(s2,_) -> do + runResourceT $ sourceSocket s2 $$ sinkFile outputFile + runResourceT $ copyfile range + system $ "cmp -s " ++ outputFile ++ " " ++ expectedFile + where + copyfile EntireFile = do + -- of course, we can use <> here + sourceList headers $$ sinkFile expectedFile + sourceFile inputFile $$ sinkAppendFile expectedFile + copyfile (PartOfFile off len) = do + sourceList headers $$ sinkFile expectedFile + sourceFile inputFile $= CB.isolate (off' + len') + $$ (CB.take off' >> sinkAppendFile expectedFile) + where + off' = fromIntegral off + len' = fromIntegral len + setup = do + (s1,s2) <- socketPair AF_UNIX Stream 0 + tid <- forkIO (sf s1 `finally` sendEOF s1) + return (s2,tid) + where + sf s1 + | headers == [] = sendfile s1 inputFile range (return ()) + | otherwise = sendfileWithHeader s1 inputFile range (return ()) headers + sendEOF = sClose + teardown (s2,tid) = do + sClose s2 + killThread tid + removeFileIfExists outputFile + removeFileIfExists expectedFile + inputFile = "test/inputFile" + outputFile = "test/outputFile" + expectedFile = "test/expectedFile" + +---------------------------------------------------------------- + +sendIllegal :: FileRange -> IO () +sendIllegal range = sendIllegalCore range [] + +sendIllegalH :: FileRange -> IO () +sendIllegalH range = sendIllegalCore range headers + where + headers = [ + BS.replicate 100 'a' + , "\n" + , BS.replicate 200 'b' + , "\n" + , BS.replicate 300 'c' + , "\n" + ] + +sendIllegalCore :: FileRange -> [ByteString] -> IO () +sendIllegalCore range headers = bracket setup teardown $ \(s2,_) -> do + runResourceT $ sourceSocket s2 $$ sinkFile outputFile + return () + where + setup = do + (s1,s2) <- socketPair AF_UNIX Stream 0 + tid <- forkIO (sf s1 `finally` sendEOF s1) + return (s2,tid) + where + sf s1 + | headers == [] = sendfile s1 inputFile range (return ()) + | otherwise = sendfileWithHeader s1 inputFile range (return ()) headers + sendEOF = sClose + teardown (s2,tid) = do + sClose s2 + killThread tid + removeFileIfExists outputFile + inputFile = "test/inputFile" + outputFile = "test/outputFile" + +---------------------------------------------------------------- + +truncateFile :: IO () +truncateFile = truncateFileCore [] + +truncateFileH :: IO () +truncateFileH = truncateFileCore headers + where + headers = [ + BS.replicate 100 'a' + , "\n" + , BS.replicate 200 'b' + , "\n" + , BS.replicate 300 'c' + , "\n" + ] + +truncateFileCore :: [ByteString] -> IO () +truncateFileCore headers = bracket setup teardown $ \(s2,_) -> do + runResourceT $ sourceSocket s2 $$ sinkFile outputFile + return () + where + setup = do + runResourceT $ sourceFile inputFile $$ sinkFile tempFile + (s1,s2) <- socketPair AF_UNIX Stream 0 + ref <- newIORef (1 :: Int) + tid <- forkIO (sf s1 ref `finally` sendEOF s1) + return (s2,tid) + where + sf s1 ref + | headers == [] = sendfile s1 tempFile range (hook ref) + | otherwise = sendfileWithHeader s1 tempFile range (hook ref) headers + sendEOF = sClose + hook ref = do + n <- readIORef ref + when (n == 10) $ setFileSize tempFile 900000 + writeIORef ref (n+1) + teardown (s2,tid) = do + sClose s2 + killThread tid + removeFileIfExists tempFile + removeFileIfExists outputFile + inputFile = "test/inputFile" + tempFile = "test/tempFile" + outputFile = "test/outputFile" + range = EntireFile + +---------------------------------------------------------------- + +removeFileIfExists :: FilePath -> IO () +removeFileIfExists file = do + exist <- doesFileExist file + when exist $ removeFile file + +sinkAppendFile :: MonadResource m + => FilePath + -> Sink ByteString m () +sinkAppendFile fp = sinkIOHandle (openBinaryFile fp AppendMode) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/setup.sh b/test/setup.sh new file mode 100644 --- /dev/null +++ b/test/setup.sh @@ -0,0 +1,3 @@ +#! /bin/sh + +ln -s /usr/share/dict/words inputFile