diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -15,4 +15,4 @@ xelatex "$<" xelatex "$<" -pdfs: dbus-client.pdf manual.pdf +pdfs: dbus-client.pdf #manual.pdf diff --git a/dbus-client.cabal b/dbus-client.cabal --- a/dbus-client.cabal +++ b/dbus-client.cabal @@ -1,5 +1,5 @@ name: dbus-client -version: 0.1 +version: 0.2 synopsis: D-Bus client libraries description: Connect and interact with the D-Bus IPC system. license: GPL @@ -26,7 +26,7 @@ build-depends: base >=3 && < 5 - , dbus-core >= 0.5 + , dbus-core >= 0.6 , containers , text diff --git a/dbus-client.nw b/dbus-client.nw --- a/dbus-client.nw +++ b/dbus-client.nw @@ -43,8 +43,18 @@ clients. It implements async operations, remote object proxies, and local object exporting. -All source code is licensed under the terms of the GNU GPL v3 or later. +The {\tt DBus.Client} module provides the public interface to this library. +<>= +<> +{-# LANGUAGE OverloadedStrings #-} +module DBus.Client + ( <> + ) where +<> + +@ All source code is licensed under the terms of the GNU GPL v3 or later. + <>= {- Copyright (C) 2009 John Millikin @@ -63,174 +73,155 @@ along with this program. If not, see . -} - @ \section{Clients} -<>= -<> -{-# LANGUAGE OverloadedStrings #-} -module DBus.Client - ( <> - ) where -<> +The {\tt Client} type provides an opaque handle to internal client state, +including callback registration and the open connection. <>= import qualified Control.Concurrent.MVar as MV import qualified Data.Map as Map import qualified DBus.Connection as C -import qualified DBus.Constants as Const import qualified DBus.Message as M import qualified DBus.Types as T <>= type Callback = (M.ReceivedMessage -> IO ()) -data Client = Client C.Connection +data Client = Client C.Connection T.BusName (MV.MVar (Map.Map M.Serial Callback)) (MV.MVar (Map.Map T.ObjectPath Callback)) (MV.MVar [Callback]) +@ Two accessor functions are defined for the {\tt Client}'s {\tt Connection} +and unique bus name. The {\tt Connection} is used internally by this module, +but is not otherwise useful -- sharing a {\tt Connection} between two +{\tt Client}s is a bad idea. + +The {\tt Client}'s bus name might be useful, and there's no harm in exposing +it. + +<>= clientConnection :: Client -> C.Connection -clientConnection (Client x _ _ _) = x +clientConnection (Client x _ _ _ _) = x +clientName :: Client -> T.BusName +clientName (Client _ x _ _ _) = x + <>= + -- * Clients Client -, clientConnection +, 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. + <>= -mkClient :: IO (C.Connection, T.BusName) -> IO Client -mkClient getBus = do - (c, _) <- getBus +mkClient :: (C.Connection, T.BusName) -> IO Client +mkClient (c, name) = do replies <- MV.newMVar Map.empty exports <- MV.newMVar Map.empty signals <- MV.newMVar [] - let client = Client c replies exports signals + let client = Client c name replies exports signals <> return client <>= , mkClient -<>= -send' :: M.Message a => C.Connection -> (M.Serial -> IO b) -> a - -> IO b -send' c f msg = C.send c f msg >>= \result -> case result of - Left x -> error $ show x - Right x -> return x - -@ -\section{Name reservation} +@ \subsection{Sending messages} -@ 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. +To simplify error conditions, errors returned from the {\tt DBus.Connection} +computations are converted to exceptions via {\tt error}. These errors only +occur if the message is malformed, so it's not worth the additional API +complexity to handle them. <>= -data RequestNameFlag - = AllowReplacement - | ReplaceExisting - | DoNotQueue - deriving (Show) +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 -<>= -data RequestNameReply - = PrimaryOwner - | InQueue - | Exists - | AlreadyOwner - deriving (Show) +@ And since most uses of {\tt send} don't care about the message's +serial, it can be reduced further. <>= -data ReleaseNameReply - = Released - | NonExistent - | NotOwner - deriving (Show) - -<>= -, RequestNameFlag (..) -, RequestNameReply (..) -, ReleaseNameReply (..) +sendOnly :: M.Message a => Client -> a -> IO () +sendOnly c = send c (const $ return ()) -@ All name requests are handled by the main bus service, which has names -provided by the {\tt DBus.Constants} module. +@ Additional helper computations are useful for sending method calls, to +keep track of which pending calls are currently expecting replies. The +{\tt call} computation is asynchronous; it will return immediately, and +one of the provided computations will be invoked depending on whether a +{\tt MethodReturn} or {\tt Error} were received. -<>= -dbus :: Proxy -dbus = Proxy (RemoteObject Const.dbusName Const.dbusPath) Const.dbusInterface +TODO: pending method calls should be removed periodically, after a +decently long timeout. -@ There are only two methods of interest here, {\tt RequestName} and -{\tt ReleaseName}. +TODO: if method calls with the {\tt NoReplyExpected} flag are sent, a +callback will be added but never removed. This could cause a space leak. <>= -request, release :: T.MemberName -request = T.mkMemberName' "RequestName" -release = T.mkMemberName' "ReleaseName" +call :: Client -> M.MethodCall + -> (M.Error -> IO ()) + -> (M.MethodReturn -> IO ()) + -> IO () +call client msg onError onReturn = send client addCallback msg where + Client _ _ mvar _ _ = client + addCallback s = MV.modifyMVar_ mvar $ return . Map.insert s callback + + callback (M.ReceivedError _ _ msg') = onError msg' + callback (M.ReceivedMethodReturn _ _ msg') = onReturn msg' + callback _ = return () -@ 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. +@ {\tt callBlocking} is similar, except that it waits for the reply and +returns in the current {\tt IO} thread. <>= -requestName :: Client -> T.BusName -> [RequestNameFlag] -> IO RequestNameReply -requestName client name flags = do - returned <- callBlocking client dbus request [] - [ T.toVariant name - , T.toVariant . encodeFlags $ flags] - - let reply = M.messageBody returned !! 0 - case decodeRequestReply =<< T.fromVariant reply of - Just x -> return x - Nothing -> error $ "Unknown request name reply: " ++ - show reply - -<>= -, requestName +callBlocking :: Client -> M.MethodCall -> IO (Either M.Error M.MethodReturn) +callBlocking client msg = do + mvar <- MV.newEmptyMVar + call client msg + (MV.putMVar mvar . Left) + (MV.putMVar mvar . Right) + MV.takeMVar mvar -@ Releasing a name is similar, except there's no flags for releasing a name. +@ 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. <>= -releaseName :: Client -> T.BusName -> IO ReleaseNameReply -releaseName client name = do - returned <- callBlocking client dbus release [] [T.toVariant name] - - let reply = M.messageBody returned !! 0 - case decodeReleaseReply =<< T.fromVariant reply of - Just x -> return x - Nothing -> error $ "Unknown release name reply: " ++ - show reply +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 <>= -, releaseName + -- ** Sending messages +, call +, callBlocking +, callBlocking' -<>= -import Data.Word (Word32) -import Data.Bits ((.|.)) +@ \subsubsection{Emitting signals} -<>= -encodeFlags :: [RequestNameFlag] -> Word32 -encodeFlags = foldr (.|.) 0 . map flagValue where - flagValue AllowReplacement = 0x1 - flagValue ReplaceExisting = 0x2 - flagValue DoNotQueue = 0x4 +TODO: this should be written in terms of locally exported objects; having +to construct a {\tt Signal} is a pain. <>= -decodeRequestReply :: Word32 -> Maybe RequestNameReply -decodeRequestReply 1 = Just PrimaryOwner -decodeRequestReply 2 = Just InQueue -decodeRequestReply 3 = Just Exists -decodeRequestReply 4 = Just AlreadyOwner -decodeRequestReply _ = Nothing +emitSignal :: Client -> M.Signal -> IO () +emitSignal = sendOnly -<>= -decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply -decodeReleaseReply 1 = Just Released -decodeReleaseReply 2 = Just NonExistent -decodeReleaseReply 3 = Just NotOwner -decodeReleaseReply _ = Nothing +<>= + -- *** Emitting signals +, emitSignal -@ -\section{Receiving messages} +@ \subsection{Receiving messages} Each client runs a separate thread for receiving messages, and every callback is called in a separate thread. This allows callbacks to perform long @@ -240,54 +231,66 @@ import Control.Concurrent (forkIO) import Control.Monad (forever) import qualified Data.Set as Set +import qualified DBus.Constants as Const <>= forkIO $ forever (receiveMessages client) +@ FIXME: does raising an exception here cause the thread to terminate? + <>= receiveMessages :: Client -> IO () -receiveMessages client@(Client c _ _ _) = do - received <- C.receive c - msg <- case received of +receiveMessages client = do + received <- C.receive $ clientConnection client + case received of Left x -> error $ show x - Right x -> return x - case msg of - (M.ReceivedMethodCall _ _ _ ) -> gotMethodCall client msg - (M.ReceivedMethodReturn _ _ msg') -> gotReply client (M.methodReturnSerial msg') msg - (M.ReceivedError _ _ msg') -> gotReply client (M.errorSerial msg') msg - (M.ReceivedSignal _ _ _ ) -> gotSignal client msg - _ -> return () + Right x -> handleMessage client x <>= -gotMethodCall :: Client -> M.ReceivedMessage -> IO () -gotMethodCall client@(Client _ _ mvar _) msg = do +handleMessage :: Client -> M.ReceivedMessage -> IO () +<> +handleMessage _ _ = return () + +@ \subsubsection{Method calls} + +Method calls are dispatched to the client's list of exported objects. If +no object is available at the requested path, an error will be returned. + +<>= +handleMessage client msg@(M.ReceivedMethodCall _ _ call') = do + let Client _ _ _ mvar _ = client objects <- MV.readMVar mvar - let M.ReceivedMethodCall _ _ call' = msg case Map.lookup (M.methodCallPath call') objects of Just x -> x msg Nothing -> unknownMethod client msg <>= unknownMethod :: Client -> M.ReceivedMessage -> IO () -unknownMethod client msg = send' c (const $ return ()) errorMsg where +unknownMethod client msg = sendOnly client errorMsg where M.ReceivedMethodCall serial sender _ = msg - c = clientConnection client errorMsg = M.Error Const.errorUnknownMethod serial sender - (Set.fromList [M.NoReplyExpected, M.NoAutoStart]) [] +@ \subsubsection{Replies} + @ Method returns and errors both have a serial attached, which is used to find the proper callback. If the callback cannot be found, no action will be taken. +<>= +handleMessage c msg@(M.ReceivedMethodReturn _ _ msg') = + gotReply c (M.methodReturnSerial msg') msg +handleMessage c msg@(M.ReceivedError _ _ msg') = + gotReply c (M.errorSerial msg') msg + <>= -import Data.Maybe (isJust, fromJust, isNothing) +import Data.Maybe (isJust) <>= gotReply :: Client -> M.Serial -> M.ReceivedMessage -> IO () -gotReply (Client _ mvar _ _) serial msg = do +gotReply (Client _ _ mvar _ _) serial msg = do callback <- MV.modifyMVar mvar $ \callbacks -> let x = Map.lookup serial callbacks callbacks' = if isJust x @@ -298,49 +301,91 @@ Just x -> forkIO (x msg) >> return () Nothing -> return () +@ \subsubsection{Signals} + +Signals are dispatched to the list of active signal handlers. + +<>= +handleMessage c msg@(M.ReceivedSignal _ _ _) = let + Client _ _ _ _ mvar = c + in MV.withMVar mvar $ mapM_ (\cb -> forkIO (cb msg)) + +@ +\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 + <>= -gotSignal :: Client -> M.ReceivedMessage -> IO () -gotSignal (Client _ _ _ mvar) msg = MV.withMVar mvar $ - mapM_ (\cb -> forkIO (cb msg)) +requestName :: Client -> T.BusName -> [NR.RequestNameFlag] + -> IO NR.RequestNameReply +requestName client name flags = do + reply <- callBlocking' client $ NR.requestName name flags + case NR.mkRequestNameReply reply of + Nothing -> error $ "Invalid reply to RequestName" + Just x -> return x -@ \subsection{Signals} +@ Releasing a name is similar, except there's no flags. <>= -onSignal :: Client - -> (T.BusName -> M.Signal -> Bool) - -> (T.BusName -> M.Signal -> IO ()) - -> IO () -onSignal (Client _ _ _ mvar) test callback = MV.modifyMVar_ mvar addCallback where - addCallback callbacks = return $ callback' : callbacks - callback' (M.ReceivedSignal _ sender msg) = - if test (fromJust sender) msg - then callback (fromJust sender) msg - else return () - callback' _ = undefined +releaseName :: Client -> T.BusName -> IO NR.ReleaseNameReply +releaseName client name = do + reply <- callBlocking' client $ NR.releaseName name + case NR.mkReleaseNameReply reply of + Nothing -> error $ "Invalid reply to ReleaseName" + Just x -> return x +<>= + -- * Name reservation +, requestName +, releaseName + +@ \subsection{Listening for Signals} + +Before the bus forwards any signals to this client, the client must send a +match rule to the bus. The rule is kept around so the correct callback can +be found when the signal is received. + +<>= +import qualified DBus.MatchRule as MR +import Data.Maybe (fromJust) + <>= -signalFilter :: Maybe T.BusName -> Maybe T.ObjectPath -> Maybe T.InterfaceName - -> Maybe T.MemberName -> T.BusName -> M.Signal -> Bool -signalFilter sender path iface member sender' msg = all id - [ isNothing sender || sender == Just sender' - , isNothing path || path == Just (M.signalPath msg) - , isNothing iface || iface == Just (M.signalInterface msg) - , isNothing member || member == Just (M.signalMember msg) - ] +onSignal :: Client -> MR.MatchRule + -> (T.BusName -> M.Signal -> IO ()) + -> IO () +onSignal client rule callback = let + (Client _ _ _ _ mvar) = client + rule' = rule { MR.matchType = Just MR.Signal } + + callback' msg@(M.ReceivedSignal _ sender signal) + | MR.matches rule' msg = callback (fromJust sender) signal + callback' _ = return () + + in do + callBlocking' client $ MR.addMatch rule' + MV.modifyMVar_ mvar $ return . (callback' :) <>= + -- * Receiving signals , onSignal -, signalFilter @ -\section{Remote object proxies} +\section{Remote objects and proxies} +TODO: document this section + <>= + -- * Remote objects and proxies , RemoteObject (..) , Proxy (..) -, call -, callBlocking -, onSignalFrom <>= data RemoteObject = RemoteObject T.BusName T.ObjectPath @@ -349,52 +394,67 @@ @ \subsection{Method calls} <>= -call :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] - -> (M.Error -> IO ()) - -> (M.MethodReturn -> IO ()) - -> IO () -call client proxy name flags body onError onReturn = let +buildMethodCall :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] + -> M.MethodCall +buildMethodCall proxy name flags body = msg where Proxy (RemoteObject dest path) iface = proxy - Client bus mvar _ _ = client msg = M.MethodCall path name (Just iface) (Just dest) - (Set.fromList flags) - body - - callback (M.ReceivedError _ _ z) = onError z - callback (M.ReceivedMethodReturn _ _ z) = onReturn z - callback _ = undefined - - addCallback s = MV.modifyMVar_ mvar $ \callbacks -> - return $ Map.insert s callback callbacks - in send' bus addCallback msg + (Set.fromList flags) body <>= -callBlocking :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] - -> IO M.MethodReturn -callBlocking client proxy name flags body = do - mvar <- MV.newEmptyMVar - call client proxy name flags body - (MV.putMVar mvar . Left) - (MV.putMVar mvar . Right) - reply <- MV.takeMVar mvar - case reply of - Left x -> error (show x) - Right x -> return x +callProxy :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] + -> (M.Error -> IO ()) + -> (M.MethodReturn -> IO ()) + -> IO () +callProxy client proxy name flags body onError onReturn = let + msg = buildMethodCall proxy name flags body + in call client msg onError onReturn +<>= +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] + -> [T.Variant] + -> IO M.MethodReturn +callProxyBlocking' client proxy name flags body = + callBlocking' client $ buildMethodCall proxy name flags body + +<>= +, callProxy +, callProxyBlocking +, callProxyBlocking' + @ \subsection{Signals} <>= onSignalFrom :: Client -> Proxy -> T.MemberName -> (M.Signal -> IO ()) -> IO () -onSignalFrom client proxy member io = onSignal client test io' where +onSignalFrom client proxy member io = onSignal client rule io' where Proxy (RemoteObject dest path) iface = proxy - test = signalFilter (Just dest) (Just path) (Just iface) - (Just member) + rule = MR.MatchRule + { MR.matchType = Nothing + , MR.matchSender = Just dest + , MR.matchInterface = Just iface + , MR.matchMember = Just member + , MR.matchPath = Just path + , MR.matchDestination = Nothing + , MR.matchParameters = [] + } io' _ msg = io msg +<>= +, onSignalFrom + @ \section{Exporting local objects} +FIXME: the introspection stuff is \emph{really} ugly. + <>= import qualified DBus.Introspection as I @@ -415,7 +475,7 @@ path = T.mkObjectPath' "/" impl = Method inSig outSig $ \call' -> do - let Client _ _ mvar _ = methodCallClient call' + let Client _ _ _ mvar _ = methodCallClient call' paths <- fmap Map.keys $ MV.readMVar mvar let paths' = filter (/= path) paths @@ -424,10 +484,10 @@ replyReturn call' [T.toVariant xml] <>= + -- * Exporting local objects , LocalObject (..) -, Member (..) , Interface (..) -, MethodCall (..) +, Member (..) , export <>= @@ -442,7 +502,7 @@ <>= export :: Client -> T.ObjectPath -> LocalObject -> IO () -export client@(Client _ _ mvar _) path obj = MV.modifyMVar_ mvar $ +export client@(Client _ _ _ mvar _) path obj = MV.modifyMVar_ mvar $ return . Map.insert path (onMethodCall client (addIntrospectable path obj)) <>= @@ -529,22 +589,19 @@ <>= replyReturn :: MethodCall -> [T.Variant] -> IO () replyReturn call' body = reply where - c = clientConnection . methodCallClient $ call' replyInvalid = M.Error Const.errorFailed (methodCallSerial call') (methodCallSender call') - (Set.fromList [M.NoReplyExpected, M.NoAutoStart]) [T.toVariant $ TL.pack "Method return didn't match signature."] replyValid = M.MethodReturn (methodCallSerial call') (methodCallSender call') - (Set.fromList [M.NoReplyExpected, M.NoAutoStart]) body sendReply :: M.Message a => a -> IO () - sendReply = send' c (const $ return ()) + sendReply = sendOnly (methodCallClient call') sigStr = TL.concat . map (T.typeCode . T.variantType) $ body (Method _ outSig _) = methodCallMethod call' @@ -554,16 +611,17 @@ <>= replyError :: MethodCall -> T.ErrorName -> [T.Variant] -> IO () -replyError call' name body = send' c (const $ return ()) reply where - c = clientConnection . methodCallClient $ call' +replyError call' name body = sendOnly c reply where + c = methodCallClient call' reply = M.Error name (methodCallSerial call') (methodCallSender call') - (Set.fromList [M.NoReplyExpected, M.NoAutoStart]) body <>= + -- ** Responding to method calls +, MethodCall (..) , replyReturn , replyError diff --git a/hs/DBus/Client.hs b/hs/DBus/Client.hs --- a/hs/DBus/Client.hs +++ b/hs/DBus/Client.hs @@ -15,37 +15,47 @@ along with this program. If not, see . -} - {-# LANGUAGE OverloadedStrings #-} module DBus.Client - ( Client - , clientConnection + ( -- * Clients + Client + , clientName , mkClient - , RequestNameFlag (..) - , RequestNameReply (..) - , ReleaseNameReply (..) + -- ** Sending messages + , call + , callBlocking + , callBlocking' - , requestName + -- *** Emitting signals + , emitSignal + -- * Name reservation + , requestName , releaseName + -- * Receiving signals , onSignal - , signalFilter + -- * Remote objects and proxies , RemoteObject (..) , Proxy (..) - , call - , callBlocking + + , callProxy + , callProxyBlocking + , callProxyBlocking' + , onSignalFrom + -- * Exporting local objects , LocalObject (..) - , Member (..) , Interface (..) - , MethodCall (..) + , Member (..) , export + -- ** Responding to method calls + , MethodCall (..) , replyReturn , replyError @@ -53,19 +63,21 @@ import qualified Control.Concurrent.MVar as MV import qualified Data.Map as Map import qualified DBus.Connection as C -import qualified DBus.Constants as Const import qualified DBus.Message as M import qualified DBus.Types as T -import Data.Word (Word32) -import Data.Bits ((.|.)) - import Control.Concurrent (forkIO) import Control.Monad (forever) import qualified Data.Set as Set +import qualified DBus.Constants as Const -import Data.Maybe (isJust, fromJust, isNothing) +import Data.Maybe (isJust) +import qualified DBus.NameReservation as NR + +import qualified DBus.MatchRule as MR +import Data.Maybe (fromJust) + import qualified DBus.Introspection as I import qualified Data.Text.Lazy as TL @@ -73,133 +85,105 @@ type Callback = (M.ReceivedMessage -> IO ()) -data Client = Client C.Connection +data Client = Client C.Connection T.BusName (MV.MVar (Map.Map M.Serial Callback)) (MV.MVar (Map.Map T.ObjectPath Callback)) (MV.MVar [Callback]) clientConnection :: Client -> C.Connection -clientConnection (Client x _ _ _) = x +clientConnection (Client x _ _ _ _) = x -mkClient :: IO (C.Connection, T.BusName) -> IO Client -mkClient getBus = do - (c, _) <- getBus +clientName :: Client -> T.BusName +clientName (Client _ x _ _ _) = x + +mkClient :: (C.Connection, T.BusName) -> IO Client +mkClient (c, name) = do replies <- MV.newMVar Map.empty exports <- MV.newMVar Map.empty signals <- MV.newMVar [] - let client = Client c replies exports signals + let client = Client c name replies exports signals forkIO $ forever (receiveMessages client) export client (T.mkObjectPath' "/") rootObject return client -send' :: M.Message a => C.Connection -> (M.Serial -> IO b) -> a - -> IO b -send' c f msg = C.send c f msg >>= \result -> case result of - Left x -> error $ show x - Right x -> return x - -data RequestNameFlag - = AllowReplacement - | ReplaceExisting - | DoNotQueue - deriving (Show) - -data RequestNameReply - = PrimaryOwner - | InQueue - | Exists - | AlreadyOwner - deriving (Show) - -data ReleaseNameReply - = Released - | NonExistent - | NotOwner - deriving (Show) - -dbus :: Proxy -dbus = Proxy (RemoteObject Const.dbusName Const.dbusPath) Const.dbusInterface - -request, release :: T.MemberName -request = T.mkMemberName' "RequestName" -release = T.mkMemberName' "ReleaseName" +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 -requestName :: Client -> T.BusName -> [RequestNameFlag] -> IO RequestNameReply -requestName client name flags = do - returned <- callBlocking client dbus request [] - [ T.toVariant name - , T.toVariant . encodeFlags $ flags] - - let reply = M.messageBody returned !! 0 - case decodeRequestReply =<< T.fromVariant reply of - Just x -> return x - Nothing -> error $ "Unknown request name reply: " ++ - show reply +sendOnly :: M.Message a => Client -> a -> IO () +sendOnly c = send c (const $ return ()) -releaseName :: Client -> T.BusName -> IO ReleaseNameReply -releaseName client name = do - returned <- callBlocking client dbus release [] [T.toVariant name] +call :: Client -> M.MethodCall + -> (M.Error -> IO ()) + -> (M.MethodReturn -> IO ()) + -> IO () +call client msg onError onReturn = send client addCallback msg where + Client _ _ mvar _ _ = client + addCallback s = MV.modifyMVar_ mvar $ return . Map.insert s callback - let reply = M.messageBody returned !! 0 - case decodeReleaseReply =<< T.fromVariant reply of - Just x -> return x - Nothing -> error $ "Unknown release name reply: " ++ - show reply + callback (M.ReceivedError _ _ msg') = onError msg' + callback (M.ReceivedMethodReturn _ _ msg') = onReturn msg' + callback _ = return () -encodeFlags :: [RequestNameFlag] -> Word32 -encodeFlags = foldr (.|.) 0 . map flagValue where - flagValue AllowReplacement = 0x1 - flagValue ReplaceExisting = 0x2 - flagValue DoNotQueue = 0x4 +callBlocking :: Client -> M.MethodCall -> IO (Either M.Error M.MethodReturn) +callBlocking client msg = do + mvar <- MV.newEmptyMVar + call client msg + (MV.putMVar mvar . Left) + (MV.putMVar mvar . Right) + MV.takeMVar mvar -decodeRequestReply :: Word32 -> Maybe RequestNameReply -decodeRequestReply 1 = Just PrimaryOwner -decodeRequestReply 2 = Just InQueue -decodeRequestReply 3 = Just Exists -decodeRequestReply 4 = Just AlreadyOwner -decodeRequestReply _ = Nothing +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 -decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply -decodeReleaseReply 1 = Just Released -decodeReleaseReply 2 = Just NonExistent -decodeReleaseReply 3 = Just NotOwner -decodeReleaseReply _ = Nothing +emitSignal :: Client -> M.Signal -> IO () +emitSignal = sendOnly receiveMessages :: Client -> IO () -receiveMessages client@(Client c _ _ _) = do - received <- C.receive c - msg <- case received of +receiveMessages client = do + received <- C.receive $ clientConnection client + case received of Left x -> error $ show x - Right x -> return x - case msg of - (M.ReceivedMethodCall _ _ _ ) -> gotMethodCall client msg - (M.ReceivedMethodReturn _ _ msg') -> gotReply client (M.methodReturnSerial msg') msg - (M.ReceivedError _ _ msg') -> gotReply client (M.errorSerial msg') msg - (M.ReceivedSignal _ _ _ ) -> gotSignal client msg - _ -> return () + Right x -> handleMessage client x -gotMethodCall :: Client -> M.ReceivedMessage -> IO () -gotMethodCall client@(Client _ _ mvar _) msg = do +handleMessage :: Client -> M.ReceivedMessage -> IO () +handleMessage client msg@(M.ReceivedMethodCall _ _ call') = do + let Client _ _ _ mvar _ = client objects <- MV.readMVar mvar - let M.ReceivedMethodCall _ _ call' = msg case Map.lookup (M.methodCallPath call') objects of Just x -> x msg Nothing -> unknownMethod client msg +handleMessage c msg@(M.ReceivedMethodReturn _ _ msg') = + gotReply c (M.methodReturnSerial msg') msg +handleMessage c msg@(M.ReceivedError _ _ msg') = + gotReply c (M.errorSerial msg') msg + +handleMessage c msg@(M.ReceivedSignal _ _ _) = let + Client _ _ _ _ mvar = c + in MV.withMVar mvar $ mapM_ (\cb -> forkIO (cb msg)) + +handleMessage _ _ = return () + unknownMethod :: Client -> M.ReceivedMessage -> IO () -unknownMethod client msg = send' c (const $ return ()) errorMsg where +unknownMethod client msg = sendOnly client errorMsg where M.ReceivedMethodCall serial sender _ = msg - c = clientConnection client errorMsg = M.Error Const.errorUnknownMethod serial sender - (Set.fromList [M.NoReplyExpected, M.NoAutoStart]) [] gotReply :: Client -> M.Serial -> M.ReceivedMessage -> IO () -gotReply (Client _ mvar _ _) serial msg = do +gotReply (Client _ _ mvar _ _) serial msg = do callback <- MV.modifyMVar mvar $ \callbacks -> let x = Map.lookup serial callbacks callbacks' = if isJust x @@ -210,71 +194,79 @@ Just x -> forkIO (x msg) >> return () Nothing -> return () -gotSignal :: Client -> M.ReceivedMessage -> IO () -gotSignal (Client _ _ _ mvar) msg = MV.withMVar mvar $ - mapM_ (\cb -> forkIO (cb msg)) +requestName :: Client -> T.BusName -> [NR.RequestNameFlag] + -> IO NR.RequestNameReply +requestName client name flags = do + reply <- callBlocking' client $ NR.requestName name flags + case NR.mkRequestNameReply reply of + Nothing -> error $ "Invalid reply to RequestName" + Just x -> return x -onSignal :: Client - -> (T.BusName -> M.Signal -> Bool) - -> (T.BusName -> M.Signal -> IO ()) - -> IO () -onSignal (Client _ _ _ mvar) test callback = MV.modifyMVar_ mvar addCallback where - addCallback callbacks = return $ callback' : callbacks - callback' (M.ReceivedSignal _ sender msg) = - if test (fromJust sender) msg - then callback (fromJust sender) msg - else return () - callback' _ = undefined +releaseName :: Client -> T.BusName -> IO NR.ReleaseNameReply +releaseName client name = do + reply <- callBlocking' client $ NR.releaseName name + case NR.mkReleaseNameReply reply of + Nothing -> error $ "Invalid reply to ReleaseName" + Just x -> return x -signalFilter :: Maybe T.BusName -> Maybe T.ObjectPath -> Maybe T.InterfaceName - -> Maybe T.MemberName -> T.BusName -> M.Signal -> Bool -signalFilter sender path iface member sender' msg = all id - [ isNothing sender || sender == Just sender' - , isNothing path || path == Just (M.signalPath msg) - , isNothing iface || iface == Just (M.signalInterface msg) - , isNothing member || member == Just (M.signalMember msg) - ] +onSignal :: Client -> MR.MatchRule + -> (T.BusName -> M.Signal -> IO ()) + -> IO () +onSignal client rule callback = let + (Client _ _ _ _ mvar) = client + rule' = rule { MR.matchType = Just MR.Signal } + + callback' msg@(M.ReceivedSignal _ sender signal) + | MR.matches rule' msg = callback (fromJust sender) signal + callback' _ = return () + + in do + callBlocking' client $ MR.addMatch rule' + MV.modifyMVar_ mvar $ return . (callback' :) data RemoteObject = RemoteObject T.BusName T.ObjectPath data Proxy = Proxy RemoteObject T.InterfaceName -call :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] - -> (M.Error -> IO ()) - -> (M.MethodReturn -> IO ()) - -> IO () -call client proxy name flags body onError onReturn = let +buildMethodCall :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] + -> M.MethodCall +buildMethodCall proxy name flags body = msg where Proxy (RemoteObject dest path) iface = proxy - Client bus mvar _ _ = client msg = M.MethodCall path name (Just iface) (Just dest) - (Set.fromList flags) - body - - callback (M.ReceivedError _ _ z) = onError z - callback (M.ReceivedMethodReturn _ _ z) = onReturn z - callback _ = undefined - - addCallback s = MV.modifyMVar_ mvar $ \callbacks -> - return $ Map.insert s callback callbacks - in send' bus addCallback msg + (Set.fromList flags) body -callBlocking :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] - -> IO M.MethodReturn -callBlocking client proxy name flags body = do - mvar <- MV.newEmptyMVar - call client proxy name flags body - (MV.putMVar mvar . Left) - (MV.putMVar mvar . Right) - reply <- MV.takeMVar mvar - case reply of - Left x -> error (show x) - Right x -> return x +callProxy :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] + -> (M.Error -> IO ()) + -> (M.MethodReturn -> IO ()) + -> IO () +callProxy client proxy name flags body onError onReturn = let + msg = buildMethodCall proxy name flags body + in call client msg onError onReturn +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] + -> [T.Variant] + -> IO M.MethodReturn +callProxyBlocking' client proxy name flags body = + callBlocking' client $ buildMethodCall proxy name flags body + onSignalFrom :: Client -> Proxy -> T.MemberName -> (M.Signal -> IO ()) -> IO () -onSignalFrom client proxy member io = onSignal client test io' where +onSignalFrom client proxy member io = onSignal client rule io' where Proxy (RemoteObject dest path) iface = proxy - test = signalFilter (Just dest) (Just path) (Just iface) - (Just member) + rule = MR.MatchRule + { MR.matchType = Nothing + , MR.matchSender = Just dest + , MR.matchInterface = Just iface + , MR.matchMember = Just member + , MR.matchPath = Just path + , MR.matchDestination = Nothing + , MR.matchParameters = [] + } io' _ msg = io msg rootObject :: LocalObject @@ -290,7 +282,7 @@ path = T.mkObjectPath' "/" impl = Method inSig outSig $ \call' -> do - let Client _ _ mvar _ = methodCallClient call' + let Client _ _ _ mvar _ = methodCallClient call' paths <- fmap Map.keys $ MV.readMVar mvar let paths' = filter (/= path) paths @@ -305,7 +297,7 @@ | Signal T.Signature export :: Client -> T.ObjectPath -> LocalObject -> IO () -export client@(Client _ _ mvar _) path obj = MV.modifyMVar_ mvar $ +export client@(Client _ _ _ mvar _) path obj = MV.modifyMVar_ mvar $ return . Map.insert path (onMethodCall client (addIntrospectable path obj)) addIntrospectable :: T.ObjectPath -> LocalObject -> LocalObject @@ -380,22 +372,19 @@ replyReturn :: MethodCall -> [T.Variant] -> IO () replyReturn call' body = reply where - c = clientConnection . methodCallClient $ call' replyInvalid = M.Error Const.errorFailed (methodCallSerial call') (methodCallSender call') - (Set.fromList [M.NoReplyExpected, M.NoAutoStart]) [T.toVariant $ TL.pack "Method return didn't match signature."] replyValid = M.MethodReturn (methodCallSerial call') (methodCallSender call') - (Set.fromList [M.NoReplyExpected, M.NoAutoStart]) body sendReply :: M.Message a => a -> IO () - sendReply = send' c (const $ return ()) + sendReply = sendOnly (methodCallClient call') sigStr = TL.concat . map (T.typeCode . T.variantType) $ body (Method _ outSig _) = methodCallMethod call' @@ -404,12 +393,11 @@ else sendReply replyInvalid replyError :: MethodCall -> T.ErrorName -> [T.Variant] -> IO () -replyError call' name body = send' c (const $ return ()) reply where - c = clientConnection . methodCallClient $ call' +replyError call' name body = sendOnly c reply where + c = methodCallClient call' reply = M.Error name (methodCallSerial call') (methodCallSender call') - (Set.fromList [M.NoReplyExpected, M.NoAutoStart]) body