packages feed

simple-sendfile 0.2.3 → 0.2.4

raw patch · 11 files changed

+641/−218 lines, 11 filesdep +HUnitdep +directorydep +hspecdep ~basedep ~bytestringdep ~conduit

Dependencies added: HUnit, directory, hspec, hspec-discover, hspec-shouldbe, network-conduit, process, simple-sendfile

Dependency ranges changed: base, bytestring, conduit, network

Files

Network/Sendfile.hs view
@@ -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
Network/Sendfile/BSD.hsc view
@@ -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 <sys/types.h> -   - 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
Network/Sendfile/Fallback.hs view
@@ -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
+ Network/Sendfile/IOVec.hsc view
@@ -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 <sys/uio.h>+#include <sys/socket.h>++----------------------------------------------------------------++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
Network/Sendfile/Linux.hsc view
@@ -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 <sys/sendfile.h>--{-|-   Simple binding for sendfile() of Linux.-   Used system calls:+#include <sys/socket.h> -     - 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)
− Network/Sendfile/MacOS.hsc 
@@ -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 <sys/types.h>--{-|-   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
Network/Sendfile/Types.hs view
@@ -1,8 +1,8 @@ module Network.Sendfile.Types where -{-|-  File range for 'sendfile'.--}+-- |+--  File range for 'sendfile'.+ data FileRange = EntireFile                | PartOfFile {                    rangeOffset :: Integer
simple-sendfile.cabal view
@@ -1,5 +1,5 @@ Name:                   simple-sendfile-Version:                0.2.3+Version:                0.2.4 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> 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
+ test/SendfileSpec.hs view
@@ -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)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/setup.sh view
@@ -0,0 +1,3 @@+#! /bin/sh++ln -s /usr/share/dict/words inputFile