LoadFunction.hs

{-# LANGUAGE CPP #-}
{- |
   Module      :  System.Win32.DLL.LoadFunction
   Copyright   :  2012 shelarcy
   License     :  BSD-style

   Maintainer  :  shelarcy@gmail.com
   Stability   :  Provisional
   Portability :  Non-portable (Win32 API)

   Load a DLL's function.
-}
module System.Win32.DLL.LoadFunction
  ( module System.Win32.DLL.LoadFunction
  ) where
import Control.Exception            ( bracket, mask, finally )
import Foreign.C.String             ( withCAString )
import Foreign.Ptr                  ( FunPtr, castPtrToFunPtr )
import System.Win32.Error           ( failIfFalse_ )
import System.Win32.Exception.Unsupported
import System.Win32.DLL             ( c_GetProcAddress, c_LoadLibrary, freeLibrary, getModuleHandle )
import System.Win32.Types hiding    ( failIfFalse_ )
----------------------------------------------------------------
-- LoadFunctions
----------------------------------------------------------------
loadFunction :: HMODULE -> String -> (FunPtr a -> IO b) -> IO b
loadFunction dll name conv
  = withCAString name $ \c_name -> do
        proc <- unsupportedIfNull (missingFunction name)
                    $ c_GetProcAddress dll c_name
        conv $ castPtrToFunPtr proc

loadSystemFunction :: HMODULE -> String -> (FunPtr a -> IO b) -> IO b
loadSystemFunction dll name conv
  = withCAString name $ \c_name -> do
        -- Is failIfNull suitable or not?
        proc <- unsupportedIfNull (missingWin32Function name)
                    $ c_GetProcAddress dll c_name
        conv $ castPtrToFunPtr proc

loadLibrary' :: FilePath -> IO HINSTANCE
loadLibrary' name =
  withTString name $ \ c_name ->
  unsupportedIfNull (missingLibrary name) $ c_LoadLibrary c_name

withLoadFunction :: FilePath -> String -> (FunPtr a -> IO b) -> IO b
withLoadFunction dllname name conv =
  mask $ \restore -> do
    -- loadLibrry is better than c_getModuleHandle when load non-system library.
    dll    <- loadLibrary' dllname
    restore $ finally (loadFunction dll name conv) (freeLibrary dll)
{-
    result <- restore $
                catch (loadFunction dllname dll name conv)
                  (\e -> case e of
                           MissingFunction _ _ -> do freeLibrary dll
                                                     throwIO e
                           _ -> throwIO e)
    _      <- freeLibrary a
    return result
-}

withLoadSystemFunction :: String -> String -> (FunPtr a -> IO b) -> IO b
withLoadSystemFunction dllname name conv
  = bracket (getModuleHandle (Just dllname)) (\_ -> return ())
      $ \dll -> loadSystemFunction dll name conv

-- portable version
setSearchPathMode :: SearchPathModeFlags -> IO ()
setSearchPathMode flag =
  withLoadSystemFunction "Kernel32.dll" "SetSearchPathMode" $ \c_SetSearchPathMode ->
    failIfFalse_ "SetDllDirectory" $ convSetSearchPathMode c_SetSearchPathMode flag

type SearchPathModeFlags = DWORD
bASE_SEARCH_PATH_ENABLE_SAFE_SEARCHMODE, bASE_SEARCH_PATH_DISABLE_SAFE_SEARCHMODE, bASE_SEARCH_PATH_PERMANENT :: SearchPathModeFlags
bASE_SEARCH_PATH_ENABLE_SAFE_SEARCHMODE = 0x00000001
bASE_SEARCH_PATH_DISABLE_SAFE_SEARCHMODE = 0x00010000
bASE_SEARCH_PATH_PERMANENT = 0x00008000

foreign import WINDOWS_CCONV unsafe "dynamic" convSetSearchPathMode ::
   FunPtr (SearchPathModeFlags -> IO BOOL) -> (SearchPathModeFlags -> IO BOOL)
{-
-- non portable version.
setSearchPathMode :: SearchPathModeFlags -> IO ()
setSearchPathMode flag =
  failIfFalse_ "SetDllDirectory" $ c_SetSearchPathMode flag

foreign import WINDOWS_CCONV unsafe "windows.h SetSearchPathMode"
  c_SetSearchPathMode :: SearchPathModeFlags -> IO BOOL

{enum SearchPathModeFlags,
 , bASE_SEARCH_PATH_ENABLE_SAFE_SEARCHMODE  = BASE_SEARCH_PATH_ENABLE_SAFE_SEARCHMODE
 , bASE_SEARCH_PATH_DISABLE_SAFE_SEARCHMODE = BASE_SEARCH_PATH_DISABLE_SAFE_SEARCHMODE
 , bASE_SEARCH_PATH_PERMANENT               = BASE_SEARCH_PATH_PERMANENT
 }
-}

setDllDirectory :: String -> IO ()
setDllDirectory name =
  withTString name $ \ c_name ->
  failIfFalse_ "SetDllDirectory" $ c_SetDllDirectory c_name

foreign import WINDOWS_CCONV unsafe "windows.h SetDllDirectoryW"
  c_SetDllDirectory :: LPTSTR -> IO BOOL