simple-sendfile-0.2.11/0000755000000000000000000000000012111016062013027 5ustar0000000000000000simple-sendfile-0.2.11/LICENSE0000644000000000000000000000276512111016062014046 0ustar0000000000000000Copyright (c) 2009, IIJ Innovation Institute Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. simple-sendfile-0.2.11/Setup.hs0000644000000000000000000000005612111016062014464 0ustar0000000000000000import Distribution.Simple main = defaultMain simple-sendfile-0.2.11/simple-sendfile.cabal0000644000000000000000000000442712111016062017102 0ustar0000000000000000Name: simple-sendfile Version: 0.2.11 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE Synopsis: Cross platform library for the sendfile system call Description: Cross platform library for the sendfile system call. This library tries to call minimum system calls which are the bottleneck of web servers. Category: Network Cabal-Version: >= 1.10 Build-Type: Simple Library Default-Language: Haskell2010 GHC-Options: -Wall Exposed-Modules: Network.Sendfile Other-Modules: Network.Sendfile.Types 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 Network.Sendfile.IOVec Build-Depends: unix else if os(darwin) 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 else Other-Modules: Network.Sendfile.Fallback Build-Depends: conduit >= 0.4.1 && < 1.1 , 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 >= 1.3 , network , network-conduit , process , simple-sendfile , unix Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/simple-sendfile simple-sendfile-0.2.11/Network/0000755000000000000000000000000012111016062014460 5ustar0000000000000000simple-sendfile-0.2.11/Network/Sendfile.hs0000644000000000000000000000106012111016062016542 0ustar0000000000000000{-# LANGUAGE CPP #-} {-| Cross platform library for the sendfile system call. This library tries to call minimum system calls which are the bottleneck of web servers. -} module Network.Sendfile ( sendfile , sendfileWithHeader #if OS_BSD || OS_MacOS || OS_Linux , sendfileFd , sendfileFdWithHeader #endif , FileRange(..) ) where import Network.Sendfile.Types #ifdef OS_BSD import Network.Sendfile.BSD #elif OS_MacOS import Network.Sendfile.BSD #elif OS_Linux import Network.Sendfile.Linux #else import Network.Sendfile.Fallback #endif simple-sendfile-0.2.11/Network/Sendfile/0000755000000000000000000000000012111016062016211 5ustar0000000000000000simple-sendfile-0.2.11/Network/Sendfile/BSD.hsc0000644000000000000000000001714012111016062017323 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} module Network.Sendfile.BSD ( sendfile , sendfileFd , sendfileWithHeader , sendfileFdWithHeader ) 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 import Foreign.Marshal (alloca) import Foreign.Ptr (Ptr, nullPtr) 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 #include entire :: COff entire = 0 -- | -- 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 setup teardown $ \fd -> sendfileFd sock fd range hook where setup = openFd path ReadOnly Nothing defaultFileFlags teardown = closeFd -- | -- Simple binding for sendfile() of BSD and MacOS. -- -- - Used system calls: sendfile() -- -- 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. sendfileFd :: Socket -> Fd -> FileRange -> IO () -> IO () sendfileFd sock fd range hook = 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 dst = Fd $ fdSocket sock 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 sentp hook -- Parallel IO manager use edge-trigger mode. -- So, calling threadWaitWrite only when errnor is eAGAIN. when (errno == eAGAIN) $ 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" ---------------------------------------------------------------- -- | -- 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 -> sendfileFdWithHeader sock fd range hook hdr where setup = openFd path ReadOnly Nothing defaultFileFlags teardown = closeFd -- | -- Simple binding for sendfile() of BSD and MacOS. -- -- - Used system calls: sendfile() -- -- 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. sendfileFdWithHeader :: Socket -> Fd -> FileRange -> IO () -> [ByteString] -> IO () sendfileFdWithHeader sock fd range hook hdr = 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 sendfileFd sock fd 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 hdr hlen case mrc of Nothing -> return () Just (newoff,newlen) -> do threadWaitWrite dst sendloop dst fd newoff newlen sentp hook where dst = Fd $ fdSocket sock hlen = fromIntegral . sum . map BS.length $ hdr sendloopHeader :: Fd -> Fd -> COff -> COff -> Ptr COff -> [ByteString] -> COff -> IO (Maybe (COff, COff)) sendloopHeader dst src off len sentp 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 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 -- Parallel IO manager use edge-trigger mode. -- So, calling threadWaitWrite only when errnor is eAGAIN. when (errno == eAGAIN) $ threadWaitWrite dst let newlen = if len == entire then entire else len - sent newhdr = remainingChunks (fromIntegral sent) hdr newhlen = hlen - sent sendloopHeader dst src off newlen sentp newhdr newhlen else throwErrno "Network.SendFile.MacOS.sendloopHeader" ---------------------------------------------------------------- #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 simple-sendfile-0.2.11/Network/Sendfile/Fallback.hs0000644000000000000000000000302512111016062020244 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.Sendfile.Fallback ( sendfile , sendfileWithHeader ) where import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.ByteString (ByteString) import Data.Conduit 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 conduit. -- Used system calls: -- -- - Used system calls: open(), stat(), read(), send() and close(). sendfile :: Socket -> FilePath -> FileRange -> IO () -> IO () 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 () #if MIN_VERSION_conduit(0,5,0) sinkSocket s hook = awaitForever $ \bs -> liftIO $ SB.sendAll s bs >> hook #else sinkSocket s hook = NeedInput push close where push bs = flip PipeM (return ()) $ do liftIO (SB.sendAll s bs) liftIO hook return (NeedInput push close) close = return () #endif -- | -- 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 sendfile sock path range hook simple-sendfile-0.2.11/Network/Sendfile/IOVec.hsc0000644000000000000000000000535112111016062017661 0ustar0000000000000000{- 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 simple-sendfile-0.2.11/Network/Sendfile/Linux.hsc0000644000000000000000000001432212111016062020011 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} module Network.Sendfile.Linux ( sendfile , sendfileFd , sendfileWithHeader , sendfileFdWithHeader ) where import Control.Applicative import Control.Exception import Control.Monad import Data.ByteString as B import Data.ByteString.Unsafe import Data.Int 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 #include #include ---------------------------------------------------------------- -- | -- 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. sendfile :: Socket -> FilePath -> FileRange -> IO () -> IO () sendfile sock path range hook = bracket setup teardown $ \fd -> sendfileFd sock fd range hook where setup = openFd path ReadOnly Nothing defaultFileFlags teardown = 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 bofore waiting the socket to be ready for writing. sendfileFd :: Socket -> Fd -> FileRange -> IO () -> IO () sendfileFd sock fd range hook = 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 dst = Fd $ fdSocket sock 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 0 = return () loop left = do hook -- Parallel IO manager use edge-trigger mode. -- So, calling threadWaitWrite only when errnor is eAGAIN. errno <- getErrno when (errno == eAGAIN) $ threadWaitWrite dst sendloop dst src offp left hook -- Dst Src in order. take care 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 $ B.concat hdr sendfile sock path range hook -- | -- 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 bofore waiting the socket to be ready for writing. sendfileFdWithHeader :: Socket -> Fd -> FileRange -> IO () -> [ByteString] -> IO () sendfileFdWithHeader sock fd range hook hdr = do -- Copying is much faster than syscall. sendAllMsgMore sock $ B.concat hdr sendfileFd sock fd range hook sendAllMsgMore :: Socket -> ByteString -> IO () sendAllMsgMore sock bs = do sent <- sendMsgMore sock bs when (sent < B.length bs) $ sendAllMsgMore sock (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) simple-sendfile-0.2.11/Network/Sendfile/Types.hs0000644000000000000000000000035312111016062017652 0ustar0000000000000000module Network.Sendfile.Types where -- | -- File range for 'sendfile'. data FileRange = EntireFile | PartOfFile { rangeOffset :: Integer , rangeLength :: Integer } simple-sendfile-0.2.11/test/0000755000000000000000000000000012111016062014006 5ustar0000000000000000simple-sendfile-0.2.11/test/SendfileSpec.hs0000644000000000000000000001557712111016062016725 0ustar0000000000000000{-# 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.Posix.Files import System.Process import System.Timeout import Test.Hspec ---------------------------------------------------------------- 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) simple-sendfile-0.2.11/test/Spec.hs0000644000000000000000000000005412111016062015233 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-}