7.8 Wrapping up COM components

OK, you've written the IDL, generated the HaskellDirect proxies and implemented the methods of your Haskell COM component - now how do you actually wrap it up as a real, live COM component that's accessable by any old COM client? This section shows you how to do just that, presenting the mechanism by which you declare what components your code implements. The support libraries that take care of the rest are presented in the tailend of this section, but the details of which are probably only of interest to the implementor(s) of this Haskell COM framework.

Declaring your components

By convention, you declare the components that your Haskell code implements by defining comComponents in module Main:

Main.comComponents :: [ComponentInfo]

i.e., a COM server can implement one or more components. The ComponentInfo is an abstract type containing the various pieces of information that you need to communicate to the underlying support code, so that it can register and create instances of the component for you:

data ComponentInfo = .. -- abstract

type RegisterComponent
  =  ComponentInfo
  -> String        -- path to where the component's DLL is installed.
  -> Bool          -- register or unregister?
  -> IO ()

type ComponentConstructor
  =  String            -- path to where the component's DLL is installed.
  -> IID (IUnknown ()) -- IID of interface to create the component at.
  -> IO (IUnknown ())  -- interface pointer to use (and abuse?)

mkComponentInfo :: CLSID  
                -> RegisterComponent
                -> ComponentConstructor
                -> ComponentInfo

ComponentInfos are initially built using mkComponentInfo, supplying the CLSID which identifies the component along with a pair of actions that perform the registration and creation of a component instance.

HaskellDirect will for each component that you declare in IDL (using the coclass construct), generate a corresponding ComponentInfo for you. See Section ToDo for details of exactly what the generated ComponentInfo contains.

You can customise the automatically generated ComponentInfo using the following combinators:

withProgID         :: ProgID -> ComponentInfo -> ComponentInfo
withVerIndepProgID :: ProgID -> ComponentInfo -> ComponentInfo
withComponentName  :: String -> ComponentInfo -> ComponentInfo

onRegister         :: RegisterComponent -> ComponentInfo -> ComponentInfo
onFinalize         :: IO ()  -> ComponentInfo -> ComponentInfo

withProgID lets you specify the ProgID (i.e., a humanly-readable identifier for your component of the form <Vendor>.<Component>), that's sometimes easier to use and refer to (cf. CreateObject).

withComponentName lets you attach a short descriptive string of what your component is -- this string is displayed by some object browsers.

Here's an example use of these combinators:

comComponents =
  [ withProgID          "Haskell.PBX.1" $
    withVerIndepProgID  "Haskell.PBX"   $
    withComponentName   "A simple phone directory" $
    PBXProxy.componentInfo --  automatically generated by HDirect.
  ]

Notice that the above customisations are entirely optional - your component will be eminently useable if you decide to just use the automatically generated ComponentInfo.

The pre-generated ComponentInfo includes IO actions which will take care of (un)registering your component in standard ways (i.e., adding itself directly to the Registry.) Should you want to provide custom registration actions via onRegister, ComDll also exports actions for adding and deleting values from the Registry:

regAddEntry :: RegHive
            -> String
            -> Maybe String -- Nothing => new key.
            -> IO ()
regRemoveEntry :: RegHive
               -> String
               -> String
               -> Bool
               -> IO ()

data RegHive
 = HKEY_CLASSES_ROOT
 | HKEY_CURRENT_USER
 | HKEY_LOCAL_MACHINE
 | HKEY_USERS
 | KHEY_CURRENT_CONFIG
   deriving ( Eq, Ord, Enum )

That's it, really - see the example section for instructions of what commands to use to compile up and link the DLL containing the COM server.

In-proc COM server basics

[ Starting with this section, we present the gory details of how the COM component wrapper libraries takes a list of ComponentInfos and wraps those up as COM in-proc servers. Feel free to ignore (unless you're a sucker for low-level details :-) ]

A self-registering, COM in-proc server is delivered in DLL-form, and needs to export the following five entry points:

BOOL
STDCALL
DllMain(               // return TRUE is everything is ok.
  HINSTANCE hinstDLL,  // handle to DLL module
  DWORD fdwReason,     // 4 reasons for calling this function, 
                       // (attach/detach process/thread)
  void* lpvReserved    // reserved (duh!)
);

HRESULT STDCALL DllCanUnloadNow();
HRESULT STDCALL DllRegisterServer();
HRESULT STDCALL DllUnregisterServer();
HRESULT STDCALL DllGetClassObject( 
    REFCLSID rclsid, //CLSID for the class object 
    REFIID riid,     //Reference to the identifier of the interface 
                     // that communicates with the class object
                     // (normally IID_IClassFactory)                   
    void** ppv       //Address of output variable that receives the 
                     // interface pointer requested in riid 
    );

where DllMain is the main DLL entry point (doh!), which is called upon DLL load (and unload) etc. Registration is done via DllRegisterServer() and DllUnregisterServer(), whereas component instances are created via DllGetClassObject(). More about all this next.

The outermost layer

Almost all of the code required to implement Haskell COM in-proc servers is written in Haskell. The only bit that's not, is a boilerplate C implementation of the signatures given in the previous section:

ComDll* comDll = NULL;

extern ComDll* newComDll ( HANDLE hMod );

BOOL
STDCALL
DllMain
   ( HANDLE hModule
   , DWORD reason
   , void* reserved
   )
{
  if (reason == DLL_PROCESS_ATTACH) {
      comDll = newComDll(hModule);
      return TRUE;
  } else {
    if (comDll && reason == DLL_PROCESS_DETACH) {
        (comDll)->dllUnload();
    }
    return TRUE;
  }
}

HRESULT
STDCALL
DllCanUnloadNow (void)
{
  if (comDll) {
     return (comDll)->dllCanUnloadNow();
  } else {
     return S_OK;
  }
}

HRESULT
STDCALL
DllRegisterServer (void)
{
  if (comDll) {
     return (comDll)->dllRegisterServer();
  } else {
    return E_FAIL;
  }
}

HRESULT
STDCALL
DllUnregisterServer (void)
{
  if (comDll) {
    return (comDll)->dllUnregisterServer();
  } else {
    return E_FAIL;
  }
}

HRESULT
STDCALL
DllGetClassObject
  ( CLSID* rclsid
  , IID*   riid
  , void** ppv
  )
{
  HRESULT hr;
  if (comDll) {
     hr = (comDll)->dllGetClassObject(rclsid, riid, ppv);
     return S_OK;
  } else { 
     return E_FAIL;
  }
}

As is evident, the wrappers simply delegate to methods in a ComDll structure:

typedef struct IComDll {
   void    (*dllUnload)();
   HRESULT (*dllCanUnloadNow)();
   HRESULT (*dllRegisterServer)();
   HRESULT (*dllUnregisterServer)();
   HRESULT (*dllGetClassObject)(CLSID* clsid, IID* iid,
                                void** ppv);
} ComDll;

extern ComDll* newComDll(HANDLE hMod);

which is created via newComDll. Unsurprisingly, newComDll is implemented in Haskell, and its implementation is presented in the next section.

Implementing the DLL entry points in Haskell

Implementing the DLL entry points of a COM in-proc server in Haskell means that we need to be able to wrap up Haskell functions behind a C-callable interface in order to fill in a ComDll method table.

We show how to do this here using the GHC/Hugs FFI, which is only supported fully under GHC at the moment. Getting this to work under Hugs / HaskellScript isn't beyond the realms of possibility either, but currently un-supported (by HaskellDirect, at least).

The ComDll module takes care of implementing the goods, with the ComDll method table constructor being:

createIComDll :: Addr{-HMODULE-}
              -> [ComponentInfo]
              -> IO (VTable iid_comDllState ComDllState)

In addition to the Win32 module HANDLE, it is passed the user-supplied list of ComponentInfo of the components to wrap up. The connection between createIComDll and the user's comComponents is made by newComDll in a separate module, ComDllMain:

module ComDllMain where

import Main   ( comComponents )
import ComDll ( createIComDll )
import Com    ( putMessage )
import Addr

newComDll :: Addr -> IO Addr
newComDll handle = createIComDll handle comComponents

foreign export ccall "newComDll" newComDll :: Addr -> IO Addr

The reason for putting newComDll in a separate module is that we want to share the code contained in the ComDll library between all our COM in-proc servers. So, ComDllMain just makes the connection between it and the user's Main module, and has to be included when linking the component DLL.

The definition of newComDll makes use of a foreign export FFI declaration in order to make it callable from C code. When the component DLL is loaded, the entry point DllMain() is invoked, which then calls newComDll.

Returning to createIComDll,

createIComDll :: Addr{-HMODULE-}
              -> [ComponentInfo]
              -> IO (VTable iid_comDllState ComDllState)
createIComDll hMod components = do
   state       <- newComDllState hMod components
   meths       <- iComDllEntryPoints state
   createVTable meths

iComDllEntryPoints :: ComDllState -> IO [Addr]
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
         ]

it fills in a ComDll method table by exporting five Haskell functions using foreign export dynamic FFI declarations,

foreign export ccall dynamic 
   export_DllUnload :: (IO ()) -> IO Addr
foreign export ccall dynamic 
   export_nullaryMeth :: (IO HRESULT) -> IO Addr

foreign export ccall dynamic
   export_dllGetClassObject :: (Addr -> Addr -> Addr -> IO HRESULT) -> IO Addr

From the declaration for export_dllGetClassObject, the Haskell system will generate an IO action with its stated type. When applied to an IO action, it will return a C function pointer that when it is invoked, will execute the IO action, passing it the arguments that it was passed on the C stack.

In our case, the actions that we export are partially applied to the state that each component wrapper needs to maintain:

data ComDllState
  = ComDllState {
      dllPath    :: String, 
      components :: IORef [ComponentInfo],
      lockCount  :: IORef Int
     }

newComDllState :: Addr{-HANDLE-}
               -> [ComponentInfo]
               -> IO ComDllState

Of the entries in the ComDll method table, the dllGetClassObject method is the one that's really of interest:

Consult the source code for ComDll if you want to find out more about how the others are implemented.

dllGetClassObject :: ComDllState
                  -> Ptr CLSID
                  -> Ptr (IID a)
                  -> Ptr (PrimIP a)
                  -> IO HRESULT
dllGetClassObject comDll rclsid riid ppvObject = do
  iid <- unmarshallIID riid
  if ( iidToGUID iid /= iidToGUID iidIClassFactory ) then
     return e_NOINTERFACE
   else do
    clsid <- unmarshallCLSID rclsid
    cs    <- readIORef (components comDll)
    case lookupCLSID clsid cs of
      Nothing -> return cLASS_E_CLASSNOTAVAILABLE
      Just i  -> do
         ip <- createClassFactory (newInstance i (dllPath comDll))
         writeAddr ppvObject (ifaceToAddr ip)
         return s_OK

lookupCLSID :: CLSID -> [ComponentInfo] -> Maybe ComponentInfo

The DllGetClassObject() method is eventually called by COM on behalf of a client wanting to create an instance of your component.

Consult other COM documentation (the COM spec, for instance) for details of how COM maps from component identity (i.e., CLSIDs) to your in-proc DLL.

Assuming the rclsid argument to dllGetClassObject identifies a component that's supported, we create an instance of a class factory through which a client can create instances of your component. To be able to do just that, the class factory constructor needs to be passed the Haskell action that actually instantiates the component:

createClassFactory :: (IID (IUnknown ()) -> IO (IUnknown ()))
                   -> IO (IClassFactory ())

The next section shows how this class factory is implemented.

A class factory

The IClassFactory interface is defined as follows:

[...]
interface IClassFactory : IUnknown {
 HRESULT CreateInstance
               ( [in]IUnknown* pUnkOuter
               , [in]REFIID    riid
               , [out]void**   ppv
               );
 HRESULT LockServer
               ( [in]BOOL fLock );
};

LockServer gives you a way of keeping a class factory in memory, and not have it unload itself -- an optimisation that's occasionally worthwhile. CreateInstance does the actual creation of a component,

createInstance :: This_ClassFactory 
               -> Ptr (PrimIP a)
               -> Ptr (IID (IUnknown b))
               -> Ptr (PrimIP b)
               -> IO HRESULT
createInstance this punkOuter riid ppv
 | punkOuter /= nullAddr = return cLASS_E_NOAGGREGATION
 | otherwise             = do
    st   <-  getObjState this
    iid  <-  unmarshallIID riid
    unk  <-  (new_instance st) iid
    writeAddr ppv (ifaceToAddr unk)
    return s_OK

As you can see, there's no support for aggregation just yet (but there ought to be). Non-aggregated instances are created by simply delegating to the action that was supplied when creating the class factory. The object state that's accessible from an IClassFactory interface pointer has got the following type:

data ClassFactory a
 = ClassFactory {
         new_instance :: (IID (IUnknown ()) -> IO (IUnknown ())),
         lockCount    :: (IORef Int)
   }

type IClassFactory a   = IUnknown (ClassFactory a)
type This_ClassFactory = Ptr (IClassFactory ())