diff --git a/Examples/simple.hs b/Examples/simple.hs new file mode 100644 --- /dev/null +++ b/Examples/simple.hs @@ -0,0 +1,43 @@ +-- Copyright (C) 2009 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import DBus.Bus +import DBus.Client +import DBus.Message +import DBus.Types +import Data.List (sort) + +dbus :: Proxy +dbus = Proxy (RemoteObject "org.freedesktop.DBus" "/org/freedesktop/DBus") "org.freedesktop.DBus" + +main :: IO () +main = do + -- Connect to the bus, and print which name was assigned to this + -- connection. + client <- mkClient =<< getSessionBus + putStrLn $ "Connected as: " ++ show (clientName client) + + -- Request a list of connected clients from the bus + reply <- callProxyBlocking_ client dbus "ListNames" [] [] + + -- Pull out the body, and convert it to [String] + let Just names = fromArray =<< fromVariant (messageBody reply !! 0) + + -- Print each name on a line, sorted so reserved names are below + -- temporary names. + mapM_ putStrLn $ sort names diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -11,8 +11,8 @@ hs/DBus: mkdir -p hs/DBus -%.pdf: %.tex - xelatex "$<" - xelatex "$<" +dbus-client.pdf: dbus-client.tex + xelatex dbus-client.tex + xelatex dbus-client.tex -pdfs: dbus-client.pdf #manual.pdf +pdf: dbus-client.pdf diff --git a/dbus-client.cabal b/dbus-client.cabal --- a/dbus-client.cabal +++ b/dbus-client.cabal @@ -1,8 +1,7 @@ name: dbus-client -version: 0.2 +version: 0.3 synopsis: D-Bus client libraries -description: Connect and interact with the D-Bus IPC system. -license: GPL +license: GPL-3 license-file: License.txt author: John Millikin maintainer: jmillikin@gmail.com @@ -11,14 +10,17 @@ category: Network, Desktop stability: experimental bug-reports: mailto:jmillikin@gmail.com +homepage: http://ianen.org/haskell/dbus/ +tested-with: GHC==6.10.4 extra-source-files: dbus-client.nw + Examples/*.hs Makefile source-repository head type: darcs - location: http://patch-tag.com/r/jmillikin/dbus-client/pullrepo + location: http://ianen.org/haskell/dbus/client/ library ghc-options: -Wall @@ -26,7 +28,7 @@ build-depends: base >=3 && < 5 - , dbus-core >= 0.6 + , dbus-core >= 0.8 , containers , text diff --git a/dbus-client.nw b/dbus-client.nw --- a/dbus-client.nw +++ b/dbus-client.nw @@ -89,6 +89,9 @@ <>= type Callback = (M.ReceivedMessage -> IO ()) +-- | 'Client's are opaque handles to an open connection and other internal +-- state. +-- data Client = Client C.Connection T.BusName (MV.MVar (Map.Map M.Serial Callback)) (MV.MVar (Map.Map T.ObjectPath Callback)) @@ -114,11 +117,19 @@ Client , clientName -@ The slightly weird signature for {\tt mkClient} is designed to work with -the computations defined in {\tt DBus.Bus} -- their results can be passed -directly to {\tt mkClient} without having to perform any unpacking. - <>= +-- | Create a new 'Client' from an open connection and bus name. The weird + +-- signature allows 'mkClient' to use the computations in "DBus.Bus" +-- directly, without unpacking: +-- +-- @ +-- client <- mkClient =<< getSessionBus +-- @ +-- +-- Only one client should be created for any given connection. Otherwise, +-- they will compete to receive messages. +-- mkClient :: (C.Connection, T.BusName) -> IO Client mkClient (c, name) = do replies <- MV.newMVar Map.empty @@ -139,19 +150,19 @@ complexity to handle them. <>= -send :: M.Message a => Client -> (M.Serial -> IO b) -> a -> IO b -send c f msg = do +send_ :: M.Message a => Client -> (M.Serial -> IO b) -> a -> IO b +send_ c f msg = do result <- C.send (clientConnection c) f msg case result of Left x -> error $ show x Right x -> return x -@ And since most uses of {\tt send} don't care about the message's +@ And since most uses of {\tt send\_} don't care about the message's serial, it can be reduced further. <>= -sendOnly :: M.Message a => Client -> a -> IO () -sendOnly c = send c (const $ return ()) +sendOnly_ :: M.Message a => Client -> a -> IO () +sendOnly_ c = send_ c (const $ return ()) @ Additional helper computations are useful for sending method calls, to keep track of which pending calls are currently expecting replies. The @@ -166,11 +177,15 @@ callback will be added but never removed. This could cause a space leak. <>= +-- | Perform an asynchronous method call. One of the provided computations +-- will be performed depending on what message type the destination sends +-- back. +-- call :: Client -> M.MethodCall -> (M.Error -> IO ()) -> (M.MethodReturn -> IO ()) -> IO () -call client msg onError onReturn = send client addCallback msg where +call client msg onError onReturn = send_ client addCallback msg where Client _ _ mvar _ _ = client addCallback s = MV.modifyMVar_ mvar $ return . Map.insert s callback @@ -178,10 +193,10 @@ callback (M.ReceivedMethodReturn _ _ msg') = onReturn msg' callback _ = return () -@ {\tt callBlocking} is similar, except that it waits for the reply and -returns in the current {\tt IO} thread. - <>= +-- | Similar to 'call', except that it waits for the reply and returns it +-- in the current 'IO' thread. +-- callBlocking :: Client -> M.MethodCall -> IO (Either M.Error M.MethodReturn) callBlocking client msg = do mvar <- MV.newEmptyMVar @@ -190,13 +205,12 @@ (MV.putMVar mvar . Right) MV.takeMVar mvar -@ Finally, for reasons similar to {\tt send}, it's useful to have a -computation which calls a method and raises an exception if it returns -an error. - <>= -callBlocking' :: Client -> M.MethodCall -> IO M.MethodReturn -callBlocking' client msg = do +-- | Similar to 'callBlocking', except that an exception is raised if the +-- destination sends back an error. +-- +callBlocking_ :: Client -> M.MethodCall -> IO M.MethodReturn +callBlocking_ client msg = do reply <- callBlocking client msg case reply of Left x -> error . TL.unpack . M.errorMessage $ x @@ -206,7 +220,7 @@ -- ** Sending messages , call , callBlocking -, callBlocking' +, callBlocking_ @ \subsubsection{Emitting signals} @@ -215,7 +229,7 @@ <>= emitSignal :: Client -> M.Signal -> IO () -emitSignal = sendOnly +emitSignal = sendOnly_ <>= -- *** Emitting signals @@ -266,7 +280,7 @@ <>= unknownMethod :: Client -> M.ReceivedMessage -> IO () -unknownMethod client msg = sendOnly client errorMsg where +unknownMethod client msg = sendOnly_ client errorMsg where M.ReceivedMethodCall serial sender _ = msg errorMsg = M.Error Const.errorUnknownMethod @@ -313,31 +327,31 @@ @ \section{Name reservation} -@ A client can request a ``well-known'' name from the bus. This allows -messages sent to that name to be received by the client, without senders -being aware of which application is actually handling requests. - -A name may be requested for any client, using the given flags. The bus's -reply will be returned, or an exception raised if the reply was invalid. - <>= import qualified DBus.NameReservation as NR <>= +-- | A client can request a \"well-known\" name from the bus. This allows +-- messages sent to that name to be received by the client, without senders +-- being aware of which application is actually handling requests. +-- +-- A name may be requested for any client, using the given flags. The bus's +-- reply will be returned, or an exception raised if the reply was invalid. +-- requestName :: Client -> T.BusName -> [NR.RequestNameFlag] -> IO NR.RequestNameReply requestName client name flags = do - reply <- callBlocking' client $ NR.requestName name flags + reply <- callBlocking_ client $ NR.requestName name flags case NR.mkRequestNameReply reply of Nothing -> error $ "Invalid reply to RequestName" Just x -> return x -@ Releasing a name is similar, except there's no flags. - <>= +-- | Clients may also release names they've requested. +-- releaseName :: Client -> T.BusName -> IO NR.ReleaseNameReply releaseName client name = do - reply <- callBlocking' client $ NR.releaseName name + reply <- callBlocking_ client $ NR.releaseName name case NR.mkReleaseNameReply reply of Nothing -> error $ "Invalid reply to ReleaseName" Just x -> return x @@ -358,6 +372,9 @@ import Data.Maybe (fromJust) <>= +-- | Perform some computation every time this client receives a matching +-- signal. +-- onSignal :: Client -> MR.MatchRule -> (T.BusName -> M.Signal -> IO ()) -> IO () @@ -370,7 +387,7 @@ callback' _ = return () in do - callBlocking' client $ MR.addMatch rule' + callBlocking_ client $ MR.addMatch rule' MV.modifyMVar_ mvar $ return . (callback' :) <>= @@ -402,6 +419,9 @@ (Set.fromList flags) body <>= +-- | As 'call', except that the proxy's information is used to +-- build the message. +-- callProxy :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] -> (M.Error -> IO ()) -> (M.MethodReturn -> IO ()) @@ -411,6 +431,9 @@ in call client msg onError onReturn <>= +-- | As 'callBlocking', except that the proxy's information is used +-- to build the message. +-- callProxyBlocking :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] -> IO (Either M.Error M.MethodReturn) @@ -418,16 +441,19 @@ callBlocking client $ buildMethodCall proxy name flags body <>= -callProxyBlocking' :: Client -> Proxy -> T.MemberName -> [M.Flag] +-- | As 'callBlocking_', except that the proxy's information is used +-- to build the message. +-- +callProxyBlocking_ :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] -> IO M.MethodReturn -callProxyBlocking' client proxy name flags body = - callBlocking' client $ buildMethodCall proxy name flags body +callProxyBlocking_ client proxy name flags body = + callBlocking_ client $ buildMethodCall proxy name flags body <>= , callProxy , callProxyBlocking -, callProxyBlocking' +, callProxyBlocking_ @ \subsection{Signals} @@ -459,27 +485,24 @@ import qualified DBus.Introspection as I <>= -export client (T.mkObjectPath' "/") rootObject +export client ("/") rootObject <>= rootObject :: LocalObject rootObject = LocalObject $ Map.fromList [(ifaceName, interface)] where - ifaceName = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable" - memberName = T.mkMemberName' "Introspect" - inSig = T.mkSignature' "" - outSig = T.mkSignature' "s" + ifaceName = "org.freedesktop.DBus.Introspectable" + memberName = "Introspect" interface = Interface $ Map.fromList [(memberName, impl)] - method = I.Method memberName [] [I.Parameter "xml" outSig] + method = I.Method memberName [] [I.Parameter "xml" "s"] iface = I.Interface ifaceName [method] [] [] - path = T.mkObjectPath' "/" - impl = Method inSig outSig $ \call' -> do + impl = Method "" "s" $ \call' -> do let Client _ _ _ mvar _ = methodCallClient call' paths <- fmap Map.keys $ MV.readMVar mvar - let paths' = filter (/= path) paths - let Just xml = I.toXML $ I.Object path [iface] + let paths' = filter (/= "/") paths + let Just xml = I.toXML $ I.Object "/" [iface] [I.Object p [] [] | p <- paths'] replyReturn call' [T.toVariant xml] @@ -501,6 +524,13 @@ | Signal T.Signature <>= +-- | Export a set of interfaces on the bus. Whenever a method call is +-- received which matches the object's path, interface, and member name, +-- one of its members will be called. +-- +-- Exported objects automatically implement the +-- @org.freedesktop.DBus.Introspectable@ interface. +-- export :: Client -> T.ObjectPath -> LocalObject -> IO () export client@(Client _ _ _ mvar _) path obj = MV.modifyMVar_ mvar $ return . Map.insert path (onMethodCall client (addIntrospectable path obj)) @@ -509,9 +539,9 @@ addIntrospectable :: T.ObjectPath -> LocalObject -> LocalObject addIntrospectable path (LocalObject ifaces) = LocalObject ifaces' where ifaces' = Map.insertWith (\_ x -> x) name iface ifaces - name = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable" - iface = Interface $ Map.fromList [(T.mkMemberName' "Introspect", impl)] - impl = Method (T.mkSignature' "") (T.mkSignature' "s") $ \call' -> do + name = "org.freedesktop.DBus.Introspectable" + iface = Interface $ Map.fromList [("Introspect", impl)] + impl = Method "" "s" $ \call' -> do let Just xml = I.toXML . introspect path . methodCallObject $ call' replyReturn call' [T.toVariant xml] @@ -539,7 +569,7 @@ (map introspectParam (T.signatureTypes sig))] introspectSignal _ = [] - introspectParam = I.Parameter "" . T.mkSignature' . T.typeCode + introspectParam = I.Parameter "" . T.mkSignature_ . T.typeCode @ \subsection{Responding to method calls} @@ -571,7 +601,7 @@ let M.ReceivedMethodCall serial sender call' = msg sigStr = TL.concat . map (T.typeCode . T.variantType) . M.methodCallBody $ call' - sig = T.mkSignature' sigStr + sig = T.mkSignature_ sigStr case findMember call' obj of Just method@(Method inSig _ x) -> let @@ -587,6 +617,8 @@ <>= +-- | Send a successful return reply for a method call. +-- replyReturn :: MethodCall -> [T.Variant] -> IO () replyReturn call' body = reply where replyInvalid = M.Error @@ -601,7 +633,7 @@ body sendReply :: M.Message a => a -> IO () - sendReply = sendOnly (methodCallClient call') + sendReply = sendOnly_ (methodCallClient call') sigStr = TL.concat . map (T.typeCode . T.variantType) $ body (Method _ outSig _) = methodCallMethod call' @@ -610,8 +642,10 @@ else sendReply replyInvalid <>= +-- | Send an error reply for a method call. +-- replyError :: MethodCall -> T.ErrorName -> [T.Variant] -> IO () -replyError call' name body = sendOnly c reply where +replyError call' name body = sendOnly_ c reply where c = methodCallClient call' reply = M.Error name diff --git a/hs/DBus/Client.hs b/hs/DBus/Client.hs --- a/hs/DBus/Client.hs +++ b/hs/DBus/Client.hs @@ -26,7 +26,7 @@ -- ** Sending messages , call , callBlocking - , callBlocking' + , callBlocking_ -- *** Emitting signals , emitSignal @@ -44,7 +44,7 @@ , callProxy , callProxyBlocking - , callProxyBlocking' + , callProxyBlocking_ , onSignalFrom @@ -85,6 +85,8 @@ type Callback = (M.ReceivedMessage -> IO ()) +-- | 'Client's are opaque handles to an open connection and other internal +-- state. data Client = Client C.Connection T.BusName (MV.MVar (Map.Map M.Serial Callback)) (MV.MVar (Map.Map T.ObjectPath Callback)) @@ -96,6 +98,18 @@ clientName :: Client -> T.BusName clientName (Client _ x _ _ _) = x +-- | Create a new 'Client' from an open connection and bus name. The weird + +-- signature allows 'mkClient' to use the computations in "DBus.Bus" +-- directly, without unpacking: +-- +-- @ +-- client <- mkClient =<< getSessionBus +-- @ +-- +-- Only one client should be created for any given connection. Otherwise, +-- they will compete to receive messages. +-- mkClient :: (C.Connection, T.BusName) -> IO Client mkClient (c, name) = do replies <- MV.newMVar Map.empty @@ -104,25 +118,29 @@ let client = Client c name replies exports signals forkIO $ forever (receiveMessages client) - export client (T.mkObjectPath' "/") rootObject + export client ("/") rootObject return client -send :: M.Message a => Client -> (M.Serial -> IO b) -> a -> IO b -send c f msg = do +send_ :: M.Message a => Client -> (M.Serial -> IO b) -> a -> IO b +send_ c f msg = do result <- C.send (clientConnection c) f msg case result of Left x -> error $ show x Right x -> return x -sendOnly :: M.Message a => Client -> a -> IO () -sendOnly c = send c (const $ return ()) +sendOnly_ :: M.Message a => Client -> a -> IO () +sendOnly_ c = send_ c (const $ return ()) +-- | Perform an asynchronous method call. One of the provided computations +-- will be performed depending on what message type the destination sends +-- back. +-- call :: Client -> M.MethodCall -> (M.Error -> IO ()) -> (M.MethodReturn -> IO ()) -> IO () -call client msg onError onReturn = send client addCallback msg where +call client msg onError onReturn = send_ client addCallback msg where Client _ _ mvar _ _ = client addCallback s = MV.modifyMVar_ mvar $ return . Map.insert s callback @@ -130,6 +148,9 @@ callback (M.ReceivedMethodReturn _ _ msg') = onReturn msg' callback _ = return () +-- | Similar to 'call', except that it waits for the reply and returns it +-- in the current 'IO' thread. +-- callBlocking :: Client -> M.MethodCall -> IO (Either M.Error M.MethodReturn) callBlocking client msg = do mvar <- MV.newEmptyMVar @@ -138,15 +159,18 @@ (MV.putMVar mvar . Right) MV.takeMVar mvar -callBlocking' :: Client -> M.MethodCall -> IO M.MethodReturn -callBlocking' client msg = do +-- | Similar to 'callBlocking', except that an exception is raised if the +-- destination sends back an error. +-- +callBlocking_ :: Client -> M.MethodCall -> IO M.MethodReturn +callBlocking_ client msg = do reply <- callBlocking client msg case reply of Left x -> error . TL.unpack . M.errorMessage $ x Right x -> return x emitSignal :: Client -> M.Signal -> IO () -emitSignal = sendOnly +emitSignal = sendOnly_ receiveMessages :: Client -> IO () receiveMessages client = do @@ -175,7 +199,7 @@ handleMessage _ _ = return () unknownMethod :: Client -> M.ReceivedMessage -> IO () -unknownMethod client msg = sendOnly client errorMsg where +unknownMethod client msg = sendOnly_ client errorMsg where M.ReceivedMethodCall serial sender _ = msg errorMsg = M.Error Const.errorUnknownMethod @@ -194,21 +218,33 @@ Just x -> forkIO (x msg) >> return () Nothing -> return () +-- | A client can request a \"well-known\" name from the bus. This allows +-- messages sent to that name to be received by the client, without senders +-- being aware of which application is actually handling requests. +-- +-- A name may be requested for any client, using the given flags. The bus's +-- reply will be returned, or an exception raised if the reply was invalid. +-- requestName :: Client -> T.BusName -> [NR.RequestNameFlag] -> IO NR.RequestNameReply requestName client name flags = do - reply <- callBlocking' client $ NR.requestName name flags + reply <- callBlocking_ client $ NR.requestName name flags case NR.mkRequestNameReply reply of Nothing -> error $ "Invalid reply to RequestName" Just x -> return x +-- | Clients may also release names they've requested. +-- releaseName :: Client -> T.BusName -> IO NR.ReleaseNameReply releaseName client name = do - reply <- callBlocking' client $ NR.releaseName name + reply <- callBlocking_ client $ NR.releaseName name case NR.mkReleaseNameReply reply of Nothing -> error $ "Invalid reply to ReleaseName" Just x -> return x +-- | Perform some computation every time this client receives a matching +-- signal. +-- onSignal :: Client -> MR.MatchRule -> (T.BusName -> M.Signal -> IO ()) -> IO () @@ -221,7 +257,7 @@ callback' _ = return () in do - callBlocking' client $ MR.addMatch rule' + callBlocking_ client $ MR.addMatch rule' MV.modifyMVar_ mvar $ return . (callback' :) data RemoteObject = RemoteObject T.BusName T.ObjectPath @@ -234,6 +270,9 @@ msg = M.MethodCall path name (Just iface) (Just dest) (Set.fromList flags) body +-- | As 'call', except that the proxy's information is used to +-- build the message. +-- callProxy :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] -> (M.Error -> IO ()) -> (M.MethodReturn -> IO ()) @@ -242,17 +281,23 @@ msg = buildMethodCall proxy name flags body in call client msg onError onReturn +-- | As 'callBlocking', except that the proxy's information is used +-- to build the message. +-- callProxyBlocking :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] -> IO (Either M.Error M.MethodReturn) callProxyBlocking client proxy name flags body = callBlocking client $ buildMethodCall proxy name flags body -callProxyBlocking' :: Client -> Proxy -> T.MemberName -> [M.Flag] +-- | As 'callBlocking_', except that the proxy's information is used +-- to build the message. +-- +callProxyBlocking_ :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] -> IO M.MethodReturn -callProxyBlocking' client proxy name flags body = - callBlocking' client $ buildMethodCall proxy name flags body +callProxyBlocking_ client proxy name flags body = + callBlocking_ client $ buildMethodCall proxy name flags body onSignalFrom :: Client -> Proxy -> T.MemberName -> (M.Signal -> IO ()) -> IO () @@ -271,22 +316,19 @@ rootObject :: LocalObject rootObject = LocalObject $ Map.fromList [(ifaceName, interface)] where - ifaceName = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable" - memberName = T.mkMemberName' "Introspect" - inSig = T.mkSignature' "" - outSig = T.mkSignature' "s" + ifaceName = "org.freedesktop.DBus.Introspectable" + memberName = "Introspect" interface = Interface $ Map.fromList [(memberName, impl)] - method = I.Method memberName [] [I.Parameter "xml" outSig] + method = I.Method memberName [] [I.Parameter "xml" "s"] iface = I.Interface ifaceName [method] [] [] - path = T.mkObjectPath' "/" - impl = Method inSig outSig $ \call' -> do + impl = Method "" "s" $ \call' -> do let Client _ _ _ mvar _ = methodCallClient call' paths <- fmap Map.keys $ MV.readMVar mvar - let paths' = filter (/= path) paths - let Just xml = I.toXML $ I.Object path [iface] + let paths' = filter (/= "/") paths + let Just xml = I.toXML $ I.Object "/" [iface] [I.Object p [] [] | p <- paths'] replyReturn call' [T.toVariant xml] @@ -296,6 +338,13 @@ = Method T.Signature T.Signature (MethodCall -> IO ()) | Signal T.Signature +-- | Export a set of interfaces on the bus. Whenever a method call is +-- received which matches the object's path, interface, and member name, +-- one of its members will be called. +-- +-- Exported objects automatically implement the +-- @org.freedesktop.DBus.Introspectable@ interface. +-- export :: Client -> T.ObjectPath -> LocalObject -> IO () export client@(Client _ _ _ mvar _) path obj = MV.modifyMVar_ mvar $ return . Map.insert path (onMethodCall client (addIntrospectable path obj)) @@ -303,9 +352,9 @@ addIntrospectable :: T.ObjectPath -> LocalObject -> LocalObject addIntrospectable path (LocalObject ifaces) = LocalObject ifaces' where ifaces' = Map.insertWith (\_ x -> x) name iface ifaces - name = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable" - iface = Interface $ Map.fromList [(T.mkMemberName' "Introspect", impl)] - impl = Method (T.mkSignature' "") (T.mkSignature' "s") $ \call' -> do + name = "org.freedesktop.DBus.Introspectable" + iface = Interface $ Map.fromList [("Introspect", impl)] + impl = Method "" "s" $ \call' -> do let Just xml = I.toXML . introspect path . methodCallObject $ call' replyReturn call' [T.toVariant xml] @@ -332,7 +381,7 @@ (map introspectParam (T.signatureTypes sig))] introspectSignal _ = [] - introspectParam = I.Parameter "" . T.mkSignature' . T.typeCode + introspectParam = I.Parameter "" . T.mkSignature_ . T.typeCode data MethodCall = MethodCall { methodCallObject :: LocalObject @@ -355,7 +404,7 @@ let M.ReceivedMethodCall serial sender call' = msg sigStr = TL.concat . map (T.typeCode . T.variantType) . M.methodCallBody $ call' - sig = T.mkSignature' sigStr + sig = T.mkSignature_ sigStr case findMember call' obj of Just method@(Method inSig _ x) -> let @@ -370,6 +419,8 @@ _ -> unknownMethod client msg +-- | Send a successful return reply for a method call. +-- replyReturn :: MethodCall -> [T.Variant] -> IO () replyReturn call' body = reply where replyInvalid = M.Error @@ -384,7 +435,7 @@ body sendReply :: M.Message a => a -> IO () - sendReply = sendOnly (methodCallClient call') + sendReply = sendOnly_ (methodCallClient call') sigStr = TL.concat . map (T.typeCode . T.variantType) $ body (Method _ outSig _) = methodCallMethod call' @@ -392,8 +443,10 @@ then sendReply replyValid else sendReply replyInvalid +-- | Send an error reply for a method call. +-- replyError :: MethodCall -> T.ErrorName -> [T.Variant] -> IO () -replyError call' name body = sendOnly c reply where +replyError call' name body = sendOnly_ c reply where c = methodCallClient call' reply = M.Error name