-- (c) The FFI task force, 2000
--
-- C-specific Marshalling support: Handling of C "errno" error codes
module CError (
-- Haskell representation for "errno" values
--
Errno(..), -- instance: Eq
eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,
eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED,
eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT,
eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ,
eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK,
eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH,
eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK,
eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS,
eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO,
eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL,
ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE,
eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN,
eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT,
eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV,
-- :: Errno
isValidErrno, -- :: Errno -> Bool
-- access to the current thread's "errno" value
--
getErrno, -- :: IO Errno
resetErrno, -- :: IO ()
-- conversion of an "errno" value into IO error
--
errnoToIOError, -- :: String -- location
-- -> Errno -- errno
-- -> Maybe Handle -- handle
-- -> Maybe String -- filename
-- -> IOError
-- throw current "errno" value
--
throwErrno, -- :: String -> IO a
-- guards for IO operations that may fail
--
throwErrnoIf, -- :: (a -> Bool) -> String -> IO a -> IO a
throwErrnoIf_, -- :: (a -> Bool) -> String -> IO a -> IO ()
throwErrnoIfRetry, -- :: (a -> Bool) -> String -> IO a -> IO a
throwErrnoIfRetry_, -- :: (a -> Bool) -> String -> IO a -> IO ()
throwErrnoIfMinus1, -- :: Num a
-- => String -> IO a -> IO a
throwErrnoIfMinus1_, -- :: Num a
-- => String -> IO a -> IO ()
throwErrnoIfMinus1Retry,
-- :: Num a
-- => String -> IO a -> IO a
throwErrnoIfMinus1Retry_,
-- :: Num a
-- => String -> IO a -> IO ()
throwErrnoIfNull, -- :: String -> IO (Ptr a) -> IO (Ptr a)
throwErrnoIfNullRetry -- :: String -> IO (Ptr a) -> IO (Ptr a)
) where
-- regular imports
-- ---------------
import Monad (liftM)
import Ptr (Ptr, nullPtr)
import NewStorable (Storable(..))
import CTypes (CInt)
import MarshalError (void)
import IO (IOError, Handle, ioError)
-- "errno" type
-- ------------
-- import of address of C-level "errno" variable
--
foreign label "errno" _errno :: Ptr CInt
-- Haskell representation for "errno" values
--
newtype Errno = Errno CInt
instance Eq Errno where
errno1@(Errno no1) == errno2@(Errno no2)
| isValidErrno errno1 && isValidErrno errno2 = no1 == no2
| otherwise = False
-- common "errno" symbols
--
eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,
eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED,
eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT,
eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ,
eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK,
eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH,
eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK,
eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS,
eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO,
eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL,
ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE,
eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN,
eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT,
eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV :: Errno
--
-- the @CCONST_XXX@ identifiers have to replaced by the appropriate
-- system-dependent values
--
eOK = Errno 0
e2BIG = Errno (@CCONST_E2BIG@)
eACCES = Errno (@CCONST_EACCES@)
eADDRINUSE = Errno (@CCONST_EADDRINUSE@)
eADDRNOTAVAIL = Errno (@CCONST_EADDRNOTAVAIL@)
eADV = Errno (@CCONST_EADV@)
eAFNOSUPPORT = Errno (@CCONST_EAFNOSUPPORT@)
eAGAIN = Errno (@CCONST_EAGAIN@)
eALREADY = Errno (@CCONST_EALREADY@)
eBADF = Errno (@CCONST_EBADF@)
eBADMSG = Errno (@CCONST_EBADMSG@)
eBADRPC = Errno (@CCONST_EBADRPC@)
eBUSY = Errno (@CCONST_EBUSY@)
eCHILD = Errno (@CCONST_ECHILD@)
eCOMM = Errno (@CCONST_ECOMM@)
eCONNABORTED = Errno (@CCONST_ECONNABORTED@)
eCONNREFUSED = Errno (@CCONST_ECONNREFUSED@)
eCONNRESET = Errno (@CCONST_ECONNRESET@)
eDEADLK = Errno (@CCONST_EDEADLK@)
eDESTADDRREQ = Errno (@CCONST_EDESTADDRREQ@)
eDIRTY = Errno (@CCONST_EDIRTY@)
eDOM = Errno (@CCONST_EDOM@)
eDQUOT = Errno (@CCONST_EDQUOT@)
eEXIST = Errno (@CCONST_EEXIST@)
eFAULT = Errno (@CCONST_EFAULT@)
eFBIG = Errno (@CCONST_EFBIG@)
eFTYPE = Errno (@CCONST_EFTYPE@)
eHOSTDOWN = Errno (@CCONST_EHOSTDOWN@)
eHOSTUNREACH = Errno (@CCONST_EHOSTUNREACH@)
eIDRM = Errno (@CCONST_EIDRM@)
eILSEQ = Errno (@CCONST_EILSEQ@)
eINPROGRESS = Errno (@CCONST_EINPROGRESS@)
eINTR = Errno (@CCONST_EINTR@)
eINVAL = Errno (@CCONST_EINVAL@)
eIO = Errno (@CCONST_EIO@)
eISCONN = Errno (@CCONST_EISCONN@)
eISDIR = Errno (@CCONST_EISDIR@)
eLOOP = Errno (@CCONST_ELOOP@)
eMFILE = Errno (@CCONST_EMFILE@)
eMLINK = Errno (@CCONST_EMLINK@)
eMSGSIZE = Errno (@CCONST_EMSGSIZE@)
eMULTIHOP = Errno (@CCONST_EMULTIHOP@)
eNAMETOOLONG = Errno (@CCONST_ENAMETOOLONG@)
eNETDOWN = Errno (@CCONST_ENETDOWN@)
eNETRESET = Errno (@CCONST_ENETRESET@)
eNETUNREACH = Errno (@CCONST_ENETUNREACH@)
eNFILE = Errno (@CCONST_ENFILE@)
eNOBUFS = Errno (@CCONST_ENOBUFS@)
eNODATA = Errno (@CCONST_ENODATA@)
eNODEV = Errno (@CCONST_ENODEV@)
eNOENT = Errno (@CCONST_ENOENT@)
eNOEXEC = Errno (@CCONST_ENOEXEC@)
eNOLCK = Errno (@CCONST_ENOLCK@)
eNOLINK = Errno (@CCONST_ENOLINK@)
eNOMEM = Errno (@CCONST_ENOMEM@)
eNOMSG = Errno (@CCONST_ENOMSG@)
eNONET = Errno (@CCONST_ENONET@)
eNOPROTOOPT = Errno (@CCONST_ENOPROTOOPT@)
eNOSPC = Errno (@CCONST_ENOSPC@)
eNOSR = Errno (@CCONST_ENOSR@)
eNOSTR = Errno (@CCONST_ENOSTR@)
eNOSYS = Errno (@CCONST_ENOSYS@)
eNOTBLK = Errno (@CCONST_ENOTBLK@)
eNOTCONN = Errno (@CCONST_ENOTCONN@)
eNOTDIR = Errno (@CCONST_ENOTDIR@)
eNOTEMPTY = Errno (@CCONST_ENOTEMPTY@)
eNOTSOCK = Errno (@CCONST_ENOTSOCK@)
eNOTTY = Errno (@CCONST_ENOTTY@)
eNXIO = Errno (@CCONST_ENXIO@)
eOPNOTSUPP = Errno (@CCONST_EOPNOTSUPP@)
ePERM = Errno (@CCONST_EPERM@)
ePFNOSUPPORT = Errno (@CCONST_EPFNOSUPPORT@)
ePIPE = Errno (@CCONST_EPIPE@)
ePROCLIM = Errno (@CCONST_EPROCLIM@)
ePROCUNAVAIL = Errno (@CCONST_EPROCUNAVAIL@)
ePROGMISMATCH = Errno (@CCONST_EPROGMISMATCH@)
ePROGUNAVAIL = Errno (@CCONST_EPROGUNAVAIL@)
ePROTO = Errno (@CCONST_EPROTO@)
ePROTONOSUPPORT = Errno (@CCONST_EPROTONOSUPPORT@)
ePROTOTYPE = Errno (@CCONST_EPROTOTYPE@)
eRANGE = Errno (@CCONST_ERANGE@)
eREMCHG = Errno (@CCONST_EREMCHG@)
eREMOTE = Errno (@CCONST_EREMOTE@)
eROFS = Errno (@CCONST_EROFS@)
eRPCMISMATCH = Errno (@CCONST_ERPCMISMATCH@)
eRREMOTE = Errno (@CCONST_ERREMOTE@)
eSHUTDOWN = Errno (@CCONST_ESHUTDOWN@)
eSOCKTNOSUPPORT = Errno (@CCONST_ESOCKTNOSUPPORT@)
eSPIPE = Errno (@CCONST_ESPIPE@)
eSRCH = Errno (@CCONST_ESRCH@)
eSRMNT = Errno (@CCONST_ESRMNT@)
eSTALE = Errno (@CCONST_ESTALE@)
eTIME = Errno (@CCONST_ETIME@)
eTIMEDOUT = Errno (@CCONST_ETIMEDOUT@)
eTOOMANYREFS = Errno (@CCONST_ETOOMANYREFS@)
eTXTBSY = Errno (@CCONST_ETXTBSY@)
eUSERS = Errno (@CCONST_EUSERS@)
eWOULDBLOCK = Errno (@CCONST_EWOULDBLOCK@)
eXDEV = Errno (@CCONST_EXDEV@)
-- checks whether the given errno value is supported on the current
-- architecture
--
isValidErrno :: Errno -> Bool
--
-- the configure script sets all invalid "errno"s to -1
--
isValidErrno (Errno errno) = errno /= -1
-- access to the current thread's "errno" value
-- --------------------------------------------
-- yield the current thread's "errno" value
--
getErrno :: IO Errno
getErrno = liftM Errno (peek _errno)
-- set the current thread's "errno" value to 0
--
resetErrno :: IO ()
resetErrno = poke _errno 0
-- throw current "errno" value
-- ---------------------------
-- the common case: throw an IO error based on a textual description
-- of the error location and the current thread's "errno" value
--
throwErrno :: String -> IO a
throwErrno loc =
do
errno <- getErrno
ioError (errnoToIOError loc errno Nothing Nothing)
-- guards for IO operations that may fail
-- --------------------------------------
-- guard an IO operation and throw an "errno" based exception of the result
-- value of the IO operation meets the given predicate
--
throwErrnoIf :: (a -> Bool) -> String -> IO a -> IO a
throwErrnoIf pred loc f =
do
res <- f
if pred res then throwErrno loc else return res
-- as `throwErrnoIf', but discards the result
--
throwErrnoIf_ :: (a -> Bool) -> String -> IO a -> IO ()
throwErrnoIf_ pred loc f = void $ throwErrnoIf pred loc f
-- as `throwErrnoIf', but retries interrupted IO operations (ie, those whose
-- flag `EINTR')
--
throwErrnoIfRetry :: (a -> Bool) -> String -> IO a -> IO a
throwErrnoIfRetry pred loc f =
do
res <- f
if pred res
then do
err <- getErrno
if err == eINTR
then throwErrnoIfRetry pred loc f
else throwErrno loc
else return res
-- as `throwErrnoIfRetry', but discards the result
--
throwErrnoIfRetry_ :: (a -> Bool) -> String -> IO a -> IO ()
throwErrnoIfRetry_ pred loc f = void $ throwErrnoIfRetry pred loc f
-- throws "errno" if a result of "-1" is returned
--
throwErrnoIfMinus1 :: Num a => String -> IO a -> IO a
throwErrnoIfMinus1 = throwErrnoIf (== -1)
-- as `throwErrnoIfMinus1', but discards the result
--
throwErrnoIfMinus1_ :: Num a => String -> IO a -> IO ()
throwErrnoIfMinus1_ = throwErrnoIf_ (== -1)
-- throws "errno" if a result of "-1" is returned, but retries in case of an
-- interrupted operation
--
throwErrnoIfMinus1Retry :: Num a => String -> IO a -> IO a
throwErrnoIfMinus1Retry = throwErrnoIfRetry (== -1)
-- as `throwErrnoIfMinus1', but discards the result
--
throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ = throwErrnoIfRetry_ (== -1)
-- throws "errno" if a result of a NULL pointer is returned
--
throwErrnoIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
throwErrnoIfNull = throwErrnoIf (== nullPtr)
-- throws "errno" if a result of a NULL pointer is returned, but retries in
-- case of an interrupted operation
--
throwErrnoIfNullRetry :: String -> IO (Ptr a) -> IO (Ptr a)
throwErrnoIfNullRetry = throwErrnoIfRetry (== nullPtr)
-- conversion of an "errno" value into IO error
-- --------------------------------------------
-- convert a location string, an "errno" value, an optional handle,
-- and an optional filename into a matching IO error
--
errnoToIOError :: String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError loc errno@(Errno no) maybeHdl maybeName =
userError (loc ++ ": " ++ str ++ maybe "" (": "++) maybeName)
where
str
| errno == eOK = "no error"
| errno == e2BIG = "argument list too long"
| errno == eACCES = "inadequate access permission"
| errno == eADDRINUSE = "address already in use"
| errno == eADDRNOTAVAIL = "address not available"
| errno == eADV = "RFS advertise error"
| errno == eAFNOSUPPORT = "address family not supported by \
\protocol family"
| errno == eAGAIN = "insufficient resources"
| errno == eALREADY = "operation already in progress"
| errno == eBADF = "internal error (EBADF)"
| errno == eBADMSG = "next message has wrong type"
| errno == eBADRPC = "invalid RPC request or response"
| errno == eBUSY = "device busy"
| errno == eCHILD = "no child processes"
| errno == eCOMM = "no virtual circuit could be found"
| errno == eCONNABORTED = "aborted connection"
| errno == eCONNREFUSED = "no listener on remote host"
| errno == eCONNRESET = "connection reset by peer"
| errno == eDEADLK = "resource deadlock avoided"
| errno == eDESTADDRREQ = "destination address required"
| errno == eDIRTY = "file system dirty"
| errno == eDOM = "argument too large"
| errno == eDQUOT = "quota exceeded"
| errno == eEXIST = "file already exists"
| errno == eFAULT = "internal error (EFAULT)"
| errno == eFBIG = "file too large"
| errno == eFTYPE = "inappropriate NFS file type or format"
| errno == eHOSTDOWN = "destination host down"
| errno == eHOSTUNREACH = "remote host is unreachable"
| errno == eIDRM = "IPC identifier removed"
| errno == eILSEQ = "invalid wide character"
| errno == eINPROGRESS = "operation now in progress"
| errno == eINTR = "interrupted system call"
| errno == eINVAL = "invalid argument"
| errno == eIO = "unknown I/O fault"
| errno == eISCONN = "socket is already connected"
| errno == eISDIR = "file is a directory"
| errno == eLOOP = "too many symbolic links"
| errno == eMFILE = "process file table full"
| errno == eMLINK = "too many links"
| errno == eMSGSIZE = "message too long"
| errno == eMULTIHOP = "multi-hop RFS request"
| errno == eNAMETOOLONG = "filename too long"
| errno == eNETDOWN = "network is down"
| errno == eNETRESET = "remote host rebooted; connection lost"
| errno == eNETUNREACH = "remote network is unreachable"
| errno == eNFILE = "system file table full"
| errno == eNOBUFS = "no buffer space available"
| errno == eNODATA = "no message on the stream head read queue"
| errno == eNODEV = "no such device"
| errno == eNOENT = "no such file or directory"
| errno == eNOEXEC = "not an executable file"
| errno == eNOLCK = "no file locks available"
| errno == eNOLINK = "RFS link has been severed"
| errno == eNOMEM = "not enough virtual memory"
| errno == eNOMSG = "no message of desired type"
| errno == eNONET = "host is not on a network"
| errno == eNOPROTOOPT = "operation not supported by protocol"
| errno == eNOSPC = "no space left on device"
| errno == eNOSR = "out of stream resources"
| errno == eNOSTR = "not a stream device"
| errno == eNOSYS = "function not implemented"
| errno == eNOTBLK = "not a block device"
| errno == eNOTCONN = "socket is not connected"
| errno == eNOTDIR = "not a directory"
| errno == eNOTEMPTY = "directory not empty"
| errno == eNOTSOCK = "not a socket"
| errno == eNOTTY = "inappropriate ioctl for device"
| errno == eNXIO = "no such device or address"
| errno == eOPNOTSUPP = "operation not supported on socket"
| errno == ePERM = "privileged operation"
| errno == ePFNOSUPPORT = "protocol family not supported"
| errno == ePIPE = "broken pipe"
| errno == ePROCLIM = "too many processes"
| errno == ePROCUNAVAIL = "unimplemented RPC procedure"
| errno == ePROGMISMATCH = "unsupported RPC program version"
| errno == ePROGUNAVAIL = "RPC program unavailable"
| errno == ePROTO = "error in streams protocol"
| errno == ePROTONOSUPPORT = "protocol not supported"
| errno == ePROTOTYPE = "wrong protocol for socket"
| errno == eRANGE = "result too large"
| errno == eREMCHG = "remote address changed"
| errno == eREMOTE = "too many levels of remote in path"
| errno == eROFS = "read-only file system"
| errno == eRPCMISMATCH = "RPC version is wrong"
| errno == eRREMOTE = "object is remote"
| errno == eSHUTDOWN = "can't send after socket shutdown"
| errno == eSOCKTNOSUPPORT = "socket type not supported"
| errno == eSPIPE = "can't seek on a pipe"
| errno == eSRCH = "no such process"
| errno == eSRMNT = "RFS resources still mounted by \
\remote host(s)")
| errno == eSTALE = "stale NFS file handle"
| errno == eTIME = "timer expired"
| errno == eTIMEDOUT = "connection timed out"
| errno == eTOOMANYREFS = "too many references; can't splice"
| errno == eTXTBSY = "text file in-use"
| errno == eUSERS = "quota table full"
| errno == eWOULDBLOCK = "operation would block"
| errno == eXDEV = "can't make a cross-device link"
| otherwise = "unexpected error (error code: "
++ show no ++ ")"
