module System.Win32.Com.Server.ConnectionPoint
(
mkConnectionContainer
) where
import System.Win32.Com.Server
import System.Win32.Com.Automation.Connection ( iidIConnectionPointContainer, iidIConnectionPoint,
IConnectionPointContainer, IConnectionPoint,
iidIEnumConnections, iidIEnumConnectionPoints
)
import System.Win32.Com
import System.Win32.Com.HDirect.HDirect ( writeWord32, Ptr, sizeofPtr )
import System.Win32.Com.Server.EnumInterface ( mkEnumInterface )
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import System.IO.Unsafe ( unsafePerformIO )
import System.IO ( fixIO )
import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
import Data.Word
import Data.Int
import System.Win32.Com.Exception
import Control.Exception
type ThisPtr = Ptr (IUnknown ())
mkConnectionContainer :: [(IID (IUnknown ()), IORef [(Word32, IUnknown ())])]
-> IO (IConnectionPointContainer ())
mkConnectionContainer ls = fixIO $ \ ip -> do
let ils = unsafePerformIO (mapM (mkConnection ip) ls)
addrOf_eCP <- export_enumCP (enumConnectionPoints (map snd ils))
addrOf_fCP <- export_fCP (findConnectionPoint ils)
vtbl <- createComVTable [ castPtr addrOf_eCP, castPtr addrOf_fCP ]
createComInstance "" () (return ())
[mkIface iidIConnectionPointContainer vtbl]
iidIConnectionPointContainer
mkConnection :: IConnectionPointContainer ()
-> (IID (IUnknown ()), IORef [(Word32, IUnknown ())])
-> IO (IID (IUnknown ()), IConnectionPoint ())
mkConnection ip (iid, regd_sinks) = do
vtbl <- mkConnectionPointVTBL ip iid regd_sinks
ip <- createComInstance "" () (return ())
[ mkIface iidIConnectionPoint vtbl ]
iidIConnectionPoint
return (iid, ip)
mkConnectionPointVTBL :: IConnectionPointContainer ()
-> IID (IUnknown iid)
-> IORef [(Word32, IUnknown ())]
-> IO (ComVTable (IConnectionPoint a) objState)
mkConnectionPointVTBL ip iid sinks = do
addrOf_gi <- export_gi (getConnectionInterface iid)
addrOf_gcpc <- export_gcpc (getConnectionPointContainer ip)
cookie_ref <- newIORef (0::Word32)
addrOf_adv <- export_adv (advise sinks cookie_ref iid)
addrOf_unadv <- export_unadv (unadvise sinks)
addrOf_eC <- export_eCP (enumConnections sinks)
createComVTable
[ castPtr addrOf_gi , castPtr addrOf_gcpc , castPtr addrOf_adv, castPtr addrOf_unadv, castPtr addrOf_eC ]
getConnectionInterface :: IID iid
-> ThisPtr
-> Ptr GUID
-> IO HRESULT
getConnectionInterface iid _ piid
| piid == nullPtr = return e_POINTER
| otherwise = do
writeGUID piid (iidToGUID iid)
return s_OK
foreign import stdcall "wrapper"
export_gi :: (ThisPtr -> Ptr GUID -> IO HRESULT) -> IO (Ptr (ThisPtr -> Ptr GUID -> IO HRESULT))
getConnectionPointContainer :: IConnectionPointContainer ()
-> ThisPtr
-> Ptr (Ptr (IUnknown b))
-> IO HRESULT
getConnectionPointContainer ip _ pip = do
writeIUnknown True pip ip
return s_OK
foreign import stdcall "wrapper"
export_gcpc :: (ThisPtr -> Ptr (Ptr (IUnknown b)) -> IO HRESULT)
-> IO (Ptr (ThisPtr -> Ptr (Ptr (IUnknown b)) -> IO HRESULT))
advise :: IORef [(Word32,IUnknown ())]
-> IORef Word32
-> IID (IUnknown iid)
-> ThisPtr
-> PrimIP ()
-> Ptr Word32
-> IO HRESULT
advise sinks cookie_ref iid this pUnkSink pdwCookie = do
ls <- readIORef sinks
cookie <- readIORef cookie_ref
ip <- unmarshallIUnknown False pUnkSink
catch (do
ip2 <- ip # queryInterface iid
if nullPtr == pdwCookie then
return e_POINTER
else do
writeIORef cookie_ref (cookie+1)
writeIORef sinks ((cookie,castIface ip2):ls)
writeWord32 pdwCookie cookie
return s_OK
)(\ e -> do
p <- return $ show (e :: SomeException)
return cONNECT_E_CANNOTCONNECT)
foreign import stdcall "wrapper"
export_adv :: (ThisPtr -> PrimIP () -> Ptr Word32 -> IO HRESULT)
-> IO (Ptr (ThisPtr -> PrimIP () -> Ptr Word32 -> IO HRESULT))
unadvise :: IORef [(Word32,IUnknown ())]
-> ThisPtr
-> Word32
-> IO HRESULT
unadvise sinks this dwCookie = do
ls <- readIORef sinks
case break ((==dwCookie).fst) ls of
(ls,[]) -> return cONNECT_E_NOCONNECTION
(ls, _:rs) -> do
writeIORef sinks (ls++rs)
return s_OK
foreign import stdcall "wrapper"
export_unadv :: (ThisPtr -> Word32 -> IO HRESULT) -> IO (Ptr (ThisPtr -> Word32 -> IO HRESULT))
enumConnections :: IORef [(Word32,IUnknown ())]
-> ThisPtr
-> Ptr (Ptr (IUnknown a))
-> IO HRESULT
enumConnections sinks this ppCP
| ppCP == nullPtr = return e_POINTER
| otherwise = do
ls <- readIORef sinks
vtbl <- mkEnumInterface (map snd ls) (fromIntegral sizeofPtr) (writeIUnknown True)
ip <- createComInstance "" () (return ())
[mkIface iidIEnumConnections vtbl]
iidIEnumConnections
writeIUnknown True ppCP ip
return s_OK
foreign import stdcall "wrapper"
export_enumCP :: (ThisPtr -> Ptr (Ptr (IUnknown b)) -> IO HRESULT) -> IO (Ptr (ThisPtr -> Ptr (Ptr (IUnknown b)) -> IO HRESULT))
enumConnectionPoints :: [IConnectionPoint ()]
-> ThisPtr
-> Ptr (Ptr (IUnknown b))
-> IO HRESULT
enumConnectionPoints ls this ppEnum
| ppEnum == nullPtr = return e_POINTER
| otherwise = do
vtbl <- mkEnumInterface ls (fromIntegral sizeofPtr) (writeIUnknown True)
ip <- createComInstance "" () (return ())
[mkIface iidIEnumConnectionPoints vtbl]
iidIEnumConnectionPoints
writeIUnknown True ppEnum ip
return s_OK
foreign import stdcall "wrapper"
export_eCP :: (ThisPtr -> Ptr (Ptr (IUnknown b)) -> IO HRESULT) -> IO (Ptr (ThisPtr -> Ptr (Ptr (IUnknown b)) -> IO HRESULT))
findConnectionPoint :: [(IID (IUnknown ()), IConnectionPoint ())]
-> ThisPtr
-> Ptr GUID
-> Ptr (Ptr (IUnknown ()))
-> IO HRESULT
findConnectionPoint ls this riid ppCP
| ppCP == nullPtr = return e_POINTER
| otherwise = do
guid <- unmarshallGUID False riid
let iid = guidToIID guid
case (lookup iid ls) of
Nothing -> do
poke ppCP nullPtr
return cONNECT_E_NOCONNECTION
Just i -> do
writeIUnknown True ppCP i
return s_OK
foreign import stdcall "wrapper"
export_fCP :: (ThisPtr -> Ptr GUID -> Ptr (Ptr (IUnknown b)) -> IO HRESULT) -> IO (Ptr (ThisPtr -> Ptr GUID -> Ptr (Ptr (IUnknown b)) -> IO HRESULT))
cONNECT_E_NOCONNECTION :: HRESULT
cONNECT_E_NOCONNECTION = 0x80040200
cONNECT_E_ADVISELIMIT :: HRESULT
cONNECT_E_ADVISELIMIT = 0x80040201
cONNECT_E_CANNOTCONNECT :: HRESULT
cONNECT_E_CANNOTCONNECT = 0x80040202
cONNECT_E_OVERRIDDEN :: HRESULT
cONNECT_E_OVERRIDDEN = 0x80040203