simple-sendfile 0.2.32 → 0.2.33
raw patch · 8 files changed
+262/−168 lines, 8 filesdep −transformersdep ~basedep ~conduitdep ~conduit-extraPVP ok
version bump matches the API change (PVP)
Dependencies removed: transformers
Dependency ranges changed: base, conduit, conduit-extra
API changes (from Hackage documentation)
Files
- ChangeLog.md +20/−0
- Network/Sendfile/BSD.hsc +38/−36
- Network/Sendfile/Fallback.hs +23/−25
- Network/Sendfile/IOVec.hsc +17/−13
- Network/Sendfile/Linux.hsc +34/−45
- Network/Sendfile/Types.hs +19/−0
- simple-sendfile.cabal +12/−10
- test/SendfileSpec.hs +99/−39
+ ChangeLog.md view
@@ -0,0 +1,20 @@+# ChangeLog for simple-sendfile++## 0.2.33++GHC 9.2 or later is required.++* Don't send the entire file for zero-length ranges on BSD/macOS+ [#43](https://github.com/kazu-yamamoto/simple-sendfile/pull/43)+* Fallback: open the file before sending the header+ [#44](https://github.com/kazu-yamamoto/simple-sendfile/pull/44)+* Reject negative offsets and lengths in FileRange+ [#45](https://github.com/kazu-yamamoto/simple-sendfile/pull/45)+* Fix the header path of BSD/macOS (IOV_MAX, EINTR, hook)+ [#47](https://github.com/kazu-yamamoto/simple-sendfile/pull/47)+* Linux: open the file before the header, handle EINTR and 64-bit off_t+ [#48](https://github.com/kazu-yamamoto/simple-sendfile/pull/48)+* Document how FileRange is handled+ [#49](https://github.com/kazu-yamamoto/simple-sendfile/pull/49)+* Add FreeBSD to CI and fix BSD error messages+ [#50](https://github.com/kazu-yamamoto/simple-sendfile/pull/50)
Network/Sendfile/BSD.hsc view
@@ -63,19 +63,15 @@ sendfileFd :: Socket -> Fd -> FileRange -> IO () -> IO () sendfileFd sock fd range hook = do-#if MIN_VERSION_network(3,1,0)+ checkRange range withFdSocket sock $ \s -> do let dst = Fd s-#elif MIN_VERSION_network(3,0,0)- dst <- Fd <$> fdSocket sock-#else- let dst = Fd $ fdSocket sock-#endif- 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+ alloca $ \sentp -> case range of+ EntireFile -> sendloop dst fd 0 entire sentp hook+ -- 0 means the entire file for BSD sendfile(), so skip it.+ PartOfFile off len+ | len <= 0 -> return ()+ | otherwise -> sendloop dst fd (fromInteger off) (fromInteger len) sentp hook sendloop :: Fd -> Fd -> COff -> COff -> Ptr COff -> IO () -> IO () sendloop dst src off len sentp hook = do@@ -85,14 +81,16 @@ 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+ -- newlen must not reach 0, which means the entire file.+ unless (len /= entire && newlen <= 0) $ do+ -- Parallel IO manager use edge-trigger mode.+ -- So, calling threadWaitWrite only when errnor is eAGAIN.+ when (errno == eAGAIN) $ threadWaitWrite dst+ sendloop dst src newoff newlen sentp hook else- throwErrno "Network.SendFile.MacOS.sendloop"+ throwErrno "Network.Sendfile.BSD.sendloop" ---------------------------------------------------------------- @@ -135,16 +133,14 @@ sendfileFdWithHeader :: Socket -> Fd -> FileRange -> IO () -> [ByteString] -> IO () sendfileFdWithHeader sock fd range hook hdr = do-#if MIN_VERSION_network(3,1,0)+ checkRange range withFdSocket sock $ \s -> do let dst = Fd s-#elif MIN_VERSION_network(3,0,0)- dst <- Fd <$> fdSocket sock-#else- let dst = Fd $ fdSocket sock-#endif alloca $ \sentp ->- if isFreeBSD && hlen >= 8192 then do+ if isEmptyPart then+ -- 0 means the entire file for BSD sendfile(), so skip it.+ sendMany sock hdr+ else 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.@@ -158,17 +154,18 @@ EntireFile -> (0,entire) PartOfFile off' len' -> (fromInteger off' ,fromInteger len' + hlen)- mrc <- sendloopHeader dst fd off len sentp hdr hlen+ mrc <- sendloopHeader dst fd off len sentp hdr hlen hook case mrc of Nothing -> return ()- Just (newoff,newlen) -> do- threadWaitWrite dst- sendloop dst fd newoff newlen sentp hook+ Just (newoff,newlen) -> sendloop dst fd newoff newlen sentp hook where hlen = fromIntegral . sum . map BS.length $ hdr+ isEmptyPart = case range of+ PartOfFile _ len -> len <= 0+ EntireFile -> False -sendloopHeader :: Fd -> Fd -> COff -> COff -> Ptr COff -> [ByteString] -> COff -> IO (Maybe (COff, COff))-sendloopHeader dst src off len sentp hdr hlen = do+sendloopHeader :: Fd -> Fd -> COff -> COff -> Ptr COff -> [ByteString] -> COff -> IO () -> IO (Maybe (COff, COff))+sendloopHeader dst src off len sentp hdr hlen hook = do rc <- withSfHdtr hdr $ sendFile src dst off len sentp if rc == 0 then return Nothing@@ -176,22 +173,27 @@ 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.+ let wait = when (errno == eAGAIN) $ threadWaitWrite dst if sent >= hlen then do let newoff = off + sent - hlen if len == entire then- return $ Just (newoff, entire)+ wait >> return (Just (newoff, entire))+ else if len - sent <= 0 then+ -- 0 means the entire file, so stop here.+ return Nothing else- return $ Just (newoff, len - sent)+ wait >> 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+ wait+ sendloopHeader dst src off newlen sentp newhdr newhlen hook else- throwErrno "Network.SendFile.MacOS.sendloopHeader"+ throwErrno "Network.Sendfile.BSD.sendloopHeader" ----------------------------------------------------------------
Network/Sendfile/Fallback.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} module Network.Sendfile.Fallback ( sendfile , sendfileWithHeader@@ -7,45 +6,44 @@ import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.ByteString (ByteString) import Data.Conduit-import Data.Conduit.Binary as EB+import qualified Data.Conduit.Binary as EB import Network.Sendfile.Types import Network.Socket-import Network.Socket.ByteString import qualified Network.Socket.ByteString as SB+import System.IO (Handle, IOMode(ReadMode), withBinaryFile) -- | -- 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 =- runConduitRes $ sourceFile path .| sinkSocket sock hook-sendfile sock path (PartOfFile off len) hook =- runConduitRes $ EB.sourceFileRange path (Just off) (Just len) .| sinkSocket sock hook---- See sinkHandle.-sinkSocket :: MonadIO m => Socket -> IO () -> ConduitT ByteString Void 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 sock path range hook = do+ checkRange range+ withBinaryFile path ReadMode $ \h -> sendHandle sock h range hook -- | -- Sendfile emulation using conduit.--- Used system calls: -- -- - Used system calls: open(), stat(), read(), writev(), send() and close().+--+-- The file is opened before the header is sent, so nothing is sent+-- if the file cannot be opened. sendfileWithHeader :: Socket -> FilePath -> FileRange -> IO () -> [ByteString] -> IO () sendfileWithHeader sock path range hook hdr = do- sendMany sock hdr- sendfile sock path range hook+ checkRange range+ withBinaryFile path ReadMode $ \h -> do+ SB.sendMany sock hdr+ sendHandle sock h range hook++sendHandle :: Socket -> Handle -> FileRange -> IO () -> IO ()+sendHandle sock h range hook = runConduit $ source .| sinkSocket sock hook+ where+ source = case range of+ EntireFile -> EB.sourceHandle h+ PartOfFile off len -> EB.sourceHandleRange h (Just off) (Just len)++-- See sinkHandle.+sinkSocket :: MonadIO m => Socket -> IO () -> ConduitT ByteString Void m ()+sinkSocket s hook = awaitForever $ \bs -> liftIO $ SB.sendAll s bs >> hook
Network/Sendfile/IOVec.hsc view
@@ -8,7 +8,6 @@ , remainingChunks ) where -import Control.Monad (zipWithM_) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Unsafe (unsafeUseAsCStringLen)@@ -18,6 +17,7 @@ import Foreign.Ptr (Ptr, nullPtr, plusPtr) import Foreign.Storable (Storable(..)) +#include <limits.h> #include <sys/uio.h> #include <sys/socket.h> @@ -29,8 +29,8 @@ } instance Storable IOVec where- sizeOf _ = (#const sizeof(struct iovec))- alignment _ = alignment (undefined :: CInt)+ sizeOf _ = (#size struct iovec)+ alignment _ = (#alignment struct iovec) peek p = do base <- (#peek struct iovec, iov_base) p@@ -49,8 +49,8 @@ } instance Storable SfHdtr where- sizeOf _ = (#const sizeof(struct sf_hdtr))- alignment _ = alignment (undefined :: CInt)+ sizeOf _ = (#size struct sf_hdtr)+ alignment _ = (#alignment struct sf_hdtr) peek p = do hdr <- (#peek struct sf_hdtr, headers) p@@ -65,23 +65,27 @@ ---------------------------------------------------------------- +-- The buffers stay valid while 'f' runs since the calls are nested. withIOVec :: [ByteString] -> ((Ptr IOVec, Int) -> IO a) -> IO a withIOVec cs f =- allocaArray csLen $ \aPtr -> do- zipWithM_ pokeIov (ptrs aPtr) cs- f (aPtr, csLen)+ allocaArray csLen $ \aPtr -> go aPtr aPtr cs where csLen = length cs- ptrs = iterate (`plusPtr` sizeOf (undefined :: IOVec))- pokeIov ptr s =- unsafeUseAsCStringLen s $ \(sPtr, sLen) ->- poke ptr $ IOVec sPtr (fromIntegral sLen)+ go aPtr _ [] = f (aPtr, csLen)+ go aPtr ptr (s:ss) =+ unsafeUseAsCStringLen s $ \(sPtr, sLen) -> do+ poke ptr $ IOVec sPtr (fromIntegral sLen)+ go aPtr (ptr `plusPtr` sizeOf (undefined :: IOVec)) ss +-- Too many chunks cause EINVAL, so they are concatenated. withSfHdtr :: [ByteString] -> (Ptr SfHdtr -> IO a) -> IO a-withSfHdtr cs f = withIOVec cs $ \(iovecp,len) ->+withSfHdtr cs0 f = withIOVec cs $ \(iovecp,len) -> alloca $ \sfhdtrp -> do poke sfhdtrp $ SfHdtr iovecp (fromIntegral len) f sfhdtrp+ where+ cs | length cs0 > (#const IOV_MAX) = [BS.concat cs0]+ | otherwise = cs0 ----------------------------------------------------------------
Network/Sendfile/Linux.hsc view
@@ -1,5 +1,6 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CApiFFI #-}+-- Let sendfile() take a 64-bit off_t also on 32-bit platforms.+{-# OPTIONS_GHC -optc-D_FILE_OFFSET_BITS=64 #-} #define _FILE_OFFSET_BITS 64 @@ -14,13 +15,13 @@ import Control.Exception import Control.Monad-import Data.ByteString as B-import Data.ByteString.Internal-import Foreign.C.Error (eAGAIN, getErrno, throwErrno)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno) import Foreign.C.Types import Foreign.Marshal (alloca)-import Foreign.Ptr (Ptr, plusPtr, castPtr)-import Foreign.ForeignPtr+import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (poke, sizeOf) import GHC.Conc (threadWaitWrite) import Network.Sendfile.Types@@ -93,37 +94,31 @@ -- is sent and before waiting the socket to be ready for writing. sendfileFd :: Socket -> Fd -> FileRange -> IO () -> IO () sendfileFd sock fd range hook = do-#if MIN_VERSION_network(3,1,0) withFdSocket sock $ \s -> do let dst = Fd s-#elif MIN_VERSION_network(3,0,0)- dst <- Fd <$> fdSocket sock-#else- let dst = Fd $ fdSocket sock-#endif sendfileFd' dst fd range hook sendfileFd' :: Fd -> Fd -> FileRange -> IO () -> IO ()-sendfileFd' dst src range hook =- alloca $ \offp -> case range of+sendfileFd' dst src range hook = do+ checkRange range+ alloca $ \offp -> case range of EntireFile -> do poke offp 0 -- System call is very slow. Use PartOfFile instead. len <- fileSize <$> getFdStatus src- let len' = fromIntegral len- sendfileloop dst src offp len' hook+ sendfileloop dst src offp len hook PartOfFile off len -> do poke offp (fromIntegral off)- let len' = fromIntegral len- sendfileloop dst src offp len' hook+ sendfileloop dst src offp (fromIntegral len) hook -sendfileloop :: Fd -> Fd -> Ptr COff -> CSize -> IO () -> IO ()+-- The remaining length is COff since CSize is 32-bit on 32-bit platforms.+sendfileloop :: Fd -> Fd -> Ptr COff -> COff -> IO () -> IO () sendfileloop dst src offp len hook = do -- Multicore IO manager use edge-trigger mode. -- So, calling threadWaitWrite only when errnor is eAGAIN. let toSend- | len > safeSize = safeSize- | otherwise = len+ | len > fromIntegral safeSize = safeSize+ | otherwise = fromIntegral len bytes <- c_sendfile dst src offp toSend case bytes of -1 -> do@@ -131,8 +126,10 @@ if errno == eAGAIN then do threadWaitWrite dst sendfileloop dst src offp len hook+ else if errno == eINTR then+ sendfileloop dst src offp len hook else- throwErrno "Network.SendFile.Linux.sendfileloop"+ throwErrno "Network.Sendfile.Linux.sendfileloop" 0 -> return () -- the file is truncated _ -> do hook@@ -140,7 +137,7 @@ when (left /= 0) $ sendfileloop dst src offp left hook -- Dst Src in order. take care-foreign import ccall unsafe "sendfile"+foreign import capi unsafe "sys/sendfile.h sendfile" c_sendfile :: Fd -> Fd -> Ptr COff -> CSize -> IO CSsize ----------------------------------------------------------------@@ -149,9 +146,9 @@ -- Simple binding for send() and sendfile() of Linux. -- Used system calls: ----- - EntireFile -- send(), open(), stat(), sendfile(), and close()+-- - EntireFile -- open(), send(), stat(), sendfile(), and close() ----- - PartOfFile -- send(), open(), sendfile(), and close()+-- - PartOfFile -- open(), send(), 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@@ -166,10 +163,11 @@ -- is sent and before 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.- sendMsgMore sock $ B.concat hdr- sendfile sock path range hook+sendfileWithHeader sock path range hook hdr = bracket setup teardown $ \fd ->+ sendfileFdWithHeader sock fd range hook hdr+ where+ setup = openFd path ReadOnly defaultFileFlags{nonBlock=True}+ teardown = closeFd -- | -- Simple binding for send() and sendfile() of Linux.@@ -193,25 +191,14 @@ sendfileFdWithHeader :: Socket -> Fd -> FileRange -> IO () -> [ByteString] -> IO () sendfileFdWithHeader sock fd range hook hdr = do+ checkRange range -- Copying is much faster than syscall. sendMsgMore sock $ B.concat hdr sendfileFd sock fd range hook sendMsgMore :: Socket -> ByteString -> IO ()-sendMsgMore sock bs = withForeignPtr fptr $ \ptr -> do-#if MIN_VERSION_network(3,1,0)- withFdSocket sock $ \fd -> do- let s = Fd fd-#elif MIN_VERSION_network(3,0,0)- s <- Fd <$> fdSocket sock-#else- let s = Fd $ fdSocket sock-#endif- let buf = castPtr (ptr `plusPtr` off)- siz = fromIntegral len- sendloop s buf siz- where- PS fptr off len = bs+sendMsgMore sock bs = unsafeUseAsCStringLen bs $ \(buf, len) ->+ withFdSocket sock $ \fd -> sendloop (Fd fd) buf (fromIntegral len) sendloop :: Fd -> Ptr CChar -> CSize -> IO () sendloop s buf len = do@@ -221,8 +208,10 @@ if errno == eAGAIN then do threadWaitWrite s sendloop s buf len+ else if errno == eINTR then+ sendloop s buf len else- throwErrno "Network.SendFile.Linux.sendloop"+ throwErrno "Network.Sendfile.Linux.sendloop" else do let sent = fromIntegral bytes when (sent /= len) $ do
Network/Sendfile/Types.hs view
@@ -2,6 +2,8 @@ module Network.Sendfile.Types where +import GHC.IO.Exception (IOErrorType(InvalidArgument), IOException(..))+ #ifdef VERSION_unix import qualified Data.ByteString as B @@ -12,12 +14,29 @@ -- | -- File range for 'sendfile'.+--+-- * If the offset or the length of 'PartOfFile' is negative, an+-- 'IOException' of 'InvalidArgument' is thrown before anything is sent.+--+-- * If the length is 0, nothing is sent (only the header for the+-- @WithHeader@ variants).+--+-- * If the file is shorter than the range, or is truncated while+-- being sent, sending stops at the end of the file without any+-- error. So, the number of bytes sent may be less than requested. data FileRange = EntireFile | PartOfFile { rangeOffset :: Integer , rangeLength :: Integer }++-- | Throws 'InvalidArgument' if the offset or the length is negative.+checkRange :: FileRange -> IO ()+checkRange (PartOfFile off len)+ | off < 0 || len < 0 = ioError $ IOError Nothing InvalidArgument+ "Network.Sendfile" "negative offset or length" Nothing Nothing+checkRange _ = return () -- To avoid build error in windows #ifdef VERSION_unix
simple-sendfile.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: simple-sendfile-version: 0.2.32+version: 0.2.33 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto <kazu@iij.ad.jp>@@ -13,7 +13,10 @@ category: Network build-type: Simple-extra-source-files: test/inputFile+tested-with: GHC == 9.2.8 || == 9.4.8 || == 9.6.7 || == 9.8.4 || == 9.10.3 || == 9.12.4 || == 9.14.1+extra-source-files:+ ChangeLog.md+ test/inputFile source-repository head type: git@@ -32,7 +35,7 @@ default-language: Haskell2010 ghc-options: -Wall build-depends:- base >=4.8 && <5,+ base >=4.16 && <5, network >=3.1.4, bytestring @@ -63,10 +66,8 @@ else other-modules: Network.Sendfile.Fallback build-depends:- conduit >=1.0 && <1.4,- conduit-extra >=1.0 && <1.4,- transformers >=0.2.2 && <0.7,- resourcet+ conduit >=1.3 && <1.4,+ conduit-extra >=1.3 && <1.4 test-suite spec type: exitcode-stdio-1.0@@ -75,13 +76,14 @@ hs-source-dirs: test other-modules: SendfileSpec default-language: Haskell2010- ghc-options: -Wall+ -- The non-threaded RTS on Windows sometimes misses EOF on sockets.+ ghc-options: -Wall -threaded build-depends: HUnit, base, bytestring,- conduit,- conduit-extra,+ conduit >=1.3,+ conduit-extra >=1.3, directory, easy-file >= 0.2.4, hspec >=1.3,
test/SendfileSpec.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module SendfileSpec where @@ -22,6 +22,7 @@ import System.Timeout import System.EasyFile import Test.Hspec+import System.IO.Unsafe (unsafePerformIO) ---------------------------------------------------------------- @@ -32,6 +33,8 @@ sendFile EntireFile `shouldReturn` True it "sends a part of file" $ do sendFile (PartOfFile 2000 1000000) `shouldReturn` True+ it "sends nothing for a zero-length part" $ do+ sendFile (PartOfFile 2000 0) `shouldReturn` True it "terminates even if length is over" $ do shouldTerminate $ sendIllegal (PartOfFile 2000 5000000) it "terminates even if offset is over" $ do@@ -41,15 +44,23 @@ -- not a right test. it "terminates even if the file is truncated" $ do shouldTerminate truncateFile+ it "rejects a negative offset" $ do+ sendRejected (PartOfFile (-1) 1000) `shouldReturn` ""+ it "rejects a negative length" $ do+ sendRejected (PartOfFile 2000 (-1)) `shouldReturn` "" describe "sendfileWithHeader" $ do it "sends an header and an entire file" $ do sendFileH EntireFile `shouldReturn` True it "sends an header and a part of file" $ do sendFileH (PartOfFile 2000 1000000) `shouldReturn` True+ it "sends only an header for a zero-length part" $ do+ sendFileH (PartOfFile 2000 0) `shouldReturn` True it "sends a large header and an entire file" $ do sendFileHLarge EntireFile `shouldReturn` True it "sends a large header and a part of file" $ do sendFileHLarge (PartOfFile 2000 1000000) `shouldReturn` True+ it "sends a header with many chunks" $ do+ sendFileCore EntireFile (Prelude.replicate 5000 "a\n") `shouldReturn` True it "terminates even if length is over" $ do shouldTerminate $ sendIllegalH (PartOfFile 2000 5000000) it "terminates even if offset is over" $ do@@ -59,9 +70,18 @@ -- not a right test. it "terminates even if the file is truncated" $ do shouldTerminate truncateFileH+ it "sends nothing for a negative offset" $ do+ sendRejectedH (PartOfFile (-1) 1000) `shouldReturn` ""+ it "sends nothing for a negative length" $ do+ sendRejectedH (PartOfFile 2000 (-1)) `shouldReturn` ""+ it "sends nothing if the file does not exist" $ do+ sendMissingH `shouldReturn` "" where fiveSecs = 5000000- shouldTerminate body = timeout fiveSecs body `shouldReturn` Just ()+ shouldTerminate body = do+ r <- timeout fiveSecs body+ when (r == Nothing) $ tr "TIMEOUT" >> dumpTrace+ r `shouldBe` Just () ---------------------------------------------------------------- @@ -94,11 +114,9 @@ sendFileCore :: FileRange -> [ByteString] -> IO Bool sendFileCore range headers = bracket setup teardown $ \(s2,_) -> do-#if MIN_VERSION_conduit(1,3,0)+ tr "reader:begin" runResourceT $ runConduit (sourceSocket s2 .| sinkFile outputFile)-#else- runResourceT $ sourceSocket s2 $$ sinkFile outputFile-#endif+ tr "reader:eof" runResourceT $ copyfile range !f1 <- BL.readFile outputFile !f2 <- BL.readFile expectedFile@@ -106,39 +124,35 @@ where copyfile EntireFile = do -- of course, we can use <> here-#if MIN_VERSION_conduit(1,3,0) runConduit (sourceList headers .| sinkFile expectedFile) runConduit (sourceFile inputFile .| sinkAppendFile expectedFile)-#else- sourceList headers $$ sinkFile expectedFile- sourceFile inputFile $$ sinkAppendFile expectedFile-#endif copyfile (PartOfFile off len) = do-#if MIN_VERSION_conduit(1,3,0) runConduit (sourceList headers .| sinkFile expectedFile) runConduit (sourceFile inputFile .| CB.isolate (off' + len') .| (CB.take off' >> sinkAppendFile expectedFile))-#else- sourceList headers $$ sinkFile expectedFile- sourceFile inputFile $= CB.isolate (off' + len')- $$ (CB.take off' >> sinkAppendFile expectedFile)-#endif where off' = fromIntegral off len' = fromIntegral len setup = do+ tr "setup:begin" (s1,s2) <- socketPair AF_UNIX Stream 0- tid <- forkIO (sf s1 `finally` sendEOF s1)+ tr "setup:pair"+ tid <- forkIO $+ (tr "sender:begin" >> sf s1 >> tr "sender:sent")+ `finally` (tr "sender:close" >> sendEOF s1 >> tr "sender:closed") return (s2,tid) where sf s1- | headers == [] = sendfile s1 inputFile range (return ())- | otherwise = sendfileWithHeader s1 inputFile range (return ()) headers+ | headers == [] = sendfile s1 inputFile range (tr "sender:hook")+ | otherwise = sendfileWithHeader s1 inputFile range (tr "sender:hook") headers sendEOF = close teardown (s2,tid) = do+ tr "teardown:begin" close s2+ tr "teardown:closed" killThread tid+ tr "teardown:killed" removeFileIfExists outputFile removeFileIfExists expectedFile inputFile = "test/inputFile"@@ -164,31 +178,64 @@ sendIllegalCore :: FileRange -> [ByteString] -> IO () sendIllegalCore range headers = bracket setup teardown $ \(s2,_) -> do-#if MIN_VERSION_conduit(1,3,0)+ tr "reader:begin" runResourceT $ runConduit (sourceSocket s2 .| sinkFile outputFile)-#else- runResourceT $ sourceSocket s2 $$ sinkFile outputFile-#endif+ tr "reader:eof" return () where setup = do+ tr "setup:begin" (s1,s2) <- socketPair AF_UNIX Stream 0- tid <- forkIO (sf s1 `finally` sendEOF s1)+ tr "setup:pair"+ tid <- forkIO $+ (tr "sender:begin" >> sf s1 >> tr "sender:sent")+ `finally` (tr "sender:close" >> sendEOF s1 >> tr "sender:closed") return (s2,tid) where sf s1- | headers == [] = sendfile s1 inputFile range (return ())- | otherwise = sendfileWithHeader s1 inputFile range (return ()) headers+ | headers == [] = sendfile s1 inputFile range (tr "sender:hook")+ | otherwise = sendfileWithHeader s1 inputFile range (tr "sender:hook") headers sendEOF = close teardown (s2,tid) = do+ tr "teardown:begin" close s2+ tr "teardown:closed" killThread tid+ tr "teardown:killed" removeFileIfExists outputFile inputFile = "test/inputFile" outputFile = "test/outputFile" ---------------------------------------------------------------- +-- Returns what the peer received after sendfileWithHeader failed.+sendMissingH :: IO ByteString+sendMissingH = sendFailing $ \s ->+ sendfileWithHeader s "test/nonexistent" EntireFile (return ()) ["header"]++sendRejected :: FileRange -> IO ByteString+sendRejected range = sendFailing $ \s ->+ sendfile s "test/inputFile" range (return ())++sendRejectedH :: FileRange -> IO ByteString+sendRejectedH range = sendFailing $ \s ->+ sendfileWithHeader s "test/inputFile" range (return ()) ["header"]++-- Runs an action expected to throw and returns what the peer received.+sendFailing :: (Socket -> IO ()) -> IO ByteString+sendFailing act = bracket setup teardown $ \(s1,s2) -> do+ r <- try $ act s1+ case r of+ Left (_ :: IOException) -> return ()+ Right () -> expectationFailure "no exception"+ close s1+ BS.concat <$> runConduit (sourceSocket s2 .| CL.consume)+ where+ setup = socketPair AF_UNIX Stream 0+ teardown (_,s2) = close s2++----------------------------------------------------------------+ truncateFile :: IO () truncateFile = truncateFileCore [] @@ -206,19 +253,13 @@ truncateFileCore :: [ByteString] -> IO () truncateFileCore headers = bracket setup teardown $ \(s2,_) -> do-#if MIN_VERSION_conduit(1,3,0)+ tr "reader:begin" runResourceT $ runConduit (sourceSocket s2 .| sinkFile outputFile)-#else- runResourceT $ sourceSocket s2 $$ sinkFile outputFile-#endif+ tr "reader:eof" return () where setup = do-#if MIN_VERSION_conduit(1,3,0) runResourceT $ runConduit (sourceFile inputFile .| sinkFile tempFile)-#else- runResourceT $ sourceFile inputFile $$ sinkFile tempFile-#endif (s1,s2) <- socketPair AF_UNIX Stream 0 ref <- newIORef (1 :: Int) tid <- forkIO (sf s1 ref `finally` sendEOF s1)@@ -233,8 +274,11 @@ when (n == 10) $ setFileSize tempFile 900000 writeIORef ref (n+1) teardown (s2,tid) = do+ tr "teardown:begin" close s2+ tr "teardown:closed" killThread tid+ tr "teardown:killed" removeFileIfExists tempFile removeFileIfExists outputFile inputFile = "test/inputFile"@@ -251,9 +295,25 @@ sinkAppendFile :: MonadResource m => FilePath-#if MIN_VERSION_conduit(1,3,0) -> ConduitT ByteString Void m ()-#else- -> Sink ByteString m ()-#endif sinkAppendFile fp = sinkIOHandle (openBinaryFile fp AppendMode)++----------------------------------------------------------------++-- Lightweight trace ring dumped only on timeout, to locate hangs+-- without perturbing timing (formatting happens in dumpTrace).+traceBuf :: IORef [(ThreadId, String)]+traceBuf = unsafePerformIO $ newIORef []+{-# NOINLINE traceBuf #-}++tr :: String -> IO ()+tr msg = do+ tid <- myThreadId+ atomicModifyIORef' traceBuf (\xs -> (Prelude.take 200 ((tid, msg) : xs), ()))++dumpTrace :: IO ()+dumpTrace = do+ xs <- atomicModifyIORef' traceBuf (\xs -> ([], xs))+ forM_ (Prelude.reverse (Prelude.take 80 xs)) $ \(t, m) ->+ System.IO.hPutStrLn stderr ("TRACE " ++ show t ++ " " ++ m)+ hFlush stderr