dbus-1.3.0: lib/DBus/Client.hs
{-# 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 <john@john-millikin.com>
--
-- 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.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 <http://dbus.freedesktop.org/>
-- 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