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,
39 import GHC.IO.BufferedIO
40 import qualified GHC.IO.Device
41 import GHC.IO.Device (SeekMode(..), IODeviceType(..))
43 import GHC.IO.Exception
47 import qualified System.Posix.Internals
48 import System.Posix.Internals hiding (FD, setEcho, getEcho)
49 import System.Posix.Types
52 -- -----------------------------------------------------------------------------
53 -- The file-descriptor IO device
56 fdFD :: {-# UNPACK #-} !CInt,
57 #ifdef mingw32_HOST_OS
58 -- On Windows, a socket file descriptor needs to be read and written
59 -- using different functions (send/recv).
60 fdIsSocket_ :: {-# UNPACK #-} !Int
62 -- On Unix we need to know whether this FD has O_NONBLOCK set.
63 -- If it has, then we can use more efficient routines to read/write to it.
64 -- It is always safe for this to be off.
65 fdIsNonBlocking :: {-# UNPACK #-} !Int
70 #ifdef mingw32_HOST_OS
71 fdIsSocket :: FD -> Bool
72 fdIsSocket fd = fdIsSocket_ fd /= 0
75 instance Show FD where
76 show fd = show (fdFD fd)
78 instance GHC.IO.Device.RawIO FD where
80 readNonBlocking = fdReadNonBlocking
82 writeNonBlocking = fdWriteNonBlocking
84 instance GHC.IO.Device.IODevice FD where
87 isTerminal = isTerminal
88 isSeekable = isSeekable
100 instance BufferedIO FD where
101 newBuffer _dev state = newByteBuffer dEFAULT_BUFFER_SIZE state
102 fillReadBuffer fd buf = readBuf' fd buf
103 fillReadBuffer0 fd buf = readBufNonBlocking fd buf
104 flushWriteBuffer fd buf = writeBuf' fd buf
105 flushWriteBuffer0 fd buf = writeBufNonBlocking fd buf
107 readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
110 puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
112 (r,buf') <- readBuf fd buf
114 puts ("after: " ++ summaryBuffer buf' ++ "\n")
118 writeBuf' :: FD -> Buffer Word8 -> IO ()
119 writeBuf' fd buf = do
121 puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
125 -- -----------------------------------------------------------------------------
128 -- | Open a file and make an 'FD' for it. Truncates the file to zero
129 -- size when the `IOMode` is `WriteMode`. Puts the file descriptor
130 -- into non-blocking mode on Unix systems.
131 openFile :: FilePath -> IOMode -> IO (FD,IODeviceType)
132 openFile filepath iomode =
133 withFilePath filepath $ \ f ->
136 oflags1 = case iomode of
137 ReadMode -> read_flags
138 #ifdef mingw32_HOST_OS
139 WriteMode -> write_flags .|. o_TRUNC
141 WriteMode -> write_flags
143 ReadWriteMode -> rw_flags
144 AppendMode -> append_flags
146 #ifdef mingw32_HOST_OS
147 binary_flags = o_BINARY
152 oflags = oflags1 .|. binary_flags
155 -- the old implementation had a complicated series of three opens,
156 -- which is perhaps because we have to be careful not to open
157 -- directories. However, the man pages I've read say that open()
158 -- always returns EISDIR if the file is a directory and was opened
159 -- for writing, so I think we're ok with a single open() here...
160 fd <- throwErrnoIfMinus1Retry "openFile"
161 (c_open f (fromIntegral oflags) 0o666)
163 (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
164 False{-not a socket-}
165 True{-is non-blocking-}
166 `catchAny` \e -> do c_close fd; throwIO e
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 let _ = (dev,ino,write,fd) -- 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 -- -----------------------------------------------------------------------------
251 -- Standard file descriptors
254 stdFD fd = FD { fdFD = fd,
255 #ifdef mingw32_HOST_OS
259 -- We don't set non-blocking mode on standard handles, because it may
260 -- confuse other applications attached to the same TTY/pipe
261 -- see Note [nonblock]
265 stdin, stdout, stderr :: FD
270 -- -----------------------------------------------------------------------------
271 -- Operations on file descriptors
275 #ifndef mingw32_HOST_OS
276 (flip finally) (release fd) $ do
278 throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
279 #ifdef mingw32_HOST_OS
280 if fdIsSocket fd then
281 c_closesocket (fdFD fd)
286 release :: FD -> IO ()
288 #ifndef mingw32_HOST_OS
291 let _ = fd -- warning suppression
294 #ifdef mingw32_HOST_OS
295 foreign import stdcall unsafe "HsBase.h closesocket"
296 c_closesocket :: CInt -> IO CInt
299 isSeekable :: FD -> IO Bool
302 return (t == RegularFile || t == RawDevice)
304 seek :: FD -> SeekMode -> Integer -> IO ()
305 seek fd mode off = do
306 throwErrnoIfMinus1Retry "seek" $
307 c_lseek (fdFD fd) (fromIntegral off) seektype
311 seektype = case mode of
312 AbsoluteSeek -> sEEK_SET
313 RelativeSeek -> sEEK_CUR
314 SeekFromEnd -> sEEK_END
316 tell :: FD -> IO Integer
319 (throwErrnoIfMinus1Retry "hGetPosn" $
320 c_lseek (fdFD fd) 0 sEEK_CUR)
322 getSize :: FD -> IO Integer
323 getSize fd = fdFileSize (fdFD fd)
325 setSize :: FD -> Integer -> IO ()
327 throwErrnoIf (/=0) "GHC.IO.FD.setSize" $
328 c_ftruncate (fdFD fd) (fromIntegral size)
331 devType :: FD -> IO IODeviceType
332 devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
336 newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)
337 return fd{ fdFD = newfd }
339 dup2 :: FD -> FD -> IO FD
341 -- Windows' dup2 does not return the new descriptor, unlike Unix
342 throwErrnoIfMinus1 "GHC.IO.FD.dup2" $
343 c_dup2 (fdFD fd) (fdFD fdto)
344 return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
346 setNonBlockingMode :: FD -> Bool -> IO FD
347 setNonBlockingMode fd set = do
348 setNonBlockingFD (fdFD fd) set
349 #if defined(mingw32_HOST_OS)
352 return fd{ fdIsNonBlocking = fromEnum set }
355 ready :: FD -> Bool -> Int -> IO Bool
356 ready fd write msecs = do
357 r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $
358 fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)
360 #if defined(mingw32_HOST_OS)
361 (fromIntegral $ fromEnum $ fdIsSocket fd)
365 return (toEnum (fromIntegral r))
367 foreign import ccall safe "fdReady"
368 fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
370 -- ---------------------------------------------------------------------------
371 -- Terminal-related stuff
373 isTerminal :: FD -> IO Bool
374 isTerminal fd = c_isatty (fdFD fd) >>= return.toBool
376 setEcho :: FD -> Bool -> IO ()
377 setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
379 getEcho :: FD -> IO Bool
380 getEcho fd = System.Posix.Internals.getEcho (fdFD fd)
382 setRaw :: FD -> Bool -> IO ()
383 setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
385 -- -----------------------------------------------------------------------------
386 -- Reading and Writing
388 fdRead :: FD -> Ptr Word8 -> Int -> IO Int
389 fdRead fd ptr bytes = do
390 r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
391 return (fromIntegral r)
393 fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
394 fdReadNonBlocking fd ptr bytes = do
395 r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr
396 0 (fromIntegral bytes)
398 (-1) -> return (Nothing)
399 n -> return (Just (fromIntegral n))
402 fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
403 fdWrite fd ptr bytes = do
404 res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
405 let res' = fromIntegral res
407 then fdWrite fd (ptr `plusPtr` res') (bytes - res')
410 -- XXX ToDo: this isn't non-blocking
411 fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int
412 fdWriteNonBlocking fd ptr bytes = do
413 res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0
415 return (fromIntegral res)
417 -- -----------------------------------------------------------------------------
420 -- Low level routines for reading/writing to (raw)buffers:
422 #ifndef mingw32_HOST_OS
427 Unix has broken semantics when it comes to non-blocking I/O: you can
428 set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
429 attached to the same underlying file, pipe or TTY; there's no way to
430 have private non-blocking behaviour for an FD. See bug #724.
432 We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
433 come from external sources or are exposed externally are left in
434 blocking mode. This solution has some problems though. We can't
435 completely simulate a non-blocking read without O_NONBLOCK: several
436 cases are wrong here. The cases that are wrong:
438 * reading/writing to a blocking FD in non-threaded mode.
439 In threaded mode, we just make a safe call to read().
440 In non-threaded mode we call select() before attempting to read,
441 but that leaves a small race window where the data can be read
442 from the file descriptor before we issue our blocking read().
443 * readRawBufferNoBlock for a blocking FD
447 In the threaded RTS we could just make safe calls to read()/write()
448 for file descriptors in blocking mode without worrying about blocking
449 other threads, but the problem with this is that the thread will be
450 uninterruptible while it is blocked in the foreign call. See #2363.
451 So now we always call fdReady() before reading, and if fdReady
452 indicates that there's no data, we call threadWaitRead.
456 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
457 readRawBufferPtr loc !fd buf off len
458 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
459 | otherwise = do r <- throwErrnoIfMinus1 loc
460 (unsafe_fdReady (fdFD fd) 0 0 0)
463 else do threadWaitRead (fromIntegral (fdFD fd)); read
465 do_read call = fromIntegral `fmap`
466 throwErrnoIfMinus1RetryMayBlock loc call
467 (threadWaitRead (fromIntegral (fdFD fd)))
468 read = if threaded then safe_read else unsafe_read
469 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
470 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
472 -- return: -1 indicates EOF, >=0 is bytes read
473 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
474 readRawBufferPtrNoBlock loc !fd buf off len
475 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
476 | otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0
477 if r /= 0 then safe_read
479 -- XXX see note [nonblock]
481 do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
485 n -> return (fromIntegral n)
486 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
487 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
489 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
490 writeRawBufferPtr loc !fd buf off len
491 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
492 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
495 else do threadWaitWrite (fromIntegral (fdFD fd)); write
497 do_write call = fromIntegral `fmap`
498 throwErrnoIfMinus1RetryMayBlock loc call
499 (threadWaitWrite (fromIntegral (fdFD fd)))
500 write = if threaded then safe_write else unsafe_write
501 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
502 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
504 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
505 writeRawBufferPtrNoBlock loc !fd buf off len
506 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
507 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
511 do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
514 n -> return (fromIntegral n)
515 write = if threaded then safe_write else unsafe_write
516 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
517 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
519 isNonBlocking :: FD -> Bool
520 isNonBlocking fd = fdIsNonBlocking fd /= 0
522 foreign import ccall unsafe "fdReady"
523 unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
525 #else /* mingw32_HOST_OS.... */
527 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
528 readRawBufferPtr loc !fd buf off len
529 | threaded = blockingReadRawBufferPtr loc fd buf off len
530 | otherwise = asyncReadRawBufferPtr loc fd buf off len
532 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
533 writeRawBufferPtr loc !fd buf off len
534 | threaded = blockingWriteRawBufferPtr loc fd buf off len
535 | otherwise = asyncWriteRawBufferPtr loc fd buf off len
537 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
538 readRawBufferPtrNoBlock = readRawBufferPtr
540 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
541 writeRawBufferPtrNoBlock = writeRawBufferPtr
543 -- Async versions of the read/write primitives, for the non-threaded RTS
545 asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
546 asyncReadRawBufferPtr loc !fd buf off len = do
547 (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
548 (fromIntegral len) (buf `plusPtr` off)
551 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
552 else return (fromIntegral l)
554 asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
555 asyncWriteRawBufferPtr loc !fd buf off len = do
556 (l, rc) <- asyncWrite (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 -- Blocking versions of the read/write primitives, for the threaded RTS
565 blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
566 blockingReadRawBufferPtr loc fd buf off len
567 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
569 then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0
570 else c_safe_read (fdFD fd) (buf `plusPtr` off) len
572 blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
573 blockingWriteRawBufferPtr loc fd buf off len
574 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
576 then c_safe_send (fdFD fd) (buf `plusPtr` off) len 0
577 else c_safe_write (fdFD fd) (buf `plusPtr` off) len
579 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
580 -- These calls may block, but that's ok.
582 foreign import stdcall safe "recv"
583 c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
585 foreign import stdcall safe "send"
586 c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
590 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
592 -- -----------------------------------------------------------------------------
595 #ifndef mingw32_HOST_OS
596 throwErrnoIfMinus1RetryOnBlock :: String -> IO CSsize -> IO CSsize -> IO CSsize
597 throwErrnoIfMinus1RetryOnBlock loc f on_block =
600 if (res :: CSsize) == -1
604 then throwErrnoIfMinus1RetryOnBlock loc f on_block
605 else if err == eWOULDBLOCK || err == eAGAIN
611 -- -----------------------------------------------------------------------------
614 #ifndef mingw32_HOST_OS
615 foreign import ccall unsafe "lockFile"
616 lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
618 foreign import ccall unsafe "unlockFile"
619 unlockFile :: CInt -> IO CInt
622 #if defined(DEBUG_DUMP)
623 puts :: String -> IO ()
624 puts s = do withCStringLen s $ \(p,len) -> c_write 1 p (fromIntegral len)