{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP
           , NoImplicitPrelude
           , BangPatterns
           , RankNTypes
  #-}
{-# OPTIONS_GHC -Wno-identities #-}
-- Whether there are identities depends on the platform
{-# OPTIONS_HADDOCK not-home #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.IO.FD
-- Copyright   :  (c) The University of Glasgow, 1994-2008
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable
--
-- Raw read/write operations on file descriptors
--
-----------------------------------------------------------------------------

module GHC.IO.FD (
        FD(..),
        openFileWith, openFile, mkFD, release,
        setNonBlockingMode,
        readRawBufferPtr, readRawBufferPtrNoBlock, writeRawBufferPtr,
        stdin, stdout, stderr
    ) where

import GHC.Base
import GHC.Num
import GHC.Real
import GHC.Show
import GHC.Enum

import GHC.IO
import GHC.IO.IOMode
import GHC.IO.Buffer
import GHC.IO.BufferedIO
import qualified GHC.IO.Device
import GHC.IO.Device (SeekMode(..), IODeviceType(..))
import GHC.Conc.IO
import GHC.IO.Exception
#if defined(mingw32_HOST_OS)
import GHC.Windows
import Data.Bool
import GHC.IO.SubSystem ((<!>))
#endif

import Foreign
import Foreign.C
import qualified System.Posix.Internals
import System.Posix.Internals hiding (FD, setEcho, getEcho)
import System.Posix.Types

#if defined(mingw32_HOST_OS)
# if defined(i386_HOST_ARCH)
#  define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
#  define WINDOWS_CCONV ccall
# else
#  error Unknown mingw32 arch
# endif
#endif

c_DEBUG_DUMP :: Bool
c_DEBUG_DUMP :: Bool
c_DEBUG_DUMP = Bool
False

-- Darwin limits the length of writes to 2GB. See #17414.
-- Moreover, Linux will only transfer up to 0x7ffff000 and interpreting the
-- result of write/read is tricky above 2GB due to its signed type. For
-- simplicity we therefore clamp on all platforms.
clampWriteSize, clampReadSize :: Int -> Int
clampWriteSize :: Int -> Int
clampWriteSize = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
0x7ffff000
clampReadSize :: Int -> Int
clampReadSize  = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
0x7ffff000

-- -----------------------------------------------------------------------------
-- The file-descriptor IO device

data FD = FD {
  FD -> CInt
fdFD :: {-# UNPACK #-} !CInt,
#if defined(mingw32_HOST_OS)
  -- On Windows, a socket file descriptor needs to be read and written
  -- using different functions (send/recv).
  FD -> Int
fdIsSocket_ :: {-# UNPACK #-} !Int
#else
  -- On Unix we need to know whether this FD has O_NONBLOCK set.
  -- If it has, then we can use more efficient routines to read/write to it.
  -- It is always safe for this to be off.
  fdIsNonBlocking :: {-# UNPACK #-} !Int
#endif
 }

#if defined(mingw32_HOST_OS)
fdIsSocket :: FD -> Bool
fdIsSocket :: FD -> Bool
fdIsSocket FD
fd = FD -> Int
fdIsSocket_ FD
fd Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
#endif

-- | @since 4.1.0.0
instance Show FD where
  show :: FD -> String
show FD
fd = CInt -> String
forall a. Show a => a -> String
show (FD -> CInt
fdFD FD
fd)

{-# INLINE ifSupported #-}
ifSupported :: String -> a -> a
#if defined(mingw32_HOST_OS)
ifSupported :: forall a. String -> a -> a
ifSupported String
s a
a = a
a a -> a -> a
forall a. a -> a -> a
<!> (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"FD:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not supported")
#else
ifSupported _ = id
#endif

-- | @since 4.1.0.0
instance GHC.IO.Device.RawIO FD where
  read :: FD -> Ptr Word8 -> Word64 -> Int -> IO Int
read             = String
-> (FD -> Ptr Word8 -> Word64 -> Int -> IO Int)
-> FD
-> Ptr Word8
-> Word64
-> Int
-> IO Int
forall a. String -> a -> a
ifSupported String
"fdRead" FD -> Ptr Word8 -> Word64 -> Int -> IO Int
fdRead
  readNonBlocking :: FD -> Ptr Word8 -> Word64 -> Int -> IO (Maybe Int)
readNonBlocking  = String
-> (FD -> Ptr Word8 -> Word64 -> Int -> IO (Maybe Int))
-> FD
-> Ptr Word8
-> Word64
-> Int
-> IO (Maybe Int)
forall a. String -> a -> a
ifSupported String
"fdReadNonBlocking" FD -> Ptr Word8 -> Word64 -> Int -> IO (Maybe Int)
fdReadNonBlocking
  write :: FD -> Ptr Word8 -> Word64 -> Int -> IO ()
write            = String
-> (FD -> Ptr Word8 -> Word64 -> Int -> IO ())
-> FD
-> Ptr Word8
-> Word64
-> Int
-> IO ()
forall a. String -> a -> a
ifSupported String
"fdWrite" FD -> Ptr Word8 -> Word64 -> Int -> IO ()
fdWrite
  writeNonBlocking :: FD -> Ptr Word8 -> Word64 -> Int -> IO Int
writeNonBlocking = String
-> (FD -> Ptr Word8 -> Word64 -> Int -> IO Int)
-> FD
-> Ptr Word8
-> Word64
-> Int
-> IO Int
forall a. String -> a -> a
ifSupported String
"fdWriteNonBlocking" FD -> Ptr Word8 -> Word64 -> Int -> IO Int
fdWriteNonBlocking

-- | @since 4.1.0.0
instance GHC.IO.Device.IODevice FD where
  ready :: FD -> Bool -> Int -> IO Bool
ready         = String
-> (FD -> Bool -> Int -> IO Bool) -> FD -> Bool -> Int -> IO Bool
forall a. String -> a -> a
ifSupported String
"ready" FD -> Bool -> Int -> IO Bool
ready
  close :: FD -> IO ()
close         = String -> (FD -> IO ()) -> FD -> IO ()
forall a. String -> a -> a
ifSupported String
"close" FD -> IO ()
close
  isTerminal :: FD -> IO Bool
isTerminal    = String -> (FD -> IO Bool) -> FD -> IO Bool
forall a. String -> a -> a
ifSupported String
"isTerm" FD -> IO Bool
isTerminal
  isSeekable :: FD -> IO Bool
isSeekable    = String -> (FD -> IO Bool) -> FD -> IO Bool
forall a. String -> a -> a
ifSupported String
"isSeek" FD -> IO Bool
isSeekable
  seek :: FD -> SeekMode -> Integer -> IO Integer
seek          = String
-> (FD -> SeekMode -> Integer -> IO Integer)
-> FD
-> SeekMode
-> Integer
-> IO Integer
forall a. String -> a -> a
ifSupported String
"seek" FD -> SeekMode -> Integer -> IO Integer
seek
  tell :: FD -> IO Integer
tell          = String -> (FD -> IO Integer) -> FD -> IO Integer
forall a. String -> a -> a
ifSupported String
"tell" FD -> IO Integer
tell
  getSize :: FD -> IO Integer
getSize       = String -> (FD -> IO Integer) -> FD -> IO Integer
forall a. String -> a -> a
ifSupported String
"getSize" FD -> IO Integer
getSize
  setSize :: FD -> Integer -> IO ()
setSize       = String -> (FD -> Integer -> IO ()) -> FD -> Integer -> IO ()
forall a. String -> a -> a
ifSupported String
"setSize" FD -> Integer -> IO ()
setSize
  setEcho :: FD -> Bool -> IO ()
setEcho       = String -> (FD -> Bool -> IO ()) -> FD -> Bool -> IO ()
forall a. String -> a -> a
ifSupported String
"setEcho" FD -> Bool -> IO ()
setEcho
  getEcho :: FD -> IO Bool
getEcho       = String -> (FD -> IO Bool) -> FD -> IO Bool
forall a. String -> a -> a
ifSupported String
"getEcho" FD -> IO Bool
getEcho
  setRaw :: FD -> Bool -> IO ()
setRaw        = String -> (FD -> Bool -> IO ()) -> FD -> Bool -> IO ()
forall a. String -> a -> a
ifSupported String
"setRaw" FD -> Bool -> IO ()
setRaw
  devType :: FD -> IO IODeviceType
devType       = String -> (FD -> IO IODeviceType) -> FD -> IO IODeviceType
forall a. String -> a -> a
ifSupported String
"devType" FD -> IO IODeviceType
devType
  dup :: FD -> IO FD
dup           = String -> (FD -> IO FD) -> FD -> IO FD
forall a. String -> a -> a
ifSupported String
"dup" FD -> IO FD
dup
  dup2 :: FD -> FD -> IO FD
dup2          = String -> (FD -> FD -> IO FD) -> FD -> FD -> IO FD
forall a. String -> a -> a
ifSupported String
"dup2" FD -> FD -> IO FD
dup2

-- We used to use System.Posix.Internals.dEFAULT_BUFFER_SIZE, which is
-- taken from the value of BUFSIZ on the current platform.  This value
-- varies too much though: it is 512 on Windows, 1024 on OS X and 8192
-- on Linux.  So let's just use a decent size on every platform:
dEFAULT_FD_BUFFER_SIZE :: Int
dEFAULT_FD_BUFFER_SIZE :: Int
dEFAULT_FD_BUFFER_SIZE = Int
8192

-- | @since 4.1.0.0
instance BufferedIO FD where
  newBuffer :: FD -> BufferState -> IO (Buffer Word8)
newBuffer FD
_dev BufferState
state = String -> IO (Buffer Word8) -> IO (Buffer Word8)
forall a. String -> a -> a
ifSupported String
"newBuf" (IO (Buffer Word8) -> IO (Buffer Word8))
-> IO (Buffer Word8) -> IO (Buffer Word8)
forall a b. (a -> b) -> a -> b
$ Int -> BufferState -> IO (Buffer Word8)
newByteBuffer Int
dEFAULT_FD_BUFFER_SIZE BufferState
state
  fillReadBuffer :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
fillReadBuffer    FD
fd Buffer Word8
buf = String -> IO (Int, Buffer Word8) -> IO (Int, Buffer Word8)
forall a. String -> a -> a
ifSupported String
"readBuf" (IO (Int, Buffer Word8) -> IO (Int, Buffer Word8))
-> IO (Int, Buffer Word8) -> IO (Int, Buffer Word8)
forall a b. (a -> b) -> a -> b
$ FD -> Buffer Word8 -> IO (Int, Buffer Word8)
readBuf' FD
fd Buffer Word8
buf
  fillReadBuffer0 :: FD -> Buffer Word8 -> IO (Maybe Int, Buffer Word8)
fillReadBuffer0   FD
fd Buffer Word8
buf = String
-> IO (Maybe Int, Buffer Word8) -> IO (Maybe Int, Buffer Word8)
forall a. String -> a -> a
ifSupported String
"readBufNonBlock" (IO (Maybe Int, Buffer Word8) -> IO (Maybe Int, Buffer Word8))
-> IO (Maybe Int, Buffer Word8) -> IO (Maybe Int, Buffer Word8)
forall a b. (a -> b) -> a -> b
$ FD -> Buffer Word8 -> IO (Maybe Int, Buffer Word8)
forall dev.
RawIO dev =>
dev -> Buffer Word8 -> IO (Maybe Int, Buffer Word8)
readBufNonBlocking FD
fd Buffer Word8
buf
  flushWriteBuffer :: FD -> Buffer Word8 -> IO (Buffer Word8)
flushWriteBuffer  FD
fd Buffer Word8
buf = String -> IO (Buffer Word8) -> IO (Buffer Word8)
forall a. String -> a -> a
ifSupported String
"writeBuf" (IO (Buffer Word8) -> IO (Buffer Word8))
-> IO (Buffer Word8) -> IO (Buffer Word8)
forall a b. (a -> b) -> a -> b
$ FD -> Buffer Word8 -> IO (Buffer Word8)
writeBuf' FD
fd Buffer Word8
buf
  flushWriteBuffer0 :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
flushWriteBuffer0 FD
fd Buffer Word8
buf = String -> IO (Int, Buffer Word8) -> IO (Int, Buffer Word8)
forall a. String -> a -> a
ifSupported String
"writeBufNonBlock" (IO (Int, Buffer Word8) -> IO (Int, Buffer Word8))
-> IO (Int, Buffer Word8) -> IO (Int, Buffer Word8)
forall a b. (a -> b) -> a -> b
$ FD -> Buffer Word8 -> IO (Int, Buffer Word8)
forall dev.
RawIO dev =>
dev -> Buffer Word8 -> IO (Int, Buffer Word8)
writeBufNonBlocking FD
fd Buffer Word8
buf

readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
readBuf' FD
fd Buffer Word8
buf = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
c_DEBUG_DUMP (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
puts (String
"readBuf fd=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ FD -> String
forall a. Show a => a -> String
show FD
fd String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Buffer Word8 -> String
forall a. Buffer a -> String
summaryBuffer Buffer Word8
buf String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")
  (Int
r,Buffer Word8
buf') <- FD -> Buffer Word8 -> IO (Int, Buffer Word8)
forall dev.
RawIO dev =>
dev -> Buffer Word8 -> IO (Int, Buffer Word8)
readBuf FD
fd Buffer Word8
buf
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
c_DEBUG_DUMP (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
puts (String
"after: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Buffer Word8 -> String
forall a. Buffer a -> String
summaryBuffer Buffer Word8
buf' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")
  (Int, Buffer Word8) -> IO (Int, Buffer Word8)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
r,Buffer Word8
buf')

writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
writeBuf' FD
fd Buffer Word8
buf = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
c_DEBUG_DUMP (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
puts (String
"writeBuf fd=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ FD -> String
forall a. Show a => a -> String
show FD
fd String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Buffer Word8 -> String
forall a. Buffer a -> String
summaryBuffer Buffer Word8
buf String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")
  FD -> Buffer Word8 -> IO (Buffer Word8)
forall dev. RawIO dev => dev -> Buffer Word8 -> IO (Buffer Word8)
writeBuf FD
fd Buffer Word8
buf

-- -----------------------------------------------------------------------------
-- opening files

-- | Open a file and make an 'FD' for it. Truncates the file to zero size when
-- the `IOMode` is `WriteMode`.
--
-- `openFileWith` takes two actions, @act1@ and @act2@, to perform after
-- opening the file.
--
-- @act1@ is passed a file descriptor and I/O device type for the newly opened
-- file. If an exception occurs in @act1@, then the file will be closed.
-- @act1@ /must not/ close the file itself. If it does so and then receives an
-- exception, then the exception handler will attempt to close it again, which
-- is impermissible.
--
-- @act2@ is performed with asynchronous exceptions masked. It is passed a
-- function to restore the masking state and the result of @act1@.  It /must
-- not/ throw an exception (or deliver one via an interruptible operation)
-- without first closing the file or arranging for it to be closed. @act2@
-- /may/ close the file, but is not required to do so.  If @act2@ leaves the
-- file open, then the file will remain open on return from `openFileWith`.
--
-- Code calling `openFileWith` that wishes to install a finalizer to close
-- the file should do so in @act2@. Doing so in @act1@ could potentially close
-- the file in the finalizer first and then in the exception handler. See
-- 'GHC.IO.Handle.FD.openFile'' for an example of this use. Regardless, the
-- caller is responsible for ensuring that the file is eventually closed,
-- perhaps using 'Control.Exception.bracket'.

openFileWith
  :: FilePath -- ^ file to open
  -> IOMode   -- ^ mode in which to open the file
  -> Bool     -- ^ open the file in non-blocking mode?
  -> (FD -> IODeviceType -> IO r) -- ^ @act1@: An action to perform
                    -- on the file descriptor with the masking state
                    -- restored and an exception handler that closes
                    -- the file on exception.
  -> ((forall x. IO x -> IO x) -> r -> IO s)
                    -- ^ @act2@: An action to perform with async exceptions
                    -- masked and no exception handler.
  -> IO s
openFileWith :: forall r s.
String
-> IOMode
-> Bool
-> (FD -> IODeviceType -> IO r)
-> ((forall x. IO x -> IO x) -> r -> IO s)
-> IO s
openFileWith String
filepath IOMode
iomode Bool
non_blocking FD -> IODeviceType -> IO r
act1 (forall x. IO x -> IO x) -> r -> IO s
act2 =
  String -> (CWString -> IO s) -> IO s
forall a. String -> (CWString -> IO a) -> IO a
withFilePath String
filepath ((CWString -> IO s) -> IO s) -> (CWString -> IO s) -> IO s
forall a b. (a -> b) -> a -> b
$ \ CWString
f ->
    let
      oflags1 :: CInt
oflags1 = case IOMode
iomode of
                  IOMode
ReadMode      -> CInt
read_flags
                  IOMode
WriteMode     -> CInt
write_flags
                  IOMode
ReadWriteMode -> CInt
rw_flags
                  IOMode
AppendMode    -> CInt
append_flags

#if defined(mingw32_HOST_OS)
      binary_flags :: CInt
binary_flags = CInt
o_BINARY
#else
      binary_flags = 0
#endif

      oflags2 :: CInt
oflags2 = CInt
oflags1 CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
binary_flags

      oflags :: CInt
oflags | Bool
non_blocking = CInt
oflags2 CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
nonblock_flags
             | Bool
otherwise    = CInt
oflags2
    in do
      -- We want to be sure all the arguments to c_interruptible_open
      -- are fully evaluated *before* it slips under a mask (assuming we're
      -- not already under a user-imposed mask).
      CInt
oflags' <- CInt -> IO CInt
forall a. a -> IO a
evaluate CInt
oflags
      -- NB. always use a safe open(), because we don't know whether open()
      -- will be fast or not.  It can be slow on NFS and FUSE filesystems,
      -- for example.

      ((forall x. IO x -> IO x) -> IO s) -> IO s
forall b. ((forall x. IO x -> IO x) -> IO b) -> IO b
mask (((forall x. IO x -> IO x) -> IO s) -> IO s)
-> ((forall x. IO x -> IO x) -> IO s) -> IO s
forall a b. (a -> b) -> a -> b
$ \forall x. IO x -> IO x
restore -> do
        CInt
fileno <- String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"openFile" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$
                CWString -> CInt -> CMode -> IO CInt
c_interruptible_open CWString
f CInt
oflags' CMode
0o666

        (FD
fD,IODeviceType
fd_type) <- CInt
-> IOMode
-> Maybe (IODeviceType, CDev, CIno)
-> Bool
-> Bool
-> IO (FD, IODeviceType)
mkFD CInt
fileno IOMode
iomode Maybe (IODeviceType, CDev, CIno)
forall a. Maybe a
Nothing{-no stat-}
                                Bool
False{-not a socket-}
                                Bool
non_blocking IO (FD, IODeviceType) -> IO CInt -> IO (FD, IODeviceType)
forall a b. IO a -> IO b -> IO a
`onException` CInt -> IO CInt
c_close CInt
fileno

        -- we want to truncate() if this is an open in WriteMode, but only
        -- if the target is a RegularFile.  ftruncate() fails on special files
        -- like /dev/null.

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IOMode
iomode IOMode -> IOMode -> Bool
forall a. Eq a => a -> a -> Bool
== IOMode
WriteMode Bool -> Bool -> Bool
&& IODeviceType
fd_type IODeviceType -> IODeviceType -> Bool
forall a. Eq a => a -> a -> Bool
== IODeviceType
RegularFile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          FD -> Integer -> IO ()
setSize FD
fD Integer
0 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`onException` FD -> IO ()
close FD
fD

        r
carry <- IO r -> IO r
forall x. IO x -> IO x
restore (FD -> IODeviceType -> IO r
act1 FD
fD IODeviceType
fd_type) IO r -> IO () -> IO r
forall a b. IO a -> IO b -> IO a
`onException` FD -> IO ()
close FD
fD

        (forall x. IO x -> IO x) -> r -> IO s
act2 IO x -> IO x
forall x. IO x -> IO x
restore r
carry

-- | Open a file and make an 'FD' for it.  Truncates the file to zero
-- size when the `IOMode` is `WriteMode`. This function is difficult
-- to use without potentially leaking the file descriptor on exception.
-- In particular, it must be used with exceptions masked, which is a
-- bit rude because the thread will be uninterruptible while the file
-- path is being encoded. Use 'openFileWith' instead.
openFile
  :: FilePath -- ^ file to open
  -> IOMode   -- ^ mode in which to open the file
  -> Bool     -- ^ open the file in non-blocking mode?
  -> IO (FD,IODeviceType)
openFile :: String -> IOMode -> Bool -> IO (FD, IODeviceType)
openFile String
filepath IOMode
iomode Bool
non_blocking =
  String
-> IOMode
-> Bool
-> (FD -> IODeviceType -> IO (FD, IODeviceType))
-> ((forall x. IO x -> IO x)
    -> (FD, IODeviceType) -> IO (FD, IODeviceType))
-> IO (FD, IODeviceType)
forall r s.
String
-> IOMode
-> Bool
-> (FD -> IODeviceType -> IO r)
-> ((forall x. IO x -> IO x) -> r -> IO s)
-> IO s
openFileWith String
filepath IOMode
iomode Bool
non_blocking
    (\ FD
fd IODeviceType
fd_type -> (FD, IODeviceType) -> IO (FD, IODeviceType)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FD
fd, IODeviceType
fd_type)) (\forall x. IO x -> IO x
_ (FD, IODeviceType)
r -> (FD, IODeviceType) -> IO (FD, IODeviceType)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FD, IODeviceType)
r)

std_flags, output_flags, read_flags, write_flags, rw_flags,
    append_flags, nonblock_flags :: CInt
std_flags :: CInt
std_flags    = CInt
o_NOCTTY
output_flags :: CInt
output_flags = CInt
std_flags    CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
o_CREAT
read_flags :: CInt
read_flags   = CInt
std_flags    CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
o_RDONLY
write_flags :: CInt
write_flags  = CInt
output_flags CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
o_WRONLY
rw_flags :: CInt
rw_flags     = CInt
output_flags CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
o_RDWR
append_flags :: CInt
append_flags = CInt
write_flags  CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
o_APPEND
nonblock_flags :: CInt
nonblock_flags = CInt
o_NONBLOCK


-- | Make a 'FD' from an existing file descriptor.  Fails if the FD
-- refers to a directory.  If the FD refers to a file, `mkFD` locks
-- the file according to the Haskell 2010 single writer/multiple reader
-- locking semantics (this is why we need the `IOMode` argument too).
mkFD :: CInt
     -> IOMode
     -> Maybe (IODeviceType, CDev, CIno)
     -- the results of fdStat if we already know them, or we want
     -- to prevent fdToHandle_stat from doing its own stat.
     -- These are used for:
     --   - we fail if the FD refers to a directory
     --   - if the FD refers to a file, we lock it using (cdev,cino)
     -> Bool   -- ^ is a socket (on Windows)
     -> Bool   -- ^ is in non-blocking mode on Unix
     -> IO (FD,IODeviceType)

mkFD :: CInt
-> IOMode
-> Maybe (IODeviceType, CDev, CIno)
-> Bool
-> Bool
-> IO (FD, IODeviceType)
mkFD CInt
fd IOMode
iomode Maybe (IODeviceType, CDev, CIno)
mb_stat Bool
is_socket Bool
is_nonblock = do

    let (Bool, Bool)
_ = (Bool
is_socket, Bool
is_nonblock) -- warning suppression

    (IODeviceType
fd_type,CDev
dev,CIno
ino) <-
        case Maybe (IODeviceType, CDev, CIno)
mb_stat of
          Maybe (IODeviceType, CDev, CIno)
Nothing   -> CInt -> IO (IODeviceType, CDev, CIno)
fdStat CInt
fd
          Just (IODeviceType, CDev, CIno)
stat -> (IODeviceType, CDev, CIno) -> IO (IODeviceType, CDev, CIno)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IODeviceType, CDev, CIno)
stat

    let write :: Bool
write = case IOMode
iomode of
                   IOMode
ReadMode -> Bool
False
                   IOMode
_ -> Bool
True

    case IODeviceType
fd_type of
        IODeviceType
Directory ->
           IOException -> IO ()
forall a. IOException -> IO a
ioException (Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError Maybe Handle
forall a. Maybe a
Nothing IOErrorType
InappropriateType String
"openFile"
                           String
"is a directory" Maybe CInt
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)

        -- regular files need to be locked
        IODeviceType
RegularFile -> do
           -- On Windows we need an additional call to get a unique device id
           -- and inode, since fstat just returns 0 for both.
           -- See also Note [RTS File locking]
           (Word64
unique_dev, Word64
unique_ino) <- CInt -> CDev -> CIno -> IO (Word64, Word64)
getUniqueFileInfo CInt
fd CDev
dev CIno
ino
           CInt
r <- Word64 -> Word64 -> Word64 -> CInt -> IO CInt
lockFile (CInt -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
fd) Word64
unique_dev Word64
unique_ino
                         (Bool -> CInt
forall a. Num a => Bool -> a
fromBool Bool
write)
           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== -CInt
1)  (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                IOException -> IO ()
forall a. IOException -> IO a
ioException (Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError Maybe Handle
forall a. Maybe a
Nothing IOErrorType
ResourceBusy String
"openFile"
                                   String
"file is locked" Maybe CInt
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)

        IODeviceType
_other_type -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

#if defined(mingw32_HOST_OS)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
is_socket) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> Bool -> IO CInt
setmode CInt
fd Bool
True IO CInt -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif

    (FD, IODeviceType) -> IO (FD, IODeviceType)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FD{ fdFD :: CInt
fdFD = CInt
fd,
#if !defined(mingw32_HOST_OS)
                fdIsNonBlocking = fromEnum is_nonblock
#else
                fdIsSocket_ :: Int
fdIsSocket_ = Bool -> Int
forall a. Enum a => a -> Int
fromEnum Bool
is_socket
#endif
              },
            IODeviceType
fd_type)

getUniqueFileInfo :: CInt -> CDev -> CIno -> IO (Word64, Word64)
#if !defined(mingw32_HOST_OS)
getUniqueFileInfo _ dev ino = return (fromIntegral dev, fromIntegral ino)
#else
getUniqueFileInfo :: CInt -> CDev -> CIno -> IO (Word64, Word64)
getUniqueFileInfo CInt
fd CDev
_ CIno
_ = do
  Word64
-> (Ptr Word64 -> IO (Word64, Word64)) -> IO (Word64, Word64)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Word64
0 ((Ptr Word64 -> IO (Word64, Word64)) -> IO (Word64, Word64))
-> (Ptr Word64 -> IO (Word64, Word64)) -> IO (Word64, Word64)
forall a b. (a -> b) -> a -> b
$ \Ptr Word64
devptr -> do
    Word64
-> (Ptr Word64 -> IO (Word64, Word64)) -> IO (Word64, Word64)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Word64
0 ((Ptr Word64 -> IO (Word64, Word64)) -> IO (Word64, Word64))
-> (Ptr Word64 -> IO (Word64, Word64)) -> IO (Word64, Word64)
forall a b. (a -> b) -> a -> b
$ \Ptr Word64
inoptr -> do
      CInt -> Ptr Word64 -> Ptr Word64 -> IO ()
c_getUniqueFileInfo CInt
fd Ptr Word64
devptr Ptr Word64
inoptr
      (Word64 -> Word64 -> (Word64, Word64))
-> IO Word64 -> IO Word64 -> IO (Word64, Word64)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
peek Ptr Word64
devptr) (Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
peek Ptr Word64
inoptr)
#endif

#if defined(mingw32_HOST_OS)
foreign import ccall unsafe "__hscore_setmode"
  setmode :: CInt -> Bool -> IO CInt
#endif

-- -----------------------------------------------------------------------------
-- Standard file descriptors

stdFD :: CInt -> FD
stdFD :: CInt -> FD
stdFD CInt
fd = FD { fdFD :: CInt
fdFD = CInt
fd,
#if defined(mingw32_HOST_OS)
                fdIsSocket_ :: Int
fdIsSocket_ = Int
0
#else
                fdIsNonBlocking = 0
   -- We don't set non-blocking mode on standard handles, because it may
   -- confuse other applications attached to the same TTY/pipe
   -- see Note [nonblock]
#endif
                }

stdin, stdout, stderr :: FD
stdin :: FD
stdin  = CInt -> FD
stdFD CInt
0
stdout :: FD
stdout = CInt -> FD
stdFD CInt
1
stderr :: FD
stderr = CInt -> FD
stdFD CInt
2

-- -----------------------------------------------------------------------------
-- Operations on file descriptors

close :: FD -> IO ()
close :: FD -> IO ()
close FD
fd =
  do let closer :: a -> IO ()
closer a
realFd =
           String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"GHC.IO.FD.close" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
#if defined(mingw32_HOST_OS)
           if FD -> Bool
fdIsSocket FD
fd then
             CInt -> IO CInt
c_closesocket (a -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
realFd)
           else
#endif
             CInt -> IO CInt
c_close (a -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
realFd)

     -- release the lock *first*, because otherwise if we're preempted
     -- after closing but before releasing, the FD may have been reused.
     -- (#7646)
     FD -> IO ()
release FD
fd

     (Fd -> IO ()) -> Fd -> IO ()
closeFdWith Fd -> IO ()
forall {a}. Integral a => a -> IO ()
closer (CInt -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FD -> CInt
fdFD FD
fd))

release :: FD -> IO ()
release :: FD -> IO ()
release FD
fd = do CInt
_ <- Word64 -> IO CInt
unlockFile (CInt -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Word64) -> CInt -> Word64
forall a b. (a -> b) -> a -> b
$ FD -> CInt
fdFD FD
fd)
                () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

#if defined(mingw32_HOST_OS)
foreign import WINDOWS_CCONV unsafe "HsBase.h closesocket"
   c_closesocket :: CInt -> IO CInt
#endif

isSeekable :: FD -> IO Bool
isSeekable :: FD -> IO Bool
isSeekable FD
fd = do
  IODeviceType
t <- FD -> IO IODeviceType
devType FD
fd
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IODeviceType
t IODeviceType -> IODeviceType -> Bool
forall a. Eq a => a -> a -> Bool
== IODeviceType
RegularFile Bool -> Bool -> Bool
|| IODeviceType
t IODeviceType -> IODeviceType -> Bool
forall a. Eq a => a -> a -> Bool
== IODeviceType
RawDevice)

seek :: FD -> SeekMode -> Integer -> IO Integer
seek :: FD -> SeekMode -> Integer -> IO Integer
seek FD
fd SeekMode
mode Integer
off = Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Integer) -> IO Int64 -> IO Integer
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
  (String -> IO Int64 -> IO Int64
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"seek" (IO Int64 -> IO Int64) -> IO Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$
     CInt -> Int64 -> CInt -> IO Int64
c_lseek (FD -> CInt
fdFD FD
fd) (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
off) CInt
seektype)
 where
    seektype :: CInt
    seektype :: CInt
seektype = case SeekMode
mode of
                   SeekMode
AbsoluteSeek -> CInt
sEEK_SET
                   SeekMode
RelativeSeek -> CInt
sEEK_CUR
                   SeekMode
SeekFromEnd  -> CInt
sEEK_END

tell :: FD -> IO Integer
tell :: FD -> IO Integer
tell FD
fd =
 Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Integer) -> IO Int64 -> IO Integer
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
   (String -> IO Int64 -> IO Int64
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"hGetPosn" (IO Int64 -> IO Int64) -> IO Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$
      CInt -> Int64 -> CInt -> IO Int64
c_lseek (FD -> CInt
fdFD FD
fd) Int64
0 CInt
sEEK_CUR)

getSize :: FD -> IO Integer
getSize :: FD -> IO Integer
getSize FD
fd = CInt -> IO Integer
fdFileSize (FD -> CInt
fdFD FD
fd)

setSize :: FD -> Integer -> IO ()
setSize :: FD -> Integer -> IO ()
setSize FD
fd Integer
size =
  (CInt -> Bool) -> String -> IO CInt -> IO ()
forall a. (a -> Bool) -> String -> IO a -> IO ()
throwErrnoIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/=CInt
0) String
"GHC.IO.FD.setSize" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
     CInt -> COff -> IO CInt
c_ftruncate (FD -> CInt
fdFD FD
fd) (Integer -> COff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
size)

devType :: FD -> IO IODeviceType
devType :: FD -> IO IODeviceType
devType FD
fd = do (IODeviceType
ty,CDev
_,CIno
_) <- CInt -> IO (IODeviceType, CDev, CIno)
fdStat (FD -> CInt
fdFD FD
fd); IODeviceType -> IO IODeviceType
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return IODeviceType
ty

dup :: FD -> IO FD
dup :: FD -> IO FD
dup FD
fd = do
  CInt
newfd <- String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1 String
"GHC.IO.FD.dup" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ CInt -> IO CInt
c_dup (FD -> CInt
fdFD FD
fd)
  FD -> IO FD
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FD
fd{ fdFD = newfd }

dup2 :: FD -> FD -> IO FD
dup2 :: FD -> FD -> IO FD
dup2 FD
fd FD
fdto = do
  -- Windows' dup2 does not return the new descriptor, unlike Unix
  String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"GHC.IO.FD.dup2" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
    CInt -> CInt -> IO CInt
c_dup2 (FD -> CInt
fdFD FD
fd) (FD -> CInt
fdFD FD
fdto)
  FD -> IO FD
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FD
fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD

setNonBlockingMode :: FD -> Bool -> IO FD
setNonBlockingMode :: FD -> Bool -> IO FD
setNonBlockingMode FD
fd Bool
set = do
  CInt -> Bool -> IO ()
setNonBlockingFD (FD -> CInt
fdFD FD
fd) Bool
set
#if defined(mingw32_HOST_OS)
  FD -> IO FD
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FD
fd
#else
  return fd{ fdIsNonBlocking = fromEnum set }
#endif

ready :: FD -> Bool -> Int -> IO Bool
ready :: FD -> Bool -> Int -> IO Bool
ready FD
fd Bool
write Int
msecs = do
  CInt
r <- String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"GHC.IO.FD.ready" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$
          CInt -> CBool -> Int64 -> CBool -> IO CInt
fdReady (FD -> CInt
fdFD FD
fd) (Int -> CBool
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CBool) -> Int -> CBool
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> Bool -> Int
forall a b. (a -> b) -> a -> b
$ Bool
write)
                            (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
msecs)
#if defined(mingw32_HOST_OS)
                          (Int -> CBool
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CBool) -> Int -> CBool
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> Bool -> Int
forall a b. (a -> b) -> a -> b
$ FD -> Bool
fdIsSocket FD
fd)
#else
                          0
#endif
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Bool
forall a. Enum a => Int -> a
toEnum (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
r))

foreign import ccall safe "fdReady"
  fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt

-- ---------------------------------------------------------------------------
-- Terminal-related stuff

isTerminal :: FD -> IO Bool
isTerminal :: FD -> IO Bool
isTerminal FD
fd =
#if defined(mingw32_HOST_OS)
    if FD -> Bool
fdIsSocket FD
fd then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                     else CInt -> IO CInt
is_console (FD -> CInt
fdFD FD
fd) IO CInt -> (CInt -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return(Bool -> IO Bool) -> (CInt -> Bool) -> CInt -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.CInt -> Bool
forall a. (Eq a, Num a) => a -> Bool
toBool
#else
    c_isatty (fdFD fd) >>= return.toBool
#endif

setEcho :: FD -> Bool -> IO ()
setEcho :: FD -> Bool -> IO ()
setEcho FD
fd Bool
on = CInt -> Bool -> IO ()
System.Posix.Internals.setEcho (FD -> CInt
fdFD FD
fd) Bool
on

getEcho :: FD -> IO Bool
getEcho :: FD -> IO Bool
getEcho FD
fd = CInt -> IO Bool
System.Posix.Internals.getEcho (FD -> CInt
fdFD FD
fd)

setRaw :: FD -> Bool -> IO ()
setRaw :: FD -> Bool -> IO ()
setRaw FD
fd Bool
raw = CInt -> Bool -> IO ()
System.Posix.Internals.setCooked (FD -> CInt
fdFD FD
fd) (Bool -> Bool
not Bool
raw)

-- -----------------------------------------------------------------------------
-- Reading and Writing

fdRead :: FD -> Ptr Word8 -> Word64 -> Int -> IO Int
fdRead :: FD -> Ptr Word8 -> Word64 -> Int -> IO Int
fdRead FD
fd Ptr Word8
ptr Word64
_offset Int
bytes
  = do { CInt
r <- String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
readRawBufferPtr String
"GHC.IO.FD.fdRead" FD
fd Ptr Word8
ptr Int
0
                (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CSize) -> Int -> CSize
forall a b. (a -> b) -> a -> b
$ Int -> Int
clampReadSize Int
bytes)
       ; Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
r) }

fdReadNonBlocking :: FD -> Ptr Word8 -> Word64 -> Int -> IO (Maybe Int)
fdReadNonBlocking :: FD -> Ptr Word8 -> Word64 -> Int -> IO (Maybe Int)
fdReadNonBlocking FD
fd Ptr Word8
ptr Word64
_offset Int
bytes = do
  CInt
r <- String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
readRawBufferPtrNoBlock String
"GHC.IO.FD.fdReadNonBlocking" FD
fd Ptr Word8
ptr
           Int
0 (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CSize) -> Int -> CSize
forall a b. (a -> b) -> a -> b
$ Int -> Int
clampReadSize Int
bytes)
  case CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
r of
    (-1) -> Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int
forall a. Maybe a
Nothing)
    Int
n    -> Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n)


fdWrite :: FD -> Ptr Word8 -> Word64 -> Int -> IO ()
fdWrite :: FD -> Ptr Word8 -> Word64 -> Int -> IO ()
fdWrite FD
fd Ptr Word8
ptr Word64
_offset Int
bytes = do
  CInt
res <- String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtr String
"GHC.IO.FD.fdWrite" FD
fd Ptr Word8
ptr Int
0
          (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CSize) -> Int -> CSize
forall a b. (a -> b) -> a -> b
$ Int -> Int
clampWriteSize Int
bytes)
  let res' :: Int
res' = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
res
  if Int
res' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bytes
     then FD -> Ptr Word8 -> Word64 -> Int -> IO ()
fdWrite FD
fd (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
res') (Word64
_offset Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
res') (Int
bytes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
res')
     else () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- XXX ToDo: this isn't non-blocking
fdWriteNonBlocking :: FD -> Ptr Word8 -> Word64 -> Int -> IO Int
fdWriteNonBlocking :: FD -> Ptr Word8 -> Word64 -> Int -> IO Int
fdWriteNonBlocking FD
fd Ptr Word8
ptr Word64
_offset Int
bytes = do
  CInt
res <- String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtrNoBlock String
"GHC.IO.FD.fdWriteNonBlocking" FD
fd Ptr Word8
ptr Int
0
            (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CSize) -> Int -> CSize
forall a b. (a -> b) -> a -> b
$ Int -> Int
clampWriteSize Int
bytes)
  Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
res)

-- -----------------------------------------------------------------------------
-- FD operations

-- Low level routines for reading/writing to (raw)buffers:

#if !defined(mingw32_HOST_OS)

{-
Note [nonblock]
~~~~~~~~~~~~~~~
Unix has broken semantics when it comes to non-blocking I/O: you can
set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
attached to the same underlying file, pipe or TTY; there's no way to
have private non-blocking behaviour for an FD.  See bug #724.

We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
come from external sources or are exposed externally are left in
blocking mode.  This solution has some problems though.  We can't
completely simulate a non-blocking read without O_NONBLOCK: several
cases are wrong here.  The cases that are wrong:

  * reading/writing to a blocking FD in non-threaded mode.
    In threaded mode, we just make a safe call to read().
    In non-threaded mode we call select() before attempting to read,
    but that leaves a small race window where the data can be read
    from the file descriptor before we issue our blocking read().
  * readRawBufferNoBlock for a blocking FD

NOTE [2363]:

In the threaded RTS we could just make safe calls to read()/write()
for file descriptors in blocking mode without worrying about blocking
other threads, but the problem with this is that the thread will be
uninterruptible while it is blocked in the foreign call.  See #2363.
So now we always call fdReady() before reading, and if fdReady
indicates that there's no data, we call threadWaitRead.

-}

readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
readRawBufferPtr loc !fd !buf !off !len
#if defined(javascript_HOST_ARCH)
  = fmap fromIntegral . mask_ $
    throwErrnoIfMinus1 loc (c_read (fdFD fd) (buf `plusPtr` off) len)
#else
  | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
  | otherwise    = do r <- throwErrnoIfMinus1 loc
                                (unsafe_fdReady (fdFD fd) 0 0 0)
                      if r /= 0
                        then read
                        else do threadWaitRead (fromIntegral (fdFD fd)); read
  where
    do_read call = fromIntegral `fmap`
                      throwErrnoIfMinus1RetryMayBlock loc call
                            (threadWaitRead (fromIntegral (fdFD fd)))
    read        = if threaded then safe_read else unsafe_read
    unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
    safe_read   = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
#endif

-- return: -1 indicates EOF, >=0 is bytes read
readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
readRawBufferPtrNoBlock loc !fd !buf !off !len
#if defined(javascript_HOST_ARCH)
  = mask_ $ do
      r <- throwErrnoIfMinus1 loc (c_read (fdFD fd) (buf `plusPtr` off) len)
      case r of
       (-1) -> return 0
       0    -> return (-1)
       n    -> return (fromIntegral n)
#else
  | isNonBlocking fd  = unsafe_read -- unsafe is ok, it can't block
  | otherwise    = do r <- unsafe_fdReady (fdFD fd) 0 0 0
                      if r /= 0 then safe_read
                                else return 0
       -- XXX see note [nonblock]
 where
   do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
                     case r of
                       (-1) -> return 0
                       0    -> return (-1)
                       n    -> return (fromIntegral n)
   unsafe_read  = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
   safe_read    = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
#endif

writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtr loc !fd !buf !off !len
#if defined(javascript_HOST_ARCH)
  = fmap fromIntegral . mask_ $
    throwErrnoIfMinus1 loc (c_write (fdFD fd) (buf `plusPtr` off) len)
#else
  | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
  | otherwise   = do r <- unsafe_fdReady (fdFD fd) 1 0 0
                     if r /= 0
                        then write
                        else do threadWaitWrite (fromIntegral (fdFD fd)); write
  where
    do_write call = fromIntegral `fmap`
                      throwErrnoIfMinus1RetryMayBlock loc call
                        (threadWaitWrite (fromIntegral (fdFD fd)))
    write         = if threaded then safe_write else unsafe_write
    unsafe_write  = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
    safe_write    = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
#endif

writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtrNoBlock loc !fd !buf !off !len
#if defined(javascript_HOST_ARCH)
  = mask_ $ do
      r <- throwErrnoIfMinus1 loc (c_write (fdFD fd) (buf `plusPtr` off) len)
      case r of
        (-1) -> return 0
        n    -> return (fromIntegral n)
#else
  | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
  | otherwise   = do r <- unsafe_fdReady (fdFD fd) 1 0 0
                     if r /= 0 then write
                               else return 0
  where
    do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
                       case r of
                         (-1) -> return 0
                         n    -> return (fromIntegral n)
    write         = if threaded then safe_write else unsafe_write
    unsafe_write  = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
    safe_write    = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
#endif

#if !defined(javascript_HOST_ARCH)
isNonBlocking :: FD -> Bool
isNonBlocking fd = fdIsNonBlocking fd /= 0

foreign import ccall unsafe "fdReady"
  unsafe_fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt
#endif

#else /* mingw32_HOST_OS.... */

readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
readRawBufferPtr String
loc !FD
fd !Ptr Word8
buf !Int
off !CSize
len
  | Bool
threaded  = String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
blockingReadRawBufferPtr String
loc FD
fd Ptr Word8
buf Int
off CSize
len
  | Bool
otherwise = String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
asyncReadRawBufferPtr    String
loc FD
fd Ptr Word8
buf Int
off CSize
len

writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtr String
loc !FD
fd !Ptr Word8
buf !Int
off !CSize
len
  | Bool
threaded  = String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
blockingWriteRawBufferPtr String
loc FD
fd Ptr Word8
buf Int
off CSize
len
  | Bool
otherwise = String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
asyncWriteRawBufferPtr    String
loc FD
fd Ptr Word8
buf Int
off CSize
len

readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
readRawBufferPtrNoBlock = String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
readRawBufferPtr

writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtrNoBlock = String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtr

-- Async versions of the read/write primitives, for the non-threaded RTS

asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
asyncReadRawBufferPtr String
loc !FD
fd !Ptr Word8
buf !Int
off !CSize
len = do
    (Int
l, Int
rc) <- Int -> Int -> Int -> Ptr Any -> IO (Int, Int)
forall a. Int -> Int -> Int -> Ptr a -> IO (Int, Int)
asyncRead (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FD -> CInt
fdFD FD
fd)) (FD -> Int
fdIsSocket_ FD
fd)
                        (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
len) (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off)
    if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (-Int
1)
      then let sock_errno :: Errno
sock_errno = ErrCode -> Errno
c_maperrno_func (Int -> ErrCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rc)
               non_sock_errno :: Errno
non_sock_errno = CInt -> Errno
Errno (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rc)
               errno :: Errno
errno = Errno -> Errno -> Bool -> Errno
forall a. a -> a -> Bool -> a
bool Errno
non_sock_errno Errno
sock_errno (FD -> Bool
fdIsSocket FD
fd)
           in  IOException -> IO CInt
forall a. IOException -> IO a
ioError (String -> Errno -> Maybe Handle -> Maybe String -> IOException
errnoToIOError String
loc Errno
errno Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
      else CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)

asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
asyncWriteRawBufferPtr String
loc !FD
fd !Ptr Word8
buf !Int
off !CSize
len = do
    (Int
l, Int
rc) <- Int -> Int -> Int -> Ptr Any -> IO (Int, Int)
forall a. Int -> Int -> Int -> Ptr a -> IO (Int, Int)
asyncWrite (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FD -> CInt
fdFD FD
fd)) (FD -> Int
fdIsSocket_ FD
fd)
                  (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
len) (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off)
    if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (-Int
1)
      then let sock_errno :: Errno
sock_errno = ErrCode -> Errno
c_maperrno_func (Int -> ErrCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rc)
               non_sock_errno :: Errno
non_sock_errno = CInt -> Errno
Errno (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rc)
               errno :: Errno
errno = Errno -> Errno -> Bool -> Errno
forall a. a -> a -> Bool -> a
bool Errno
non_sock_errno Errno
sock_errno (FD -> Bool
fdIsSocket FD
fd)
           in  IOException -> IO CInt
forall a. IOException -> IO a
ioError (String -> Errno -> Maybe Handle -> Maybe String -> IOException
errnoToIOError String
loc Errno
errno Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
      else CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)

-- Blocking versions of the read/write primitives, for the threaded RTS

blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
blockingReadRawBufferPtr String
loc !FD
fd !Ptr Word8
buf !Int
off !CSize
len
  = String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
loc (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ do
        let start_ptr :: Ptr b
start_ptr = Ptr Word8
buf Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off
            recv_ret :: IO CInt
recv_ret = CInt -> Ptr Word8 -> CInt -> CInt -> IO CInt
c_safe_recv (FD -> CInt
fdFD FD
fd) Ptr Word8
forall {b}. Ptr b
start_ptr (CSize -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
len) CInt
0
            read_ret :: IO CInt
read_ret = CInt -> Ptr Word8 -> CUInt -> IO CInt
c_safe_read (FD -> CInt
fdFD FD
fd) Ptr Word8
forall {b}. Ptr b
start_ptr (CSize -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
len)
        CInt
r <- IO CInt -> IO CInt -> Bool -> IO CInt
forall a. a -> a -> Bool -> a
bool IO CInt
read_ret IO CInt
recv_ret (FD -> Bool
fdIsSocket FD
fd)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((FD -> Bool
fdIsSocket FD
fd) Bool -> Bool -> Bool
&& (CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== -CInt
1)) IO ()
c_maperrno
        CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
r
      -- We trust read() to give us the correct errno but recv(), as a
      -- Winsock function, doesn't do the errno conversion so if the fd
      -- is for a socket, we do it from GetLastError() ourselves.

blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
blockingWriteRawBufferPtr String
loc !FD
fd !Ptr Word8
buf !Int
off !CSize
len
  = String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
loc (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ do
        let start_ptr :: Ptr b
start_ptr = Ptr Word8
buf Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off
            send_ret :: IO CInt
send_ret = CInt -> Ptr Word8 -> CInt -> CInt -> IO CInt
c_safe_send  (FD -> CInt
fdFD FD
fd) Ptr Word8
forall {b}. Ptr b
start_ptr (CSize -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
len) CInt
0
            write_ret :: IO CInt
write_ret = CInt -> Ptr Word8 -> CUInt -> IO CInt
c_safe_write (FD -> CInt
fdFD FD
fd) Ptr Word8
forall {b}. Ptr b
start_ptr (CSize -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
len)
        CInt
r <- IO CInt -> IO CInt -> Bool -> IO CInt
forall a. a -> a -> Bool -> a
bool IO CInt
write_ret IO CInt
send_ret (FD -> Bool
fdIsSocket FD
fd)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== -CInt
1) IO ()
c_maperrno
        CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
r
      -- We don't trust write() to give us the correct errno, and
      -- instead do the errno conversion from GetLastError()
      -- ourselves. The main reason is that we treat ERROR_NO_DATA
      -- (pipe is closing) as EPIPE, whereas write() returns EINVAL
      -- for this case. We need to detect EPIPE correctly, because it
      -- shouldn't be reported as an error when it happens on stdout.
      -- As for send()'s case, Winsock functions don't do errno
      -- conversion in any case so we have to do it ourselves.
      -- That means we're doing the errno conversion no matter if the
      -- fd is from a socket or not.

-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
-- These calls may block, but that's ok.

foreign import WINDOWS_CCONV safe "recv"
   c_safe_recv :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt

foreign import WINDOWS_CCONV safe "send"
   c_safe_send :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt

#endif

#if !defined(javascript_HOST_ARCH)
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
#endif

-- -----------------------------------------------------------------------------
-- utils

#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH)
throwErrnoIfMinus1RetryOnBlock  :: String -> IO CSsize -> IO CSsize -> IO CSsize
throwErrnoIfMinus1RetryOnBlock loc f on_block  =
  do
    res <- f
    if (res :: CSsize) == -1
      then do
        err <- getErrno
        if err == eINTR
          then throwErrnoIfMinus1RetryOnBlock loc f on_block
          else if err == eWOULDBLOCK || err == eAGAIN
                 then on_block
                 else throwErrno loc
      else return res
#endif

-- -----------------------------------------------------------------------------
-- Locking/unlocking

foreign import ccall unsafe "lockFile"
  lockFile :: Word64 -> Word64 -> Word64 -> CInt -> IO CInt

foreign import ccall unsafe "unlockFile"
  unlockFile :: Word64 -> IO CInt

#if defined(mingw32_HOST_OS)
foreign import ccall unsafe "get_unique_file_info"
  c_getUniqueFileInfo :: CInt -> Ptr Word64 -> Ptr Word64 -> IO ()
#endif