com 1.2.2 → 1.2.3
raw patch · 18 files changed
+456/−129 lines, 18 files
Files
- CHANGES +5/−0
- ComDllMain.hs +28/−0
- System/Win32/Com.hs +132/−67
- System/Win32/Com/Automation.hs +44/−16
- System/Win32/Com/Base.hs +1/−1
- System/Win32/Com/ClassFactory.hs +1/−1
- System/Win32/Com/Dll.hs +66/−26
- System/Win32/Com/Exception.hs +35/−6
- System/Win32/Com/HDirect/HDirect.hs +1/−1
- System/Win32/Com/HDirect/Pointer.hs +1/−1
- System/Win32/Com/Server.hs +1/−1
- System/Win32/Com/Server/ConnectionPoint.hs +1/−1
- System/Win32/Com/Server/EnumInterface.hs +1/−1
- System/Win32/Com/Server/ExeServer.hs +1/−1
- System/Win32/Com/Server/StdDispatch.hs +1/−1
- cbits/ComPrimSrc.c +3/−3
- cbits/dllStub.c +127/−0
- com.cabal +7/−2
CHANGES view
@@ -1,3 +1,8 @@+Version 1.2.3 - released 2009-01-27; changes from 1.2.2 + + * Improved and expanded Haddock comments throughout. + * Fixed allocator mismatch bug in Com.Base.getModuleFileName + Version 1.2.2 - released 2009-01-27; changes from 1.2.1 * built-in enumeration handling of variants (via the
+ ComDllMain.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS -#include "ComDllMain_stub.h" #-}+-----------------------------------------------------------------------------+-- |+-- Module : ComDllMain+-- Copyright : (c) Sigbjorn Finne, sof@forkIO.com 1999-2009+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : sof@forkIO.com+-- Stability : provisional+-- Portability : portable+--+-- The 'main-Main' to link with when building a DLL containing+-- a Haskell in-proc COM component.+-- +-----------------------------------------------------------------------------+module ComDllMain where++import Main ( comComponents )+import ComDll ( createIComDll )+import Com ( putMessage )+import Foreign.Ptr++newComDll :: Ptr () -> IO (Ptr (Ptr ()))+newComDll handle = do+ (ip,_) <- createIComDll handle comComponents+ return ip++foreign export ccall "newComDll" newComDll :: Ptr () -> IO (Ptr (Ptr ()))
System/Win32/Com.hs view
@@ -5,12 +5,11 @@ -- Copyright : (c) Sigbjorn Finne, sof@dcs.gla.ac.uk 1999 -- License : BSD-style (see the file libraries/base/LICENSE) -- --- Maintainer : sof@galois.com +-- Maintainer : sof@forkIO.com -- Stability : provisional -- Portability : portable -- --- Support library for using and generating client stubs --- for Com objects. +-- Support library for interacting with base Microsoft COM services and API. -- ----------------------------------------------------------------------------- module System.Win32.Com @@ -235,9 +234,33 @@ -- -- ip # meth1 args +-- | The @#@ operator permits /OO-style/ method application with @do@ syntax: +-- +-- @ +-- obj # method arg1 arg2 +-- @ +-- +-- is equivalent to @method arg1 arg2 obj@, so this assumes that the COM method +-- wrappers takes the /this/ pointer as the last argument. Which the /HDirect/ +-- generated wrappers do and the various base method provided by this COM+Automation library. ( # ) :: a -> (a -> IO b) -> IO b obj # method = method obj +-- | A variation on @(#)@ where the /this/ pointer is an action returning an object reference +-- rather than the reference itself. Sometimes useful when you create one-off objects +-- and call methods on them: +-- +-- @ +-- (createObject arg1) ## startUp arg2 +-- @ +-- +-- instead of the wieldier, +-- +-- @ +-- obj <- createObject arg1 +-- obj # startUp arg2 or createObject arg1 >>= (startUp arg2) +-- @ +-- ( ## ) :: IO a -> (a -> IO b) -> IO b mObj ## method = mObj >>= method @@ -250,13 +273,14 @@ iidIPersistFile :: IID (IPersistFile ()) iidIPersistFile = mkIID "{0000010B-0000-0000-C000-000000000046}" -{- -Create instance. - -@coCreateInstance@ is the basic COM way of creating components. It takes -a CLSID, an interface to aggregate on, a process context and an IID to create an object: -@coCreateInstance clsidAgentServer interfaceNULL LocalProcess iidIAgent@. --} +-- | @coCreateInstance@ is the basic COM way of creating components. It takes +-- a 'CLSID', an interface to aggregate on, a process context and an IID to +-- create an object: +-- +-- @ +-- coCreateInstance clsidAgentServer interfaceNULL LocalProcess iidIAgent +-- @ +-- coCreateInstance :: CLSID -> Maybe (IUnknown b) -> CLSCTX @@ -296,32 +320,27 @@ marshallInner Nothing = return nullFO marshallInner (Just v) = marshallIUnknown v -{- -Create Objects: - prepend @co@ to specify the initial IID, otherwise @iidIDispatch@ is - used (see @Automation@ library for more). - -@createObject@ creates an object from its progID: @createObject "Agent.Server"@. -@getObject@ creates an object from its progID and initializes it with a given file: -@getObject "spreadsheet.exl" "Excel.Application"@. If the filename is empty, -@getObject@ calls @getActiveObject@. -@getActiveObject@ tries to connect to an already running instance of the component: -@getActiveObject "Word.Application"@. -@getFileObject@ opens a file or url and loads the associated or persistent object in it: -@getFileObject "spreadsheet.spd"@. -@coCreateInstance@ is the basic com way of creating components. It takes -a CLSID, process context and IID to create an object: -@coCreateInstance clsidAgentServer Nothing LocalProcess iidIAgent@. --} - +-- | @createObject@ creates an object from its progID: @createObject "Agent.Server"@. +-- @getObject@ creates an object from its progID and initializes it with a given file: +-- @getObject "spreadsheet.exl" "Excel.Application"@. If the filename is empty, +-- @getObject@ calls @getActiveObject@. +-- @getActiveObject@ tries to connect to an already running instance of the component: +-- @getActiveObject "Word.Application"@. +-- @getFileObject@ opens a file or url and loads the associated or persistent object in it: +-- @getFileObject "spreadsheet.spd"@. +-- @coCreateInstance@ is the basic com way of creating components. It takes +-- a CLSID, process context and IID to create an object: +-- @coCreateInstance clsidAgentServer Nothing LocalProcess iidIAgent@. +-- +-- NOTE: prepend @co@ to specify the initial IID, otherwise @iidIDispatch@ is +-- used (see 'System.Win32.Com.Automation' for more). +-- coCreateObject :: ProgID -> IID (IUnknown a) -> IO (IUnknown a) coCreateObject progid iid = do clsid <- clsidFromProgID progid coCreateInstance clsid Nothing AnyProcess iid -{- -Get Object from File \& ProgID. --} +-- | Get Object from File and ProgID. coGetFileObject :: String -> ProgID -> IID (IUnknown a) -> IO (IUnknown a) coGetFileObject "" progid iid = coGetActiveObject progid iid coGetFileObject fname progid iid = do @@ -330,7 +349,7 @@ persistfileLoad pf pfname 0 pf # queryInterface iid ---Get Active Object. +-- | Look up and activate the given active/running object. coGetActiveObject :: ProgID -> IID (IUnknown a) -> IO (IUnknown a) coGetActiveObject progid iid = do clsid <- clsidFromProgID progid @@ -346,7 +365,7 @@ doThenFree free (readIUnknown False{-finalise only-}) ppvObject ---Bind to object via 'moniker string' / display name. +-- | Bind to an object via its /moniker string/ or display name. coGetObject :: String -> IID (IUnknown a) -> IO (IUnknown a) coGetObject fname iid = do stackWideString fname $ \pfname -> do @@ -356,6 +375,9 @@ --COM initialize/uninitialize: +-- | @coRun act@ is the toplevel action combinator to wrap up your +-- COM actions in. Takes care of calling 'coInitialize' (and un-initialize) +-- for you. coRun :: IO a -> IO a coRun io = do coInitialize @@ -368,6 +390,9 @@ coUnInitialize return v +-- | @coPerformIO act@ runs @act@ within an exception handler that +-- catches and displays any COM API errors in a message box. For debugging +-- purposes, mostly. coPerformIO :: IO a -> IO a coPerformIO io = catchComException io @@ -379,9 +404,11 @@ coUnsafePerformIO :: IO a -> a coUnsafePerformIO = unsafePerformIO . coPerformIO +-- | @printMessage val@ /show/s @val@ in a message box. printMessage :: Show a => a -> IO () printMessage x = putMessage (show x) +-- | @putMessage str@ displays @str@ in an informational message box containing an OK button. putMessage :: String -> IO () putMessage msg = stackString msg $ \ _ m -> @@ -389,12 +416,16 @@ Base.messageBox m t 0x40040 {- To mere mortals, that's MB_OK | MB_ICONINFORMATION | MB_TOPMOST :-) -} +-- | @messageBox msg title flg@ displays a message box with the given title and content. +-- The @flg@ parameter is the bit pattern that makes up the @MB_*@ settings you want +-- to use (cf. underlying Win32 API documentation for @MessageBox@.) messageBox :: String -> String -> Word32 -> IO () messageBox msg title flg = stackString msg $ \ _ m -> stackString title $ \ _ t -> Base.messageBox m t flg +-- | @outputDebugString str@ adds an outputDebugString :: String -> IO () outputDebugString msg = primOutputDebugString ("haskell-com: " ++ msg ++ "\n") @@ -422,12 +453,10 @@ (j,n,d) <- primGetVersionInfo return (OSVersionInfo j n d) -{- -Enumeration used by @comCreateInstance@ to specify execution -context in which we'd like to component to be created -(just use @AnyProcess@ if you're not fussed): --} - +-- | The @CLSCTX@ enumeration is used by @comCreateInstance@ to specify +-- execution context in which we'd like to component to be created +-- (just use @AnyProcess@ if you're not too fussed..) +-- data CLSCTX = CLSCTX_INPROC_SERVER | CLSCTX_INPROC_HANDLER @@ -492,11 +521,17 @@ hr <- primInvokeItFO meth offset (marshallIUnknown iptr) checkHR hr +-- | @invokeIt (\ methPtr ip -> action) offset obj@ sets up a vtbl-indexed +-- COM call, unmarshalling and indexing @obj@ before passing it along to the +-- method argument. The first argument is typically an FFI wrapped call to +-- a function pointer (@methPtr@ here). +-- +-- invokeIt :: (Ptr any -> Ptr c -> IO a) -> Int -> IUnknown b -> IO a invokeIt meth offset iptr = primInvokeItFO meth offset (marshallIUnknown iptr) {- -Library provided stubs for IEnum* interfaces - the HaskellDirect +Library provided stubs for IEnum* interfaces - the HaskellDirect compiler knows how to generate code for these: -} enumNext :: Word32 -> (Ptr any -> IO a) -> Word32 -> IUnknown b -> IO [a] @@ -580,14 +615,23 @@ -- simply define it here. type LPSTR = String +-- | @coFree ptr@ releases storage that has been allocated via the COM task allocator; +-- explicitly via @coAlloc@ or indirectly via the APIs that handed the pointer to your +-- code. coFree :: Ptr a -> IO () coFree p = freeMemory p +-- | @coAlloc sz@ allocates @sz@ bytes from the COM task allocator, returning a pointer. +-- The onus is on the caller to constrain the type of that pointer to capture what the +-- allocated memory points to. coAlloc :: Word32 -> IO (Ptr a) coAlloc sz = allocMemory sz +-- | @ProgID@s are represented in Haskell as mere strings type ProgID = String +-- | @clsidFromProgID progid@ looks up a @ProgID@ and tries to translate it into +-- its registered @CLSID@. Raises an IO exception if the @ProgID@ isn't known. clsidFromProgID :: ProgID -> IO CLSID clsidFromProgID progid = stackString progid $ \ _ pprogid -> do @@ -596,6 +640,8 @@ ("Component '" ++ progid ++ "' is unknown") unmarshallCLSID True pclsid +-- | @progIDFromCLSID cid@ is the dual @clsidFromProgID@, attempting to translate +-- in the other direction. progIDFromCLSID :: CLSID -> IO ProgID progIDFromCLSID clsid = do pclsid <- marshallCLSID clsid @@ -608,7 +654,7 @@ return str ---Type libraries are identified by a GUID too: +-- | Type libraries are identified by a GUID, the @LIBID@. type LIBID = GUID mkLIBID :: String -> LIBID @@ -616,31 +662,33 @@ type LCID = Word32 -{- -Representing interface pointers - -To represent a (COM) interface pointer, we use the type <tt/IUnknown/, -which is parameterised over its interface: --} +-- | Representing interface pointers via @IUnknown a@, where @a@ is +-- the particular @IUnknown@-extended interface, e.g., @IUnknown IDispatch_@. +-- If the interface pointer is /just/ @IUnknown@, use @IUnknown ()@. +-- +-- Extend this to @IID@s and parameterize them over the interface they +-- represent. iidIUnknown :: IID (IUnknown ()) iidIUnknown = mkIID "{00000000-0000-0000-C000-000000000046}" -{- -Equality of interface pointers is defined by the COM spec -as being equality of IUnknown (pointers to) implementations. --} +-- | Equality of interface pointers is defined by the COM spec +-- as being equality of IUnknown (pointers to) implementations. instance Eq (IUnknown_ a) where iface1 == iface2 = coEqual (castIface iface1) (castIface iface2) +-- | @castIface obj@ performs a type castIface :: IUnknown a -> IUnknown b castIface (Unknown o) = Unknown o +-- | @interfaceNULL@ is the @NULL@ interface pointer. interfaceNULL :: IUnknown a interfaceNULL = unsafePerformIO (unmarshallIUnknown False nullPtr) +-- | @isNullInterface iptr@ returns @True@ iff @iptr@ is the NULL pointer. isNullInterface :: IUnknown a -> Bool isNullInterface (Unknown ip) = foreignPtrToPtr ip == nullPtr +-- | The null interface iidNULL :: IID () iidNULL = mkIID "{00000000-0000-0000-0000-000000000000}" @@ -650,10 +698,11 @@ shows (ifaceToAddr iface) . shows ">" -{- -Library provided stubs for IUnknown's methods: -(derived from H/Direct output) --} +-- | @queryInterface iid iunk@ queries @iunk@ if it supports the @iid@ +-- interface, returning it. Notice that the type parameter to the @IID@ +-- matches up with that of the resulting interface pointer, giving you +-- type safety - i.e., you can only use the interface pointer with methods +-- supported by that interface queryInterface :: IID (IUnknown b) -> IUnknown a -> IO (IUnknown b) queryInterface riid iptr = do ppvObject <- allocOutPtr @@ -661,9 +710,15 @@ invokeIt (\ methPtr ip -> primQI methPtr ip (castForeignPtr priid) ppvObject) 0 iptr doThenFree free (readIUnknown False{-finalise only-}) ppvObject +-- | @addRef iptr@ increases the reference count of the interface pointer @iptr@. +-- Notice that interface pointers are managed and finalized when on the Haskell heap, +-- so manual reference counting is not required (and not encouraged as it could prevent +-- the underlying object from being properly released, should you forget to decrement +-- the ref count with @release@.) addRef :: IUnknown a -> IO Word32 addRef iptr = invokeIt (\ methPtr ip -> primAddRef methPtr ip) 1 iptr +-- | @addRef iptr@ decrements the reference count of the interface pointer @iptr@. release :: IUnknown a -> IO Word32 release iptr = invokeIt (\ methPtr ip -> primRelease methPtr ip) 2 iptr @@ -679,7 +734,7 @@ persistfileLoad iptr pszFileName dwMode = invokeIt (\ methPtr ip -> primPersistLoad methPtr ip pszFileName dwMode) 5 iptr ---GUIDs: +-- | @GUID@ is the Haskell representation for COM GUIDs. newtype GUID = GUID (ForeignPtr ()) --(Pointer Guid) data Guid = Guid @@ -687,6 +742,7 @@ mkGUID :: String -> GUID mkGUID str = unsafePerformIO (stringToGUID str) +-- | @newGUID@ generates a new unique GUID. newGUID :: IO GUID newGUID = do pg <- coAlloc sizeofGUID @@ -703,16 +759,18 @@ marshallGUID :: GUID -> IO (ForeignPtr GUID) marshallGUID (GUID ptr) = return (castForeignPtr ptr) -{- - A version of the GUID marshaller which copies rather - than hands back a pointer to the (immutable) GUID. --} +-- | A version of the GUID marshaller which copies rather +-- than hands back a pointer to the (immutable) GUID. copyGUID :: GUID -> IO (Ptr ()) copyGUID (GUID ptr) = do pg <- coAlloc sizeofGUID primCopyGUID ptr pg return pg +-- | @unmarshallGUID finalize ptr@ unpacks a pointer to an incoming +-- GUID, wrapping it up as a Haskell 'GUID'. If @finalize@ is @True@, +-- the GUID is assumed allocated via the COM task allocator and will +-- be freed/finalized when the 'GUID' becomes garbage. unmarshallGUID :: Bool -> Ptr GUID -> IO GUID unmarshallGUID finaliseMe ptr = do -- ToDo: verify that HDirect *never ever* allocates and @@ -723,6 +781,9 @@ f <- makeFO ptr (castPtrToFunPtr $ if finaliseMe then finalFreeMemory else finalNoFree) return (GUID f) +-- | @writeGUID ptr g@ packs the Haskell 'GUID' into the pointer; that is, +-- it writes a pointer to the GUID value to @ptr@ -- no copying of underlying +-- structure. writeGUID :: Ptr GUID -> GUID -> IO () writeGUID ptr (GUID g) = poke (castPtr ptr) (foreignPtrToPtr g) @@ -734,6 +795,8 @@ sizeofGUID :: Word32 sizeofGUID = 16 +-- | @stringToGUID "{00000000-0000-0000-C000-0000 0000 0046}"@ translates the +-- COM string representation for GUIDs into an actual 'GUID' value. stringToGUID :: String -> IO GUID stringToGUID str = stackWideString str $ \xstr -> do @@ -741,6 +804,8 @@ primStringToGUID xstr (castPtr pg) unmarshallGUID True pg +-- | @stringFromGUID g@ converts the 'GUID' @g@ into the COM string representation +-- @{aaaaaaaa-bbbb-cccc-dddd-eeeeeeeeeeee}@ stringFromGUID :: GUID -> IO String stringFromGUID guid = do pguid <- marshallGUID guid @@ -756,15 +821,15 @@ guidToString ptr = unsafePerformIO (stringFromGUID ptr) {- -Give the interface identifier(IID) a type parameter, so that when -we come to define the Haskell type of <tt/IUnknown.QueryInterface(),/ -we can use the type checker to ensure that the IID passed to -<tt/QueryInterface/ agrees with the interface at which we're using -the interface pointer that's returned (Hmm..this'll hopefully all become -clearer.) -} - +-- | Representation of @IID@s: Give the interface identifier +-- a type parameter, so that when we come to define the Haskell +-- type of @IUnknown.QueryInterface()@ we can rely on the type checker +-- to ensure that the @IID@ passed to @QueryInterface@ agrees with +-- the interface at which we're using the interface pointer that's +-- returned newtype IID a = IID GUID deriving ( Eq ) + newtype CLSID = CLSID GUID deriving ( Eq ) mkIID :: String -> IID a
System/Win32/Com/Automation.hs view
@@ -5,11 +5,16 @@ -- Copyright : (c) Daan Leijen <leijen@fwi.uva.nl>, Sigbjorn Finne <sof@dcs.gla.ac.uk> 1998-99, Sigbjorn Finne <sigbjorn.finne@gmail.com> 2000-2009 -- License : BSD-style (see the file libraries/base/LICENSE) -- --- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com> +-- Maintainer : Sigbjorn Finne <sof@forkIO.com> -- Stability : provisional -- Portability : portable -- --- Support library for accessing OLE Automation objects. +-- Accessing COM / OLE Automation objects from Haskell clients. This library +-- provides a fairly high-level view of Automation objects and the data values +-- that their methods support. Transparent marshalling of arguments and invocation +-- over Automation objects is supported via the 'Variant' class and a family +-- of @invoke@ methods. This is also extended to cover the properties/fields of +-- such objects. -- ----------------------------------------------------------------------------- module System.Win32.Com.Automation ( @@ -161,20 +166,20 @@ import System.IO ( hPutStrLn, stderr ) -{- -The following creation functions are the VB equivalents in Haskell, -notice the `unsafe' interface pointer return types used here. The -interface pointers returned are compatible with the stubs for -*any* IDispatch-derived interface. This makes it more convenient -(saves the extra QI / type cast), but means that it is now -possible to get run-time errors of the sort: -'method X called but not supported'. --} +-- | @createObject progid@ is the Haskell equivalent of +-- VB's @CreateObject@, trying to instantiate a new +-- Automation object via an 'IDispatch' interfac pointer. createObject :: ProgID -> IO (IDispatch a) createObject progid = coCreateObject progid iidIDispatch_unsafe +-- Notice the `unsafe' interface pointer return types used here. The +-- interface pointers returned are compatible with the stubs for +-- *any* IDispatch-derived interface. This makes it more convenient +-- (saves the extra QI / type cast), but means that it is now +-- possible to get run-time errors of the sort: +-- 'method X called but not supported'. iidIDispatch_unsafe = mkIID "{00020400-0000-0000-C000-000000000046}" getFileObject :: String -> ProgID -> IO (IDispatch a) @@ -246,13 +251,16 @@ propertySet_4 name a1 a2 a3 a4 = propertySet name [inVariant a1, inVariant a2, inVariant a3, inVariant a4] --- Automation member functions or properties are identified --- by name or DISPID. - +-- | Automation 'Member' functions or properties are identified +-- by either name or 'DISPID'. The latter saving you from having +-- to do a method name resolution for each invocation. type Member = String -- type DISPID = Int sizeDISPID = 4 +-- | @getMemberID memberName obj@ translates the @memberName@ string +-- into the unique 'DISPID' representing that method/property. If unknown, +-- a COM exception is raised. getMemberID :: Member -> IDispatch a -> IO DISPID getMemberID name obj = do bstr <- allocBSTR name @@ -262,19 +270,39 @@ return dispid where handleErr hr err - | hr == dISP_E_UNKNOWNNAME = coFail ("method '" ++ name ++ "' called but not supported by object") -- " + | hr == dISP_E_UNKNOWNNAME = coFail ("method '" ++ name ++ "' called but not supported by object") | otherwise = errorMember name err {- -Type definitions for marshalling functions. Variants are represented +Type definitions for the marshalling functions. Variants are represented as functions that can read or write a value from or to a variant structure. -} + +-- | @VarIn@ is the marshaller for 'Variant' arguments; a function that +-- takes (a pointer to) a VARIANT structure and fills it in with value +-- it encodes. type VarIn = VARIANT -> IO () + +-- | @VarRes@ is the unmarshaller for 'Variant results; a function that +-- takes (a pointer to) the VARIANT result and unscrambles its contents +-- into the Haskell value representing that 'Variant' result. type VarRes a = VARIANT -> IO a +-- | @ArgIn@ is the extension of 'VarIn', returning a 'VarIn' marshaller +-- for some 'Variant'-supported value of type @a@. type ArgIn a = a -> VarIn + +-- | @ArgRes@ is the 'Variant' unmarshaller for results of type @a@, where +-- is one of the 'Variant' supported types. type ArgRes a = VarRes a + +-- | @ArgOut a@ represent an @in-out@ Automation parameter, pairing a marshaller +-- with an unmarshaller for some type. Notice that the input value being marshalled +-- may not have the same type as the output/result value being unmarshalled. type ArgOut a = (VarIn,ArgRes a) + +-- | @ArgInOut a b@ is the general 'in-out' parameter marshaller and result +-- unmarshaller. type ArgInOut a b = a -> ArgOut b {-
System/Win32/Com/Base.hs view
@@ -654,7 +654,7 @@ getModuleFileName hModule = do o_getModuleFileName <- prim_System_Win32_Com_Base_getModuleFileName hModule - doThenFree freeString unmarshallString o_getModuleFileName + doThenFree free_malloc unmarshallString o_getModuleFileName foreign import ccall "getModuleFileName" prim_System_Win32_Com_Base_getModuleFileName :: Ptr () -> IO (Ptr String) messagePump :: IO ()
System/Win32/Com/ClassFactory.hs view
@@ -4,7 +4,7 @@ -- Copyright : (c) Sigbjorn Finne <sof@dcs.gla.ac.uk> 1998-99 -- License : BSD-style (see the file libraries/base/LICENSE) -- --- Maintainer : sof@galois.com +-- Maintainer : sof@forkIO.com -- Stability : provisional -- Portability : portable --
System/Win32/Com/Dll.hs view
@@ -5,15 +5,16 @@ -- Copyright : (c) Sigbjorn Finne <sof@dcs.gla.ac.uk> 1998-99 -- License : BSD-style (see the file libraries/base/LICENSE) -- --- Maintainer : sof@galois.com +-- Maintainer : sof@forkIO.com -- Stability : provisional -- Portability : portable -- -- 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. +-- The main function is 'createIComDll' which packages up a list of 'ComponentInfo' +-- values specifying the Haskell implementation of COM objects. It returns +-- a method table which you can then wrap up as a DLL by calling its +-- COM-mandated entry points via. -- ----------------------------------------------------------------------------- module System.Win32.Com.Dll @@ -27,7 +28,7 @@ , onFinalize , hasTypeLib - , createIComDll -- :: Ptr (){-HMODULE-} -> [ComponentInfo] -> IO + , createIComDll -- :: Ptr (){-HMODULE-} -> [ComponentInfo] -> IO (VTable iid_comDllState ComDllState) , regAddEntry , regRemoveEntry @@ -35,6 +36,8 @@ , stdRegComponent , stdUnRegComponent + + , ComponentFactory ) where import System.Win32.Com.ClassFactory @@ -52,56 +55,86 @@ import Control.Monad import Data.List ( find ) -{- -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: --} - +-- | The information an implementation of a Haskell COM component +-- needs to supply in order to hook into the machinery provided +-- by @System.Win32.Com.Dll@ for interfacing to how COM does +-- activation for in-proc components +-- +-- To create one or more, you pass them into 'createIComDll'.. 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 + { newInstance :: ComponentFactory -- ^ the object factory method. + , componentFinalise :: IO () -- ^ IO action to call when the + , componentName :: String -- ^ the display name. + , componentProgID :: String -- ^ the programmatic/VB ID string (versioned, if needed.) + , componentVProgID :: String -- ^ and without version info. + , componentTLB :: Bool -- ^ @True@ if backed by a TLB. + , registerComponent :: ComponentInfo -> String -> Bool -> IO () -- ^ action to run when (un)registering this component. + , componentCLSID :: CLSID -- ^ the @CLSID@; required, of course. } +-- | @((\ path final iid -> IO obj)::ComponentFactory@ is the component-specific +-- object factory method: +-- +-- * @path@ is the path to the DLL implementing the component (useful for TLB lookup etc.) +-- +-- * @final@ is finalization action for the object. +-- +-- * @iid@ is the @IID@ to create object at. +-- +-- * @obj@ is the newly created object at interface @iid@. +-- +type ComponentFactory + = String + -> IO () + -> IID (IUnknown ()) + -> IO (IUnknown ()) + +-- | @withProgID p ci@ returns a new ComponentInfo based on @ci@, +-- but with 'ProgID' set to @p@. withProgID :: String -> ComponentInfo -> ComponentInfo withProgID p info = info{componentProgID=p} +-- | @onRegister act ci@ returns a new ComponentInfo based on @ci@, +-- but with the (un)registration action /extended/ with @act@. 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 act ci@ returns a new ComponentInfo based on @ci@, +-- but with the finalization action /extended/ with @act@. onFinalize :: IO () -> ComponentInfo -> ComponentInfo onFinalize act info = info{componentFinalise= act >> (componentFinalise info)} +-- | @withVerProgID vp ci@ returns a new ComponentInfo based on @ci@, +-- but with version-independent 'ProgID' set to @vp@. withVerIndepProgID :: String -> ComponentInfo -> ComponentInfo withVerIndepProgID p info = info{componentVProgID=p} +-- | @withFinalizer act ci@ returns a new ComponentInfo based on @ci@, +-- but with its finalizer action set to @act@. withFinaliser :: IO () -> ComponentInfo -> ComponentInfo withFinaliser act info = info{componentFinalise=act} +-- | @withComponentName nm ci@ returns a new 'ComponentInfo' based on @ci@, +-- but with its name set to @nm@. withComponentName :: String -> ComponentInfo -> ComponentInfo withComponentName n info = info{componentName=n} +-- | @hasTypeLib ci@ returns a new 'ComponentInfo' based on @ci@, but being type library backed. hasTypeLib :: ComponentInfo -> ComponentInfo hasTypeLib info = info{componentTLB=True} - -- constructor used to lessen the reliance on concrete rep. +-- | The @mkComponentInfo@ used to lessen the reliance on concrete representation +-- of 'ComponentInfo'. mkComponentInfo :: CLSID -> (String -> Bool -> IO ()) -> (String -> IO () -> IID (IUnknown ()) -> IO (IUnknown ())) -> ComponentInfo mkComponentInfo cls reg n = ComponentInfo n (return ()) "" "" "" False (\ _ -> reg) cls ---The state maintained by each instance of a 'ComDll' wrapper: - +-- | The (internal) state maintained by each instance of a @ComDll@ +-- wrapper: data ComDllState = ComDllState { dllPath :: String, @@ -168,9 +201,8 @@ dllUnload :: ComDllState -> IO () dllUnload st = return () --- Creating + manipulating the state of a Haskell DLL containing --- Haskell COM server(s). - +-- | @newComDllState h cis@ creates the internal representation of a Haskell +-- COM component newComDllState :: Ptr (){-HANDLE-} -> [ComponentInfo] -> IO ComDllState newComDllState hMod cs = do path <- getModuleFileName hMod @@ -186,6 +218,10 @@ lc <- newIORef 1 return (ComDllState path ref_cs lc) +-- | @createIComDll hMod cis@ creates the method table for an inproc server +-- supporting the components specified by @cis@. The method table would +-- then be wrapped up by a Haskell DLL wrapper supporting the in-proc +-- DLL entry points. createIComDll :: Ptr (){-HMODULE-} -> [ComponentInfo] -> IO (VTable iid_comDllState ComDllState) createIComDll hMod components = do state <- newComDllState hMod components @@ -222,6 +258,8 @@ | HKEY_CURRENT_CONFIG deriving ( Eq, Ord, Enum ) +-- | @regAddEntry hive path val@ is a convenient local wrapper to the Win32 +-- API function @RegAddEntry()@. regAddEntry :: RegHive -> String -> Maybe String @@ -232,6 +270,8 @@ hr <- primRegAddEntry (fromEnum hive) m_path m_value checkHR hr +-- | @regRemoveEntry hive path val doRemove@ is a convenient local wrapper to the Win32 +-- API function @RegRemoveEntry()@. regRemoveEntry :: RegHive -> String -> String
System/Win32/Com/Exception.hs view
@@ -2,14 +2,16 @@ ----------------------------------------------------------------------------- -- | -- Module : System.Win32.Com.Exception --- Copyright : (c) Sigbjorn Finne <sof@dcs.gla.ac.uk> 1998-99 +-- Copyright : (c) 2009, Sigbjorn Finne -- License : BSD-style (see the file libraries/base/LICENSE) -- --- Maintainer : sof@galois.com +-- Maintainer : sof@forkIO.com -- Stability : provisional -- Portability : portable -- --- 'Com exception handling' \/ HRESULT manipulation in Haskell. +-- Representing and working with COM's 'exception model' (@HRESULT@s) in Haskell. +-- Failures in COM method calls are mapped into 'Control.Exception' Haskell exceptions, +-- providing convenient handlers to catch and throw these. -- ----------------------------------------------------------------------------- module System.Win32.Com.Exception where @@ -28,6 +30,9 @@ import GHC.IOBase import Control.Exception +-- | @act `catchComException` (ex -> hdlr ex)@ performs the +-- IO action @act@, but catches any IO or COM exceptions @ex@, +-- passing them to the handler @hdlr@. catchComException :: IO a -> (Com_Exception -> IO a) -> IO a catchComException act hdlr = Control.Exception.catch act @@ -51,6 +56,10 @@ #else import Control.Exception + +-- | @act `catchComException` (ex -> hdlr ex)@ performs the +-- IO action @act@, but catches any IO or COM exceptions @ex@, +-- passing them to the handler @hdlr@. catchComException :: IO a -> (Com_Exception -> IO a) -> IO a catchComException act hdlr = Control.Exception.catch act @@ -71,12 +80,20 @@ Right ce -> hdlr (Just ce)) #endif +-- | @Com_Exception@ is either an 'IOException' or 'ComException'; +-- no attempt is made to embed one inside the other. type Com_Exception = Either IOException ComException +-- | @throwIOComException ex@ raises/throws the exception @ex@; +-- @ex@ is either an 'IOException' or a 'ComException'. throwIOComException :: Com_Exception -> IO a throwIOComException (Left e) = ioError e throwIOComException (Right ce) = throwComException ce +-- | @check2HR hr@ triggers a COM exception if the HRESULT +-- @hr@ represent an error condition. The current /last error/ +-- value embedded in the exception gives more information about +-- cause. check2HR :: HRESULT -> IO () check2HR hr | succeeded hr = return () @@ -84,7 +101,8 @@ dw <- getLastError coFailHR (word32ToInt32 dw) -{- FALSE = 0, TRUE = -1 -} +-- | @checkBool mbZero@ raises a COM exception if @mbZero@ is equal +-- to...zero. The /last error/ is embedded inside the exception. checkBool :: Int32 -> IO () checkBool flg | flg /=0 = return () @@ -92,6 +110,9 @@ dw <- getLastError coFailHR (word32ToInt32 dw) +-- | @returnHR act@ runs the IO action @act@, catching any +-- COM exceptions. Success or failure is then mapped back into +-- the corresponding HRESULT. In the case of success, 's_OK'. returnHR :: IO () -> IO HRESULT returnHR act = catch_ce_ @@ -103,19 +124,23 @@ failure = e_FAIL - +-- | @isCoError e@ returns @True@ for COM exceptions; @False@ +-- for IO exception values. isCoError :: Com_Exception -> Bool isCoError Right{} = True isCoError Left{} = False -coGetException :: Com_Exception-> Maybe ComException +-- | @coGetException ei@ picks out the COM exception @ei@, if one. +coGetException :: Com_Exception -> Maybe ComException coGetException (Right ce) = Just ce coGetException _ = Nothing +-- | @coGetException ei@ picks out the COM HRESULT from the exception, if any. coGetErrorHR :: Com_Exception -> Maybe HRESULT coGetErrorHR Left{} = Nothing coGetErrorHR (Right ce) = Just (case comException ce of (ComError hr) -> hr) +-- | @coGetException ei@ returns a user-friendlier representation of the @ei@ exception. coGetErrorString :: Com_Exception -> String coGetErrorString (Left ioe) = ioeGetErrorString ioe coGetErrorString (Right ce) = @@ -125,6 +150,7 @@ printComError :: Com_Exception -> IO () printComError ce = putStrLn (coGetErrorString ce) +-- | An alias to 'coGetErrorString'. hresultToString :: HRESULT -> IO String hresultToString = stringFromHR @@ -139,9 +165,12 @@ Left ioe -> coFail (msg ++ ": " ++ ioeGetErrorString ioe) Right ce -> coFail (msg ++ ": " ++ comExceptionMsg ce)) +-- | @coFail msg@ raised the @E_FAIL@ COM exception along with +-- the descriptive string @msg@. coFail :: String -> IO a coFail = coFailWithHR e_FAIL +-- | @s_OK@ and @s_FALSE@ are the boolean values encoded as 'HRESULT's. s_FALSE, s_OK :: HRESULT s_OK = 0 s_FALSE = 1
System/Win32/Com/HDirect/HDirect.hs view
@@ -5,7 +5,7 @@ -- Copyright : (c) Sigbjorn Finne, sof@dcs.gla.ac.uk 1999 -- License : BSD-style (see the file libraries/base/LICENSE) -- --- Maintainer : sof@galois.com +-- Maintainer : sof@forkIO.com -- Stability : provisional -- Portability : portable --
System/Win32/Com/HDirect/Pointer.hs view
@@ -5,7 +5,7 @@ -- Copyright : (c) Daan Leijen, leijen@@fwi.uva.nl 1998 -- License : BSD-style (see the file libraries/base/LICENSE) -- --- Maintainer : sof@galois.com+-- Maintainer : sof@forkIO.com -- Stability : provisional -- Portability : portable --
System/Win32/Com/Server.hs view
@@ -6,7 +6,7 @@ -- Copyright : (c) Sigbjorn Finne <sof@dcs.gla.ac.uk> 1998-99 -- License : BSD-style (see the file libraries/base/LICENSE) -- --- Maintainer : sof@galois.com +-- Maintainer : sof@forkIO.com -- Stability : provisional -- Portability : portable --
System/Win32/Com/Server/ConnectionPoint.hs view
@@ -4,7 +4,7 @@ -- Copyright : (c) Sigbjorn Finne <sof@dcs.gla.ac.uk> 1998-99 -- License : BSD-style (see the file libraries/base/LICENSE) -- --- Maintainer : sof@galois.com +-- Maintainer : sof@forkIO.com -- Stability : provisional -- Portability : portable --
System/Win32/Com/Server/EnumInterface.hs view
@@ -4,7 +4,7 @@ -- Copyright : (c) Sigbjorn Finne <sof@dcs.gla.ac.uk> 1998-99 -- License : BSD-style (see the file libraries/base/LICENSE) -- --- Maintainer : sof@galois.com +-- Maintainer : sof@forkIO.com -- Stability : provisional -- Portability : portable --
System/Win32/Com/Server/ExeServer.hs view
@@ -5,7 +5,7 @@ -- Copyright : (c) Sigbjorn Finne <sof@dcs.gla.ac.uk> 1998-99 -- License : BSD-style (see the file libraries/base/LICENSE) -- --- Maintainer : sof@galois.com +-- Maintainer : sof@forkIO.com -- Stability : provisional -- Portability : portable --
System/Win32/Com/Server/StdDispatch.hs view
@@ -4,7 +4,7 @@ -- Copyright : (c) Sigbjorn Finne <sof@dcs.gla.ac.uk> 1998-99 -- License : BSD-style (see the file libraries/base/LICENSE) -- --- Maintainer : sof@galois.com +-- Maintainer : sof@forkIO.com -- Stability : provisional -- Portability : portable --
cbits/ComPrimSrc.c view
@@ -408,10 +408,10 @@ getModuleFileName ( HANDLE hMod) { char* buf = malloc(sizeof(char) * MAX_LEN_MOD_FNAME); - DWORD len; + DWORD len = 0; - len = GetModuleFileNameA(hMod, buf, MAX_LEN_MOD_FNAME); - return buf; + len = GetModuleFileNameA(hMod, buf, MAX_LEN_MOD_FNAME); + return buf; }
+ cbits/dllStub.c view
@@ -0,0 +1,127 @@+/* + * Entry points needed to implement a COM inproc server. + * The C wrappers defined here delegate to (library) methods + * implemented in Haskell. + * + * Sigbjorn Finne, 1999 + */ + +#include <windows.h> +#include "comPrim.h" + +/* + * A Haskell in-proc server exposes a VTBL which mimics + * the entry points that a self-registering inproc server + * has to supply to the outside world. + * + */ +typedef struct IComDll { + void (*dllUnload)(); + HRESULT (*dllCanUnloadNow)(); + HRESULT (*dllRegisterServer)(); + HRESULT (*dllUnregisterServer)(); + HRESULT (*dllGetClassObject)(CLSID* clsid, IID* iid, + void** ppv); +} ComDll; + +ComDll* comDll = NULL; + +extern ComDll* newComDll ( HANDLE hMod ); + +#if __GLASGOW_HASKELL__ >= 408 +extern void startupHaskell (int argc, char* argv[], void* rootMod); +extern void* __stginit_ComDllMain; +extern void shutdownHaskell (void); +#else +extern void startupHaskell(int , char** ); +extern void shutdownHaskell (void); +#endif + +static char* args[] = { "ghcDll" }; + +BOOL +STDCALL +DllMain + ( HANDLE hModule + , DWORD reason + , void* reserved + ) +{ + if (reason == DLL_PROCESS_ATTACH) { + /* By now, the RTS DLL should have been hoisted in, but we need to start + it up. + + Note: for ghc-4.08 and later, you need to give the main / 'root module' + of the Haskell module you want to start running. So, if this is something + other than 'ComDllMain', you'll need to tweak the invocation below. + */ +#if __GLASGOW_HASKELL__ >= 408 + startupHaskell( sizeof(args) / sizeof(char*) + , args + , &__stginit_ComDllMain + ); +#else + startupHaskell(sizeof(args) / sizeof(char*), args); +#endif + comDll = newComDll(hModule); + return TRUE; + } else { + if (comDll && reason == DLL_PROCESS_DETACH) { + (comDll)->dllUnload(); + shutdownHaskell(); + /* Not properly letting go of memory here is rude, but we're shutting down.. */ + comDll=NULL; + } + 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; + } +}
com.cabal view
@@ -1,8 +1,11 @@ Name: com -version: 1.2.2 +version: 1.2.3 Synopsis: Haskell COM support library Description: - COM + Automation libraries for Haskell. + Supporting for writing COM\/Automation clients in Haskell, and for + packaging up your Haskell code behind a COM-callable veneer. + . + Some examples of how to use the package can be found at <http://haskell.forkio.com/com-examples> Cabal-version: >= 1.2 build-type: Simple Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com> @@ -19,6 +22,8 @@ include/safeArrayPrim.h include/SafeArray.h include/StdTypes.h + cbits/dllStub.c + ComDllMain.hs CHANGES flag old-base