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 (fromIntegral 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
397 fdRead fd ptr bytes = do
398 r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
399 return (fromIntegral r)
401 fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
402 fdReadNonBlocking fd ptr bytes = do
403 r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr
404 0 (fromIntegral bytes)
406 (-1) -> return (Nothing)
407 n -> return (Just (fromIntegral n))
410 fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
411 fdWrite fd ptr bytes = do
412 res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
413 let res' = fromIntegral res
415 then fdWrite fd (ptr `plusPtr` res') (bytes - res')
418 -- XXX ToDo: this isn't non-blocking
419 fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int
420 fdWriteNonBlocking fd ptr bytes = do
421 res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0
423 return (fromIntegral res)
425 -- -----------------------------------------------------------------------------
428 -- Low level routines for reading/writing to (raw)buffers:
430 #ifndef mingw32_HOST_OS
435 Unix has broken semantics when it comes to non-blocking I/O: you can
436 set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
437 attached to the same underlying file, pipe or TTY; there's no way to
438 have private non-blocking behaviour for an FD. See bug #724.
440 We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
441 come from external sources or are exposed externally are left in
442 blocking mode. This solution has some problems though. We can't
443 completely simulate a non-blocking read without O_NONBLOCK: several
444 cases are wrong here. The cases that are wrong:
446 * reading/writing to a blocking FD in non-threaded mode.
447 In threaded mode, we just make a safe call to read().
448 In non-threaded mode we call select() before attempting to read,
449 but that leaves a small race window where the data can be read
450 from the file descriptor before we issue our blocking read().
451 * readRawBufferNoBlock for a blocking FD
455 In the threaded RTS we could just make safe calls to read()/write()
456 for file descriptors in blocking mode without worrying about blocking
457 other threads, but the problem with this is that the thread will be
458 uninterruptible while it is blocked in the foreign call. See #2363.
459 So now we always call fdReady() before reading, and if fdReady
460 indicates that there's no data, we call threadWaitRead.
464 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
465 readRawBufferPtr loc !fd buf off len
466 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
467 | otherwise = do r <- throwErrnoIfMinus1 loc
468 (unsafe_fdReady (fdFD fd) 0 0 0)
471 else do threadWaitRead (fromIntegral (fdFD fd)); read
473 do_read call = fromIntegral `fmap`
474 throwErrnoIfMinus1RetryMayBlock loc call
475 (threadWaitRead (fromIntegral (fdFD fd)))
476 read = if threaded then safe_read else unsafe_read
477 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
478 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
480 -- return: -1 indicates EOF, >=0 is bytes read
481 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
482 readRawBufferPtrNoBlock loc !fd buf off len
483 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
484 | otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0
485 if r /= 0 then safe_read
487 -- XXX see note [nonblock]
489 do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
493 n -> return (fromIntegral n)
494 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
495 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
497 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
498 writeRawBufferPtr loc !fd buf off len
499 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
500 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
503 else do threadWaitWrite (fromIntegral (fdFD fd)); write
505 do_write call = fromIntegral `fmap`
506 throwErrnoIfMinus1RetryMayBlock loc call
507 (threadWaitWrite (fromIntegral (fdFD fd)))
508 write = if threaded then safe_write else unsafe_write
509 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
510 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
512 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
513 writeRawBufferPtrNoBlock loc !fd buf off len
514 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
515 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
519 do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
522 n -> return (fromIntegral n)
523 write = if threaded then safe_write else unsafe_write
524 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
525 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
527 isNonBlocking :: FD -> Bool
528 isNonBlocking fd = fdIsNonBlocking fd /= 0
530 foreign import ccall unsafe "fdReady"
531 unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
533 #else /* mingw32_HOST_OS.... */
535 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
536 readRawBufferPtr loc !fd buf off len
537 | threaded = blockingReadRawBufferPtr loc fd buf off len
538 | otherwise = asyncReadRawBufferPtr loc fd buf off len
540 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
541 writeRawBufferPtr loc !fd buf off len
542 | threaded = blockingWriteRawBufferPtr loc fd buf off len
543 | otherwise = asyncWriteRawBufferPtr loc fd buf off len
545 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
546 readRawBufferPtrNoBlock = readRawBufferPtr
548 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
549 writeRawBufferPtrNoBlock = writeRawBufferPtr
551 -- Async versions of the read/write primitives, for the non-threaded RTS
553 asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
554 asyncReadRawBufferPtr loc !fd buf off len = do
555 (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
556 (fromIntegral len) (buf `plusPtr` off)
559 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
560 else return (fromIntegral l)
562 asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
563 asyncWriteRawBufferPtr loc !fd buf off len = do
564 (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
565 (fromIntegral len) (buf `plusPtr` off)
568 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
569 else return (fromIntegral l)
571 -- Blocking versions of the read/write primitives, for the threaded RTS
573 blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
574 blockingReadRawBufferPtr loc fd buf off len
575 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
577 then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0
578 else c_safe_read (fdFD fd) (buf `plusPtr` off) len
580 blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
581 blockingWriteRawBufferPtr loc fd buf off len
582 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
584 then c_safe_send (fdFD fd) (buf `plusPtr` off) len 0
586 r <- c_safe_write (fdFD fd) (buf `plusPtr` off) len
587 when (r == -1) c_maperrno
589 -- we don't trust write() to give us the correct errno, and
590 -- instead do the errno conversion from GetLastError()
591 -- ourselves. The main reason is that we treat ERROR_NO_DATA
592 -- (pipe is closing) as EPIPE, whereas write() returns EINVAL
593 -- for this case. We need to detect EPIPE correctly, because it
594 -- shouldn't be reported as an error when it happens on stdout.
596 foreign import ccall unsafe "maperrno" -- in Win32Utils.c
599 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
600 -- These calls may block, but that's ok.
602 foreign import stdcall safe "recv"
603 c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
605 foreign import stdcall safe "send"
606 c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
610 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
612 -- -----------------------------------------------------------------------------
615 #ifndef mingw32_HOST_OS
616 throwErrnoIfMinus1RetryOnBlock :: String -> IO CSsize -> IO CSsize -> IO CSsize
617 throwErrnoIfMinus1RetryOnBlock loc f on_block =
620 if (res :: CSsize) == -1
624 then throwErrnoIfMinus1RetryOnBlock loc f on_block
625 else if err == eWOULDBLOCK || err == eAGAIN
631 -- -----------------------------------------------------------------------------
634 #ifndef mingw32_HOST_OS
635 foreign import ccall unsafe "lockFile"
636 lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
638 foreign import ccall unsafe "unlockFile"
639 unlockFile :: CInt -> IO CInt
642 puts :: String -> IO ()
643 puts s = do _ <- withCStringLen s $ \(p,len) ->
644 c_write 1 (castPtr p) (fromIntegral len)