{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -- Copyright (C) 2009-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. -- | 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(..) , DBusR -- * Path/Interface storage , PathInfo(..) , pathInterfaces , pathChildren , pathLens , findPath , Interface(..) , defaultInterface -- * Connecting to a bus , connect , connectSystem , connectSession , connectStarter , disconnect -- * Sending method calls , call , call_ , callNoReply , getProperty , getPropertyValue , setProperty , setPropertyValue , getAllProperties , getAllPropertiesMap , buildPropertiesInterface -- * Receiving method calls , export , unexport , Method(..) , makeMethod , AutoMethod , autoMethod , autoMethodWithMsg , Property(..) , autoProperty , readOnlyProperty , Reply(..) , throwError -- * Signals , SignalHandler , addMatch , removeMatch , emit , listen -- ** Match rules , MatchRule , formatMatchRule , matchAny , matchSender , matchDestination , matchPath , matchInterface , matchMember , matchPathNamespace -- * Introspection , buildIntrospectionObject , buildIntrospectionInterface , buildIntrospectionMethod , buildIntrospectionProperty , buildIntrospectableInterface -- * Name reservation , requestName , releaseName , RequestNameFlag , nameAllowReplacement , nameReplaceExisting , nameDoNotQueue , RequestNameReply(..) , ReleaseNameReply(..) -- * Client errors , ClientError , clientError , clientErrorMessage , clientErrorFatal -- * Advanced connection options , ClientOptions , clientSocketOptions , clientThreadRunner , defaultClientOptions , connectWith , connectWithName , dbusName , dbusPath , ErrorName , errorFailed , errorInvalidParameters , errorUnknownMethod ) where import Control.Applicative import Control.Arrow import Control.Concurrent import qualified Control.Exception import Control.Exception (SomeException, throwIO) import Control.Lens import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Control.Monad.Trans.Except import Data.Bits ((.|.)) import Data.Coerce import Data.Foldable hiding (forM_, and) import Data.Function import Data.Functor ((<$>)) import Data.IORef import Data.List (intercalate, isPrefixOf) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid import Data.String import qualified Data.Traversable as T import Data.Typeable (Typeable, Proxy(..)) import Data.Unique import Data.Word (Word32) import Prelude hiding (foldl, foldr, concat) import DBus import DBus.Internal.Message import qualified DBus.Internal.Types as T import qualified DBus.Introspection.Types as I import qualified DBus.Introspection.Render 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 PathInfo , clientThreadID :: ThreadId , clientInterfaces :: [Interface] } type DBusR a = ReaderT Client IO a 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 () -- | A function to build the interfaces that should be present at every -- point where there is an object present. The default value builds the -- property and introspection interfaces. , clientBuildInterfaces :: Client -> [Interface] } type FormattedMatchRule = String data SignalHandler = SignalHandler Unique FormattedMatchRule (IORef Bool) (Signal -> IO ()) data Method = Method { methodName :: MemberName , inSignature :: Signature , outSignature :: Signature , methodHandler :: MethodCall -> DBusR Reply } data Property = Property { propertyName :: MemberName , propertyType :: Type , propertyGetter :: Maybe (IO Variant) , propertySetter :: Maybe (Variant -> IO ()) } data Reply = ReplyReturn [Variant] | ReplyError ErrorName [Variant] data Interface = Interface { interfaceName :: InterfaceName , interfaceMethods :: [Method] , interfaceProperties :: [Property] , interfaceSignals :: [I.Signal] } defaultInterface :: Interface defaultInterface = Interface { interfaceName = "" , interfaceMethods = [] , interfaceProperties = [] , interfaceSignals = [] } data PathInfo = PathInfo { _pathInterfaces :: [Interface] , _pathChildren :: Map String PathInfo } -- NOTE: This instance is needed to make modifyNothingHandler work, but it -- shouldn't really be used for much else. A more complete implementation can't -- be provided because PathInfo > Interface > Method conatain functions which -- can't/don't have an eq instance. instance Eq PathInfo where a == b = null (_pathInterfaces a) && null (_pathInterfaces b) && M.null (_pathChildren a) && M.null (_pathChildren b) makeLenses ''PathInfo emptyPathInfo :: PathInfo emptyPathInfo = PathInfo { _pathInterfaces = [] , _pathChildren = M.empty } traverseElement :: Applicative f => (a -> Maybe PathInfo -> f (Maybe PathInfo)) -> String -> a -> PathInfo -> f PathInfo traverseElement nothingHandler pathElement = pathChildren . at pathElement . nothingHandler lookupNothingHandler :: (a -> Const (Data.Monoid.First PathInfo) b) -> Maybe a -> Const (Data.Monoid.First PathInfo) (Maybe b) lookupNothingHandler = _Just modifyNothingHandler :: (PathInfo -> Identity PathInfo) -> Maybe PathInfo -> Identity (Maybe PathInfo) modifyNothingHandler = non emptyPathInfo pathLens :: Applicative f => ObjectPath -> ((PathInfo -> f PathInfo) -> Maybe PathInfo -> f (Maybe PathInfo)) -> (PathInfo -> f PathInfo) -> PathInfo -> f PathInfo pathLens path nothingHandler = foldl (\f pathElem -> f . traverseElement nothingHandler pathElem) id $ T.pathElements path modifyPathInfoLens :: ObjectPath -> (PathInfo -> Identity PathInfo) -> PathInfo -> Identity PathInfo modifyPathInfoLens path = pathLens path modifyNothingHandler modifyPathInterfacesLens :: ObjectPath -> ([Interface] -> Identity [Interface]) -> PathInfo -> Identity PathInfo modifyPathInterfacesLens path = modifyPathInfoLens path . pathInterfaces addInterface :: ObjectPath -> Interface -> PathInfo -> PathInfo addInterface path interface = over (modifyPathInterfacesLens path) (interface :) findPath :: ObjectPath -> PathInfo -> Maybe PathInfo findPath path = preview (pathLens path lookupNothingHandler) findByGetterAndName :: (Coercible a2 a1, Eq a1, Foldable t) => t a3 -> (a3 -> a2) -> a1 -> Maybe a3 findByGetterAndName options getter name = find ((== name) . coerce . getter) options findInterface :: [Interface] -> InterfaceName -> PathInfo -> Maybe Interface findInterface alwaysPresent (T.InterfaceName name) info = findByGetterAndName (_pathInterfaces info ++ alwaysPresent) interfaceName name findMethod :: MemberName -> Interface -> Maybe Method findMethod (T.MemberName name) interface = findByGetterAndName (interfaceMethods interface) methodName name findProperty :: MemberName -> Interface -> Maybe Property findProperty (T.MemberName name) interface = findByGetterAndName (interfaceProperties interface) propertyName name -- | 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 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 client <- connectWith' opts addr callNoReply client (methodCall dbusPath dbusInterface "Hello") { methodCallDestination = Just dbusName } return client -- | Connect to the bus at the specified address, with the given connection -- options, and return the unique client bus name. Most users should use -- 'connect' or 'connectWith' instead. -- -- Throws a 'ClientError' on failure. connectWithName :: TransportOpen t => ClientOptions t -> Address -> IO (Client, BusName) connectWithName opts addr = do client <- connectWith' opts addr reply <- call_ client (methodCall dbusPath dbusInterface "Hello") { methodCallDestination = Just dbusName } case methodReturnBody reply of [name] | Just nameStr <- fromVariant name -> do busName <- parseBusName nameStr return (client, busName) _ -> throwIO (clientError "connectWithName: Hello response did not contain client name.") connectWith' :: TransportOpen t => ClientOptions t -> Address -> IO Client connectWith' opts addr = do sock <- DBus.Socket.openWith (clientSocketOptions opts) addr pendingCalls <- newIORef M.empty signalHandlers <- newIORef M.empty objects <- newIORef $ PathInfo [] M.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 , clientInterfaces = clientBuildInterfaces opts client } putMVar clientMVar client return client makeErrorReply :: ErrorName -> Reply makeErrorReply errorName = ReplyError errorName [] buildPropertiesInterface :: Client -> Interface buildPropertiesInterface client = let alwaysPresent = clientInterfaces client getPropertyObjF propertyInterfaceName memberName path info = findInterfaceAtPath alwaysPresent info path (Just $ fromString propertyInterfaceName) >>= (maybeToEither errorUnknownMethod . findProperty (fromString memberName)) getPropertyObj propertyInterfaceName memberName path = getPropertyObjF propertyInterfaceName memberName path <$> readIORef (clientObjects client) callGet MethodCall { methodCallPath = path } propertyInterfaceName memberName = left makeErrorReply <$> runExceptT (do property <- ExceptT $ getPropertyObj propertyInterfaceName memberName path ExceptT $ sequenceA $ maybeToEither errorNotAuthorized $ propertyGetter property) callSet MethodCall { methodCallPath = path } propertyInterfaceName memberName value = left makeErrorReply <$> runExceptT (do property <- ExceptT $ getPropertyObj propertyInterfaceName memberName path setter <- ExceptT $ return $ maybeToEither errorNotAuthorized $ propertySetter property lift $ setter value) callGetAll MethodCall { methodCallPath = path } propertyInterfaceName = left makeErrorReply <$> runExceptT (do info <- lift $ readIORef (clientObjects client) propertyInterface <- ExceptT $ return $ findInterfaceAtPath alwaysPresent info path $ Just $ fromString propertyInterfaceName let properties = interfaceProperties propertyInterface nameGetters :: [IO (String, Variant)] nameGetters = [ (coerce name,) <$> getter | Property { propertyName = name , propertyGetter = Just getter } <- properties] lift $ M.fromList <$> T.sequenceA nameGetters) in defaultInterface { interfaceName = propertiesInterfaceName , interfaceMethods = [ autoMethodWithMsg "Get" callGet , autoMethodWithMsg "GetAll" callGetAll , autoMethodWithMsg "Set" callSet ] , interfaceSignals = [ I.Signal { I.signalName = "PropertiesChanged" , I.signalArgs = [ I.SignalArg { I.signalArgName = "interface_name" , I.signalArgType = T.TypeString } , I.SignalArg { I.signalArgName = "changed_properties" , I.signalArgType = T.TypeDictionary T.TypeString T.TypeVariant } , I.SignalArg { I.signalArgName = "invalidated_properties" , I.signalArgType = T.TypeArray T.TypeString } ] } ] } buildIntrospectableInterface :: Client -> Interface buildIntrospectableInterface client = defaultInterface { interfaceName = introspectableInterfaceName , interfaceMethods = [ autoMethodWithMsg "Introspect" callIntrospect ] } where callIntrospect MethodCall { methodCallPath = path } = do info <- readIORef (clientObjects client) return $ left makeErrorReply $ do targetInfo <- maybeToEither errorUnknownObject $ findPath path info -- TODO: We should probably return a better error here: maybeToEither errorUnknownObject $ I.formatXML $ buildIntrospectionObject defaultInterfaces targetInfo (T.pathElements path) defaultInterfaces = map buildIntrospectionInterface $ clientInterfaces 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 , clientBuildInterfaces = \client -> map ($ client) [buildPropertiesInterface, buildIntrospectableInterface] } -- | 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 -> (M.empty, p)) forM_ (M.toList pendingCalls) $ \(k, v) -> putMVar v (Left (methodError k errorDisconnected)) atomicWriteIORef (clientSignalHandlers client) M.empty atomicWriteIORef (clientObjects client) emptyPathInfo 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 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_ (M.toAscList handlers) (\(_, SignalHandler _ _ _ h) -> forkIO $ void $ h msg) go (ReceivedMethodCall serial msg) = do pathInfo <- readIORef (clientObjects client) let sender = methodCallSender msg sendResult reply = 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 ()) _ <- forkIO $ case findMethodForCall (clientInterfaces client) pathInfo msg of Right Method { methodHandler = handler } -> runReaderT (handler msg) client >>= sendResult Left errName -> send_ client (methodError serial errName) { methodErrorDestination = sender } (\_ -> return ()) return () go _ = return () dispatchReply serial result = do pending <- atomicModifyIORef (clientPendingCalls client) (\p -> case M.lookup serial p of Nothing -> (p, Nothing) Just mvar -> (M.delete serial p, Just mvar)) case pending of Just mvar -> putMVar mvar result Nothing -> return () findInterfaceAtPath :: [Interface] -> PathInfo -> ObjectPath -> Maybe InterfaceName -> Either ErrorName Interface findInterfaceAtPath defaultInterfaces info path name = maybeToEither errorUnknownObject (findPath path info) >>= (maybeToEither errorUnknownInterface . maybe (const Nothing) (findInterface defaultInterfaces) name) findMethodForCall :: [Interface] -> PathInfo -> MethodCall -> Either ErrorName Method findMethodForCall defaultInterfaces info MethodCall { methodCallInterface = interface , methodCallMember = member , methodCallPath = path } = findInterfaceAtPath defaultInterfaces info path interface >>= (maybeToEither errorUnknownMethod . findMethod member) -- Request name 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 ((.|.) . flagValue) 0 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 -- Requests 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 -> (M.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 (M.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 ()) orDefaultInterface :: Maybe InterfaceName -> InterfaceName orDefaultInterface = fromMaybe "org.freedesktop.DBus" dummyMethodError :: MethodError dummyMethodError = MethodError { methodErrorName = errorName_ "org.ClientTypeMismatch" , methodErrorSerial = T.Serial 1 , methodErrorSender = Nothing , methodErrorDestination = Nothing , methodErrorBody = [] } unpackVariant :: IsValue a => MethodCall -> Variant -> Either MethodError a unpackVariant MethodCall { methodCallSender = sender } variant = maybeToEither dummyMethodError { methodErrorBody = [variant, toVariant $ show $ variantType variant] , methodErrorSender = sender } $ fromVariant variant -- | Retrieve a property using the method call parameters that were provided. -- -- Throws a 'ClientError' if the property request couldn't be sent. getProperty :: Client -> MethodCall -> IO (Either MethodError Variant) getProperty client msg@MethodCall { methodCallInterface = interface , methodCallMember = member } = (>>= (unpackVariant msg . head . methodReturnBody)) <$> call client msg { methodCallInterface = Just propertiesInterfaceName , methodCallMember = getMemberName , methodCallBody = [ toVariant (coerce (orDefaultInterface interface) :: String) , toVariant (coerce member :: String) ] } getPropertyValue :: IsValue a => Client -> MethodCall -> IO (Either MethodError a) getPropertyValue client msg = (>>= unpackVariant msg) <$> getProperty client msg setProperty :: Client -> MethodCall -> Variant -> IO (Either MethodError MethodReturn) setProperty client msg@MethodCall { methodCallInterface = interface , methodCallMember = member } value = call client msg { methodCallInterface = Just propertiesInterfaceName , methodCallMember = setMemberName , methodCallBody = [ toVariant (coerce (orDefaultInterface interface) :: String) , toVariant (coerce member :: String) , value ] } setPropertyValue :: IsValue a => Client -> MethodCall -> a -> IO (Maybe MethodError) setPropertyValue client msg v = eitherToMaybe <$> setProperty client msg (toVariant v) where eitherToMaybe (Left a) = Just a eitherToMaybe (Right _) = Nothing getAllProperties :: Client -> MethodCall -> IO (Either MethodError MethodReturn) getAllProperties client msg@MethodCall { methodCallInterface = interface } = call client msg { methodCallInterface = Just propertiesInterfaceName , methodCallMember = getAllMemberName , methodCallBody = [toVariant (coerce (orDefaultInterface interface) :: String)] } getAllPropertiesMap :: Client -> MethodCall -> IO (Either MethodError (M.Map String Variant)) getAllPropertiesMap client msg = -- NOTE: We should never hit the error case here really unless the client -- returns the wrong type of object. (>>= (maybeToEither dummyMethodError . fromVariant . head . methodReturnBody)) <$> getAllProperties client msg -- Signals -- | 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 -> (M.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 -> (M.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 = void $ addMatch client rule io {-# 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)) -- Method construction returnInvalidParameters :: Monad m => m Reply returnInvalidParameters = return $ ReplyError errorInvalidParameters [] -- | 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] -> DBusR Reply handleTopLevelReturn :: IsVariant a => a -> [Variant] handleTopLevelReturn value = case toVariant value of T.Variant (T.ValueStructure xs) -> fmap T.Variant xs v -> [v] instance IsValue a => AutoMethod (IO a) where funTypes io = funTypes (lift io :: DBusR a) apply io = apply (lift io :: DBusR a) instance IsValue a => AutoMethod (DBusR a) where funTypes _ = ([], outTypes) where aType :: Type aType = typeOf' (Proxy :: Proxy a) outTypes = case aType of TypeStructure ts -> ts _ -> [aType] apply io [] = ReplyReturn . handleTopLevelReturn <$> io apply _ _ = returnInvalidParameters instance IsValue a => AutoMethod (IO (Either Reply a)) where funTypes io = funTypes (lift io :: DBusR (Either Reply a)) apply io = apply (lift io :: DBusR (Either Reply a)) instance IsValue a => AutoMethod (DBusR (Either Reply a)) where funTypes _ = ([], outTypes) where aType :: Type aType = typeOf' (Proxy :: Proxy a) outTypes = case aType of TypeStructure ts -> ts _ -> [aType] apply io [] = either id (ReplyReturn . handleTopLevelReturn) <$> io apply _ _ = returnInvalidParameters 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 _ [] = returnInvalidParameters apply fn (v:vs) = case fromVariant v of Just v' -> apply (fn v') vs Nothing -> returnInvalidParameters -- | 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) => MemberName -> fn -> Method autoMethod name fun = autoMethodWithMsg name $ const fun autoMethodWithMsg :: (AutoMethod fn) => MemberName -> (MethodCall -> fn) -> Method autoMethodWithMsg name fun = makeMethod name inSig outSig io where (typesIn, typesOut) = funTypes (fun undefined) inSig = fromMaybe (invalid "input") $ signature typesIn outSig = fromMaybe (invalid "output") $ signature typesOut io msg = apply (fun msg) (methodCallBody msg) invalid label = error (concat [ "Method " , "." , formatMemberName name , " has an invalid " , label , " signature."]) autoProperty :: forall v. (IsValue v) => MemberName -> Maybe (IO v) -> Maybe (v -> IO ()) -> Property autoProperty name mgetter msetter = Property name propType (fmap toVariant <$> mgetter) (variantSetter <$> msetter) where propType = typeOf' (Proxy :: Proxy v) variantSetter setter = let newFun variant = maybe (return ()) setter (fromVariant variant) in newFun readOnlyProperty :: (IsValue v) => MemberName -> IO v -> Property readOnlyProperty name getter = autoProperty name (Just getter) Nothing -- | 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. makeMethod :: MemberName -> Signature -- ^ Input parameter signature -> Signature -- ^ Output parameter signature -> (MethodCall -> DBusR Reply) -> Method makeMethod name inSig outSig io = Method name inSig outSig (\msg -> do fromReader <- ask lift $ Control.Exception.catch (Control.Exception.catch (runReaderT (io msg) fromReader) (\(MethodExc name' vs') -> return (ReplyError name' vs'))) (\exc -> return (ReplyError errorFailed [toVariant (show (exc :: SomeException))]))) -- | Export the given 'Interface' at the given 'ObjectPath' -- -- 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\" -- defaultInterface { interfaceName = \"com.example.HelloWorld\" -- , interfaceMethods = -- [ 'method' \"com.example.HelloWorld\" \"Ping\" ping -- , 'autoMethod' \"com.example.HelloWorld\" \"Hello\" sayHello -- ] -- } -- @ export :: Client -> ObjectPath -> Interface -> IO () export client path interface = atomicModifyIORef_ (clientObjects client) $ addInterface path interface -- | 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) clear where clear = over (modifyPathInterfacesLens path) $ const [] -- Introspection buildIntrospectionObject :: [I.Interface] -> PathInfo -> [String] -> I.Object buildIntrospectionObject defaultInterfaces PathInfo { _pathInterfaces = interfaces , _pathChildren = infoChildren } elems = I.Object { I.objectPath = T.fromElements elems , I.objectInterfaces = (if null interfaces then [] else defaultInterfaces) ++ map buildIntrospectionInterface interfaces -- TODO: Eventually we should support not outputting everything if there is -- a lot of stuff. , I.objectChildren = M.elems $ M.mapWithKey recurseFromString infoChildren } where recurseFromString stringNode nodeInfo = buildIntrospectionObject defaultInterfaces nodeInfo $ elems ++ [stringNode] buildIntrospectionInterface :: Interface -> I.Interface buildIntrospectionInterface Interface { interfaceName = name , interfaceMethods = methods , interfaceProperties = properties , interfaceSignals = signals } = I.Interface { I.interfaceName = name , I.interfaceMethods = map buildIntrospectionMethod methods , I.interfaceProperties = map buildIntrospectionProperty properties , I.interfaceSignals = signals } buildIntrospectionProperty :: Property -> I.Property buildIntrospectionProperty (Property memberName ptype getter setter) = I.Property { I.propertyName = coerce memberName , I.propertyType = ptype , I.propertyRead = isJust getter , I.propertyWrite = isJust setter } buildIntrospectionMethod :: Method -> I.Method buildIntrospectionMethod Method { methodName = name , inSignature = inSig , outSignature = outSig } = I.Method { I.methodName = name , I.methodArgs = zipWith makeMethodArg ['a'..'z'] $ inTuples ++ outTuples } where inTuples = map (, I.In) $ coerce inSig outTuples = map (, I.Out) $ coerce outSig makeMethodArg nameChar (t, dir) = I.MethodArg { I.methodArgName = [nameChar] , I.methodArgType = t , I.methodArgDirection = dir } -- Constants 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" errorNotAuthorized :: ErrorName errorNotAuthorized = errorName_ "org.freedesktop.DBus.Error.NotAuthorized" dbusName :: BusName dbusName = busName_ "org.freedesktop.DBus" dbusPath :: ObjectPath dbusPath = objectPath_ "/org/freedesktop/DBus" dbusInterface :: InterfaceName dbusInterface = interfaceName_ "org.freedesktop.DBus" introspectableInterfaceName :: InterfaceName introspectableInterfaceName = interfaceName_ "org.freedesktop.DBus.Introspectable" propertiesInterfaceName :: InterfaceName propertiesInterfaceName = fromString "org.freedesktop.DBus.Properties" getAllMemberName :: MemberName getAllMemberName = fromString "GetAll" getMemberName :: MemberName getMemberName = fromString "Get" setMemberName :: MemberName setMemberName = fromString "Set" -- Miscellaneous maybeToEither :: b -> Maybe a -> Either b a maybeToEither = flip maybe Right . Left atomicModifyIORef_ :: IORef a -> (a -> a) -> IO () atomicModifyIORef_ ref fn = atomicModifyIORef ref (fn &&& const ()) #if !MIN_VERSION_base(4,6,0) atomicWriteIORef :: IORef a -> a -> IO () atomicWriteIORef ref x = atomicModifyIORef ref $ const x &&& const () #endif