{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Network.Wai.Handler.Warp.SendFile (
sendFile,
readSendFile,
packHeader,
#ifndef WINDOWS
positionRead,
#endif
) where
import qualified Data.ByteString as BS
import Network.Socket (Socket)
import Network.Socket.BufferPool
#ifdef WINDOWS
import Foreign.ForeignPtr (newForeignPtr_)
import Foreign.Ptr (plusPtr)
import qualified System.IO as IO
#else
import Foreign.C.Error (throwErrno)
import Foreign.C.Types
import Foreign.Ptr (Ptr, castPtr, plusPtr)
import Network.Sendfile
import Network.Wai.Handler.Warp.FdCache (openFile, closeFile)
import System.Posix.Types
import qualified UnliftIO
#endif
import Network.Wai.Handler.Warp.Buffer
import Network.Wai.Handler.Warp.Imports
import Network.Wai.Handler.Warp.Types
sendFile :: Socket -> Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile
#ifdef SENDFILEFD
sendFile :: Socket -> Buffer -> Int -> (ByteString -> IO ()) -> SendFile
sendFile Socket
s Buffer
_ Int
_ ByteString -> IO ()
_ FileId
fid Integer
off Integer
len IO ()
act [ByteString]
hdr = case Maybe Fd
mfid of
Maybe Fd
Nothing -> Socket -> FilePath -> FileRange -> IO () -> [ByteString] -> IO ()
sendfileWithHeader Socket
s FilePath
path (Integer -> Integer -> FileRange
PartOfFile Integer
off Integer
len) IO ()
act [ByteString]
hdr
Just Fd
fd -> Socket -> Fd -> FileRange -> IO () -> [ByteString] -> IO ()
sendfileFdWithHeader Socket
s Fd
fd (Integer -> Integer -> FileRange
PartOfFile Integer
off Integer
len) IO ()
act [ByteString]
hdr
where
mfid :: Maybe Fd
mfid = FileId -> Maybe Fd
fileIdFd FileId
fid
path :: FilePath
path = FileId -> FilePath
fileIdPath FileId
fid
#else
sendFile _ = readSendFile
#endif
packHeader
:: Buffer
-> BufSize
-> (ByteString -> IO ())
-> IO ()
-> [ByteString]
-> Int
-> IO Int
Buffer
_ Int
_ ByteString -> IO ()
_ IO ()
_ [] Int
n = Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
packHeader Buffer
buf Int
siz ByteString -> IO ()
send IO ()
hook (ByteString
bs : [ByteString]
bss) Int
n
| Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
room = do
let dst :: Ptr b
dst = Buffer
buf Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
n
IO Buffer -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Buffer -> IO ()) -> IO Buffer -> IO ()
forall a b. (a -> b) -> a -> b
$ Buffer -> ByteString -> IO Buffer
copy Buffer
forall {b}. Ptr b
dst ByteString
bs
Buffer
-> Int
-> (ByteString -> IO ())
-> IO ()
-> [ByteString]
-> Int
-> IO Int
packHeader Buffer
buf Int
siz ByteString -> IO ()
send IO ()
hook [ByteString]
bss (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len)
| Bool
otherwise = do
let dst :: Ptr b
dst = Buffer
buf Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
n
(ByteString
bs1, ByteString
bs2) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
room ByteString
bs
IO Buffer -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Buffer -> IO ()) -> IO Buffer -> IO ()
forall a b. (a -> b) -> a -> b
$ Buffer -> ByteString -> IO Buffer
copy Buffer
forall {b}. Ptr b
dst ByteString
bs1
Buffer -> Int -> (ByteString -> IO ()) -> IO ()
bufferIO Buffer
buf Int
siz ByteString -> IO ()
send
IO ()
hook
Buffer
-> Int
-> (ByteString -> IO ())
-> IO ()
-> [ByteString]
-> Int
-> IO Int
packHeader Buffer
buf Int
siz ByteString -> IO ()
send IO ()
hook (ByteString
bs2 ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
bss) Int
0
where
len :: Int
len = ByteString -> Int
BS.length ByteString
bs
room :: Int
room = Int
siz Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n
mini :: Int -> Integer -> Int
mini :: Int -> Integer -> Int
mini Int
i Integer
n
| Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
n = Int
i
| Bool
otherwise = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n
#ifdef WINDOWS
readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile
readSendFile buf siz send fid off0 len0 hook headers = do
hn <- packHeader buf siz send hook headers 0
let room = siz - hn
buf' = buf `plusPtr` hn
IO.withBinaryFile path IO.ReadMode $ \h -> do
IO.hSeek h IO.AbsoluteSeek off0
n <- IO.hGetBufSome h buf' (mini room len0)
bufferIO buf (hn + n) send
hook
let n' = fromIntegral n
fptr <- newForeignPtr_ buf
loop h fptr (len0 - n')
where
path = fileIdPath fid
loop h fptr len
| len <= 0 = return ()
| otherwise = do
n <- IO.hGetBufSome h buf (mini siz len)
when (n /= 0) $ do
let bs = PS fptr 0 n
n' = fromIntegral n
send bs
hook
loop h fptr (len - n')
#else
readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile
readSendFile :: Buffer -> Int -> (ByteString -> IO ()) -> SendFile
readSendFile Buffer
buf Int
siz ByteString -> IO ()
send FileId
fid Integer
off0 Integer
len0 IO ()
hook [ByteString]
headers =
IO Fd -> (Fd -> IO ()) -> (Fd -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.bracket IO Fd
setup Fd -> IO ()
teardown ((Fd -> IO ()) -> IO ()) -> (Fd -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Fd
fd -> do
Int
hn <- Buffer
-> Int
-> (ByteString -> IO ())
-> IO ()
-> [ByteString]
-> Int
-> IO Int
packHeader Buffer
buf Int
siz ByteString -> IO ()
send IO ()
hook [ByteString]
headers Int
0
let room :: Int
room = Int
siz Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
hn
buf' :: Ptr b
buf' = Buffer
buf Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
hn
Int
n <- Fd -> Buffer -> Int -> Integer -> IO Int
positionRead Fd
fd Buffer
forall {b}. Ptr b
buf' (Int -> Integer -> Int
mini Int
room Integer
len0) Integer
off0
Buffer -> Int -> (ByteString -> IO ()) -> IO ()
bufferIO Buffer
buf (Int
hn Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) ByteString -> IO ()
send
IO ()
hook
let n' :: Integer
n' = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
Fd -> Integer -> Integer -> IO ()
loop Fd
fd (Integer
len0 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
n') (Integer
off0 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n')
where
path :: FilePath
path = FileId -> FilePath
fileIdPath FileId
fid
setup :: IO Fd
setup = case FileId -> Maybe Fd
fileIdFd FileId
fid of
Just Fd
fd -> Fd -> IO Fd
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Fd
fd
Maybe Fd
Nothing -> FilePath -> IO Fd
openFile FilePath
path
teardown :: Fd -> IO ()
teardown Fd
fd = case FileId -> Maybe Fd
fileIdFd FileId
fid of
Just Fd
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Fd
Nothing -> Fd -> IO ()
closeFile Fd
fd
loop :: Fd -> Integer -> Integer -> IO ()
loop Fd
fd Integer
len Integer
off
| Integer
len Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = do
Int
n <- Fd -> Buffer -> Int -> Integer -> IO Int
positionRead Fd
fd Buffer
buf (Int -> Integer -> Int
mini Int
siz Integer
len) Integer
off
Buffer -> Int -> (ByteString -> IO ()) -> IO ()
bufferIO Buffer
buf Int
n ByteString -> IO ()
send
let n' :: Integer
n' = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
IO ()
hook
Fd -> Integer -> Integer -> IO ()
loop Fd
fd (Integer
len Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
n') (Integer
off Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n')
positionRead :: Fd -> Buffer -> BufSize -> Integer -> IO Int
positionRead :: Fd -> Buffer -> Int -> Integer -> IO Int
positionRead Fd
fd Buffer
buf Int
siz Integer
off = do
Int
bytes <-
CSsize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CSsize -> Int) -> IO CSsize -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fd -> Ptr CChar -> ByteCount -> FileOffset -> IO CSsize
c_pread Fd
fd (Buffer -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Buffer
buf) (Int -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
siz) (Integer -> FileOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
off)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
bytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall a. FilePath -> IO a
throwErrno FilePath
"positionRead"
Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
bytes
foreign import ccall unsafe "pread"
c_pread :: Fd -> Ptr CChar -> ByteCount -> FileOffset -> IO CSsize
#endif