1{-# LANGUAGE ForeignFunctionInterface #-}
2{-# LANGUAGE CPP #-}
3
4module Network.Sendfile.BSD (
5    sendfile
6  , sendfileFd
7  , sendfileWithHeader
8  , sendfileFdWithHeader
9  ) where
10
11import Control.Concurrent
12import Control.Exception
13import Control.Monad
14import Data.ByteString (ByteString)
15import qualified Data.ByteString as BS
16import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno)
17import Foreign.C.Types
18import Foreign.Marshal (alloca)
19import Foreign.Ptr (Ptr, nullPtr)
20import Foreign.Storable (peek, poke)
21import Network.Sendfile.IOVec
22import Network.Sendfile.Types
23import Network.Socket
24import Network.Socket.ByteString
25import System.Posix.IO ( OpenMode(..)
26                       , OpenFileFlags(..)
27                       , defaultFileFlags
28                       , closeFd
29                       )
30import System.Posix.Types
31
32#include <sys/types.h>
33
34entire :: COff
35entire = 0
36
37-- |
38-- Simple binding for sendfile() of BSD and MacOS.
39--
40-- - Used system calls: open(), sendfile(), and close().
41--
42-- The fourth action argument is called when a file is sent as chunks.
43-- Chucking is inevitable if the socket is non-blocking (this is the
44-- default) and the file is large. The action is called after a chunk
45-- is sent and bofore waiting the socket to be ready for writing.
46
47sendfile :: Socket -> FilePath -> FileRange -> IO () -> IO ()
48sendfile sock path range hook = bracket setup teardown $ \fd ->
49    sendfileFd sock fd range hook
50  where
51    setup = openFd path ReadOnly defaultFileFlags{nonBlock=True}
52    teardown = closeFd
53
54-- |
55-- Simple binding for sendfile() of BSD and MacOS.
56--
57-- - Used system calls: sendfile()
58--
59-- The fourth action argument is called when a file is sent as chunks.
60-- Chucking is inevitable if the socket is non-blocking (this is the
61-- default) and the file is large. The action is called after a chunk
62-- is sent and bofore waiting the socket to be ready for writing.
63
64sendfileFd :: Socket -> Fd -> FileRange -> IO () -> IO ()
65sendfileFd sock fd range hook = do
66#if MIN_VERSION_network(3,1,0)
67  withFdSocket sock $ \s -> do
68    let dst = Fd s
69#elif MIN_VERSION_network(3,0,0)
70    dst <- Fd <$> fdSocket sock
71#else
72    let dst = Fd $ fdSocket sock
73#endif
74    alloca $ \sentp -> do
75        let (off,len) = case range of
76                EntireFile           -> (0, entire)
77                PartOfFile off' len' -> (fromInteger off', fromInteger len')
78        sendloop dst fd off len sentp hook
79
80sendloop :: Fd -> Fd -> COff -> COff -> Ptr COff -> IO () -> IO ()
81sendloop dst src off len sentp hook = do
82    rc <- sendFile src dst off len sentp nullPtr
83    when (rc /= 0) $ do
84        errno <- getErrno
85        if errno `elem` [eAGAIN, eINTR] then do
86            sent <- peek sentp
87            hook
88            -- Parallel IO manager use edge-trigger mode.
89            -- So, calling threadWaitWrite only when errnor is eAGAIN.
90            when (errno == eAGAIN) $ threadWaitWrite dst
91            let newoff = off + sent
92                newlen = if len == entire then entire else len - sent
93            sendloop dst src newoff newlen sentp hook
94          else
95            throwErrno "Network.SendFile.MacOS.sendloop"
96
97----------------------------------------------------------------
98
99-- |
100-- Simple binding for sendfile() of BSD and MacOS.
101--
102-- - Used system calls: open(), sendfile(), and close().
103--
104-- The fifth header is also sent with sendfile(). If the file is
105-- small enough, the header and the file is send in a single TCP packet
106-- on FreeBSD. MacOS sends the header and the file separately but it is
107-- fast.
108--
109-- The fourth action argument is called when a file is sent as chunks.
110-- Chucking is inevitable if the socket is non-blocking (this is the
111-- default) and the file is large. The action is called after a chunk
112-- is sent and bofore waiting the socket to be ready for writing.
113
114sendfileWithHeader :: Socket -> FilePath -> FileRange -> IO () -> [ByteString] -> IO ()
115sendfileWithHeader sock path range hook hdr =
116    bracket setup teardown $ \fd -> sendfileFdWithHeader sock fd range hook hdr
117  where
118    setup = openFd path ReadOnly defaultFileFlags{nonBlock=True}
119    teardown = closeFd
120
121-- |
122-- Simple binding for sendfile() of BSD and MacOS.
123--
124-- - Used system calls: sendfile()
125--
126-- The fifth header is also sent with sendfile(). If the file is
127-- small enough, the header and the file is send in a single TCP packet
128-- on FreeBSD. MacOS sends the header and the file separately but it is
129-- fast.
130--
131-- The fourth action argument is called when a file is sent as chunks.
132-- Chucking is inevitable if the socket is non-blocking (this is the
133-- default) and the file is large. The action is called after a chunk
134-- is sent and bofore waiting the socket to be ready for writing.
135
136sendfileFdWithHeader :: Socket -> Fd -> FileRange -> IO () -> [ByteString] -> IO ()
137sendfileFdWithHeader sock fd range hook hdr = do
138#if MIN_VERSION_network(3,1,0)
139  withFdSocket sock $ \s -> do
140    let dst = Fd s
141#elif MIN_VERSION_network(3,0,0)
142    dst <- Fd <$> fdSocket sock
143#else
144    let dst = Fd $ fdSocket sock
145#endif
146    alloca $ \sentp ->
147        if isFreeBSD && hlen >= 8192 then do
148            -- If the length of the header is larger than 8191,
149            -- threadWaitWrite does not come back on FreeBSD, sigh.
150            -- We use writev() for the header and sendfile() for the file.
151            sendMany sock hdr
152            sendfileFd sock fd range hook
153          else do
154            -- On MacOS, the header and the body are sent separately.
155            -- But it's fast. the writev() and sendfile() combination
156            -- is also fast.
157            let (off,len) = case range of
158                    EntireFile           -> (0,entire)
159                    PartOfFile off' len' -> (fromInteger off'
160                                            ,fromInteger len' + hlen)
161            mrc <- sendloopHeader dst fd off len sentp hdr hlen
162            case mrc of
163                Nothing              -> return ()
164                Just (newoff,newlen) -> do
165                    threadWaitWrite dst
166                    sendloop dst fd newoff newlen sentp hook
167  where
168    hlen = fromIntegral . sum . map BS.length $ hdr
169
170sendloopHeader :: Fd -> Fd -> COff -> COff -> Ptr COff -> [ByteString] -> COff -> IO (Maybe (COff, COff))
171sendloopHeader dst src off len sentp hdr hlen = do
172    rc <- withSfHdtr hdr $ sendFile src dst off len sentp
173    if rc == 0 then
174        return Nothing
175      else do
176        errno <- getErrno
177        if errno `elem` [eAGAIN, eINTR] then do
178            sent <- peek sentp
179            if sent >= hlen then do
180                let newoff = off + sent - hlen
181                if len == entire then
182                    return $ Just (newoff, entire)
183                  else
184                    return $ Just (newoff, len - sent)
185              else do
186                -- Parallel IO manager use edge-trigger mode.
187                -- So, calling threadWaitWrite only when errnor is eAGAIN.
188                when (errno == eAGAIN) $ threadWaitWrite dst
189                let newlen = if len == entire then entire else len - sent
190                    newhdr = remainingChunks (fromIntegral sent) hdr
191                    newhlen = hlen - sent
192                sendloopHeader dst src off newlen sentp newhdr newhlen
193          else
194            throwErrno "Network.SendFile.MacOS.sendloopHeader"
195
196----------------------------------------------------------------
197
198#ifdef OS_MacOS
199-- Shuffle the order of arguments for currying.
200sendFile :: Fd -> Fd -> COff -> COff -> Ptr COff -> Ptr SfHdtr -> IO CInt
201sendFile fd s off len sentp hdrp = do
202    poke sentp len
203    c_sendfile fd s off sentp hdrp 0
204
205foreign import ccall unsafe "sys/uio.h sendfile"
206    c_sendfile :: Fd -> Fd -> COff -> Ptr COff -> Ptr SfHdtr -> CInt -> IO CInt
207
208isFreeBSD :: Bool
209isFreeBSD = False
210#else
211-- Let's don't use CSize for 'len' and use COff for convenience.
212-- Shuffle the order of arguments for currying.
213sendFile :: Fd -> Fd -> COff -> COff -> Ptr COff -> Ptr SfHdtr -> IO CInt
214sendFile fd s off len sentp hdrp =
215    c_sendfile fd s off (fromIntegral len) hdrp sentp 0
216
217foreign import ccall unsafe "sys/uio.h sendfile"
218    c_sendfile :: Fd -> Fd -> COff -> CSize -> Ptr SfHdtr -> Ptr COff -> CInt -> IO CInt
219
220isFreeBSD :: Bool
221isFreeBSD = True
222#endif
223