diff --git a/Examples/exporting.hs b/Examples/exporting.hs new file mode 100644 --- /dev/null +++ b/Examples/exporting.hs @@ -0,0 +1,65 @@ +-- Copyright (C) 2009-2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where +import Control.Monad.IO.Class (liftIO) +import DBus.Client +import DBus.Constants +import qualified Data.Map as Map + +a :: String -> Object +a x = object + [ ("test.iface_1", interface + [ ("Foo", onFoo "a" x) + , ("Bar", onBar "a" x) + ]) + ] + +b :: String -> Object +b x = object + [ ("test.iface_1", interface + [ ("Foo", onFoo "b" x) + , ("Bar", onBar "b" x) + ]) + ] + +onFoo :: String -> String -> Member +onFoo x y = method "" "s" $ \call -> do + liftIO $ putStrLn $ "Foo " ++ x ++ " " ++ y + replyReturn call [toVariant $ "Foo " ++ x ++ " " ++ y] + +onBar :: String -> String -> Member +onBar x y = method "" "s" $ \call -> do + liftIO $ putStrLn $ "Bar " ++ x ++ " " ++ y + replyError call errorFailed [toVariant $ "Bar " ++ x ++ " " ++ y] + +main :: IO () +main = do + -- Connect to the bus + client <- newClient =<< getSessionBus + runDBus client $ do + -- Request a unique name on the bus. If the name is already + -- in use, continue without it. + requestName "org.test.exporting" [] + (\e -> liftIO $ putStrLn "Error requesting unique name") + (\response -> return ()) + + -- Export two example objects + export "/a" (a "hello") + export "/b" (b "world") + + -- Wait forever for method calls + mainLoop diff --git a/Examples/introspect.hs b/Examples/introspect.hs new file mode 100644 --- /dev/null +++ b/Examples/introspect.hs @@ -0,0 +1,107 @@ +-- Copyright (C) 2009-2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where +import Prelude hiding (replicate) +import qualified Prelude as Prelude +import qualified Data.Text.Lazy as TL +import Control.Monad.IO.Class (liftIO) +import Control.Concurrent (forkIO) +import Data.Maybe + +import DBus.Client +import qualified DBus.Introspection as I +import System (getArgs) + +main :: IO () +main = do + [service, path] <- getArgs + c <- newClient =<< getSessionBus + let introspect' p = runDBus c $ introspect (mkBusName_ $ TL.pack service) p + forkIO $ runDBus c mainLoop + printObj introspect' 0 (mkObjectPath_ $ TL.pack path) + +introspect :: BusName -> ObjectPath -> DBus I.Object +introspect service path = do + let proxy = Proxy service path "org.freedesktop.DBus.Introspectable" + + reply <- callProxyBlocking_ proxy "Introspect" [] [] + let text = fromJust $ fromVariant (methodReturnBody reply !! 0) + return . fromJust $ I.fromXML path text + +-- most of this stuff is just boring text formatting + +printObj :: (ObjectPath -> IO I.Object) -> Integer -> ObjectPath -> IO () +printObj get depth path = do + let strPath = strObjectPath path + putStr $ replicate (depth * 4) ' ' + putStrLn $ TL.unpack strPath + + (I.Object _ interfaces children) <- get path + + putStr $ replicate (depth * 4) ' ' + putStrLn $ replicate (fromIntegral $ TL.length strPath) '=' + + mapM_ (printIface (depth + 1)) interfaces + + mapM_ (printObj get (depth + 1)) [x | (I.Object x _ _) <- children] + +printIface :: Integer -> I.Interface -> IO () +printIface depth (I.Interface name methods signals properties) = do + let strName = strInterfaceName name + putStr $ replicate (depth * 4) ' ' + putStrLn . TL.unpack $ strName + putStr $ replicate (depth * 4) ' ' + putStrLn $ replicate (fromIntegral $ TL.length strName) '-' + + mapM_ (printMethod (depth + 1)) methods + mapM_ (printSignal (depth + 1)) signals + mapM_ (printProperty (depth + 1)) properties + +printMethod :: Integer -> I.Method -> IO () +printMethod depth (I.Method name inParams outParams) = do + putStr $ replicate (depth * 4) ' ' + putStr "M " + putStrLn . TL.unpack . strMemberName $ name + + mapM_ (printParam "IN" (depth + 1)) inParams + mapM_ (printParam "OUT" (depth + 1)) outParams + +printSignal :: Integer -> I.Signal -> IO () +printSignal depth (I.Signal name params) = do + putStr $ replicate (depth * 4) ' ' + putStr "S " + putStrLn . TL.unpack . strMemberName $ name + + mapM_ (printParam "OUT" (depth + 1)) params + +printProperty :: Integer -> I.Property -> IO () +printProperty depth (I.Property name sig access) = do + putStr $ replicate (depth * 4) ' ' + putStr $ "P " ++ show (strSignature sig) ++ " " + putStrLn $ TL.unpack name + putStr $ replicate ((depth + 1) * 4) ' ' + putStrLn $ show access + +printParam :: String -> Integer -> I.Parameter -> IO () +printParam label depth (I.Parameter name sig) = do + putStr $ replicate (depth * 4) ' ' + putStr $ "[" ++ label ++ " " + putStr $ show (strSignature sig) ++ " ] " + putStrLn $ TL.unpack name + +replicate :: Integer -> a -> [a] +replicate = Prelude.replicate . fromInteger diff --git a/Examples/simple.hs b/Examples/simple.hs --- a/Examples/simple.hs +++ b/Examples/simple.hs @@ -1,4 +1,4 @@ --- Copyright (C) 2009 John Millikin +-- Copyright (C) 2009-2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by @@ -16,27 +16,31 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import DBus.Bus import DBus.Client -import DBus.Message -import DBus.Types +import Control.Concurrent (forkIO) +import Control.Monad (forever) import Data.List (sort) dbus :: Proxy -dbus = Proxy (RemoteObject "org.freedesktop.DBus" "/org/freedesktop/DBus") "org.freedesktop.DBus" +dbus = Proxy "org.freedesktop.DBus" "/org/freedesktop/DBus" "org.freedesktop.DBus" main :: IO () main = do -- Connect to the bus, and print which name was assigned to this -- connection. - client <- mkClient =<< getSessionBus + client <- newClient =<< getSessionBus putStrLn $ "Connected as: " ++ show (clientName client) - -- Request a list of connected clients from the bus - reply <- callProxyBlocking_ client dbus "ListNames" [] [] + -- Start message handling in another thread + forkIO $ runDBus client mainLoop - -- Pull out the body, and convert it to [String] - let Just names = fromArray =<< fromVariant (messageBody reply !! 0) + -- Request a list of connected clients from the bus + names <- runDBus client $ do + reply <- callProxyBlocking_ dbus "ListNames" [] [] + + -- Pull out the body, and convert it to [String] + let Just names = fromArray =<< fromVariant (messageBody reply !! 0) + return names -- Print each name on a line, sorted so reserved names are below -- temporary names. diff --git a/Makefile b/Makefile deleted file mode 100644 --- a/Makefile +++ /dev/null @@ -1,18 +0,0 @@ -HS_SOURCES=hs/DBus/Client.hs - -all: $(HS_SOURCES) - -%.tex: %.nw - noweave -delay "$<" | cpif "$@" - -hs/%.hs: dbus-client.nw hs/DBus - notangle -R"$*.hs" "$<" | cpif "$@" - -hs/DBus: - mkdir -p hs/DBus - -dbus-client.pdf: dbus-client.tex - xelatex dbus-client.tex - xelatex dbus-client.tex - -pdf: dbus-client.pdf diff --git a/dbus-client.anansi b/dbus-client.anansi new file mode 100644 --- /dev/null +++ b/dbus-client.anansi @@ -0,0 +1,966 @@ +:# Copyright (C) 2009 John Millikin +:# +:# This program is free software: you can redistribute it and/or modify +:# it under the terms of the GNU General Public License as published by +:# the Free Software Foundation, either version 3 of the License, or +:# any later version. +:# +:# This program is distributed in the hope that it will be useful, +:# but WITHOUT ANY WARRANTY; without even the implied warranty of +:# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +:# GNU General Public License for more details. +:# +:# You should have received a copy of the GNU General Public License +:# along with this program. If not, see . + +\documentclass[12pt]{article} + +\usepackage{color} +\usepackage{hyperref} +\usepackage{noweb} + +:# Smaller margins +\usepackage[left=1.5cm,top=2cm,right=1.5cm,nohead,nofoot]{geometry} + +:# Remove boxes from hyperlinks +\hypersetup{ + colorlinks, + linkcolor=blue, +} + +\makeindex + +\begin{document} + +\addcontentsline{toc}{section}{Contents} +\tableofcontents + +\section{Introduction} + +This library provides a simplified, high-level interface for use by D-Bus +clients. It implements async operations, remote object proxies, and +local object exporting. + +The {\tt DBus.Client} module provides the public interface to this library. + +:f DBus/Client.hs +|copyright| +|language extensions| +module DBus.Client ( + |exports| + ) where +|imports| +: + +{\tt DBus.Client} also re-exports some modules from the {\tt dbus-core} +package. + +:d exports + module DBus.Bus +, module DBus.Types +, module DBus.Message +: + +:d imports +import DBus.Bus +import DBus.Types +import DBus.Message + +import qualified DBus.Connection as C +import qualified DBus.Constants as Const +import qualified DBus.Introspection as I +import qualified DBus.MatchRule as MR +import qualified DBus.Message as M +import qualified DBus.NameReservation as NR +import qualified DBus.Types as T +import qualified DBus.Wire as W +: + +All source code is licensed under the terms of the GNU GPL v3 or later. + +:d copyright +-- Copyright (C) 2009 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . +: + +:d language extensions +{-# LANGUAGE OverloadedStrings #-} +: + +\section{DBus Clients} + +The {\tt Client} type provides an opaque handle to internal client state, +including callback registration and the open connection. + +:d imports +import qualified Control.Concurrent.MVar as MV +import qualified Data.Map as Map +: + +:f DBus/Client.hs +|apidoc Client| +data Client = Client + { clientConnection :: C.Connection + , clientName :: T.BusName + , clientCallbacks :: MV.MVar (Map.Map M.Serial MessageHandler) + , clientObjects :: MV.MVar (Map.Map T.ObjectPath Object) + , clientSignalHandlers :: MV.MVar [MessageHandler] + } +type MessageHandler = (M.ReceivedMessage -> DBus ()) +: + +:d exports + -- * Clients +, Client +, C.Connection +, clientName +: + +The signature of {\tt newClient} is a bit weird so it can be called with +results from the {\tt DBus.Bus} family of computations, without having to +unwrap or curry. + +:f DBus/Client.hs +|apidoc newClient| +newClient :: (C.Connection, T.BusName) -> IO Client +newClient (c, name) = do + callbacks <- MV.newMVar Map.empty + objects <- MV.newMVar Map.empty + signals <- MV.newMVar [] + let client = Client c name callbacks objects signals + |initialize client| + return client +: + +:d exports +, newClient +: + +\section{Monadic interface} + +Most of this module uses the {\tt DBus} monad, which wraps up the DBus +connection into a more abstract form. + +:d imports +import Control.Monad (liftM, ap, forever) +import Control.Monad.IO.Class (liftIO) +import qualified Control.Monad.IO.Class as MIO +import qualified Control.Monad.Reader as R +import qualified Control.Applicative as A +: + +:f DBus/Client.hs +newtype DBus a = DBus { unDBus :: R.ReaderT Client IO a } + +instance Monad DBus where + return = DBus . return + (>>=) (DBus m) f = DBus $ m >>= unDBus . f + +instance MIO.MonadIO DBus where + liftIO = DBus . MIO.liftIO + +instance Functor DBus where + fmap = liftM + +instance A.Applicative DBus where + pure = return + (<*>) = ap +: + +The low-level DBus module prefers to return errors in the standard +{\tt Either} type, to let clients explicitly handle errors. Most of the +time, there's no reasonable way to handle such an error, so any errors +encountered when running a DBus client are thrown as exceptions. + +:d language extensions +{-# LANGUAGE DeriveDataTypeable #-} +: + +:d imports +import Data.Typeable (Typeable) +import qualified Control.Exception as Exc +: + +Errors marshaling and unmarshaling are supported. Additionally, uncaught +errors from blocking method calls may be thrown from some computations. + +:f DBus/Client.hs +data DBusException + = MarshalFailed W.MarshalError + | UnmarshalFailed W.UnmarshalError + | MethodCallFailed M.Error + | InvalidRequestNameReply M.MethodReturn + | InvalidReleaseNameReply M.MethodReturn + deriving (Show, Eq, Typeable) +instance Exc.Exception DBusException +: + +Having to run {\tt liftIO} everywhere is annoying, so {\tt MonadError} +is instanced to let clients throw/catch more easily. + +:d language extensions +{-# LANGUAGE TypeFamilies #-} +: + +:d imports +import qualified Control.Monad.Error as E +: + +:f DBus/Client.hs +instance E.MonadError DBus where + type E.ErrorType DBus = DBusException + throwError = MIO.liftIO . Exc.throwIO + catchError dbus h = do + c <- getClient + liftIO $ Exc.catch + (runDBus c dbus) + (runDBus c . h) +: + +Typical monad unwrapper, and some access computations. + +:f DBus/Client.hs +|apidoc runDBus| +runDBus :: Client -> DBus a -> IO a +runDBus c (DBus m) = R.runReaderT m c + +getClient :: DBus Client +getClient = DBus R.ask + +getConnection :: DBus C.Connection +getConnection = fmap clientConnection getClient +: + + +:d exports +, DBus +, DBusException +, runDBus +, getClient +: + +\subsection{Dispatching messages} + +Messages are read sequentially from the connection (typically in a central +loop), and then processed according to the client's message handler maps. +Unknown message types are ignored. + +:f DBus/Client.hs +|apidoc processMessage| +processMessage :: M.ReceivedMessage -> DBus () +processMessage received = p received where + p (M.ReceivedUnknown _ _ _) = return () + |process messages| + reply s = onReply s received +: + +:d exports +, processMessage +: + +\subsection{Useful wrappers} + +Sending and receiving messages is common enough to use some small wrapper +functions. + +:f DBus/Client.hs +|apidoc send| +send :: M.Message msg => (M.Serial -> DBus a) -> msg -> DBus a +send onSerial msg = do + c <- getConnection + client <- getClient + sent <- liftIO $ C.send c (runDBus client . onSerial) msg + case sent of + Left err -> E.throwError $ MarshalFailed err + Right a -> return a + +|apidoc send_| +send_ :: M.Message msg => msg -> DBus () +send_ = send (const $ return ()) +: + +:f DBus/Client.hs +|apidoc receive| +receive :: DBus M.ReceivedMessage +receive = do + c <- getConnection + parsed <- liftIO $ C.receive c + case parsed of + Left err -> E.throwError $ UnmarshalFailed err + Right msg -> return msg +: + +:f DBus/Client.hs +|apidoc mainLoop| +mainLoop :: DBus () +mainLoop = forever $ receive >>= processMessage +: + +:d exports +, send +, send_ +, receive +, mainLoop +: + +\section{Method calls} + +DBus is inherently asynchronous. Method calls are sent over the bus, and +at some future point a response might be received. + +Because all messages are sent and received over a single connection, waiting +for replies should be performed from a single thread. However, it's safe to +send messages from any thread. + +\subsection{Asynchronous} + +:f DBus/Client.hs +|apidoc call| +call :: M.MethodCall + -> (M.Error -> DBus ()) + -> (M.MethodReturn -> DBus ()) + -> DBus () +call msg onError onReturn = send addCallback msg where + cb (M.ReceivedError _ _ msg') = onError msg' + cb (M.ReceivedMethodReturn _ _ msg') = onReturn msg' + cb _ = return () + + addCallback s = do + mvar <- fmap clientCallbacks getClient + liftIO $ MV.modifyMVar_ mvar $ return . Map.insert s cb +: + +:d exports +, call +: + +:d process messages +p (M.ReceivedMethodReturn _ _ msg) = reply $ M.methodReturnSerial msg +p (M.ReceivedError _ _ msg) = reply $ M.errorSerial msg +: + +When a {\tt MethodReturn} or {\tt Error} message is received, DBus expects +that its stored serial refers to a registered callback. Sometimes this isn't +true -- for example, a client might have used {\tt send} to call a method and +ignore its return value. In these cases, the return message should be +ignored. + +:d imports +import Data.Maybe (isJust) +: + +:f DBus/Client.hs +onReply :: M.Serial -> M.ReceivedMessage -> DBus () +onReply serial msg = do + mvar <- fmap clientCallbacks getClient + maybeCB <- liftIO $ MV.modifyMVar mvar $ \callbacks -> let + x = Map.lookup serial callbacks + callbacks' = if isJust x + then Map.delete serial callbacks + else callbacks + in return (callbacks', x) + case maybeCB of + Just cb -> cb msg + Nothing -> return () +: + +\subsection{Synchronous} + +Synchronous (or ``blocking'') operation is emulated using an {\tt MVar}. + +:f DBus/Client.hs +|apidoc callBlocking| +callBlocking :: M.MethodCall -> DBus (Either M.Error M.MethodReturn) +callBlocking msg = do + mvar <- liftIO $ MV.newEmptyMVar + call msg + (liftIO . MV.putMVar mvar . Left) + (liftIO . MV.putMVar mvar . Right) + liftIO $ MV.takeMVar mvar + +|apidoc callBlocking_| +callBlocking_ :: M.MethodCall -> DBus M.MethodReturn +callBlocking_ msg = do + reply <- callBlocking msg + case reply of + Left err -> E.throwError $ MethodCallFailed err + Right x -> return x +: + +:d exports +, callBlocking +, callBlocking_ +: + +\section{Handling signals} + +Before the bus forwards any signals to this client, the client must send a +match rule to the bus. The rule is kept around so the correct callback can +be found when the signal is received. + +:f DBus/Client.hs +|apidoc onSignal| +onSignal :: MR.MatchRule + -> (T.BusName -> M.Signal -> DBus ()) + -> DBus () +onSignal rule h = addHandler where + rule' = rule { MR.matchType = Just MR.Signal } + + handler msg@(M.ReceivedSignal _ (Just sender) signal) + | MR.matches rule' msg = h sender signal + handler _ = return () + + addHandler = do + callBlocking_ $ MR.addMatch rule' + mvar <- fmap clientSignalHandlers getClient + liftIO $ MV.modifyMVar_ mvar $ return . (handler :) +: + +:d process messages +p (M.ReceivedSignal _ _ _) = do + mvar <- fmap clientSignalHandlers getClient + handlers <- liftIO $ MV.readMVar mvar + mapM_ ($ received) handlers +: + +:d exports +-- * Handling signals +, onSignal +: + +\section{Name reservation} + +:d exports +-- * Name reservation +, NR.RequestNameFlag (..) +, NR.RequestNameReply (..) +, NR.ReleaseNameReply (..) +, requestName +, releaseName +, requestName_ +, releaseName_ +: + +:f DBus/Client.hs +requestName :: T.BusName + -> [NR.RequestNameFlag] + -> (M.Error -> DBus ()) + -> (NR.RequestNameReply -> DBus ()) + -> DBus () +requestName name flags onError callback = + call (NR.requestName name flags) onError $ \reply -> + case NR.mkRequestNameReply reply of + Nothing -> E.throwError $ InvalidRequestNameReply reply + Just x -> callback x +: + +:f DBus/Client.hs +releaseName :: T.BusName + -> (M.Error -> DBus ()) + -> (NR.ReleaseNameReply -> DBus ()) + -> DBus () +releaseName name onError callback = + call (NR.releaseName name) onError $ \reply -> + case NR.mkReleaseNameReply reply of + Nothing -> E.throwError $ InvalidReleaseNameReply reply + Just x -> callback x +: + +:f DBus/Client.hs +requestName_ :: T.BusName -> [NR.RequestNameFlag] -> DBus NR.RequestNameReply +requestName_ name flags = do + reply <- callBlocking_ $ NR.requestName name flags + case NR.mkRequestNameReply reply of + Nothing -> E.throwError $ InvalidRequestNameReply reply + Just x -> return x +: + +:f DBus/Client.hs +releaseName_ :: T.BusName -> DBus NR.ReleaseNameReply +releaseName_ name = do + reply <- callBlocking_ $ NR.releaseName name + case NR.mkReleaseNameReply reply of + Nothing -> E.throwError $ InvalidReleaseNameReply reply + Just x -> return x +: + +\section{Exporting local objects} + +DBus is an object-oriented design, and most languages with DBus libraries +conform at least vaguely to object-oriented principles. Since Haskell is +functional, it's somewhat difficult to make exporting local behavior as +simple as it is in other languages. + +In DBus, the basic unit of behavior is a ``member''. Members may be either +methods, which are called, or signals, which are emitted. A collection of +members indexed by name is an ``interface''. A collection interfaces (also +indexed by name) is an ``object''. + +A method has two signatures, one for inputs and another for outputs. DBus +does not support in-out (aka ``reference'') parameters. Signals have only +one signature, which is of their output. + +:f DBus/Client.hs +newtype Object = Object (Map.Map T.InterfaceName Interface) +newtype Interface = Interface (Map.Map T.MemberName Member) +data Member + = MemberMethod Method + | MemberSignal T.Signature +data Method = Method T.Signature T.Signature (MethodCtx -> DBus ()) +: + +:d exports + -- * Exporting local objects +, Object (..) +, Interface (..) +, Member (..) +, Method (..) +: + +Exporting is mostly just a matter of adding the object and its path to the +client's lookup map. However, note the call to {\tt addIntrospectable} -- +DBus supports remote object introspection, and it's useful to generate a +basic schema by default. + +:f DBus/Client.hs +|apidoc export| +export :: T.ObjectPath -> Object -> DBus () +export path obj = do + let obj' = addIntrospectable path obj + mvar <- fmap clientObjects getClient + liftIO $ MV.modifyMVar_ mvar $ return . Map.insert path obj' +: + +:d exports +, export +: + +To simplify building objects from existing functions, some helper functions +are defined. + +:f DBus/Client.hs +object :: [(T.InterfaceName, Interface)] -> Object +object = Object . Map.fromList + +interface :: [(T.MemberName, Member)] -> Interface +interface = Interface . Map.fromList + +method :: T.Signature -- ^ Input signature + -> T.Signature -- ^ Output signature + -> (MethodCtx -> DBus ()) -- ^ Implementation + -> Member +method inSig outSig cb = MemberMethod $ Method inSig outSig cb +: + +:d exports +, object +, interface +, method +: + +\subsection{Responding to method calls} + +When a method call message is received for a local object, relevant +information for replying to the call is placed in a {\tt MethodCtx} value. + +:d imports +import qualified Data.Set as Set +: + +:f DBus/Client.hs +data MethodCtx = MethodCtx + { methodCtxObject :: Object + , methodCtxMethod :: Method + , methodCtxSerial :: M.Serial + , methodCtxSender :: Maybe T.BusName + , methodCtxFlags :: Set.Set M.Flag + , methodCtxBody :: [T.Variant] + } +: + +{\tt replyReturn} and {\tt replyError} can be used by client code to +send a response message to a method call. Using these is easier than +constructing the reply manually. + +:f DBus/Client.hs +|apidoc replyReturn| +replyReturn :: MethodCtx -> [T.Variant] -> DBus () +replyReturn call' body = if valid then sendReply else sendError where + sendError = replyError call' Const.errorFailed + [T.toVariant ("Method return didn't match signature." :: String)] + + sendReply = send_ $ M.MethodReturn + (methodCtxSerial call') + (methodCtxSender call') + body + + (Method _ outSig _) = methodCtxMethod call' + valid = listSig body == Just outSig +: + +:f DBus/Client.hs +replyError :: MethodCtx -> T.ErrorName -> [T.Variant] -> DBus () +replyError call' name body = send_ $ M.Error + name + (methodCtxSerial call') + (methodCtxSender call') + body +: + +:d exports + -- ** Responding to method calls +, MethodCtx (..) +, replyReturn +, replyError +: + +\subsection{Dispatching method calls} + +Method calls are dispatched using the client's object map. If the +specified method is not found, an error will be returned. + +:d process messages +p (M.ReceivedMethodCall _ _ msg) = do + mvar <- fmap clientObjects getClient + objects <- liftIO $ MV.readMVar mvar + case findMethod objects msg of + Just (obj, m) -> onMethodCall obj m received + Nothing -> unknownMethod received +: + +:f DBus/Client.hs +unknownMethod :: M.ReceivedMessage -> DBus () +unknownMethod msg = send_ errorMsg where + M.ReceivedMethodCall serial sender _ = msg + errorMsg = M.Error + Const.errorUnknownMethod + serial sender + [] +: + +Technically method calls don't have to specify an interface if there's only +one available in the destination object, but that'll never be the case here, +so treat an unspecified interface as unknown. + +:f DBus/Client.hs +findMethod :: Map.Map T.ObjectPath Object -> M.MethodCall -> Maybe (Object, Method) +findMethod objects call' = do + Object obj <- Map.lookup (M.methodCallPath call') objects + ifaceName <- M.methodCallInterface call' + Interface iface <- Map.lookup ifaceName obj + member <- Map.lookup (M.methodCallMember call') iface + case member of + MemberMethod m -> return (Object obj, m) + _ -> Nothing +: + +If the method was found, it needs to have its parameter list validated +before being sent on to the inner callback. This prevents DBus's dynamic +typing from causing trouble in Haskell code. + +:f DBus/Client.hs +onMethodCall :: Object -> Method -> M.ReceivedMessage -> DBus () +onMethodCall obj method' received = runCall where + M.ReceivedMethodCall serial sender msg = received + sig = listSig $ M.methodCallBody msg + Method inSig _ cb = method' + + call' = MethodCtx obj method' serial sender + (M.methodCallFlags msg) + (M.methodCallBody msg) + + runCall = if sig == Just inSig + then cb call' + else replyError call' Const.errorInvalidArgs [] +: + +\subsection{Automatic introspection} + +Some basic introspection can be performed automatically, based on the +contents of an {\tt Object}. This is only added to objects which do not +already define the {\tt Introspectable} interface -- that way, clients can +provide their own implementations if needed. + +:f DBus/Client.hs +addIntrospectable :: T.ObjectPath -> Object -> Object +addIntrospectable path (Object ifaces) = Object ifaces' where + ifaces' = Map.insertWith (\_ x -> x) name iface ifaces + name = Const.interfaceIntrospectable + iface = interface [("Introspect", impl)] + impl = method "" "s" $ \call' -> do + let Just xml = I.toXML . introspect path . methodCtxObject $ call' + replyReturn call' [T.toVariant xml] +: + +:f DBus/Client.hs +introspect :: T.ObjectPath -> Object -> I.Object +introspect path obj = I.Object path interfaces [] where + Object ifaceMap = obj + interfaces = map introspectIface (Map.toList ifaceMap) + + introspectIface :: (T.InterfaceName, Interface) -> I.Interface + introspectIface (name, iface) = I.Interface name methods signals [] where + Interface memberMap = iface + members = Map.toList memberMap + methods = concatMap introspectMethod members + signals = concatMap introspectSignal members + + introspectMethod :: (T.MemberName, Member) -> [I.Method] + introspectMethod (name, (MemberMethod (Method inSig outSig _))) = + [I.Method name + (map introspectParam (T.signatureTypes inSig)) + (map introspectParam (T.signatureTypes outSig))] + introspectMethod _ = [] + + introspectSignal :: (T.MemberName, Member) -> [I.Signal] + introspectSignal (name, (MemberSignal sig)) = [I.Signal name + (map introspectParam (T.signatureTypes sig))] + introspectSignal _ = [] + + introspectParam = I.Parameter "" . T.mkSignature_ . T.typeCode +: + +\subsection{The root object} + +Every client exports a ``root'' object, which provides introspection for +all exported objects. Although the DBus export list is hierarchical, this +module models it as a flat map. + +:f DBus/Client.hs +rootObject :: Object +rootObject = object [(ifaceName, interface [(memberName, impl)])] where + ifaceName = Const.interfaceIntrospectable + memberName = "Introspect" + + methodXML = I.Method memberName [] [I.Parameter "xml" "s"] + ifaceXML = I.Interface ifaceName [methodXML] [] [] + + impl = method "" "s" $ \call' -> do + mvar <- fmap clientObjects getClient + paths <- liftIO $ fmap Map.keys $ MV.readMVar mvar + + let paths' = filter (/= "/") paths + let Just xml = I.toXML $ I.Object "/" [ifaceXML] + [I.Object p [] [] | p <- paths'] + replyReturn call' [T.toVariant xml] +: + +:d initialize client +liftIO $ MV.modifyMVar_ objects $ return . Map.insert "/" rootObject +: + +\section{Remote object proxies} + +Most DBus libraries support the concept of an ``object proxy'', which +behaves like a native object but runs its operations in another process. +A {\tt Proxy} is an approximation of this model for Haskell. + +:f DBus/Client.hs +data Proxy = Proxy + { proxyName :: T.BusName + , proxyObjectPath :: T.ObjectPath + , proxyInterface :: T.InterfaceName + } + deriving (Show, Eq) +: + +:f DBus/Client.hs +|apidoc callProxy| +callProxy :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] + -> (M.Error -> DBus ()) + -> (M.MethodReturn -> DBus ()) + -> DBus () +callProxy proxy name flags body onError onReturn = let + msg = buildMethodCall proxy name flags body + in call msg onError onReturn +: + +:f DBus/Client.hs +|apidoc callProxyBlocking| +callProxyBlocking :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] + -> DBus (Either M.Error M.MethodReturn) +callProxyBlocking proxy name flags body = + callBlocking $ buildMethodCall proxy name flags body +: + +:f DBus/Client.hs +|apidoc callProxyBlocking_| +callProxyBlocking_ :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] + -> DBus M.MethodReturn +callProxyBlocking_ proxy name flags body = + callBlocking_ $ buildMethodCall proxy name flags body +: + +:f DBus/Client.hs +|apidoc onProxySignal| +onProxySignal :: Proxy -> T.MemberName -> (M.Signal -> DBus ()) + -> DBus () +onProxySignal proxy member handler = onSignal rule handler' where + Proxy dest path iface = proxy + rule = MR.MatchRule + { MR.matchType = Nothing + , MR.matchSender = Just dest + , MR.matchInterface = Just iface + , MR.matchMember = Just member + , MR.matchPath = Just path + , MR.matchDestination = Nothing + , MR.matchParameters = [] + } + handler' _ msg = handler msg +: + +:d exports +, Proxy (..) +, callProxy +, callProxyBlocking +, callProxyBlocking_ +, onProxySignal +: + +:f DBus/Client.hs +buildMethodCall :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] + -> M.MethodCall +buildMethodCall proxy name flags body = msg where + Proxy dest path iface = proxy + msg = M.MethodCall path name (Just iface) (Just dest) + (Set.fromList flags) body +: + +\section{Utility functions} + +:d imports +import Data.Monoid (mconcat) +: + +:f DBus/Client.hs +listSig :: [T.Variant] -> Maybe T.Signature +listSig = T.mkSignature . mconcat . map (T.typeCode . T.variantType) +: + +\section{Haddock API documentation} + +:d apidoc Client +-- | 'Client's are opaque handles to an open connection and other internal +-- state. +: + +:d apidoc newClient +-- | Create a new 'Client' from an open connection and bus name. The weird +-- signature allows @newClient@ to use the computations in "DBus.Bus" +-- directly, without unpacking: +-- +-- @ +-- client <- newClient =<< 'getSessionBus' +-- @ +-- +-- Only one client should be created for any given connection. Otherwise, +-- they will compete to receive messages. +: + +:d apidoc runDBus +-- | Run a DBus computation with the given client callbacks. Errors +-- encountered while running will be thrown as exceptions, using the +-- 'DBusException' type. +-- +-- Use the 'E.MonadError' instance for 'DBus' to handle errors inside +-- the computation. +: + +:d apidoc processMessage +-- | Run message handlers with the received message. If any method reply +-- callbacks or signal handlers are found, they will be run in the current +-- thread. +: + +:d apidoc send +-- | A wrapper around 'C.send'. +: + +:d apidoc send_ +-- | A wrapper around 'C.send', which does not allow the message serial +-- to be recorded. This is a useful shortcut when sending messages which +-- are not expected to receive a reply. +: + +:d apidoc receive +-- | A wrapper around 'C.receive'. +: + +:d apidoc mainLoop +-- | Run in a loop forever, processing messages. +-- +-- This is commonly run in a separate thread, ie +-- +-- > client <- newClient =<< getSessionBus +-- > forkIO $ runDBus client mainLoop +: + +:d apidoc call +-- | Perform an asynchronous method call. One of the provided computations +-- will be performed depending on what message type the destination sends +-- back. +: + +:d apidoc callBlocking +-- | Sends a method call, and then blocks until a reply is received. Use +-- this when the receive/process loop is running in a separate thread. +: + +:d apidoc callBlocking_ +-- | A variant of 'callBlocking', which throws an exception if the +-- remote client returns 'M.Error'. +: + +:d apidoc onSignal +-- | Perform some computation every time this client receives a matching +-- signal. +: + +:d apidoc export +-- | Export a set of interfaces on the bus. Whenever a method call is +-- received which matches the object's path, interface, and member name, +-- one of its members will be called. +-- +-- Exported objects automatically implement the +-- @org.freedesktop.DBus.Introspectable@ interface. +: + +:d apidoc replyReturn +-- | Send a successful return reply for a method call. +: + +:d apidoc replyError +-- | Send an error reply for a method call. +: + +:d apidoc callProxy +-- | As 'call', except that the proxy's information is used to +-- build the message. +: + +:d apidoc callProxyBlocking +-- | As 'callBlocking', except that the proxy's information is used +-- to build the message. +: + +:d apidoc callProxyBlocking_ +-- | As 'callBlocking_', except that the proxy's information is used +-- to build the message. +: + +:d apidoc onProxySignal +-- | As 'onSIgnal', except that the proxy's information is used +-- to build the match rule. +: diff --git a/dbus-client.cabal b/dbus-client.cabal --- a/dbus-client.cabal +++ b/dbus-client.cabal @@ -1,6 +1,6 @@ name: dbus-client -version: 0.3.0.1 -synopsis: D-Bus client libraries +version: 0.4 +synopsis: Monadic and object-oriented interfaces to DBus license: GPL-3 license-file: License.txt author: John Millikin @@ -11,26 +11,27 @@ stability: experimental bug-reports: mailto:jmillikin@gmail.com homepage: http://ianen.org/haskell/dbus/ -tested-with: GHC==6.10.4 +tested-with: GHC==6.12.1 extra-source-files: - dbus-client.nw + dbus-client.anansi Examples/*.hs - Makefile source-repository head type: darcs location: http://ianen.org/haskell/dbus/client/ library - ghc-options: -Wall + ghc-options: -Wall -fno-warn-unused-do-bind hs-source-dirs: hs build-depends: base >=3 && < 5 , dbus-core >= 0.8 && < 0.9 - , containers - , text + , containers >= 0.1 && < 0.4 + , text >= 0.7 && < 0.8 + , transformers >= 0.2 && < 0.3 + , monads-tf >= 0.1 && < 0.2 exposed-modules: DBus.Client diff --git a/dbus-client.nw b/dbus-client.nw deleted file mode 100644 --- a/dbus-client.nw +++ /dev/null @@ -1,662 +0,0 @@ - -% Copyright (C) 2009 John Millikin -% -% This program is free software: you can redistribute it and/or modify -% it under the terms of the GNU General Public License as published by -% the Free Software Foundation, either version 3 of the License, or -% any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program. If not, see . - -\documentclass[12pt]{article} - -\usepackage{color} -\usepackage{hyperref} -\usepackage{noweb} - -% Smaller margins -\usepackage[left=1.5cm,top=2cm,right=1.5cm,nohead,nofoot]{geometry} - -% Remove boxes from hyperlinks -\hypersetup{ - colorlinks, - linkcolor=blue, -} - -\makeindex - -\begin{document} - -\addcontentsline{toc}{section}{Contents} -\tableofcontents - -@ -\section{Introduction} - -This library provides a simplified, high-level interface for use by D-Bus -clients. It implements async operations, remote object proxies, and -local object exporting. - -The {\tt DBus.Client} module provides the public interface to this library. - -<>= -<> -{-# LANGUAGE OverloadedStrings #-} -module DBus.Client - ( <> - ) where -<> - -@ All source code is licensed under the terms of the GNU GPL v3 or later. - -<>= -{- - Copyright (C) 2009 John Millikin - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . --} - -@ -\section{Clients} - -The {\tt Client} type provides an opaque handle to internal client state, -including callback registration and the open connection. - -<>= -import qualified Control.Concurrent.MVar as MV -import qualified Data.Map as Map -import qualified DBus.Connection as C -import qualified DBus.Message as M -import qualified DBus.Types as T - -<>= -type Callback = (M.ReceivedMessage -> IO ()) - --- | 'Client's are opaque handles to an open connection and other internal --- state. --- -data Client = Client C.Connection T.BusName - (MV.MVar (Map.Map M.Serial Callback)) - (MV.MVar (Map.Map T.ObjectPath Callback)) - (MV.MVar [Callback]) - -@ Two accessor functions are defined for the {\tt Client}'s {\tt Connection} -and unique bus name. The {\tt Connection} is used internally by this module, -but is not otherwise useful -- sharing a {\tt Connection} between two -{\tt Client}s is a bad idea. - -The {\tt Client}'s bus name might be useful, and there's no harm in exposing -it. - -<>= -clientConnection :: Client -> C.Connection -clientConnection (Client x _ _ _ _) = x - -clientName :: Client -> T.BusName -clientName (Client _ x _ _ _) = x - -<>= - -- * Clients - Client -, clientName - -<>= --- | Create a new 'Client' from an open connection and bus name. The weird - --- signature allows 'mkClient' to use the computations in "DBus.Bus" --- directly, without unpacking: --- --- @ --- client <- mkClient =<< getSessionBus --- @ --- --- Only one client should be created for any given connection. Otherwise, --- they will compete to receive messages. --- -mkClient :: (C.Connection, T.BusName) -> IO Client -mkClient (c, name) = do - replies <- MV.newMVar Map.empty - exports <- MV.newMVar Map.empty - signals <- MV.newMVar [] - let client = Client c name replies exports signals - <> - return client - -<>= -, mkClient - -@ \subsection{Sending messages} - -To simplify error conditions, errors returned from the {\tt DBus.Connection} -computations are converted to exceptions via {\tt error}. These errors only -occur if the message is malformed, so it's not worth the additional API -complexity to handle them. - -<>= -send_ :: M.Message a => Client -> (M.Serial -> IO b) -> a -> IO b -send_ c f msg = do - result <- C.send (clientConnection c) f msg - case result of - Left x -> error $ show x - Right x -> return x - -@ And since most uses of {\tt send\_} don't care about the message's -serial, it can be reduced further. - -<>= -sendOnly_ :: M.Message a => Client -> a -> IO () -sendOnly_ c = send_ c (const $ return ()) - -@ Additional helper computations are useful for sending method calls, to -keep track of which pending calls are currently expecting replies. The -{\tt call} computation is asynchronous; it will return immediately, and -one of the provided computations will be invoked depending on whether a -{\tt MethodReturn} or {\tt Error} were received. - -TODO: pending method calls should be removed periodically, after a -decently long timeout. - -TODO: if method calls with the {\tt NoReplyExpected} flag are sent, a -callback will be added but never removed. This could cause a space leak. - -<>= --- | Perform an asynchronous method call. One of the provided computations --- will be performed depending on what message type the destination sends --- back. --- -call :: Client -> M.MethodCall - -> (M.Error -> IO ()) - -> (M.MethodReturn -> IO ()) - -> IO () -call client msg onError onReturn = send_ client addCallback msg where - Client _ _ mvar _ _ = client - addCallback s = MV.modifyMVar_ mvar $ return . Map.insert s callback - - callback (M.ReceivedError _ _ msg') = onError msg' - callback (M.ReceivedMethodReturn _ _ msg') = onReturn msg' - callback _ = return () - -<>= --- | Similar to 'call', except that it waits for the reply and returns it --- in the current 'IO' thread. --- -callBlocking :: Client -> M.MethodCall -> IO (Either M.Error M.MethodReturn) -callBlocking client msg = do - mvar <- MV.newEmptyMVar - call client msg - (MV.putMVar mvar . Left) - (MV.putMVar mvar . Right) - MV.takeMVar mvar - -<>= --- | Similar to 'callBlocking', except that an exception is raised if the --- destination sends back an error. --- -callBlocking_ :: Client -> M.MethodCall -> IO M.MethodReturn -callBlocking_ client msg = do - reply <- callBlocking client msg - case reply of - Left x -> error . TL.unpack . M.errorMessage $ x - Right x -> return x - -<>= - -- ** Sending messages -, call -, callBlocking -, callBlocking_ - -@ \subsubsection{Emitting signals} - -TODO: this should be written in terms of locally exported objects; having -to construct a {\tt Signal} is a pain. - -<>= -emitSignal :: Client -> M.Signal -> IO () -emitSignal = sendOnly_ - -<>= - -- *** Emitting signals -, emitSignal - -@ \subsection{Receiving messages} - -Each client runs a separate thread for receiving messages, and every callback -is called in a separate thread. This allows callbacks to perform long -computations without blocking receipt of other messages. - -<>= -import Control.Concurrent (forkIO) -import Control.Monad (forever) -import qualified Data.Set as Set -import qualified DBus.Constants as Const - -<>= -forkIO $ forever (receiveMessages client) - -@ FIXME: does raising an exception here cause the thread to terminate? - -<>= -receiveMessages :: Client -> IO () -receiveMessages client = do - received <- C.receive $ clientConnection client - case received of - Left x -> error $ show x - Right x -> handleMessage client x - -<>= -handleMessage :: Client -> M.ReceivedMessage -> IO () -<> -handleMessage _ _ = return () - -@ \subsubsection{Method calls} - -Method calls are dispatched to the client's list of exported objects. If -no object is available at the requested path, an error will be returned. - -<>= -handleMessage client msg@(M.ReceivedMethodCall _ _ call') = do - let Client _ _ _ mvar _ = client - objects <- MV.readMVar mvar - case Map.lookup (M.methodCallPath call') objects of - Just x -> x msg - Nothing -> unknownMethod client msg - -<>= -unknownMethod :: Client -> M.ReceivedMessage -> IO () -unknownMethod client msg = sendOnly_ client errorMsg where - M.ReceivedMethodCall serial sender _ = msg - errorMsg = M.Error - Const.errorUnknownMethod - serial sender - [] - -@ \subsubsection{Replies} - -@ Method returns and errors both have a serial attached, which is used to -find the proper callback. If the callback cannot be found, no action will -be taken. - -<>= -handleMessage c msg@(M.ReceivedMethodReturn _ _ msg') = - gotReply c (M.methodReturnSerial msg') msg -handleMessage c msg@(M.ReceivedError _ _ msg') = - gotReply c (M.errorSerial msg') msg - -<>= -import Data.Maybe (isJust) - -<>= -gotReply :: Client -> M.Serial -> M.ReceivedMessage -> IO () -gotReply (Client _ _ mvar _ _) serial msg = do - callback <- MV.modifyMVar mvar $ \callbacks -> let - x = Map.lookup serial callbacks - callbacks' = if isJust x - then Map.delete serial callbacks - else callbacks - in return (callbacks', x) - case callback of - Just x -> forkIO (x msg) >> return () - Nothing -> return () - -@ \subsubsection{Signals} - -Signals are dispatched to the list of active signal handlers. - -<>= -handleMessage c msg@(M.ReceivedSignal _ _ _) = let - Client _ _ _ _ mvar = c - in MV.withMVar mvar $ mapM_ (\cb -> forkIO (cb msg)) - -@ -\section{Name reservation} - -<>= -import qualified DBus.NameReservation as NR - -<>= --- | A client can request a \"well-known\" name from the bus. This allows --- messages sent to that name to be received by the client, without senders --- being aware of which application is actually handling requests. --- --- A name may be requested for any client, using the given flags. The bus's --- reply will be returned, or an exception raised if the reply was invalid. --- -requestName :: Client -> T.BusName -> [NR.RequestNameFlag] - -> IO NR.RequestNameReply -requestName client name flags = do - reply <- callBlocking_ client $ NR.requestName name flags - case NR.mkRequestNameReply reply of - Nothing -> error $ "Invalid reply to RequestName" - Just x -> return x - -<>= --- | Clients may also release names they've requested. --- -releaseName :: Client -> T.BusName -> IO NR.ReleaseNameReply -releaseName client name = do - reply <- callBlocking_ client $ NR.releaseName name - case NR.mkReleaseNameReply reply of - Nothing -> error $ "Invalid reply to ReleaseName" - Just x -> return x - -<>= - -- * Name reservation -, requestName -, releaseName - -@ \subsection{Listening for Signals} - -Before the bus forwards any signals to this client, the client must send a -match rule to the bus. The rule is kept around so the correct callback can -be found when the signal is received. - -<>= -import qualified DBus.MatchRule as MR -import Data.Maybe (fromJust) - -<>= --- | Perform some computation every time this client receives a matching --- signal. --- -onSignal :: Client -> MR.MatchRule - -> (T.BusName -> M.Signal -> IO ()) - -> IO () -onSignal client rule callback = let - (Client _ _ _ _ mvar) = client - rule' = rule { MR.matchType = Just MR.Signal } - - callback' msg@(M.ReceivedSignal _ sender signal) - | MR.matches rule' msg = callback (fromJust sender) signal - callback' _ = return () - - in do - callBlocking_ client $ MR.addMatch rule' - MV.modifyMVar_ mvar $ return . (callback' :) - -<>= - -- * Receiving signals -, onSignal - -@ -\section{Remote objects and proxies} - -TODO: document this section - -<>= - -- * Remote objects and proxies -, RemoteObject (..) -, Proxy (..) - -<>= -data RemoteObject = RemoteObject T.BusName T.ObjectPath -data Proxy = Proxy RemoteObject T.InterfaceName - -@ \subsection{Method calls} - -<>= -buildMethodCall :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] - -> M.MethodCall -buildMethodCall proxy name flags body = msg where - Proxy (RemoteObject dest path) iface = proxy - msg = M.MethodCall path name (Just iface) (Just dest) - (Set.fromList flags) body - -<>= --- | As 'call', except that the proxy's information is used to --- build the message. --- -callProxy :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] - -> (M.Error -> IO ()) - -> (M.MethodReturn -> IO ()) - -> IO () -callProxy client proxy name flags body onError onReturn = let - msg = buildMethodCall proxy name flags body - in call client msg onError onReturn - -<>= --- | As 'callBlocking', except that the proxy's information is used --- to build the message. --- -callProxyBlocking :: Client -> Proxy -> T.MemberName -> [M.Flag] - -> [T.Variant] - -> IO (Either M.Error M.MethodReturn) -callProxyBlocking client proxy name flags body = - callBlocking client $ buildMethodCall proxy name flags body - -<>= --- | As 'callBlocking_', except that the proxy's information is used --- to build the message. --- -callProxyBlocking_ :: Client -> Proxy -> T.MemberName -> [M.Flag] - -> [T.Variant] - -> IO M.MethodReturn -callProxyBlocking_ client proxy name flags body = - callBlocking_ client $ buildMethodCall proxy name flags body - -<>= -, callProxy -, callProxyBlocking -, callProxyBlocking_ - -@ \subsection{Signals} - -<>= -onSignalFrom :: Client -> Proxy -> T.MemberName -> (M.Signal -> IO ()) - -> IO () -onSignalFrom client proxy member io = onSignal client rule io' where - Proxy (RemoteObject dest path) iface = proxy - rule = MR.MatchRule - { MR.matchType = Nothing - , MR.matchSender = Just dest - , MR.matchInterface = Just iface - , MR.matchMember = Just member - , MR.matchPath = Just path - , MR.matchDestination = Nothing - , MR.matchParameters = [] - } - io' _ msg = io msg - -<>= -, onSignalFrom - -@ -\section{Exporting local objects} - -FIXME: the introspection stuff is \emph{really} ugly. - -<>= -import qualified DBus.Introspection as I - -<>= -export client ("/") rootObject - -<>= -rootObject :: LocalObject -rootObject = LocalObject $ Map.fromList [(ifaceName, interface)] where - ifaceName = "org.freedesktop.DBus.Introspectable" - memberName = "Introspect" - interface = Interface $ Map.fromList [(memberName, impl)] - - method = I.Method memberName [] [I.Parameter "xml" "s"] - iface = I.Interface ifaceName [method] [] [] - - impl = Method "" "s" $ \call' -> do - let Client _ _ _ mvar _ = methodCallClient call' - paths <- fmap Map.keys $ MV.readMVar mvar - - let paths' = filter (/= "/") paths - let Just xml = I.toXML $ I.Object "/" [iface] - [I.Object p [] [] | p <- paths'] - replyReturn call' [T.toVariant xml] - -<>= - -- * Exporting local objects -, LocalObject (..) -, Interface (..) -, Member (..) -, export - -<>= -import qualified Data.Text.Lazy as TL - -<>= -newtype LocalObject = LocalObject (Map.Map T.InterfaceName Interface) -newtype Interface = Interface (Map.Map T.MemberName Member) -data Member - = Method T.Signature T.Signature (MethodCall -> IO ()) - | Signal T.Signature - -<>= --- | Export a set of interfaces on the bus. Whenever a method call is --- received which matches the object's path, interface, and member name, --- one of its members will be called. --- --- Exported objects automatically implement the --- @org.freedesktop.DBus.Introspectable@ interface. --- -export :: Client -> T.ObjectPath -> LocalObject -> IO () -export client@(Client _ _ _ mvar _) path obj = MV.modifyMVar_ mvar $ - return . Map.insert path (onMethodCall client (addIntrospectable path obj)) - -<>= -addIntrospectable :: T.ObjectPath -> LocalObject -> LocalObject -addIntrospectable path (LocalObject ifaces) = LocalObject ifaces' where - ifaces' = Map.insertWith (\_ x -> x) name iface ifaces - name = "org.freedesktop.DBus.Introspectable" - iface = Interface $ Map.fromList [("Introspect", impl)] - impl = Method "" "s" $ \call' -> do - let Just xml = I.toXML . introspect path . methodCallObject $ call' - replyReturn call' [T.toVariant xml] - -<>= -introspect :: T.ObjectPath -> LocalObject -> I.Object -introspect path obj = I.Object path interfaces [] where - LocalObject ifaceMap = obj - interfaces = map introspectIface (Map.toList ifaceMap) - - introspectIface :: (T.InterfaceName, Interface) -> I.Interface - introspectIface (name, iface) = I.Interface name methods signals [] where - Interface memberMap = iface - members = Map.toList memberMap - methods = concatMap introspectMethod members - signals = concatMap introspectSignal members - - introspectMethod :: (T.MemberName, Member) -> [I.Method] - introspectMethod (name, (Method inSig outSig _)) = [I.Method name - (map introspectParam (T.signatureTypes inSig)) - (map introspectParam (T.signatureTypes outSig))] - introspectMethod _ = [] - - introspectSignal :: (T.MemberName, Member) -> [I.Signal] - introspectSignal (name, (Signal sig)) = [I.Signal name - (map introspectParam (T.signatureTypes sig))] - introspectSignal _ = [] - - introspectParam = I.Parameter "" . T.mkSignature_ . T.typeCode - -@ \subsection{Responding to method calls} - -<>= -data MethodCall = MethodCall - { methodCallObject :: LocalObject - , methodCallClient :: Client - , methodCallMethod :: Member - , methodCallSerial :: M.Serial - , methodCallSender :: Maybe T.BusName - , methodCallFlags :: Set.Set M.Flag - , methodCallBody :: [T.Variant] - } - -@ Technically method calls don't have to specify an interface if there's only -one available in the destination object, but that'll never be the case here, -so treat an unspecified interface as unknown. - -<>= -findMember :: M.MethodCall -> LocalObject -> Maybe Member -findMember call' (LocalObject ifaces) = do - iface <- M.methodCallInterface call' - Interface members <- Map.lookup iface ifaces - Map.lookup (M.methodCallMember call') members - -<>= -onMethodCall :: Client -> LocalObject -> M.ReceivedMessage -> IO () -onMethodCall client obj msg = do - let M.ReceivedMethodCall serial sender call' = msg - sigStr = TL.concat . map (T.typeCode . T.variantType) - . M.methodCallBody $ call' - sig = T.mkSignature_ sigStr - - case findMember call' obj of - Just method@(Method inSig _ x) -> let - call'' = MethodCall obj client method - serial sender - (M.methodCallFlags call') - (M.methodCallBody call') - invalidArgs = replyError call'' Const.errorInvalidArgs [] - in if inSig == sig - then x call'' - else invalidArgs - _ -> unknownMethod client msg - - -<>= --- | Send a successful return reply for a method call. --- -replyReturn :: MethodCall -> [T.Variant] -> IO () -replyReturn call' body = reply where - replyInvalid = M.Error - Const.errorFailed - (methodCallSerial call') - (methodCallSender call') - [T.toVariant $ TL.pack "Method return didn't match signature."] - - replyValid = M.MethodReturn - (methodCallSerial call') - (methodCallSender call') - body - - sendReply :: M.Message a => a -> IO () - sendReply = sendOnly_ (methodCallClient call') - - sigStr = TL.concat . map (T.typeCode . T.variantType) $ body - (Method _ outSig _) = methodCallMethod call' - reply = if T.mkSignature sigStr == Just outSig - then sendReply replyValid - else sendReply replyInvalid - -<>= --- | Send an error reply for a method call. --- -replyError :: MethodCall -> T.ErrorName -> [T.Variant] -> IO () -replyError call' name body = sendOnly_ c reply where - c = methodCallClient call' - reply = M.Error - name - (methodCallSerial call') - (methodCallSender call') - body - -<>= - -- ** Responding to method calls -, MethodCall (..) -, replyReturn -, replyError - -@ \end{document} diff --git a/hs/DBus/Client.hs b/hs/DBus/Client.hs --- a/hs/DBus/Client.hs +++ b/hs/DBus/Client.hs @@ -1,457 +1,491 @@ -{- - Copyright (C) 2009 John Millikin - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . --} - +-- Copyright (C) 2009 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . {-# LANGUAGE OverloadedStrings #-} -module DBus.Client - ( -- * Clients - Client - , clientName - - , mkClient - - -- ** Sending messages - , call - , callBlocking - , callBlocking_ - - -- *** Emitting signals - , emitSignal - - -- * Name reservation - , requestName - , releaseName - - -- * Receiving signals - , onSignal - - -- * Remote objects and proxies - , RemoteObject (..) - , Proxy (..) - - , callProxy - , callProxyBlocking - , callProxyBlocking_ - - , onSignalFrom - - -- * Exporting local objects - , LocalObject (..) - , Interface (..) - , Member (..) - , export - - -- ** Responding to method calls - , MethodCall (..) - , replyReturn - , replyError +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +module DBus.Client ( + module DBus.Bus + , module DBus.Types + , module DBus.Message + -- * Clients + , Client + , C.Connection + , clientName + , newClient + , DBus + , DBusException + , runDBus + , getClient + , processMessage + , send + , send_ + , receive + , mainLoop + , call + , callBlocking + , callBlocking_ + -- * Handling signals + , onSignal + -- * Name reservation + , NR.RequestNameFlag (..) + , NR.RequestNameReply (..) + , NR.ReleaseNameReply (..) + , requestName + , releaseName + , requestName_ + , releaseName_ + -- * Exporting local objects + , Object (..) + , Interface (..) + , Member (..) + , Method (..) + , export + , object + , interface + , method + -- ** Responding to method calls + , MethodCtx (..) + , replyReturn + , replyError + , Proxy (..) + , callProxy + , callProxyBlocking + , callProxyBlocking_ + , onProxySignal + ) where +import DBus.Bus +import DBus.Types +import DBus.Message - ) where -import qualified Control.Concurrent.MVar as MV -import qualified Data.Map as Map import qualified DBus.Connection as C +import qualified DBus.Constants as Const +import qualified DBus.Introspection as I +import qualified DBus.MatchRule as MR import qualified DBus.Message as M +import qualified DBus.NameReservation as NR import qualified DBus.Types as T - -import Control.Concurrent (forkIO) -import Control.Monad (forever) -import qualified Data.Set as Set -import qualified DBus.Constants as Const - +import qualified DBus.Wire as W +import qualified Control.Concurrent.MVar as MV +import qualified Data.Map as Map +import Control.Monad (liftM, ap, forever) +import Control.Monad.IO.Class (liftIO) +import qualified Control.Monad.IO.Class as MIO +import qualified Control.Monad.Reader as R +import qualified Control.Applicative as A +import Data.Typeable (Typeable) +import qualified Control.Exception as Exc +import qualified Control.Monad.Error as E import Data.Maybe (isJust) - -import qualified DBus.NameReservation as NR - -import qualified DBus.MatchRule as MR -import Data.Maybe (fromJust) - -import qualified DBus.Introspection as I - -import qualified Data.Text.Lazy as TL - - -type Callback = (M.ReceivedMessage -> IO ()) - +import qualified Data.Set as Set +import Data.Monoid (mconcat) -- | 'Client's are opaque handles to an open connection and other internal -- state. --- -data Client = Client C.Connection T.BusName - (MV.MVar (Map.Map M.Serial Callback)) - (MV.MVar (Map.Map T.ObjectPath Callback)) - (MV.MVar [Callback]) - -clientConnection :: Client -> C.Connection -clientConnection (Client x _ _ _ _) = x - -clientName :: Client -> T.BusName -clientName (Client _ x _ _ _) = x - +data Client = Client + { clientConnection :: C.Connection + , clientName :: T.BusName + , clientCallbacks :: MV.MVar (Map.Map M.Serial MessageHandler) + , clientObjects :: MV.MVar (Map.Map T.ObjectPath Object) + , clientSignalHandlers :: MV.MVar [MessageHandler] + } +type MessageHandler = (M.ReceivedMessage -> DBus ()) -- | Create a new 'Client' from an open connection and bus name. The weird - --- signature allows 'mkClient' to use the computations in "DBus.Bus" +-- signature allows @newClient@ to use the computations in "DBus.Bus" -- directly, without unpacking: --- +-- -- @ --- client <- mkClient =<< getSessionBus +-- client <- newClient =<< 'getSessionBus' -- @ --- +-- -- Only one client should be created for any given connection. Otherwise, -- they will compete to receive messages. --- -mkClient :: (C.Connection, T.BusName) -> IO Client -mkClient (c, name) = do - replies <- MV.newMVar Map.empty - exports <- MV.newMVar Map.empty - signals <- MV.newMVar [] - let client = Client c name replies exports signals - forkIO $ forever (receiveMessages client) +newClient :: (C.Connection, T.BusName) -> IO Client +newClient (c, name) = do + callbacks <- MV.newMVar Map.empty + objects <- MV.newMVar Map.empty + signals <- MV.newMVar [] + let client = Client c name callbacks objects signals + liftIO $ MV.modifyMVar_ objects $ return . Map.insert "/" rootObject + return client +newtype DBus a = DBus { unDBus :: R.ReaderT Client IO a } - export client ("/") rootObject +instance Monad DBus where + return = DBus . return + (>>=) (DBus m) f = DBus $ m >>= unDBus . f - return client +instance MIO.MonadIO DBus where + liftIO = DBus . MIO.liftIO -send_ :: M.Message a => Client -> (M.Serial -> IO b) -> a -> IO b -send_ c f msg = do - result <- C.send (clientConnection c) f msg - case result of - Left x -> error $ show x - Right x -> return x +instance Functor DBus where + fmap = liftM -sendOnly_ :: M.Message a => Client -> a -> IO () -sendOnly_ c = send_ c (const $ return ()) +instance A.Applicative DBus where + pure = return + (<*>) = ap +data DBusException + = MarshalFailed W.MarshalError + | UnmarshalFailed W.UnmarshalError + | MethodCallFailed M.Error + | InvalidRequestNameReply M.MethodReturn + | InvalidReleaseNameReply M.MethodReturn + deriving (Show, Eq, Typeable) +instance Exc.Exception DBusException +instance E.MonadError DBus where + type E.ErrorType DBus = DBusException + throwError = MIO.liftIO . Exc.throwIO + catchError dbus h = do + c <- getClient + liftIO $ Exc.catch + (runDBus c dbus) + (runDBus c . h) +-- | Run a DBus computation with the given client callbacks. Errors +-- encountered while running will be thrown as exceptions, using the +-- 'DBusException' type. +-- +-- Use the 'E.MonadError' instance for 'DBus' to handle errors inside +-- the computation. +runDBus :: Client -> DBus a -> IO a +runDBus c (DBus m) = R.runReaderT m c +getClient :: DBus Client +getClient = DBus R.ask + +getConnection :: DBus C.Connection +getConnection = fmap clientConnection getClient +-- | Run message handlers with the received message. If any method reply +-- callbacks or signal handlers are found, they will be run in the current +-- thread. +processMessage :: M.ReceivedMessage -> DBus () +processMessage received = p received where + p (M.ReceivedUnknown _ _ _) = return () + p (M.ReceivedMethodReturn _ _ msg) = reply $ M.methodReturnSerial msg + p (M.ReceivedError _ _ msg) = reply $ M.errorSerial msg + p (M.ReceivedSignal _ _ _) = do + mvar <- fmap clientSignalHandlers getClient + handlers <- liftIO $ MV.readMVar mvar + mapM_ ($ received) handlers + p (M.ReceivedMethodCall _ _ msg) = do + mvar <- fmap clientObjects getClient + objects <- liftIO $ MV.readMVar mvar + case findMethod objects msg of + Just (obj, m) -> onMethodCall obj m received + Nothing -> unknownMethod received + reply s = onReply s received +-- | A wrapper around 'C.send'. +send :: M.Message msg => (M.Serial -> DBus a) -> msg -> DBus a +send onSerial msg = do + c <- getConnection + client <- getClient + sent <- liftIO $ C.send c (runDBus client . onSerial) msg + case sent of + Left err -> E.throwError $ MarshalFailed err + Right a -> return a + +-- | A wrapper around 'C.send', which does not allow the message serial +-- to be recorded. This is a useful shortcut when sending messages which +-- are not expected to receive a reply. +send_ :: M.Message msg => msg -> DBus () +send_ = send (const $ return ()) +-- | A wrapper around 'C.receive'. +receive :: DBus M.ReceivedMessage +receive = do + c <- getConnection + parsed <- liftIO $ C.receive c + case parsed of + Left err -> E.throwError $ UnmarshalFailed err + Right msg -> return msg +-- | Run in a loop forever, processing messages. +-- +-- This is commonly run in a separate thread, ie +-- +-- > client <- newClient =<< getSessionBus +-- > forkIO $ runDBus client mainLoop +mainLoop :: DBus () +mainLoop = forever $ receive >>= processMessage -- | Perform an asynchronous method call. One of the provided computations -- will be performed depending on what message type the destination sends -- back. --- -call :: Client -> M.MethodCall - -> (M.Error -> IO ()) - -> (M.MethodReturn -> IO ()) - -> IO () -call client msg onError onReturn = send_ client addCallback msg where - Client _ _ mvar _ _ = client - addCallback s = MV.modifyMVar_ mvar $ return . Map.insert s callback - - callback (M.ReceivedError _ _ msg') = onError msg' - callback (M.ReceivedMethodReturn _ _ msg') = onReturn msg' - callback _ = return () - --- | Similar to 'call', except that it waits for the reply and returns it --- in the current 'IO' thread. --- -callBlocking :: Client -> M.MethodCall -> IO (Either M.Error M.MethodReturn) -callBlocking client msg = do - mvar <- MV.newEmptyMVar - call client msg - (MV.putMVar mvar . Left) - (MV.putMVar mvar . Right) - MV.takeMVar mvar - --- | Similar to 'callBlocking', except that an exception is raised if the --- destination sends back an error. --- -callBlocking_ :: Client -> M.MethodCall -> IO M.MethodReturn -callBlocking_ client msg = do - reply <- callBlocking client msg - case reply of - Left x -> error . TL.unpack . M.errorMessage $ x - Right x -> return x - -emitSignal :: Client -> M.Signal -> IO () -emitSignal = sendOnly_ - -receiveMessages :: Client -> IO () -receiveMessages client = do - received <- C.receive $ clientConnection client - case received of - Left x -> error $ show x - Right x -> handleMessage client x - -handleMessage :: Client -> M.ReceivedMessage -> IO () -handleMessage client msg@(M.ReceivedMethodCall _ _ call') = do - let Client _ _ _ mvar _ = client - objects <- MV.readMVar mvar - case Map.lookup (M.methodCallPath call') objects of - Just x -> x msg - Nothing -> unknownMethod client msg - -handleMessage c msg@(M.ReceivedMethodReturn _ _ msg') = - gotReply c (M.methodReturnSerial msg') msg -handleMessage c msg@(M.ReceivedError _ _ msg') = - gotReply c (M.errorSerial msg') msg - -handleMessage c msg@(M.ReceivedSignal _ _ _) = let - Client _ _ _ _ mvar = c - in MV.withMVar mvar $ mapM_ (\cb -> forkIO (cb msg)) - -handleMessage _ _ = return () - -unknownMethod :: Client -> M.ReceivedMessage -> IO () -unknownMethod client msg = sendOnly_ client errorMsg where - M.ReceivedMethodCall serial sender _ = msg - errorMsg = M.Error - Const.errorUnknownMethod - serial sender - [] - -gotReply :: Client -> M.Serial -> M.ReceivedMessage -> IO () -gotReply (Client _ _ mvar _ _) serial msg = do - callback <- MV.modifyMVar mvar $ \callbacks -> let - x = Map.lookup serial callbacks - callbacks' = if isJust x - then Map.delete serial callbacks - else callbacks - in return (callbacks', x) - case callback of - Just x -> forkIO (x msg) >> return () - Nothing -> return () - --- | A client can request a \"well-known\" name from the bus. This allows --- messages sent to that name to be received by the client, without senders --- being aware of which application is actually handling requests. --- --- A name may be requested for any client, using the given flags. The bus's --- reply will be returned, or an exception raised if the reply was invalid. --- -requestName :: Client -> T.BusName -> [NR.RequestNameFlag] - -> IO NR.RequestNameReply -requestName client name flags = do - reply <- callBlocking_ client $ NR.requestName name flags - case NR.mkRequestNameReply reply of - Nothing -> error $ "Invalid reply to RequestName" - Just x -> return x - --- | Clients may also release names they've requested. --- -releaseName :: Client -> T.BusName -> IO NR.ReleaseNameReply -releaseName client name = do - reply <- callBlocking_ client $ NR.releaseName name - case NR.mkReleaseNameReply reply of - Nothing -> error $ "Invalid reply to ReleaseName" - Just x -> return x +call :: M.MethodCall + -> (M.Error -> DBus ()) + -> (M.MethodReturn -> DBus ()) + -> DBus () +call msg onError onReturn = send addCallback msg where + cb (M.ReceivedError _ _ msg') = onError msg' + cb (M.ReceivedMethodReturn _ _ msg') = onReturn msg' + cb _ = return () + + addCallback s = do + mvar <- fmap clientCallbacks getClient + liftIO $ MV.modifyMVar_ mvar $ return . Map.insert s cb +onReply :: M.Serial -> M.ReceivedMessage -> DBus () +onReply serial msg = do + mvar <- fmap clientCallbacks getClient + maybeCB <- liftIO $ MV.modifyMVar mvar $ \callbacks -> let + x = Map.lookup serial callbacks + callbacks' = if isJust x + then Map.delete serial callbacks + else callbacks + in return (callbacks', x) + case maybeCB of + Just cb -> cb msg + Nothing -> return () +-- | Sends a method call, and then blocks until a reply is received. Use +-- this when the receive/process loop is running in a separate thread. +callBlocking :: M.MethodCall -> DBus (Either M.Error M.MethodReturn) +callBlocking msg = do + mvar <- liftIO $ MV.newEmptyMVar + call msg + (liftIO . MV.putMVar mvar . Left) + (liftIO . MV.putMVar mvar . Right) + liftIO $ MV.takeMVar mvar +-- | A variant of 'callBlocking', which throws an exception if the +-- remote client returns 'M.Error'. +callBlocking_ :: M.MethodCall -> DBus M.MethodReturn +callBlocking_ msg = do + reply <- callBlocking msg + case reply of + Left err -> E.throwError $ MethodCallFailed err + Right x -> return x -- | Perform some computation every time this client receives a matching -- signal. --- -onSignal :: Client -> MR.MatchRule - -> (T.BusName -> M.Signal -> IO ()) - -> IO () -onSignal client rule callback = let - (Client _ _ _ _ mvar) = client - rule' = rule { MR.matchType = Just MR.Signal } - - callback' msg@(M.ReceivedSignal _ sender signal) - | MR.matches rule' msg = callback (fromJust sender) signal - callback' _ = return () - - in do - callBlocking_ client $ MR.addMatch rule' - MV.modifyMVar_ mvar $ return . (callback' :) - -data RemoteObject = RemoteObject T.BusName T.ObjectPath -data Proxy = Proxy RemoteObject T.InterfaceName - -buildMethodCall :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] - -> M.MethodCall -buildMethodCall proxy name flags body = msg where - Proxy (RemoteObject dest path) iface = proxy - msg = M.MethodCall path name (Just iface) (Just dest) - (Set.fromList flags) body - --- | As 'call', except that the proxy's information is used to --- build the message. --- -callProxy :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] - -> (M.Error -> IO ()) - -> (M.MethodReturn -> IO ()) - -> IO () -callProxy client proxy name flags body onError onReturn = let - msg = buildMethodCall proxy name flags body - in call client msg onError onReturn - --- | As 'callBlocking', except that the proxy's information is used --- to build the message. --- -callProxyBlocking :: Client -> Proxy -> T.MemberName -> [M.Flag] - -> [T.Variant] - -> IO (Either M.Error M.MethodReturn) -callProxyBlocking client proxy name flags body = - callBlocking client $ buildMethodCall proxy name flags body - --- | As 'callBlocking_', except that the proxy's information is used --- to build the message. --- -callProxyBlocking_ :: Client -> Proxy -> T.MemberName -> [M.Flag] - -> [T.Variant] - -> IO M.MethodReturn -callProxyBlocking_ client proxy name flags body = - callBlocking_ client $ buildMethodCall proxy name flags body - -onSignalFrom :: Client -> Proxy -> T.MemberName -> (M.Signal -> IO ()) - -> IO () -onSignalFrom client proxy member io = onSignal client rule io' where - Proxy (RemoteObject dest path) iface = proxy - rule = MR.MatchRule - { MR.matchType = Nothing - , MR.matchSender = Just dest - , MR.matchInterface = Just iface - , MR.matchMember = Just member - , MR.matchPath = Just path - , MR.matchDestination = Nothing - , MR.matchParameters = [] - } - io' _ msg = io msg - -rootObject :: LocalObject -rootObject = LocalObject $ Map.fromList [(ifaceName, interface)] where - ifaceName = "org.freedesktop.DBus.Introspectable" - memberName = "Introspect" - interface = Interface $ Map.fromList [(memberName, impl)] - - method = I.Method memberName [] [I.Parameter "xml" "s"] - iface = I.Interface ifaceName [method] [] [] - - impl = Method "" "s" $ \call' -> do - let Client _ _ _ mvar _ = methodCallClient call' - paths <- fmap Map.keys $ MV.readMVar mvar - - let paths' = filter (/= "/") paths - let Just xml = I.toXML $ I.Object "/" [iface] - [I.Object p [] [] | p <- paths'] - replyReturn call' [T.toVariant xml] - -newtype LocalObject = LocalObject (Map.Map T.InterfaceName Interface) +onSignal :: MR.MatchRule + -> (T.BusName -> M.Signal -> DBus ()) + -> DBus () +onSignal rule h = addHandler where + rule' = rule { MR.matchType = Just MR.Signal } + + handler msg@(M.ReceivedSignal _ (Just sender) signal) + | MR.matches rule' msg = h sender signal + handler _ = return () + + addHandler = do + callBlocking_ $ MR.addMatch rule' + mvar <- fmap clientSignalHandlers getClient + liftIO $ MV.modifyMVar_ mvar $ return . (handler :) +requestName :: T.BusName + -> [NR.RequestNameFlag] + -> (M.Error -> DBus ()) + -> (NR.RequestNameReply -> DBus ()) + -> DBus () +requestName name flags onError callback = + call (NR.requestName name flags) onError $ \reply -> + case NR.mkRequestNameReply reply of + Nothing -> E.throwError $ InvalidRequestNameReply reply + Just x -> callback x +releaseName :: T.BusName + -> (M.Error -> DBus ()) + -> (NR.ReleaseNameReply -> DBus ()) + -> DBus () +releaseName name onError callback = + call (NR.releaseName name) onError $ \reply -> + case NR.mkReleaseNameReply reply of + Nothing -> E.throwError $ InvalidReleaseNameReply reply + Just x -> callback x +requestName_ :: T.BusName -> [NR.RequestNameFlag] -> DBus NR.RequestNameReply +requestName_ name flags = do + reply <- callBlocking_ $ NR.requestName name flags + case NR.mkRequestNameReply reply of + Nothing -> E.throwError $ InvalidRequestNameReply reply + Just x -> return x +releaseName_ :: T.BusName -> DBus NR.ReleaseNameReply +releaseName_ name = do + reply <- callBlocking_ $ NR.releaseName name + case NR.mkReleaseNameReply reply of + Nothing -> E.throwError $ InvalidReleaseNameReply reply + Just x -> return x +newtype Object = Object (Map.Map T.InterfaceName Interface) newtype Interface = Interface (Map.Map T.MemberName Member) data Member - = Method T.Signature T.Signature (MethodCall -> IO ()) - | Signal T.Signature - + = MemberMethod Method + | MemberSignal T.Signature +data Method = Method T.Signature T.Signature (MethodCtx -> DBus ()) -- | Export a set of interfaces on the bus. Whenever a method call is -- received which matches the object's path, interface, and member name, -- one of its members will be called. --- +-- -- Exported objects automatically implement the -- @org.freedesktop.DBus.Introspectable@ interface. --- -export :: Client -> T.ObjectPath -> LocalObject -> IO () -export client@(Client _ _ _ mvar _) path obj = MV.modifyMVar_ mvar $ - return . Map.insert path (onMethodCall client (addIntrospectable path obj)) - -addIntrospectable :: T.ObjectPath -> LocalObject -> LocalObject -addIntrospectable path (LocalObject ifaces) = LocalObject ifaces' where - ifaces' = Map.insertWith (\_ x -> x) name iface ifaces - name = "org.freedesktop.DBus.Introspectable" - iface = Interface $ Map.fromList [("Introspect", impl)] - impl = Method "" "s" $ \call' -> do - let Just xml = I.toXML . introspect path . methodCallObject $ call' - replyReturn call' [T.toVariant xml] - -introspect :: T.ObjectPath -> LocalObject -> I.Object -introspect path obj = I.Object path interfaces [] where - LocalObject ifaceMap = obj - interfaces = map introspectIface (Map.toList ifaceMap) - - introspectIface :: (T.InterfaceName, Interface) -> I.Interface - introspectIface (name, iface) = I.Interface name methods signals [] where - Interface memberMap = iface - members = Map.toList memberMap - methods = concatMap introspectMethod members - signals = concatMap introspectSignal members - - introspectMethod :: (T.MemberName, Member) -> [I.Method] - introspectMethod (name, (Method inSig outSig _)) = [I.Method name - (map introspectParam (T.signatureTypes inSig)) - (map introspectParam (T.signatureTypes outSig))] - introspectMethod _ = [] - - introspectSignal :: (T.MemberName, Member) -> [I.Signal] - introspectSignal (name, (Signal sig)) = [I.Signal name - (map introspectParam (T.signatureTypes sig))] - introspectSignal _ = [] - - introspectParam = I.Parameter "" . T.mkSignature_ . T.typeCode - -data MethodCall = MethodCall - { methodCallObject :: LocalObject - , methodCallClient :: Client - , methodCallMethod :: Member - , methodCallSerial :: M.Serial - , methodCallSender :: Maybe T.BusName - , methodCallFlags :: Set.Set M.Flag - , methodCallBody :: [T.Variant] - } - -findMember :: M.MethodCall -> LocalObject -> Maybe Member -findMember call' (LocalObject ifaces) = do - iface <- M.methodCallInterface call' - Interface members <- Map.lookup iface ifaces - Map.lookup (M.methodCallMember call') members +export :: T.ObjectPath -> Object -> DBus () +export path obj = do + let obj' = addIntrospectable path obj + mvar <- fmap clientObjects getClient + liftIO $ MV.modifyMVar_ mvar $ return . Map.insert path obj' +object :: [(T.InterfaceName, Interface)] -> Object +object = Object . Map.fromList -onMethodCall :: Client -> LocalObject -> M.ReceivedMessage -> IO () -onMethodCall client obj msg = do - let M.ReceivedMethodCall serial sender call' = msg - sigStr = TL.concat . map (T.typeCode . T.variantType) - . M.methodCallBody $ call' - sig = T.mkSignature_ sigStr - - case findMember call' obj of - Just method@(Method inSig _ x) -> let - call'' = MethodCall obj client method - serial sender - (M.methodCallFlags call') - (M.methodCallBody call') - invalidArgs = replyError call'' Const.errorInvalidArgs [] - in if inSig == sig - then x call'' - else invalidArgs - _ -> unknownMethod client msg - +interface :: [(T.MemberName, Member)] -> Interface +interface = Interface . Map.fromList +method :: T.Signature -- ^ Input signature + -> T.Signature -- ^ Output signature + -> (MethodCtx -> DBus ()) -- ^ Implementation + -> Member +method inSig outSig cb = MemberMethod $ Method inSig outSig cb +data MethodCtx = MethodCtx + { methodCtxObject :: Object + , methodCtxMethod :: Method + , methodCtxSerial :: M.Serial + , methodCtxSender :: Maybe T.BusName + , methodCtxFlags :: Set.Set M.Flag + , methodCtxBody :: [T.Variant] + } -- | Send a successful return reply for a method call. --- -replyReturn :: MethodCall -> [T.Variant] -> IO () -replyReturn call' body = reply where - replyInvalid = M.Error - Const.errorFailed - (methodCallSerial call') - (methodCallSender call') - [T.toVariant $ TL.pack "Method return didn't match signature."] - - replyValid = M.MethodReturn - (methodCallSerial call') - (methodCallSender call') - body - - sendReply :: M.Message a => a -> IO () - sendReply = sendOnly_ (methodCallClient call') - - sigStr = TL.concat . map (T.typeCode . T.variantType) $ body - (Method _ outSig _) = methodCallMethod call' - reply = if T.mkSignature sigStr == Just outSig - then sendReply replyValid - else sendReply replyInvalid - --- | Send an error reply for a method call. --- -replyError :: MethodCall -> T.ErrorName -> [T.Variant] -> IO () -replyError call' name body = sendOnly_ c reply where - c = methodCallClient call' - reply = M.Error - name - (methodCallSerial call') - (methodCallSender call') - body - +replyReturn :: MethodCtx -> [T.Variant] -> DBus () +replyReturn call' body = if valid then sendReply else sendError where + sendError = replyError call' Const.errorFailed + [T.toVariant ("Method return didn't match signature." :: String)] + + sendReply = send_ $ M.MethodReturn + (methodCtxSerial call') + (methodCtxSender call') + body + + (Method _ outSig _) = methodCtxMethod call' + valid = listSig body == Just outSig +replyError :: MethodCtx -> T.ErrorName -> [T.Variant] -> DBus () +replyError call' name body = send_ $ M.Error + name + (methodCtxSerial call') + (methodCtxSender call') + body +unknownMethod :: M.ReceivedMessage -> DBus () +unknownMethod msg = send_ errorMsg where + M.ReceivedMethodCall serial sender _ = msg + errorMsg = M.Error + Const.errorUnknownMethod + serial sender + [] +findMethod :: Map.Map T.ObjectPath Object -> M.MethodCall -> Maybe (Object, Method) +findMethod objects call' = do + Object obj <- Map.lookup (M.methodCallPath call') objects + ifaceName <- M.methodCallInterface call' + Interface iface <- Map.lookup ifaceName obj + member <- Map.lookup (M.methodCallMember call') iface + case member of + MemberMethod m -> return (Object obj, m) + _ -> Nothing +onMethodCall :: Object -> Method -> M.ReceivedMessage -> DBus () +onMethodCall obj method' received = runCall where + M.ReceivedMethodCall serial sender msg = received + sig = listSig $ M.methodCallBody msg + Method inSig _ cb = method' + + call' = MethodCtx obj method' serial sender + (M.methodCallFlags msg) + (M.methodCallBody msg) + + runCall = if sig == Just inSig + then cb call' + else replyError call' Const.errorInvalidArgs [] +addIntrospectable :: T.ObjectPath -> Object -> Object +addIntrospectable path (Object ifaces) = Object ifaces' where + ifaces' = Map.insertWith (\_ x -> x) name iface ifaces + name = Const.interfaceIntrospectable + iface = interface [("Introspect", impl)] + impl = method "" "s" $ \call' -> do + let Just xml = I.toXML . introspect path . methodCtxObject $ call' + replyReturn call' [T.toVariant xml] +introspect :: T.ObjectPath -> Object -> I.Object +introspect path obj = I.Object path interfaces [] where + Object ifaceMap = obj + interfaces = map introspectIface (Map.toList ifaceMap) + + introspectIface :: (T.InterfaceName, Interface) -> I.Interface + introspectIface (name, iface) = I.Interface name methods signals [] where + Interface memberMap = iface + members = Map.toList memberMap + methods = concatMap introspectMethod members + signals = concatMap introspectSignal members + + introspectMethod :: (T.MemberName, Member) -> [I.Method] + introspectMethod (name, (MemberMethod (Method inSig outSig _))) = + [I.Method name + (map introspectParam (T.signatureTypes inSig)) + (map introspectParam (T.signatureTypes outSig))] + introspectMethod _ = [] + + introspectSignal :: (T.MemberName, Member) -> [I.Signal] + introspectSignal (name, (MemberSignal sig)) = [I.Signal name + (map introspectParam (T.signatureTypes sig))] + introspectSignal _ = [] + + introspectParam = I.Parameter "" . T.mkSignature_ . T.typeCode +rootObject :: Object +rootObject = object [(ifaceName, interface [(memberName, impl)])] where + ifaceName = Const.interfaceIntrospectable + memberName = "Introspect" + + methodXML = I.Method memberName [] [I.Parameter "xml" "s"] + ifaceXML = I.Interface ifaceName [methodXML] [] [] + + impl = method "" "s" $ \call' -> do + mvar <- fmap clientObjects getClient + paths <- liftIO $ fmap Map.keys $ MV.readMVar mvar + + let paths' = filter (/= "/") paths + let Just xml = I.toXML $ I.Object "/" [ifaceXML] + [I.Object p [] [] | p <- paths'] + replyReturn call' [T.toVariant xml] +data Proxy = Proxy + { proxyName :: T.BusName + , proxyObjectPath :: T.ObjectPath + , proxyInterface :: T.InterfaceName + } + deriving (Show, Eq) +-- | As 'call', except that the proxy's information is used to +-- build the message. +callProxy :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] + -> (M.Error -> DBus ()) + -> (M.MethodReturn -> DBus ()) + -> DBus () +callProxy proxy name flags body onError onReturn = let + msg = buildMethodCall proxy name flags body + in call msg onError onReturn +-- | As 'callBlocking', except that the proxy's information is used +-- to build the message. +callProxyBlocking :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] + -> DBus (Either M.Error M.MethodReturn) +callProxyBlocking proxy name flags body = + callBlocking $ buildMethodCall proxy name flags body +-- | As 'callBlocking_', except that the proxy's information is used +-- to build the message. +callProxyBlocking_ :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] + -> DBus M.MethodReturn +callProxyBlocking_ proxy name flags body = + callBlocking_ $ buildMethodCall proxy name flags body +-- | As 'onSIgnal', except that the proxy's information is used +-- to build the match rule. +onProxySignal :: Proxy -> T.MemberName -> (M.Signal -> DBus ()) + -> DBus () +onProxySignal proxy member handler = onSignal rule handler' where + Proxy dest path iface = proxy + rule = MR.MatchRule + { MR.matchType = Nothing + , MR.matchSender = Just dest + , MR.matchInterface = Just iface + , MR.matchMember = Just member + , MR.matchPath = Just path + , MR.matchDestination = Nothing + , MR.matchParameters = [] + } + handler' _ msg = handler msg +buildMethodCall :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant] + -> M.MethodCall +buildMethodCall proxy name flags body = msg where + Proxy dest path iface = proxy + msg = M.MethodCall path name (Just iface) (Just dest) + (Set.fromList flags) body +listSig :: [T.Variant] -> Maybe T.Signature +listSig = T.mkSignature . mconcat . map (T.typeCode . T.variantType)