hdirect-0.21.0: comlib/ComDll.lhs
Support for sealing up Haskell code as an in-proc COM server.
The export list is odd in that it doesn't export the Haskell functions
required to implement the class factory, but rather an action which
exposes them via a COM-like interface.
\begin{code}
{-# OPTIONS -#include "ComDll_stub.h" -#include <windows.h> -#include "Registry.h" #-}
module ComDll
(
ComponentInfo(..)
, mkComponentInfo
, withComponentName
, withProgID
, withVerIndepProgID
, onRegister
, onFinalize
, hasTypeLib
, createIComDll -- :: Ptr (){-HMODULE-} -> [ComponentInfo] -> IO
, regAddEntry
, regRemoveEntry
, RegHive(..)
, stdRegComponent
, stdUnRegComponent
) where
import ClassFactory
import Com
import ComException
import ComServ
import ComPrim ( getModuleFileName )
import HDirect ( Ptr, marshallString )
import Foreign hiding ( Ptr )
import Word ( Word32 )
import HDirect ( marshallMaybe )
import IOExts
import Monad
import List ( find )
\end{code}
The information an implementation of a Haskell COM component
needs to supply in order to hook into the machinery provided
here for interfacing to how COM does activation for in-proc
components:
\begin{code}
data ComponentInfo
= ComponentInfo
{ newInstance :: String -> IO () -> IID (IUnknown ()) -> IO (IUnknown ())
, componentFinalise :: IO ()
, componentName :: String
, componentProgID :: String
, componentVProgID :: String
, componentTLB :: Bool
, registerComponent :: ComponentInfo -> String -> Bool -> IO ()
, componentCLSID :: CLSID
}
withProgID :: String -> ComponentInfo -> ComponentInfo
withProgID p info = info{componentProgID=p}
onRegister :: (ComponentInfo -> String -> Bool -> IO ()) -> ComponentInfo -> ComponentInfo
onRegister reg info =
info{registerComponent= \ a b c -> reg a b c >> (registerComponent info) a b c}
onFinalize :: IO () -> ComponentInfo -> ComponentInfo
onFinalize act info = info{componentFinalise= act >> (componentFinalise info)}
withVerIndepProgID :: String -> ComponentInfo -> ComponentInfo
withVerIndepProgID p info = info{componentVProgID=p}
withFinaliser :: IO () -> ComponentInfo -> ComponentInfo
withFinaliser act info = info{componentFinalise=act}
withComponentName :: String -> ComponentInfo -> ComponentInfo
withComponentName n info = info{componentName=n}
hasTypeLib :: ComponentInfo -> ComponentInfo
hasTypeLib info = info{componentTLB=True}
-- constructor used to lessen the reliance on concrete rep.
mkComponentInfo :: CLSID
-> (String -> Bool -> IO ())
-> (String -> IO () -> IID (IUnknown ()) -> IO (IUnknown ()))
-> ComponentInfo
mkComponentInfo cls reg n = ComponentInfo n (return ()) "" "" "" False (\ _ -> reg) cls
\end{code}
The state maintained by each instance of a 'ComDll' wrapper:
\begin{code}
data ComDllState
= ComDllState {
dllPath :: String,
components :: IORef [ComponentInfo],
lockCount :: IORef Int
}
\end{code}
\begin{code}
dllGetClassObject :: ComDllState -> Ptr CLSID -> Ptr (IID a) -> Ptr (Ptr (IUnknown a)) -> IO HRESULT
dllGetClassObject comDll rclsid riid ppvObject = do
iid <- unmarshallIID False (castPtr riid)
let g = iidToGUID iid
if ( not (g == iidToGUID iidIClassFactory || g == iidToGUID iidIUnknown) ) then
return e_NOINTERFACE
else do
clsid <- unmarshallCLSID False rclsid
cs <- readIORef (components comDll)
case lookupCLSID clsid cs of
Nothing -> return cLASS_E_CLASSNOTAVAILABLE
Just i -> do
ip <- createClassFactory (newInstance i (dllPath comDll) (componentFinalise i))
writeIUnknown False ppvObject ip
return s_OK
lookupCLSID :: CLSID -> [ComponentInfo] -> Maybe ComponentInfo
lookupCLSID clsid cs = find (\ x -> clsidToGUID (componentCLSID x) == guid) cs
where
guid = clsidToGUID clsid
dllCanUnloadNow :: ComDllState -> IO HRESULT
dllCanUnloadNow state = do
c <- readIORef (lockCount state)
if c == 0 then
return s_OK
else
return s_FALSE
dllRegisterServer :: ComDllState -> IO HRESULT
dllRegisterServer = registerServer True
dllUnregisterServer :: ComDllState -> IO HRESULT
dllUnregisterServer = registerServer False
registerServer :: Bool -> ComDllState -> IO HRESULT
registerServer isReg st = do
cs <- readIORef (components st)
let
path = dllPath st
regComponent info
| not isReg = do
-- give the user-supplied un-reg action the opportunity
-- to delete some entries first.
(registerComponent info) info path isReg
stdUnRegComponent info True path
| otherwise = do
stdRegComponent info True path
(registerComponent info) info path isReg
mapM_ regComponent cs
case s_OK of
14 -> return s_OK
x -> return x
dllUnload :: ComDllState -> IO ()
dllUnload st = return ()
\end{code}
Creating + manipulating the state of a Haskell DLL containing
Haskell COM server(s).
\begin{code}
newComDllState :: Ptr (){-HANDLE-} -> [ComponentInfo] -> IO ComDllState
newComDllState hMod cs = do
path <- getModuleFileName hMod
ref_cs <- newIORef cs
-- The lock count is intended used by DllCanUnloadNow() to keep
-- track of when the Com DLL can safely be unloaded. It is only
-- safe to do so if no COM interface pointers handed out by the
-- component are currently alive.
--
-- The Com library doesn't yet try to keep track of this, so the
-- lock count is always left at 1 (==> DllCanUnloadNow() always returns
-- S_FALSE.)
lc <- newIORef 1
return (ComDllState path ref_cs lc)
\end{code}
\begin{code}
createIComDll :: Ptr (){-HMODULE-} -> [ComponentInfo] -> IO (VTable iid_comDllState ComDllState)
createIComDll hMod components = do
state <- newComDllState hMod components
meths <- iComDllEntryPoints state
createVTable meths
iComDllEntryPoints :: ComDllState -> IO [Ptr ()]
iComDllEntryPoints state = do
addrOf_DllUnload <- export_DllUnload (dllUnload state)
addrOf_DllCanUnloadNow <- export_nullaryMeth (dllCanUnloadNow state)
addrOf_DllRegisterServer <- export_nullaryMeth (dllRegisterServer state)
addrOf_DllUnregisterServer <- export_nullaryMeth (dllUnregisterServer state)
addrOf_DllGetClassObject <- export_dllGetClassObject (dllGetClassObject state)
return [ addrOf_DllUnload
, addrOf_DllCanUnloadNow
, addrOf_DllRegisterServer
, addrOf_DllUnregisterServer
, addrOf_DllGetClassObject
]
foreign export ccall dynamic
export_DllUnload :: (IO ()) -> IO (Ptr ())
foreign export ccall dynamic
export_nullaryMeth :: (IO HRESULT) -> IO (Ptr ())
foreign export ccall dynamic
export_dllGetClassObject :: (Ptr CLSID -> Ptr (IID a) -> Ptr (Ptr (IUnknown a)) -> IO HRESULT) -> IO (Ptr ())
\end{code}
\begin{code}
data RegHive
= HKEY_CLASSES_ROOT
| HKEY_CURRENT_USER
| HKEY_LOCAL_MACHINE
| HKEY_USERS
| HKEY_CURRENT_CONFIG
deriving ( Eq, Ord, Enum )
regAddEntry :: RegHive
-> String
-> Maybe String
-> IO ()
regAddEntry hive path value = do
m_path <- marshallString path
m_value <- marshallMaybe marshallString nullPtr value
hr <- primRegAddEntry (fromEnum hive) m_path m_value
checkHR hr
regRemoveEntry :: RegHive
-> String
-> String
-> Bool
-> IO ()
regRemoveEntry hive path value removeKey = do
m_path <- marshallString path
m_value <- marshallString value
let m_removeKey
| removeKey = (1::Int)
| otherwise = 0
hr <- primRegRemoveEntry (fromEnum hive) m_path m_value m_removeKey
checkHR hr
foreign import ccall "primRegAddEntry"
primRegAddEntry :: Int -> Ptr String -> Ptr String -> IO HRESULT
foreign import ccall "primRegRemoveEntry"
primRegRemoveEntry :: Int -> Ptr String -> Ptr String -> Int -> IO HRESULT
\end{code}
\begin{code}
stdRegComponent :: ComponentInfo -> Bool -> String -> IO ()
stdRegComponent info isInProc path = do
let clsid_path = "CLSID\\" ++ clsid_str
progid = componentProgID info
vprogid = componentVProgID info
clsid_str = show (componentCLSID info)
-- Add CLSID\{clsid}\friendly name
regAddEntry HKEY_CLASSES_ROOT clsid_path (Just (componentName info))
-- Add CLSID\{clsid}\ProgID (if any.)
when (not (null progid)) (regAddEntry HKEY_CLASSES_ROOT (clsid_path++"\\ProgID") (Just progid))
-- Add CLSID\{clsid}\VersionIndependentProgID (if any.)
when (not (null vprogid)) (regAddEntry HKEY_CLASSES_ROOT (clsid_path++"\\VersionIndependentProgID") (Just vprogid))
-- Add CLSID\{clsid}\{Inproc,Local}Server32\path
regAddEntry HKEY_CLASSES_ROOT (clsid_path ++ (if isInProc then "\\InprocServer32" else "\\LocalServer32")) (Just path)
-- register the type library; we don't care if it fails, or not.
when (componentTLB info)
(catch (loadTypeLibEx path True{-register-} >>= \ p -> p # release >> return ())
(\ _ -> return ()))
-- Add the ProgID entries
when (not (null progid)) (regAddEntry HKEY_CLASSES_ROOT (progid ++ "\\CLSID") (Just clsid_str))
when (not (null vprogid)) (regAddEntry HKEY_CLASSES_ROOT (vprogid ++ "\\CLSID") (Just clsid_str))
when (not (null vprogid) && not (null progid))
(regAddEntry HKEY_CLASSES_ROOT (progid ++ "\\CurVer") (Just vprogid))
return ()
\end{code}
The removal of entries isn't quite right
\begin{code}
stdUnRegComponent :: ComponentInfo -> Bool -> String -> IO ()
stdUnRegComponent info isInProc path = do
let clsid_path = "CLSID\\" ++ clsid_str
progid = componentProgID info
vprogid = componentVProgID info
clsid_str = show (componentCLSID info)
-- Remove CLSID\{clsid}\{Local,Inproc}Server32
regRemoveEntry HKEY_CLASSES_ROOT clsid_path (if isInProc then "InprocServer32" else "LocalServer32") True
-- Remove CLSID\{clsid}\VersionIndependentProgID (if any.)
when (not (null vprogid)) (regRemoveEntry HKEY_CLASSES_ROOT clsid_path "VersionIndependentProgID" True)
-- Remove CLSID\{clsid}\ProgID (if any.)
when (not (null progid)) (regRemoveEntry HKEY_CLASSES_ROOT clsid_path "ProgID" True)
-- Remove CLSID\{clsid}\friendly name
regRemoveEntry HKEY_CLASSES_ROOT "CLSID" clsid_str True
-- Remove the ProgID entries
when (not (null progid)) (regRemoveEntry HKEY_CLASSES_ROOT (progid ++ "\\CLSID") clsid_str False)
when (not (null progid)) (regRemoveEntry HKEY_CLASSES_ROOT progid "CLSID" True)
when (not (null progid) && not (null vprogid))
(regRemoveEntry HKEY_CLASSES_ROOT progid "CurVer" True)
when (not (null vprogid)) (regRemoveEntry HKEY_CLASSES_ROOT (vprogid ++ "\\CLSID") clsid_str False)
when (not (null vprogid)) (regRemoveEntry HKEY_CLASSES_ROOT vprogid "CLSID" True)
return ()
\end{code}