{-# 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_ :: Text -> IO Bool -> IO ()
failIfFalse_ Text
wh IO Bool
act = (Bool -> Bool) -> Text -> IO Bool -> IO Bool
forall a. (a -> Bool) -> Text -> IO a -> IO a
failIf Bool -> Bool
not Text
wh IO Bool
act IO Bool -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
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 :: forall a. (a -> Bool) -> Text -> IO a -> IO a
failIf a -> Bool
p Text
wh IO a
act = do
    a
v <- IO a
act
    if a -> Bool
p a
v then Text -> IO a
forall a. Text -> IO a
errorWin Text
wh else a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

-- |This function mirrors the Win32 package's 'System.Win32.Types.failIfNull'
-- function.
failIfNull :: Text -> IO (Ptr a) -> IO (Ptr a)
failIfNull :: forall a. Text -> IO (Ptr a) -> IO (Ptr a)
failIfNull = (Ptr a -> Bool) -> Text -> IO (Ptr a) -> IO (Ptr a)
forall a. (a -> Bool) -> Text -> IO a -> IO a
failIf (Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
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 :: Text -> IO DWORD -> IO ()
failUnlessSuccess Text
fn_name IO DWORD
act = do
    DWORD
r <- IO DWORD
act
    if DWORD
r DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== ErrCode -> DWORD
toDWORD ErrCode
Success then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () else Text -> DWORD -> IO ()
forall a. Text -> DWORD -> IO a
failWith' Text
fn_name DWORD
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 :: forall a. Text -> IO a
errorWin Text
fn_name = IO DWORD
Win32.getLastError IO DWORD -> (DWORD -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> DWORD -> IO a
forall a. Text -> DWORD -> IO a
failWith' Text
fn_name

-- |Like failWith, but avoid multiple conversions to and from 'ErrCode'.
failWith' :: Text -> DWORD -> IO a
failWith' :: forall a. Text -> DWORD -> IO a
failWith' Text
fn_name DWORD
err_code = do
    Text
msg <- DWORD -> IO Text
formatMessage DWORD
err_code
    -- drop trailing \n
    let msg' :: Text
msg' = Text -> Text
T.reverse (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.reverse (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
msg
    Win32Exception -> IO a
forall a e. Exception e => e -> a
throw (Win32Exception -> IO a) -> Win32Exception -> IO a
forall a b. (a -> b) -> a -> b
$ Text -> ErrCode -> Text -> Win32Exception
Win32Exception Text
fn_name (DWORD -> ErrCode
fromDWORD DWORD
err_code) Text
msg'

-- |Throw a `Win32Exception` exception for the given function name and error code.
failWith :: Text -> ErrCode -> IO a
failWith :: forall a. Text -> ErrCode -> IO a
failWith Text
fn_name ErrCode
err_code = Text -> DWORD -> IO a
forall a. Text -> DWORD -> IO a
failWith' Text
fn_name (DWORD -> IO a) -> DWORD -> IO a
forall a b. (a -> b) -> a -> b
$ ErrCode -> DWORD
toDWORD ErrCode
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 :: DWORD -> IO Text
formatMessage DWORD
err =
    -- Specifying FORMAT_MESSAGE_ALLOCATE_BUFFER changes the lpBuffer argument
    -- to a pointer to LPTSTR
    (Ptr (Ptr Word8) -> IO Text) -> IO Text
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr Word8) -> IO Text) -> IO Text)
-> (Ptr (Ptr Word8) -> IO Text) -> IO Text
forall a b. (a -> b) -> a -> b
$ \ Ptr (Ptr Word8)
ppBuffer -> do
    DWORD
len <- DWORD
-> Ptr ()
-> DWORD
-> DWORD
-> LPTSTR
-> DWORD
-> Ptr ()
-> IO DWORD
c_FormatMessage (FORMAT_MESSAGE_FROM_SYSTEM .|. FORMAT_MESSAGE_ALLOCATE_BUFFER)
                             Ptr ()
forall a. Ptr a
nullPtr DWORD
err DWORD
0 (Ptr (Ptr Word8) -> LPTSTR
forall a b. Ptr a -> Ptr b
castPtr Ptr (Ptr Word8)
ppBuffer) DWORD
0 Ptr ()
forall a. Ptr a
nullPtr
    Ptr Word8
pBuffer <- Ptr (Ptr Word8) -> IO (Ptr Word8)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr Word8)
ppBuffer
    if (DWORD
len DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
0 Bool -> Bool -> Bool
|| Ptr Word8
pBuffer Ptr Word8 -> Ptr Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Word8
forall a. Ptr a
nullPtr)
       then Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text
"Error 0x" Text -> Text -> Text
`T.append` String -> Text
T.pack (DWORD -> ShowS
forall a. Integral a => a -> ShowS
Numeric.showHex DWORD
err String
"")
       else Ptr Word8 -> I8 -> IO Text
fromPtr Ptr Word8
pBuffer (DWORD -> I8
forall a b. (Integral a, Num b) => a -> b
fromIntegral DWORD
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