diff --git a/d-bus.cabal b/d-bus.cabal --- a/d-bus.cabal +++ b/d-bus.cabal @@ -1,5 +1,5 @@ name: d-bus -version: 0.1.2 +version: 0.1.3 synopsis: Permissively licensed D-Bus client library description: This library uses modern extensions to the Haskell type system (including GADTs, DataKinds and TypeFamilies) and the @@ -12,8 +12,12 @@ copyright: 2013 Philipp Balzarek category: Network, Desktop build-type: Simple -cabal-version: >=1.8 +cabal-version: >=1.10 +source-repository head + type: git + location: git@github.com:Philonous/d-bus.git + library hs-source-dirs: src/ exposed-modules: DBus @@ -25,15 +29,18 @@ , DBus.MessageBus , DBus.Object , DBus.Representable - , DBus.Signature + , DBus.Method + , DBus.Property , DBus.Signal + , DBus.Signature , DBus.TH , DBus.Transport , DBus.Types , DBus.Wire - build-depends: base >= 4 && <5 - , async >= 2.0 + , DBus.Scaffold + build-depends: async >= 2.0 , attoparsec >= 0.12 + , base >= 4 && <5 , binary >= 0.7 , blaze-builder >= 0.3 , bytestring >= 0.10 @@ -42,48 +49,60 @@ , containers >= 0.5 , data-binary-ieee754 >= 0.4 , data-default >= 0.5 + , exceptions >= 0.6 , free >= 4.2 - , mtl >= 2.1 + , hslogger >= 1.2 + , mtl >= 2.2.1 , network >= 2.4 , singletons >= 1.0 , stm >= 2.4 , template-haskell >= 2.8 , text >= 1.1 - , transformers >= 0.3 + , transformers >= 0.4 , xml-conduit >= 1.1 , xml-picklers >= 0.3 , xml-types >= 0.3 - , hslogger >= 1.2 - , exceptions >= 0.6 if os(freebsd) { c-sources: src/cbits/credentials.c cpp-options: -DSEND_CREDENTIALS } + default-language: Haskell2010 + default-extensions: DataKinds + , DeriveDataTypeable + , FlexibleContexts + , GADTs + , KindSignatures + , OverloadedStrings + , PolyKinds + , ScopedTypeVariables + , TypeFamilies test-suite unittests type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Main.hs - build-depends: base >= 4 && < 5 + build-depends: QuickCheck + , base >= 4 && < 5 + , binary + , bytestring , d-bus - , xml-hamlet - , QuickCheck - , text + , mtl + , singletons , tasty - , tasty-th + , tasty-hunit , tasty-quickcheck - , singletons - , bytestring - , binary - , mtl - -test-suite integrationtest - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Runtest.hs - build-depends: base >= 4 && < 5 - , d-bus + , tasty-th , text + , xml-hamlet + default-language: Haskell2010 + +-- test-suite integrationtest +-- type: exitcode-stdio-1.0 +-- hs-source-dirs: tests +-- main-is: Runtest.hs +-- build-depends: base >= 4 && < 5 +-- , d-bus +-- , text -- test-suite singletons diff --git a/src/DBus.hs b/src/DBus.hs --- a/src/DBus.hs +++ b/src/DBus.hs @@ -1,8 +1,10 @@ module DBus ( -- * Connection management - ConnectionType(..) + DBusConnection + , ConnectionType(..) , connectBus + , makeServer , MethodCallHandler , SignalHandler , checkAlive @@ -12,12 +14,19 @@ , ignore -- * Signals , MatchRule(..) + , Signal(..) + , SignalDescription(..) + , SomeSignalDescription(..) , matchAll , matchSignal , addMatch , removeMatch + , addSignalHandler + , signalChan + , handleSignal -- * Representable Types , Representable(..) + , FlattenRepType , makeRepresentable , makeRepresentableTuple -- * DBus specific types @@ -47,15 +56,27 @@ , Method(..) , MethodWrapper(..) , ArgumentDescription(..) - , ResultDescription(..) , repMethod , callMethod , callMethod' + , call + , callAsync + , fromResponse , MsgError(..) + , MethodError(..) + , MethodHandlerT(..) + , MethodDescription(..) + , SomeMethodDescription(..) -- * Properties , Property (..) - , PropertyWrapper(..) + , SomeProperty(..) , PropertyEmitsChangedSignal(..) + , RemoteProperty(..) + , propertyChanged + , emitPropertyChanged + , getProperty + , setProperty + , handlePropertyChanged , mkProperty , mkTVarProperty -- * Introspection @@ -84,6 +105,8 @@ import DBus.Message import DBus.MessageBus import DBus.Object +import DBus.Property +import DBus.Method import DBus.Signal import DBus.TH import DBus.Types diff --git a/src/DBus/Auth.hs b/src/DBus/Auth.hs --- a/src/DBus/Auth.hs +++ b/src/DBus/Auth.hs @@ -8,7 +8,7 @@ module DBus.Auth where import Control.Applicative -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.Free import qualified Data.Attoparsec.ByteString as AP import qualified Data.Attoparsec.ByteString.Char8 as AP8 @@ -121,7 +121,7 @@ | Recv (ServerMessage -> a) deriving (Functor) -newtype SASL a = SASL {unSASL :: ErrorT String (Free SASLF) a} +newtype SASL a = SASL {unSASL :: ExceptT String (Free SASLF) a} deriving (Functor, Applicative, Monad) instance MonadError String SASL where @@ -164,7 +164,7 @@ ++ ": " ++ show e Right r -> return r return () - res <- go snd rcv (runErrorT s) + res <- go snd rcv (runExceptT s) case res of Left e -> do snd (CMCancel) diff --git a/src/DBus/Error.hs b/src/DBus/Error.hs --- a/src/DBus/Error.hs +++ b/src/DBus/Error.hs @@ -1,12 +1,27 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + module DBus.Error where import Control.Exception as Ex import Data.Typeable (Typeable) +import DBus.Types + data DBusError = CouldNotConnect String | DBusParseError String | MarshalError String deriving (Show, Eq, Typeable) instance Ex.Exception DBusError + +errorFailed msg = (MsgError "org.freedesktop.DBus.Error.Failed" + (Just msg) + []) + +-- noSuchInterface, noSuchProperty, propertyNotReadable, propertyNotReadable +noSuchInterface = errorFailed "No such interface" +noSuchProperty = errorFailed "No such property" +propertyNotReadable = errorFailed "Property is not readable" +propertyNotWriteable = errorFailed "Property is not writeable" +argTypeMismatch = errorFailed "Argument type mismatch" diff --git a/src/DBus/Introspect.hs b/src/DBus/Introspect.hs --- a/src/DBus/Introspect.hs +++ b/src/DBus/Introspect.hs @@ -10,17 +10,23 @@ import Blaze.ByteString.Builder import Control.Applicative ((<$>)) import Control.Exception (SomeException) +import Control.Monad import qualified Data.ByteString as BS import Data.Conduit (($$), ($=)) import Data.Conduit.List (consume, sourceList) -import Data.Data(Data) +import Data.Data (Data) import Data.Functor.Identity +import Data.Map (Map) +import qualified Data.Map as Map import Data.Maybe +import Data.Monoid import Data.Monoid (mconcat) +import Data.Singletons +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Lazy as LText -import Data.Typeable(Typeable) +import Data.Typeable (Typeable) import Data.XML.Pickle hiding (Result) import Data.XML.Types import Text.XML.Stream.Parse @@ -31,63 +37,63 @@ import DBus.Representable import DBus.Signature import DBus.Types +import DBus.Method data IDirection = In | Out deriving (Eq, Show, Data, Typeable) -directionFromText :: Text.Text -> Either Text.Text IDirection +introspectableInterfaceName :: Text +introspectableInterfaceName = "org.freedesktop.DBus.Introspectable" + +directionFromText :: Text -> Either Text IDirection directionFromText "in" = Right In directionFromText "out" = Right Out directionFromText d = Left $ "Not a direction: " `Text.append` d -directionToText :: IDirection -> Text.Text +directionToText :: IDirection -> Text directionToText In = "in" directionToText Out = "out" -data IPropertyAccess = Read - | Write - | ReadWrite - deriving (Eq, Show, Data, Typeable) -propertyAccessFromText :: Text.Text -> Either Text.Text IPropertyAccess +propertyAccessFromText :: Text -> Either Text PropertyAccess propertyAccessFromText "read" = Right Read propertyAccessFromText "write" = Right Write propertyAccessFromText "readwrite" = Right ReadWrite propertyAccessFromText a = Left $ "Not a property access type: " `Text.append` a -propertyAccessToText :: IPropertyAccess -> Text.Text +propertyAccessToText :: PropertyAccess -> Text propertyAccessToText Read = "read" propertyAccessToText Write = "write" propertyAccessToText ReadWrite = "readwrite" -data IArgument = IArgument { iArgumentName :: Text.Text +data IArgument = IArgument { iArgumentName :: Text , iArgumentType :: DBusType , iArgumentDirection :: Maybe IDirection } deriving (Eq, Show, Data, Typeable) -data IMethod = IMethod { iMethodName :: Text.Text +data IMethod = IMethod { iMethodName :: Text , iMethodArguments :: [IArgument] , iMethodAnnotations :: [Annotation] } deriving (Eq, Show, Data, Typeable) -data ISignal = ISignal { iSignalName :: Text.Text +data ISignal = ISignal { iSignalName :: Text , iSignalArguments :: [IArgument] , iSignalAnnotations :: [Annotation] } deriving (Eq, Show, Data, Typeable) -data IProperty = IProperty { iPropertyName :: Text.Text +data IProperty = IProperty { iPropertyName :: Text , iPropertyType :: DBusType - , iPropertyAccess :: IPropertyAccess + , iPropertyAccess :: PropertyAccess , iPropertyAnnotation :: [Annotation] } deriving (Eq, Show, Data, Typeable) -data IInterface = IInterface { iInterfaceName :: Text.Text +data IInterface = IInterface { iInterfaceName :: Text , iInterfaceMethods :: [IMethod] , iInterfaceSignals :: [ISignal] , iInterfaceProperties :: [IProperty] , iInterfaceAnnotations :: [Annotation] } deriving (Eq, Show, Data, Typeable) -data INode = INode { nodeName :: Text.Text +data INode = INode { nodeName :: Text , nodeInterfaces :: [IInterface] , nodeSubnodes :: [INode] } deriving (Eq, Show, Data, Typeable) @@ -99,11 +105,11 @@ (xp2Tuple (xpAttribute "name" xpText) (xpAttribute "value" xpText)) -xpSignature :: PU Text.Text DBusType +xpSignature :: PU Text DBusType xpSignature = xpPartial (eitherParseSig . Text.encodeUtf8) (Text.decodeUtf8 . toSignature) -xpDirection :: PU Text.Text IDirection +xpDirection :: PU Text IDirection xpDirection = xpPartial directionFromText directionToText xpPropertyAccess = xpPartial propertyAccessFromText propertyAccessToText @@ -165,7 +171,7 @@ (xp2Tuple (xpFindMatches xpInterface) (xpFindMatches xpNode)) -xmlToNode :: BS.ByteString -> Either Text.Text INode +xmlToNode :: BS.ByteString -> Either Text INode xmlToNode xml = case sourceList [xml] $= parseBytesPos def $$ fromEvents of Left e -> Left (Text.pack $ show (e :: SomeException)) Right d -> case unpickle (xpRoot . xpUnliftElems $ xpNode) $ documentRoot d of @@ -173,6 +179,9 @@ Right r -> Right r + + + pubID :: ExternalID pubID = PublicID "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN" "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd" @@ -206,19 +215,25 @@ ++ zipWith ((\r t -> IArgument r t (Just Out))) rs res -introspectSignalArgument a = - IArgument { iArgumentName = signalArgumentName a - , iArgumentType = signalArgumentType a +introspectSignalArgument :: DBusType -> Text -> IArgument +introspectSignalArgument tp name = + IArgument { iArgumentName = name + , iArgumentType = tp , iArgumentDirection = Nothing } -introspectSignal s = - ISignal { iSignalName = signalName s - , iSignalArguments = introspectSignalArgument <$> signalArguments s - , iSignalAnnotations = signalAnnotations s +introspectSignal :: SomeSignalDescription -> ISignal +introspectSignal (SSD (s :: SignalDescription a)) = + ISignal { iSignalName = signalDMember s + , iSignalArguments = zipWith introspectSignalArgument + (fromSing $ (sing :: Sing a)) + (adToList $ signalDArguments s) + + , iSignalAnnotations = [] -- signalAnnotations s } -propertyAccess (Property{propertyAccessors = PropertyWrapper mbSet mbGet}) +propertyAccess :: Property t -> PropertyAccess +propertyAccess Property{propertySet = mbSet, propertyGet = mbGet} = case (mbSet, mbGet) of (Just{}, Just{}) -> ReadWrite (Nothing, Just{}) -> Read @@ -226,50 +241,198 @@ (Nothing, Nothing) -> error "iPropertyAccess: Both getter and setter are Nothing" -introspectProperty p = IProperty { iPropertyName = propertyName p - , iPropertyType = propertyType p - , iPropertyAccess = propertyAccess p - , iPropertyAnnotation = [] -- TODO +introspectProperty :: SomeProperty -> IProperty +introspectProperty (SomeProperty p) = + IProperty { iPropertyName = propertyName p + , iPropertyType = propertyType p + , iPropertyAccess = propertyAccess p + , iPropertyAnnotation = [] -- TODO } -introspectInterface :: Interface -> IInterface -introspectInterface i = IInterface { iInterfaceName = interfaceName i - , iInterfaceMethods = introspectMethods +introspectInterface :: Text -> Interface -> IInterface +introspectInterface n i = IInterface { iInterfaceName = n + , iInterfaceMethods = introspectMethods $ interfaceMethods i - , iInterfaceSignals = - introspectSignal <$> interfaceSignals i - , iInterfaceProperties = - introspectProperty + , iInterfaceSignals = + introspectSignal <$> interfaceSignals i + , iInterfaceProperties = + introspectProperty <$> interfaceProperties i - , iInterfaceAnnotations = [] -- TODO - } + , iInterfaceAnnotations = [] -- TODO + } -introspectObject o = INode { nodeName = objectPathToText $ objectObjectPath o - , nodeInterfaces = introspectInterface <$> - objectInterfaces o - , nodeSubnodes = introspectObject - <$> objectSubObjects o - } -introspect :: Object -> IO Text.Text -introspect object = return $ Text.decodeUtf8 . nodeToXml $ introspectObject object +-- | Delete prefix from map, returns (elements with prefix delete, elements that +-- didn't have this prefix) +deletePrefix :: ObjectPath -> Map ObjectPath a -> ( Map ObjectPath a + , Map ObjectPath a) +deletePrefix pre m = + let (sub, rest) = Map.partitionWithKey (\k _ -> pre `isPathPrefix` k) m + in (Map.mapKeys (fromJust . stripObjectPrefix pre) sub, rest) -introspectMethod :: Object -> Method -introspectMethod object = Method (repMethod $ introspect object) - "Introspect" - Result - ("xml_data" :> ResultDone) -introspectable :: Object -> Interface -introspectable o = Interface{ interfaceName = "org.freedesktop.DBus.Introspectable" - , interfaceMethods = [introspectMethod o] - , interfaceSignals = [] - , interfaceAnnotations = [] - , interfaceProperties = [] - } +grabPrefixes :: Map ObjectPath a -> [(ObjectPath, a, Map ObjectPath a)] +grabPrefixes m = + let mbMin = Map.minViewWithKey m + in case mbMin of + Nothing -> [] + Just ((pre, obj), m') + -> let (sub, rest) = deletePrefix pre m' + in (pre, obj, sub) : grabPrefixes rest -addIntrospectable :: Object -> Object -addIntrospectable o@(Object nm is sos) = - let intr = introspectable o - in Object nm (if intr `elem` is then is else (intr:is)) - (addIntrospectable <$> sos) +propertiesInterfaceName :: Text +propertiesInterfaceName = "org.freedesktop.DBus.Properties" + +propertiesInterface :: IInterface +propertiesInterface = + IInterface { + iInterfaceName = "org.freedesktop.DBus.Properties" + , iInterfaceMethods = + [IMethod{ + iMethodName = "Get" + , iMethodArguments = + [ IArgument { + iArgumentName = "interface_name" + , iArgumentType = DBusSimpleType TypeString + , iArgumentDirection = Just In} + , IArgument { + iArgumentName = "property_name" + , iArgumentType = DBusSimpleType TypeString + , iArgumentDirection = Just In} + , IArgument { + iArgumentName = "value" + , iArgumentType = TypeVariant + , iArgumentDirection = Just Out }] + , iMethodAnnotations = []} + , IMethod{ + iMethodName = "Set" + , iMethodArguments = + [ IArgument { + iArgumentName = "interface_name" + , iArgumentType = DBusSimpleType TypeString + , iArgumentDirection = Just In } + , IArgument { + iArgumentName = "property_name" + , iArgumentType = DBusSimpleType TypeString + , iArgumentDirection = Just In } + , IArgument { + iArgumentName = "value" + , iArgumentType = TypeVariant + , iArgumentDirection = Just In}] + , iMethodAnnotations = [] } + , IMethod{ + iMethodName = "GetAll" + , iMethodArguments = + [ IArgument { + iArgumentName = "interface_name" + , iArgumentType = DBusSimpleType TypeString + , iArgumentDirection = Just In } + , IArgument { + iArgumentName = "props" + , iArgumentType = TypeDict TypeString TypeVariant + , iArgumentDirection = Just Out }] + , iMethodAnnotations = [] }] + , iInterfaceSignals = + [ ISignal { iSignalName = "PropertiesChanged" + , iSignalArguments = + [ IArgument { + iArgumentName = "interface_name" + , iArgumentType = DBusSimpleType TypeString + , iArgumentDirection = Nothing} + , IArgument { + iArgumentName = "changed_properties" + , iArgumentType = TypeDict TypeString TypeVariant + , iArgumentDirection = Nothing} + , IArgument { + iArgumentName = "invalidated_properties" + , iArgumentType = + TypeArray (DBusSimpleType TypeString) + , iArgumentDirection = Nothing}] + , iSignalAnnotations = []}] + , iInterfaceProperties = [] + , iInterfaceAnnotations = [] + } + +introspectObject :: Bool + -> ObjectPath + -> Object + -> Map ObjectPath Object + -> INode +introspectObject recurse path (Object ifaces) sub + = INode { nodeName = objectPathToText path + , nodeInterfaces = + let propIface = if hasInterface propertiesInterfaceName ifaces + then [] + else [propertiesInterface] + introspectIface = + if hasInterface introspectableInterfaceName ifaces + then [] + else [introspectInterface introspectableInterfaceName $ + introspectableInterface path False undefined] + in concat [introspectIface + , propIface + , uncurry introspectInterface <$> Map.toList ifaces + ] + + , nodeSubnodes = (if recurse + then (uncurry3 $ introspectObject True) + else \(n, _, _) -> + INode { nodeName = objectPathToText n + , nodeInterfaces = [] + , nodeSubnodes = [] + }) + <$> grabPrefixes sub + } + where + hasInterface :: Text -> Map Text Interface -> Bool + hasInterface iname o = isJust $ Map.lookup iname o + +uncurry3 f (x, y, z) = f x y z + +introspectObjects path recursive objs@(Objects os) = + case Map.updateLookupWithKey (\_ _ -> Nothing) path os of + (Nothing, _) -> + let oss = Map.mapKeys (fromMaybe "" . stripObjectPrefix path) os + in INode { nodeName = objectPathToText path + , nodeInterfaces = [] + , nodeSubnodes = + uncurry3 (introspectObject recursive ) + <$> grabPrefixes oss + } + (Just o, os') -> + let oss = Map.mapKeys (fromMaybe "" . stripObjectPrefix path) os' + in introspectObject recursive path o oss + + +introspect :: ObjectPath -> Bool -> Objects -> Text +introspect path recursive object = Text.decodeUtf8 . nodeToXml + $ introspectObjects path recursive object + +introspectMethod :: ObjectPath -> Bool -> Objects -> Method +introspectMethod path recursive object = + Method (repMethod $ (return (introspect path recursive object) :: IO Text)) + "Introspect" + Done + ("xml_data" :> Done) + + +introspectableInterface path recursive o = + Interface{ interfaceMethods = [introspectMethod path recursive o] + , interfaceSignals = [] + , interfaceAnnotations = [] + , interfaceProperties = [] + } + +introspectable :: ObjectPath -> Bool -> Objects -> Object +introspectable path recursive = + object introspectableInterfaceName . introspectableInterface path recursive + +addIntrospectable :: Objects -> Objects +addIntrospectable os = + let ro = root "/" (Object Map.empty) <> os + intrs = for (Map.keys (Map.delete "/" (unObjects ro))) $ \path -> + root path (introspectable path False ro) + intr = introspectable "/" True ro + in os <> root "/" intr <> mconcat intrs + where + for = flip fmap diff --git a/src/DBus/MainLoop.hs b/src/DBus/MainLoop.hs --- a/src/DBus/MainLoop.hs +++ b/src/DBus/MainLoop.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} module DBus.MainLoop where @@ -27,8 +28,10 @@ import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Text as CT import Data.IORef +import Data.Map (Map) import qualified Data.Map as Map import Data.Singletons +import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable (Typeable) import Data.Word @@ -52,14 +55,32 @@ import DBus.Transport import DBus.Types import DBus.Wire +import DBus.Signal +import DBus.Property +import DBus.Introspect -handleMessage handleCall handleSignals answerSlots (header, body) = - case messageType header of - MessageTypeMethodCall -> handleCall header body - MessageTypeMethodReturn -> handleReturn True - MessageTypeError -> handleError - MessageTypeSignal -> handleSignals header body - _ -> return () +handleMessage :: (MessageHeader -> [SomeDBusValue] -> IO ()) + -> (MessageHeader -> [SomeDBusValue] -> IO a) + -> TVar AnswerSlots + -> TVar SignalSlots + -> TVar PropertySlots + -> (MessageHeader, [SomeDBusValue]) + -> IO () +handleMessage handleCall handleSignals answerSlots signalSlots propertySlots + (header, body) = do + case messageType header of + MessageTypeMethodCall -> do + let hfs = fields header + logDebug $ "Dispatching method call " + ++ show (hFPath hfs) + ++ "; " ++ (maybe "" Text.unpack $ hFInterface hfs) + ++ "; " ++ (maybe "" Text.unpack $ hFMember hfs) + ++ ": " ++ show body + handleCall header body + MessageTypeMethodReturn -> handleReturn True + MessageTypeError -> handleError + MessageTypeSignal -> handleSignal + _ -> return () where handleReturn nonError = case hFReplySerial $ fields header of Nothing -> return () @@ -75,10 +96,74 @@ handleError = case hFReplySerial $ fields header of Nothing -> return () -- TODO: handle non-response errors Just s -> handleReturn False + handleSignal = do + handleSignals header body + sSlots <- atomically $ readTVar signalSlots + let fs = fields header + case () of + _ | Just iface <- hFInterface fs + , Just member <- hFMember fs + , Just path <- hFPath fs + , Just sender <- hFSender fs + -> case (iface, member) of + ( "org.freedesktop.DBus.Properties" + ,"PropertiesChanged") + | [DBV pi, DBV uds, DBV invs] <- body + , Just propIface <- fromRep =<< castDBV pi :: Maybe Text + , Just updates <- fromRep =<< castDBV uds + :: Maybe (Map Text (DBusValue TypeVariant)) + , Just ivs <- (fromRep =<< castDBV invs :: Maybe [Text]) + -> handlePropertyUpdates path propIface updates ivs + _ -> case filter (match4 ( Match iface + , Match member + , Match path + , Match sender) . fst) + sSlots of + handlers@(_:_) -> + case listToSomeArguments body of + SDBA as -> let sig = SomeSignal $ + Signal { signalPath = path + , signalInterface = iface + , signalMember = member + , signalBody = as + } + in forM_ handlers $ \(_, handler) -> + handler sig + _ -> logDebug $ "Unhandled signal" + ++ show path ++ "/ " + ++ show iface ++ "." + ++ show member ++ " from " + ++ show sender ++ ": " + ++ show body ++ "\n" + | otherwise -> logDebug $ "Signal is missing header fields:" + ++ show header ++ "; " ++ show body + match4 (x1, x2, x3, x4) (y1, y2, y3, y4) = + and $ [ x1 `checkMatch` y1 + , x2 `checkMatch` y2 + , x3 `checkMatch` y3 + , x4 `checkMatch` y4 + ] + handlePropertyUpdates path iface updates ivs = do + pSlots <- readTVarIO propertySlots + let items = Map.toList (Just <$> updates) + ++ ((\i -> (i, Nothing)) <$> ivs) + forM_ items $ \(member, mbV) -> + case Map.lookup (path, iface, member) pSlots of + Nothing -> logDebug $ "unexpected property update for " + ++ show path ++" / " + ++ Text.unpack iface ++ "." + ++ Text.unpack member + Just hs -> do + let v = variantToDBV <$> mbV + logDebug $ "Recevied property updates " ++ show updates + ++ " and invalidated propertied " ++ show ivs + forM_ hs $ \h -> forkIO $ h v + variantToDBV :: DBusValue TypeVariant -> SomeDBusValue + variantToDBV (DBVVariant v) = DBV v -- | Create a message handler that dispatches matches to the methods in a root -- object -objectRoot :: Object -> Handler +objectRoot :: Objects -> Handler objectRoot o conn header args | fs <- fields header , Just path <- hFPath fs , Just iface <- hFInterface fs @@ -89,31 +174,32 @@ let errToErrMessage s e = errorMessage s (Just ser) sender (errorName e) (errorText e) (errorBody e) mkReturnMethod s args = methodReturn s ser sender args - ret <- case callAtPath o path iface member args of - Left e -> return $ Left e + (ret, sigs) <- case callAtPath o path iface member args of + Left e -> return (Left e, []) Right f -> do - ret <- withAsync (Ex.catch (Right <$> runSignalT f) - (return . Left)) waitCatch + ret <- withAsync (Ex.catch (runMethodHandlerT f) + -- catches MsgError only: + (\e -> return (Left e, [])) + ) waitCatch case ret of - Left e -> return $ Left + Left e -> return $ (Left (MsgError "org.freedesktop.DBus.Error.Failed" (Just $ "Method threw exception: " `Text.append` Text.pack (show e)) []) - Right r -> return $ r + , []) + Right r -> return r serial <- atomically $ dBusCreateSerial conn + forM_ sigs $ flip emitSignal' conn + logDebug $ "method call returned " ++ show ret case ret of Left err -> sendBS conn $ errToErrMessage serial err - Right (r, sigs) -> do - sendBS conn $ mkReturnMethod serial r - forM_ sigs $ \sig -> do - sid <- atomically $ dBusCreateSerial conn - sendBS conn $ mkSignal sid [] sig + Right r -> sendBS conn $ mkReturnMethod serial r + logDebug "done" where notUnit (DBV DBVUnit) = False notUnit _ = True objectRoot _ _ _ _ = return () - -- | Check whether connection is alive checkAlive :: DBusConnection -> IO Bool checkAlive conn = atomically $ readTVar (connectionAliveRef conn) @@ -185,6 +271,8 @@ return s lock <- newTMVarIO $ BS.hPutBuilder h answerSlots <- newTVarIO (Map.empty :: AnswerSlots) + signalSlots <- newTVarIO ([] :: SignalSlots) + propertySlots <- newTVarIO (Map.empty :: PropertySlots) aliveRef <- newTVarIO True weakAliveRef <- mkWeakPtr aliveRef Nothing let kill = do @@ -196,6 +284,7 @@ slots <- atomically $ do sls <- readTVar answerSlots writeTVar answerSlots Map.empty return sls + atomically $ writeTVar signalSlots [] atomically $ forM_ (Map.elems slots) $ \s -> s . Left $ [DBV $ DBVString "Connection Closed"] mfix $ \conn' -> do @@ -206,11 +295,16 @@ C.$$ (C.awaitForever $ liftIO . handleMessage (handleCalls conn') (handleSignals conn') - answerSlots)) + answerSlots + signalSlots + propertySlots + )) (\e -> print (e :: Ex.SomeException) >> kill >> Ex.throwIO e) addFinalizer aliveRef $ killThread handlerThread let conn = DBusConnection { dBusCreateSerial = getSerial , dBusAnswerSlots = answerSlots + , dbusSignalSlots = signalSlots + , dbusPropertySlots = propertySlots , dBusWriteLock = lock , dBusConnectionName = "" , connectionAliveRef = aliveRef @@ -219,6 +313,11 @@ connName <- hello conn debugM "DBus" $ "Done" return conn{dBusConnectionName = connName} + +makeServer :: ConnectionType -> Objects -> IO DBusConnection +makeServer transport objs = do + connectBus transport (objectRoot (addIntrospectable objs)) + (\_ _ _ -> return ()) type Handler = DBusConnection -> MessageHeader -> [SomeDBusValue] -> IO () diff --git a/src/DBus/Message.hs b/src/DBus/Message.hs --- a/src/DBus/Message.hs +++ b/src/DBus/Message.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -37,7 +38,6 @@ import DBus.TH import DBus.Types import DBus.Wire -import DBus.Object data MessageType = MessageTypeInvalid | MessageTypeMethodCall @@ -193,6 +193,7 @@ } in serializeMessage header args +mkSignal :: SingI ts => Word32 -> [Flag] -> Signal ts -> BS.Builder mkSignal sid flags sig = let hFields = emptyHeaderFields { hFPath = Just $ signalPath sig , hFInterface = Just $ signalInterface sig @@ -207,7 +208,7 @@ , serial = sid , fields = hFields } - in serializeMessage header (signalBody sig) + in serializeMessage header (argsToValues . SDBA $ signalBody sig) @@ -311,7 +312,7 @@ ref <- newEmptyTMVarIO rSlot <- newTVarIO () mkWeak rSlot (connectionAliveRef conn) Nothing - addFinalizer rSlot (finalizeSlot serial) + _ <- mkWeakTVar rSlot (finalizeSlot serial) slot <- atomically $ do modifyTVar (dBusAnswerSlots conn) (Map.insert serial $ putTMVar ref) return ref @@ -323,17 +324,48 @@ atomically $ modifyTVar (dBusAnswerSlots conn) (Map.delete s) --- | Wait for the answer of a method call -getAnswer :: IO (STM b) -> IO b -getAnswer = (atomically =<<) +toArgs :: Representable args => args -> [SomeDBusValue] +toArgs (arg :: args) = + let sng = sing :: Sing (RepType args) + flsng = sFlattenRepType sng + in withSingI flsng $ argsToValues $ SDBA (flattenRep arg) +-- | Try to convert the response to a method call top Haskell types +fromResponse :: Representable a => + Either [SomeDBusValue] [SomeDBusValue] + -> Either MethodError a +fromResponse (Left e) = Left $ MethodErrorMessage e +fromResponse (Right rvs) = + case listToSomeArguments rvs of + sr@(SDBA (r :: DBusArguments ats)) -> + maybe (Left $ MethodSignatureMissmatch rvs) Right + -- Use fix to access the return type (We only care about the type) + $ fix $ \(_ :: Maybe ret) -> + case sing :: Sing (RepType ret) of + STypeStruct ts -> case (r, sing :: Sing ats) of + (ArgsNil, SNil) -> Nothing + (ArgsCons r' ArgsNil, SCons a SNil) -> + case a %~ (sing :: Sing (RepType ret)) of + Proved Refl -> fromRep r' + Disproved _ -> Nothing + _ -> withSingI ts + $ fromRep . DBVStruct =<< maybeArgsToStruct r + STypeUnit -> case r of + ArgsNil -> fromRep DBVUnit + _ -> Nothing + _ -> case (sing :: Sing ats, r) of + (SCons at SNil, ArgsCons r' ArgsNil) -> + case at %~ (sing :: Sing (RepType ret)) of + Proved Refl -> fromRep r' + Disproved _ -> Nothing + -- | Synchronously call a method. -- -- This is the "cooked" version of callMethod\''. It automatically converts --- arguments and returns values and throws conversion errors as exceptions +-- arguments and returns values. -- -- If the returned value's type doesn't match the expected type a --- 'MethodSignatureMissmatch' is thrown. +-- 'MethodSignatureMissmatch' is returned -- -- You can pass in and extract multiple arguments and return values with types -- that are represented by DBus Structs (e.g. tuples). More specifically, @@ -369,27 +401,28 @@ let sng = sing :: Sing (RepType args) flsng = sFlattenRepType sng args' = withSingI flsng $ argsToValues $ SDBA (flattenRep arg) - ret <- getAnswer $ callMethod' dest path interface member args' flags conn - return $ case ret of - Left e -> Left $ MethodErrorMessage e - Right rvs -> case listToSomeArguments rvs of - sr@(SDBA (r :: DBusArguments ats)) -> - maybe (Left $ MethodSignatureMissmatch rvs) Right - $ fix $ \(_ :: Maybe ret) -> - case sing :: Sing (RepType ret) of - STypeStruct ts -> case (r, sing :: Sing ats) of - (ArgsNil, SNil) -> Nothing - (ArgsCons r' ArgsNil, SCons a SNil) -> - case a %~ (sing :: Sing (RepType ret)) of - Proved Refl -> fromRep r' - Disproved _ -> Nothing - _ -> withSingI ts - $ fromRep . DBVStruct =<< maybeArgsToStruct r - STypeUnit -> case r of - ArgsNil -> fromRep DBVUnit - _ -> Nothing - _ -> case (sing :: Sing ats, r) of - (SCons at SNil, ArgsCons r' ArgsNil) -> - case at %~ (sing :: Sing (RepType ret)) of - Proved Refl -> fromRep r' - Disproved _ -> Nothing + ret <- callMethod' dest path interface member args' flags conn + fromResponse <$> atomically ret + +callAsync :: (Representable args, Representable ret) => + MethodDescription (FlattenRepType (RepType args)) + (FlattenRepType (RepType ret)) + -> Text.Text + -> args + -> [Flag] + -> DBusConnection + -> IO (STM (Either MethodError ret)) +callAsync md dest args flags con = do + res <- callMethod' dest (methodObjectPath md) (methodInterface md) + (methodMember md) (toArgs args) flags con + return $ fromResponse <$> res + +call :: (Representable ret, Representable args) => + MethodDescription (FlattenRepType (RepType args)) + (FlattenRepType (RepType ret)) + -> Text.Text + -> args + -> [Flag] + -> DBusConnection + -> IO (Either MethodError ret) +call md dest args flags con = atomically =<< callAsync md dest args flags con diff --git a/src/DBus/MessageBus.hs b/src/DBus/MessageBus.hs --- a/src/DBus/MessageBus.hs +++ b/src/DBus/MessageBus.hs @@ -7,14 +7,13 @@ import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.IO.Class import Control.Monad.Trans (MonadIO) -import DBus.Message -import DBus.Object -import DBus.Types import Data.Default import Data.Singletons import qualified Data.Text as Text import Data.Word +import DBus.Message +import DBus.Types import DBus.Error messageBusMethod :: ( MonadIO m diff --git a/src/DBus/Method.hs b/src/DBus/Method.hs new file mode 100644 --- /dev/null +++ b/src/DBus/Method.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module DBus.Method where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import qualified Data.List as List +import Data.Singletons +import Data.Singletons.Prelude.List +import Data.Text (Text) +import qualified Data.Text as Text + +import DBus.Types +import DBus.Representable + +-- | IsMethod is a Helper class to create MethodWrappers without having to +-- explicitly unwrap all the function arguments. +class IsMethod f where + type ArgTypes f :: [DBusType] + type ResultType f :: [DBusType] + toMethod :: f -> MethodWrapper (ArgTypes f) (ResultType f) + +instance SingI t => IsMethod (IO (DBusArguments t)) where + type ArgTypes (IO (DBusArguments ts)) = '[] + type ResultType (IO (DBusArguments ts)) = ts + toMethod = MReturn. lift + +instance SingI t => IsMethod (MethodHandlerT IO (DBusArguments t)) where + type ArgTypes (MethodHandlerT IO (DBusArguments ts)) = '[] + type ResultType (MethodHandlerT IO (DBusArguments ts)) = ts + toMethod = MReturn + +instance (IsMethod f, SingI t) => IsMethod (DBusValue t -> f) where + type ArgTypes (DBusValue t -> f) = (t ': ArgTypes f) + type ResultType (DBusValue t -> f) = ResultType f + toMethod f = MAsk $ \x -> toMethod (f x) + +class RepMethod f where + type RepMethodArgs f :: [DBusType] + type RepMethodValue f :: [DBusType] + repMethod :: f -> MethodWrapper (RepMethodArgs f) (RepMethodValue f) + + +instance (Representable t) => RepMethod (IO t) where + type RepMethodArgs (IO t) = '[] + type RepMethodValue (IO t) = FlattenRepType (RepType t) + repMethod (f :: IO t) + = let sng = sFlattenRepType (sing :: Sing (RepType t)) + in withSingI sng $ MReturn $ flattenRep . toRep <$> lift f + +instance (Representable t) => RepMethod (MethodHandlerT IO t) where + type RepMethodArgs (MethodHandlerT IO t) = '[] + type RepMethodValue (MethodHandlerT IO t) = FlattenRepType (RepType t) + repMethod (f :: MethodHandlerT IO t) + = let sng = sFlattenRepType (sing :: Sing (RepType t)) + in withSingI sng $ MReturn $ flattenRep . toRep <$> f + + +instance (RepMethod b, Representable a) + => RepMethod (a -> b) where + type RepMethodArgs (a -> b) = (RepType a ': RepMethodArgs b) + type RepMethodValue (a -> b) = RepMethodValue b + repMethod f = MAsk $ \x -> case fromRep x of + Nothing -> error "marshalling error" -- TODO + Just x -> repMethod $ f x + +runMethodW :: SingI at => + MethodWrapper at rt + -> [SomeDBusValue] + -> Maybe (MethodHandlerT IO (DBusArguments rt)) +runMethodW m args = runMethodW' sing args m + +runMethodW' :: Sing at + -> [SomeDBusValue] + -> MethodWrapper at rt + -> Maybe (MethodHandlerT IO (DBusArguments rt)) +runMethodW' SNil [] (MReturn f) = Just f +runMethodW' (SCons t ts) (arg:args) (MAsk f) = (runMethodW' ts args . f ) + =<< dbusValue arg +runMethodW' _ _ _ = Nothing + +methodWSignature :: (SingI at, SingI rt) => + MethodWrapper (at :: [DBusType]) (rt :: [DBusType]) + -> ([DBusType], [DBusType]) +methodWSignature (_ :: MethodWrapper at rt) = + ( fromSing (sing :: Sing at) + , fromSing (sing :: Sing rt) + ) + + +runMethod :: Method -> [SomeDBusValue] -> Maybe (MethodHandlerT IO SomeDBusArguments) +runMethod (Method m _ _ _) args = liftM SDBA <$> runMethodW m args + +methodSignature :: Method -> ([DBusType], [DBusType]) +methodSignature (Method m _ _ _) = methodWSignature m + +methodName :: Method -> Text.Text +methodName (Method _ n _ _) = n + +argDescriptions args ress = (adToList args, adToList ress) + +instance Show Method where + show m@(Method _ n argDs resDs) = + let (args, res) = argDescriptions argDs resDs + (argst, rest) = methodSignature m + components = zipWith (\name tp -> (Text.unpack name + ++ ":" + ++ ppType tp)) + (args ++ res) + (argst ++ rest) + in Text.unpack n ++ " :: " ++ List.intercalate " -> " components diff --git a/src/DBus/Object.hs b/src/DBus/Object.hs --- a/src/DBus/Object.hs +++ b/src/DBus/Object.hs @@ -18,13 +18,14 @@ import Control.Concurrent.STM import qualified Control.Exception as Ex import Control.Monad +import Control.Monad (liftM) +import Control.Monad.Except import Control.Monad.Trans import Data.List (intercalate, find) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe -import Data.Singletons -import Data.Singletons.Prelude.List +import Data.Monoid import Data.Singletons.TH import Data.String import Data.Text (Text) @@ -33,267 +34,80 @@ import DBus.Types import DBus.Representable - --- | IsMethod is a Helper class to create MethodWrappers without having to --- explicitly unwrap all the function arguments. -class IsMethod f where - type ArgTypes f :: [DBusType] - type ResultType f :: [DBusType] - toMethod :: f -> MethodWrapper (ArgTypes f) (ResultType f) - -instance SingI t => IsMethod (IO (DBusArguments t)) where - type ArgTypes (IO (DBusArguments ts)) = '[] - type ResultType (IO (DBusArguments ts)) = ts - toMethod = MReturn. lift - -instance SingI t => IsMethod (SignalT IO (DBusArguments t)) where - type ArgTypes (SignalT IO (DBusArguments ts)) = '[] - type ResultType (SignalT IO (DBusArguments ts)) = ts - toMethod = MReturn - -instance (IsMethod f, SingI t) => IsMethod (DBusValue t -> f) where - type ArgTypes (DBusValue t -> f) = (t ': ArgTypes f) - type ResultType (DBusValue t -> f) = ResultType f - toMethod f = MAsk $ \x -> toMethod (f x) - -class RepMethod f where - type RepMethodArgs f :: [DBusType] - type RepMethodValue f :: [DBusType] - repMethod :: f -> MethodWrapper (RepMethodArgs f) (RepMethodValue f) - -flattenRep :: ( Representable a ) => - a - -> DBusArguments (FlattenRepType (RepType a)) -flattenRep (x :: t) = - let rts = sing :: Sing (RepType t) - frts :: Sing (FlattenRepType (RepType t)) - frts = sFlattenRepType rts - in case (rts, frts) of - (STypeUnit, SNil) -> ArgsNil - (STypeStruct ts, ts') -> case toRep x of DBVStruct str -> structToArgs str - (t, SCons t' SNil) -> case t %~ t' of - Proved Refl -> ArgsCons (toRep x) ArgsNil - Disproved _ -> error "flattenRep: this shouldn't happen" - -instance (Representable t) => RepMethod (IO t) where - type RepMethodArgs (IO t) = '[] - type RepMethodValue (IO t) = FlattenRepType (RepType t) - repMethod (f :: IO t) - = let sng = sFlattenRepType (sing :: Sing (RepType t)) - in withSingI sng $ MReturn $ flattenRep . toRep <$> lift f - -instance (Representable t) => RepMethod (SignalT IO t) where - type RepMethodArgs (SignalT IO t) = '[] - type RepMethodValue (SignalT IO t) = FlattenRepType (RepType t) - repMethod (f :: SignalT IO t) - = let sng = sFlattenRepType (sing :: Sing (RepType t)) - in withSingI sng $ MReturn $ flattenRep . toRep <$> f - - -instance (RepMethod b, Representable a) - => RepMethod (a -> b) where - type RepMethodArgs (a -> b) = (RepType a ': RepMethodArgs b) - type RepMethodValue (a -> b) = RepMethodValue b - repMethod f = MAsk $ \x -> case fromRep x of - Nothing -> error "marshalling error" -- TODO - Just x -> repMethod $ f x - --- | Create a property from a getter and a setter. It will emit a --- PropertyChanged signal when the setter is called (not only then). To change --- this behaviour modify the propertyEmitsChangedSignal field -mkProperty :: Representable a => - Text - -> Maybe (IO a) - -> Maybe (a -> IO Bool) - -> Property -mkProperty name get set = - let pw = PropertyWrapper { setProperty = doSet <$> set - , getProperty = lift . fmap toRep <$> get - } - in Property { propertyName = name - , propertyAccessors = pw - , propertyEmitsChangedSignal = PECSTrue - } - where - doSet f v = lift $ f =<< fromRepHelper v - fromRepHelper x = case fromRep x of - Nothing -> Ex.throwIO argTypeMismatch - Just r -> return r - --- | Make a property out of a TVar. The property is considered changed on every --- get, no matter if the updated value is actually different from the old one -mkTVarProperty :: Representable a => - Text - -> TVar a - -> Property -mkTVarProperty name tv = mkProperty - name - (Just (atomically $ readTVar tv)) - (Just (\v -> atomically (writeTVar tv v) - >> return True)) - -runMethodW :: SingI at => - MethodWrapper at rt - -> [SomeDBusValue] - -> Maybe (SignalT IO (DBusArguments rt)) -runMethodW m args = runMethodW' sing args m - -runMethodW' :: Sing at - -> [SomeDBusValue] - -> MethodWrapper at rt - -> Maybe (SignalT IO (DBusArguments rt)) -runMethodW' SNil [] (MReturn f) = Just f -runMethodW' (SCons t ts) (arg:args) (MAsk f) = (runMethodW' ts args . f ) - =<< dbusValue arg -runMethodW' _ _ _ = Nothing - -methodWSignature :: (SingI at, SingI rt) => - MethodWrapper (at :: [DBusType]) (rt :: [DBusType]) - -> ([DBusType], [DBusType]) -methodWSignature (_ :: MethodWrapper at rt) = - ( fromSing (sing :: Sing at) - , fromSing (sing :: Sing rt) - ) - - -runMethod :: Method -> [SomeDBusValue] -> Maybe (SignalT IO SomeDBusArguments) -runMethod (Method m _ _ _) args = liftM SDBA <$> runMethodW m args - -methodSignature :: Method -> ([DBusType], [DBusType]) -methodSignature (Method m _ _ _) = methodWSignature m - -methodName :: Method -> Text.Text -methodName (Method _ n _ _) = n - -argDescToList :: ArgumentDescription ts - -> [Text.Text] -argDescToList (t :-> ts) = t : argDescToList ts -argDescToList Result = [] - -resultDescToList :: ResultDescription t -> [Text.Text] -resultDescToList ResultDone = [] -resultDescToList (t :> ts) = t : resultDescToList ts - -argDescriptions args ress = (argDescToList args, resultDescToList ress) - -instance Show Method where - show m@(Method _ n argDs resDs) = - let (args, res) = argDescriptions argDs resDs - (argst, rest) = methodSignature m - components = zipWith (\name tp -> (Text.unpack name - ++ ":" - ++ ppType tp)) - (args ++ res) - (argst ++ rest) - in Text.unpack n ++ " :: " ++ intercalate " -> " components - -instance Show Interface where - show i = "Interface " ++ show (interfaceName i) ++ " [{" - ++ intercalate "}, {" (map show $ interfaceMethods i) ++ "}]" - -instance Show Object where - show o = "Object " ++ show (objectPathToText $ objectObjectPath o) ++ " [(" - ++ intercalate "), (" (map show $ objectInterfaces o) ++ ")]" +import DBus.Error +import DBus.Property +import DBus.Signal +import DBus.Method -findObject :: ObjectPath -> Object -> Maybe Object -findObject path o = case stripObjectPrefix (objectObjectPath o) path of - Nothing -> Nothing - Just suff -> if isEmpty suff then Just o - else listToMaybe . catMaybes $ - (findObject suff <$> objectSubObjects o) - -errorFailed msg = (MsgError "org.freedesktop.DBus.Error.Failed" - (Just msg) - []) - --- noSuchInterface, noSuchProperty, propertyNotReadable, propertyNotReadable -noSuchInterface = errorFailed "No such interface" -noSuchProperty = errorFailed "No such property" -propertyNotReadable = errorFailed "Property is not readable" -propertyNotWriteable = errorFailed "Property is not writeable" -argTypeMismatch = errorFailed "Argument type missmatch" - -findProperty o ifaceName prop - = case find ((== ifaceName) . interfaceName) $ objectInterfaces o of +findProperty (Object o) ifaceName prop + = case Map.lookup ifaceName o of Nothing -> Left noSuchInterface - Just iface -> case find ((== prop) . propertyName) - $ interfaceProperties iface of + Just iface -> case find (\(SomeProperty p) -> propertyName p == prop) + $ interfaceProperties iface of Nothing -> Left noSuchProperty Just p -> Right p -propertyInterface = "org.freedesktop.DBus.Properties" +getAllProperties iface = liftM (SDBA . singletonArg . toRep . mconcat) + . forM (interfaceProperties iface) + $ \(SomeProperty p) -> + case propertyGet p of + Nothing -> return (Map.empty :: Map Text (DBusValue TypeVariant)) + Just g -> flip catchMethodError (\_ -> return Map.empty) $ do + res <- g + return $ Map.singleton (propertyName p) (DBVVariant res) handleProperty :: Object -> ObjectPath -> MemberName -> [SomeDBusValue] - -> Either MsgError (SignalT IO SomeDBusArguments) + -> Either MsgError (MethodHandlerT IO SomeDBusArguments) handleProperty o _ "Get" [mbIface, mbProp] | Just ifaceName <- fromRep =<< dbusValue mbIface , Just propName <- fromRep =<< dbusValue mbProp = findProperty o ifaceName propName - >>= (\Property{ propertyAccessors = accs} -> - case getProperty accs of + >>= (\(SomeProperty prop) -> + case propertyGet prop of Nothing -> Left propertyNotReadable - Just rd -> Right $ SDBA . singletonArg <$> rd) + Just rd -> Right $ SDBA . singletonArg . DBVVariant <$> rd) handleProperty o path "Set" [mbIface , mbProp, mbVal] | Just ifaceName <- fromRep =<< dbusValue mbIface , Just propName <- fromRep =<< dbusValue mbProp = findProperty o ifaceName propName - >>= (\prop@Property{ propertyAccessors = accs} -> do - rd <- maybe (Left propertyNotWriteable) Right (setProperty accs) - v <- maybe (Left argTypeMismatch) Right (dbusValue mbVal) + >>= (\(SomeProperty prop@Property{propertySet = set}) -> do + wt <- maybe (Left propertyNotWriteable) Right set + v <- maybe (Left argTypeMismatch) Right + (fromVariant =<< dbusValue mbVal) Right $ do - invalidated <- rd v - when invalidated $ case propertyEmitsChangedSignal prop of - PECSTrue -> - signal - Signal - { signalPath = path - , signalInterface = propertyInterface - , signalMember = "PropertiesChanged" - , signalBody = - [ DBV $ - toRep ( ifaceName - , Map.fromList [(propName , DBVVariant v)] - , [] :: [Text] - ) - ] - } - PECSInvalidates -> - signal - Signal - { signalPath = path - , signalInterface = propertyInterface - , signalMember = "PropertiesChanged" - , signalBody = - [ DBV $ toRep - ( ifaceName - , Map.empty :: Map.Map Text - (DBusValue (TypeVariant)) - , [propName] - ) - ] - } - PECSFalse -> return () + invalidated <- wt v + when invalidated $ propertyChanged prop v return (SDBA ArgsNil)) +handleProperty (Object o) path "GetAll" [mbIface] + | Just ifaceName <- fromRep =<< dbusValue mbIface + = case Map.lookup ifaceName o of + Just iface -> Right $ getAllProperties iface + Nothing -> if ifaceName `elem` ["" + -- d-feet silliness: + , "org.freedesktop.DBus.Properties" + ] + then Right $ getAllProperties (mconcat $ Map.elems o) + else Left noSuchInterface handleProperty _ _ _ _ = Left argTypeMismatch -callAtPath :: Object +callAtPath :: Objects -> ObjectPath -> Text.Text -> Text.Text -> [SomeDBusValue] - -> Either MsgError (SignalT IO SomeDBusArguments) -callAtPath root path interface member args = case findObject path root of + -> Either MsgError (MethodHandlerT IO SomeDBusArguments) +callAtPath (Objects root) path interface member args = case Map.lookup path root of Nothing -> Left (MsgError "org.freedesktop.DBus.Error.Failed" (Just . Text.pack $ "No such object " ++ show path) []) - Just o -> case interface of - "org.freedesktop.DBus.Properties" -> handleProperty o path member args - _ -> case find ((== interface) . interfaceName) $ objectInterfaces o of + Just obj@(Object o) -> case interface of + "org.freedesktop.DBus.Properties" -> handleProperty obj path member args + _ -> case Map.lookup interface o of Nothing -> Left noSuchInterface Just i -> case find ((== member) . methodName) $ interfaceMethods i of Nothing -> Left (MsgError "org.freedesktop.DBus.Error.Failed" diff --git a/src/DBus/Property.hs b/src/DBus/Property.hs new file mode 100644 --- /dev/null +++ b/src/DBus/Property.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module DBus.Property where + +import Control.Applicative +import Control.Concurrent +import Control.Concurrent.STM +import qualified Control.Exception as Ex +import Control.Monad +import Control.Monad.Reader +import Control.Monad.Trans +import Control.Monad.Writer +import qualified Data.Foldable as Foldable +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Singletons +import Data.Text (Text) +import qualified Data.Text as Text + +import DBus.Signal +import DBus.Types +import DBus.Error +import DBus.Message +import DBus.Representable + +property :: SingI t => Property t -> Objects +property p = root (propertyPath p) + (object (propertyInterface p) + mempty{interfaceProperties = [SomeProperty p]}) + + + + +-- | Create a property from a getter and a setter. It will emit a +-- PropertyChanged signal when the setter is called. To change +-- this behaviour modify the propertyEmitsChangedSignal field +mkProperty :: Representable a => + ObjectPath + -> Text + -> Text + -> Maybe (MethodHandlerT IO a) + -> Maybe (a -> MethodHandlerT IO Bool) + -> PropertyEmitsChangedSignal + -> Property (RepType a) +mkProperty path iface name get set pecs = + let prop = Property { propertyPath = path + , propertyInterface = iface + , propertyName = name + , propertySet = doSet <$> set + , propertyGet = fmap toRep <$> get + , propertyEmitsChangedSignal = pecs + } + in prop + where + doSet f v = f =<< fromRepHelper v + fromRepHelper x = case fromRep x of + Nothing -> methodError argTypeMismatch + Just r -> return r + +-- | Make a property out of a TVar. The property is considered changed on every +-- outside set, no matter if the updated value is actually different from the +-- old one +mkTVarProperty :: Representable a => + ObjectPath + -> Text + -> Text + -> PropertyAccess + -> PropertyEmitsChangedSignal + -> TVar a + -> Property (RepType a) +mkTVarProperty path iface name acc pecs tv = + mkProperty path iface name + (case acc of + Write -> Nothing + _ -> Just (liftIO . atomically $ readTVar tv)) + (case acc of + Read -> Nothing + _ -> Just (\v -> liftIO (atomically (writeTVar tv v)) + >> return True)) + pecs + +manageStmProperty :: (Representable t, Eq t) => + Property (RepType t) + -> STM t + -> DBusConnection + -> IO () +manageStmProperty prop get con = do + let sendSig v = emitPropertyChanged prop v con + forkIO $ onEdge sendSig + return () + where + onEdge f = do + x <- atomically get + go f x + go f x = do + x' <- atomically $ do + x' <- get + when (x == x') $ retry + return x' + f x' + go f x' + +-- | Interface for D-BUs properties +propertiesInterfaceName = "org.freedesktop.DBus.Properties" + +-- | Create a propertyChangedSignal for a property +propertyChangedSignal :: Representable a => + Property (RepType a) + -> a + -> Maybe SomeSignal +propertyChangedSignal prop x = + let path = propertyPath prop + iface = propertyInterface prop + name = propertyName prop + in case propertyEmitsChangedSignal prop of + PECSFalse -> Nothing + PECSTrue -> + Just $ SomeSignal $ + Signal { signalPath = path + , signalInterface = propertiesInterfaceName + , signalMember = "PropertiesChanged" + , signalBody = flattenRep $ toRep + ( iface + , Map.fromList [ ( name , DBVVariant $ toRep x )] + , [] :: [Text] + )} + -- invalidates or emits changed but is write-only + PECSInvalidates -> Just $ SomeSignal $ + Signal { signalPath = path + , signalInterface = propertiesInterfaceName + , signalMember = "PropertiesChanged" + , signalBody = flattenRep $ toRep + ( iface + , Map.empty :: Map.Map Text (DBusValue (TypeVariant)) + , [name] + ) + } + +propertyChanged :: (MonadIO m, Representable a) => + Property (RepType a) -> a -> MethodHandlerT m () +propertyChanged prop a = + Foldable.mapM_ signal' (propertyChangedSignal prop a) + +emitPropertyChanged :: Representable a => + Property (RepType a) -> a -> DBusConnection -> IO () +emitPropertyChanged prop x con = do + let mbSig = propertyChangedSignal prop x + Foldable.forM_ mbSig $ flip emitSignal' con + +getProperty :: Representable a => + RemoteProperty (RepType a) + -> DBusConnection + -> IO (Either MethodError a) +getProperty rp con = do + res <- callMethod (rpEntity rp) (rpObject rp) propertiesInterfaceName "Get" + (rpInterface rp , rpName rp) [] con + return $ castVariant =<< res + where + castVariant v = case fromRep =<< fromVariant v of + Nothing -> Left $ MethodSignatureMissmatch [DBV v] + Just x -> Right x + +setProperty :: Representable a => + RemoteProperty (RepType a) + -> a + -> DBusConnection + -> IO (Either MethodError ()) +setProperty rp x con = do + callMethod (rpEntity rp) (rpObject rp) propertiesInterfaceName "Set" + (rpInterface rp , rpName rp, DBVVariant $ toRep x) [] con + +handlePropertyChanged :: Representable a => + RemoteProperty (RepType a) + -> (Maybe a -> IO ()) + -> DBusConnection + -> IO () +handlePropertyChanged rp f' con = do + let ms = anySignal { matchInterface = Just $ propertiesInterfaceName + , matchMember = Just "PropertiesChanged" + , matchPath = Just $ rpObject rp + , matchSender = Just $ rpEntity rp + } + mr = (matchSignalToMatchRule ms) + <> matchAll {mrArgs = [(0, rpInterface rp)]} + f Nothing = f' Nothing + f (Just sdbv) = case fromRep =<< dbusValue sdbv of + Nothing -> logError $ "Property type error " + ++ show (rpObject rp) ++ " / " + ++ Text.unpack (rpInterface rp) + ++ "." ++ Text.unpack (rpName rp) + Just v -> f' (Just v) + slot = Map.singleton (rpObject rp, rpInterface rp, rpName rp) [f] + atomically $ modifyTVar' (dbusPropertySlots con) (Map.unionWith (++) slot) + addMatch mr con diff --git a/src/DBus/Representable.hs b/src/DBus/Representable.hs --- a/src/DBus/Representable.hs +++ b/src/DBus/Representable.hs @@ -17,12 +17,28 @@ import Control.Applicative ((<$>), (<*>)) import Control.Monad +import qualified Data.ByteString as BS import Data.Int import qualified Data.Map as Map import Data.Singletons +import Data.Singletons.Decide +import Data.Singletons.Prelude.List import qualified Data.Text as Text import Data.Word -import qualified Data.ByteString as BS + +flattenRep :: ( Representable a ) => + a + -> DBusArguments (FlattenRepType (RepType a)) +flattenRep (x :: t) = + let rts = sing :: Sing (RepType t) + frts :: Sing (FlattenRepType (RepType t)) + frts = sFlattenRepType rts + in case (rts, frts) of + (STypeUnit, SNil) -> ArgsNil + (STypeStruct ts, ts') -> case toRep x of DBVStruct str -> structToArgs str + (t, SCons t' SNil) -> case t %~ t' of + Proved Refl -> ArgsCons (toRep x) ArgsNil + Disproved _ -> error "flattenRep: this shouldn't happen" -- class Representable; see DBus.Types forM [2..20] makeRepresentableTuple diff --git a/src/DBus/Scaffold.hs b/src/DBus/Scaffold.hs new file mode 100644 --- /dev/null +++ b/src/DBus/Scaffold.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} + +-- | TH helpers to build scaffolding from introspection data + + +module DBus.Scaffold where + +import Control.Applicative +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Monoid +import Data.Singletons +import Data.Singletons.Prelude.List +import Data.Text (Text) +import qualified Data.Text as Text +import Language.Haskell.TH +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + +import DBus.Introspect +import DBus.Message +import DBus.Representable +import DBus.Types +import DBus.Property + + +liftObjectPath :: ObjectPath -> ExpQ +liftObjectPath op = [| objectPath $( liftText $ objectPathToText op) |] + +liftArgDesc :: ArgumentDescription n -> ExpQ +liftArgDesc Done = [|Done|] +liftArgDesc (r :> rs) = [|$(liftText r) :> $(liftArgDesc rs)|] + + +toSomeMethodDescription :: Text + -> IInterface + -> IMethod + -> SomeMethodDescription +toSomeMethodDescription path iface imethod = + let iInArgs = filter ((/= Just Out) . iArgumentDirection) + (iMethodArguments imethod) + iOutArgs = filter ((== Just Out) . iArgumentDirection) + (iMethodArguments imethod) + inArgs = toSings iInArgs + outArgs = toSings iOutArgs + in case (inArgs, outArgs) of + ( SSAD (is :: Sing args) inDescs + ,SSAD (os :: Sing rets) outDescs) + -> withSingI is $ withSingI os $ + SMD (MD { methodObjectPath = objectPath path + , methodInterface = iInterfaceName iface + , methodMember = iMethodName imethod + , methodArgs = inDescs + , methodResult = outDescs + } :: MethodDescription args rets) + +interfacMethodDescriptions :: Text -> IInterface -> [SomeMethodDescription] +interfacMethodDescriptions path iface = + for (iInterfaceMethods iface) $ toSomeMethodDescription path iface + where for = flip map + +mapIInterfaces :: (Text -> IInterface -> [a]) -> Text -> INode -> [a] +mapIInterfaces f path node = + let ifaceMembers = f path =<< nodeInterfaces node + subNodeMembers = nodeSubnodes node >>= \n -> + let subPath = path <> "/" <> nodeName n + in mapIInterfaces f subPath n + in ifaceMembers ++ subNodeMembers + +nodeMethodDescriptions :: Text -> INode -> [SomeMethodDescription] +nodeMethodDescriptions = mapIInterfaces interfacMethodDescriptions + +interfacPropertyDescriptions :: Text -> IInterface -> [PropertyDescription] +interfacPropertyDescriptions path iface = + for (iInterfaceProperties iface) $ \p -> + PD { pdObjectPath = path + , pdInterface = iInterfaceName iface + , pdName = iPropertyName p + , pdType = iPropertyType p + } + where for = flip map + + +-- TODO: This should be completely replaced by RemoteProperty +data PropertyDescription = PD { pdObjectPath :: Text + , pdInterface :: Text + , pdName :: Text + , pdType :: DBusType + } + +nodePropertyDescriptions :: Text -> INode -> [PropertyDescription] +nodePropertyDescriptions = mapIInterfaces interfacPropertyDescriptions + +liftText t = [|Text.pack $(liftString (Text.unpack t))|] + + +promotedListT :: [TypeQ] -> TypeQ +promotedListT = foldr (\t ts -> appT (appT promotedConsT t) ts) promotedNilT + +arrows :: [TypeQ] -> TypeQ -> TypeQ +arrows = flip $ foldr (\t ts -> appT (appT arrowT t) ts) + +tupleType :: [TypeQ] -> TypeQ +tupleType xs = foldl (\ts t -> appT ts t) (tupleT (length xs)) xs + +promoteSimpleType t = promotedT (mkName (show t)) + +promoteDBusType :: DBusType -> TypeQ +promoteDBusType (DBusSimpleType t) = [t|'DBusSimpleType $(promoteSimpleType t)|] +promoteDBusType (TypeArray t) = [t| TypeArray $(promoteDBusType t)|] +promoteDBusType (TypeStruct ts) = + let ts' = promotedListT $ promoteDBusType <$> ts + in [t| TypeStruct $ts'|] +promoteDBusType (TypeDict k v) = + [t| TypeDict $(promoteSimpleType k) + $(promoteDBusType v) |] +promoteDBusType (TypeDictEntry k v) = + [t| TypeDictEntry $(promoteSimpleType k) + $(promoteDBusType v) |] +promoteDBusType TypeVariant = [t| TypeVariant |] +promoteDBusType TypeUnit = [t| TypeUnit |] + +readIntrospectXml :: FilePath -> Q INode +readIntrospectXml interfaceFile = do + qAddDependentFile interfaceFile + xml <- qRunIO $ BS.readFile interfaceFile + case xmlToNode xml of + Left e -> error $ "Could not parse introspection XML: " ++ show e + Right r -> return r + +liftMethodDescription :: String + -> SomeMethodDescription + -> Q [Dec] +liftMethodDescription name smd = case smd of + (SMD (md :: MethodDescription args rets)) -> do + let ats = promotedListT . map promoteDBusType $ + fromSing (sing :: Sing args) + rts = promotedListT . map promoteDBusType $ + fromSing (sing :: Sing rets) + md' = [|MD{ methodObjectPath = $(liftObjectPath $ methodObjectPath md) + , methodInterface = $(liftText $ methodInterface md) + , methodMember = $(liftText $ methodMember md) + , methodArgs = $(liftArgDesc $ methodArgs md) + , methodResult = $(liftArgDesc $ methodResult md) + } |] + tp <- sigD (mkName name) [t|MethodDescription $(ats) $(rts)|] + cl <- valD (varP (mkName name)) (normalB md') [] + return [tp, cl] + + +propertyFromDescription :: (PropertyDescription -> String) + -> Maybe Text + -> PropertyDescription + -> Q [Dec] +propertyFromDescription nameGen mbEntity pd = do + entName <- newName "entity" + let rp ent = [|RP{ rpEntity = $ent + , rpObject = objectPath $(liftText $ pdObjectPath pd) + , rpInterface = $(liftText $ pdInterface pd) + , rpName = $(liftText $ pdName pd) + } |] + name = mkName $ nameGen pd + entN = (mkName "entity") + typeName = mkName "t" + + arg = case mbEntity of + Nothing -> [[t|Text|]] + Just _ -> [] + t = promoteDBusType $ pdType pd + tp <- sigD name $ (arrows arg [t|RemoteProperty $(t)|]) + cl <- case mbEntity of + Nothing -> funD name [clause [varP entN] + (normalB (rp (varE entN))) []] + Just e -> valD (varP name) (normalB . rp $ liftText e) [] + return [tp, cl] + + +nodeSignals :: Text -> INode -> [SomeSignalDescription] +nodeSignals = mapIInterfaces interfaceSignalDs + +interfaceSignalDs :: Text -> IInterface -> [SomeSignalDescription] +interfaceSignalDs ndName iface = signalDs (objectPath ndName) + (iInterfaceName iface) + <$> iInterfaceSignals iface + + + +signalDs :: ObjectPath -> Text -> ISignal -> SomeSignalDescription +signalDs nPath iName iSig = + case toSings $ iSignalArguments iSig of + SSAD (s :: Sing ts) descs -> withSingI s $ (SSD + (SignalDescription { signalDPath = nPath + , signalDInterface = iName + , signalDMember = iSignalName iSig + , signalDArguments = descs + } :: SignalDescription (ts :: [DBusType]) + )) + +data SomeArgumentDescription where + SSAD :: Sing (ts :: [DBusType]) + -> ArgumentDescription (ArgParity ts) + -> SomeArgumentDescription + +toSings :: [IArgument] -> SomeArgumentDescription +toSings [] = SSAD SNil Done +toSings (iarg : iargs) = + let t = iArgumentType iarg + desc = iArgumentName iarg + in case (toSing t, toSings iargs) of + (SomeSing s, SSAD ss descs) + -> SSAD (SCons s ss) (desc :> descs) + + +liftSignalDescription :: String -> SomeSignalDescription -> Q [Dec] +liftSignalDescription nameString ssigDesc@(SSD (sigDesc :: SignalDescription a)) + = do + let name = mkName nameString + ts = fromSing (sing :: (Sing a)) + t = [t| SignalDescription $(promotedListT $ promoteDBusType <$> ts)|] + e = [| SignalDescription + { signalDPath = $(liftObjectPath $ signalDPath sigDesc) + , signalDInterface = $(liftText $ signalDInterface sigDesc) + , signalDMember = $(liftText $ signalDMember sigDesc) + , signalDArguments = $(liftArgDesc + $ signalDArguments sigDesc) + } |] + tpDecl <- sigD name t + decl <- valD (varP name) (normalB e) [] + return [tpDecl, decl] + where diff --git a/src/DBus/Signal.hs b/src/DBus/Signal.hs --- a/src/DBus/Signal.hs +++ b/src/DBus/Signal.hs @@ -1,12 +1,22 @@ +{-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} module DBus.Signal where import Control.Applicative -import Control.Monad.Trans +import Control.Concurrent.STM +import Control.Monad import Control.Monad.Catch (MonadThrow) +import Control.Monad.Trans +import Control.Monad.Writer import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map import Data.Maybe import Data.Monoid +import Data.Singletons +import Data.Singletons.Decide +import Data.Singletons.Prelude.List +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy.Builder as TB @@ -14,7 +24,9 @@ import DBus.Types import DBus.Message import DBus.MessageBus +import DBus.Representable + data MatchRule = MatchRule { mrType :: Maybe MessageType , mrSender :: Maybe Text.Text , mrInterface :: Maybe Text.Text @@ -27,10 +39,30 @@ , mrEavesdrop :: Maybe Bool } + matchAll :: MatchRule matchAll = MatchRule Nothing Nothing Nothing Nothing Nothing Nothing [] [] Nothing Nothing +-- Left-biased monoid +instance Monoid MatchRule where + mempty = matchAll + mappend lr rr = + MatchRule + { mrType = mrType lr `mplus` mrType rr + , mrSender = mrSender lr `mplus` mrSender rr + , mrInterface = mrInterface lr `mplus` mrInterface rr + , mrMember = mrMember lr `mplus` mrMember rr + , mrPath = mrPath lr `mplus` mrPath rr + , mrDestination = mrDestination lr `mplus` mrDestination rr + , mrArgs = mrArgs lr `mplus` mrArgs rr + , mrArgPaths = mrArgPaths lr `mplus` mrArgPaths rr + , mrArg0namespace = mrArg0namespace lr `mplus` mrArg0namespace rr + , mrEavesdrop = mrEavesdrop lr `mplus` mrEavesdrop rr + } + + + renderRule :: MatchRule -> Text.Text renderRule mr = Text.concat . TextL.toChunks . TB.toLazyText . mconcat . List.intersperse (TB.singleton ',') $ @@ -65,28 +97,157 @@ -- | Match a Signal against a rule. The argN, argNPath and arg0namespace -- parameter are ignored at the moment -matchSignal :: MessageHeader -> MatchRule -> Bool -matchSignal header rule = - let fs = fields header - in and $ catMaybes - [ Just $ messageType header == MessageTypeSignal - , (\x -> hFMember fs == Just x ) <$> mrMember rule - , (\x -> hFInterface fs == Just x ) <$> mrInterface rule - , (\(ns, x) -> case hFPath fs of - Nothing -> False - Just p -> if ns then isPathPrefix x p +matchSignal :: Signal a -> MatchRule -> Bool +matchSignal sig rule = and $ catMaybes + [ (\x -> signalMember sig == x ) <$> mrMember rule + , (\x -> signalInterface sig == x ) <$> mrInterface rule + , (\(ns, x) -> let p = (signalPath sig) + in if ns then isPathPrefix x p else x == p) <$> mrPath rule - , (\x -> hFDestination fs == Just x) <$> mrDestination rule ] +-- | Add a match rule addMatch :: (MonadIO m, MonadThrow m ) => MatchRule -> DBusConnection -> m () -addMatch rule = messageBusMethod "AddMatch" (renderRule rule) +addMatch rule con = do + let renderedRule = (renderRule rule) + liftIO . logDebug $ "adding signal match rule: " ++ show renderedRule + messageBusMethod "AddMatch" renderedRule con + +-- | Remove a match rule removeMatch :: (MonadIO m, MonadThrow m ) => MatchRule -> DBusConnection -> m () removeMatch rule = messageBusMethod "RemoveMatch" (renderRule rule) + + +matchSignalToMatchRule :: MatchSignal -> MatchRule +matchSignalToMatchRule ms= + matchAll { mrType = Just MessageTypeSignal + , mrInterface = matchInterface ms + , mrMember = matchMember ms + , mrPath = (False,) <$> matchPath ms + , mrSender = matchSender ms + } +-- | Add a match rule for the given signal specification and call function on +-- all incoming matching signals +addSignalHandler :: MatchSignal + -> MatchRule -- Addition Match rules. mempty for none + -> (SomeSignal -> IO ()) + -> DBusConnection + -> IO () +addSignalHandler ms rules m dbc = do + atomically $ modifyTVar (dbusSignalSlots dbc) ((fromSlot ms, m):) + let rule = rules <> matchSignalToMatchRule ms + addMatch rule dbc + where + fromSlot s = ( maybeToMatch $ matchInterface s + , maybeToMatch $ matchMember s + , maybeToMatch $ matchPath s + , maybeToMatch $ matchSender s) + + +castSignalBody :: SingI a => SomeSignal -> Maybe (DBusValue a) +castSignalBody (SomeSignal s) = + case (signalBody s) of + sr@(r :: DBusArguments ats) -> + -- Use fix to access the return type (We only care about the type) + fix $ \(_ :: Maybe (DBusValue ret)) -> + case sing :: Sing ret of + STypeStruct ts -> case (r, sing :: Sing ats) of + (ArgsNil, SNil) -> Nothing + (ArgsCons r' ArgsNil, SCons a SNil) -> + case a %~ (sing :: Sing ret) of + Proved Refl -> Just r' + Disproved _ -> Nothing + _ -> withSingI ts (DBVStruct <$> maybeArgsToStruct r) + STypeUnit -> case r of + ArgsNil -> Just DBVUnit + _ -> Nothing + _ -> case (sing :: Sing ats, r) of + (SCons at SNil, ArgsCons r' ArgsNil) -> + case at %~ (sing :: Sing ret) of + Proved Refl -> Just r' + Disproved _ -> Nothing + + +-- | Add a match rule (computed from the SignalDescription) and install a +-- handler that tries to convert the Signal's body and passes it to the callback +handleSignal :: Representable a => + SignalDescription (FlattenRepType (RepType a)) + -> Maybe Text + -> MatchRule + -> (a -> IO ()) + -> DBusConnection + -> IO () +handleSignal desc sender rules f con = do + let mSignal = MatchSignal { matchInterface = Just $ signalDInterface desc + , matchMember = Just $ signalDMember desc + , matchPath = Just $ signalDPath desc + , matchSender = sender + } + f' = \s -> case fromRep =<< castSignalBody s of + Nothing -> logWarning $ "Received signal " + ++ ((\(SomeSignal ss) -> show ss) s) + ++ " could not be converted to to" + ++ " type " + -- ++ (show . fromSing + -- $ (sing :: Sing ts)) + Just x -> f x + addSignalHandler mSignal rules f' con + +-- | Add a match rule for the given signal specification and put all incoming +-- signals into the TChan +signalChan :: MatchSignal + -> DBusConnection + -> IO (TChan SomeSignal) +signalChan match dbc = do + signalChan <- newTChanIO + addSignalHandler match mempty (atomically . writeTChan signalChan) dbc + return signalChan + +createSignal desc x = Signal{ signalPath = signalDPath desc + , signalInterface = signalDInterface desc + , signalMember = signalDMember desc + , signalBody = flattenRep $ toRep x + } + +---------------------- +-- Emitting signals -- +---------------------- + +signal :: (Representable a, Monad m) => + SignalDescription (FlattenRepType (RepType a)) + -> a + -> MethodHandlerT m () +signal desc (x :: a) = + let s = (sing :: Sing (RepType a)) + fs = sFlattenRepType s + in withSingI fs $ signal' (SomeSignal $ createSignal desc x) + +signal' :: Monad m => SomeSignal -> MethodHandlerT m () +signal' sig = MHT $ tell [sig] + +emitSignal' (SomeSignal s) con = do + sid <- atomically $ dBusCreateSerial con + logDebug $ "Emitting signal (ID = " ++ show sid ++ "): " ++ show s + sendBS con $ mkSignal sid [] s + +emitSignal :: Representable a => + SignalDescription (FlattenRepType (RepType a)) + -> a + -> DBusConnection -> IO () +emitSignal sigD (x :: a) con = + let s = (sing :: Sing (RepType a)) + fs = sFlattenRepType s + in withSingI fs $ emitSignal' (SomeSignal $ createSignal sigD x) con + +execSignalT :: MethodHandlerT IO a -> DBusConnection -> IO (Either MsgError a) +execSignalT m con = do + (x, sigs) <- runMethodHandlerT m + forM_ sigs $ flip emitSignal' con + return x diff --git a/src/DBus/Types.hs b/src/DBus/Types.hs --- a/src/DBus/Types.hs +++ b/src/DBus/Types.hs @@ -1,21 +1,12 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PolyKinds #-} - module DBus.Types where import Control.Applicative @@ -24,8 +15,8 @@ import Control.Concurrent.STM import qualified Control.Exception as Ex import Control.Monad +import Control.Monad.Except import Control.Monad.Trans -import Control.Monad.Trans.Error import Control.Monad.Writer.Strict import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Builder as BS @@ -34,29 +25,51 @@ import Data.Int import Data.List import Data.List (intercalate) +import Data.Map (Map) import qualified Data.Map as Map import Data.Singletons (withSingI) import Data.Singletons.Prelude.Bool -import Data.Singletons.Prelude.List +import Data.Singletons.Prelude.List hiding (Map) import Data.Singletons.TH hiding (Error) +import Data.String +import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable (Typeable) import Data.Word +import System.Log.Logger import Unsafe.Coerce (unsafeCoerce) --- import qualified DBus.Connection as DBus --- import qualified DBus.Message as DBus +dbusLogger :: String +dbusLogger = "DBus" +logDebug :: String -> IO () +logDebug = debugM dbusLogger +logWarning :: String -> IO () +logWarning = warningM dbusLogger + +logError :: String -> IO () +logError = errorM dbusLogger + + data ObjectPath = ObjectPath { opAbsolute :: Bool - , opParts :: [Text.Text] - } deriving (Eq, Data, Typeable) + , opParts :: [Text] + } deriving (Eq, Data, Typeable, Ord) +type InterfaceName = Text +type MemberName = Text -type InterfaceName = Text.Text -type MemberName = Text.Text +opNode op = ObjectPath { opAbsolute = False + , opParts = take 1 . reverse $ opParts op + } +opPath op = ObjectPath { opAbsolute = opAbsolute op + , opParts = case opParts op of + [] -> [] + opps -> init opps + } + newtype Signature = Signature {fromSignature :: [DBusType]} deriving (Show, Eq) @@ -72,6 +85,9 @@ instance Show ObjectPath where show = Text.unpack . objectPathToText +instance IsString ObjectPath where + fromString = objectPath . Text.pack + stripObjectPrefix :: ObjectPath -> ObjectPath -> Maybe ObjectPath stripObjectPrefix (ObjectPath abs1 pre) (ObjectPath abs2 x) | abs1 == abs2 = ObjectPath False <$> stripPrefix pre x @@ -160,46 +176,121 @@ flattenRepType t@(TypeDict _ _) = [t] flattenRepType t@(TypeDictEntry _ _) = [t] flattenRepType t@(TypeVariant) = [t] - |] -- | A Transformer for (IO) actions that might want to send a signal. -newtype SignalT m a = SignalT { unSignal :: WriterT [Signal] m a} - deriving ( Functor - , Applicative - , Monad - , MonadTrans ) +newtype MethodHandlerT m a = + MHT { unMHT :: ExceptT MsgError (WriterT [SomeSignal] m) a} + deriving ( Functor + , Applicative + , Monad + , MonadIO + ) -data Signal = Signal { signalPath :: ObjectPath - , signalInterface :: InterfaceName - , signalMember :: MemberName - , signalBody :: [SomeDBusValue] - } +methodError :: Monad m => MsgError -> MethodHandlerT m a +methodError = MHT . throwError +-- instance MonadError MethodHandlerT -runSignalT :: SignalT m a -> m (a, [Signal]) -runSignalT (SignalT w) = runWriterT w +catchMethodError :: Monad m => + MethodHandlerT m a + -> (MsgError -> MethodHandlerT m a) + -> MethodHandlerT m a +catchMethodError m f = MHT $ catchError (unMHT m) (unMHT . f) -signal :: Monad m => Signal -> SignalT m () -signal sig = SignalT $ tell [sig] +instance MonadTrans MethodHandlerT where + lift = MHT . lift . lift +instance (Functor m, Monad m) => Alternative (MethodHandlerT m) where + empty = mzero + (<|>) = mplus +instance Monad m => MonadPlus (MethodHandlerT m) where + mzero = methodError (MsgError "org.freedesktop.DBus.Error.Failed" Nothing []) + mplus (MHT m) (MHT n) = MHT . ExceptT $ do + res <- runExceptT m + case res of + Left e -> runExceptT n + Right r -> return $ Right r +runMethodHandlerT :: MethodHandlerT m a -> m (Either MsgError a, [SomeSignal]) +runMethodHandlerT (MHT w) = runWriterT $ runExceptT w + +data Signal a = Signal { signalPath :: ObjectPath + , signalInterface :: InterfaceName + , signalMember :: MemberName + , signalBody :: DBusArguments a + } deriving (Show) + +data SomeSignal where + SomeSignal :: SingI a => Signal a -> SomeSignal + +deriving instance Show SomeSignal + +data SignalDescription a = SignalDescription + { signalDPath :: ObjectPath + , signalDInterface :: InterfaceName + , signalDMember :: MemberName + , signalDArguments :: ArgumentDescription (ArgParity a) + } deriving (Typeable) + +signalDArgumentTypes :: SingI ts => SignalDescription ts -> [DBusType] +signalDArgumentTypes (_ :: SignalDescription ts) = fromSing (sing :: Sing ts) + +instance SingI a => Show (SignalDescription a) where + show (sd :: SignalDescription ts) + = "SignalDescription{ signalDPath = " ++ show (signalDPath sd) + ++ ", signalDInterface = " + ++ show (signalDInterface sd) + ++ ", signalDMember = " ++ show (signalDMember sd) + ++ ", signalDArgumentTypes = " + ++ show (fromSing $ (sing :: Sing ts)) + ++ ",signalDArguments = " + ++ show (adToList $ signalDArguments sd) + ++ "}" + +instance Eq (SignalDescription a) where + x == y = and [ ((==) `on` signalDPath) x y + , ((==) `on` signalDInterface) x y + , ((==) `on` signalDMember) x y + -- argument types are guaranteed to be equal + , adToList (signalDArguments x) == adToList (signalDArguments y) + ] + +data SomeSignalDescription where + SSD :: forall (a :: [DBusType]) . SingI a => + SignalDescription a -> SomeSignalDescription + deriving (Typeable) + +deriving instance Show SomeSignalDescription + +instance Eq SomeSignalDescription where + (SSD (x :: SignalDescription a)) == (SSD (y :: SignalDescription b)) + = case (sing :: Sing a) %~ (sing :: Sing b) of + Proved (Refl{}) -> x == y + Disproved{} -> False + type family ArgsOf x :: Parity where ArgsOf (IO x) = 'Null - ArgsOf (SignalT IO x) = 'Null + ArgsOf (MethodHandlerT IO x) = 'Null ArgsOf (a -> b) = 'Arg (ArgsOf b) -infixr 0 :> -data ResultDescription parity where - (:>) :: Text.Text -> ResultDescription n -> ResultDescription (Arg n) - ResultDone :: ResultDescription 'Null +type family ArgParity (x :: [DBusType]) :: Parity where + ArgParity '[] = 'Null + ArgParity (x ': xs) = Arg (ArgParity xs) -infixr 0 :-> +infixr 0 :> data ArgumentDescription parity where - (:->) :: Text.Text -> ArgumentDescription n -> ArgumentDescription (Arg n) - Result :: ArgumentDescription 'Null + (:>) :: Text -> ArgumentDescription n -> ArgumentDescription (Arg n) + Done :: ArgumentDescription 'Null + deriving (Typeable) +adToList :: ArgumentDescription n -> [Text] +adToList Done = [] +adToList (x :> xs) = x : adToList xs +instance Show (ArgumentDescription n) where + show res = show $ adToList res + data DBusArguments :: [DBusType] -> * where ArgsNil :: DBusArguments '[] ArgsCons :: DBusValue a -> DBusArguments as -> DBusArguments (a ': as) @@ -293,7 +384,7 @@ DBVUInt64 :: Word64 -> DBusValue ('DBusSimpleType TypeUInt64) DBVDouble :: Double -> DBusValue ('DBusSimpleType TypeDouble) DBVUnixFD :: Word32 -> DBusValue ('DBusSimpleType TypeUnixFD) - DBVString :: Text.Text -> DBusValue ('DBusSimpleType TypeString) + DBVString :: Text -> DBusValue ('DBusSimpleType TypeString) DBVObjectPath :: ObjectPath -> DBusValue ('DBusSimpleType TypeObjectPath) DBVSignature :: [DBusType] -> DBusValue ('DBusSimpleType TypeSignature) DBVVariant :: (SingI t ) => DBusValue t -> DBusValue TypeVariant @@ -302,11 +393,9 @@ DBVStruct :: DBusStruct ts -> DBusValue (TypeStruct ts) DBVDict :: [(DBusValue ('DBusSimpleType k) ,DBusValue v)] -> DBusValue (TypeDict k v) - -- TODO: Remove - - -- | Unit isn't an actual DBus type and is included only for use with methods + DBVUnit :: DBusValue TypeUnit -- How to get rid of this? + -- Unit isn't an actual DBus type and is included only for use with methods -- that don't return a value. - DBVUnit :: DBusValue TypeUnit instance Eq (DBusValue t) where @@ -466,104 +555,99 @@ data MethodWrapper av rv where - MReturn :: SingI ts => SignalT IO (DBusArguments ts) -> MethodWrapper '[] ts + MReturn :: SingI ts => MethodHandlerT IO (DBusArguments ts) -> MethodWrapper '[] ts MAsk :: SingI t => (DBusValue t -> MethodWrapper avs rv ) -> MethodWrapper (t ': avs) rv -type family ArgParity (x :: [DBusType]) :: Parity where - ArgParity '[] = 'Null - ArgParity (x ': xs) = Arg (ArgParity xs) - data Method where Method :: (SingI avs, SingI ts) => MethodWrapper avs ts - -> Text.Text + -> Text -> ArgumentDescription (ArgParity avs) - -> ResultDescription (ArgParity ts) + -> ArgumentDescription (ArgParity ts) -> Method +data PropertyAccess = Read + | Write + | ReadWrite + deriving (Eq, Show, Data, Typeable) + data PropertyEmitsChangedSignal = PECSTrue | PECSInvalidates | PECSFalse - -data PropertyWrapper t where - PropertyWrapper :: forall t. SingI t => - { setProperty :: Maybe (DBusValue t -> SignalT IO Bool) - -- | ^ setter for the property. Returns - , getProperty :: Maybe (SignalT IO (DBusValue t)) - } -> PropertyWrapper t - -data Property where +data Property t where Property :: forall t . (SingI t) => - { propertyName :: Text.Text - , propertyAccessors :: PropertyWrapper t + { propertyPath :: ObjectPath + , propertyInterface :: Text + , propertyName :: Text + , propertyGet :: Maybe (MethodHandlerT IO (DBusValue t)) + , propertySet :: Maybe (DBusValue t -> MethodHandlerT IO Bool) , propertyEmitsChangedSignal :: PropertyEmitsChangedSignal - } -> Property + } -> Property t -propertyType :: Property -> DBusType -propertyType Property{propertyAccessors = accs :: PropertyWrapper t} - = fromSing (sing :: Sing t) +data SomeProperty where + SomeProperty :: forall t . (SingI t) => + {fromSomeProperty :: Property t} -> SomeProperty -data Annotation = Annotation { annotationName :: Text.Text - , annotationValue :: Text.Text +propertyType :: SingI t => Property t -> DBusType +propertyType (_ :: Property t) = fromSing (sing :: Sing t) + +data RemoteProperty a = RP { rpEntity :: Text + , rpObject :: ObjectPath + , rpInterface :: Text + , rpName :: Text + } deriving (Show, Eq) + + +data Annotation = Annotation { annotationName :: Text + , annotationValue :: Text } deriving (Eq, Show, Data, Typeable) data SignalArgument = - SignalArgument { signalArgumentName :: Text.Text + SignalArgument { signalArgumentName :: Text , signalArgumentType :: DBusType } -data SignalInterface = SignalI { signalName :: Text.Text - , signalArguments :: [SignalArgument] - , signalAnnotations :: [Annotation] - } - -data Interface = Interface { interfaceName :: Text.Text - , interfaceMethods :: [Method] +data Interface = Interface { interfaceMethods :: [Method] , interfaceAnnotations :: [Annotation] - , interfaceSignals :: [SignalInterface] - , interfaceProperties :: [Property] + , interfaceSignals :: [SomeSignalDescription] + , interfaceProperties :: [SomeProperty] } -instance Eq Interface where - (==) = (==) `on` interfaceName +instance Monoid Interface where + mempty = Interface [] [] [] [] + (Interface m1 a1 s1 p1) `mappend` (Interface m2 a2 s2 p2) = + Interface (m1 <> m2) (a1 <> a2) (s1 <> s2) (p1 <> p2) -data Object = Object { objectObjectPath :: ObjectPath - , objectInterfaces :: [Interface] - , objectSubObjects :: [Object] - } +newtype Object = Object {interfaces :: Map Text Interface } +instance Monoid Object where + mempty = Object Map.empty + mappend (Object o1) (Object o2) = Object $ Map.unionWith (<>) o1 o2 +object interfaceName iface = Object $ Map.singleton interfaceName iface + + +newtype Objects = Objects {unObjects :: Map ObjectPath Object} + +instance Monoid Objects where + mempty = Objects Map.empty + mappend (Objects o1) (Objects o2) = Objects $ Map.unionWith (<>) o1 o2 + +root path object = Objects $ Map.singleton path object + -------------------------------------------------- -- Connection and Message -------------------------------------------------- -data MsgError = MsgError { errorName :: Text.Text - , errorText :: Maybe Text.Text +data MsgError = MsgError { errorName :: Text + , errorText :: Maybe Text , errorBody :: [SomeDBusValue] } deriving (Show, Typeable) instance Ex.Exception MsgError -instance Error MsgError where - strMsg str = MsgError { errorName = "org.freedesktop.DBus.Error.Failed" - , errorText = Just (Text.pack str) - , errorBody = [] - } - noMsg = MsgError { errorName = "org.freedesktop.DBus.Error.Failed" - , errorText = Nothing - , errorBody = [] - } - - -data Connection = Connection { primConnection :: () -- DBus.Connection - , answerSlots :: TVar (Map.Map Word32 - (TMVar (Either MsgError - SomeDBusValue))) - , mainLoop :: ThreadId - } - data MethodError = MethodErrorMessage [SomeDBusValue] | MethodSignatureMissmatch [SomeDBusValue] deriving (Show, Typeable) @@ -574,11 +658,64 @@ type Slot = Either [SomeDBusValue] [SomeDBusValue] -> STM () type AnswerSlots = Map.Map Serial Slot +data Match a = Match a | MatchAny + deriving (Show) + +checkMatch :: Eq a => Match a -> Match a -> Bool +checkMatch MatchAny _ = True +checkMatch _ MatchAny = True +checkMatch (Match x) (Match y) = x == y + +maybeToMatch :: Maybe a -> Match a +maybeToMatch Nothing = MatchAny +maybeToMatch (Just x) = Match x + +data MatchSignal = MatchSignal { matchInterface :: Maybe Text + , matchMember :: Maybe Text + , matchPath :: Maybe ObjectPath + , matchSender :: Maybe Text + } deriving (Show, Eq, Ord) + +anySignal = MatchSignal Nothing Nothing Nothing Nothing + +type SignalSlots = [ (( Match Text + , Match Text + , Match ObjectPath + , Match Text) + , (SomeSignal -> IO ())) ] + +type PropertySlots = Map ( ObjectPath + , Text -- Interface + , Text -- Member + ) + [Maybe SomeDBusValue -> IO ()] + + data DBusConnection = DBusConnection { dBusCreateSerial :: STM Serial , dBusAnswerSlots :: TVar AnswerSlots + , dbusSignalSlots :: TVar SignalSlots + , dbusPropertySlots :: TVar PropertySlots , dBusWriteLock :: TMVar (BS.Builder -> IO ()) - , dBusConnectionName :: Text.Text + , dBusConnectionName :: Text , connectionAliveRef :: TVar Bool } + +data MethodDescription args rets where + MD :: + { methodObjectPath :: ObjectPath + , methodInterface :: Text + , methodMember :: Text + , methodArgs :: ArgumentDescription (ArgParity args) + , methodResult :: ArgumentDescription (ArgParity rets) + } -> MethodDescription args rets + +data SomeMethodDescription where + SMD :: (SingI args, SingI rets) => MethodDescription args rets + -> SomeMethodDescription + +instance Show (MethodDescription args rets) where + show md = "Method " ++ show (methodObjectPath md) + ++ " / " ++ Text.unpack (methodInterface md) + ++ "." ++ Text.unpack (methodMember md) diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} @@ -176,7 +177,8 @@ STypeArray ts -> withSingI ts $ ( case shrink (fromSing (sing :: Sing t)) of tss -> for tss $ \tshrink -> case toSing tshrink of - (SomeSing (ss :: Sing tt)) -> withSingI ss $ + (SomeSing (ss :: Sing (tt :: DBusType))) + -> withSingI ss $ DBV (DBVArray ([] :: [DBusValue tt])) ) ++ [ DBV ( DBVArray [] :: DBusValue t) diff --git a/tests/Runtest.hs b/tests/Runtest.hs deleted file mode 100644 --- a/tests/Runtest.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import qualified Control.Exception as Ex -import DBus -import DBus.Types -import DBus.Object -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Word - - -testFunction1 txt num b = - if b then Right $ (fromIntegral $ Text.length txt) * num - else Left txt - -testAction1 :: Text -> Word32 -> Bool -> IO Word32 -testAction1 txt num doError = do - case testFunction1 txt num doError of - Right num -> return num - Left e -> Ex.throwIO $ errorFailed txt - -testMethod = Method (repMethod testAction1) - "testMethod1" - ("text" :-> "number" :-> "error?" :-> Result) - ("another number" :> ResultDone) - -testInterface = Interface "dbus.test" [testMethod] [] [] [] - -testObject = Object { objectObjectPath = objectPath "dbus/test" - , objectInterfaces = [testInterface] - , objectSubObjects = [] - } - -root = Object { objectObjectPath = objectPath "/" - , objectInterfaces = [] - , objectSubObjects = [testObject] - } - -server = do - con <- connectBus Session - (\con header bdy -> do - print header - objectRoot (addIntrospectable root) - con header bdy - ) ignore - requestName "dbus.test" def con - return con - - - - -client = connectBus Session ignore ignore - - -main = do - srvCon <- server - cl <- client - res <- callMethod - "dbus.test" (objectPath "/dbus/test") "dbus.test" "testMethod1" - ("test" :: Text, 13 :: Word32, True) - [] cl - print (res :: (Either MethodError Word32)) - checkAlive srvCon - return ()