1 {-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-}
2 {-# OPTIONS_HADDOCK hide #-}
3 -----------------------------------------------------------------------------
6 -- Copyright : (c) The University of Glasgow, 1994-2008
7 -- License : see libraries/base/LICENSE
9 -- Maintainer : libraries@haskell.org
10 -- Stability : internal
11 -- Portability : non-portable
13 -- Raw read/write operations on file descriptors
15 -----------------------------------------------------------------------------
19 openFile, mkFD, release,
21 readRawBufferPtr, readRawBufferPtrNoBlock, writeRawBufferPtr,
37 import GHC.IO.BufferedIO
38 import qualified GHC.IO.Device
39 import GHC.IO.Device (SeekMode(..), IODeviceType(..))
41 import GHC.IO.Exception
45 import qualified System.Posix.Internals
46 import System.Posix.Internals hiding (FD, setEcho, getEcho)
47 import System.Posix.Types
53 -- -----------------------------------------------------------------------------
54 -- The file-descriptor IO device
57 fdFD :: {-# UNPACK #-} !CInt,
58 #ifdef mingw32_HOST_OS
59 -- On Windows, a socket file descriptor needs to be read and written
60 -- using different functions (send/recv).
61 fdIsSocket_ :: {-# UNPACK #-} !Int
63 -- On Unix we need to know whether this FD has O_NONBLOCK set.
64 -- If it has, then we can use more efficient routines to read/write to it.
65 -- It is always safe for this to be off.
66 fdIsNonBlocking :: {-# UNPACK #-} !Int
71 #ifdef mingw32_HOST_OS
72 fdIsSocket :: FD -> Bool
73 fdIsSocket fd = fdIsSocket_ fd /= 0
76 instance Show FD where
77 show fd = show (fdFD fd)
79 instance GHC.IO.Device.RawIO FD where
81 readNonBlocking = fdReadNonBlocking
83 writeNonBlocking = fdWriteNonBlocking
85 instance GHC.IO.Device.IODevice FD where
88 isTerminal = isTerminal
89 isSeekable = isSeekable
101 instance BufferedIO FD where
102 newBuffer _dev state = newByteBuffer dEFAULT_BUFFER_SIZE state
103 fillReadBuffer fd buf = readBuf' fd buf
104 fillReadBuffer0 fd buf = readBufNonBlocking fd buf
105 flushWriteBuffer fd buf = writeBuf' fd buf
106 flushWriteBuffer0 fd buf = writeBufNonBlocking fd buf
108 readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
111 puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
112 (r,buf') <- readBuf fd buf
114 puts ("after: " ++ summaryBuffer buf' ++ "\n")
117 writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
118 writeBuf' fd buf = do
120 puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
123 -- -----------------------------------------------------------------------------
126 -- | Open a file and make an 'FD' for it. Truncates the file to zero
127 -- size when the `IOMode` is `WriteMode`. Puts the file descriptor
128 -- into non-blocking mode on Unix systems.
129 openFile :: FilePath -> IOMode -> IO (FD,IODeviceType)
130 openFile filepath iomode =
131 withFilePath filepath $ \ f ->
134 oflags1 = case iomode of
135 ReadMode -> read_flags
136 #ifdef mingw32_HOST_OS
137 WriteMode -> write_flags .|. o_TRUNC
139 WriteMode -> write_flags
141 ReadWriteMode -> rw_flags
142 AppendMode -> append_flags
144 #ifdef mingw32_HOST_OS
145 binary_flags = o_BINARY
150 oflags = oflags1 .|. binary_flags
153 -- the old implementation had a complicated series of three opens,
154 -- which is perhaps because we have to be careful not to open
155 -- directories. However, the man pages I've read say that open()
156 -- always returns EISDIR if the file is a directory and was opened
157 -- for writing, so I think we're ok with a single open() here...
158 fd <- throwErrnoIfMinus1Retry "openFile"
159 (c_open f oflags 0o666)
161 (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
162 False{-not a socket-}
163 True{-is non-blocking-}
164 `catchAny` \e -> do _ <- c_close fd
167 #ifndef mingw32_HOST_OS
168 -- we want to truncate() if this is an open in WriteMode, but only
169 -- if the target is a RegularFile. ftruncate() fails on special files
171 if iomode == WriteMode && fd_type == RegularFile
178 std_flags, output_flags, read_flags, write_flags, rw_flags,
180 std_flags = o_NONBLOCK .|. o_NOCTTY
181 output_flags = std_flags .|. o_CREAT
182 read_flags = std_flags .|. o_RDONLY
183 write_flags = output_flags .|. o_WRONLY
184 rw_flags = output_flags .|. o_RDWR
185 append_flags = write_flags .|. o_APPEND
188 -- | Make a 'FD' from an existing file descriptor. Fails if the FD
189 -- refers to a directory. If the FD refers to a file, `mkFD` locks
190 -- the file according to the Haskell 98 single writer/multiple reader
191 -- locking semantics (this is why we need the `IOMode` argument too).
194 -> Maybe (IODeviceType, CDev, CIno)
195 -- the results of fdStat if we already know them, or we want
196 -- to prevent fdToHandle_stat from doing its own stat.
197 -- These are used for:
198 -- - we fail if the FD refers to a directory
199 -- - if the FD refers to a file, we lock it using (cdev,cino)
200 -> Bool -- ^ is a socket (on Windows)
201 -> Bool -- ^ is in non-blocking mode on Unix
202 -> IO (FD,IODeviceType)
204 mkFD fd iomode mb_stat is_socket is_nonblock = do
206 let _ = (is_socket, is_nonblock) -- warning suppression
211 Just stat -> return stat
213 let write = case iomode of
217 #ifdef mingw32_HOST_OS
218 _ <- setmode fd True -- unconditionally set binary mode
219 let _ = (dev,ino,write) -- warning suppression
224 ioException (IOError Nothing InappropriateType "openFile"
225 "is a directory" Nothing Nothing)
227 #ifndef mingw32_HOST_OS
228 -- regular files need to be locked
230 -- On Windows we use explicit exclusion via sopen() to implement
231 -- this locking (see __hscore_open()); on Unix we have to
232 -- implment it in the RTS.
233 r <- lockFile fd dev ino (fromBool write)
235 ioException (IOError Nothing ResourceBusy "openFile"
236 "file is locked" Nothing Nothing)
239 _other_type -> return ()
241 return (FD{ fdFD = fd,
242 #ifndef mingw32_HOST_OS
243 fdIsNonBlocking = fromEnum is_nonblock
245 fdIsSocket_ = fromEnum is_socket
250 #ifdef mingw32_HOST_OS
251 foreign import ccall unsafe "__hscore_setmode"
252 setmode :: CInt -> Bool -> IO CInt
255 -- -----------------------------------------------------------------------------
256 -- Standard file descriptors
259 stdFD fd = FD { fdFD = fd,
260 #ifdef mingw32_HOST_OS
264 -- We don't set non-blocking mode on standard handles, because it may
265 -- confuse other applications attached to the same TTY/pipe
266 -- see Note [nonblock]
270 stdin, stdout, stderr :: FD
275 -- -----------------------------------------------------------------------------
276 -- Operations on file descriptors
280 #ifndef mingw32_HOST_OS
281 (flip finally) (release fd) $ do
283 throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
284 #ifdef mingw32_HOST_OS
285 if fdIsSocket fd then
286 c_closesocket (fdFD fd)
291 release :: FD -> IO ()
292 #ifdef mingw32_HOST_OS
293 release _ = return ()
295 release fd = do _ <- unlockFile (fdFD fd)
299 #ifdef mingw32_HOST_OS
300 foreign import stdcall unsafe "HsBase.h closesocket"
301 c_closesocket :: CInt -> IO CInt
304 isSeekable :: FD -> IO Bool
307 return (t == RegularFile || t == RawDevice)
309 seek :: FD -> SeekMode -> Integer -> IO ()
310 seek fd mode off = do
311 throwErrnoIfMinus1Retry_ "seek" $
312 c_lseek (fdFD fd) (fromIntegral off) seektype
315 seektype = case mode of
316 AbsoluteSeek -> sEEK_SET
317 RelativeSeek -> sEEK_CUR
318 SeekFromEnd -> sEEK_END
320 tell :: FD -> IO Integer
323 (throwErrnoIfMinus1Retry "hGetPosn" $
324 c_lseek (fdFD fd) 0 sEEK_CUR)
326 getSize :: FD -> IO Integer
327 getSize fd = fdFileSize (fdFD fd)
329 setSize :: FD -> Integer -> IO ()
331 throwErrnoIf_ (/=0) "GHC.IO.FD.setSize" $
332 c_ftruncate (fdFD fd) (fromIntegral size)
334 devType :: FD -> IO IODeviceType
335 devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
339 newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)
340 return fd{ fdFD = newfd }
342 dup2 :: FD -> FD -> IO FD
344 -- Windows' dup2 does not return the new descriptor, unlike Unix
345 throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $
346 c_dup2 (fdFD fd) (fdFD fdto)
347 return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
349 setNonBlockingMode :: FD -> Bool -> IO FD
350 setNonBlockingMode fd set = do
351 setNonBlockingFD (fdFD fd) set
352 #if defined(mingw32_HOST_OS)
355 return fd{ fdIsNonBlocking = fromEnum set }
358 ready :: FD -> Bool -> Int -> IO Bool
359 ready fd write msecs = do
360 r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $
361 fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)
363 #if defined(mingw32_HOST_OS)
364 (fromIntegral $ fromEnum $ fdIsSocket fd)
368 return (toEnum (fromIntegral r))
370 foreign import ccall safe "fdReady"
371 fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
373 -- ---------------------------------------------------------------------------
374 -- Terminal-related stuff
376 isTerminal :: FD -> IO Bool
378 #if defined(mingw32_HOST_OS)
379 is_console (fdFD fd) >>= return.toBool
381 c_isatty (fdFD fd) >>= return.toBool
384 setEcho :: FD -> Bool -> IO ()
385 setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
387 getEcho :: FD -> IO Bool
388 getEcho fd = System.Posix.Internals.getEcho (fdFD fd)
390 setRaw :: FD -> Bool -> IO ()
391 setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
393 -- -----------------------------------------------------------------------------
394 -- Reading and Writing
396 fdRead :: FD -> Ptr Word8 -> Int -> IO Int
398 = readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
400 fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
401 fdReadNonBlocking fd ptr bytes = do
402 r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr
403 0 (fromIntegral bytes)
405 (-1) -> return (Nothing)
409 fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
410 fdWrite fd ptr bytes = do
411 res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
412 let res' = fromIntegral res
414 then fdWrite fd (ptr `plusPtr` res') (bytes - res')
417 -- XXX ToDo: this isn't non-blocking
418 fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int
419 fdWriteNonBlocking fd ptr bytes = do
420 res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0
422 return (fromIntegral res)
424 -- -----------------------------------------------------------------------------
427 -- Low level routines for reading/writing to (raw)buffers:
429 #ifndef mingw32_HOST_OS
434 Unix has broken semantics when it comes to non-blocking I/O: you can
435 set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
436 attached to the same underlying file, pipe or TTY; there's no way to
437 have private non-blocking behaviour for an FD. See bug #724.
439 We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
440 come from external sources or are exposed externally are left in
441 blocking mode. This solution has some problems though. We can't
442 completely simulate a non-blocking read without O_NONBLOCK: several
443 cases are wrong here. The cases that are wrong:
445 * reading/writing to a blocking FD in non-threaded mode.
446 In threaded mode, we just make a safe call to read().
447 In non-threaded mode we call select() before attempting to read,
448 but that leaves a small race window where the data can be read
449 from the file descriptor before we issue our blocking read().
450 * readRawBufferNoBlock for a blocking FD
454 In the threaded RTS we could just make safe calls to read()/write()
455 for file descriptors in blocking mode without worrying about blocking
456 other threads, but the problem with this is that the thread will be
457 uninterruptible while it is blocked in the foreign call. See #2363.
458 So now we always call fdReady() before reading, and if fdReady
459 indicates that there's no data, we call threadWaitRead.
463 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
464 readRawBufferPtr loc !fd buf off len
465 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
466 | otherwise = do r <- throwErrnoIfMinus1 loc
467 (unsafe_fdReady (fdFD fd) 0 0 0)
470 else do threadWaitRead (fromIntegral (fdFD fd)); read
472 do_read call = fromIntegral `fmap`
473 throwErrnoIfMinus1RetryMayBlock loc call
474 (threadWaitRead (fromIntegral (fdFD fd)))
475 read = if threaded then safe_read else unsafe_read
476 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
477 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
479 -- return: -1 indicates EOF, >=0 is bytes read
480 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
481 readRawBufferPtrNoBlock loc !fd buf off len
482 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
483 | otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0
484 if r /= 0 then safe_read
486 -- XXX see note [nonblock]
488 do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
492 n -> return (fromIntegral n)
493 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
494 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
496 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
497 writeRawBufferPtr loc !fd buf off len
498 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
499 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
502 else do threadWaitWrite (fromIntegral (fdFD fd)); write
504 do_write call = fromIntegral `fmap`
505 throwErrnoIfMinus1RetryMayBlock loc call
506 (threadWaitWrite (fromIntegral (fdFD fd)))
507 write = if threaded then safe_write else unsafe_write
508 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
509 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
511 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
512 writeRawBufferPtrNoBlock loc !fd buf off len
513 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
514 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
518 do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
521 n -> return (fromIntegral n)
522 write = if threaded then safe_write else unsafe_write
523 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
524 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
526 isNonBlocking :: FD -> Bool
527 isNonBlocking fd = fdIsNonBlocking fd /= 0
529 foreign import ccall unsafe "fdReady"
530 unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
532 #else /* mingw32_HOST_OS.... */
534 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
535 readRawBufferPtr loc !fd buf off len
536 | threaded = blockingReadRawBufferPtr loc fd buf off len
537 | otherwise = asyncReadRawBufferPtr loc fd buf off len
539 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
540 writeRawBufferPtr loc !fd buf off len
541 | threaded = blockingWriteRawBufferPtr loc fd buf off len
542 | otherwise = asyncWriteRawBufferPtr loc fd buf off len
544 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
545 readRawBufferPtrNoBlock = readRawBufferPtr
547 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
548 writeRawBufferPtrNoBlock = writeRawBufferPtr
550 -- Async versions of the read/write primitives, for the non-threaded RTS
552 asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
553 asyncReadRawBufferPtr loc !fd buf off len = do
554 (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
555 (fromIntegral len) (buf `plusPtr` off)
558 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
559 else return (fromIntegral l)
561 asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
562 asyncWriteRawBufferPtr loc !fd buf off len = do
563 (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
564 (fromIntegral len) (buf `plusPtr` off)
567 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
568 else return (fromIntegral l)
570 -- Blocking versions of the read/write primitives, for the threaded RTS
572 blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
573 blockingReadRawBufferPtr loc fd buf off len
574 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
576 then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0
577 else c_safe_read (fdFD fd) (buf `plusPtr` off) len
579 blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
580 blockingWriteRawBufferPtr loc fd buf off len
581 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
583 then c_safe_send (fdFD fd) (buf `plusPtr` off) len 0
585 r <- c_safe_write (fdFD fd) (buf `plusPtr` off) len
586 when (r == -1) c_maperrno
588 -- we don't trust write() to give us the correct errno, and
589 -- instead do the errno conversion from GetLastError()
590 -- ourselves. The main reason is that we treat ERROR_NO_DATA
591 -- (pipe is closing) as EPIPE, whereas write() returns EINVAL
592 -- for this case. We need to detect EPIPE correctly, because it
593 -- shouldn't be reported as an error when it happens on stdout.
595 foreign import ccall unsafe "maperrno" -- in Win32Utils.c
598 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
599 -- These calls may block, but that's ok.
601 foreign import stdcall safe "recv"
602 c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
604 foreign import stdcall safe "send"
605 c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
609 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
611 -- -----------------------------------------------------------------------------
614 #ifndef mingw32_HOST_OS
615 throwErrnoIfMinus1RetryOnBlock :: String -> IO CSsize -> IO CSsize -> IO CSsize
616 throwErrnoIfMinus1RetryOnBlock loc f on_block =
619 if (res :: CSsize) == -1
623 then throwErrnoIfMinus1RetryOnBlock loc f on_block
624 else if err == eWOULDBLOCK || err == eAGAIN
630 -- -----------------------------------------------------------------------------
633 #ifndef mingw32_HOST_OS
634 foreign import ccall unsafe "lockFile"
635 lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
637 foreign import ccall unsafe "unlockFile"
638 unlockFile :: CInt -> IO CInt
641 puts :: String -> IO ()
642 puts s = do _ <- withCStringLen s $ \(p,len) ->
643 c_write 1 (castPtr p) (fromIntegral len)