dbus-client 0.4.0.3 → 0.4.0.4

raw patch · 3 files changed

+115/−9 lines, 3 filesdep ~textPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: text

API changes (from Hackage documentation)

Files

• dbus-client.anansi +1/−1
• dbus-client.cabal +3/−7
• hs/DBus/Client.hs +111/−1

@@ -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 :) :

@@ -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 

@@ -1,3 +1,5 @@++ -- Copyright (C) 2009 John Millikin <jmillikin@gmail.com> --  -- 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 <http://www.gnu.org/licenses/>.++ {-# 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)