Ticket #7353: 0001-GHC.Windows-more-error-support-guards-system-error-s.patch

File 0001-GHC.Windows-more-error-support-guards-system-error-s.patch, 8.0 KB (added by joeyadams, 3 years ago)

Patch for base that extends GHC.Windows (mostly error code stuff)

  • GHC/Windows.hs

    From 7f9bd4d7d04f4c9c99c0b52077c145b8255ab029 Mon Sep 17 00:00:00 2001
    From: Joey Adams <[email protected]>
    Date: Mon, 12 Nov 2012 21:48:08 -0500
    Subject: [PATCH] GHC.Windows: more error support (guards, system error
     strings)
    
    ---
     GHC/Windows.hs     | 149 ++++++++++++++++++++++++++++++++++++++++++++++++-----
     cbits/Win32Utils.c |  69 +++++++++++++++----------
     include/HsBase.h   |   1 +
     3 files changed, 180 insertions(+), 39 deletions(-)
    
    diff --git a/GHC/Windows.hs b/GHC/Windows.hs
    index fa25f63..fbcf97e 100644
    a b  
    11{-# LANGUAGE Trustworthy #-}
    2 {-# LANGUAGE NoImplicitPrelude, ForeignFunctionInterface #-}
     2{-# LANGUAGE CPP #-}
     3{-# LANGUAGE ForeignFunctionInterface #-}
     4{-# LANGUAGE NoImplicitPrelude #-}
    35-----------------------------------------------------------------------------
    46-- |
    57-- Module      :  GHC.Windows
     
    1921-----------------------------------------------------------------------------
    2022
    2123module GHC.Windows (
    22         HANDLE, DWORD, LPTSTR, iNFINITE,
    23         throwGetLastError, c_maperrno
    24     ) where
     24        -- * Types
     25        BOOL,
     26        DWORD,
     27        ErrCode,
     28        HANDLE,
     29        LPWSTR,
     30        LPTSTR,
    2531
    26 import GHC.Base
    27 import GHC.Ptr
     32        -- * Constants
     33        iNFINITE,
     34        iNVALID_HANDLE_VALUE,
    2835
    29 import Data.Word
     36        -- * System errors
     37        throwGetLastError,
     38        c_maperrno,
     39        c_maperrno_func,
     40        getErrorMessage,
     41        getLastError,
     42        errCodeToIOError,
     43        failWith,
    3044
    31 import Foreign.C.Error (throwErrno)
     45        -- ** Guards for system calls that might fail
     46        failIf,
     47        failIf_,
     48        failIfNull,
     49        failIfZero,
     50        failIfFalse_,
     51        failUnlessSuccess,
     52        failUnlessSuccessOr,
     53    ) where
     54
     55import Data.Char
     56import Data.List
     57import Data.Maybe
     58import Data.Word
     59import Foreign.C.Error
     60import Foreign.C.String
    3261import Foreign.C.Types
     62import Foreign.Ptr
     63import GHC.Base
     64import GHC.IO
     65import GHC.Num
     66import System.IO.Error
    3367
     68import qualified Numeric
    3469
    35 type HANDLE       = Ptr ()
    36 type DWORD        = Word32
     70#ifdef mingw32_HOST_OS
     71# if defined(i386_HOST_ARCH)
     72#  define WINDOWS_CCONV stdcall
     73# elif defined(x86_64_HOST_ARCH)
     74#  define WINDOWS_CCONV ccall
     75# else
     76#  error Unknown mingw32 arch
     77# endif
     78#endif
    3779
    38 type LPTSTR = Ptr CWchar
     80type BOOL       = Bool
     81type DWORD      = Word32
     82type ErrCode    = DWORD
     83type HANDLE     = Ptr ()
     84type LPWSTR     = Ptr CWchar
     85type LPTSTR     = LPWSTR
    3986
    4087iNFINITE :: DWORD
    4188iNFINITE = 0xFFFFFFFF -- urgh
    4289
     90iNVALID_HANDLE_VALUE :: HANDLE
     91iNVALID_HANDLE_VALUE = wordPtrToPtr (-1)
     92
    4393throwGetLastError :: String -> IO a
    44 throwGetLastError where_from = c_maperrno >> throwErrno where_from
     94throwGetLastError where_from =
     95    getLastError >>= failWith where_from
    4596
    4697foreign import ccall unsafe "maperrno"             -- in Win32Utils.c
    4798   c_maperrno :: IO ()
    4899
     100foreign import ccall unsafe "maperrno_func"        -- in Win32Utils.c
     101   c_maperrno_func :: ErrCode -> Errno
     102
     103foreign import ccall unsafe "base_getErrorMessage" -- in Win32Utils.c
     104    c_getErrorMessage :: DWORD -> IO LPWSTR
     105
     106foreign import WINDOWS_CCONV unsafe "windows.h LocalFree"
     107    localFree :: Ptr a -> IO (Ptr a)
     108
     109foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"
     110    getLastError :: IO ErrCode
     111
     112
     113failIf :: (a -> Bool) -> String -> IO a -> IO a
     114failIf p wh act = do
     115    v <- act
     116    if p v then throwGetLastError wh else return v
     117
     118failIf_ :: (a -> Bool) -> String -> IO a -> IO ()
     119failIf_ p wh act = do
     120    v <- act
     121    if p v then throwGetLastError wh else return ()
     122
     123failIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
     124failIfNull = failIf (== nullPtr)
     125
     126failIfZero :: (Eq a, Num a) => String -> IO a -> IO a
     127failIfZero = failIf (== 0)
     128
     129failIfFalse_ :: String -> IO Bool -> IO ()
     130failIfFalse_ = failIf_ not
     131
     132failUnlessSuccess :: String -> IO ErrCode -> IO ()
     133failUnlessSuccess fn_name act = do
     134    r <- act
     135    if r == 0 then return () else failWith fn_name r
     136
     137failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool
     138failUnlessSuccessOr val fn_name act = do
     139    r <- act
     140    if r == 0 then return False
     141        else if r == val then return True
     142        else failWith fn_name r
     143
     144-- | Convert a Windows error code to an exception, then throw it.
     145failWith :: String -> ErrCode -> IO a
     146failWith fn_name err_code =
     147    errCodeToIOError fn_name err_code >>= throwIO
     148
     149-- | Convert a Windows error code to an exception.
     150errCodeToIOError :: String -> ErrCode -> IO IOError
     151errCodeToIOError fn_name err_code = do
     152    msg <- getErrorMessage err_code
     153
     154    -- turn GetLastError() into errno, which errnoToIOError knows
     155    -- how to convert to an IOException we can throw.
     156    -- XXX we should really do this directly.
     157    let errno = c_maperrno_func err_code
     158
     159    let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n
     160        ioerror = errnoToIOError fn_name errno Nothing Nothing
     161                    `ioeSetErrorString` msg'
     162    return ioerror
     163
     164getErrorMessage :: ErrCode -> IO String
     165getErrorMessage err_code =
     166    mask_ $ do
     167        c_msg <- c_getErrorMessage err_code
     168        if c_msg == nullPtr
     169          then return $ "Error 0x" ++ Numeric.showHex err_code ""
     170          else do msg <- peekCWString c_msg
     171                  -- We ignore failure of freeing c_msg, given we're already failing
     172                  _ <- localFree c_msg
     173                  return msg
  • cbits/Win32Utils.c

    diff --git a/cbits/Win32Utils.c b/cbits/Win32Utils.c
    index ecd54f3..7038cbf 100644
    a b static struct errentry errtable[] = { 
    8080#define MIN_EACCES_RANGE ERROR_WRITE_PROTECT
    8181#define MAX_EACCES_RANGE ERROR_SHARING_BUFFER_EXCEEDED
    8282
    83 void maperrno (void)
     83void maperrno(void)
    8484{
    85         int i;
    86         DWORD dwErrorCode;
    87 
    88         dwErrorCode = GetLastError();
    89 
    90         /* check the table for the OS error code */
    91         for (i = 0; i < ERRTABLESIZE; ++i)
    92         {
    93                 if (dwErrorCode == errtable[i].oscode)
    94                 {
    95                         errno = errtable[i].errnocode;
    96                         return;
    97                 }
    98         }
    99 
    100         /* The error code wasn't in the table.  We check for a range of */
    101         /* EACCES errors or exec failure errors (ENOEXEC).  Otherwise   */
    102         /* EINVAL is returned.                                          */
    103 
    104         if (dwErrorCode >= MIN_EACCES_RANGE && dwErrorCode <= MAX_EACCES_RANGE)
    105                 errno = EACCES;
    106         else
    107                 if (dwErrorCode >= MIN_EXEC_ERROR && dwErrorCode <= MAX_EXEC_ERROR)
    108                         errno = ENOEXEC;
    109                 else
    110                         errno = EINVAL;
     85    errno = maperrno_func(GetLastError());
     86}
     87
     88int maperrno_func(DWORD dwErrorCode)
     89{
     90    int i;
     91
     92    /* check the table for the OS error code */
     93    for (i = 0; i < ERRTABLESIZE; ++i)
     94        if (dwErrorCode == errtable[i].oscode)
     95            return errtable[i].errnocode;
     96
     97    /* The error code wasn't in the table.  We check for a range of */
     98    /* EACCES errors or exec failure errors (ENOEXEC).  Otherwise   */
     99    /* EINVAL is returned.                                          */
     100
     101    if (dwErrorCode >= MIN_EACCES_RANGE && dwErrorCode <= MAX_EACCES_RANGE)
     102        return EACCES;
     103    else if (dwErrorCode >= MIN_EXEC_ERROR && dwErrorCode <= MAX_EXEC_ERROR)
     104        return ENOEXEC;
     105    else
     106        return EINVAL;
     107}
     108
     109LPWSTR base_getErrorMessage(DWORD err)
     110{
     111    LPWSTR what;
     112    DWORD res;
     113
     114    res = FormatMessageW(
     115              (FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER),
     116              NULL,
     117              err,
     118              MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), /* Default language */
     119              (LPWSTR) &what,
     120              0,
     121              NULL
     122          );
     123    if (res == 0)
     124        return NULL;
     125    return what;
    111126}
    112127
    113128int get_unique_file_info(int fd, HsWord64 *dev, HsWord64 *ino)
  • include/HsBase.h

    diff --git a/include/HsBase.h b/include/HsBase.h
    index 74ab816..b1a62fd 100644
    a b  
    141141#if defined(__MINGW32__)
    142142/* in Win32Utils.c */
    143143extern void maperrno (void);
     144extern int maperrno_func(DWORD dwErrorCode);
    144145extern HsWord64 getMonotonicUSec(void);
    145146#endif
    146147