diff --git a/dbus-client.anansi b/dbus-client.anansi --- a/dbus-client.anansi +++ b/dbus-client.anansi @@ -423,7 +423,7 @@ handler _ = return () addHandler = do - callBlocking_ $ MR.addMatch rule' + (callBlocking_ (MR.addMatch rule')) >> return () mvar <- fmap clientSignalHandlers getClient liftIO $ MV.modifyMVar_ mvar $ return . (handler :) : diff --git a/dbus-client.cabal b/dbus-client.cabal --- a/dbus-client.cabal +++ b/dbus-client.cabal @@ -1,5 +1,5 @@ name: dbus-client -version: 0.4.0.3 +version: 0.4.0.4 synopsis: Monadic and object-oriented interfaces to DBus license: GPL-3 license-file: License.txt @@ -22,11 +22,7 @@ location: http://john-millikin.com/software/haskell-dbus/ library - if true - ghc-options: -Wall - - if impl(ghc >= 6.11) - ghc-options: -fno-warn-unused-do-bind + ghc-options: -Wall hs-source-dirs: hs @@ -34,7 +30,7 @@ base >= 4.0 && < 5 , dbus-core >= 0.8 && < 0.9 , containers >= 0.1 && < 0.5 - , text >= 0.7 && < 0.11 + , text >= 0.7 && < 0.12 , transformers >= 0.2 && < 0.3 , monads-tf >= 0.1 && < 0.2 diff --git a/hs/DBus/Client.hs b/hs/DBus/Client.hs --- a/hs/DBus/Client.hs +++ b/hs/DBus/Client.hs @@ -1,3 +1,5 @@ + + -- Copyright (C) 2009 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -12,32 +14,47 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . + + {-# LANGUAGE OverloadedStrings #-} + {-# 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 (..) @@ -46,25 +63,32 @@ , 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 @@ -77,21 +101,31 @@ import qualified DBus.NameReservation as NR import qualified DBus.Types as T 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 Data.Set as Set + import Data.Monoid (mconcat) + + -- | 'Client's are opaque handles to an open connection and other internal -- state. + data Client = Client { clientConnection :: C.Connection , clientName :: T.BusName @@ -100,6 +134,8 @@ , clientSignalHandlers :: MV.MVar [MessageHandler] } type MessageHandler = (M.ReceivedMessage -> DBus ()) + + -- | 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: @@ -110,14 +146,18 @@ -- -- Only one client should be created for any given connection. Otherwise, -- they will compete to receive messages. + 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 } instance Monad DBus where @@ -133,6 +173,7 @@ instance A.Applicative DBus where pure = return (<*>) = ap + data DBusException = MarshalFailed W.MarshalError | UnmarshalFailed W.UnmarshalError @@ -141,6 +182,7 @@ | 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 @@ -149,12 +191,15 @@ 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 @@ -163,26 +208,36 @@ 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 @@ -192,12 +247,17 @@ 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 @@ -205,17 +265,23 @@ 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 :: M.MethodCall -> (M.Error -> DBus ()) -> (M.MethodReturn -> DBus ()) @@ -228,6 +294,7 @@ 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 @@ -240,8 +307,11 @@ 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 @@ -250,16 +320,21 @@ (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 :: MR.MatchRule -> (T.BusName -> M.Signal -> DBus ()) -> DBus () @@ -271,9 +346,10 @@ handler _ = return () addHandler = do - callBlocking_ $ MR.addMatch rule' + (callBlocking_ (MR.addMatch rule')) >> return () mvar <- fmap clientSignalHandlers getClient liftIO $ MV.modifyMVar_ mvar $ return . (handler :) + requestName :: T.BusName -> [NR.RequestNameFlag] -> (M.Error -> DBus ()) @@ -284,6 +360,7 @@ case NR.mkRequestNameReply reply of Nothing -> E.throwError $ InvalidRequestNameReply reply Just x -> callback x + releaseName :: T.BusName -> (M.Error -> DBus ()) -> (NR.ReleaseNameReply -> DBus ()) @@ -293,35 +370,42 @@ 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 = 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 :: 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 @@ -333,6 +417,7 @@ -> (MethodCtx -> DBus ()) -- ^ Implementation -> Member method inSig outSig cb = MemberMethod $ Method inSig outSig cb + data MethodCtx = MethodCtx { methodCtxObject :: Object , methodCtxMethod :: Method @@ -341,7 +426,10 @@ , methodCtxFlags :: Set.Set M.Flag , methodCtxBody :: [T.Variant] } + + -- | Send a successful return reply for a method call. + replyReturn :: MethodCtx -> [T.Variant] -> DBus () replyReturn call' body = if valid then sendReply else sendError where sendError = replyError call' Const.errorFailed @@ -354,12 +442,14 @@ (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 @@ -367,6 +457,7 @@ 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 @@ -376,6 +467,7 @@ 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 @@ -389,6 +481,7 @@ 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 @@ -397,6 +490,7 @@ 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 @@ -422,6 +516,7 @@ introspectSignal _ = [] introspectParam = I.Parameter "" . T.mkSignature_ . T.typeCode + rootObject :: Object rootObject = object [(ifaceName, interface [(memberName, impl)])] where ifaceName = Const.interfaceIntrospectable @@ -438,14 +533,18 @@ 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 ()) @@ -453,20 +552,29 @@ 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 @@ -481,11 +589,13 @@ , 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)