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
----------------------------------------------------------------
-- | This function is not stable yet.
-- If you worry about compatibility, use 'loadFunction'' instead.
loadFunction :: HMODULE
             -> String -- ^ Function name
             -> String -- ^ Advice to use function when user can't load function.
             -> (FunPtr a -> IO b) -- ^ Process with using loaded function.
             -> IO b
loadFunction dll name reason conv
  = withCAString name $ \c_name -> do
        proc <- unsupportedIfNull (MissingFunction name reason)
                    $ c_GetProcAddress dll c_name
        conv $ castPtrToFunPtr proc

loadFunction' :: HMODULE
              -> String -- ^ Function name
              -> (FunPtr a -> IO b) -- ^ Process with using loaded function.
              -> IO b
loadFunction' dll name conv = loadFunction dll name "" conv

-- | This function is not stable yet.
-- If you worry about compatibility, use 'loadSystemFunction'' instead.
loadSystemFunction :: HMODULE -> String -> String -> (FunPtr a -> IO b) -> IO b
loadSystemFunction dll name reason conv
  = withCAString name $ \c_name -> do
        -- Is failIfNull suitable or not?
        proc <- unsupportedIfNull (missingWin32Function name reason)
                    $ c_GetProcAddress dll c_name
        conv $ castPtrToFunPtr proc

loadSystemFunction' :: HMODULE -> String -> (FunPtr a -> IO b) -> IO b
loadSystemFunction' dll name conv = loadSystemFunction dll name "" conv

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

-- | This function is not stable yet.
-- If you worry about compatibility, use 'withLoadFunction'' instead.
withLoadFunction :: FilePath -- ^ DLL path
                 -> String   -- ^ Function name
                 -> String   -- ^ Advice to use function when user can't load function.
                 -> (FunPtr a -> IO b) -- ^ Process with using loaded function.
                 -> IO b
withLoadFunction dllname name reason conv =
  mask $ \restore -> do
    -- loadLibrry is better than c_getModuleHandle when load non-system library.
    dll    <- loadLibrary' dllname
    restore $ finally (loadFunction dll name reason 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
-}
withLoadFunction' :: FilePath -- ^ DLL path
                  -> String   -- ^ Function name
                  -> (FunPtr a -> IO b) -- ^ Process with using loaded function.
                  -> IO b
withLoadFunction' dllname name conv = withLoadFunction dllname name "" conv

-- | This function is not stable yet.
-- If you worry about compatibility, use 'withLoadSystemFunction'' instead.
withLoadSystemFunction :: String -- ^ System's DLL name
                       -> String -- ^ Function name
                       -> String -- ^ Advice to use function when user can't load function.
                       -> (FunPtr a -> IO b) -- ^ Process with using loaded function.
                       -> IO b
withLoadSystemFunction dllname name reason conv
  = bracket (getModuleHandle (Just dllname)) (\_ -> return ())
      $ \dll -> loadSystemFunction dll name reason conv

withLoadSystemFunction' :: String -- ^ System's DLL name
                        -> String -- ^ Function name
                        -> (FunPtr a -> IO b) -- ^ Process with using loaded function.
                        -> IO b
withLoadSystemFunction' dllname name conv = withLoadSystemFunction dllname name "" conv

{-
-- Should we provide Maybe version's function to provide fallback functionality?

getModuleHandle :: String -> IO (Maybe HMODULE)
getModuleHandle moduleName = do
    ptr <- withTString moduleName c_GetModuleHandle
    if ptr == nullPtr
      then do
        err <- getLastError
        if err == eRROR_MOD_NOT_FOUND
          then return Nothing
          else failWith "GetModuleHandle" err
      else return $ Just ptr

getProcAddress :: HMODULE -> String -> IO (Maybe (FunPtr a))
getProcAddress hModule procName = do
    ptr <- withCAString procName $ c_GetProcAddress hModule
    if ptr == nullPtr
      then do
        err <- getLastError
        if err == eRROR_PROC_NOT_FOUND
          then return Nothing
          else failWith "GetProcAddress" err
      else return $ Just $ castPtrToFunPtr ptr
-}

-- portable version
setSearchPathMode :: SearchPathModeFlags -> IO ()
setSearchPathMode flag =
  withLoadSystemFunction "Kernel32.dll" "SetSearchPathMode" "" $ \c_SetSearchPathMode ->
    failIfFalse_ "SetDllDirectory" $ mkSetSearchPathMode 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" mkSetSearchPathMode ::
   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_ (unwords ["SetDllDirectory", name]) $ c_SetDllDirectory c_name

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