dbus-client 0.1 → 0.2
raw patch · 4 files changed
+414/−368 lines, 4 filesdep ~dbus-core
Dependency ranges changed: dbus-core
Files
- Makefile +1/−1
- dbus-client.cabal +2/−2
- dbus-client.nw +256/−198
- hs/DBus/Client.hs +155/−167
Makefile view
@@ -15,4 +15,4 @@ xelatex "$<" xelatex "$<" -pdfs: dbus-client.pdf manual.pdf+pdfs: dbus-client.pdf #manual.pdf
dbus-client.cabal view
@@ -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
dbus-client.nw view
@@ -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. +<<DBus/Client.hs>>=+<<copyright>>+{-# LANGUAGE OverloadedStrings #-}+module DBus.Client+ ( <<exports>>+ ) where+<<imports>>++@ All source code is licensed under the terms of the GNU GPL v3 or later.+ <<copyright>>= {- Copyright (C) 2009 John Millikin <jmillikin@gmail.com>@@ -63,174 +73,155 @@ along with this program. If not, see <http://www.gnu.org/licenses/>. -} - @ \section{Clients} -<<DBus/Client.hs>>=-<<copyright>>-{-# LANGUAGE OverloadedStrings #-}-module DBus.Client- ( <<exports>>- ) where-<<imports>>+The {\tt Client} type provides an opaque handle to internal client state,+including callback registration and the open connection. <<imports>>= 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 <<DBus/Client.hs>>= 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.++<<DBus/Client.hs>>= clientConnection :: Client -> C.Connection-clientConnection (Client x _ _ _) = x+clientConnection (Client x _ _ _ _) = x +clientName :: Client -> T.BusName+clientName (Client _ x _ _ _) = x+ <<exports>>=+ -- * 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.+ <<DBus/Client.hs>>=-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 <<initialize client>> return client <<exports>>= , mkClient -<<DBus/Client.hs>>=-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. <<DBus/Client.hs>>=-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 -<<DBus/Client.hs>>=-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. <<DBus/Client.hs>>=-data ReleaseNameReply- = Released- | NonExistent- | NotOwner- deriving (Show)--<<exports>>=-, 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/Client.hs>>=-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. <<DBus/Client.hs>>=-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. <<DBus/Client.hs>>=-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--<<exports>>=-, 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. <<DBus/Client.hs>>=-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 <<exports>>=-, releaseName+ -- ** Sending messages+, call+, callBlocking+, callBlocking' -<<imports>>=-import Data.Word (Word32)-import Data.Bits ((.|.))+@ \subsubsection{Emitting signals} -<<DBus/Client.hs>>=-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. <<DBus/Client.hs>>=-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 -<<DBus/Client.hs>>=-decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply-decodeReleaseReply 1 = Just Released-decodeReleaseReply 2 = Just NonExistent-decodeReleaseReply 3 = Just NotOwner-decodeReleaseReply _ = Nothing+<<exports>>=+ -- *** 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 <<initialize client>>= forkIO $ forever (receiveMessages client) +@ FIXME: does raising an exception here cause the thread to terminate?+ <<DBus/Client.hs>>= 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 <<DBus/Client.hs>>=-gotMethodCall :: Client -> M.ReceivedMessage -> IO ()-gotMethodCall client@(Client _ _ mvar _) msg = do+handleMessage :: Client -> M.ReceivedMessage -> IO ()+<<message handlers>>+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.++<<message handlers>>=+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 <<DBus/Client.hs>>= 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. +<<message handlers>>=+handleMessage c msg@(M.ReceivedMethodReturn _ _ msg') =+ gotReply c (M.methodReturnSerial msg') msg+handleMessage c msg@(M.ReceivedError _ _ msg') =+ gotReply c (M.errorSerial msg') msg+ <<imports>>=-import Data.Maybe (isJust, fromJust, isNothing)+import Data.Maybe (isJust) <<DBus/Client.hs>>= 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.++<<message 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.++<<imports>>=+import qualified DBus.NameReservation as NR+ <<DBus/Client.hs>>=-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. <<DBus/Client.hs>>=-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 +<<exports>>=+ -- * 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.++<<imports>>=+import qualified DBus.MatchRule as MR+import Data.Maybe (fromJust)+ <<DBus/Client.hs>>=-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' :) <<exports>>=+ -- * Receiving signals , onSignal-, signalFilter @-\section{Remote object proxies}+\section{Remote objects and proxies} +TODO: document this section+ <<exports>>=+ -- * Remote objects and proxies , RemoteObject (..) , Proxy (..)-, call-, callBlocking-, onSignalFrom <<DBus/Client.hs>>= data RemoteObject = RemoteObject T.BusName T.ObjectPath@@ -349,52 +394,67 @@ @ \subsection{Method calls} <<DBus/Client.hs>>=-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 <<DBus/Client.hs>>=-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 +<<DBus/Client.hs>>=+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++<<DBus/Client.hs>>=+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++<<exports>>=+, callProxy+, callProxyBlocking+, callProxyBlocking'+ @ \subsection{Signals} <<DBus/Client.hs>>= 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 +<<exports>>=+, onSignalFrom+ @ \section{Exporting local objects} +FIXME: the introspection stuff is \emph{really} ugly.+ <<imports>>= 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] <<exports>>=+ -- * Exporting local objects , LocalObject (..)-, Member (..) , Interface (..)-, MethodCall (..)+, Member (..) , export <<imports>>=@@ -442,7 +502,7 @@ <<DBus/Client.hs>>= 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)) <<DBus/Client.hs>>=@@ -529,22 +589,19 @@ <<DBus/Client.hs>>= 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 @@ <<DBus/Client.hs>>= 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 <<exports>>=+ -- ** Responding to method calls+, MethodCall (..) , replyReturn , replyError
hs/DBus/Client.hs view
@@ -15,37 +15,47 @@ along with this program. If not, see <http://www.gnu.org/licenses/>. -} - {-# 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