module Manatee.Toolkit.General.DBus where
import Control.Arrow (first)
import DBus.Bus
import DBus.Client
import DBus.MatchRule
import DBus.Message (messageBody)
import DBus.Types
import Data.Maybe (fromMaybe)
import Data.Text.Lazy hiding (zip, map, head)
import qualified DBus.Client as DC
import qualified DBus.Message as DM
import qualified DBus.NameReservation as DNR
import qualified Data.Map as M
type ObjectPathText = Text
type MemberNameText = Text
type InterfaceNameText = Text
type BusNameText = Text
type SignatureText = Text
memberNamePrefix :: Text
memberNamePrefix = "member_"
mkMessageSignal :: ObjectPathText
-> MemberNameText
-> InterfaceNameText
-> BusNameText
-> [Variant]
-> DM.Signal
mkMessageSignal oPath mName iName bName =
DM.Signal (mkObjectPath_ oPath)
(mkMemberName_ mName)
(mkInterfaceName_ iName)
(mkBusName bName)
mkSystemClient :: IO Client
mkSystemClient = mkClient =<< getSystemBus
mkSystemClientWithName :: Text -> IO Client
mkSystemClientWithName clientName = do
client <- mkSystemClient
requestName' client clientName []
return client
mkSessionClient :: IO Client
mkSessionClient = mkClient =<< getSessionBus
mkSessionClientWithName :: Text -> IO Client
mkSessionClientWithName clientName = do
client <- mkSessionClient
requestName' client clientName []
return client
mkStarterClient :: IO Client
mkStarterClient = mkClient =<< getStarterBus
requestName' :: Client -> BusNameText -> [DNR.RequestNameFlag] -> IO DNR.RequestNameReply
requestName' client name = requestName client (mkBusName_ name)
mkLocalObject :: [(InterfaceNameText, [(MemberNameText, Member)])] -> LocalObject
mkLocalObject list = LocalObject $ M.fromList $ zip interfaceName interface
where interfaceNameList = fst $ unzip list
interfaceList = snd $ unzip list
interfaceName = map mkInterfaceName_ interfaceNameList
interface = map (Interface . M.fromList . map (first mkMemberName_)) interfaceList
export' :: Client -> ObjectPathText -> LocalObject -> IO ()
export' client path = export client (mkObjectPath_ path)
exportLocalObject :: Client -> ObjectPathText -> [(InterfaceNameText, [(MemberNameText, Member)])] -> IO ()
exportLocalObject client path info = export' client path (mkLocalObject info)
mkMatchRule :: Maybe MessageType
-> BusNameText
-> InterfaceNameText
-> MemberNameText
-> ObjectPathText
-> BusNameText
-> [ParameterValue]
-> MatchRule
mkMatchRule mType sender interface member path dest =
MatchRule mType
(mkBusName sender)
(mkInterfaceName interface)
(mkMemberName member)
(mkObjectPath path)
(mkBusName dest)
mkSignalMember :: SignatureText -> Member
mkSignalMember =
DC.Signal . mkSignature_
mkMethodMember :: SignatureText -> SignatureText -> (MethodCall -> IO ()) -> Member
mkMethodMember input output =
DC.Method (mkSignature_ input) (mkSignature_ output)
packDigitMemberName :: Text -> Text
packDigitMemberName name =
memberNamePrefix `append` name
unpackDigitMemberName :: Text -> Text
unpackDigitMemberName =
replace memberNamePrefix empty
isBusNameExist :: Text -> IO Bool
isBusNameExist busName = do
client <- mkSessionClient
reply <- callProxyBlocking_ client dbus "ListNames" [] []
let names = fromMaybe [] (fromArray =<< fromVariant (head $ messageBody reply))
return (busName `elem` names)
where
dbus :: Proxy
dbus = Proxy (RemoteObject "org.freedesktop.DBus" "/org/freedesktop/DBus") "org.freedesktop.DBus"