diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright 2008 Felix Martini. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + 1. Redistributions of source code must retain the above copyright notice + this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the names of the copyright holders nor the names of the + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell + +import Distribution.Simple +main = defaultMain diff --git a/System/Windows/Error.hs b/System/Windows/Error.hs new file mode 100644 --- /dev/null +++ b/System/Windows/Error.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, ForeignFunctionInterface #-} +{-# INCLUDE "HsWinError.h" #-} +{-# CFILES "cbits/HsWinError.c" #-} +{- | + Module : System.Windows.Error + Copyright : 2008 Felix Martini + License : BSD-style + + Maintainer : fmartini@gmail.com + Stability : Provisional + Portability : Portable + + Error handling for foreign calls to the Windows API. +-} + +module System.Windows.Error + ( WinError(..), + getWinError, + getWinErrorMessage, + throwWinError, + throwWinErrorIf, + throwWinErrorIfFalse, + throwWinErrorIfInvalidHandle, +#ifdef __GLASGOW_HASKELL__ + catchWinError, +#endif + +-- ** Common Windows error codes +-- | If the error code that you need is not listed below you can create your +-- own with the 'WinError' constructor and a numeric error code obtained from +-- the MSDN documentation at +-- . If you regularly +-- use an error code please contact the maintainer of this package to have it +-- included. + + errorSuccess, errorInvalidFunction, errorFileNotFound, + errorPathNotFound, errorTooManyOpenFiles, errorAccessDenied, + errorInvalidHandle, errorArenaTrashed, errorNotEnoughMemory, + errorInvalidBlock, errorBadEnvironment, errorBadFormat, + errorInvalidAccess, errorInvalidData, errorOutOfMemory, + errorInvalidDrive, errorCurrentDirectory, errorNotReady, + errorHandleEOF, + + ) where + +import Data.Word (Word32) +import Foreign.Ptr (Ptr) +import Foreign.C.String (CWString, peekCWString) +import System.IO.Error (mkIOError) + +#ifdef __GLASGOW_HASKELL__ +import GHC.IOBase (IOErrorType(DynIOError)) +import Data.Dynamic (fromDynamic, toDyn) +import Data.Typeable (Typeable) +import System.IO.Error (ioeGetErrorType) +#else +import System.IO.Error (userErrorType) +#endif + +newtype WinError = WinError Word32 +#ifdef __GLASGOW_HASKELL__ + deriving (Eq, Typeable) +#else + deriving Eq +#endif + +instance Show WinError where + show (WinError err) = "Windows error " ++ show err + +-- | Get the current thread's last error code. Each OS thread maintains it's +-- own last error code. +getWinError :: IO WinError +getWinError = do + err <- c_GetLastError + return (WinError err) + +-- | Get the error message corresponding to the error code. +getWinErrorMessage :: WinError -- ^ Windows error code + -> IO String +getWinErrorMessage (WinError err) = do + msg <- c_GetErrorMessage err + str <- peekCWString msg + let str' = (unwords . words) str + c_LocalFree msg + return str' + +-- | Throw an 'IOError' corresponding to the Windows error code. For GHC the +-- IOError type is DynIOError WinError. For other compilers the IOError type +-- is UserError. +throwWinError :: WinError -- ^ Windows error code + -> String -- ^ Textual description of the error location + -> IO a +throwWinError werr loc = do + str <- getWinErrorMessage werr + let loc' = loc ++ ": " ++ str ++ " (" ++ show werr ++ ")" +#ifdef __GLASGOW_HASKELL__ + let ioe = mkIOError (DynIOError (toDyn werr)) loc' Nothing Nothing +#else + let ioe = mkIOError userErrorType loc' Nothing Nothing +#endif + ioError ioe + +#ifdef __GLASGOW_HASKELL__ +-- | Catch Windows errors. Other exceptions are not caught. Note that this +-- function is available only for GHC. +catchWinError :: IO a -- ^ The 'IO' operation to be executed + -> (WinError -> IO a) -- ^ Exception handler + -> IO a +catchWinError act h = catch act handle + where handle ex = case ioeGetErrorType ex of + DynIOError dyn -> + case fromDynamic dyn of + Just err -> h err + _other -> ioError ex + _other -> ioError ex +#endif + +-- | Throw an 'IOError' corresponding to the last error code +-- if the result value of the 'IO' action meets the given predicate. +throwWinErrorIf :: (a -> Bool) -- ^ Predicate to apply to the result value + -- of the 'IO' operation + -> String -- ^ Textual description of the error location + -> IO a -- ^ The 'IO' action to be executed + -> IO a +throwWinErrorIf predicate loc act = do + res <- act + if predicate res + then do err <- c_GetLastError + throwWinError (WinError err) loc + else return res + +-- | Throw an 'IOError' corresponding to the last error code if the result +-- value of the 'IO' action is False. +throwWinErrorIfFalse :: String -- ^ Textual description of the error location + -> IO Bool -- ^ The 'IO' action to be executed + -> IO () +throwWinErrorIfFalse loc act = do + res <- act + if not res + then do err <- c_GetLastError + throwWinError (WinError err) loc + else return () + +-- | Throw an 'IOError' corresponding to the last error code if the result +-- value of the 'IO' action is an invalid handle. +throwWinErrorIfInvalidHandle :: String -- ^ Textual description of the + -- error location + -> IO (Ptr a) -- ^ The 'IO' action to be + -- executed + -> IO (Ptr a) +throwWinErrorIfInvalidHandle loc act = do + res <- act + if res == invalidHandleValue + then do err <- c_GetLastError + throwWinError (WinError err) loc + else return res + +-- --------------------------------------------------------------------- +-- Error codes + +errorSuccess, errorInvalidFunction, errorFileNotFound, + errorPathNotFound, errorTooManyOpenFiles, errorAccessDenied, + errorInvalidHandle, errorArenaTrashed, errorNotEnoughMemory, + errorInvalidBlock, errorBadEnvironment, errorBadFormat, + errorInvalidAccess, errorInvalidData, errorOutOfMemory, + errorInvalidDrive, errorCurrentDirectory, errorNotReady, + errorHandleEOF :: WinError + +errorSuccess = WinError 0 +errorInvalidFunction = WinError 1 +errorFileNotFound = WinError 2 +errorPathNotFound = WinError 3 +errorTooManyOpenFiles = WinError 4 +errorAccessDenied = WinError 5 +errorInvalidHandle = WinError 6 +errorArenaTrashed = WinError 7 +errorNotEnoughMemory = WinError 8 +errorInvalidBlock = WinError 9 +errorBadEnvironment = WinError 10 +errorBadFormat = WinError 11 +errorInvalidAccess = WinError 12 +errorInvalidData = WinError 13 +errorOutOfMemory = WinError 14 +errorInvalidDrive = WinError 15 +errorCurrentDirectory = WinError 16 +errorNotReady = WinError 21 +errorHandleEOF = WinError 38 + +-- --------------------------------------------------------------------- +-- Foreign functions + +foreign import stdcall unsafe "GetLastError" + c_GetLastError :: IO Word32 + +foreign import ccall unsafe "GetErrorMessageW" + c_GetErrorMessage :: Word32 -> IO CWString + +foreign import stdcall unsafe "LocalFree" + c_LocalFree :: Ptr a -> IO (Ptr a) + +foreign import ccall unsafe "invalidHandleValue" + invalidHandleValue :: Ptr a diff --git a/cbits/HsWinError.c b/cbits/HsWinError.c new file mode 100644 --- /dev/null +++ b/cbits/HsWinError.c @@ -0,0 +1,29 @@ +#if (defined(_WIN32) || defined(__MINGW32__)) + +#include "HsWinError.h" +#include + +LPWSTR GetErrorMessageW(DWORD dwError) +{ + LPWSTR lpMsgBuf = NULL; + DWORD res; + + res = FormatMessageW( + FORMAT_MESSAGE_ALLOCATE_BUFFER | /* free buffer with LocalFree */ + FORMAT_MESSAGE_FROM_SYSTEM | + FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, + dwError, + 0, + (LPWSTR)&lpMsgBuf, + 0, + NULL); + if (res == 0) { + lpMsgBuf = (LPWSTR) L"[No description available]"; + } + return lpMsgBuf; +} + +HANDLE invalidHandleValue(void) {return INVALID_HANDLE_VALUE;} + +#endif diff --git a/include/HsWinError.h b/include/HsWinError.h new file mode 100644 --- /dev/null +++ b/include/HsWinError.h @@ -0,0 +1,12 @@ +#if (defined(_WIN32) || defined(__MINGW32__)) + +#ifndef HSWINERROR_H +#define HSWINERROR_H + +#include + +LPWSTR GetErrorMessageW(DWORD dwError); +HANDLE invalidHandleValue(void); + +#endif +#endif diff --git a/winerror.cabal b/winerror.cabal new file mode 100644 --- /dev/null +++ b/winerror.cabal @@ -0,0 +1,21 @@ +name: winerror +version: 0.1 +copyright: 2008 Felix Martini +license: BSD3 +license-file: LICENSE +maintainer: fmartini@gmail.com +stability: Provisional +category: Foreign +synopsis: Error handling for foreign calls to the Windows API. +tested-with: GHC == 6.8.2, Hugs == 2006-09 +build-type: Simple +cabal-version: >= 1.2 + +library + if os(windows) + build-depends: base + exposed-modules: System.Windows.Error + include-dirs: include + c-sources: cbits/HsWinError.c + install-includes: HsWinError.h + extensions: CPP