diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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) diff --git a/Network/Sendfile/BSD.hsc b/Network/Sendfile/BSD.hsc --- a/Network/Sendfile/BSD.hsc +++ b/Network/Sendfile/BSD.hsc @@ -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" ---------------------------------------------------------------- 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,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 diff --git a/Network/Sendfile/IOVec.hsc b/Network/Sendfile/IOVec.hsc --- a/Network/Sendfile/IOVec.hsc +++ b/Network/Sendfile/IOVec.hsc @@ -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 #include #include @@ -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 ---------------------------------------------------------------- diff --git a/Network/Sendfile/Linux.hsc b/Network/Sendfile/Linux.hsc --- a/Network/Sendfile/Linux.hsc +++ b/Network/Sendfile/Linux.hsc @@ -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 diff --git a/Network/Sendfile/Types.hs b/Network/Sendfile/Types.hs --- a/Network/Sendfile/Types.hs +++ b/Network/Sendfile/Types.hs @@ -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 diff --git a/simple-sendfile.cabal b/simple-sendfile.cabal --- a/simple-sendfile.cabal +++ b/simple-sendfile.cabal @@ -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 @@ -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, diff --git a/test/SendfileSpec.hs b/test/SendfileSpec.hs --- a/test/SendfileSpec.hs +++ b/test/SendfileSpec.hs @@ -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