module DBus.Client
(
Client
, connect
, connectSystem
, connectSession
, connectStarter
, disconnect
, call
, call_
, callNoReply
, export
, Method
, method
, Reply
, replyReturn
, replyError
, throwError
, AutoMethod
, autoMethod
, listen
, emit
, MatchRule
, formatMatchRule
, matchAny
, matchSender
, matchDestination
, matchPath
, matchInterface
, matchMember
, requestName
, releaseName
, RequestNameFlag
, nameAllowReplacement
, nameReplaceExisting
, nameDoNotQueue
, RequestNameReply(NamePrimaryOwner, NameInQueue, NameExists, NameAlreadyOwner)
, ReleaseNameReply(NameReleased, NameNonExistent, NameNotOwner)
, ClientError
, clientError
, clientErrorMessage
, clientErrorFatal
, ClientOptions
, clientSocketOptions
, 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)
import qualified Data.Map
import Data.Map (Map)
import Data.Maybe (catMaybes, listToMaybe)
import Data.Typeable (Typeable)
import Data.Word (Word32)
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 [Signal -> IO ()]
, clientObjects :: IORef (Map ObjectPath ObjectInfo)
, clientThreadID :: ThreadId
}
data ClientOptions t = ClientOptions
{
clientSocketOptions :: DBus.Socket.SocketOptions t
}
type Callback = (ReceivedMessage -> 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 []
objects <- newIORef Data.Map.empty
clientMVar <- newEmptyMVar
threadID <- forkIO $ do
client <- readMVar clientMVar
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
}
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))
atomicModifyIORef (clientSignalHandlers client) (\_ -> ([], ()))
atomicModifyIORef (clientObjects client) (\_ -> (Data.Map.empty, ()))
DBus.Socket.close (clientSocket client)
mainLoop :: Client -> IO ()
mainLoop client = forever $ 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_ handlers (\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 serial -> return serial
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
send_ client safeMsg (\serial -> do
let ref = clientPendingCalls client
addMVarFinalizer mvar (atomicModifyIORef ref (\p -> (Data.Map.delete serial p, ())))
atomicModifyIORef ref (\p -> (Data.Map.insert serial mvar p, ())))
takeMVar mvar
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 ())
listen :: Client -> MatchRule -> (Signal -> IO ()) -> IO ()
listen client rule io = do
let handler msg = when (checkMatchRule rule msg) (io msg)
let formatted = case formatMatchRule rule of
"" -> "type='signal'"
x -> "type='signal'," ++ x
atomicModifyIORef (clientSignalHandlers client) (\hs -> (handler : hs, ()))
_ <- call_ client (methodCall dbusPath dbusInterface "AddMatch")
{ methodCallDestination = Just dbusName
, methodCallBody = [toVariant formatted]
}
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
}
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 :: 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
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)
]
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)
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"