    {-# LANGUAGE CPP #-}
    {-# LANGUAGE ForeignFunctionInterface #-}

    module Network.Wai.Handler.Warp.SendFile (
        sendFile,
        readSendFile,
        packHeader, -- for testing
    #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 qualified Control.Exception as E
    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
    #endif

    import Network.Wai.Handler.Warp.Buffer
    import Network.Wai.Handler.Warp.Imports
    import Network.Wai.Handler.Warp.Types

    ----------------------------------------------------------------

    -- | Function to send a file based on sendfile() for Linux\/Mac\/FreeBSD.
    --   This makes use of the file descriptor cache.
    --   For other OSes, this is identical to 'readSendFile'.
    --
    -- Since: 3.1.0
    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
        -- settingsFdCacheDuration is 0
        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
    packHeader :: Buffer
    -> Int
    -> (ByteString -> IO ())
    -> IO ()
    -> [ByteString]
    -> Int
    -> IO Int
    packHeader 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

    -- | Function to send a file based on pread()\/send() for Unix.
    --   This makes use of the file descriptor cache.
    --   For Windows, this is emulated by 'Handle'.
    --
    -- Since: 3.1.0
    #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 a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    E.bracket IO Fd
    setup Fd -> IO ()
    teardown ((Fd -> IO ()) -> IO ()) -> (Fd -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \Fd
    fd -> do
            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
    siz Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    hn
                buf' = Buffer
    buf Buffer -> Int -> Ptr b
    forall a b. Ptr a -> Int -> Ptr b
    `plusPtr` Int
    hn
            n <- positionRead fd buf' (mini room len0) off0
            bufferIO buf (hn + n) send
            hook
            let n' = Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    n
            loop fd (len0 - n') (off0 + 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
                n <- Fd -> Buffer -> Int -> Integer -> IO Int
    positionRead Fd
    fd Buffer
    buf (Int -> Integer -> Int
    mini Int
    siz Integer
    len) Integer
    off
                bufferIO buf n send
                let n' = Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    n
                hook
                loop fd (len - n') (off + 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
        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)
        when (bytes < 0) $ throwErrno "positionRead"
        return bytes

    foreign import ccall unsafe "pread"
        c_pread :: Fd -> Ptr CChar -> ByteCount -> FileOffset -> IO CSsize
    #endif