{-# 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 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 c_DEBUG_DUMP :: Bool c_DEBUG_DUMP = False -- ----------------------------------------------------------------------------- -- 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 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`. 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 () #ifdef mingw32_HOST_OS release _ = return () #else release fd = do _ <- unlockFile (fdFD fd) return () #endif #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 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 -- 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 fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt fdReady _ _ _ _ = return 1 -- --------------------------------------------------------------------------- -- 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 unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt unsafe_fdReady _ _ _ _ = return 1 #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 threaded :: Bool threaded = False -- ----------------------------------------------------------------------------- -- 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 puts :: String -> IO () puts s = do _ <- withCStringLen s $ \(p,len) -> c_write 1 (castPtr p) (fromIntegral len) return ()