path: root/libraries/base/GHC/IO/FD.hs

{-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
-- |
-- 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(..),
  openFile, mkFD, release,
  setNonBlockingMode,
  readRawBufferPtr, readRawBufferPtrNoBlock, writeRawBufferPtr,
  stdin, stdout, stderr
  ) where

#undef DEBUG_DUMP

import GHC.Base
import GHC.Num
import GHC.Real
import GHC.Show
import GHC.Enum
import Data.Maybe
import Control.Monad
import Data.Typeable

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
import GHC.IO.Exception

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

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

data FD = FD {
  fdFD :: {-# UNPACK #-} !CInt,
#ifdef 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
 }
 deriving Typeable

#ifdef mingw32_HOST_OS
fdIsSocket :: FD -> Bool
fdIsSocket fd = fdIsSocket_ fd /= 0
#endif

instance Show FD where
  show fd = show (fdFD fd)

instance GHC.IO.Device.RawIO FD where
  read             = fdRead
  readNonBlocking  = fdReadNonBlocking
  write            = fdWrite
  writeNonBlocking = fdWriteNonBlocking

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

instance BufferedIO FD where
  newBuffer _dev state = newByteBuffer dEFAULT_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
#ifdef DEBUG_DUMP
  puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
#endif
  (r,buf') <- readBuf fd buf
#ifdef DEBUG_DUMP
  puts ("after: " ++ summaryBuffer buf' ++ "\n")
#endif
  return (r,buf')

writeBuf' :: FD -> Buffer Word8 -> IO ()
writeBuf' fd buf = do
#ifdef DEBUG_DUMP
  puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
#endif
  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`.  Puts the file descriptor
-- into non-blocking mode on Unix systems.
openFile :: FilePath -> IOMode -> IO (FD,IODeviceType)
openFile filepath iomode =
  withFilePath filepath $ \ f ->

    let 
      oflags1 = case iomode of
                  ReadMode      -> read_flags
#ifdef mingw32_HOST_OS
                  WriteMode     -> write_flags .|. o_TRUNC
#else
                  WriteMode     -> write_flags
#endif
                  ReadWriteMode -> rw_flags
                  AppendMode    -> append_flags

#ifdef mingw32_HOST_OS
      binary_flags = o_BINARY
#else
      binary_flags = 0
#endif      

      oflags = oflags1 .|. binary_flags
    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"
                (c_open f (fromIntegral oflags) 0o666)

    (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
                            False{-not a socket-} 
                            True{-is non-blocking-}
            `catchAny` \e -> do c_close fd; throwIO e

#ifndef mingw32_HOST_OS
        -- 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.
    if iomode == WriteMode && fd_type == RegularFile
      then setSize fD 0
      else return ()
#endif

    return (fD,fd_type)

std_flags, output_flags, read_flags, write_flags, rw_flags,
    append_flags :: CInt
std_flags    = o_NONBLOCK   .|. o_NOCTTY
output_flags = std_flags    .|. o_CREAT
read_flags   = std_flags    .|. o_RDONLY 
write_flags  = output_flags .|. o_WRONLY
rw_flags     = output_flags .|. o_RDWR
append_flags = write_flags  .|. o_APPEND


-- | 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 98 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 fd iomode mb_stat is_socket is_nonblock = do

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

    (fd_type,dev,ino) <- 
        case mb_stat of
          Nothing   -> fdStat fd
          Just stat -> return stat

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

#ifdef mingw32_HOST_OS
    setmode fd True -- unconditionally set binary mode
    let _ = (dev,ino,write) -- warning suppression
#endif

    case fd_type of
        Directory -> 
           ioException (IOError Nothing InappropriateType "openFile"
                           "is a directory" Nothing Nothing)

#ifndef mingw32_HOST_OS
        -- regular files need to be locked
        RegularFile -> do
           -- On Windows we use explicit exclusion via sopen() to implement
           -- this locking (see __hscore_open()); on Unix we have to
           -- implment it in the RTS.
           r <- lockFile fd dev ino (fromBool write)
           when (r == -1)  $
                ioException (IOError Nothing ResourceBusy "openFile"
                                   "file is locked" Nothing Nothing)
#endif

        _other_type -> return ()

    return (FD{ fdFD = fd,
#ifndef mingw32_HOST_OS
                fdIsNonBlocking = fromEnum is_nonblock
#else
                fdIsSocket_ = fromEnum is_socket
#endif
              },
            fd_type)

#ifdef mingw32_HOST_OS
foreign import ccall unsafe "__hscore_setmode"
  setmode :: CInt -> Bool -> IO CInt
#endif

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

stdFD :: CInt -> FD
stdFD fd = FD { fdFD = fd,
#ifdef mingw32_HOST_OS
                fdIsSocket_ = 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  = stdFD 0
stdout = stdFD 1
stderr = stdFD 2

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

close :: FD -> IO ()
close fd =
#ifndef mingw32_HOST_OS
  (flip finally) (release fd) $ do
#endif
  throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
#ifdef mingw32_HOST_OS
    if fdIsSocket fd then
       c_closesocket (fdFD fd)
    else
#endif
       c_close (fdFD fd)

release :: FD -> IO ()
release fd = do
#ifndef mingw32_HOST_OS
   unlockFile (fdFD fd)
#endif
   let _ = fd -- warning suppression
   return ()

#ifdef mingw32_HOST_OS
foreign import stdcall unsafe "HsBase.h closesocket"
   c_closesocket :: CInt -> IO CInt
#endif

isSeekable :: FD -> IO Bool
isSeekable fd = do
  t <- devType fd
  return (t == RegularFile || t == RawDevice)

seek :: FD -> SeekMode -> Integer -> IO ()
seek fd mode off = do
  throwErrnoIfMinus1Retry "seek" $
     c_lseek (fdFD fd) (fromIntegral off) seektype
  return ()
 where
    seektype :: CInt
    seektype = case mode of
                   AbsoluteSeek -> sEEK_SET
                   RelativeSeek -> sEEK_CUR
                   SeekFromEnd  -> sEEK_END

tell :: FD -> IO Integer
tell fd =
 fromIntegral `fmap`
   (throwErrnoIfMinus1Retry "hGetPosn" $
      c_lseek (fdFD fd) 0 sEEK_CUR)

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

setSize :: FD -> Integer -> IO () 
setSize fd size = do
  throwErrnoIf (/=0) "GHC.IO.FD.setSize"  $
     c_ftruncate (fdFD fd) (fromIntegral size)
  return ()

devType :: FD -> IO IODeviceType
devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty

dup :: FD -> IO FD
dup fd = do
  newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)
  return fd{ fdFD = newfd }

dup2 :: FD -> FD -> IO FD
dup2 fd fdto = do
  -- Windows' dup2 does not return the new descriptor, unlike Unix
  throwErrnoIfMinus1 "GHC.IO.FD.dup2" $ 
    c_dup2 (fdFD fd) (fdFD fdto)
  return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD

setNonBlockingMode :: FD -> Bool -> IO FD
setNonBlockingMode fd set = do 
  setNonBlockingFD (fdFD fd) set
#if defined(mingw32_HOST_OS)
  return fd
#else
  return fd{ fdIsNonBlocking = fromEnum set }
#endif

ready :: FD -> Bool -> Int -> IO Bool
ready fd write msecs = do
  r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $
          fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)
                            (fromIntegral msecs)
#if defined(mingw32_HOST_OS)
                          (fromIntegral $ fromEnum $ fdIsSocket fd)
#else
                          0
#endif
  return (toEnum (fromIntegral r))

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

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

isTerminal :: FD -> IO Bool
isTerminal fd = c_isatty (fdFD fd) >>= return.toBool

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

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

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

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

fdRead :: FD -> Ptr Word8 -> Int -> IO Int
fdRead fd ptr bytes = do
  r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
  return (fromIntegral r)

fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
fdReadNonBlocking fd ptr bytes = do
  r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr 
           0 (fromIntegral bytes)
  case r of
    (-1) -> return (Nothing)
    n    -> return (Just (fromIntegral n))


fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
fdWrite fd ptr bytes = do
  res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
  let res' = fromIntegral res
  if res' < bytes 
     then fdWrite fd (ptr `plusPtr` res') (bytes - res')
     else return ()

-- XXX ToDo: this isn't non-blocking
fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int
fdWriteNonBlocking fd ptr bytes = do
  res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0
            (fromIntegral bytes)
  return (fromIntegral res)

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

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

#ifndef 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
  | 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)

-- return: -1 indicates EOF, >=0 is bytes read
readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
readRawBufferPtrNoBlock loc !fd buf off len
  | 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)

writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtr loc !fd buf off len
  | 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)

writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtrNoBlock loc !fd buf off len
  | 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)

isNonBlocking :: FD -> Bool
isNonBlocking fd = fdIsNonBlocking fd /= 0

foreign import ccall unsafe "fdReady"
  unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt

#else /* mingw32_HOST_OS.... */

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

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

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

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

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

asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
asyncReadRawBufferPtr loc !fd buf off len = do
    (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd) 
                        (fromIntegral len) (buf `plusPtr` off)
    if l == (-1)
      then 
        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
      else return (fromIntegral l)

asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
asyncWriteRawBufferPtr loc !fd buf off len = do
    (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
                  (fromIntegral len) (buf `plusPtr` off)
    if l == (-1)
      then 
        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
      else return (fromIntegral l)

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

blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
blockingReadRawBufferPtr loc fd buf off len
  = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
        if fdIsSocket fd
           then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0
           else c_safe_read (fdFD fd) (buf `plusPtr` off) len

blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
blockingWriteRawBufferPtr loc fd buf off len 
  = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
        if fdIsSocket fd
           then c_safe_send  (fdFD fd) (buf `plusPtr` off) len 0
           else c_safe_write (fdFD fd) (buf `plusPtr` off) len

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

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

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

#endif

foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool

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

#ifndef mingw32_HOST_OS
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 do on_block
                 else throwErrno loc
      else return res
#endif

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

#ifndef mingw32_HOST_OS
foreign import ccall unsafe "lockFile"
  lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt

foreign import ccall unsafe "unlockFile"
  unlockFile :: CInt -> IO CInt
#endif

#if defined(DEBUG_DUMP)
puts :: String -> IO ()
puts s = do withCStringLen s $ \(p,len) -> c_write 1 p (fromIntegral len)
            return ()
#endif