module DBus.Client
(
Client
, connect
, connectSystem
, connectSession
, connectStarter
, disconnect
, call
, call_
, callNoReply
, export
, unexport
, Method
, method
, Reply
, replyReturn
, replyError
, throwError
, AutoMethod
, autoMethod
, SignalHandler
, addMatch
, removeMatch
, emit
, listen
, MatchRule
, formatMatchRule
, matchAny
, matchSender
, matchDestination
, matchPath
, matchInterface
, matchMember
, matchPathNamespace
, requestName
, releaseName
, RequestNameFlag
, nameAllowReplacement
, nameReplaceExisting
, nameDoNotQueue
, RequestNameReply(NamePrimaryOwner, NameInQueue, NameExists, NameAlreadyOwner)
, ReleaseNameReply(NameReleased, NameNonExistent, NameNotOwner)
, ClientError
, clientError
, clientErrorMessage
, clientErrorFatal
, 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
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
{
clientSocketOptions :: DBus.Socket.SocketOptions t
, 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]
replyReturn :: [Variant] -> Reply
replyReturn = ReplyReturn
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
connectSystem :: IO Client
connectSystem = do
env <- getSystemAddress
case env of
Nothing -> throwIO (clientError "connectSystem: DBUS_SYSTEM_BUS_ADDRESS is invalid.")
Just addr -> connect addr
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
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 :: Address -> IO Client
connect = connectWith defaultClientOptions
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
defaultClientOptions :: ClientOptions SocketTransport
defaultClientOptions = ClientOptions
{ clientSocketOptions = DBus.Socket.defaultSocketOptions
, clientThreadRunner = forever
}
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)
nameAllowReplacement :: RequestNameFlag
nameAllowReplacement = AllowReplacement
nameReplaceExisting :: RequestNameFlag
nameReplaceExisting = ReplaceExisting
nameDoNotQueue :: RequestNameFlag
nameDoNotQueue = DoNotQueue
data RequestNameReply
= NamePrimaryOwner
| NameInQueue
| NameExists
| NameAlreadyOwner
| UnknownRequestNameReply Word32
deriving (Eq, Show)
data ReleaseNameReply
= NameReleased
| NameNonExistent
| NameNotOwner
| UnknownReleaseNameReply Word32
deriving (Eq, Show)
encodeFlags :: [RequestNameFlag] -> Word32
encodeFlags = foldr (.|.) 0 . map flagValue where
flagValue AllowReplacement = 0x1
flagValue ReplaceExisting = 0x2
flagValue DoNotQueue = 0x4
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
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
}
call :: Client -> MethodCall -> IO (Either MethodError MethodReturn)
call client msg = do
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)))
Control.Exception.onException
(takeMVar mvar)
(atomicModifyIORef_ ref (Data.Map.delete serial))
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
callNoReply :: Client -> MethodCall -> IO ()
callNoReply client msg = do
let safeMsg = msg
{ methodCallReplyExpected = False
}
send_ client safeMsg (\_ -> return ())
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
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 ()
listen :: Client -> MatchRule -> (Signal -> IO ()) -> IO ()
listen client rule io = addMatch client rule io >> return ()
emit :: Client -> Signal -> IO ()
emit client msg = send_ client msg (\_ -> return ())
data MatchRule = MatchRule
{
matchSender :: Maybe BusName
, matchDestination :: Maybe BusName
, matchPath :: Maybe ObjectPath
, matchInterface :: Maybe InterfaceName
, matchMember :: Maybe MemberName
, matchPathNamespace :: Maybe ObjectPath
}
instance Show MatchRule where
showsPrec d rule = showParen (d > 10) (showString "MatchRule " . shows (formatMatchRule rule))
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, "'"])
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
throwError :: ErrorName
-> String
-> [Variant]
-> IO a
throwError name message extra = Control.Exception.throwIO (MethodExc name (toVariant message : extra))
method :: InterfaceName
-> MemberName
-> Signature
-> 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 :: 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)
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
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
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