1{-# LANGUAGE ForeignFunctionInterface #-}
2{-# LANGUAGE CPP #-}
3
4module Network.Sendfile.Linux (
5    sendfile
6  , sendfile'
7  , sendfileFd
8  , sendfileFd'
9  , sendfileWithHeader
10  , sendfileFdWithHeader
11  ) where
12
13import Control.Exception
14import Control.Monad
15import Data.ByteString as B
16import Data.ByteString.Internal
17import Foreign.C.Error (eAGAIN, getErrno, throwErrno)
18import Foreign.C.Types
19import Foreign.Marshal (alloca)
20import Foreign.Ptr (Ptr, plusPtr, castPtr)
21import Foreign.ForeignPtr
22import Foreign.Storable (poke, sizeOf)
23import GHC.Conc (threadWaitWrite)
24import Network.Sendfile.Types
25import Network.Socket
26import System.Posix.Files
27import System.Posix.IO ( OpenMode(..)
28                       , OpenFileFlags(..)
29                       , defaultFileFlags
30                       , closeFd
31                       )
32import System.Posix.Types
33
34#include <sys/sendfile.h>
35#include <sys/socket.h>
36
37isLargeOffset :: Bool
38isLargeOffset = sizeOf (0 :: COff) == 8
39
40isLargeSize :: Bool
41isLargeSize = sizeOf (0 :: CSize) == 8
42
43safeSize :: CSize
44safeSize
45  | isLargeSize = 2^(60 :: Int)
46  | otherwise   = 2^(30 :: Int)
47
48----------------------------------------------------------------
49
50-- |
51-- Simple binding for sendfile() of Linux.
52-- Used system calls:
53--
54--  - EntireFile -- open(), stat(), sendfile(), and close()
55--
56--  - PartOfFile -- open(), sendfile(), and close()
57--
58-- If the size of the file is unknown when sending the entire file,
59-- specifying PartOfFile is much faster.
60--
61-- The fourth action argument is called when a file is sent as chunks.
62-- Chucking is inevitable if the socket is non-blocking (this is the
63-- default) and the file is large. The action is called after a chunk
64-- is sent and bofore waiting the socket to be ready for writing.
65
66sendfile :: Socket -> FilePath -> FileRange -> IO () -> IO ()
67sendfile sock path range hook = bracket setup teardown $ \fd ->
68    sendfileFd sock fd range hook
69  where
70    setup = openFd path ReadOnly defaultFileFlags{nonBlock=True}
71    teardown = closeFd
72
73sendfile' :: Fd -> ByteString -> FileRange -> IO () -> IO ()
74sendfile' dst path range hook = bracket setup teardown $ \src ->
75    sendfileFd' dst src range hook
76  where
77    setup = openFdBS path ReadOnly defaultFileFlags{nonBlock=True}
78    teardown = closeFd
79
80-- |
81-- Simple binding for sendfile() of Linux.
82-- Used system calls:
83--
84--  - EntireFile -- stat() and sendfile()
85--
86--  - PartOfFile -- sendfile()
87--
88-- If the size of the file is unknown when sending the entire file,
89-- specifying PartOfFile is much faster.
90--
91-- The fourth action argument is called when a file is sent as chunks.
92-- Chucking is inevitable if the socket is non-blocking (this is the
93-- default) and the file is large. The action is called after a chunk
94-- is sent and bofore waiting the socket to be ready for writing.
95sendfileFd :: Socket -> Fd -> FileRange -> IO () -> IO ()
96sendfileFd sock fd range hook = do
97#if MIN_VERSION_network(3,1,0)
98  withFdSocket sock $ \s -> do
99    let dst = Fd s
100#elif MIN_VERSION_network(3,0,0)
101    dst <- Fd <$> fdSocket sock
102#else
103    let dst = Fd $ fdSocket sock
104#endif
105    sendfileFd' dst fd range hook
106
107sendfileFd' :: Fd -> Fd -> FileRange -> IO () -> IO ()
108sendfileFd' dst src range hook =
109    alloca $ \offp -> case range of
110        EntireFile -> do
111            poke offp 0
112            -- System call is very slow. Use PartOfFile instead.
113            len <- fileSize <$> getFdStatus src
114            let len' = fromIntegral len
115            sendfileloop dst src offp len' hook
116        PartOfFile off len -> do
117            poke offp (fromIntegral off)
118            let len' = fromIntegral len
119            sendfileloop dst src offp len' hook
120
121sendfileloop :: Fd -> Fd -> Ptr COff -> CSize -> IO () -> IO ()
122sendfileloop dst src offp len hook = do
123    -- Multicore IO manager use edge-trigger mode.
124    -- So, calling threadWaitWrite only when errnor is eAGAIN.
125    let toSend
126          | len > safeSize = safeSize
127          | otherwise      = len
128    bytes <- c_sendfile dst src offp toSend
129    case bytes of
130        -1 -> do
131            errno <- getErrno
132            if errno == eAGAIN then do
133                threadWaitWrite dst
134                sendfileloop dst src offp len hook
135              else
136                throwErrno "Network.SendFile.Linux.sendfileloop"
137        0  -> return () -- the file is truncated
138        _  -> do
139            hook
140            let left = len - fromIntegral bytes
141            when (left /= 0) $ sendfileloop dst src offp left hook
142
143-- Dst Src in order. take care
144foreign import ccall unsafe "sendfile"
145    c_sendfile32 :: Fd -> Fd -> Ptr COff -> CSize -> IO CSsize
146
147foreign import ccall unsafe "sendfile64"
148    c_sendfile64 :: Fd -> Fd -> Ptr COff -> CSize -> IO CSsize
149
150c_sendfile :: Fd -> Fd -> Ptr COff -> CSize -> IO CSsize
151c_sendfile
152  | isLargeOffset = c_sendfile64
153  | otherwise     = c_sendfile32
154
155----------------------------------------------------------------
156
157-- |
158-- Simple binding for send() and sendfile() of Linux.
159-- Used system calls:
160--
161--  - EntireFile -- send(), open(), stat(), sendfile(), and close()
162--
163--  - PartOfFile -- send(), open(), sendfile(), and close()
164--
165-- The fifth header is sent with send() + the MSG_MORE flag. If the
166-- file is small enough, the header and the file is send in a single
167-- TCP packet.
168--
169-- If the size of the file is unknown when sending the entire file,
170-- specifying PartOfFile is much faster.
171--
172-- The fourth action argument is called when a file is sent as chunks.
173-- Chucking is inevitable if the socket is non-blocking (this is the
174-- default) and the file is large. The action is called after a chunk
175-- is sent and bofore waiting the socket to be ready for writing.
176
177sendfileWithHeader :: Socket -> FilePath -> FileRange -> IO () -> [ByteString] -> IO ()
178sendfileWithHeader sock path range hook hdr = do
179    -- Copying is much faster than syscall.
180    sendMsgMore sock $ B.concat hdr
181    sendfile sock path range hook
182
183-- |
184-- Simple binding for send() and sendfile() of Linux.
185-- Used system calls:
186--
187--  - EntireFile -- send(), stat() and sendfile()
188--
189--  - PartOfFile -- send() and sendfile()
190--
191-- The fifth header is sent with send() + the MSG_MORE flag. If the
192-- file is small enough, the header and the file is send in a single
193-- TCP packet.
194--
195-- If the size of the file is unknown when sending the entire file,
196-- specifying PartOfFile is much faster.
197--
198-- The fourth action argument is called when a file is sent as chunks.
199-- Chucking is inevitable if the socket is non-blocking (this is the
200-- default) and the file is large. The action is called after a chunk
201-- is sent and bofore waiting the socket to be ready for writing.
202
203sendfileFdWithHeader :: Socket -> Fd -> FileRange -> IO () -> [ByteString] -> IO ()
204sendfileFdWithHeader sock fd range hook hdr = do
205    -- Copying is much faster than syscall.
206    sendMsgMore sock $ B.concat hdr
207    sendfileFd sock fd range hook
208
209sendMsgMore :: Socket -> ByteString -> IO ()
210sendMsgMore sock bs = withForeignPtr fptr $ \ptr -> do
211#if MIN_VERSION_network(3,1,0)
212  withFdSocket sock $ \fd -> do
213    let s = Fd fd
214#elif MIN_VERSION_network(3,0,0)
215    s <- Fd <$> fdSocket sock
216#else
217    let s = Fd $ fdSocket sock
218#endif
219    let buf = castPtr (ptr `plusPtr` off)
220        siz = fromIntegral len
221    sendloop s buf siz
222  where
223    PS fptr off len = bs
224
225sendloop :: Fd -> Ptr CChar -> CSize -> IO ()
226sendloop s buf len = do
227    bytes <- c_send s buf len (#const MSG_MORE)
228    if bytes == -1 then do
229        errno <- getErrno
230        if errno == eAGAIN then do
231            threadWaitWrite s
232            sendloop s buf len
233          else
234            throwErrno "Network.SendFile.Linux.sendloop"
235      else do
236        let sent = fromIntegral bytes
237        when (sent /= len) $ do
238            let left = len - sent
239                ptr = buf `plusPtr` fromIntegral bytes
240            sendloop s ptr left
241
242foreign import ccall unsafe "send"
243  c_send :: Fd -> Ptr CChar -> CSize -> CInt -> IO CSsize
244