{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP
, NoImplicitPrelude
, BangPatterns
, AutoDeriveTypeable
#-}
{-# OPTIONS_GHC -fno-warn-identities #-}
{-# OPTIONS_HADDOCK hide #-}
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 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.IO
import GHC.IO.Exception
#ifdef 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
#ifdef 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
data FD = FD {
fdFD :: {-# UNPACK #-} !CInt,
#ifdef mingw32_HOST_OS
fdIsSocket_ :: {-# UNPACK #-} !Int
#else
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
dEFAULT_FD_BUFFER_SIZE :: Int
dEFAULT_FD_BUFFER_SIZE = 8096
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
openFile
:: FilePath
-> IOMode
-> Bool
-> 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
#ifdef 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
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
False
non_blocking
`catchAny` \e -> do _ <- c_close fd
throwIO e
when (iomode == WriteMode && fd_type == RegularFile) $
setSize fD 0
return (fD,fd_type)
std_flags, output_flags, read_flags, write_flags, rw_flags,
append_flags, nonblock_flags :: CInt
std_flags = 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
nonblock_flags = o_NONBLOCK
mkFD :: CInt
-> IOMode
-> Maybe (IODeviceType, CDev, CIno)
-> Bool
-> Bool
-> IO (FD,IODeviceType)
mkFD fd iomode mb_stat is_socket is_nonblock = do
let _ = (is_socket, is_nonblock)
(fd_type,dev,ino) <-
case mb_stat of
Nothing -> fdStat fd
Just stat -> return stat
let write = case iomode of
ReadMode -> False
_ -> True
case fd_type of
Directory ->
ioException (IOError Nothing InappropriateType "openFile"
"is a directory" Nothing Nothing)
RegularFile -> do
(unique_dev, unique_ino) <- getUniqueFileInfo fd dev ino
r <- lockFile fd unique_dev unique_ino (fromBool write)
when (r == -1) $
ioException (IOError Nothing ResourceBusy "openFile"
"file is locked" Nothing Nothing)
_other_type -> return ()
#ifdef mingw32_HOST_OS
when (not is_socket) $ setmode fd True >> return ()
#endif
return (FD{ fdFD = fd,
#ifndef mingw32_HOST_OS
fdIsNonBlocking = fromEnum is_nonblock
#else
fdIsSocket_ = fromEnum is_socket
#endif
},
fd_type)
getUniqueFileInfo :: CInt -> CDev -> CIno -> IO (Word64, Word64)
#ifndef mingw32_HOST_OS
getUniqueFileInfo _ dev ino = return (fromIntegral dev, fromIntegral ino)
#else
getUniqueFileInfo fd _ _ = do
with 0 $ \devptr -> do
with 0 $ \inoptr -> do
c_getUniqueFileInfo fd devptr inoptr
liftM2 (,) (peek devptr) (peek inoptr)
#endif
#ifdef mingw32_HOST_OS
foreign import ccall unsafe "__hscore_setmode"
setmode :: CInt -> Bool -> IO CInt
#endif
stdFD :: CInt -> FD
stdFD fd = FD { fdFD = fd,
#ifdef mingw32_HOST_OS
fdIsSocket_ = 0
#else
fdIsNonBlocking = 0
#endif
}
stdin, stdout, stderr :: FD
stdin = stdFD 0
stdout = stdFD 1
stderr = stdFD 2
close :: FD -> IO ()
close fd =
do let closer realFd =
throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
#ifdef mingw32_HOST_OS
if fdIsSocket fd then
c_closesocket (fromIntegral realFd)
else
#endif
c_close (fromIntegral realFd)
release fd
closeFdWith closer (fromIntegral (fdFD fd))
release :: FD -> IO ()
release fd = do _ <- unlockFile (fdFD fd)
return ()
#ifdef mingw32_HOST_OS
foreign import WINDOWS_CCONV 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
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)
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
throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $
c_dup2 (fdFD fd) (fdFD fdto)
return fd{ fdFD = fdFD fdto }
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
isTerminal :: FD -> IO Bool
isTerminal fd =
#if defined(mingw32_HOST_OS)
if fdIsSocket fd then return False
else is_console (fdFD fd) >>= return.toBool
#else
c_isatty (fdFD fd) >>= return.toBool
#endif
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)
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 fromIntegral r of
(-1) -> return (Nothing)
n -> return (Just 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 ()
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)
#ifndef mingw32_HOST_OS
readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
readRawBufferPtr loc !fd buf off len
| isNonBlocking fd = unsafe_read
| 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)
readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
readRawBufferPtrNoBlock loc !fd buf off len
| isNonBlocking fd = unsafe_read
| otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0
if r /= 0 then safe_read
else return 0
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
| 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
| 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
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)
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 do
r <- c_safe_write (fdFD fd) (buf `plusPtr` off) len
when (r == -1) c_maperrno
return r
foreign import WINDOWS_CCONV safe "recv"
c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt -> IO CSsize
foreign import WINDOWS_CCONV safe "send"
c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt -> IO CSsize
#endif
foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
#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
foreign import ccall unsafe "lockFile"
lockFile :: CInt -> Word64 -> Word64 -> CInt -> IO CInt
foreign import ccall unsafe "unlockFile"
unlockFile :: CInt -> IO CInt
#ifdef mingw32_HOST_OS
foreign import ccall unsafe "get_unique_file_info"
c_getUniqueFileInfo :: CInt -> Ptr Word64 -> Ptr Word64 -> IO ()
#endif