{-# LANGUAGE Trustworthy #-}{-# LANGUAGE InterruptibleFFI #-}{-# LANGUAGE CPP, NoImplicitPrelude, CApiFFI #-}{-# LANGUAGE LambdaCase #-}{-# LANGUAGE UnboxedTuples #-}{-# LANGUAGE MagicHash #-}{-# OPTIONS_HADDOCK not-home #-}------------------------------------------------------------------------------- |-- Module : System.Posix.Internals-- Copyright : (c) The University of Glasgow, 1992-2002-- License : see libraries/base/LICENSE---- Maintainer : cvs-ghc@haskell.org-- Stability : internal-- Portability : non-portable (requires POSIX)---- POSIX support layer for the standard libraries.-- This library is built on *every* platform, including Win32.---- Non-posix compliant in order to support the following features:-- * S_ISSOCK (no sockets in POSIX)-------------------------------------------------------------------------------moduleSystem.Posix.Internalswhere
#include "HsBaseConfig.h"
importSystem.Posix.Types importForeign importForeign.C -- import Data.BitsimportData.Maybe 
#if !defined(HTYPE_TCFLAG_T)
importSystem.IO.Error
#endif
importGHC.Base importGHC.Num importGHC.Real importGHC.IO importGHC.IO.IOMode importGHC.IO.Exception importGHC.IO.Device 
#if !defined(mingw32_HOST_OS)
import{-# SOURCE#-}GHC.IO.Encoding (getFileSystemEncoding )importqualifiedGHC.Foreign asGHC
#endif
-- ----------------------------------------------------------------------------- Debugging the base packageputs ::String ->IO ()puts :: String -> IO ()
puts String
s =forall a. String -> (CStringLen -> IO a) -> IO a
withCAStringLen (String
s forall a. [a] -> [a] -> [a]
++ String
"\n")forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
p ,Int
len )->do-- In reality should be withCString, but assume ASCII to avoid loop-- if this is called by GHC.ForeignCSsize
_<-CInt -> Ptr Word8 -> CSize -> IO CSsize
c_write CInt
1(forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
p )(forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len )forall (m :: * -> *) a. Monad m => a -> m a
return ()-- ----------------------------------------------------------------------------- Typesdata{-# CTYPE"struct flock"#-}CFLock data{-# CTYPE"struct group"#-}CGroup data{-# CTYPE"struct lconv"#-}CLconv data{-# CTYPE"struct passwd"#-}CPasswd data{-# CTYPE"struct sigaction"#-}CSigaction data{-# CTYPE"sigset_t"#-}CSigset data{-# CTYPE"struct stat"#-}CStat data{-# CTYPE"struct termios"#-}CTermios data{-# CTYPE"struct tm"#-}CTm data{-# CTYPE"struct tms"#-}CTms data{-# CTYPE"struct utimbuf"#-}CUtimbuf data{-# CTYPE"struct utsname"#-}CUtsname typeFD =CInt -- ----------------------------------------------------------------------------- stat()-related stufffdFileSize ::FD ->IO Integer fdFileSize :: CInt -> IO Integer
fdFileSize CInt
fd =forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeof_stat forall a b. (a -> b) -> a -> b
$ \Ptr CStat
p_stat ->doforall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"fileSize"forall a b. (a -> b) -> a -> b
$ CInt -> Ptr CStat -> IO CInt
c_fstat CInt
fd Ptr CStat
p_stat CMode
c_mode <-Ptr CStat -> IO CMode
st_mode Ptr CStat
p_stat ::IO CMode ifBool -> Bool
not (CMode -> Bool
s_isreg CMode
c_mode )thenforall (m :: * -> *) a. Monad m => a -> m a
return (-Integer
1)elsedoCOff
c_size <-Ptr CStat -> IO COff
st_size Ptr CStat
p_stat forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral COff
c_size )fileType ::FilePath ->IO IODeviceType fileType :: String -> IO IODeviceType
fileType String
file =forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeof_stat forall a b. (a -> b) -> a -> b
$ \Ptr CStat
p_stat ->forall a. String -> (Ptr CChar -> IO a) -> IO a
withFilePath String
file forall a b. (a -> b) -> a -> b
$ \Ptr CChar
p_file ->doforall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"fileType"forall a b. (a -> b) -> a -> b
$ Ptr CChar -> Ptr CStat -> IO CInt
c_stat Ptr CChar
p_file Ptr CStat
p_stat Ptr CStat -> IO IODeviceType
statGetType Ptr CStat
p_stat -- NOTE: On Win32 platforms, this will only work with file descriptors-- referring to file handles. i.e., it'll fail for socket FDs.fdStat ::FD ->IO (IODeviceType ,CDev ,CIno )fdStat :: CInt -> IO (IODeviceType, CDev, CIno)
fdStat CInt
fd =forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeof_stat forall a b. (a -> b) -> a -> b
$ \Ptr CStat
p_stat ->doforall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"fdType"forall a b. (a -> b) -> a -> b
$ CInt -> Ptr CStat -> IO CInt
c_fstat CInt
fd Ptr CStat
p_stat IODeviceType
ty <-Ptr CStat -> IO IODeviceType
statGetType Ptr CStat
p_stat CDev
dev <-Ptr CStat -> IO CDev
st_dev Ptr CStat
p_stat CIno
ino <-Ptr CStat -> IO CIno
st_ino Ptr CStat
p_stat forall (m :: * -> *) a. Monad m => a -> m a
return (IODeviceType
ty ,CDev
dev ,CIno
ino )fdType ::FD ->IO IODeviceType fdType :: CInt -> IO IODeviceType
fdType CInt
fd =do(IODeviceType
ty ,CDev
_,CIno
_)<-CInt -> IO (IODeviceType, CDev, CIno)
fdStat CInt
fd ;forall (m :: * -> *) a. Monad m => a -> m a
return IODeviceType
ty statGetType ::Ptr CStat ->IO IODeviceType statGetType :: Ptr CStat -> IO IODeviceType
statGetType Ptr CStat
p_stat =doCMode
c_mode <-Ptr CStat -> IO CMode
st_mode Ptr CStat
p_stat ::IO CMode case()of()
_|CMode -> Bool
s_isdir CMode
c_mode ->forall (m :: * -> *) a. Monad m => a -> m a
return IODeviceType
Directory |CMode -> Bool
s_isfifo CMode
c_mode Bool -> Bool -> Bool
|| CMode -> Bool
s_issock CMode
c_mode Bool -> Bool -> Bool
|| CMode -> Bool
s_ischr CMode
c_mode ->forall (m :: * -> *) a. Monad m => a -> m a
return IODeviceType
Stream |CMode -> Bool
s_isreg CMode
c_mode ->forall (m :: * -> *) a. Monad m => a -> m a
return IODeviceType
RegularFile -- Q: map char devices to RawDevice too?|CMode -> Bool
s_isblk CMode
c_mode ->forall (m :: * -> *) a. Monad m => a -> m a
return IODeviceType
RawDevice |Bool
otherwise ->forall a. IOError -> IO a
ioError IOError
ioe_unknownfiletype ioe_unknownfiletype ::IOException ioe_unknownfiletype :: IOError
ioe_unknownfiletype =Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError forall a. Maybe a
Nothing IOErrorType
UnsupportedOperation String
"fdType"String
"unknown file type"forall a. Maybe a
Nothing forall a. Maybe a
Nothing fdGetMode ::FD ->IO IOMode 
#if defined(mingw32_HOST_OS)
fdGetMode_=do-- We don't have a way of finding out which flags are set on FDs-- on Windows, so make a handle that thinks that anything goes.letflags=o_RDWR
#else
fdGetMode :: CInt -> IO IOMode
fdGetMode CInt
fd =doCInt
flags <-forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"fdGetMode"(CInt -> CInt -> IO CInt
c_fcntl_read CInt
fd CInt
const_f_getfl )
#endif
letwH :: Bool
wH =(CInt
flags forall a. Bits a => a -> a -> a
.&. CInt
o_WRONLY )forall a. Eq a => a -> a -> Bool
/= CInt
0aH :: Bool
aH =(CInt
flags forall a. Bits a => a -> a -> a
.&. CInt
o_APPEND )forall a. Eq a => a -> a -> Bool
/= CInt
0rwH :: Bool
rwH =(CInt
flags forall a. Bits a => a -> a -> a
.&. CInt
o_RDWR )forall a. Eq a => a -> a -> Bool
/= CInt
0mode :: IOMode
mode |Bool
wH Bool -> Bool -> Bool
&& Bool
aH =IOMode
AppendMode |Bool
wH =IOMode
WriteMode |Bool
rwH =IOMode
ReadWriteMode |Bool
otherwise =IOMode
ReadMode forall (m :: * -> *) a. Monad m => a -> m a
return IOMode
mode 
#if defined(mingw32_HOST_OS)
withFilePath::FilePath->(CWString->IOa)->IOawithFilePath=withCWStringnewFilePath::FilePath->IOCWStringnewFilePath=newCWStringpeekFilePath::CWString->IOFilePathpeekFilePath=peekCWString
#else
withFilePath ::FilePath ->(CString ->IO a )->IO a newFilePath ::FilePath ->IO CString peekFilePath ::CString ->IO FilePath peekFilePathLen ::CStringLen ->IO FilePath withFilePath :: forall a. String -> (Ptr CChar -> IO a) -> IO a
withFilePath String
fp Ptr CChar -> IO a
f =IO TextEncoding
getFileSystemEncoding forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TextEncoding
enc ->forall a. TextEncoding -> String -> (Ptr CChar -> IO a) -> IO a
GHC.withCString TextEncoding
enc String
fp Ptr CChar -> IO a
f newFilePath :: String -> IO (Ptr CChar)
newFilePath String
fp =IO TextEncoding
getFileSystemEncoding forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TextEncoding
enc ->TextEncoding -> String -> IO (Ptr CChar)
GHC.newCString TextEncoding
enc String
fp peekFilePath :: Ptr CChar -> IO String
peekFilePath Ptr CChar
fp =IO TextEncoding
getFileSystemEncoding forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TextEncoding
enc ->TextEncoding -> Ptr CChar -> IO String
GHC.peekCString TextEncoding
enc Ptr CChar
fp peekFilePathLen :: CStringLen -> IO String
peekFilePathLen CStringLen
fp =IO TextEncoding
getFileSystemEncoding forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TextEncoding
enc ->TextEncoding -> CStringLen -> IO String
GHC.peekCStringLen TextEncoding
enc CStringLen
fp 
#endif
-- ----------------------------------------------------------------------------- Terminal-related stuff
#if defined(HTYPE_TCFLAG_T)
setEcho ::FD ->Bool ->IO ()setEcho :: CInt -> Bool -> IO ()
setEcho CInt
fd Bool
on =forall a. CInt -> (Ptr CTermios -> IO a) -> IO a
tcSetAttr CInt
fd forall a b. (a -> b) -> a -> b
$ \Ptr CTermios
p_tios ->doCTcflag
lflag <-Ptr CTermios -> IO CTcflag
c_lflag Ptr CTermios
p_tios ::IO CTcflag letnew_lflag :: CTcflag
new_lflag |Bool
on =CTcflag
lflag forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
const_echo |Bool
otherwise =CTcflag
lflag forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> a
complement (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
const_echo )Ptr CTermios -> CTcflag -> IO ()
poke_c_lflag Ptr CTermios
p_tios (CTcflag
new_lflag ::CTcflag )getEcho ::FD ->IO Bool getEcho :: CInt -> IO Bool
getEcho CInt
fd =forall a. CInt -> (Ptr CTermios -> IO a) -> IO a
tcSetAttr CInt
fd forall a b. (a -> b) -> a -> b
$ \Ptr CTermios
p_tios ->doCTcflag
lflag <-Ptr CTermios -> IO CTcflag
c_lflag Ptr CTermios
p_tios ::IO CTcflag forall (m :: * -> *) a. Monad m => a -> m a
return ((CTcflag
lflag forall a. Bits a => a -> a -> a
.&. forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
const_echo )forall a. Eq a => a -> a -> Bool
/= CTcflag
0)setCooked ::FD ->Bool ->IO ()setCooked :: CInt -> Bool -> IO ()
setCooked CInt
fd Bool
cooked =forall a. CInt -> (Ptr CTermios -> IO a) -> IO a
tcSetAttr CInt
fd forall a b. (a -> b) -> a -> b
$ \Ptr CTermios
p_tios ->do-- turn on/off ICANONCTcflag
lflag <-Ptr CTermios -> IO CTcflag
c_lflag Ptr CTermios
p_tios ::IO CTcflag letnew_lflag :: CTcflag
new_lflag |Bool
cooked =CTcflag
lflag forall a. Bits a => a -> a -> a
.|. (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
const_icanon )|Bool
otherwise =CTcflag
lflag forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> a
complement (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
const_icanon )Ptr CTermios -> CTcflag -> IO ()
poke_c_lflag Ptr CTermios
p_tios (CTcflag
new_lflag ::CTcflag )-- set VMIN & VTIME to 1/0 respectivelyforall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
cooked )forall a b. (a -> b) -> a -> b
$ doPtr Word8
c_cc <-Ptr CTermios -> IO (Ptr Word8)
ptr_c_cc Ptr CTermios
p_tios letvmin :: Ptr Word8
vmin =(Ptr Word8
c_cc forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
const_vmin ))::Ptr Word8 vtime :: Ptr Word8
vtime =(Ptr Word8
c_cc forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
const_vtime ))::Ptr Word8 forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
vmin Word8
1forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
vtime Word8
0tcSetAttr ::FD ->(Ptr CTermios ->IO a )->IO a tcSetAttr :: forall a. CInt -> (Ptr CTermios -> IO a) -> IO a
tcSetAttr CInt
fd Ptr CTermios -> IO a
fun =forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeof_termios forall a b. (a -> b) -> a -> b
$ \Ptr CTermios
p_tios ->doforall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"tcSetAttr"(CInt -> Ptr CTermios -> IO CInt
c_tcgetattr CInt
fd Ptr CTermios
p_tios )-- Save a copy of termios, if this is a standard file descriptor.-- These terminal settings are restored in hs_exit().forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
fd forall a. Ord a => a -> a -> Bool
<= CInt
2)forall a b. (a -> b) -> a -> b
$ doPtr CTermios
p <-CInt -> IO (Ptr CTermios)
get_saved_termios CInt
fd forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr CTermios
p forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr )forall a b. (a -> b) -> a -> b
$ doPtr CTermios
saved_tios <-forall a. Int -> IO (Ptr a)
mallocBytes Int
sizeof_termios forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr CTermios
saved_tios Ptr CTermios
p_tios Int
sizeof_termios CInt -> Ptr CTermios -> IO ()
set_saved_termios CInt
fd Ptr CTermios
saved_tios -- tcsetattr() when invoked by a background process causes the process-- to be sent SIGTTOU regardless of whether the process has TOSTOP set-- in its terminal flags (try it...). This function provides a-- wrapper which temporarily blocks SIGTTOU around the call, making it-- transparent.forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeof_sigset_t forall a b. (a -> b) -> a -> b
$ \Ptr CSigset
p_sigset ->forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeof_sigset_t forall a b. (a -> b) -> a -> b
$ \Ptr CSigset
p_old_sigset ->doforall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"sigemptyset"forall a b. (a -> b) -> a -> b
$ Ptr CSigset -> IO CInt
c_sigemptyset Ptr CSigset
p_sigset forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"sigaddset"forall a b. (a -> b) -> a -> b
$ Ptr CSigset -> CInt -> IO CInt
c_sigaddset Ptr CSigset
p_sigset CInt
const_sigttou forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"sigprocmask"forall a b. (a -> b) -> a -> b
$ CInt -> Ptr CSigset -> Ptr CSigset -> IO CInt
c_sigprocmask CInt
const_sig_block Ptr CSigset
p_sigset Ptr CSigset
p_old_sigset a
r <-Ptr CTermios -> IO a
fun Ptr CTermios
p_tios -- do the businessforall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"tcSetAttr"forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> Ptr CTermios -> IO CInt
c_tcsetattr CInt
fd CInt
const_tcsanow Ptr CTermios
p_tios forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"sigprocmask"forall a b. (a -> b) -> a -> b
$ CInt -> Ptr CSigset -> Ptr CSigset -> IO CInt
c_sigprocmask CInt
const_sig_setmask Ptr CSigset
p_old_sigset forall a. Ptr a
nullPtr forall (m :: * -> *) a. Monad m => a -> m a
return a
r foreignimportccallunsafe"HsBase.h __hscore_get_saved_termios"get_saved_termios ::CInt ->IO (Ptr CTermios )foreignimportccallunsafe"HsBase.h __hscore_set_saved_termios"set_saved_termios ::CInt ->(Ptr CTermios )->IO ()
#else
-- 'raw' mode for Win32 means turn off 'line input' (=> buffering and-- character translation for the console.) The Win32 API for doing-- this is GetConsoleMode(), which also requires echoing to be disabled-- when turning off 'line input' processing. Notice that turning off-- 'line input' implies enter/return is reported as '\r' (and it won't-- report that character until another character is input..odd.) This-- latter feature doesn't sit too well with IO actions like IO.hGetLine..-- consider yourself warned.setCooked::FD->Bool->IO()setCookedfdcooked=dox<-set_console_bufferingfd(ifcookedthen1else0)if(x/=0)thenioError(ioe_unk_error"setCooked""failed to set buffering")elsereturn()ioe_unk_error::String->String->IOExceptionioe_unk_errorlocmsg=ioeSetErrorString(mkIOErrorOtherErrorlocNothingNothing)msg-- Note: echoing goes hand in hand with enabling 'line input' / raw-ness-- for Win32 consoles, hence setEcho ends up being the inverse of setCooked.setEcho::FD->Bool->IO()setEchofdon=dox<-set_console_echofd(ifonthen1else0)if(x/=0)thenioError(ioe_unk_error"setEcho""failed to set echoing")elsereturn()getEcho::FD->IOBoolgetEchofd=dor<-get_console_echofdif(r==(-1))thenioError(ioe_unk_error"getEcho""failed to get echoing")elsereturn(r==1)foreignimportccallunsafe"consUtils.h set_console_buffering__"set_console_buffering::CInt->CInt->IOCIntforeignimportccallunsafe"consUtils.h set_console_echo__"set_console_echo::CInt->CInt->IOCIntforeignimportccallunsafe"consUtils.h get_console_echo__"get_console_echo::CInt->IOCIntforeignimportccallunsafe"consUtils.h is_console__"is_console::CInt->IOCInt
#endif
-- ----------------------------------------------------------------------------- Turning on non-blocking for a file descriptorsetNonBlockingFD ::FD ->Bool ->IO ()
#if !defined(mingw32_HOST_OS)
setNonBlockingFD :: CInt -> Bool -> IO ()
setNonBlockingFD CInt
fd Bool
set =doCInt
flags <-forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"setNonBlockingFD"(CInt -> CInt -> IO CInt
c_fcntl_read CInt
fd CInt
const_f_getfl )letflags' :: CInt
flags' |Bool
set =CInt
flags forall a. Bits a => a -> a -> a
.|. CInt
o_NONBLOCK |Bool
otherwise =CInt
flags forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> a
complement CInt
o_NONBLOCK forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
flags forall a. Eq a => a -> a -> Bool
/= CInt
flags' )forall a b. (a -> b) -> a -> b
$ do-- An error when setting O_NONBLOCK isn't fatal: on some systems-- there are certain file handles on which this will fail (eg. /dev/null-- on FreeBSD) so we throw away the return code from fcntl_write.CInt
_<-CInt -> CInt -> CLong -> IO CInt
c_fcntl_write CInt
fd CInt
const_f_setfl (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
flags' )forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
-- bogus defns for win32setNonBlockingFD__=return()
#endif
-- ------------------------------------------------------------------------------- Set close-on-exec for a file descriptor
#if !defined(mingw32_HOST_OS)
setCloseOnExec ::FD ->IO ()setCloseOnExec :: CInt -> IO ()
setCloseOnExec CInt
fd =forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"setCloseOnExec"forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> CLong -> IO CInt
c_fcntl_write CInt
fd CInt
const_f_setfd CLong
const_fd_cloexec 
#endif
-- ------------------------------------------------------------------------------- foreign imports
#if !defined(mingw32_HOST_OS)
typeCFilePath =CString 
#else
typeCFilePath=CWString
#endif
foreignimportccallunsafe"HsBase.h __hscore_open"c_open ::CFilePath ->CInt ->CMode ->IO CInt -- | The same as 'c_safe_open', but an /interruptible operation/-- as described in "Control.Exception"—it respects `uninterruptibleMask`-- but not `mask`.---- We want to be able to interrupt an openFile call if-- it's expensive (NFS, FUSE, etc.), and we especially-- need to be able to interrupt a blocking open call.-- See #17912.c_interruptible_open ::CFilePath ->CInt ->CMode ->IO CInt c_interruptible_open :: Ptr CChar -> CInt -> CMode -> IO CInt
c_interruptible_open Ptr CChar
filepath CInt
oflags CMode
mode =IO MaskingState
getMaskingState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case-- If we're in an uninterruptible mask, there's basically-- no point in using an interruptible FFI call. The open system call-- will be interrupted, but the exception won't be delivered-- unless the caller manually futzes with the masking state. So-- then the caller (assuming they're following the usual conventions)-- will retry the call (in response to EINTR), and we've just-- wasted everyone's time.MaskingState
MaskedUninterruptible ->Ptr CChar -> CInt -> CMode -> IO CInt
c_safe_open_ Ptr CChar
filepath CInt
oflags CMode
mode MaskingState
_->doCInt
open_res <-Ptr CChar -> CInt -> CMode -> IO CInt
c_interruptible_open_ Ptr CChar
filepath CInt
oflags CMode
mode -- c_interruptible_open_ is an interruptible foreign call.-- If the call is interrupted by an exception handler-- before the system call has returned (so the file is-- not yet open), we want to deliver the exception.-- In point of fact, we deliver any pending exception-- here regardless of the *reason* the system call-- fails.forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
open_res forall a. Eq a => a -> a -> Bool
== -CInt
1)forall a b. (a -> b) -> a -> b
$ ifBool
hostIsThreaded then-- Control.Exception.allowInterrupt, inlined to avoid-- messing with any Haddock links.forall a. IO a -> IO a
interruptible (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())else-- Try to make this work somewhat better on the non-threaded-- RTS. See #8684. This inlines the definition of `yield`; module-- dependencies look pretty hairy here and I don't want to make-- things worse for one little wrapper.forall a. IO a -> IO a
interruptible (forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->(#State# RealWorld -> State# RealWorld
yield# State# RealWorld
s ,()#))forall (f :: * -> *) a. Applicative f => a -> f a
pure CInt
open_res foreignimportccallinterruptible"HsBase.h __hscore_open"c_interruptible_open_ ::CFilePath ->CInt ->CMode ->IO CInt -- | Consult the RTS to find whether it is threaded.hostIsThreaded ::Bool hostIsThreaded :: Bool
hostIsThreaded =Int
rtsIsThreaded_ forall a. Eq a => a -> a -> Bool
/= Int
0foreignimportccallunsafe"rts_isThreaded"rtsIsThreaded_ ::Int c_safe_open ::CFilePath ->CInt ->CMode ->IO CInt c_safe_open :: Ptr CChar -> CInt -> CMode -> IO CInt
c_safe_open Ptr CChar
filepath CInt
oflags CMode
mode =IO MaskingState
getMaskingState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case-- When exceptions are unmasked, we use an interruptible-- open call. If the system call is successfully-- interrupted, the situation will be the same as if-- the exception had arrived before this function was-- called.MaskingState
Unmasked ->Ptr CChar -> CInt -> CMode -> IO CInt
c_interruptible_open_ Ptr CChar
filepath CInt
oflags CMode
mode MaskingState
_->Ptr CChar -> CInt -> CMode -> IO CInt
c_safe_open_ Ptr CChar
filepath CInt
oflags CMode
mode foreignimportccallsafe"HsBase.h __hscore_open"c_safe_open_ ::CFilePath ->CInt ->CMode ->IO CInt foreignimportccallunsafe"HsBase.h __hscore_fstat"c_fstat ::CInt ->Ptr CStat ->IO CInt foreignimportccallunsafe"HsBase.h __hscore_lstat"lstat ::CFilePath ->Ptr CStat ->IO CInt {- Note: Win32 POSIX functions
Functions that are not part of the POSIX standards were
at some point deprecated by Microsoft. This deprecation
was performed by renaming the functions according to the
C++ ABI Section 17.6.4.3.2b. This was done to free up the
namespace of normal Windows programs since Windows isn't
POSIX compliant anyway.
These were working before since the RTS was re-exporting
these symbols under the undeprecated names. This is no longer
being done. See #11223
See https://msdn.microsoft.com/en-us/library/ms235384.aspx
for more.
However since we can't hope to get people to support Windows
packages we should support the deprecated names. See #12497
-}foreignimportcapiunsafe"unistd.h lseek"c_lseek ::CInt ->COff ->CInt ->IO COff foreignimportccallunsafe"HsBase.h access"c_access ::CString ->CInt ->IO CInt foreignimportccallunsafe"HsBase.h chmod"c_chmod ::CString ->CMode ->IO CInt foreignimportccallunsafe"HsBase.h close"c_close ::CInt ->IO CInt foreignimportccallunsafe"HsBase.h creat"c_creat ::CString ->CMode ->IO CInt foreignimportccallunsafe"HsBase.h dup"c_dup ::CInt ->IO CInt foreignimportccallunsafe"HsBase.h dup2"c_dup2 ::CInt ->CInt ->IO CInt foreignimportccallunsafe"HsBase.h isatty"c_isatty ::CInt ->IO CInt 
#if defined(mingw32_HOST_OS)
-- See Note: Windows typesforeignimportcapiunsafe"HsBase.h _read"c_read::CInt->PtrWord8->CUInt->IOCInt-- See Note: Windows typesforeignimportcapisafe"HsBase.h _read"c_safe_read::CInt->PtrWord8->CUInt->IOCIntforeignimportccallunsafe"HsBase.h _umask"c_umask::CMode->IOCMode-- See Note: Windows typesforeignimportcapiunsafe"HsBase.h _write"c_write::CInt->PtrWord8->CUInt->IOCInt-- See Note: Windows typesforeignimportcapisafe"HsBase.h _write"c_safe_write::CInt->PtrWord8->CUInt->IOCIntforeignimportccallunsafe"HsBase.h _pipe"c_pipe::PtrCInt->IOCInt
#else
-- We use CAPI as on some OSs (eg. Linux) this is wrapped by a macro-- which redirects to the 64-bit-off_t versions when large file-- support is enabled.-- See Note: Windows typesforeignimportcapiunsafe"HsBase.h read"c_read ::CInt ->Ptr Word8 ->CSize ->IO CSsize -- See Note: Windows typesforeignimportcapisafe"HsBase.h read"c_safe_read ::CInt ->Ptr Word8 ->CSize ->IO CSsize foreignimportccallunsafe"HsBase.h umask"c_umask ::CMode ->IO CMode -- See Note: Windows typesforeignimportcapiunsafe"HsBase.h write"c_write ::CInt ->Ptr Word8 ->CSize ->IO CSsize -- See Note: Windows typesforeignimportcapisafe"HsBase.h write"c_safe_write ::CInt ->Ptr Word8 ->CSize ->IO CSsize foreignimportccallunsafe"HsBase.h pipe"c_pipe ::Ptr CInt ->IO CInt 
#endif
foreignimportccallunsafe"HsBase.h unlink"c_unlink ::CString ->IO CInt foreignimportcapiunsafe"HsBase.h utime"c_utime ::CString ->Ptr CUtimbuf ->IO CInt foreignimportccallunsafe"HsBase.h getpid"c_getpid ::IO CPid foreignimportccallunsafe"HsBase.h __hscore_stat"c_stat ::CFilePath ->Ptr CStat ->IO CInt foreignimportccallunsafe"HsBase.h __hscore_ftruncate"c_ftruncate ::CInt ->COff ->IO CInt 
#if !defined(mingw32_HOST_OS)
foreignimportcapiunsafe"HsBase.h fcntl"c_fcntl_read ::CInt ->CInt ->IO CInt foreignimportcapiunsafe"HsBase.h fcntl"c_fcntl_write ::CInt ->CInt ->CLong ->IO CInt foreignimportcapiunsafe"HsBase.h fcntl"c_fcntl_lock ::CInt ->CInt ->Ptr CFLock ->IO CInt foreignimportccallunsafe"HsBase.h fork"c_fork ::IO CPid foreignimportccallunsafe"HsBase.h link"c_link ::CString ->CString ->IO CInt -- capi is required at least on Androidforeignimportcapiunsafe"HsBase.h mkfifo"c_mkfifo ::CString ->CMode ->IO CInt foreignimportcapiunsafe"signal.h sigemptyset"c_sigemptyset ::Ptr CSigset ->IO CInt foreignimportcapiunsafe"signal.h sigaddset"c_sigaddset ::Ptr CSigset ->CInt ->IO CInt foreignimportcapiunsafe"signal.h sigprocmask"c_sigprocmask ::CInt ->Ptr CSigset ->Ptr CSigset ->IO CInt -- capi is required at least on Androidforeignimportcapiunsafe"HsBase.h tcgetattr"c_tcgetattr ::CInt ->Ptr CTermios ->IO CInt -- capi is required at least on Androidforeignimportcapiunsafe"HsBase.h tcsetattr"c_tcsetattr ::CInt ->CInt ->Ptr CTermios ->IO CInt foreignimportccallunsafe"HsBase.h waitpid"c_waitpid ::CPid ->Ptr CInt ->CInt ->IO CPid 
#endif
-- POSIX flags only:foreignimportccallunsafe"HsBase.h __hscore_o_rdonly"o_RDONLY ::CInt foreignimportccallunsafe"HsBase.h __hscore_o_wronly"o_WRONLY ::CInt foreignimportccallunsafe"HsBase.h __hscore_o_rdwr"o_RDWR ::CInt foreignimportccallunsafe"HsBase.h __hscore_o_append"o_APPEND ::CInt foreignimportccallunsafe"HsBase.h __hscore_o_creat"o_CREAT ::CInt foreignimportccallunsafe"HsBase.h __hscore_o_excl"o_EXCL ::CInt foreignimportccallunsafe"HsBase.h __hscore_o_trunc"o_TRUNC ::CInt -- non-POSIX flags.foreignimportccallunsafe"HsBase.h __hscore_o_noctty"o_NOCTTY ::CInt foreignimportccallunsafe"HsBase.h __hscore_o_nonblock"o_NONBLOCK ::CInt foreignimportccallunsafe"HsBase.h __hscore_o_binary"o_BINARY ::CInt foreignimportcapiunsafe"sys/stat.h S_ISREG"c_s_isreg ::CMode ->CInt foreignimportcapiunsafe"sys/stat.h S_ISCHR"c_s_ischr ::CMode ->CInt foreignimportcapiunsafe"sys/stat.h S_ISBLK"c_s_isblk ::CMode ->CInt foreignimportcapiunsafe"sys/stat.h S_ISDIR"c_s_isdir ::CMode ->CInt foreignimportcapiunsafe"sys/stat.h S_ISFIFO"c_s_isfifo ::CMode ->CInt s_isreg ::CMode ->Bool s_isreg :: CMode -> Bool
s_isreg CMode
cm =CMode -> CInt
c_s_isreg CMode
cm forall a. Eq a => a -> a -> Bool
/= CInt
0s_ischr ::CMode ->Bool s_ischr :: CMode -> Bool
s_ischr CMode
cm =CMode -> CInt
c_s_ischr CMode
cm forall a. Eq a => a -> a -> Bool
/= CInt
0s_isblk ::CMode ->Bool s_isblk :: CMode -> Bool
s_isblk CMode
cm =CMode -> CInt
c_s_isblk CMode
cm forall a. Eq a => a -> a -> Bool
/= CInt
0s_isdir ::CMode ->Bool s_isdir :: CMode -> Bool
s_isdir CMode
cm =CMode -> CInt
c_s_isdir CMode
cm forall a. Eq a => a -> a -> Bool
/= CInt
0s_isfifo ::CMode ->Bool s_isfifo :: CMode -> Bool
s_isfifo CMode
cm =CMode -> CInt
c_s_isfifo CMode
cm forall a. Eq a => a -> a -> Bool
/= CInt
0foreignimportccallunsafe"HsBase.h __hscore_sizeof_stat"sizeof_stat ::Int foreignimportccallunsafe"HsBase.h __hscore_st_mtime"st_mtime ::Ptr CStat ->IO CTime 
#if defined(mingw32_HOST_OS)
foreignimportccallunsafe"HsBase.h __hscore_st_size"st_size::PtrCStat->IOInt64
#else
foreignimportccallunsafe"HsBase.h __hscore_st_size"st_size ::Ptr CStat ->IO COff 
#endif
foreignimportccallunsafe"HsBase.h __hscore_st_mode"st_mode ::Ptr CStat ->IO CMode foreignimportccallunsafe"HsBase.h __hscore_st_dev"st_dev ::Ptr CStat ->IO CDev foreignimportccallunsafe"HsBase.h __hscore_st_ino"st_ino ::Ptr CStat ->IO CIno foreignimportccallunsafe"HsBase.h __hscore_echo"const_echo ::CInt foreignimportccallunsafe"HsBase.h __hscore_tcsanow"const_tcsanow ::CInt foreignimportccallunsafe"HsBase.h __hscore_icanon"const_icanon ::CInt foreignimportccallunsafe"HsBase.h __hscore_vmin"const_vmin ::CInt foreignimportccallunsafe"HsBase.h __hscore_vtime"const_vtime ::CInt foreignimportccallunsafe"HsBase.h __hscore_sigttou"const_sigttou ::CInt foreignimportccallunsafe"HsBase.h __hscore_sig_block"const_sig_block ::CInt foreignimportccallunsafe"HsBase.h __hscore_sig_setmask"const_sig_setmask ::CInt foreignimportccallunsafe"HsBase.h __hscore_f_getfl"const_f_getfl ::CInt foreignimportccallunsafe"HsBase.h __hscore_f_setfl"const_f_setfl ::CInt foreignimportccallunsafe"HsBase.h __hscore_f_setfd"const_f_setfd ::CInt foreignimportccallunsafe"HsBase.h __hscore_fd_cloexec"const_fd_cloexec ::CLong 
#if defined(HTYPE_TCFLAG_T)
foreignimportccallunsafe"HsBase.h __hscore_sizeof_termios"sizeof_termios ::Int foreignimportccallunsafe"HsBase.h __hscore_sizeof_sigset_t"sizeof_sigset_t ::Int foreignimportccallunsafe"HsBase.h __hscore_lflag"c_lflag ::Ptr CTermios ->IO CTcflag foreignimportccallunsafe"HsBase.h __hscore_poke_lflag"poke_c_lflag ::Ptr CTermios ->CTcflag ->IO ()foreignimportccallunsafe"HsBase.h __hscore_ptr_c_cc"ptr_c_cc ::Ptr CTermios ->IO (Ptr Word8 )
#endif
s_issock ::CMode ->Bool 
#if !defined(mingw32_HOST_OS)
s_issock :: CMode -> Bool
s_issock CMode
cmode =CMode -> CInt
c_s_issock CMode
cmode forall a. Eq a => a -> a -> Bool
/= CInt
0foreignimportcapiunsafe"sys/stat.h S_ISSOCK"c_s_issock ::CMode ->CInt 
#else
s_issock_=False
#endif
foreignimportccallunsafe"__hscore_bufsiz"dEFAULT_BUFFER_SIZE ::Int foreignimportcapiunsafe"stdio.h value SEEK_CUR"sEEK_CUR ::CInt foreignimportcapiunsafe"stdio.h value SEEK_SET"sEEK_SET ::CInt foreignimportcapiunsafe"stdio.h value SEEK_END"sEEK_END ::CInt {-
Note: Windows types
Windows' _read and _write have types that differ from POSIX. They take an
unsigned int for length and return a signed int where POSIX uses size_t and
ssize_t. Those are different on x86_64 and equivalent on x86. We import them
with the types in Microsoft's documentation which means that c_read,
c_safe_read, c_write and c_safe_write have different Haskell types depending on
the OS.
-}