module DBus.Client.Internal where
import Control.Concurrent
import Control.Exception (SomeException)
import qualified Control.Exception
import Control.Monad (forever, unless)
import Data.IORef
import Data.List (foldl')
import qualified Data.Map
import Data.Map (Map)
import Data.Maybe (isJust, catMaybes)
import Data.Text (Text)
import qualified Data.Text
import Data.Typeable (Typeable)
import qualified Data.Set
import DBus.Address
import qualified DBus.Connection
import DBus.Connection (Connection)
import DBus.Connection.Authentication (external)
import DBus.Connection.Transport (unix, tcp)
import DBus.Connection.Error
import qualified DBus.Constants
import DBus.Constants ( errorFailed, errorUnknownMethod
, errorInvalidParameters)
import DBus.Message
import qualified DBus.Introspection
import DBus.Types
import DBus.Types.Internal (Signature(..))
import DBus.Util (void)
data Client = Client
{ clientConnection :: Connection
, clientCallbacks :: MVar (Map Serial Callback)
, clientSignalHandlers :: MVar [Callback]
, clientObjects :: MVar (Map ObjectPath ObjectInfo)
, clientThreadID :: ThreadId
, clientMessageProcessor :: IORef (ReceivedMessage -> IO Bool)
}
type Callback = (ReceivedMessage -> IO ())
data Reply
= ReplyReturn [Variant]
| ReplyError ErrorName [Variant]
data Method = Method InterfaceName MemberName Signature Signature ([Variant] -> IO Reply)
type ObjectInfo = Map InterfaceName InterfaceInfo
type InterfaceInfo = Map MemberName MemberInfo
data MemberInfo
= MemberMethod Signature Signature Callback
| MemberSignal Signature
attach :: Connection -> IO Client
attach connection = do
callbacks <- newMVar Data.Map.empty
signalHandlers <- newMVar []
objects <- newMVar Data.Map.empty
processor <- newIORef (\_ -> return False)
clientMVar <- newEmptyMVar
threadID <- forkIO $ do
client <- readMVar clientMVar
mainLoop client
let client = Client
{ clientConnection = connection
, clientCallbacks = callbacks
, clientSignalHandlers = signalHandlers
, clientObjects = objects
, clientThreadID = threadID
, clientMessageProcessor = processor
}
putMVar clientMVar client
export client "/" [introspectRoot client]
void (call_ client (MethodCall
{ methodCallDestination = Just "org.freedesktop.DBus"
, methodCallMember = "Hello"
, methodCallInterface = Just "org.freedesktop.DBus"
, methodCallPath = "/org/freedesktop/DBus"
, methodCallFlags = Data.Set.empty
, methodCallBody = []
}))
return client
connect :: Address -> IO Client
connect addr = do
connection <- DBus.Connection.connect [unix, tcp] [external] addr
attach connection
disconnect :: Client -> IO ()
disconnect client = do
killThread (clientThreadID client)
disconnect' client
disconnect' :: Client -> IO ()
disconnect' client = do
let connection = clientConnection client
modifyMVar_ (clientCallbacks client) (\_ -> return Data.Map.empty)
modifyMVar_ (clientSignalHandlers client) (\_ -> return [])
modifyMVar_ (clientObjects client) (\_ -> return Data.Map.empty)
DBus.Connection.disconnect connection
setMessageProcessor :: Client -> (ReceivedMessage -> IO Bool) -> IO ()
setMessageProcessor client io = atomicModifyIORef
(clientMessageProcessor client)
(\_ -> (io, ()))
mainLoop :: Client -> IO ()
mainLoop client = forever $ do
let connection = clientConnection client
received <- DBus.Connection.receive connection
msg <- case received of
Left err -> do
disconnect' client
connectionError ("Received invalid message: " ++ show err)
Right msg -> return msg
dispatch client msg
dispatch :: Client -> ReceivedMessage -> IO ()
dispatch client received = void . forkIO $ do
process <- readIORef (clientMessageProcessor client)
handled <- process received
let onReply serial = do
let mvar = clientCallbacks client
maybeCB <- modifyMVar mvar $ \callbacks -> let
x = Data.Map.lookup serial callbacks
callbacks' = if isJust x
then Data.Map.delete serial callbacks
else callbacks
in return (callbacks', x)
case maybeCB of
Just cb -> void (cb received)
Nothing -> return ()
unless handled $ case received of
(ReceivedMethodReturn _ _ msg) -> onReply (methodReturnSerial msg)
(ReceivedError _ _ msg) -> onReply (errorSerial msg)
(ReceivedSignal _ _ _) -> do
handlers <- readMVar (clientSignalHandlers client)
mapM_ ($ received) handlers
(ReceivedMethodCall serial sender msg) -> do
objects <- readMVar (clientObjects client)
case findMethod objects msg of
Just io -> io received
Nothing -> send_ client
(Error errorUnknownMethod serial sender [])
(\_ -> return ())
_ -> return ()
send_ :: Message msg => Client -> msg -> (Serial -> IO a) -> IO a
send_ client msg io = do
result <- DBus.Connection.send (clientConnection client) msg io
case result of
Right serial -> return serial
Left err -> connectionError ("Error sending message: " ++ show err)
call :: Client -> MethodCall -> IO (Either Error MethodReturn)
call client msg = do
mvar <- newEmptyMVar
let callback (ReceivedError _ _ err) = putMVar mvar (Left err)
callback (ReceivedMethodReturn _ _ reply) = putMVar mvar (Right reply)
callback _ = return ()
send_ client msg (\serial ->
modifyMVar_ (clientCallbacks client) (\callbacks ->
return (Data.Map.insert serial callback callbacks)))
tried <- Control.Exception.try (takeMVar mvar)
case tried of
#if MIN_VERSION_base(4,2,0)
Left Control.Exception.BlockedIndefinitelyOnMVar ->
#else
Left Control.Exception.BlockedOnDeadMVar ->
#endif
connectionError "DBus.Client.call: connection closed during method call"
Right ret -> return ret
call_ :: Client -> MethodCall -> IO MethodReturn
call_ client msg = do
result <- call client msg
case result of
Left err -> connectionError ("Call failed: " ++ Data.Text.unpack (errorMessage err))
Right ret -> return ret
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
}
deriving (Show)
listen :: Client -> MatchRule -> (BusName -> Signal -> IO ()) -> IO ()
listen client rule io = do
let handler (ReceivedSignal _ (Just sender) msg)
| checkMatchRule rule sender msg = io sender msg
handler _ = return ()
modifyMVar_ (clientSignalHandlers client) (\hs -> return (handler : hs))
void (call_ client (MethodCall
{ methodCallPath = DBus.Constants.dbusPath
, methodCallMember = "AddMatch"
, methodCallInterface = Just DBus.Constants.dbusInterface
, methodCallDestination = Just DBus.Constants.dbusName
, methodCallFlags = Data.Set.empty
, methodCallBody = [toVariant (formatMatchRule rule)]
}))
formatMatchRule :: MatchRule -> Text
formatMatchRule rule = Data.Text.intercalate "," predicates where
predicates = catMaybes
[ f "sender" matchSender busNameText
, f "destination" matchDestination busNameText
, f "path" matchPath objectPathText
, f "interface" matchInterface interfaceNameText
, f "member" matchMember memberNameText
]
f :: Text -> (MatchRule -> Maybe a) -> (a -> Text) -> Maybe Text
f key get text = do
val <- fmap text (get rule)
return (Data.Text.concat [key, "='", val, "'"])
checkMatchRule :: MatchRule -> BusName -> Signal -> Bool
checkMatchRule rule sender msg = and
[ maybe True (== sender) (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 MethodError = MethodError ErrorName [Variant]
deriving (Show, Eq, Typeable)
instance Control.Exception.Exception MethodError
throwError :: ErrorName -> Text -> [Variant] -> IO a
throwError name message extra = Control.Exception.throwIO (MethodError name (toVariant message : extra))
method :: InterfaceName -> MemberName -> Signature -> Signature -> ([Variant] -> IO Reply) -> Method
method iface name inSig outSig io = Method iface name inSig outSig
(\vs -> Control.Exception.catch
(Control.Exception.catch
(io vs)
(\(MethodError name' vs') -> return (ReplyError name' vs')))
(\exc -> return (ReplyError errorFailed
[toVariant (Data.Text.pack (show (exc :: SomeException)))])))
export :: Client -> ObjectPath -> [Method] -> IO ()
export client path methods = modifyMVar_ (clientObjects client) addObject where
addObject objs = return (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, MemberMethod inSig outSig (wrapCB cb))]) m
wrapCB cb (ReceivedMethodCall serial sender msg) = do
reply <- cb (methodCallBody msg)
case reply of
ReplyReturn vs -> send_ client (MethodReturn serial sender vs) (\_ -> return ())
ReplyError name vs -> send_ client (Error name serial sender vs) (\_ -> return ())
wrapCB _ _ = return ()
defaultIntrospect = methodIntrospect $ do
objects <- readMVar (clientObjects client)
let Just obj = Data.Map.lookup path objects
return (introspect path obj)
findMethod :: Map ObjectPath ObjectInfo -> MethodCall -> Maybe Callback
findMethod objects msg = do
ifaceName <- methodCallInterface msg
obj <- Data.Map.lookup (methodCallPath msg) objects
iface <- Data.Map.lookup ifaceName obj
member <- Data.Map.lookup (methodCallMember msg) iface
case member of
MemberMethod _ _ io -> return io
_ -> Nothing
introspectRoot :: Client -> Method
introspectRoot client = methodIntrospect $ do
objects <- readMVar (clientObjects client)
let paths = filter (/= "/") (Data.Map.keys objects)
let iface = "org.freedesktop.DBus.Introspectable"
let name = "Introspect"
return (DBus.Introspection.Object "/"
[DBus.Introspection.Interface iface
[DBus.Introspection.Method name
[]
[DBus.Introspection.Parameter "" "s"]]
[] []]
[DBus.Introspection.Object p [] [] | p <- paths])
methodIntrospect :: IO DBus.Introspection.Object -> Method
methodIntrospect get = method iface name "" "s" impl where
iface = "org.freedesktop.DBus.Introspectable"
name = "Introspect"
impl [] = do
obj <- get
let Just xml = DBus.Introspection.toXML obj
return (ReplyReturn [toVariant xml])
impl _ = return (ReplyError errorInvalidParameters [])
introspect :: ObjectPath -> ObjectInfo -> DBus.Introspection.Object
introspect path obj = DBus.Introspection.Object path interfaces [] where
interfaces = map introspectIface (Data.Map.toList obj)
introspectIface (name, iface) = let
members = Data.Map.toList iface
methods = concatMap introspectMethod members
signals = concatMap introspectSignal members
in DBus.Introspection.Interface name methods signals []
introspectMethod (name, (MemberMethod inSig outSig _)) =
[DBus.Introspection.Method name
(map introspectParam (signatureTypes inSig))
(map introspectParam (signatureTypes outSig))]
introspectMethod _ = []
introspectSignal (name, (MemberSignal sig)) =
[DBus.Introspection.Signal name
(map introspectParam (signatureTypes sig))]
introspectSignal _ = []
introspectParam t = DBus.Introspection.Parameter "" (Signature [t])