module System.Win32.Com.Server
(
createComInstance
, createInstance
, createVTable
, createComVTable
, createIPointer
, cloneIPointer
, cloneIPointer_prim
, getObjState
, getRealObjState
, createDualInterface
, createDispInterface
, VTable
, ComVTable
, PrimIP
, ComInterface
, mkIface
, mkDispIface
, mkDualIface
, export_getTypeInfoCount
, export_getTypeInfo
, export_getIDsOfNames
, export_invoke
) where
import System.Win32.Com.HDirect.HDirect
import Data.Word
import Data.Int
import Data.IORef ( IORef, readIORef, writeIORef, newIORef )
import System.IO.Unsafe ( unsafePerformIO )
import System.IO ( fixIO )
import System.Win32.Com hiding ( queryInterface, addRef, release )
import qualified System.Win32.Com as Com ( addRef, release )
import System.Win32.Com.Automation ( IDispatch, VARIANT, iidIDispatch, DISPID )
import Foreign.StablePtr
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Data.Maybe ( fromMaybe )
import Data.Bits ( (.&.) )
import System.Win32.Com.Exception
import System.Win32.Com.HDirect.WideString
import Control.Monad
import Data.List
type PrimIP iid = Ptr (Ptr ())
type VTBL = (Ptr (Ptr ()), Int)
type VTable iid objState = VTBL
type ComVTable iid objState = VTable iid (objState, IUnkState)
data ComInterface objState
= Iface { ifaceGUID :: GUID
, ifaceVTBL :: VTBL
}
| DispIface { ifaceGUID :: GUID
, ifaceLIBID :: Either LIBID String
, ifaceVTBL :: VTBL
, isDual :: Bool
}
mkIface :: IID iid -> VTable iid objState -> ComInterface objState
mkIface iid a = Iface (iidToGUID iid) a
mkDispIface :: Maybe LIBID -> IID iid -> VTable iid objState -> ComInterface objState
mkDispIface l iid v = DispIface (iidToGUID iid) l' v False
where
l' = fromMaybe (Right "") (fmap Left l)
mkDualIface :: Maybe LIBID -> IID iid -> VTable iid objState -> ComInterface objState
mkDualIface l iid v = DispIface (iidToGUID iid) l' v True
where
l' = fromMaybe (Right "") (fmap Left l)
createComInstance :: String
-> objState
-> IO ()
-> [ComInterface objState]
-> IID (IUnknown iid)
-> IO (IUnknown iid)
createComInstance dll_path initState releaseAction supported_ifaces initial_iid = do
ip_state <- mkInstanceState supported_ifaces dll_path releaseAction initState
(_,iu) <- deRefStablePtr ip_state
res <- lookupInterface initial_iid (iu_ifaces iu)
case res of
(_,_,ip) -> do
return (castIface ip)
createInstance :: objState -> VTable (IUnknown iid) objState -> IO (IUnknown iid)
createInstance initState vtable = do
ip_state <- newStablePtr initState
createIPointer ip_state vtable
createIPointer :: StablePtr a
-> VTBL
-> IO (IUnknown b)
createIPointer iface_st (vtbl,_) = do
pre <- alloc (sizeofIfaceHeader)
poke pre vtbl
poke (pre `plusPtr` fromIntegral sizeofPtr) iface_st
unmarshallIUnknown False pre
sizeofIfaceHeader :: Word32
sizeofIfaceHeader =
sizeofPtr
+ sizeofPtr
cloneIPointer :: IUnknown iid_old -> VTable (IUnknown iid_new) objState -> IO (IUnknown iid_new)
cloneIPointer iptr vtbl = do
stable_state <- getIPointerState_stbl (ifaceToAddr iptr)
createIPointer stable_state vtbl
cloneIPointer_prim :: Ptr (IUnknown a) -> VTable (IUnknown iid_new) objState -> IO (IUnknown iid_new)
cloneIPointer_prim iptr vtbl = do
stable_state <- getIPointerState_stbl iptr
createIPointer stable_state vtbl
findInterface :: IUnkIfaceInfo
-> Ptr GUID
-> Ptr (Ptr (IUnknown b))
-> IO HRESULT
findInterface ls piid ppv = do
iid <- unmarshallGUID False piid
if (iid == iidToGUID iidIUnknown) then
case ls of
[] -> return e_NOINTERFACE
((_,_,ip):_) -> realiseIPointer ip
else if (iid == iidToGUID iidIDispatch) then
case filter (isIDispatch) ls of
[] -> return e_NOINTERFACE
((_,_,ip):_) -> realiseIPointer ip
else
let
findIt [] = do
poke (castPtr ppv) nullPtr
return e_NOINTERFACE
findIt ((x,_,ip):xs)
| x == iid = realiseIPointer ip
| otherwise = findIt xs
in
findIt ls
where
realiseIPointer newip = do
primip <- marshallIUnknown newip
writefptr ppv primip
addRef (ifaceToAddr newip)
return s_OK
isIDispatch (iid, flg, _) = flg || iid == iidToGUID iidIDispatch
lookupInterface :: IID iid
-> IUnkIfaceInfo
-> IO (GUID, Bool, IUnknown ())
lookupInterface iid [] = ioError (userError "lookupInterface: interface not supported")
lookupInterface iid ls@(i:_) =
case (find (\ (i,_,_) -> i == guid) ls) of
Nothing -> return i
Just i -> return i
where
guid = iidToGUID iid
data IUnkState
= IUnkState
{ iu_ifaces :: IUnkIfaceInfo
, iu_release :: IO ()
, iu_refcnt :: IORef Int
}
type IUnkIfaceInfo = [(GUID, Bool, IUnknown ())]
mkInstanceState :: [ComInterface objState]
-> String
-> IO ()
-> objState
-> IO (StablePtr (objState, IUnkState))
mkInstanceState iface_list dll_path releaseAction objState = do
fixIO (\ stbl_st -> do
ref_cnt <- newIORef 1
let iptrs = map (mkIf stbl_st) iface_list
iu_st = IUnkState iptrs releaseAction ref_cnt
newStablePtr (objState, iu_st)
)
where
mkIf st (Iface iid vtbl) =
(iid, False, unsafePerformIO (createIPointer st vtbl))
mkIf st (DispIface guid libid vtbl is_dual) =
(guid, True, unsafePerformIO $ do
let iid = guidToIID guid
lib_loc = case libid of
Right "" -> Right dll_path
_ -> libid
if is_dual then
createDualInterface st vtbl lib_loc iid
else do
ip <- createIPointer st vtbl
createDispInterface ip lib_loc iid
)
queryInterface :: Ptr (IUnknown a)
-> Ptr GUID
-> Ptr (Ptr (IUnknown b))
-> IO HRESULT
queryInterface iptr riid ppvObject = do
iid <- unmarshallGUID False riid
if_ls <- getSupportedInterfaces iptr
hr <- findInterface if_ls riid ppvObject
return hr
addRef :: Ptr (IUnknown a) -> IO Word32
addRef iptr = do
v <- readRefCount iptr
writeRefCount iptr (v+1)
return (fromIntegral v)
release :: Ptr (IUnknown a) -> IO Word32
release iptr = do
v <- readRefCount iptr
let v' = v-1
writeRefCount iptr v'
if v' <= 0 then do
releaseObj iptr
let x = (fromIntegral 0)
return x
else do
let x = (fromIntegral (v-1))
return x
foreign import stdcall "wrapper" export_queryInterface ::
(Ptr (IUnknown a) -> Ptr GUID -> Ptr (Ptr (IUnknown b)) -> IO Int32)
-> IO (Ptr (Ptr (IUnknown a) -> Ptr GUID -> Ptr (Ptr (IUnknown b)) ->IO Int32))
foreign import stdcall "wrapper" export_addRef :: (Ptr (IUnknown a) -> IO Word32) -> IO (Ptr (Ptr (IUnknown a) -> IO Word32))
foreign import stdcall "wrapper" export_release :: (Ptr (IUnknown a) -> IO Word32) -> IO (Ptr (Ptr (IUnknown a) -> IO Word32))
releaseObj :: Ptr (IUnknown a) -> IO ()
releaseObj iptr = do
r <- iptr # getReleaseAction
r
stbl <- iptr # getIPointerState_stbl
freeStablePtr stbl
return ()
readRefCount :: Ptr (IUnknown a) -> IO Int
readRefCount ptr = do
iu <- getIUnkState ptr
readIORef (iu_refcnt iu)
writeRefCount :: Ptr (IUnknown a) -> Int -> IO ()
writeRefCount ptr v = do
iu <- getIUnkState ptr
writeIORef (iu_refcnt iu) v
getReleaseAction :: Ptr (IUnknown a) -> IO (IO ())
getReleaseAction ptr = do
iu <- getIUnkState ptr
return (iu_release iu)
getSupportedInterfaces :: Ptr (IUnknown a) -> IO IUnkIfaceInfo
getSupportedInterfaces ptr = do
iu_state <- getIUnkState ptr
return (iu_ifaces iu_state)
getIUnkState :: Ptr (IUnknown a) -> IO IUnkState
getIUnkState iptr = do
stbl <- getIPointerState_stbl iptr
(_,x) <- deRefStablePtr stbl
return x
getObjState :: Ptr (IUnknown a) -> IO b
getObjState iptr = do
stbl <- getIPointerState_stbl iptr
(x,_) <- deRefStablePtr stbl
return x
getRealObjState :: Ptr (IUnknown a) -> IO b
getRealObjState iptr = do
stbl <- getIPointerState_stbl iptr
deRefStablePtr stbl
getIPointerState_stbl :: Ptr (IUnknown a) -> IO (StablePtr b)
getIPointerState_stbl iptr = peek (iptr `plusPtr` fromIntegral sizeofPtr)
createDualInterface :: StablePtr objState
-> ComVTable (IUnknown iid) objState
-> Either LIBID String
-> IID (IUnknown iid)
-> IO (IUnknown iid)
createDualInterface ip_state vtbl libid iid = do
ip <- createIPointer ip_state vtbl
st <- mkDispatchState libid ip iid
meths <- unmarshallVTable vtbl
let real_meths = case meths of
(qi : ar : re : ls) -> ls
_ -> error "createDualInterface: failed to strip of IU methods"
vtable <- createDispVTable real_meths st
cloneIPointer ip vtable
createDispInterface :: IUnknown iid
-> Either LIBID String
-> IID (IUnknown iid)
-> IO (IUnknown iid)
createDispInterface ip libid iid = do
st <- mkDispatchState libid ip iid
vtable <- createDispVTable [] st
i <- cloneIPointer ip vtable
return i
mkDispatchState :: Either LIBID String
-> IUnknown iid
-> IID (IUnknown iid)
-> IO DispState
mkDispatchState libid ip iid = do
pTInfo_ref <- newIORef nullPtr
return (DispState libid (coerceIID iid) (coerceIP ip) pTInfo_ref)
coerceIID :: IID a -> IID b
coerceIID iid = guidToIID (iidToGUID iid)
coerceIP :: IUnknown a -> IUnknown b
coerceIP x = castIface x
data DispState
= DispState {
disp_libid :: Either LIBID String,
disp_iid :: (IID ()),
disp_ip :: (IUnknown ()),
disp_ti :: (IORef (PrimIP (ITypeInfo ())))
}
type DISPPARAMS = Ptr ()
type EXCEPINFO = Ptr ()
createDispVTable :: [Ptr ()]
-> DispState
-> IO (ComVTable (IDispatch ()) DispState)
createDispVTable meths disp_st = do
a_getTypeInfoCount <- export_getTypeInfoCount getTypeInfoCount
a_getTypeInfo <- export_getTypeInfo (getTypeInfo disp_st)
a_getIDsOfNames <- export_getIDsOfNames (getIDsOfNames disp_st)
a_invoke <- export_invoke (invoke disp_st)
createComVTable ([ castPtr a_getTypeInfoCount
, castPtr a_getTypeInfo
, castPtr a_getIDsOfNames
, castPtr a_invoke
] ++ meths)
getTypeInfoCount :: Ptr () -> Ptr Word32 -> IO HRESULT
getTypeInfoCount iptr pctInfo = do
writeWord32 pctInfo 1
return s_OK
foreign import stdcall "wrapper" export_getTypeInfoCount
:: (Ptr () -> Ptr Word32 -> IO HRESULT) -> IO (Ptr (Ptr () -> Ptr Word32 -> IO HRESULT))
getTypeInfo :: DispState -> Ptr (IDispatch ()) -> Word32 -> LCID -> Ptr () -> IO HRESULT
getTypeInfo disp_state this iTInfo lcid ppTInfo
| iTInfo /= 0 = return tYPE_E_ELEMENTNOTFOUND
| ppTInfo == nullPtr = return e_POINTER
| otherwise = do
poke (castPtr ppTInfo) nullPtr
let ppITInfo_ref = disp_ti disp_state
(hr, pITInfo) <- do
pITInfo <- readIORef ppITInfo_ref
if (pITInfo == nullPtr) then do
ppITInfo <- allocOutPtr
hr <- loadTypeInfo (disp_libid disp_state) (disp_iid disp_state) lcid ppITInfo
if (failed hr) then
return (hr, undefined)
else do
pITInfo <- peek ppITInfo
writeIORef ppITInfo_ref pITInfo
return (s_OK, pITInfo)
else
return (s_OK, pITInfo)
if (failed hr) then
return hr
else do
punk <- unmarshallIUnknown True pITInfo
Com.addRef punk
poke (castPtr ppTInfo) pITInfo
return s_OK
loadTypeInfo :: Either LIBID String
-> IID iid
-> LCID
-> Ptr (PrimIP (ITypeInfo ()))
-> IO HRESULT
loadTypeInfo tlb_loc iid lcid ppITI = do
(hr, pITypeLib) <-
catchComException
(case tlb_loc of
Left libid -> do
ip <- loadRegTypeLib libid 1 0 (fromIntegral (primLangID lcid))
return (s_OK, ip)
Right path -> do
ip <- loadTypeLibEx path False
return (s_OK, ip))
(\ ex -> do
putMessage "Failed to load typelib"
return (fromMaybe e_FAIL (coGetErrorHR ex), interfaceNULL))
if (failed hr) then
return hr
else do
hr <- pITypeLib # getTypeInfoOfGuid iid ppITI
return hr
foreign import ccall "primLoadRegTypeLib"
primLoadRegTypeLib :: Ptr () -> Word16 -> Word16 -> Word32 -> Ptr () -> IO HRESULT
foreign import stdcall "wrapper" export_getTypeInfo
:: (Ptr (IDispatch ()) -> Word32 -> LCID -> Ptr () -> IO HRESULT)
-> IO (Ptr (Ptr (IDispatch ()) -> Word32 -> LCID -> Ptr () -> IO HRESULT))
getIDsOfNames :: DispState
-> Ptr (IDispatch ())
-> Ptr (IID ())
-> Ptr WideString
-> Word32
-> LCID
-> Ptr DISPID
-> IO HRESULT
getIDsOfNames disp_state this riid rgszNames cNames lcid rgDispID = do
pti <- allocOutPtr
hr <- getTypeInfo disp_state this 0 lcid pti
if (failed hr) then do
free pti
return hr
else do
prim_ti <- peek (castPtr pti)
free pti
hr <- prim_ti # getIDsOfNamesTI rgszNames cNames rgDispID
return hr
foreign import stdcall "wrapper" export_getIDsOfNames
:: (Ptr (IDispatch ()) -> Ptr (IID ()) -> Ptr WideString -> Word32 -> LCID -> Ptr DISPID -> IO HRESULT)
-> IO (Ptr (Ptr (IDispatch ()) -> Ptr (IID ()) -> Ptr WideString -> Word32 -> LCID -> Ptr DISPID -> IO HRESULT))
invoke :: DispState
-> Ptr (IDispatch ())
-> DISPID
-> Ptr (IID a)
-> LCID
-> Word32
-> Ptr DISPPARAMS
-> Ptr VARIANT
-> Ptr EXCEPINFO
-> Ptr Word32
-> IO HRESULT
invoke disp_state this dispIdMember riid lcid wFlags pDispParams pVarResult pExcepInfo puArgErr = do
iid <- unmarshallIID False riid
if (iid /= castIID iidNULL) then
return dISP_E_UNKNOWNINTERFACE
else do
pti <- allocOutPtr
hr <- getTypeInfo disp_state this 0 lcid pti
if (failed hr) then do
free pti
return hr
else do
prim_ti <- peek (castPtr pti)
let ip = disp_ip disp_state
clearException
hr <- prim_ti # invokeTI ip dispIdMember wFlags pDispParams pVarResult pExcepInfo puArgErr
fillException pExcepInfo lcid
ip <- unmarshallIUnknown False prim_ti
ip # Com.release
return hr
invokeTI :: IUnknown a
-> DISPID
-> Word32
-> Ptr DISPPARAMS
-> Ptr VARIANT
-> Ptr EXCEPINFO
-> Ptr Word32
-> Ptr (ITypeInfo a)
-> IO HRESULT
invokeTI ip dispIdMember wFlags pDispParams pVarResult pExcepInfo puArgErr this = do
iptr_fo <- marshallIUnknown ip
let offset = (11::Int)
lpVtbl <- peek (castPtr this)
methPtr <- indexPtr lpVtbl offset
withForeignPtr iptr_fo $ \ iptr ->
prim_invokeTI methPtr (castPtr this) iptr dispIdMember wFlags pDispParams pVarResult pExcepInfo puArgErr
foreign import stdcall "dynamic"
prim_invokeTI :: Ptr (Ptr () -> Ptr () -> DISPID -> Word32 -> Ptr DISPPARAMS -> Ptr VARIANT -> Ptr EXCEPINFO -> Ptr Word32 -> IO HRESULT) -> Ptr () -> Ptr () -> DISPID -> Word32 -> Ptr DISPPARAMS -> Ptr VARIANT -> Ptr EXCEPINFO -> Ptr Word32 -> IO HRESULT
getTypeInfoOfGuid :: IID iid -> Ptr (PrimIP (ITypeInfo ())) -> IUnknown a -> IO HRESULT
getTypeInfoOfGuid iid ppITI this = do
let offset = (6::Int)
pthis <- marshallIUnknown this
let a = foreignPtrToPtr pthis
lpVtbl <- peek (castPtr a)
methPtr <- indexPtr lpVtbl offset
piid <- marshallIID iid
withForeignPtr pthis $ \ pthis ->
withForeignPtr piid $ \ piid ->
prim_getTypeInfoOfGuid methPtr pthis piid ppITI
foreign import stdcall "dynamic"
prim_getTypeInfoOfGuid :: Ptr (Ptr (Ptr a) -> Ptr (IID iid) -> Ptr (PrimIP (ITypeInfo ())) -> IO HRESULT)
-> Ptr (Ptr a) -> Ptr (IID iid) -> Ptr (PrimIP (ITypeInfo ())) -> IO HRESULT
getIDsOfNamesTI :: Ptr WideString -> Word32 -> Ptr DISPID -> Ptr (ITypeInfo ()) -> IO HRESULT
getIDsOfNamesTI rgszNames cNames rgDispID this = do
let offset = 10::Int
lpVtbl <- peek (castPtr this)
methPtr <- indexPtr lpVtbl offset
prim_getIDsOfNamesTI methPtr (castPtr this) rgszNames cNames rgDispID
foreign import stdcall "dynamic"
prim_getIDsOfNamesTI :: Ptr(Ptr () -> Ptr WideString -> Word32 -> Ptr DISPID -> IO HRESULT)
-> Ptr () -> Ptr WideString -> Word32 -> Ptr DISPID -> IO HRESULT
clearException :: IO ()
clearException = return ()
fillException :: Ptr EXCEPINFO
-> LCID
-> IO ()
fillException _ _ = return ()
foreign import stdcall "wrapper" export_invoke
:: (Ptr (IDispatch ()) -> DISPID -> Ptr (IID a) -> LCID -> Word32 -> Ptr DISPPARAMS -> Ptr VARIANT -> Ptr EXCEPINFO -> Ptr Word32 -> IO HRESULT)
-> IO (Ptr (Ptr (IDispatch ()) -> DISPID -> Ptr (IID a) -> LCID -> Word32 -> Ptr DISPPARAMS -> Ptr VARIANT -> Ptr EXCEPINFO -> Ptr Word32 -> IO HRESULT))
data TypeInfo a = TypeInfo__
type ITypeInfo a = IUnknown (TypeInfo a)
primLangID :: Word32 -> Word32
primLangID w = (w .&. 0x3ff)
createVTable :: [Ptr ()] -> IO (VTable iid objState)
createVTable methods = do
vtbl <- alloc (sizeofPtr * fromIntegral no_meths)
sequence (zipWith (pokeElemOff vtbl) [(0::Int)..] methods)
return (vtbl, no_meths)
where
no_meths = length methods
unmarshallVTable :: VTable iid objState -> IO [Ptr ()]
unmarshallVTable (vtbl, no_meths) =
mapM (peekElemOff vtbl) [(0::Int)..no_meths]
createComVTable :: [Ptr ()] -> IO (ComVTable iid objState)
createComVTable methods = do
m_queryInterface <- export_queryInterface queryInterface
m_addRef <- export_addRef addRef
m_release <- export_release release
createVTable (castPtr m_queryInterface: castPtr m_addRef: castPtr m_release: methods)