<commit_before>{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP
           , NoImplicitPrelude
           , BangPatterns
  #-}
{-# OPTIONS_GHC -Wno-identities #-}
-- Whether there are identities depends on the platform
{-# OPTIONS_HADDOCK hide #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.IO.FD
-- Copyright   :  (c) The University of Glasgow, 1994-2008
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  <EMAIL>
-- Stability   :  internal
-- Portability :  non-portable
--
-- Raw read/write operations on file descriptors
--
-----------------------------------------------------------------------------

module GHC.IO.FD (
        FD(..),
        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
#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 = False

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

data FD = FD {
  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).
  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 = fdIsSocket_ fd /= 0
#endif

-- | @since 4.1.0.0
instance Show FD where
  show fd = show (fdFD fd)

-- | @since 4.1.0.0
instance GHC.IO.Device.RawIO FD where
  read             = fdRead
  readNonBlocking  = fdReadNonBlocking
  write            = fdWrite
  writeNonBlocking = fdWriteNonBlocking

-- | @since 4.1.0.0
instance GHC.IO.Device.IODevice FD where
  ready         = ready
  close         = close
  isTerminal    = isTerminal
  isSeekable    = isSeekable
  seek          = seek
  tell          = tell
  getSize       = getSize
  setSize       = setSize
  setEcho       = setEcho
  getEcho       = getEcho
  setRaw        = setRaw
  devType       = devType
  dup           = dup
  dup2          = 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 = 8192

-- | @since 4.1.0.0
instance BufferedIO FD where
  newBuffer _dev state = newByteBuffer dEFAULT_FD_BUFFER_SIZE state
  fillReadBuffer    fd buf = readBuf' fd buf
  fillReadBuffer0   fd buf = readBufNonBlocking fd buf
  flushWriteBuffer  fd buf = writeBuf' fd buf
  flushWriteBuffer0 fd buf = writeBufNonBlocking fd buf

readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
readBuf' fd buf = do
  when c_DEBUG_DUMP $
      puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
  (r,buf') <- readBuf fd buf
  when c_DEBUG_DUMP $
      puts ("after: " ++ summaryBuffer buf' ++ "\n")
  return (r,buf')

writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
writeBuf' fd buf = do
  when c_DEBUG_DUMP $
      puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
  writeBuf fd buf

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

-- | Open a file and make an 'FD' for it.  Truncates the file to zero
-- size when the `IOMode` is `WriteMode`.
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 filepath iomode non_blocking =
  withFilePath filepath $ \ f ->

    let
      oflags1 = case iomode of
                  ReadMode      -> read_flags
                  WriteMode     -> write_flags
                  ReadWriteMode -> rw_flags
                  AppendMode    -> append_flags

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

      oflags2 = oflags1 .|. binary_flags

      oflags | non_blocking = oflags2 .|. nonblock_flags
             | otherwise    = oflags2
    in do

    -- the old implementation had a complicated series of three opens,
    -- which is perhaps because we have to be careful not to open
    -- directories.  However, the man pages I've read say that open()
    -- always returns EISDIR if the file is a directory and was opened
    -- for writing, so I think we're ok with a single open() here...
    fd <- throwErrnoIfMinus1Retry "openFile"
                (if non_blocking then c_open      f oflags 0o666
                                 else c_safe_open f oflags 0o666)

    (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
                            False{-not a socket-}
                            non_blocking
            `catchAny` \e -> do _ <- c_close fd
                                throwIO e

    -- 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.
    when (iomode == WriteMode && fd_type == RegularFile) $
      setSize fD 0
<commit_msg>Always use the safe open() call<commit_after>{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP
           , NoImplicitPrelude
           , BangPatterns
  #-}
{-# OPTIONS_GHC -Wno-identities #-}
-- Whether there are identities depends on the platform
{-# OPTIONS_HADDOCK hide #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.IO.FD
-- Copyright   :  (c) The University of Glasgow, 1994-2008
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  <EMAIL>
-- Stability   :  internal
-- Portability :  non-portable
--
-- Raw read/write operations on file descriptors
--
-----------------------------------------------------------------------------

module GHC.IO.FD (
        FD(..),
        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
#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 = False

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

data FD = FD {
  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).
  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 = fdIsSocket_ fd /= 0
#endif

-- | @since 4.1.0.0
instance Show FD where
  show fd = show (fdFD fd)

-- | @since 4.1.0.0
instance GHC.IO.Device.RawIO FD where
  read             = fdRead
  readNonBlocking  = fdReadNonBlocking
  write            = fdWrite
  writeNonBlocking = fdWriteNonBlocking

-- | @since 4.1.0.0
instance GHC.IO.Device.IODevice FD where
  ready         = ready
  close         = close
  isTerminal    = isTerminal
  isSeekable    = isSeekable
  seek          = seek
  tell          = tell
  getSize       = getSize
  setSize       = setSize
  setEcho       = setEcho
  getEcho       = getEcho
  setRaw        = setRaw
  devType       = devType
  dup           = dup
  dup2          = 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 = 8192

-- | @since 4.1.0.0
instance BufferedIO FD where
  newBuffer _dev state = newByteBuffer dEFAULT_FD_BUFFER_SIZE state
  fillReadBuffer    fd buf = readBuf' fd buf
  fillReadBuffer0   fd buf = readBufNonBlocking fd buf
  flushWriteBuffer  fd buf = writeBuf' fd buf
  flushWriteBuffer0 fd buf = writeBufNonBlocking fd buf

readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
readBuf' fd buf = do
  when c_DEBUG_DUMP $
      puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
  (r,buf') <- readBuf fd buf
  when c_DEBUG_DUMP $
      puts ("after: " ++ summaryBuffer buf' ++ "\n")
  return (r,buf')

writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
writeBuf' fd buf = do
  when c_DEBUG_DUMP $
      puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
  writeBuf fd buf

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

-- | Open a file and make an 'FD' for it.  Truncates the file to zero
-- size when the `IOMode` is `WriteMode`.
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 filepath iomode non_blocking =
  withFilePath filepath $ \ f ->

    let
      oflags1 = case iomode of
                  ReadMode      -> read_flags
                  WriteMode     -> write_flags
                  ReadWriteMode -> rw_flags
                  AppendMode    -> append_flags

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

      oflags2 = oflags1 .|. binary_flags

      oflags | non_blocking = oflags2 .|. nonblock_flags
             | otherwise    = oflags2
    in do

    -- 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.
    fd <- throwErrnoIfMinus1Retry "openFile" $ c_safe_open f oflags 0o666

    (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
                            False{-not a socket-}
                            non_blocking
            `catchAny` \e -> do _ <- c_close fd
                                throwIO e

    -- 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.
    when (iomode == WriteMode && fd_type == RegularFile) $
      setSize fD 0

{'fraction_non_alphanumeric': 0.14173228346456693, 'fraction_numerical': 0.013570112246607473, 'mean_word_length': 2.017947421638018, 'pattern_counts': {'":': 0, '<': 13, '<?xml version=': 0, '>': 33, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 8, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 1, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4982200', 'n_tokens_mistral': 3929, 'n_tokens_neox': 3748, 'n_words': 1209}