diff options
| -rw-r--r-- | libraries/base/GHC/Windows.hs | 168 | ||||
| -rw-r--r-- | libraries/base/System/Environment.hs | 2 | ||||
| -rw-r--r-- | libraries/base/cbits/Win32Utils.c | 69 | ||||
| -rw-r--r-- | libraries/base/include/HsBase.h | 1 |
4 files changed, 200 insertions, 40 deletions
diff --git a/libraries/base/GHC/Windows.hs b/libraries/base/GHC/Windows.hs index fa25f63e32..8316824f55 100644 --- a/libraries/base/GHC/Windows.hs +++ b/libraries/base/GHC/Windows.hs @@ -1,5 +1,7 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE NoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Windows @@ -19,30 +21,172 @@ ----------------------------------------------------------------------------- module GHC.Windows ( - HANDLE, DWORD, LPTSTR, iNFINITE, - throwGetLastError, c_maperrno - ) where + -- * Types + BOOL, + DWORD, + ErrCode, + HANDLE, + LPWSTR, + LPTSTR, -import GHC.Base -import GHC.Ptr + -- * Constants + iNFINITE, + iNVALID_HANDLE_VALUE, -import Data.Word + -- * System errors + throwGetLastError, + failWith, + getLastError, + getErrorMessage, + errCodeToIOError, + + -- ** Guards for system calls that might fail + failIf, + failIf_, + failIfNull, + failIfZero, + failIfFalse_, + failUnlessSuccess, + failUnlessSuccessOr, -import Foreign.C.Error (throwErrno) + -- ** Mapping system errors to errno + -- $errno + c_maperrno, + c_maperrno_func, + ) where + +import Data.Char +import Data.List +import Data.Maybe +import Data.Word +import Foreign.C.Error +import Foreign.C.String import Foreign.C.Types +import Foreign.Ptr +import GHC.Base +import GHC.IO +import GHC.Num +import System.IO.Error + +import qualified Numeric +#ifdef mingw32_HOST_OS +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif +#endif -type HANDLE = Ptr () -type DWORD = Word32 +type BOOL = Bool +type DWORD = Word32 +type ErrCode = DWORD +type HANDLE = Ptr () +type LPWSTR = Ptr CWchar -type LPTSTR = Ptr CWchar +-- | Be careful with this. LPTSTR can mean either WCHAR* or CHAR*, depending +-- on whether the UNICODE macro is defined in the corresponding C code. +-- Consider using LPWSTR instead. +type LPTSTR = LPWSTR iNFINITE :: DWORD iNFINITE = 0xFFFFFFFF -- urgh +iNVALID_HANDLE_VALUE :: HANDLE +iNVALID_HANDLE_VALUE = wordPtrToPtr (-1) + +-- | Get the last system error, and throw it as an 'IOError' exception. throwGetLastError :: String -> IO a -throwGetLastError where_from = c_maperrno >> throwErrno where_from +throwGetLastError where_from = + getLastError >>= failWith where_from + +-- | Convert a Windows error code to an exception, then throw it. +failWith :: String -> ErrCode -> IO a +failWith fn_name err_code = + errCodeToIOError fn_name err_code >>= throwIO + +-- | Convert a Windows error code to an exception. +errCodeToIOError :: String -> ErrCode -> IO IOError +errCodeToIOError fn_name err_code = do + msg <- getErrorMessage err_code + + -- turn GetLastError() into errno, which errnoToIOError knows + -- how to convert to an IOException we can throw. + -- XXX we should really do this directly. + let errno = c_maperrno_func err_code + + let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n + ioerror = errnoToIOError fn_name errno Nothing Nothing + `ioeSetErrorString` msg' + return ioerror +-- | Get a string describing a Windows error code. This uses the +-- @FormatMessage@ system call. +getErrorMessage :: ErrCode -> IO String +getErrorMessage err_code = + mask_ $ do + c_msg <- c_getErrorMessage err_code + if c_msg == nullPtr + then return $ "Error 0x" ++ Numeric.showHex err_code "" + else do msg <- peekCWString c_msg + -- We ignore failure of freeing c_msg, given we're already failing + _ <- localFree c_msg + return msg + +failIf :: (a -> Bool) -> String -> IO a -> IO a +failIf p wh act = do + v <- act + if p v then throwGetLastError wh else return v + +failIf_ :: (a -> Bool) -> String -> IO a -> IO () +failIf_ p wh act = do + v <- act + if p v then throwGetLastError wh else return () + +failIfNull :: String -> IO (Ptr a) -> IO (Ptr a) +failIfNull = failIf (== nullPtr) + +failIfZero :: (Eq a, Num a) => String -> IO a -> IO a +failIfZero = failIf (== 0) + +failIfFalse_ :: String -> IO Bool -> IO () +failIfFalse_ = failIf_ not + +failUnlessSuccess :: String -> IO ErrCode -> IO () +failUnlessSuccess fn_name act = do + r <- act + if r == 0 then return () else failWith fn_name r + +failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool +failUnlessSuccessOr val fn_name act = do + r <- act + if r == 0 then return False + else if r == val then return True + else failWith fn_name r + +-- $errno +-- +-- On Windows, @errno@ is defined by msvcrt.dll for compatibility with other +-- systems, and is distinct from the system error as returned +-- by @GetLastError@. + +-- | Map the last system error to an errno value, and assign it to @errno@. foreign import ccall unsafe "maperrno" -- in Win32Utils.c c_maperrno :: IO () +-- | Pure function variant of 'c_maperrno' that does not call @GetLastError@ +-- or modify @errno@. +foreign import ccall unsafe "maperrno_func" -- in Win32Utils.c + c_maperrno_func :: ErrCode -> Errno + +foreign import ccall unsafe "base_getErrorMessage" -- in Win32Utils.c + c_getErrorMessage :: DWORD -> IO LPWSTR + +foreign import WINDOWS_CCONV unsafe "windows.h LocalFree" + localFree :: Ptr a -> IO (Ptr a) + +-- | Get the last system error produced in the current thread. +foreign import WINDOWS_CCONV unsafe "windows.h GetLastError" + getLastError :: IO ErrCode diff --git a/libraries/base/System/Environment.hs b/libraries/base/System/Environment.hs index c74286f29d..184c910330 100644 --- a/libraries/base/System/Environment.hs +++ b/libraries/base/System/Environment.hs @@ -238,7 +238,7 @@ lookupEnv name = withCWString name $ \s -> try_size s 256 | otherwise -> peekCWString p_value >>= return . Just foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentVariableW" - c_GetEnvironmentVariable :: LPTSTR -> LPTSTR -> DWORD -> IO DWORD + c_GetEnvironmentVariable :: LPWSTR -> LPWSTR -> DWORD -> IO DWORD #else lookupEnv name = withCString name $ \s -> do diff --git a/libraries/base/cbits/Win32Utils.c b/libraries/base/cbits/Win32Utils.c index ecd54f32c2..7038cbf48e 100644 --- a/libraries/base/cbits/Win32Utils.c +++ b/libraries/base/cbits/Win32Utils.c @@ -80,34 +80,49 @@ static struct errentry errtable[] = { #define MIN_EACCES_RANGE ERROR_WRITE_PROTECT #define MAX_EACCES_RANGE ERROR_SHARING_BUFFER_EXCEEDED -void maperrno (void) +void maperrno(void) { - int i; - DWORD dwErrorCode; - - dwErrorCode = GetLastError(); - - /* check the table for the OS error code */ - for (i = 0; i < ERRTABLESIZE; ++i) - { - if (dwErrorCode == errtable[i].oscode) - { - errno = errtable[i].errnocode; - return; - } - } - - /* The error code wasn't in the table. We check for a range of */ - /* EACCES errors or exec failure errors (ENOEXEC). Otherwise */ - /* EINVAL is returned. */ - - if (dwErrorCode >= MIN_EACCES_RANGE && dwErrorCode <= MAX_EACCES_RANGE) - errno = EACCES; - else - if (dwErrorCode >= MIN_EXEC_ERROR && dwErrorCode <= MAX_EXEC_ERROR) - errno = ENOEXEC; - else - errno = EINVAL; + errno = maperrno_func(GetLastError()); +} + +int maperrno_func(DWORD dwErrorCode) +{ + int i; + + /* check the table for the OS error code */ + for (i = 0; i < ERRTABLESIZE; ++i) + if (dwErrorCode == errtable[i].oscode) + return errtable[i].errnocode; + + /* The error code wasn't in the table. We check for a range of */ + /* EACCES errors or exec failure errors (ENOEXEC). Otherwise */ + /* EINVAL is returned. */ + + if (dwErrorCode >= MIN_EACCES_RANGE && dwErrorCode <= MAX_EACCES_RANGE) + return EACCES; + else if (dwErrorCode >= MIN_EXEC_ERROR && dwErrorCode <= MAX_EXEC_ERROR) + return ENOEXEC; + else + return EINVAL; +} + +LPWSTR base_getErrorMessage(DWORD err) +{ + LPWSTR what; + DWORD res; + + res = FormatMessageW( + (FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER), + NULL, + err, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), /* Default language */ + (LPWSTR) &what, + 0, + NULL + ); + if (res == 0) + return NULL; + return what; } int get_unique_file_info(int fd, HsWord64 *dev, HsWord64 *ino) diff --git a/libraries/base/include/HsBase.h b/libraries/base/include/HsBase.h index 74ab816d84..b1a62fd131 100644 --- a/libraries/base/include/HsBase.h +++ b/libraries/base/include/HsBase.h @@ -141,6 +141,7 @@ #if defined(__MINGW32__) /* in Win32Utils.c */ extern void maperrno (void); +extern int maperrno_func(DWORD dwErrorCode); extern HsWord64 getMonotonicUSec(void); #endif |