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) $
284 do let closer realFd =
285 throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
286 #ifdef mingw32_HOST_OS
287 if fdIsSocket fd then
288 c_closesocket (fromIntegral realFd)
291 c_close (fromIntegral realFd)
292 closeFdWith closer (fromIntegral (fdFD fd))
294 release :: FD -> IO ()
295 #ifdef mingw32_HOST_OS
296 release _ = return ()
298 release fd = do _ <- unlockFile (fdFD fd)
302 #ifdef mingw32_HOST_OS
303 foreign import stdcall unsafe "HsBase.h closesocket"
304 c_closesocket :: CInt -> IO CInt
307 isSeekable :: FD -> IO Bool
310 return (t == RegularFile || t == RawDevice)
312 seek :: FD -> SeekMode -> Integer -> IO ()
313 seek fd mode off = do
314 throwErrnoIfMinus1Retry_ "seek" $
315 c_lseek (fdFD fd) (fromIntegral off) seektype
318 seektype = case mode of
319 AbsoluteSeek -> sEEK_SET
320 RelativeSeek -> sEEK_CUR
321 SeekFromEnd -> sEEK_END
323 tell :: FD -> IO Integer
326 (throwErrnoIfMinus1Retry "hGetPosn" $
327 c_lseek (fdFD fd) 0 sEEK_CUR)
329 getSize :: FD -> IO Integer
330 getSize fd = fdFileSize (fdFD fd)
332 setSize :: FD -> Integer -> IO ()
334 throwErrnoIf_ (/=0) "GHC.IO.FD.setSize" $
335 c_ftruncate (fdFD fd) (fromIntegral size)
337 devType :: FD -> IO IODeviceType
338 devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
342 newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)
343 return fd{ fdFD = newfd }
345 dup2 :: FD -> FD -> IO FD
347 -- Windows' dup2 does not return the new descriptor, unlike Unix
348 throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $
349 c_dup2 (fdFD fd) (fdFD fdto)
350 return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
352 setNonBlockingMode :: FD -> Bool -> IO FD
353 setNonBlockingMode fd set = do
354 setNonBlockingFD (fdFD fd) set
355 #if defined(mingw32_HOST_OS)
358 return fd{ fdIsNonBlocking = fromEnum set }
361 ready :: FD -> Bool -> Int -> IO Bool
362 ready fd write msecs = do
363 r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $
364 fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)
366 #if defined(mingw32_HOST_OS)
367 (fromIntegral $ fromEnum $ fdIsSocket fd)
371 return (toEnum (fromIntegral r))
373 foreign import ccall safe "fdReady"
374 fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
376 -- ---------------------------------------------------------------------------
377 -- Terminal-related stuff
379 isTerminal :: FD -> IO Bool
381 #if defined(mingw32_HOST_OS)
382 is_console (fdFD fd) >>= return.toBool
384 c_isatty (fdFD fd) >>= return.toBool
387 setEcho :: FD -> Bool -> IO ()
388 setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
390 getEcho :: FD -> IO Bool
391 getEcho fd = System.Posix.Internals.getEcho (fdFD fd)
393 setRaw :: FD -> Bool -> IO ()
394 setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
396 -- -----------------------------------------------------------------------------
397 -- Reading and Writing
399 fdRead :: FD -> Ptr Word8 -> Int -> IO Int
401 = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
402 ; return (fromIntegral r) }
404 fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
405 fdReadNonBlocking fd ptr bytes = do
406 r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr
407 0 (fromIntegral bytes)
408 case fromIntegral r of
409 (-1) -> return (Nothing)
413 fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
414 fdWrite fd ptr bytes = do
415 res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
416 let res' = fromIntegral res
418 then fdWrite fd (ptr `plusPtr` res') (bytes - res')
421 -- XXX ToDo: this isn't non-blocking
422 fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int
423 fdWriteNonBlocking fd ptr bytes = do
424 res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0
426 return (fromIntegral res)
428 -- -----------------------------------------------------------------------------
431 -- Low level routines for reading/writing to (raw)buffers:
433 #ifndef mingw32_HOST_OS
438 Unix has broken semantics when it comes to non-blocking I/O: you can
439 set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
440 attached to the same underlying file, pipe or TTY; there's no way to
441 have private non-blocking behaviour for an FD. See bug #724.
443 We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
444 come from external sources or are exposed externally are left in
445 blocking mode. This solution has some problems though. We can't
446 completely simulate a non-blocking read without O_NONBLOCK: several
447 cases are wrong here. The cases that are wrong:
449 * reading/writing to a blocking FD in non-threaded mode.
450 In threaded mode, we just make a safe call to read().
451 In non-threaded mode we call select() before attempting to read,
452 but that leaves a small race window where the data can be read
453 from the file descriptor before we issue our blocking read().
454 * readRawBufferNoBlock for a blocking FD
458 In the threaded RTS we could just make safe calls to read()/write()
459 for file descriptors in blocking mode without worrying about blocking
460 other threads, but the problem with this is that the thread will be
461 uninterruptible while it is blocked in the foreign call. See #2363.
462 So now we always call fdReady() before reading, and if fdReady
463 indicates that there's no data, we call threadWaitRead.
467 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
468 readRawBufferPtr loc !fd buf off len
469 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
470 | otherwise = do r <- throwErrnoIfMinus1 loc
471 (unsafe_fdReady (fdFD fd) 0 0 0)
474 else do threadWaitRead (fromIntegral (fdFD fd)); read
476 do_read call = fromIntegral `fmap`
477 throwErrnoIfMinus1RetryMayBlock loc call
478 (threadWaitRead (fromIntegral (fdFD fd)))
479 read = if threaded then safe_read else unsafe_read
480 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
481 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
483 -- return: -1 indicates EOF, >=0 is bytes read
484 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
485 readRawBufferPtrNoBlock loc !fd buf off len
486 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
487 | otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0
488 if r /= 0 then safe_read
490 -- XXX see note [nonblock]
492 do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
496 n -> return (fromIntegral n)
497 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
498 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
500 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
501 writeRawBufferPtr loc !fd buf off len
502 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
503 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
506 else do threadWaitWrite (fromIntegral (fdFD fd)); write
508 do_write call = fromIntegral `fmap`
509 throwErrnoIfMinus1RetryMayBlock loc call
510 (threadWaitWrite (fromIntegral (fdFD fd)))
511 write = if threaded then safe_write else unsafe_write
512 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
513 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
515 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
516 writeRawBufferPtrNoBlock loc !fd buf off len
517 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
518 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
522 do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
525 n -> return (fromIntegral n)
526 write = if threaded then safe_write else unsafe_write
527 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
528 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
530 isNonBlocking :: FD -> Bool
531 isNonBlocking fd = fdIsNonBlocking fd /= 0
533 foreign import ccall unsafe "fdReady"
534 unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
536 #else /* mingw32_HOST_OS.... */
538 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
539 readRawBufferPtr loc !fd buf off len
540 | threaded = blockingReadRawBufferPtr loc fd buf off len
541 | otherwise = asyncReadRawBufferPtr loc fd buf off len
543 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
544 writeRawBufferPtr loc !fd buf off len
545 | threaded = blockingWriteRawBufferPtr loc fd buf off len
546 | otherwise = asyncWriteRawBufferPtr loc fd buf off len
548 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
549 readRawBufferPtrNoBlock = readRawBufferPtr
551 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
552 writeRawBufferPtrNoBlock = writeRawBufferPtr
554 -- Async versions of the read/write primitives, for the non-threaded RTS
556 asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
557 asyncReadRawBufferPtr loc !fd buf off len = do
558 (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
559 (fromIntegral len) (buf `plusPtr` off)
562 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
563 else return (fromIntegral l)
565 asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
566 asyncWriteRawBufferPtr loc !fd buf off len = do
567 (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
568 (fromIntegral len) (buf `plusPtr` off)
571 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
572 else return (fromIntegral l)
574 -- Blocking versions of the read/write primitives, for the threaded RTS
576 blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
577 blockingReadRawBufferPtr loc fd buf off len
578 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
580 then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0
581 else c_safe_read (fdFD fd) (buf `plusPtr` off) len
583 blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
584 blockingWriteRawBufferPtr loc fd buf off len
585 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
587 then c_safe_send (fdFD fd) (buf `plusPtr` off) len 0
589 r <- c_safe_write (fdFD fd) (buf `plusPtr` off) len
590 when (r == -1) c_maperrno
592 -- we don't trust write() to give us the correct errno, and
593 -- instead do the errno conversion from GetLastError()
594 -- ourselves. The main reason is that we treat ERROR_NO_DATA
595 -- (pipe is closing) as EPIPE, whereas write() returns EINVAL
596 -- for this case. We need to detect EPIPE correctly, because it
597 -- shouldn't be reported as an error when it happens on stdout.
599 foreign import ccall unsafe "maperrno" -- in Win32Utils.c
602 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
603 -- These calls may block, but that's ok.
605 foreign import stdcall safe "recv"
606 c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
608 foreign import stdcall safe "send"
609 c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
613 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
615 -- -----------------------------------------------------------------------------
618 #ifndef mingw32_HOST_OS
619 throwErrnoIfMinus1RetryOnBlock :: String -> IO CSsize -> IO CSsize -> IO CSsize
620 throwErrnoIfMinus1RetryOnBlock loc f on_block =
623 if (res :: CSsize) == -1
627 then throwErrnoIfMinus1RetryOnBlock loc f on_block
628 else if err == eWOULDBLOCK || err == eAGAIN
634 -- -----------------------------------------------------------------------------
637 #ifndef mingw32_HOST_OS
638 foreign import ccall unsafe "lockFile"
639 lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
641 foreign import ccall unsafe "unlockFile"
642 unlockFile :: CInt -> IO CInt
645 puts :: String -> IO ()
646 puts s = do _ <- withCStringLen s $ \(p,len) ->
647 c_write 1 (castPtr p) (fromIntegral len)