packages feed

Win32-errors (empty) → 0.1

raw patch · 9 files changed

+487/−0 lines, 9 filesdep +Win32dep +basedep +template-haskellsetup-changed

Dependencies added: Win32, base, template-haskell, text

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Michael Steele
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * 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.
+
+    * Neither the name of Michael Steele nor the names of other
+      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
+OWNER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain
+ System/Win32/Error.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE Trustworthy #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+
+-- |
+-- module: System.Win32.Error
+-- copyright: (c) Michael Steele, 2014
+-- license: BSD3
+-- maintainer: mikesteele81@gmail.com
+-- stability: experimental
+-- portability: Windows
+--
+-- This package assumes that you will be using strict `T.Text` values for string
+-- handling. Consider using the following language pragma and import
+-- statements:
+--
+-- > {-# LANGUAGE OverloadedStrings #-}
+-- >
+-- > module Main where
+-- >
+-- > import Data.Text (Text)
+-- > import qualified Data.Text as T
+-- > import qualified Data.Text.Foreign as T
+--
+-- This module is intended to be imported qualified.
+--
+-- > import System.Win32.Errors (ErrCode, Win32Exception)
+-- > import qualified System.Win32.Errors as E
+--
+-- See the 'Win32Exception' type's documentation for an instructions on
+-- working with functions that may throw exceptions of this type.
+module System.Win32.Error
+  ( Win32Exception (..)
+  , tryWin32
+  , toDWORD
+  , fromDWORD
+  , ErrCode (..)
+  ) where
+
+import qualified Data.Text as T
+import System.Win32.Error.Types
+ System/Win32/Error/Foreign.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Trustworthy #-}
+
+-- |
+-- module: System.Win32.Error.Foreign
+-- copyright: (c) Michael Steele, 2014
+-- license: BSD3
+-- maintainer: mikesteele81@gmail.com
+-- stability: experimental
+-- portability: Windows
+--
+-- This module provides functions which can be used as drop-in replacements
+-- for Win32 when writing wrappers to foreign imports.
+--
+-- You will likely need to import modules from Win32 as well. To avoid
+-- accidentally calling the standard error handling functions it's a good idea
+-- to hide a few names:
+--
+-- > import qualified System.Win32.Error.Foreign as E
+-- > import System.Win32 hiding (failIfFalse_, failIf, failUnlessSuccess, failWith)
+--
+-- Handling error conditions in Windows revolves around a thread-local
+-- global variable representing the most recent error condition. Functions
+-- indicate that an error occurred in various ways. The C++ programmer will
+-- observe that a function failed, and immediately call GetLastError to
+-- retrieve details on the possible cause or to get a localized error message
+-- which can be relayed to a human in some way.
+--
+-- There are some cases where an error code may mean different things
+-- depending on varying context, but in general these codes are globally
+-- unique. Microsoft documents which error codes may be expected for any
+-- given function.
+--
+-- When working with functions exported by Win32, error conditions are dealt
+-- with using the `IOError` exception type. Most native Win32 functions return
+-- an error code which can be used to determine whether something went wrong
+-- during its execution. By convention these functions are all named something
+-- of the form "c_DoSomething" where "DoSomething" matches the name given by
+-- Microsoft. A haskell wrapper function named "doSomething" will typically,
+-- among other things, check this error code. Based on its value the operating
+-- system will be queried for additional error information, and a Haskell
+-- exception will be thrown.
+--
+-- Consider the `System.Win32.File.createFile` function used to
+-- open existing files which may or may not actually exist.
+--
+-- > createFile "c:\\nofilehere.txt" gENERIC_READ
+-- >            fILE_SHARE_NONE Nothing oPEN_EXISTING 0 Nothing
+--
+-- If no file by that name exists the underlying `Win32.c_CreateFile` call will
+-- return `Win32.iNVALID_HANDLE_VALUE`. This will result in an `IOError` exception
+-- being thrown with a `String` value indicating the function and file name.
+-- Internally, the `IOError` will also contain the error code, which will be
+-- converted to a general Haskell value.
+--
+-- The Win32-errors package works similarly. A (simplified) wrapper around
+-- c_CreateFile could be written as follows. Source code
+-- from the Win32 package often provides a good starting point:
+--
+-- > createFile name access mode = withTString name $ \ c_name ->
+-- >     E.failIf (== E.toDWORD E.InvalidHandle) "CreateFile" $
+-- >     c_CreateFile c_name access fILE_SHARE_NONE nullPtr
+-- >                  mode 0 nullPtr
+--
+module System.Win32.Error.Foreign
+  ( failIf
+  , failIfFalse_
+  , failIfNull
+  , failUnlessSuccess
+  , failWith
+  , errorWin
+  ) where
+
+import Control.Exception
+import Data.Char
+import Data.Text as T
+import Data.Text.Foreign as T
+import Foreign
+import Numeric
+import System.Win32 (DWORD, LPTSTR)
+import qualified System.Win32 as Win32
+
+import System.Win32.Error.Types
+
+#include "windows_cconv.h"
+
+-- |This function mirrors the Win32 package's 'System.Win32.Types.failIfFalse_'
+-- function.
+failIfFalse_ :: Text -> IO Bool -> IO ()
+failIfFalse_ wh act = failIf not wh act >> return ()
+
+-- |Copied from the Win32 package. Use this to throw a Win32 exception
+-- when an action returns a value satisfying the given predicate.
+-- The exception thrown will depend on a thead-local global error condition.
+-- The supplied `Text` value should be set to the human-friendly name of the
+-- action that triggered the error.
+failIf :: (a -> Bool) -> Text -> IO a -> IO a
+failIf p wh act = do
+    v <- act
+    if p v then errorWin wh else return v
+
+-- |This function mirrors the Win32 package's 'System.Win32.Types.failIfNull'
+-- function.
+failIfNull :: Text -> IO (Ptr a) -> IO (Ptr a)
+failIfNull = failIf (== nullPtr)
+
+-- |Perform the supplied action, and throw a `Win32Exception` exception if the
+-- return code is anything other than `Success`. The supplied action returns
+-- a `DWORD` instead of an `ErrCode` so that foreign imports can be used more
+-- conveniently.
+failUnlessSuccess :: Text -> IO DWORD -> IO ()
+failUnlessSuccess fn_name act = do
+    r <- act
+    if r == toDWORD Success then return () else failWith' fn_name r
+
+-- |Windows maintains a thread-local value representing the previously triggered
+-- error code. Calling `errorWin` will look up the value, and throw a `Win32Exception`
+-- exception. The supplied `Text` argument should be set to the name of the function
+-- which triggered the error condition.
+--
+-- Calling this action when no error has occurred (0x00000000 -- ERROR_SUCCESS) will
+-- result in an exception being thrown for the `Success` error code.
+errorWin :: Text -> IO a
+errorWin fn_name = Win32.getLastError >>= failWith' fn_name
+
+-- |Like failWith, but avoid multiple conversions to and from 'ErrCode'.
+failWith' :: Text -> DWORD -> IO a
+failWith' fn_name err_code = do
+    msg <- formatMessage err_code
+    -- drop trailing \n
+    let msg' = T.reverse . T.dropWhile isSpace . T.reverse $ msg
+    throw $ Win32Exception fn_name (fromDWORD err_code) msg'
+
+-- |Throw a `Win32Exception` exception for the given function name and error code.
+failWith :: Text -> ErrCode -> IO a
+failWith fn_name err_code = failWith' fn_name $ toDWORD err_code
+
+#define FORMAT_MESSAGE_FROM_SYSTEM     0x00001000
+#define FORMAT_MESSAGE_ALLOCATE_BUFFER 0x00000100
+
+-- |This function doesn't belong in Win32-errors, which is why it isn't
+-- exported. FormatMessage is required to get the standard system message
+-- associated with an error code.
+formatMessage :: DWORD -> IO Text
+formatMessage err =
+    -- Specifying FORMAT_MESSAGE_ALLOCATE_BUFFER changes the lpBuffer argument
+    -- to a pointer to LPTSTR
+    alloca $ \ ppBuffer -> do
+    len <- c_FormatMessage (FORMAT_MESSAGE_FROM_SYSTEM .|. FORMAT_MESSAGE_ALLOCATE_BUFFER)
+                             nullPtr err 0 (castPtr ppBuffer) 0 nullPtr
+    pBuffer <- peek ppBuffer
+    if (len == 0 || pBuffer == nullPtr)
+       then return $ "Error 0x" `T.append` T.pack (Numeric.showHex err "")
+       else fromPtr pBuffer (fromIntegral len)
+
+-- DWORD WINAPI FormatMessage(
+--   _In_      DWORD dwFlags,
+--   _In_opt_  LPCVOID lpSource,
+--   _In_      DWORD dwMessageId,
+--   _In_      DWORD dwLanguageId,
+--   _Out_     LPTSTR lpBuffer,
+--   _In_      DWORD nSize,
+--   _In_opt_  va_list *Arguments
+-- );
+foreign import WINDOWS_CCONV "Windows.h FormatMessageW"
+    c_FormatMessage :: DWORD -> Ptr () -> DWORD -> DWORD -> LPTSTR -> DWORD
+                    -> Ptr () -> IO DWORD
+ System/Win32/Error/Mapping.hs view
@@ -0,0 +1,41 @@+module System.Win32.Error.Mapping
+  ( mapping
+  ) where
+
+import Language.Haskell.TH (mkName, Name)
+
+import System.Win32.Types (DWORD)
+
+mapping :: [(DWORD, Name)]
+mapping = map (fmap mkName) $
+    [ -- INVALID_HANDLE_VALUE is -1 for compatibility with 16-bit windows
+      (fromIntegral (-1 :: Int), "InvalidHandleValue")
+    , (0x00000000, "Success")
+    , (0x00000002, "FileNotFound")
+    , (0x00000003, "PathNotFound")
+    , (0x00000005, "AccessDenied")
+    , (0x00000006, "InvalidHandle")
+    , (0x0000000d, "InvalidData")
+    , (0x0000000f, "InvalidDrive")
+    , (0x00000010, "CurrentDirectory")
+    , (0x00000012, "NoMoreFiles")
+    , (0x00000078, "CallNotImplemented")
+    , (0x000000ea, "MoreData")
+    , (0x00000103, "NoMoreItems")
+    , (0x00000420, "ServiceAlreadyRunning")
+    , (0x00000422, "ServiceDisabled")
+    , (0x00000424, "ServiceDoesNotExist")
+    , (0x00000425, "ServiceCannotAcceptCtrl")
+    , (0x00000426, "ServiceNotActive")
+    , (0x00000427, "FailedServiceControllerConnect")
+    , (0x00000428, "ExceptionInService")
+    , (0x0000042a, "ServiceSpecificError")
+    , (0x0000043b, "ServiceNotInExe")
+    , (0x00001126, "NotAReparsePoint")
+    , (0x00004e25, "DhcpSubnetNotPresent")
+    , (0x00004e27, "DhcpElementCantRemove")
+    , (0x00004e2a, "DhcpOptionNotPresent")
+    , (0x00004e2d, "DhcpJetError")
+    , (0x00004e32, "DhcpNotReservedClient")
+    , (0x00004e37, "DhcpInvalidRange")
+    ]
+ System/Win32/Error/TH.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE TemplateHaskell #-}
+
+module System.Win32.Error.TH
+  ( genErrCode
+  , gentoDWORD
+  , genfromDWORD
+  ) where
+
+import Language.Haskell.TH
+import System.Win32 (DWORD)
+
+import System.Win32.Error.Mapping
+
+errCode :: Name
+errCode = mkName "ErrCode"
+
+errOther :: Name
+errOther = mkName "Other"
+
+-- |Given something like [(undefined, "Success")], the following will be produced:
+--     data ErrCode
+--         = Success
+--         | Other !DWORD
+--         deriving (Eq, Show)
+genErrCode :: Q [Dec]
+genErrCode = return [DataD [] errCode [] cons [''Eq, ''Show]]
+  where
+    con name = NormalC name []
+    cons = map (con . snd) mapping ++ [NormalC errOther [(IsStrict, ConT ''DWORD)]]
+
+-- toDWORD :: ErrCode -> DWORD
+-- toDWORD (ErrorOther x) = x
+-- toDWORD errorSomethingElse = #
+-- toDWORD errorSomethingElse = #
+-- toDWORD errorSomethingElse = #
+gentoDWORD :: Q [Dec]
+gentoDWORD  = do
+    x <- newName "x"
+    return [ SigD toDWORD (AppT (AppT ArrowT (ConT errCode)) (ConT ''DWORD))
+           , FunD toDWORD $ Clause [ConP errOther [VarP x]] (NormalB (VarE x)) [] : map genClause mapping
+           ]
+  where
+    toDWORD = mkName "toDWORD"
+    genClause :: (DWORD, Name) -> Clause
+    genClause (dw, err) = Clause [ConP err []] (NormalB (LitE . litDWORD $ dw)) []
+
+-- fromDWORD :: DWORD -> ErrCode
+-- fromDWORD 0 = ErrorSuccess
+-- fromDWORD # = ErrorSomethingElse
+-- fromDWORD # = ErrorSomethingElse
+-- fromDWORD # = ErrorSomethingElse
+-- fromDWORD x = ErrorOther x
+genfromDWORD :: Q [Dec]
+genfromDWORD = do
+    x <- newName "x"
+    return [ SigD fromDWORD (AppT (AppT ArrowT (ConT ''DWORD)) (ConT errCode))
+           , FunD fromDWORD $ map genClause mapping ++ [Clause [VarP x] (NormalB (AppE (ConE errOther) (VarE x))) []]
+           ]
+  where
+    fromDWORD = mkName "fromDWORD"
+    genClause :: (DWORD, Name) -> Clause
+    genClause (dw, err) = Clause [LitP $ litDWORD dw] (NormalB (ConE  err)) []
+
+litDWORD :: DWORD -> Lit
+litDWORD = IntegerL . toInteger
+ System/Win32/Error/Types.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module System.Win32.Error.Types where
+
+import Control.Exception
+import Data.Text
+import Data.Typeable
+import Foreign
+import System.Win32.Types (DWORD)
+
+import System.Win32.Error.TH
+
+-- |Win32 actions typically return an error code to indicate success or failure.
+-- These codes are intended to be globally unique, though there may be some overlap.
+-- MSDN documents which errors may be returned by any given action.
+--
+-- The naming of errors follows a convention. An error such as ERROR_SUCCESS
+-- becomes `Success`, ERROR_FILE_NOT_FOUND becomes `FileNotFound`, and so
+-- on. There are thousands of errors, so it would be impractical to add them
+-- all. The `Other` constructor is used to represent error codes which are not
+-- handled specifically.
+--
+-- User's of this library are encouraged to submit new error codes. Add new entries to
+-- System.Win32.Errors.Mapping. Send your pull requests along with a link to relevent
+-- documentation to
+-- <https://github.com/mikesteele81/Win32-errors.git https://github.com/mikesteele81/Win32-errors.git>.
+genErrCode
+
+-- |Convert an `ErrCode` into a `DWORD`.
+gentoDWORD
+
+-- |Convert a `DWORD` into an `ErrCode`. Values which don't have a
+-- corresponding constructor will end up becoming an `Other`.
+genfromDWORD
+
+-- |Performs marshalling by converting to and from `DWORD`.
+instance Storable ErrCode where
+  sizeOf _ = sizeOf (undefined :: DWORD)
+  alignment _ = alignment (undefined :: DWORD)
+  peek ptr = (peek . castPtr) ptr >>= return . fromDWORD
+  poke ptr ec = poke (castPtr ptr) (toDWORD ec)
+
+-- |Exception type for Win32 errors.
+--
+-- This type will be thrown as an extensible exception when a foreign call out
+-- to part of the Win32 indicates that an error has occurred. In most cases you
+-- should wrap an IO computation in a call to `tryWin32`.
+--
+-- The following example uses the custom 'createFile' function described in
+-- "System.Win32.Error.Foreign":
+--
+-- > eHandle <- do
+-- >     h <- E.tryWin32 $ createFile "c:\\missing.txt" gENERIC_READ oPEN_EXISTING
+-- >     -- perform other actions
+-- >     return h
+-- > case eHandle of
+-- >   Right handle -> do
+-- >     -- do something with the file handle
+-- >   Left w32Err -> do
+-- >     case E.errCode w32Err of
+-- >       E.InvalidHandle -> do
+-- >         -- perform cleanup
+-- >       -- handle other error codes.
+-- >     T.putStrLn $ E.systemMessage w32Err
+data Win32Exception = Win32Exception
+    { function :: Text
+    -- ^ The foreign action which triggered this exception.
+    , errCode  :: ErrCode
+    -- ^ The error code
+    , systemMessage :: Text
+    -- ^ The standard system message associated with the error code.
+    } deriving (Typeable, Show)
+
+instance Exception Win32Exception
+
+-- |Actions calling out to Win32 may throw exceptions. Wrapping the action in
+-- `tryWin32` will catch `Win32Exception` exceptions, but will allow any other
+-- exception type to pass through.
+tryWin32 :: IO a -> IO (Either Win32Exception a)
+tryWin32 = try
+ Win32-errors.cabal view
@@ -0,0 +1,44 @@+name:                Win32-errors
+version:             0.1
+synopsis:            Alternative error handling for Win32 foreign calls
+description:
+    This package provides an alternative to the Win32 library's error handling
+    mechanism. The goal is to provide a nearly drop-in replacement for Win32's
+    error-handling functions while offering the following benefits:
+    .
+    * Ability to distinguish between different Win32 error codes.
+    .
+    * Ability to catch Win32 exceptions separately from other exception types.
+    .
+    * Ability to query for the generating function's name and standard system error massage associated with the exception.
+license:       BSD3
+license-file:  LICENSE
+author:        Michael Steele
+maintainer:    mikesteele81@gmail.com
+copyright:     Michael Steele, 2014
+category:      System
+build-type:    Simple
+cabal-version: >=1.16
+homepage:       http://github.com/mikesteele81/win32-errors
+bug-reports:    http://github.com/mikesteele81/win32-errors/issues
+tested-with:    GHC == 7.6.3
+extra-source-files:
+    include/windows_cconv.h
+
+library
+    default-language: Haskell2010
+    ghc-options: -Wall
+    cc-options:  -fno-strict-aliasing
+    build-depends:
+          base             >= 4.5  && < 4.9
+        , template-haskell >= 2.8  && < 2.9
+        , text             >= 0.11 && < 1.2
+        , Win32            >= 2.2  && < 2.4
+    exposed-modules:
+        System.Win32.Error
+        System.Win32.Error.Foreign
+    other-modules:
+        System.Win32.Error.Mapping
+        System.Win32.Error.TH
+        System.Win32.Error.Types
+    include-dirs: include
+ include/windows_cconv.h view
@@ -0,0 +1,16 @@+/* Taken from Win32. 64-bit Windows uses the 'ccall' calling convention
+   instead of 'stdcall'
+*/
+
+#ifndef __WINDOWS_CCONV_H
+#define __WINDOWS_CCONV_H
+
+#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