1 {-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns -fno-warn-identities #-}
2 -- Whether there are identities depends on the platform
3 {-# OPTIONS_HADDOCK hide #-}
4 -----------------------------------------------------------------------------
7 -- Copyright : (c) The University of Glasgow, 1994-2008
8 -- License : see libraries/base/LICENSE
10 -- Maintainer : libraries@haskell.org
11 -- Stability : internal
12 -- Portability : non-portable
14 -- Raw read/write operations on file descriptors
16 -----------------------------------------------------------------------------
20 openFile, mkFD, release,
22 readRawBufferPtr, readRawBufferPtrNoBlock, writeRawBufferPtr,
38 import GHC.IO.BufferedIO
39 import qualified GHC.IO.Device
40 import GHC.IO.Device (SeekMode(..), IODeviceType(..))
42 import GHC.IO.Exception
46 import qualified System.Posix.Internals
47 import System.Posix.Internals hiding (FD, setEcho, getEcho)
48 import System.Posix.Types
54 -- -----------------------------------------------------------------------------
55 -- The file-descriptor IO device
58 fdFD :: {-# UNPACK #-} !CInt,
59 #ifdef mingw32_HOST_OS
60 -- On Windows, a socket file descriptor needs to be read and written
61 -- using different functions (send/recv).
62 fdIsSocket_ :: {-# UNPACK #-} !Int
64 -- On Unix we need to know whether this FD has O_NONBLOCK set.
65 -- If it has, then we can use more efficient routines to read/write to it.
66 -- It is always safe for this to be off.
67 fdIsNonBlocking :: {-# UNPACK #-} !Int
72 #ifdef mingw32_HOST_OS
73 fdIsSocket :: FD -> Bool
74 fdIsSocket fd = fdIsSocket_ fd /= 0
77 instance Show FD where
78 show fd = show (fdFD fd)
80 instance GHC.IO.Device.RawIO FD where
82 readNonBlocking = fdReadNonBlocking
84 writeNonBlocking = fdWriteNonBlocking
86 instance GHC.IO.Device.IODevice FD where
89 isTerminal = isTerminal
90 isSeekable = isSeekable
102 instance BufferedIO FD where
103 newBuffer _dev state = newByteBuffer dEFAULT_BUFFER_SIZE state
104 fillReadBuffer fd buf = readBuf' fd buf
105 fillReadBuffer0 fd buf = readBufNonBlocking fd buf
106 flushWriteBuffer fd buf = writeBuf' fd buf
107 flushWriteBuffer0 fd buf = writeBufNonBlocking fd buf
109 readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
112 puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
113 (r,buf') <- readBuf fd buf
115 puts ("after: " ++ summaryBuffer buf' ++ "\n")
118 writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
119 writeBuf' fd buf = do
121 puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
124 -- -----------------------------------------------------------------------------
127 -- | Open a file and make an 'FD' for it. Truncates the file to zero
128 -- size when the `IOMode` is `WriteMode`. Puts the file descriptor
129 -- into non-blocking mode on Unix systems.
130 openFile :: FilePath -> IOMode -> IO (FD,IODeviceType)
131 openFile filepath iomode =
132 withFilePath filepath $ \ f ->
135 oflags1 = case iomode of
136 ReadMode -> read_flags
137 #ifdef mingw32_HOST_OS
138 WriteMode -> write_flags .|. o_TRUNC
140 WriteMode -> write_flags
142 ReadWriteMode -> rw_flags
143 AppendMode -> append_flags
145 #ifdef mingw32_HOST_OS
146 binary_flags = o_BINARY
151 oflags = oflags1 .|. binary_flags
154 -- the old implementation had a complicated series of three opens,
155 -- which is perhaps because we have to be careful not to open
156 -- directories. However, the man pages I've read say that open()
157 -- always returns EISDIR if the file is a directory and was opened
158 -- for writing, so I think we're ok with a single open() here...
159 fd <- throwErrnoIfMinus1Retry "openFile"
160 (c_open f oflags 0o666)
162 (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
163 False{-not a socket-}
164 True{-is non-blocking-}
165 `catchAny` \e -> do _ <- c_close fd
168 #ifndef mingw32_HOST_OS
169 -- we want to truncate() if this is an open in WriteMode, but only
170 -- if the target is a RegularFile. ftruncate() fails on special files
172 if iomode == WriteMode && fd_type == RegularFile
179 std_flags, output_flags, read_flags, write_flags, rw_flags,
181 std_flags = o_NONBLOCK .|. o_NOCTTY
182 output_flags = std_flags .|. o_CREAT
183 read_flags = std_flags .|. o_RDONLY
184 write_flags = output_flags .|. o_WRONLY
185 rw_flags = output_flags .|. o_RDWR
186 append_flags = write_flags .|. o_APPEND
189 -- | Make a 'FD' from an existing file descriptor. Fails if the FD
190 -- refers to a directory. If the FD refers to a file, `mkFD` locks
191 -- the file according to the Haskell 98 single writer/multiple reader
192 -- locking semantics (this is why we need the `IOMode` argument too).
195 -> Maybe (IODeviceType, CDev, CIno)
196 -- the results of fdStat if we already know them, or we want
197 -- to prevent fdToHandle_stat from doing its own stat.
198 -- These are used for:
199 -- - we fail if the FD refers to a directory
200 -- - if the FD refers to a file, we lock it using (cdev,cino)
201 -> Bool -- ^ is a socket (on Windows)
202 -> Bool -- ^ is in non-blocking mode on Unix
203 -> IO (FD,IODeviceType)
205 mkFD fd iomode mb_stat is_socket is_nonblock = do
207 let _ = (is_socket, is_nonblock) -- warning suppression
212 Just stat -> return stat
214 let write = case iomode of
218 #ifdef mingw32_HOST_OS
219 _ <- setmode fd True -- unconditionally set binary mode
220 let _ = (dev,ino,write) -- warning suppression
225 ioException (IOError Nothing InappropriateType "openFile"
226 "is a directory" Nothing Nothing)
228 #ifndef mingw32_HOST_OS
229 -- regular files need to be locked
231 -- On Windows we use explicit exclusion via sopen() to implement
232 -- this locking (see __hscore_open()); on Unix we have to
233 -- implment it in the RTS.
234 r <- lockFile fd dev ino (fromBool write)
236 ioException (IOError Nothing ResourceBusy "openFile"
237 "file is locked" Nothing Nothing)
240 _other_type -> return ()
242 return (FD{ fdFD = fd,
243 #ifndef mingw32_HOST_OS
244 fdIsNonBlocking = fromEnum is_nonblock
246 fdIsSocket_ = fromEnum is_socket
251 #ifdef mingw32_HOST_OS
252 foreign import ccall unsafe "__hscore_setmode"
253 setmode :: CInt -> Bool -> IO CInt
256 -- -----------------------------------------------------------------------------
257 -- Standard file descriptors
260 stdFD fd = FD { fdFD = fd,
261 #ifdef mingw32_HOST_OS
265 -- We don't set non-blocking mode on standard handles, because it may
266 -- confuse other applications attached to the same TTY/pipe
267 -- see Note [nonblock]
271 stdin, stdout, stderr :: FD
276 -- -----------------------------------------------------------------------------
277 -- Operations on file descriptors
281 #ifndef mingw32_HOST_OS
282 (flip finally) (release fd) $ do
284 throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
285 #ifdef mingw32_HOST_OS
286 if fdIsSocket fd then
287 c_closesocket (fdFD fd)
292 release :: FD -> IO ()
293 #ifdef mingw32_HOST_OS
294 release _ = return ()
296 release fd = do _ <- unlockFile (fdFD fd)
300 #ifdef mingw32_HOST_OS
301 foreign import stdcall unsafe "HsBase.h closesocket"
302 c_closesocket :: CInt -> IO CInt
305 isSeekable :: FD -> IO Bool
308 return (t == RegularFile || t == RawDevice)
310 seek :: FD -> SeekMode -> Integer -> IO ()
311 seek fd mode off = do
312 throwErrnoIfMinus1Retry_ "seek" $
313 c_lseek (fdFD fd) (fromIntegral off) seektype
316 seektype = case mode of
317 AbsoluteSeek -> sEEK_SET
318 RelativeSeek -> sEEK_CUR
319 SeekFromEnd -> sEEK_END
321 tell :: FD -> IO Integer
324 (throwErrnoIfMinus1Retry "hGetPosn" $
325 c_lseek (fdFD fd) 0 sEEK_CUR)
327 getSize :: FD -> IO Integer
328 getSize fd = fdFileSize (fdFD fd)
330 setSize :: FD -> Integer -> IO ()
332 throwErrnoIf_ (/=0) "GHC.IO.FD.setSize" $
333 c_ftruncate (fdFD fd) (fromIntegral size)
335 devType :: FD -> IO IODeviceType
336 devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
340 newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)
341 return fd{ fdFD = newfd }
343 dup2 :: FD -> FD -> IO FD
345 -- Windows' dup2 does not return the new descriptor, unlike Unix
346 throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $
347 c_dup2 (fdFD fd) (fdFD fdto)
348 return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
350 setNonBlockingMode :: FD -> Bool -> IO FD
351 setNonBlockingMode fd set = do
352 setNonBlockingFD (fdFD fd) set
353 #if defined(mingw32_HOST_OS)
356 return fd{ fdIsNonBlocking = fromEnum set }
359 ready :: FD -> Bool -> Int -> IO Bool
360 ready fd write msecs = do
361 r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $
362 fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)
364 #if defined(mingw32_HOST_OS)
365 (fromIntegral $ fromEnum $ fdIsSocket fd)
369 return (toEnum (fromIntegral r))
371 foreign import ccall safe "fdReady"
372 fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
374 -- ---------------------------------------------------------------------------
375 -- Terminal-related stuff
377 isTerminal :: FD -> IO Bool
379 #if defined(mingw32_HOST_OS)
380 is_console (fdFD fd) >>= return.toBool
382 c_isatty (fdFD fd) >>= return.toBool
385 setEcho :: FD -> Bool -> IO ()
386 setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
388 getEcho :: FD -> IO Bool
389 getEcho fd = System.Posix.Internals.getEcho (fdFD fd)
391 setRaw :: FD -> Bool -> IO ()
392 setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
394 -- -----------------------------------------------------------------------------
395 -- Reading and Writing
397 fdRead :: FD -> Ptr Word8 -> Int -> IO Int
399 = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
400 ; return (fromIntegral r) }
402 fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
403 fdReadNonBlocking fd ptr bytes = do
404 r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr
405 0 (fromIntegral bytes)
406 case fromIntegral r of
407 (-1) -> return (Nothing)
411 fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
412 fdWrite fd ptr bytes = do
413 res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
414 let res' = fromIntegral res
416 then fdWrite fd (ptr `plusPtr` res') (bytes - res')
419 -- XXX ToDo: this isn't non-blocking
420 fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int
421 fdWriteNonBlocking fd ptr bytes = do
422 res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0
424 return (fromIntegral res)
426 -- -----------------------------------------------------------------------------
429 -- Low level routines for reading/writing to (raw)buffers:
431 #ifndef mingw32_HOST_OS
436 Unix has broken semantics when it comes to non-blocking I/O: you can
437 set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
438 attached to the same underlying file, pipe or TTY; there's no way to
439 have private non-blocking behaviour for an FD. See bug #724.
441 We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
442 come from external sources or are exposed externally are left in
443 blocking mode. This solution has some problems though. We can't
444 completely simulate a non-blocking read without O_NONBLOCK: several
445 cases are wrong here. The cases that are wrong:
447 * reading/writing to a blocking FD in non-threaded mode.
448 In threaded mode, we just make a safe call to read().
449 In non-threaded mode we call select() before attempting to read,
450 but that leaves a small race window where the data can be read
451 from the file descriptor before we issue our blocking read().
452 * readRawBufferNoBlock for a blocking FD
456 In the threaded RTS we could just make safe calls to read()/write()
457 for file descriptors in blocking mode without worrying about blocking
458 other threads, but the problem with this is that the thread will be
459 uninterruptible while it is blocked in the foreign call. See #2363.
460 So now we always call fdReady() before reading, and if fdReady
461 indicates that there's no data, we call threadWaitRead.
465 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
466 readRawBufferPtr loc !fd buf off len
467 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
468 | otherwise = do r <- throwErrnoIfMinus1 loc
469 (unsafe_fdReady (fdFD fd) 0 0 0)
472 else do threadWaitRead (fromIntegral (fdFD fd)); read
474 do_read call = fromIntegral `fmap`
475 throwErrnoIfMinus1RetryMayBlock loc call
476 (threadWaitRead (fromIntegral (fdFD fd)))
477 read = if threaded then safe_read else unsafe_read
478 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
479 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
481 -- return: -1 indicates EOF, >=0 is bytes read
482 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
483 readRawBufferPtrNoBlock loc !fd buf off len
484 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
485 | otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0
486 if r /= 0 then safe_read
488 -- XXX see note [nonblock]
490 do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
494 n -> return (fromIntegral n)
495 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
496 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
498 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
499 writeRawBufferPtr loc !fd buf off len
500 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
501 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
504 else do threadWaitWrite (fromIntegral (fdFD fd)); write
506 do_write call = fromIntegral `fmap`
507 throwErrnoIfMinus1RetryMayBlock loc call
508 (threadWaitWrite (fromIntegral (fdFD fd)))
509 write = if threaded then safe_write else unsafe_write
510 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
511 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
513 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
514 writeRawBufferPtrNoBlock loc !fd buf off len
515 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
516 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
520 do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
523 n -> return (fromIntegral n)
524 write = if threaded then safe_write else unsafe_write
525 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
526 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
528 isNonBlocking :: FD -> Bool
529 isNonBlocking fd = fdIsNonBlocking fd /= 0
531 foreign import ccall unsafe "fdReady"
532 unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
534 #else /* mingw32_HOST_OS.... */
536 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
537 readRawBufferPtr loc !fd buf off len
538 | threaded = blockingReadRawBufferPtr loc fd buf off len
539 | otherwise = asyncReadRawBufferPtr loc fd buf off len
541 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
542 writeRawBufferPtr loc !fd buf off len
543 | threaded = blockingWriteRawBufferPtr loc fd buf off len
544 | otherwise = asyncWriteRawBufferPtr loc fd buf off len
546 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
547 readRawBufferPtrNoBlock = readRawBufferPtr
549 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
550 writeRawBufferPtrNoBlock = writeRawBufferPtr
552 -- Async versions of the read/write primitives, for the non-threaded RTS
554 asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
555 asyncReadRawBufferPtr loc !fd buf off len = do
556 (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
557 (fromIntegral len) (buf `plusPtr` off)
560 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
561 else return (fromIntegral l)
563 asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
564 asyncWriteRawBufferPtr loc !fd buf off len = do
565 (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
566 (fromIntegral len) (buf `plusPtr` off)
569 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
570 else return (fromIntegral l)
572 -- Blocking versions of the read/write primitives, for the threaded RTS
574 blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
575 blockingReadRawBufferPtr loc fd buf off len
576 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
578 then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0
579 else c_safe_read (fdFD fd) (buf `plusPtr` off) len
581 blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
582 blockingWriteRawBufferPtr loc fd buf off len
583 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
585 then c_safe_send (fdFD fd) (buf `plusPtr` off) len 0
587 r <- c_safe_write (fdFD fd) (buf `plusPtr` off) len
588 when (r == -1) c_maperrno
590 -- we don't trust write() to give us the correct errno, and
591 -- instead do the errno conversion from GetLastError()
592 -- ourselves. The main reason is that we treat ERROR_NO_DATA
593 -- (pipe is closing) as EPIPE, whereas write() returns EINVAL
594 -- for this case. We need to detect EPIPE correctly, because it
595 -- shouldn't be reported as an error when it happens on stdout.
597 foreign import ccall unsafe "maperrno" -- in Win32Utils.c
600 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
601 -- These calls may block, but that's ok.
603 foreign import stdcall safe "recv"
604 c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
606 foreign import stdcall safe "send"
607 c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
611 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
613 -- -----------------------------------------------------------------------------
616 #ifndef mingw32_HOST_OS
617 throwErrnoIfMinus1RetryOnBlock :: String -> IO CSsize -> IO CSsize -> IO CSsize
618 throwErrnoIfMinus1RetryOnBlock loc f on_block =
621 if (res :: CSsize) == -1
625 then throwErrnoIfMinus1RetryOnBlock loc f on_block
626 else if err == eWOULDBLOCK || err == eAGAIN
632 -- -----------------------------------------------------------------------------
635 #ifndef mingw32_HOST_OS
636 foreign import ccall unsafe "lockFile"
637 lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
639 foreign import ccall unsafe "unlockFile"
640 unlockFile :: CInt -> IO CInt
643 puts :: String -> IO ()
644 puts s = do _ <- withCStringLen s $ \(p,len) ->
645 c_write 1 (castPtr p) (fromIntegral len)