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
377 isTerminal fd = c_isatty (fdFD fd) >>= return.toBool
379 setEcho :: FD -> Bool -> IO ()
380 setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
382 getEcho :: FD -> IO Bool
383 getEcho fd = System.Posix.Internals.getEcho (fdFD fd)
385 setRaw :: FD -> Bool -> IO ()
386 setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
388 -- -----------------------------------------------------------------------------
389 -- Reading and Writing
391 fdRead :: FD -> Ptr Word8 -> Int -> IO Int
392 fdRead fd ptr bytes = do
393 r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
394 return (fromIntegral r)
396 fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
397 fdReadNonBlocking fd ptr bytes = do
398 r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr
399 0 (fromIntegral bytes)
401 (-1) -> return (Nothing)
402 n -> return (Just (fromIntegral n))
405 fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
406 fdWrite fd ptr bytes = do
407 res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
408 let res' = fromIntegral res
410 then fdWrite fd (ptr `plusPtr` res') (bytes - res')
413 -- XXX ToDo: this isn't non-blocking
414 fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int
415 fdWriteNonBlocking fd ptr bytes = do
416 res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0
418 return (fromIntegral res)
420 -- -----------------------------------------------------------------------------
423 -- Low level routines for reading/writing to (raw)buffers:
425 #ifndef mingw32_HOST_OS
430 Unix has broken semantics when it comes to non-blocking I/O: you can
431 set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
432 attached to the same underlying file, pipe or TTY; there's no way to
433 have private non-blocking behaviour for an FD. See bug #724.
435 We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
436 come from external sources or are exposed externally are left in
437 blocking mode. This solution has some problems though. We can't
438 completely simulate a non-blocking read without O_NONBLOCK: several
439 cases are wrong here. The cases that are wrong:
441 * reading/writing to a blocking FD in non-threaded mode.
442 In threaded mode, we just make a safe call to read().
443 In non-threaded mode we call select() before attempting to read,
444 but that leaves a small race window where the data can be read
445 from the file descriptor before we issue our blocking read().
446 * readRawBufferNoBlock for a blocking FD
450 In the threaded RTS we could just make safe calls to read()/write()
451 for file descriptors in blocking mode without worrying about blocking
452 other threads, but the problem with this is that the thread will be
453 uninterruptible while it is blocked in the foreign call. See #2363.
454 So now we always call fdReady() before reading, and if fdReady
455 indicates that there's no data, we call threadWaitRead.
459 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
460 readRawBufferPtr loc !fd buf off len
461 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
462 | otherwise = do r <- throwErrnoIfMinus1 loc
463 (unsafe_fdReady (fdFD fd) 0 0 0)
466 else do threadWaitRead (fromIntegral (fdFD fd)); read
468 do_read call = fromIntegral `fmap`
469 throwErrnoIfMinus1RetryMayBlock loc call
470 (threadWaitRead (fromIntegral (fdFD fd)))
471 read = if threaded then safe_read else unsafe_read
472 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
473 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
475 -- return: -1 indicates EOF, >=0 is bytes read
476 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
477 readRawBufferPtrNoBlock loc !fd buf off len
478 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
479 | otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0
480 if r /= 0 then safe_read
482 -- XXX see note [nonblock]
484 do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
488 n -> return (fromIntegral n)
489 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
490 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
492 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
493 writeRawBufferPtr loc !fd buf off len
494 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
495 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
498 else do threadWaitWrite (fromIntegral (fdFD fd)); write
500 do_write call = fromIntegral `fmap`
501 throwErrnoIfMinus1RetryMayBlock loc call
502 (threadWaitWrite (fromIntegral (fdFD fd)))
503 write = if threaded then safe_write else unsafe_write
504 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
505 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
507 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
508 writeRawBufferPtrNoBlock loc !fd buf off len
509 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
510 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
514 do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
517 n -> return (fromIntegral n)
518 write = if threaded then safe_write else unsafe_write
519 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
520 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
522 isNonBlocking :: FD -> Bool
523 isNonBlocking fd = fdIsNonBlocking fd /= 0
525 foreign import ccall unsafe "fdReady"
526 unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
528 #else /* mingw32_HOST_OS.... */
530 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
531 readRawBufferPtr loc !fd buf off len
532 | threaded = blockingReadRawBufferPtr loc fd buf off len
533 | otherwise = asyncReadRawBufferPtr loc fd buf off len
535 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
536 writeRawBufferPtr loc !fd buf off len
537 | threaded = blockingWriteRawBufferPtr loc fd buf off len
538 | otherwise = asyncWriteRawBufferPtr loc fd buf off len
540 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
541 readRawBufferPtrNoBlock = readRawBufferPtr
543 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
544 writeRawBufferPtrNoBlock = writeRawBufferPtr
546 -- Async versions of the read/write primitives, for the non-threaded RTS
548 asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
549 asyncReadRawBufferPtr loc !fd buf off len = do
550 (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
551 (fromIntegral len) (buf `plusPtr` off)
554 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
555 else return (fromIntegral l)
557 asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
558 asyncWriteRawBufferPtr loc !fd buf off len = do
559 (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
560 (fromIntegral len) (buf `plusPtr` off)
563 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
564 else return (fromIntegral l)
566 -- Blocking versions of the read/write primitives, for the threaded RTS
568 blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
569 blockingReadRawBufferPtr loc fd buf off len
570 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
572 then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0
573 else c_safe_read (fdFD fd) (buf `plusPtr` off) len
575 blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
576 blockingWriteRawBufferPtr loc fd buf off len
577 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
579 then c_safe_send (fdFD fd) (buf `plusPtr` off) len 0
580 else c_safe_write (fdFD fd) (buf `plusPtr` off) len
582 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
583 -- These calls may block, but that's ok.
585 foreign import stdcall safe "recv"
586 c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
588 foreign import stdcall safe "send"
589 c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
593 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
595 -- -----------------------------------------------------------------------------
598 #ifndef mingw32_HOST_OS
599 throwErrnoIfMinus1RetryOnBlock :: String -> IO CSsize -> IO CSsize -> IO CSsize
600 throwErrnoIfMinus1RetryOnBlock loc f on_block =
603 if (res :: CSsize) == -1
607 then throwErrnoIfMinus1RetryOnBlock loc f on_block
608 else if err == eWOULDBLOCK || err == eAGAIN
614 -- -----------------------------------------------------------------------------
617 #ifndef mingw32_HOST_OS
618 foreign import ccall unsafe "lockFile"
619 lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
621 foreign import ccall unsafe "unlockFile"
622 unlockFile :: CInt -> IO CInt
625 puts :: String -> IO ()
626 puts s = do _ <- withCStringLen s $ \(p,len) ->
627 c_write 1 (castPtr p) (fromIntegral len)