-- Copyright (C) 2009 John Millikin <jmillikin@gmail.com>-- -- 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 <http://www.gnu.org/licenses/>.{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE DeriveDataTypeable #-}{-# LANGUAGE TypeFamilies #-}moduleDBus.Client(moduleDBus.Bus,moduleDBus.Types,moduleDBus.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)whereimportDBus.BusimportDBus.TypesimportDBus.MessageimportqualifiedDBus.ConnectionasCimportqualifiedDBus.ConstantsasConstimportqualifiedDBus.IntrospectionasIimportqualifiedDBus.MatchRuleasMRimportqualifiedDBus.MessageasMimportqualifiedDBus.NameReservationasNRimportqualifiedDBus.TypesasTimportqualifiedDBus.WireasWimportqualifiedControl.Concurrent.MVarasMVimportqualifiedData.MapasMapimportControl.Monad(liftM,ap,forever)importControl.Monad.IO.Class(liftIO)importqualifiedControl.Monad.IO.ClassasMIOimportqualifiedControl.Monad.ReaderasRimportqualifiedControl.ApplicativeasAimportData.Typeable(Typeable)importqualifiedControl.ExceptionasExcimportqualifiedControl.Monad.ErrorasEimportData.Maybe(isJust)importqualifiedData.SetasSetimportData.Monoid(mconcat)-- | 'Client's are opaque handles to an open connection and other internal-- state.dataClient=Client{clientConnection::C.Connection,clientName::T.BusName,clientCallbacks::MV.MVar(Map.MapM.SerialMessageHandler),clientObjects::MV.MVar(Map.MapT.ObjectPathObject),clientSignalHandlers::MV.MVar[MessageHandler]}typeMessageHandler=(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:---- @-- client <- newClient =<< 'getSessionBus'-- @---- Only one client should be created for any given connection. Otherwise,-- they will compete to receive messages.newClient::(C.Connection,T.BusName)->IOClientnewClient(c,name)=docallbacks<-MV.newMVarMap.emptyobjects<-MV.newMVarMap.emptysignals<-MV.newMVar[]letclient=ClientcnamecallbacksobjectssignalsliftIO$MV.modifyMVar_objects$return.Map.insert"/"rootObjectreturnclientnewtypeDBusa=DBus{unDBus::R.ReaderTClientIOa}instanceMonadDBuswherereturn=DBus.return(>>=)(DBusm)f=DBus$m>>=unDBus.finstanceMIO.MonadIODBuswhereliftIO=DBus.MIO.liftIOinstanceFunctorDBuswherefmap=liftMinstanceA.ApplicativeDBuswherepure=return(<*>)=apdataDBusException=MarshalFailedW.MarshalError|UnmarshalFailedW.UnmarshalError|MethodCallFailedM.Error|InvalidRequestNameReplyM.MethodReturn|InvalidReleaseNameReplyM.MethodReturnderiving(Show,Eq,Typeable)instanceExc.ExceptionDBusExceptioninstanceE.MonadErrorDBuswheretypeE.ErrorTypeDBus=DBusExceptionthrowError=MIO.liftIO.Exc.throwIOcatchErrordbush=doc<-getClientliftIO$Exc.catch(runDBuscdbus)(runDBusc.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->DBusa->IOarunDBusc(DBusm)=R.runReaderTmcgetClient::DBusClientgetClient=DBusR.askgetConnection::DBusC.ConnectiongetConnection=fmapclientConnectiongetClient-- | 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()processMessagereceived=preceivedwherep(M.ReceivedUnknown___)=return()p(M.ReceivedMethodReturn__msg)=reply$M.methodReturnSerialmsgp(M.ReceivedError__msg)=reply$M.errorSerialmsgp(M.ReceivedSignal___)=domvar<-fmapclientSignalHandlersgetClienthandlers<-liftIO$MV.readMVarmvarmapM_($received)handlersp(M.ReceivedMethodCall__msg)=domvar<-fmapclientObjectsgetClientobjects<-liftIO$MV.readMVarmvarcasefindMethodobjectsmsgofJust(obj,m)->onMethodCallobjmreceivedNothing->unknownMethodreceivedreplys=onReplysreceived-- | A wrapper around 'C.send'.send::M.Messagemsg=>(M.Serial->DBusa)->msg->DBusasendonSerialmsg=doc<-getConnectionclient<-getClientsent<-liftIO$C.sendc(runDBusclient.onSerial)msgcasesentofLefterr->E.throwError$MarshalFailederrRighta->returna-- | 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.Messagemsg=>msg->DBus()send_=send(const$return())-- | A wrapper around 'C.receive'.receive::DBusM.ReceivedMessagereceive=doc<-getConnectionparsed<-liftIO$C.receiveccaseparsedofLefterr->E.throwError$UnmarshalFailederrRightmsg->returnmsg-- | Run in a loop forever, processing messages.---- This is commonly run in a separate thread, ie---- > client <- newClient =<< getSessionBus-- > forkIO $ runDBus client mainLoopmainLoop::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())->DBus()callmsgonErroronReturn=sendaddCallbackmsgwherecb(M.ReceivedError__msg')=onErrormsg'cb(M.ReceivedMethodReturn__msg')=onReturnmsg'cb_=return()addCallbacks=domvar<-fmapclientCallbacksgetClientliftIO$MV.modifyMVar_mvar$return.Map.insertscbonReply::M.Serial->M.ReceivedMessage->DBus()onReplyserialmsg=domvar<-fmapclientCallbacksgetClientmaybeCB<-liftIO$MV.modifyMVarmvar$\callbacks->letx=Map.lookupserialcallbackscallbacks'=ifisJustxthenMap.deleteserialcallbackselsecallbacksinreturn(callbacks',x)casemaybeCBofJustcb->cbmsgNothing->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(EitherM.ErrorM.MethodReturn)callBlockingmsg=domvar<-liftIO$MV.newEmptyMVarcallmsg(liftIO.MV.putMVarmvar.Left)(liftIO.MV.putMVarmvar.Right)liftIO$MV.takeMVarmvar-- | A variant of 'callBlocking', which throws an exception if the-- remote client returns 'M.Error'.callBlocking_::M.MethodCall->DBusM.MethodReturncallBlocking_msg=doreply<-callBlockingmsgcasereplyofLefterr->E.throwError$MethodCallFailederrRightx->returnx-- | Perform some computation every time this client receives a matching-- signal.onSignal::MR.MatchRule->(T.BusName->M.Signal->DBus())->DBus()onSignalruleh=addHandlerwhererule'=rule{MR.matchType=JustMR.Signal}handlermsg@(M.ReceivedSignal_(Justsender)signal)|MR.matchesrule'msg=hsendersignalhandler_=return()addHandler=docallBlocking_$MR.addMatchrule'mvar<-fmapclientSignalHandlersgetClientliftIO$MV.modifyMVar_mvar$return.(handler:)requestName::T.BusName->[NR.RequestNameFlag]->(M.Error->DBus())->(NR.RequestNameReply->DBus())->DBus()requestNamenameflagsonErrorcallback=call(NR.requestNamenameflags)onError$\reply->caseNR.mkRequestNameReplyreplyofNothing->E.throwError$InvalidRequestNameReplyreplyJustx->callbackxreleaseName::T.BusName->(M.Error->DBus())->(NR.ReleaseNameReply->DBus())->DBus()releaseNamenameonErrorcallback=call(NR.releaseNamename)onError$\reply->caseNR.mkReleaseNameReplyreplyofNothing->E.throwError$InvalidReleaseNameReplyreplyJustx->callbackxrequestName_::T.BusName->[NR.RequestNameFlag]->DBusNR.RequestNameReplyrequestName_nameflags=doreply<-callBlocking_$NR.requestNamenameflagscaseNR.mkRequestNameReplyreplyofNothing->E.throwError$InvalidRequestNameReplyreplyJustx->returnxreleaseName_::T.BusName->DBusNR.ReleaseNameReplyreleaseName_name=doreply<-callBlocking_$NR.releaseNamenamecaseNR.mkReleaseNameReplyreplyofNothing->E.throwError$InvalidReleaseNameReplyreplyJustx->returnxnewtypeObject=Object(Map.MapT.InterfaceNameInterface)newtypeInterface=Interface(Map.MapT.MemberNameMember)dataMember=MemberMethodMethod|MemberSignalT.SignaturedataMethod=MethodT.SignatureT.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()exportpathobj=doletobj'=addIntrospectablepathobjmvar<-fmapclientObjectsgetClientliftIO$MV.modifyMVar_mvar$return.Map.insertpathobj'object::[(T.InterfaceName,Interface)]->Objectobject=Object.Map.fromListinterface::[(T.MemberName,Member)]->Interfaceinterface=Interface.Map.fromListmethod::T.Signature-- ^ Input signature->T.Signature-- ^ Output signature->(MethodCtx->DBus())-- ^ Implementation->MembermethodinSigoutSigcb=MemberMethod$MethodinSigoutSigcbdataMethodCtx=MethodCtx{methodCtxObject::Object,methodCtxMethod::Method,methodCtxSerial::M.Serial,methodCtxSender::MaybeT.BusName,methodCtxFlags::Set.SetM.Flag,methodCtxBody::[T.Variant]}-- | Send a successful return reply for a method call.replyReturn::MethodCtx->[T.Variant]->DBus()replyReturncall'body=ifvalidthensendReplyelsesendErrorwheresendError=replyErrorcall'Const.errorFailed[T.toVariant("Method return didn't match signature."::String)]sendReply=send_$M.MethodReturn(methodCtxSerialcall')(methodCtxSendercall')body(Method_outSig_)=methodCtxMethodcall'valid=listSigbody==JustoutSigreplyError::MethodCtx->T.ErrorName->[T.Variant]->DBus()replyErrorcall'namebody=send_$M.Errorname(methodCtxSerialcall')(methodCtxSendercall')bodyunknownMethod::M.ReceivedMessage->DBus()unknownMethodmsg=send_errorMsgwhereM.ReceivedMethodCallserialsender_=msgerrorMsg=M.ErrorConst.errorUnknownMethodserialsender[]findMethod::Map.MapT.ObjectPathObject->M.MethodCall->Maybe(Object,Method)findMethodobjectscall'=doObjectobj<-Map.lookup(M.methodCallPathcall')objectsifaceName<-M.methodCallInterfacecall'Interfaceiface<-Map.lookupifaceNameobjmember<-Map.lookup(M.methodCallMembercall')ifacecasememberofMemberMethodm->return(Objectobj,m)_->NothingonMethodCall::Object->Method->M.ReceivedMessage->DBus()onMethodCallobjmethod'received=runCallwhereM.ReceivedMethodCallserialsendermsg=receivedsig=listSig$M.methodCallBodymsgMethodinSig_cb=method'call'=MethodCtxobjmethod'serialsender(M.methodCallFlagsmsg)(M.methodCallBodymsg)runCall=ifsig==JustinSigthencbcall'elsereplyErrorcall'Const.errorInvalidArgs[]addIntrospectable::T.ObjectPath->Object->ObjectaddIntrospectablepath(Objectifaces)=Objectifaces'whereifaces'=Map.insertWith(\_x->x)nameifaceifacesname=Const.interfaceIntrospectableiface=interface[("Introspect",impl)]impl=method"""s"$\call'->doletJustxml=I.toXML.introspectpath.methodCtxObject$call'replyReturncall'[T.toVariantxml]introspect::T.ObjectPath->Object->I.Objectintrospectpathobj=I.Objectpathinterfaces[]whereObjectifaceMap=objinterfaces=mapintrospectIface(Map.toListifaceMap)introspectIface::(T.InterfaceName,Interface)->I.InterfaceintrospectIface(name,iface)=I.Interfacenamemethodssignals[]whereInterfacememberMap=ifacemembers=Map.toListmemberMapmethods=concatMapintrospectMethodmemberssignals=concatMapintrospectSignalmembersintrospectMethod::(T.MemberName,Member)->[I.Method]introspectMethod(name,(MemberMethod(MethodinSigoutSig_)))=[I.Methodname(mapintrospectParam(T.signatureTypesinSig))(mapintrospectParam(T.signatureTypesoutSig))]introspectMethod_=[]introspectSignal::(T.MemberName,Member)->[I.Signal]introspectSignal(name,(MemberSignalsig))=[I.Signalname(mapintrospectParam(T.signatureTypessig))]introspectSignal_=[]introspectParam=I.Parameter"".T.mkSignature_.T.typeCoderootObject::ObjectrootObject=object[(ifaceName,interface[(memberName,impl)])]whereifaceName=Const.interfaceIntrospectablememberName="Introspect"methodXML=I.MethodmemberName[][I.Parameter"xml""s"]ifaceXML=I.InterfaceifaceName[methodXML][][]impl=method"""s"$\call'->domvar<-fmapclientObjectsgetClientpaths<-liftIO$fmapMap.keys$MV.readMVarmvarletpaths'=filter(/="/")pathsletJustxml=I.toXML$I.Object"/"[ifaceXML][I.Objectp[][]|p<-paths']replyReturncall'[T.toVariantxml]dataProxy=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()callProxyproxynameflagsbodyonErroronReturn=letmsg=buildMethodCallproxynameflagsbodyincallmsgonErroronReturn-- | As 'callBlocking', except that the proxy's information is used-- to build the message.callProxyBlocking::Proxy->T.MemberName->[M.Flag]->[T.Variant]->DBus(EitherM.ErrorM.MethodReturn)callProxyBlockingproxynameflagsbody=callBlocking$buildMethodCallproxynameflagsbody-- | As 'callBlocking_', except that the proxy's information is used-- to build the message.callProxyBlocking_::Proxy->T.MemberName->[M.Flag]->[T.Variant]->DBusM.MethodReturncallProxyBlocking_proxynameflagsbody=callBlocking_$buildMethodCallproxynameflagsbody-- | As 'onSIgnal', except that the proxy's information is used-- to build the match rule.onProxySignal::Proxy->T.MemberName->(M.Signal->DBus())->DBus()onProxySignalproxymemberhandler=onSignalrulehandler'whereProxydestpathiface=proxyrule=MR.MatchRule{MR.matchType=Nothing,MR.matchSender=Justdest,MR.matchInterface=Justiface,MR.matchMember=Justmember,MR.matchPath=Justpath,MR.matchDestination=Nothing,MR.matchParameters=[]}handler'_msg=handlermsgbuildMethodCall::Proxy->T.MemberName->[M.Flag]->[T.Variant]->M.MethodCallbuildMethodCallproxynameflagsbody=msgwhereProxydestpathiface=proxymsg=M.MethodCallpathname(Justiface)(Justdest)(Set.fromListflags)bodylistSig::[T.Variant]->MaybeT.SignaturelistSig=T.mkSignature.mconcat.map(T.typeCode.T.variantType)