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,
33 #ifndef mingw32_HOST_OS
41 import GHC.IO.BufferedIO
42 import qualified GHC.IO.Device
43 import GHC.IO.Device (SeekMode(..), IODeviceType(..))
45 import GHC.IO.Exception
49 import qualified System.Posix.Internals
50 import System.Posix.Internals hiding (FD, setEcho, getEcho)
51 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")
114 (r,buf') <- readBuf fd buf
116 puts ("after: " ++ summaryBuffer buf' ++ "\n")
120 writeBuf' :: FD -> Buffer Word8 -> IO ()
121 writeBuf' fd buf = do
123 puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
127 -- -----------------------------------------------------------------------------
130 -- | Open a file and make an 'FD' for it. Truncates the file to zero
131 -- size when the `IOMode` is `WriteMode`. Puts the file descriptor
132 -- into non-blocking mode on Unix systems.
133 openFile :: FilePath -> IOMode -> IO (FD,IODeviceType)
134 openFile filepath iomode =
135 withFilePath filepath $ \ f ->
138 oflags1 = case iomode of
139 ReadMode -> read_flags
140 #ifdef mingw32_HOST_OS
141 WriteMode -> write_flags .|. o_TRUNC
143 WriteMode -> write_flags
145 ReadWriteMode -> rw_flags
146 AppendMode -> append_flags
148 #ifdef mingw32_HOST_OS
149 binary_flags = o_BINARY
154 oflags = oflags1 .|. binary_flags
157 -- the old implementation had a complicated series of three opens,
158 -- which is perhaps because we have to be careful not to open
159 -- directories. However, the man pages I've read say that open()
160 -- always returns EISDIR if the file is a directory and was opened
161 -- for writing, so I think we're ok with a single open() here...
162 fd <- throwErrnoIfMinus1Retry "openFile"
163 (c_open f (fromIntegral oflags) 0o666)
165 (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
166 False{-not a socket-}
167 True{-is non-blocking-}
168 `catchAny` \e -> do _ <- c_close fd
171 #ifndef mingw32_HOST_OS
172 -- we want to truncate() if this is an open in WriteMode, but only
173 -- if the target is a RegularFile. ftruncate() fails on special files
175 if iomode == WriteMode && fd_type == RegularFile
182 std_flags, output_flags, read_flags, write_flags, rw_flags,
184 std_flags = o_NONBLOCK .|. o_NOCTTY
185 output_flags = std_flags .|. o_CREAT
186 read_flags = std_flags .|. o_RDONLY
187 write_flags = output_flags .|. o_WRONLY
188 rw_flags = output_flags .|. o_RDWR
189 append_flags = write_flags .|. o_APPEND
192 -- | Make a 'FD' from an existing file descriptor. Fails if the FD
193 -- refers to a directory. If the FD refers to a file, `mkFD` locks
194 -- the file according to the Haskell 98 single writer/multiple reader
195 -- locking semantics (this is why we need the `IOMode` argument too).
198 -> Maybe (IODeviceType, CDev, CIno)
199 -- the results of fdStat if we already know them, or we want
200 -- to prevent fdToHandle_stat from doing its own stat.
201 -- These are used for:
202 -- - we fail if the FD refers to a directory
203 -- - if the FD refers to a file, we lock it using (cdev,cino)
204 -> Bool -- ^ is a socket (on Windows)
205 -> Bool -- ^ is in non-blocking mode on Unix
206 -> IO (FD,IODeviceType)
208 mkFD fd iomode mb_stat is_socket is_nonblock = do
210 let _ = (is_socket, is_nonblock) -- warning suppression
215 Just stat -> return stat
217 let write = case iomode of
221 #ifdef mingw32_HOST_OS
222 _ <- setmode fd True -- unconditionally set binary mode
223 let _ = (dev,ino,write) -- warning suppression
228 ioException (IOError Nothing InappropriateType "openFile"
229 "is a directory" Nothing Nothing)
231 #ifndef mingw32_HOST_OS
232 -- regular files need to be locked
234 -- On Windows we use explicit exclusion via sopen() to implement
235 -- this locking (see __hscore_open()); on Unix we have to
236 -- implment it in the RTS.
237 r <- lockFile fd dev ino (fromBool write)
239 ioException (IOError Nothing ResourceBusy "openFile"
240 "file is locked" Nothing Nothing)
243 _other_type -> return ()
245 return (FD{ fdFD = fd,
246 #ifndef mingw32_HOST_OS
247 fdIsNonBlocking = fromEnum is_nonblock
249 fdIsSocket_ = fromEnum is_socket
254 #ifdef mingw32_HOST_OS
255 foreign import ccall unsafe "__hscore_setmode"
256 setmode :: CInt -> Bool -> IO CInt
259 -- -----------------------------------------------------------------------------
260 -- Standard file descriptors
263 stdFD fd = FD { fdFD = fd,
264 #ifdef mingw32_HOST_OS
268 -- We don't set non-blocking mode on standard handles, because it may
269 -- confuse other applications attached to the same TTY/pipe
270 -- see Note [nonblock]
274 stdin, stdout, stderr :: FD
279 -- -----------------------------------------------------------------------------
280 -- Operations on file descriptors
284 #ifndef mingw32_HOST_OS
285 (flip finally) (release fd) $ do
287 throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
288 #ifdef mingw32_HOST_OS
289 if fdIsSocket fd then
290 c_closesocket (fdFD fd)
295 release :: FD -> IO ()
296 #ifdef mingw32_HOST_OS
297 release _ = return ()
299 release fd = do _ <- unlockFile (fdFD fd)
303 #ifdef mingw32_HOST_OS
304 foreign import stdcall unsafe "HsBase.h closesocket"
305 c_closesocket :: CInt -> IO CInt
308 isSeekable :: FD -> IO Bool
311 return (t == RegularFile || t == RawDevice)
313 seek :: FD -> SeekMode -> Integer -> IO ()
314 seek fd mode off = do
315 throwErrnoIfMinus1Retry_ "seek" $
316 c_lseek (fdFD fd) (fromIntegral off) seektype
319 seektype = case mode of
320 AbsoluteSeek -> sEEK_SET
321 RelativeSeek -> sEEK_CUR
322 SeekFromEnd -> sEEK_END
324 tell :: FD -> IO Integer
327 (throwErrnoIfMinus1Retry "hGetPosn" $
328 c_lseek (fdFD fd) 0 sEEK_CUR)
330 getSize :: FD -> IO Integer
331 getSize fd = fdFileSize (fdFD fd)
333 setSize :: FD -> Integer -> IO ()
335 throwErrnoIf_ (/=0) "GHC.IO.FD.setSize" $
336 c_ftruncate (fdFD fd) (fromIntegral size)
338 devType :: FD -> IO IODeviceType
339 devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
343 newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)
344 return fd{ fdFD = newfd }
346 dup2 :: FD -> FD -> IO FD
348 -- Windows' dup2 does not return the new descriptor, unlike Unix
349 throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $
350 c_dup2 (fdFD fd) (fdFD fdto)
351 return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
353 setNonBlockingMode :: FD -> Bool -> IO FD
354 setNonBlockingMode fd set = do
355 setNonBlockingFD (fdFD fd) set
356 #if defined(mingw32_HOST_OS)
359 return fd{ fdIsNonBlocking = fromEnum set }
362 ready :: FD -> Bool -> Int -> IO Bool
363 ready fd write msecs = do
364 r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $
365 fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)
367 #if defined(mingw32_HOST_OS)
368 (fromIntegral $ fromEnum $ fdIsSocket fd)
372 return (toEnum (fromIntegral r))
374 foreign import ccall safe "fdReady"
375 fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
377 -- ---------------------------------------------------------------------------
378 -- Terminal-related stuff
380 isTerminal :: FD -> IO Bool
381 isTerminal fd = c_isatty (fdFD fd) >>= return.toBool
383 setEcho :: FD -> Bool -> IO ()
384 setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
386 getEcho :: FD -> IO Bool
387 getEcho fd = System.Posix.Internals.getEcho (fdFD fd)
389 setRaw :: FD -> Bool -> IO ()
390 setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
392 -- -----------------------------------------------------------------------------
393 -- Reading and Writing
395 fdRead :: FD -> Ptr Word8 -> Int -> IO Int
396 fdRead fd ptr bytes = do
397 r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
398 return (fromIntegral r)
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)
406 n -> return (Just (fromIntegral n))
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
584 else c_safe_write (fdFD fd) (buf `plusPtr` off) len
586 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
587 -- These calls may block, but that's ok.
589 foreign import stdcall safe "recv"
590 c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
592 foreign import stdcall safe "send"
593 c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
597 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
599 -- -----------------------------------------------------------------------------
602 #ifndef mingw32_HOST_OS
603 throwErrnoIfMinus1RetryOnBlock :: String -> IO CSsize -> IO CSsize -> IO CSsize
604 throwErrnoIfMinus1RetryOnBlock loc f on_block =
607 if (res :: CSsize) == -1
611 then throwErrnoIfMinus1RetryOnBlock loc f on_block
612 else if err == eWOULDBLOCK || err == eAGAIN
618 -- -----------------------------------------------------------------------------
621 #ifndef mingw32_HOST_OS
622 foreign import ccall unsafe "lockFile"
623 lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
625 foreign import ccall unsafe "unlockFile"
626 unlockFile :: CInt -> IO CInt
629 #if defined(DEBUG_DUMP)
630 puts :: String -> IO ()
631 puts s = do withCStringLen s $ \(p,len) -> c_write 1 p (fromIntegral len)