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
import Data.Bool
#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
clampWriteSize, clampReadSize :: Int -> Int
clampWriteSize = min 0x7ffff000
clampReadSize = min 0x7ffff000
data FD = FD {
fdFD :: !CInt,
#if defined(mingw32_HOST_OS)
fdIsSocket_ :: !Int
#else
fdIsNonBlocking :: !Int
#endif
}
#if defined(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 = 8192
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
#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
fd <- throwErrnoIfMinus1Retry "openFile" $ 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 ()
#if defined(mingw32_HOST_OS)
when (not is_socket) $ setmode fd True >> return ()
#endif
return (FD{ fdFD = fd,
#if !defined(mingw32_HOST_OS)
fdIsNonBlocking = fromEnum is_nonblock
#else
fdIsSocket_ = fromEnum is_socket
#endif
},
fd_type)
getUniqueFileInfo :: CInt -> CDev -> CIno -> IO (Word64, Word64)
#if !defined(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
#if defined(mingw32_HOST_OS)
foreign import ccall unsafe "__hscore_setmode"
setmode :: CInt -> Bool -> IO CInt
#endif
stdFD :: CInt -> FD
stdFD fd = FD { fdFD = fd,
#if defined(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" $
#if defined(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 ()
#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 = 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 -> CBool -> Int64 -> CBool -> 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 $ clampReadSize 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 $ clampReadSize 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 $ clampWriteSize 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 $ clampWriteSize bytes)
return (fromIntegral res)
#if !defined(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 -> CBool -> Int64 -> CBool -> 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 let sock_errno = c_maperrno_func (fromIntegral rc)
non_sock_errno = Errno (fromIntegral rc)
errno = bool non_sock_errno sock_errno (fdIsSocket fd)
in ioError (errnoToIOError loc errno 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 let sock_errno = c_maperrno_func (fromIntegral rc)
non_sock_errno = Errno (fromIntegral rc)
errno = bool non_sock_errno sock_errno (fdIsSocket fd)
in ioError (errnoToIOError loc errno Nothing Nothing)
else return (fromIntegral l)
blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
blockingReadRawBufferPtr loc !fd !buf !off !len
= throwErrnoIfMinus1Retry loc $ do
let start_ptr = buf `plusPtr` off
recv_ret = c_safe_recv (fdFD fd) start_ptr (fromIntegral len) 0
read_ret = c_safe_read (fdFD fd) start_ptr (fromIntegral len)
r <- bool read_ret recv_ret (fdIsSocket fd)
when ((fdIsSocket fd) && (r == 1)) c_maperrno
return r
blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
blockingWriteRawBufferPtr loc !fd !buf !off !len
= throwErrnoIfMinus1Retry loc $ do
let start_ptr = buf `plusPtr` off
send_ret = c_safe_send (fdFD fd) start_ptr (fromIntegral len) 0
write_ret = c_safe_write (fdFD fd) start_ptr (fromIntegral len)
r <- bool write_ret send_ret (fdIsSocket fd)
when (r == 1) c_maperrno
return r
foreign import WINDOWS_CCONV safe "recv"
c_safe_recv :: CInt -> Ptr Word8 -> CInt -> CInt -> IO CInt
foreign import WINDOWS_CCONV safe "send"
c_safe_send :: CInt -> Ptr Word8 -> CInt -> CInt -> IO CInt
#endif
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
#if !defined(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
#if defined(mingw32_HOST_OS)
foreign import ccall unsafe "get_unique_file_info"
c_getUniqueFileInfo :: CInt -> Ptr Word64 -> Ptr Word64 -> IO ()
#endif