{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2009-2012 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 . -- | D-Bus clients are an abstraction over the lower-level messaging -- system. When combined with an external daemon called the \"bus\", clients -- can perform remote procedure calls to other clients on the bus. -- -- Clients may also listen for or emit /signals/, which are asynchronous -- broadcast notifications. -- -- Example: connect to the session bus, and get a list of active names. -- -- @ --{-\# LANGUAGE OverloadedStrings \#-} -- --import Data.List (sort) --import DBus --import DBus.Client -- --main = do -- client <- 'connectSession' -- // -- \-- Request a list of connected clients from the bus -- reply <- 'call_' client ('methodCall' \"\/org\/freedesktop\/DBus\" \"org.freedesktop.DBus\" \"ListNames\") -- { 'methodCallDestination' = Just \"org.freedesktop.DBus\" -- } -- // -- \-- org.freedesktop.DBus.ListNames() returns a single value, which is -- \-- a list of names (here represented as [String]) -- let Just names = 'fromVariant' ('methodReturnBody' reply !! 0) -- // -- \-- Print each name on a line, sorted so reserved names are below -- \-- temporary names. -- mapM_ putStrLn (sort names) -- @ -- module DBus.Client ( -- * Clients Client -- * Connecting to a bus , connect , connectSystem , connectSession , connectStarter , disconnect -- * Sending method calls , call , call_ , callNoReply -- * Receiving method calls , export , unexport , Method , method , Reply , replyReturn , replyError , throwError -- ** Automatic method signatures , AutoMethod , autoMethod -- * Signals , SignalHandler , addMatch , removeMatch , emit , listen -- ** Match rules , MatchRule , formatMatchRule , matchAny , matchSender , matchDestination , matchPath , matchInterface , matchMember , matchPathNamespace -- * Name reservation , requestName , releaseName , RequestNameFlag , nameAllowReplacement , nameReplaceExisting , nameDoNotQueue , RequestNameReply(NamePrimaryOwner, NameInQueue, NameExists, NameAlreadyOwner) , ReleaseNameReply(NameReleased, NameNonExistent, NameNotOwner) -- * Client errors , ClientError , clientError , clientErrorMessage , clientErrorFatal -- * Advanced connection options , ClientOptions , clientSocketOptions , clientThreadRunner , defaultClientOptions , connectWith ) where import Control.Concurrent import Control.Exception (SomeException, throwIO) import qualified Control.Exception import Control.Monad (forever, forM_, when) import Data.Bits ((.|.)) import Data.IORef import Data.List (foldl', intercalate, isPrefixOf) import qualified Data.Map import Data.Map (Map) import Data.Maybe (catMaybes, listToMaybe) import Data.Typeable (Typeable) import Data.Unique import Data.Word (Word32) import Data.Function import DBus import qualified DBus.Introspection as I import qualified DBus.Socket import DBus.Transport (TransportOpen, SocketTransport) data ClientError = ClientError { clientErrorMessage :: String , clientErrorFatal :: Bool } deriving (Eq, Show, Typeable) instance Control.Exception.Exception ClientError clientError :: String -> ClientError clientError msg = ClientError msg True -- | An active client session to a message bus. Clients may send or receive -- method calls, and listen for or emit signals. data Client = Client { clientSocket :: DBus.Socket.Socket , clientPendingCalls :: IORef (Map Serial (MVar (Either MethodError MethodReturn))) , clientSignalHandlers :: IORef (Map Unique SignalHandler) , clientObjects :: IORef (Map ObjectPath ObjectInfo) , clientThreadID :: ThreadId } data ClientOptions t = ClientOptions { -- | Options for the underlying socket, for advanced use cases. See -- the "DBus.Socket" module. clientSocketOptions :: DBus.Socket.SocketOptions t -- | A function to run the client thread. The provided IO computation -- should be called repeatedly; each time it is called, it will process -- one incoming message. -- -- The provided computation will throw a 'ClientError' if it fails to -- process an incoming message, or if the connection is lost. -- -- The default implementation is 'forever'. , clientThreadRunner :: IO () -> IO () } type Callback = (ReceivedMessage -> IO ()) type FormattedMatchRule = String data SignalHandler = SignalHandler Unique FormattedMatchRule (IORef Bool) (Signal -> IO ()) data Reply = ReplyReturn [Variant] | ReplyError ErrorName [Variant] -- | Reply to a method call with a successful return, containing the given body. replyReturn :: [Variant] -> Reply replyReturn = ReplyReturn -- | Reply to a method call with an error, containing the given error name and -- body. -- -- Typically, the first item of the error body is a string with a message -- describing the error. replyError :: ErrorName -> [Variant] -> Reply replyError = ReplyError data Method = Method InterfaceName MemberName Signature Signature (MethodCall -> IO Reply) type ObjectInfo = Map InterfaceName InterfaceInfo type InterfaceInfo = Map MemberName MethodInfo data MethodInfo = MethodInfo Signature Signature Callback -- | Connect to the bus specified in the environment variable -- @DBUS_SYSTEM_BUS_ADDRESS@, or to -- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@ -- is not set. -- -- Throws a 'ClientError' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid -- address, or if connecting to the bus failed. connectSystem :: IO Client connectSystem = do env <- getSystemAddress case env of Nothing -> throwIO (clientError "connectSystem: DBUS_SYSTEM_BUS_ADDRESS is invalid.") Just addr -> connect addr -- | Connect to the bus specified in the environment variable -- @DBUS_SESSION_BUS_ADDRESS@, which must be set. -- -- Throws a 'ClientError' if @DBUS_SESSION_BUS_ADDRESS@ is unset, contains an -- invalid address, or if connecting to the bus failed. connectSession :: IO Client connectSession = do env <- getSessionAddress case env of Nothing -> throwIO (clientError "connectSession: DBUS_SESSION_BUS_ADDRESS is missing or invalid.") Just addr -> connect addr -- | Connect to the bus specified in the environment variable -- @DBUS_STARTER_ADDRESS@, which must be set. -- -- Throws a 'ClientError' if @DBUS_STARTER_ADDRESS@ is unset, contains an -- invalid address, or if connecting to the bus failed. connectStarter :: IO Client connectStarter = do env <- getStarterAddress case env of Nothing -> throwIO (clientError "connectStarter: DBUS_STARTER_ADDRESS is missing or invalid.") Just addr -> connect addr -- | Connect to the bus at the specified address. -- -- Throws a 'ClientError' on failure. connect :: Address -> IO Client connect = connectWith defaultClientOptions -- | Connect to the bus at the specified address, with the given connection -- options. Most users should use 'connect' instead. -- -- Throws a 'ClientError' on failure. connectWith :: TransportOpen t => ClientOptions t -> Address -> IO Client connectWith opts addr = do sock <- DBus.Socket.openWith (clientSocketOptions opts) addr pendingCalls <- newIORef Data.Map.empty signalHandlers <- newIORef Data.Map.empty objects <- newIORef Data.Map.empty let threadRunner = clientThreadRunner opts clientMVar <- newEmptyMVar threadID <- forkIO $ do client <- readMVar clientMVar threadRunner (mainLoop client) let client = Client { clientSocket = sock , clientPendingCalls = pendingCalls , clientSignalHandlers = signalHandlers , clientObjects = objects , clientThreadID = threadID } putMVar clientMVar client export client "/" [introspectRoot client] callNoReply client (methodCall dbusPath dbusInterface "Hello") { methodCallDestination = Just dbusName } return client -- | Default client options. Uses the built-in Socket-based transport, which -- supports the @tcp:@ and @unix:@ methods. defaultClientOptions :: ClientOptions SocketTransport defaultClientOptions = ClientOptions { clientSocketOptions = DBus.Socket.defaultSocketOptions , clientThreadRunner = forever } -- | Stop a 'Client''s callback thread and close its underlying socket. disconnect :: Client -> IO () disconnect client = do killThread (clientThreadID client) disconnect' client disconnect' :: Client -> IO () disconnect' client = do pendingCalls <- atomicModifyIORef (clientPendingCalls client) (\p -> (Data.Map.empty, p)) forM_ (Data.Map.toList pendingCalls) $ \(k, v) -> do putMVar v (Left (methodError k errorDisconnected)) atomicWriteIORef (clientSignalHandlers client) Data.Map.empty atomicWriteIORef (clientObjects client) Data.Map.empty DBus.Socket.close (clientSocket client) mainLoop :: Client -> IO () mainLoop client = do let sock = clientSocket client received <- Control.Exception.try (DBus.Socket.receive sock) msg <- case received of Left err -> do disconnect' client throwIO (clientError (DBus.Socket.socketErrorMessage err)) Right msg -> return msg dispatch client msg dispatch :: Client -> ReceivedMessage -> IO () dispatch client = go where go (ReceivedMethodReturn _ msg) = dispatchReply (methodReturnSerial msg) (Right msg) go (ReceivedMethodError _ msg) = dispatchReply (methodErrorSerial msg) (Left msg) go (ReceivedSignal _ msg) = do handlers <- readIORef (clientSignalHandlers client) forM_ (Data.Map.toAscList handlers) (\(_, SignalHandler _ _ _ h) -> forkIO (h msg) >> return ()) go received@(ReceivedMethodCall serial msg) = do objects <- readIORef (clientObjects client) let sender = methodCallSender msg _ <- forkIO $ case findMethod objects msg of Right io -> io received Left errName -> send_ client (methodError serial errName) { methodErrorDestination = sender } (\_ -> return ()) return () go _ = return () dispatchReply serial result = do pending <- atomicModifyIORef (clientPendingCalls client) (\p -> case Data.Map.lookup serial p of Nothing -> (p, Nothing) Just mvar -> (Data.Map.delete serial p, Just mvar)) case pending of Just mvar -> putMVar mvar result Nothing -> return () data RequestNameFlag = AllowReplacement | ReplaceExisting | DoNotQueue deriving (Eq, Show) -- | Allow this client's reservation to be replaced, if another client -- requests it with the 'nameReplaceExisting' flag. -- -- If this client's reservation is replaced, this client will be added to the -- wait queue unless the request also included the 'nameDoNotQueue' flag. nameAllowReplacement :: RequestNameFlag nameAllowReplacement = AllowReplacement -- | If the name being requested is already reserved, attempt to replace it. -- This only works if the current owner provided the 'nameAllowReplacement' -- flag. nameReplaceExisting :: RequestNameFlag nameReplaceExisting = ReplaceExisting -- | If the name is already in use, do not add this client to the queue, just -- return an error. nameDoNotQueue :: RequestNameFlag nameDoNotQueue = DoNotQueue data RequestNameReply -- | This client is now the primary owner of the requested name. = NamePrimaryOwner -- | The name was already reserved by another client, and replacement -- was either not attempted or not successful. | NameInQueue -- | The name was already reserved by another client, 'DoNotQueue' -- was set, and replacement was either not attempted or not -- successful. | NameExists -- | This client is already the primary owner of the requested name. | NameAlreadyOwner -- | Not exported; exists to generate a compiler warning if users -- case on the reply and forget to include a default case. | UnknownRequestNameReply Word32 deriving (Eq, Show) data ReleaseNameReply -- | This client has released the provided name. = NameReleased -- | The provided name is not assigned to any client on the bus. | NameNonExistent -- | The provided name is not assigned to this client. | NameNotOwner -- | Not exported; exists to generate a compiler warning if users -- case on the reply and forget to include a default case. | UnknownReleaseNameReply Word32 deriving (Eq, Show) encodeFlags :: [RequestNameFlag] -> Word32 encodeFlags = foldr (.|.) 0 . map flagValue where flagValue AllowReplacement = 0x1 flagValue ReplaceExisting = 0x2 flagValue DoNotQueue = 0x4 -- | Asks the message bus to assign the given name to this client. The bus -- maintains a queue of possible owners, where the head of the queue is the -- current (\"primary\") owner. -- -- There are several uses for name reservation: -- -- * Clients which export methods reserve a name so users and applications -- can send them messages. For example, the GNOME Keyring reserves the name -- @\"org.gnome.keyring\"@ on the user's session bus, and NetworkManager -- reserves @\"org.freedesktop.NetworkManager\"@ on the system bus. -- -- * When there are multiple implementations of a particular service, the -- service standard will ususally include a generic bus name for the -- service. This allows other clients to avoid depending on any particular -- implementation's name. For example, both the GNOME Keyring and KDE -- KWallet services request the @\"org.freedesktop.secrets\"@ name on the -- user's session bus. -- -- * A process with \"single instance\" behavior can use name assignment to -- check whether the instance is already running, and invoke some method -- on it (e.g. opening a new window). -- -- Throws a 'ClientError' if the call failed. requestName :: Client -> BusName -> [RequestNameFlag] -> IO RequestNameReply requestName client name flags = do reply <- call_ client (methodCall dbusPath dbusInterface "RequestName") { methodCallDestination = Just dbusName , methodCallBody = [toVariant name, toVariant (encodeFlags flags)] } var <- case listToMaybe (methodReturnBody reply) of Just x -> return x Nothing -> throwIO (clientError "requestName: received empty response") { clientErrorFatal = False } code <- case fromVariant var of Just x -> return x Nothing -> throwIO (clientError ("requestName: received invalid response code " ++ showsPrec 11 var "")) { clientErrorFatal = False } return $ case code :: Word32 of 1 -> NamePrimaryOwner 2 -> NameInQueue 3 -> NameExists 4 -> NameAlreadyOwner _ -> UnknownRequestNameReply code -- | Release a name that this client previously requested. See 'requestName' -- for an explanation of name reservation. -- -- Throws a 'ClientError' if the call failed. releaseName :: Client -> BusName -> IO ReleaseNameReply releaseName client name = do reply <- call_ client (methodCall dbusPath dbusInterface "ReleaseName") { methodCallDestination = Just dbusName , methodCallBody = [toVariant name] } var <- case listToMaybe (methodReturnBody reply) of Just x -> return x Nothing -> throwIO (clientError "releaseName: received empty response") { clientErrorFatal = False } code <- case fromVariant var of Just x -> return x Nothing -> throwIO (clientError ("releaseName: received invalid response code " ++ showsPrec 11 var "")) { clientErrorFatal = False } return $ case code :: Word32 of 1 -> NameReleased 2 -> NameNonExistent 3 -> NameNotOwner _ -> UnknownReleaseNameReply code send_ :: Message msg => Client -> msg -> (Serial -> IO a) -> IO a send_ client msg io = do result <- Control.Exception.try (DBus.Socket.send (clientSocket client) msg io) case result of Right x -> return x Left err -> throwIO (clientError (DBus.Socket.socketErrorMessage err)) { clientErrorFatal = DBus.Socket.socketErrorFatal err } -- | Send a method call to the bus, and wait for the response. -- -- Throws a 'ClientError' if the method call couldn't be sent, or if the reply -- couldn't be parsed. call :: Client -> MethodCall -> IO (Either MethodError MethodReturn) call client msg = do -- If ReplyExpected is False, this function would block indefinitely -- if the remote side honors it. let safeMsg = msg { methodCallReplyExpected = True } mvar <- newEmptyMVar let ref = clientPendingCalls client serial <- send_ client safeMsg (\serial -> atomicModifyIORef ref (\p -> (Data.Map.insert serial mvar p, serial))) -- At this point, we wait for the reply to arrive. The user may cancel -- a pending call by sending this thread an exception via something -- like 'timeout'; in that case, we want to clean up the pending call. Control.Exception.onException (takeMVar mvar) (atomicModifyIORef_ ref (Data.Map.delete serial)) -- | Send a method call to the bus, and wait for the response. -- -- Unsets the 'noReplyExpected' message flag before sending. -- -- Throws a 'ClientError' if the method call couldn't sent, if the reply -- couldn't be parsed, or if the reply was a 'MethodError'. call_ :: Client -> MethodCall -> IO MethodReturn call_ client msg = do result <- call client msg case result of Left err -> throwIO (clientError ("Call failed: " ++ methodErrorMessage err)) { clientErrorFatal = methodErrorName err == errorDisconnected } Right ret -> return ret -- | Send a method call to the bus, and do not wait for a response. -- -- Sets the 'noReplyExpected' message flag before sending. -- -- Throws a 'ClientError' if the method call couldn't be sent. callNoReply :: Client -> MethodCall -> IO () callNoReply client msg = do -- Ensure that noReplyExpected is always set. let safeMsg = msg { methodCallReplyExpected = False } send_ client safeMsg (\_ -> return ()) -- | Request that the bus forward signals matching the given rule to this -- client, and process them in a callback. -- -- A received signal might be processed by more than one callback at a time. -- Callbacks each run in their own thread. -- -- The returned 'SignalHandler' can be passed to 'removeMatch' -- to stop handling this signal. -- -- Throws a 'ClientError' if the match rule couldn't be added to the bus. addMatch :: Client -> MatchRule -> (Signal -> IO ()) -> IO SignalHandler addMatch client rule io = do let formatted = case formatMatchRule rule of "" -> "type='signal'" x -> "type='signal'," ++ x handlerId <- newUnique registered <- newIORef True let handler = SignalHandler handlerId formatted registered (\msg -> when (checkMatchRule rule msg) (io msg)) atomicModifyIORef (clientSignalHandlers client) (\hs -> (Data.Map.insert handlerId handler hs, ())) _ <- call_ client (methodCall dbusPath dbusInterface "AddMatch") { methodCallDestination = Just dbusName , methodCallBody = [toVariant formatted] } return handler -- | Request that the bus stop forwarding signals for the given handler. -- -- Throws a 'ClientError' if the match rule couldn't be removed from the bus. removeMatch :: Client -> SignalHandler -> IO () removeMatch client (SignalHandler handlerId formatted registered _) = do shouldUnregister <- atomicModifyIORef registered (\wasRegistered -> (False, wasRegistered)) when shouldUnregister $ do atomicModifyIORef (clientSignalHandlers client) (\hs -> (Data.Map.delete handlerId hs, ())) _ <- call_ client (methodCall dbusPath dbusInterface "RemoveMatch") { methodCallDestination = Just dbusName , methodCallBody = [toVariant formatted] } return () -- | Equivalent to 'addMatch', but does not return the added 'SignalHandler'. listen :: Client -> MatchRule -> (Signal -> IO ()) -> IO () listen client rule io = addMatch client rule io >> return () {-# DEPRECATED listen "Prefer DBus.Client.addMatch in new code." #-} -- | Emit the signal on the bus. -- -- Throws a 'ClientError' if the signal message couldn't be sent. emit :: Client -> Signal -> IO () emit client msg = send_ client msg (\_ -> return ()) -- | A match rule describes which signals a particular callback is interested -- in. Use 'matchAny' to construct match rules. -- -- Example: a match rule which matches signals sent by the root object. -- -- @ --matchFromRoot :: MatchRule --matchFromRoot = 'matchAny' { 'matchPath' = Just \"/\" } -- @ data MatchRule = MatchRule { -- | If set, only receives signals sent from the given bus name. -- -- The standard D-Bus implementation from -- almost always sets signal senders to the unique name of the sending -- client. If 'matchSender' is a requested name like -- @\"com.example.Foo\"@, it will not match any signals. -- -- The exception is for signals sent by the bus itself, which always -- have a sender of @\"org.freedesktop.DBus\"@. matchSender :: Maybe BusName -- | If set, only receives signals sent to the given bus name. , matchDestination :: Maybe BusName -- | If set, only receives signals sent with the given path. , matchPath :: Maybe ObjectPath -- | If set, only receives signals sent with the given interface name. , matchInterface :: Maybe InterfaceName -- | If set, only receives signals sent with the given member name. , matchMember :: Maybe MemberName -- | If set, only receives signals sent with the given path or any of -- its children. , matchPathNamespace :: Maybe ObjectPath } instance Show MatchRule where showsPrec d rule = showParen (d > 10) (showString "MatchRule " . shows (formatMatchRule rule)) -- | Convert a match rule into the textual format accepted by the bus. formatMatchRule :: MatchRule -> String formatMatchRule rule = intercalate "," predicates where predicates = catMaybes [ f "sender" matchSender formatBusName , f "destination" matchDestination formatBusName , f "path" matchPath formatObjectPath , f "interface" matchInterface formatInterfaceName , f "member" matchMember formatMemberName , f "path_namespace" matchPathNamespace formatObjectPath ] f :: String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String f key get text = do val <- fmap text (get rule) return (concat [key, "='", val, "'"]) -- | Match any signal. matchAny :: MatchRule matchAny = MatchRule Nothing Nothing Nothing Nothing Nothing Nothing checkMatchRule :: MatchRule -> Signal -> Bool checkMatchRule rule msg = and [ maybe True (\x -> signalSender msg == Just x) (matchSender rule) , maybe True (\x -> signalDestination msg == Just x) (matchDestination rule) , maybe True (== signalPath msg) (matchPath rule) , maybe True (== signalInterface msg) (matchInterface rule) , maybe True (== signalMember msg) (matchMember rule) , maybe True (`pathPrefix` signalPath msg) (matchPathNamespace rule) ] where pathPrefix = isPrefixOf `on` formatObjectPath data MethodExc = MethodExc ErrorName [Variant] deriving (Show, Eq, Typeable) instance Control.Exception.Exception MethodExc -- | Normally, any exceptions raised while executing a method will be -- given the generic @\"org.freedesktop.DBus.Error.Failed\"@ name. -- 'throwError' allows the programmer to specify an error name, and provide -- additional information to the remote application. You may use this instead -- of 'Control.Exception.throwIO' to abort a method call. throwError :: ErrorName -> String -- ^ Error message -> [Variant] -- ^ Additional items of the error body -> IO a throwError name message extra = Control.Exception.throwIO (MethodExc name (toVariant message : extra)) -- | Define a method handler, which will accept method calls with the given -- interface and member name. -- -- Note that the input and output parameter signatures are used for -- introspection, but are not checked when executing a method. -- -- See 'autoMethod' for an easier way to export functions with simple -- parameter and return types. method :: InterfaceName -> MemberName -> Signature -- ^ Input parameter signature -> Signature -- ^ Output parameter signature -> (MethodCall -> IO Reply) -> Method method iface name inSig outSig io = Method iface name inSig outSig (\msg -> Control.Exception.catch (Control.Exception.catch (io msg) (\(MethodExc name' vs') -> return (ReplyError name' vs'))) (\exc -> return (ReplyError errorFailed [toVariant (show (exc :: SomeException))]))) -- | Export the given functions under the given 'ObjectPath' and -- 'InterfaceName'. -- -- Use 'autoMethod' to construct a 'Method' from a function that accepts and -- returns simple types. -- -- Use 'method' to construct a 'Method' from a function that handles parameter -- conversion manually. -- -- @ --ping :: MethodCall -> IO 'Reply' --ping _ = replyReturn [] -- --sayHello :: String -> IO String --sayHello name = return (\"Hello \" ++ name ++ \"!\") -- --export client \"/hello_world\" -- [ 'method' \"com.example.HelloWorld\" \"Ping\" ping -- , 'autoMethod' \"com.example.HelloWorld\" \"Hello\" sayHello -- ] -- @ export :: Client -> ObjectPath -> [Method] -> IO () export client path methods = atomicModifyIORef (clientObjects client) addObject where addObject objs = (Data.Map.insert path info objs, ()) info = foldl' addMethod Data.Map.empty (defaultIntrospect : methods) addMethod m (Method iface name inSig outSig cb) = Data.Map.insertWith' Data.Map.union iface (Data.Map.fromList [(name, MethodInfo inSig outSig (wrapCB cb))]) m wrapCB cb (ReceivedMethodCall serial msg) = do reply <- cb msg let sender = methodCallSender msg case reply of ReplyReturn vs -> send_ client (methodReturn serial) { methodReturnDestination = sender , methodReturnBody = vs } (\_ -> return ()) ReplyError name vs -> send_ client (methodError serial name) { methodErrorDestination = sender , methodErrorBody = vs } (\_ -> return ()) wrapCB _ _ = return () defaultIntrospect = methodIntrospect $ do objects <- readIORef (clientObjects client) let Just obj = Data.Map.lookup path objects return (introspect path obj) -- | Revokes the export of the given 'ObjectPath'. This will remove all -- interfaces and methods associated with the path. unexport :: Client -> ObjectPath -> IO () unexport client path = atomicModifyIORef (clientObjects client) deleteObject where deleteObject objs = (Data.Map.delete path objs, ()) findMethod :: Map ObjectPath ObjectInfo -> MethodCall -> Either ErrorName Callback findMethod objects msg = case Data.Map.lookup (methodCallPath msg) objects of Nothing -> Left errorUnknownObject Just obj -> case methodCallInterface msg of Nothing -> let members = do iface <- Data.Map.elems obj case Data.Map.lookup (methodCallMember msg) iface of Just member -> [member] Nothing -> [] in case members of [MethodInfo _ _ io] -> Right io _ -> Left errorUnknownMethod Just ifaceName -> case Data.Map.lookup ifaceName obj of Nothing -> Left errorUnknownInterface Just iface -> case Data.Map.lookup (methodCallMember msg) iface of Just (MethodInfo _ _ io) -> Right io _ -> Left errorUnknownMethod introspectRoot :: Client -> Method introspectRoot client = methodIntrospect $ do objects <- readIORef (clientObjects client) let paths = filter (/= "/") (Data.Map.keys objects) return (I.object "/") { I.objectInterfaces = [ (I.interface interfaceIntrospectable) { I.interfaceMethods = [ (I.method "Introspect") { I.methodArgs = [ I.methodArg "" TypeString I.directionOut ] } ] } ] , I.objectChildren = [I.object p | p <- paths] } methodIntrospect :: IO I.Object -> Method methodIntrospect get = method interfaceIntrospectable "Introspect" "" "s" $ \msg -> case methodCallBody msg of [] -> do obj <- get let Just xml = I.formatXML obj return (replyReturn [toVariant xml]) _ -> return (replyError errorInvalidParameters []) introspect :: ObjectPath -> ObjectInfo -> I.Object introspect path obj = (I.object path) { I.objectInterfaces = interfaces } where interfaces = map introspectIface (Data.Map.toList obj) introspectIface (name, iface) = (I.interface name) { I.interfaceMethods = concatMap introspectMethod (Data.Map.toList iface) } args inSig outSig = map (introspectArg I.directionIn) (signatureTypes inSig) ++ map (introspectArg I.directionOut) (signatureTypes outSig) introspectMethod (name, MethodInfo inSig outSig _) = [ (I.method name) { I.methodArgs = args inSig outSig } ] introspectArg dir t = I.methodArg "" t dir -- | Used to automatically generate method signatures for introspection -- documents. To support automatic signatures, a method's parameters and -- return value must all be instances of 'IsValue'. -- -- This class maps Haskell idioms to D-Bus; it is therefore unable to -- generate some signatures. In particular, it does not support methods -- which accept/return a single structure, or single-element structures. -- It also cannot generate signatures for methods with parameters or return -- values which are only instances of 'IsVariant'. For these cases, please -- use 'DBus.Client.method'. -- -- To match common Haskell use, if the return value is a tuple, it will be -- converted to a list of return values. class AutoMethod a where funTypes :: a -> ([Type], [Type]) apply :: a -> [Variant] -> Maybe (IO [Variant]) instance AutoMethod (IO ()) where funTypes _ = ([], []) apply io [] = Just (io >> return []) apply _ _ = Nothing instance IsValue a => AutoMethod (IO a) where funTypes io = cased where cased = ([], case ioT io undefined of (_, t) -> case t of TypeStructure ts -> ts _ -> [t]) ioT :: IsValue a => IO a -> a -> (a, Type) ioT _ a = (a, typeOf a) apply io [] = Just (do var <- fmap toVariant io case fromVariant var of Just struct -> return (structureItems struct) Nothing -> return [var]) apply _ _ = Nothing instance (IsValue a, AutoMethod fn) => AutoMethod (a -> fn) where funTypes fn = cased where cased = case valueT undefined of (a, t) -> case funTypes (fn a) of (ts, ts') -> (t : ts, ts') valueT :: IsValue a => a -> (a, Type) valueT a = (a, typeOf a) apply _ [] = Nothing apply fn (v:vs) = case fromVariant v of Just v' -> apply (fn v') vs Nothing -> Nothing -- | Prepare a Haskell function for export, automatically detecting the -- function's type signature. -- -- See 'AutoMethod' for details on the limitations of this function. -- -- See 'method' for exporting functions with user-defined types. autoMethod :: (AutoMethod fn) => InterfaceName -> MemberName -> fn -> Method autoMethod iface name fun = DBus.Client.method iface name inSig outSig io where (typesIn, typesOut) = funTypes fun inSig = case signature typesIn of Just sig -> sig Nothing -> invalid "input" outSig = case signature typesOut of Just sig -> sig Nothing -> invalid "output" io msg = case apply fun (methodCallBody msg) of Nothing -> return (ReplyError errorInvalidParameters []) Just io' -> fmap ReplyReturn io' invalid label = error (concat [ "Method " , formatInterfaceName iface , "." , formatMemberName name , " has an invalid " , label , " signature."]) errorFailed :: ErrorName errorFailed = errorName_ "org.freedesktop.DBus.Error.Failed" errorDisconnected :: ErrorName errorDisconnected = errorName_ "org.freedesktop.DBus.Error.Disconnected" errorUnknownObject :: ErrorName errorUnknownObject = errorName_ "org.freedesktop.DBus.Error.UnknownObject" errorUnknownInterface :: ErrorName errorUnknownInterface = errorName_ "org.freedesktop.DBus.Error.UnknownInterface" errorUnknownMethod :: ErrorName errorUnknownMethod = errorName_ "org.freedesktop.DBus.Error.UnknownMethod" errorInvalidParameters :: ErrorName errorInvalidParameters = errorName_ "org.freedesktop.DBus.Error.InvalidParameters" dbusName :: BusName dbusName = busName_ "org.freedesktop.DBus" dbusPath :: ObjectPath dbusPath = objectPath_ "/org/freedesktop/DBus" dbusInterface :: InterfaceName dbusInterface = interfaceName_ "org.freedesktop.DBus" interfaceIntrospectable :: InterfaceName interfaceIntrospectable = interfaceName_ "org.freedesktop.DBus.Introspectable" atomicModifyIORef_ :: IORef a -> (a -> a) -> IO () atomicModifyIORef_ ref fn = atomicModifyIORef ref (\x -> (fn x, ())) #if !MIN_VERSION_base(4,6,0) atomicWriteIORef :: IORef a -> a -> IO () atomicWriteIORef ref x = atomicModifyIORef ref (\_ -> (x, ())) #endif