d-bus 0.1.2 → 0.1.3
raw patch · 17 files changed
+1540/−578 lines, 17 filesdep +tasty-hunitdep ~mtldep ~textdep ~transformers
Dependencies added: tasty-hunit
Dependency ranges changed: mtl, text, transformers
Files
- d-bus.cabal +44/−25
- src/DBus.hs +26/−3
- src/DBus/Auth.hs +3/−3
- src/DBus/Error.hs +15/−0
- src/DBus/Introspect.hs +229/−66
- src/DBus/MainLoop.hs +125/−26
- src/DBus/Message.hs +65/−32
- src/DBus/MessageBus.hs +2/−3
- src/DBus/Method.hs +117/−0
- src/DBus/Object.hs +45/−231
- src/DBus/Property.hs +195/−0
- src/DBus/Representable.hs +17/−1
- src/DBus/Scaffold.hs +234/−0
- src/DBus/Signal.hs +174/−13
- src/DBus/Types.hs +246/−109
- tests/Main.hs +3/−1
- tests/Runtest.hs +0/−65
d-bus.cabal view
@@ -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
src/DBus.hs view
@@ -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
src/DBus/Auth.hs view
@@ -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)
src/DBus/Error.hs view
@@ -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"
src/DBus/Introspect.hs view
@@ -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
src/DBus/MainLoop.hs view
@@ -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 ()
src/DBus/Message.hs view
@@ -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
src/DBus/MessageBus.hs view
@@ -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
+ src/DBus/Method.hs view
@@ -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
src/DBus/Object.hs view
@@ -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"
+ src/DBus/Property.hs view
@@ -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
src/DBus/Representable.hs view
@@ -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
+ src/DBus/Scaffold.hs view
@@ -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
src/DBus/Signal.hs view
@@ -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
src/DBus/Types.hs view
@@ -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)
tests/Main.hs view
@@ -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)
− tests/Runtest.hs
@@ -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 ()