d-bus 0.1.3.3 → 0.1.3.4
raw patch · 9 files changed
+249/−39 lines, 9 filesdep ~basedep ~textnew-component:exe:dbus-introspectnew-component:exe:liferea-example
Dependency ranges changed: base, text
Files
- d-bus.cabal +19/−1
- dbus-introspect/Main.hs +47/−0
- liferea-example/Main.hs +35/−0
- src/DBus.hs +24/−6
- src/DBus/Introspect.hs +5/−9
- src/DBus/MainLoop.hs +10/−3
- src/DBus/Scaffold.hs +57/−7
- src/DBus/TH.hs +31/−0
- src/DBus/Types.hs +21/−13
d-bus.cabal view
@@ -1,5 +1,5 @@ name: d-bus-version: 0.1.3.3+version: 0.1.3.4 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@@ -77,6 +77,22 @@ , ScopedTypeVariables , TypeFamilies +executable dbus-introspect+ hs-source-dirs: dbus-introspect+ main-is: Main.hs+ build-depends: base+ , d-bus+ , text+ default-language: Haskell2010++executable liferea-example+ hs-source-dirs: liferea-example+ main-is: Main.hs+ build-depends: base+ , d-bus+ , text+ default-language: Haskell2010+ test-suite unittests type: exitcode-stdio-1.0 hs-source-dirs: tests@@ -95,6 +111,8 @@ , text , xml-hamlet default-language: Haskell2010++ -- test-suite integrationtest -- type: exitcode-stdio-1.0
+ dbus-introspect/Main.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-}++module Main where++import Data.Char+import Data.Maybe (fromMaybe, listToMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import System.Environment+import System.Exit+import System.IO++import DBus++main = do+ args <- getArgs+ (bus, entity, root) <-+ case args of+ (busS : entityS : mbRoot) ->+ let bus :: ConnectionType+ bus = case toLower <$> busS of+ "session" -> Session+ "system" -> System+ _ -> Address busS+ in return ( bus+ , Text.pack entityS+ , Text.pack $ fromMaybe "" (listToMaybe mbRoot)+ )+ _ -> do+ hPutStrLn stderr "usage: dbus-introspect <bus> <entity> [<root>]"+ hPutStrLn stderr " where <bus> is one of \"session\", \"system\" or an address"+ exitFailure+ con <- connectClient bus+ res <- callMethod entity (objectPath root) "org.freedesktop.DBus.Introspectable" "Introspect"+ DBVUnit [] con+ case res of+ Left e -> hPutStrLn stderr $ "Error getting introspection data: " ++ showError e+ Right r -> Text.putStrLn r++showError :: MethodError -> String+showError error@(MethodErrorMessage (message : _)) =+ case message of+ DBV (DBVString message) -> Text.unpack message+ _ -> show error+showError error = show error
+ liferea-example/Main.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}++module Main where++import DBus+import Data.Int+import Data.Text (Text)+import qualified Data.Text as Text++main = do+ con <- connectClient Session+ result <- callMethod "net.sourceforge.liferea"+ "/org/gnome/feed/Reader"+ "org.gnome.feed.Reader"+ "GetUnreadItems"+ ()+ []+ con+ :: IO (Either MethodError Int32)++ case result of+ Left e -> error $ "something went wrong " ++ show e+ Right unread -> putStrLn $ "We have " ++ show unread ++ " unread items"+++unreadItems :: MethodDescription '[] '[ 'DBusSimpleType 'TypeInt32]+unreadItems =+ MD { methodObjectPath = "/org/gnome/feed/Reader"+ , methodInterface = "org.gnome.feed.Reader"+ , methodMember = "GetUnreadItems"+ , methodArgs = Done+ , methodResult = "unread items" :> Done+ }
src/DBus.hs view
@@ -3,8 +3,9 @@ -- * Connection management DBusConnection , ConnectionType(..)- , connectBus+ , connectClient , makeServer+ , connectBus , MethodCallHandler , SignalHandler , checkAlive@@ -30,6 +31,12 @@ , makeRepresentable , makeRepresentableTuple -- * DBus specific types+-- ** DBus Types+-- $Types+ , DBusSimpleType(..)+ , DBusType(..)+ , Signature(..)+ , typeOf -- ** DBus Values , DBusValue(..) , castDBV@@ -37,11 +44,6 @@ , SomeDBusValue(..) , dbusValue , fromVariant--- ** Signature- , DBusSimpleType(..)- , DBusType(..)- , Signature(..)- , typeOf -- ** Objects , Object(..) , Interface(..)@@ -96,10 +98,21 @@ , getConnectionUnixUser , getConnectionProcessID , getID+-- * Scaffolding+ , module DBus.Scaffold -- * Re-exports , def ) where +-- $types+--+-- DBus has it's own type system, described here+-- <https://dbus.freedesktop.org/doc/dbus-specification.html#type-system>+--+-- Types are divided into basic types, represented in this library by+-- 'DBusSimpleType', and composite types, represented by 'DBusType'. Only simple+-- types can be the keys in a dictionary+ import DBus.Introspect import DBus.MainLoop import DBus.Message@@ -110,7 +123,12 @@ import DBus.Signal import DBus.TH import DBus.Types+import DBus.Scaffold import Data.Default (def) -- | Ignore all incoming messages/signals ignore _ _ _ = return ()++-- | Connect to a message bus as a client+connectClient :: ConnectionType -> IO DBusConnection+connectClient bus = connectBus bus ignore ignore
src/DBus/Introspect.hs view
@@ -93,7 +93,7 @@ , iInterfaceAnnotations :: [Annotation] } deriving (Eq, Show, Data, Typeable) -data INode = INode { nodeName :: Text+data INode = INode { nodeName :: Maybe Text , nodeInterfaces :: [IInterface] , nodeSubnodes :: [INode] } deriving (Eq, Show, Data, Typeable)@@ -167,7 +167,7 @@ xpNode = xpWrap (\(name, (is, ns)) -> INode name is ns) (\(INode name is ns) -> (name, (is, ns))) $ xpElem "node"- (xpAttribute "name" xpText)+ (xpAttribute' "name" xpText) (xp2Tuple (xpFindMatches xpInterface) (xpFindMatches xpNode)) @@ -178,10 +178,6 @@ Left e -> Left $ Text.pack (ppUnpickleError e) 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"@@ -359,7 +355,7 @@ -> Map ObjectPath Object -> INode introspectObject recurse path (Object ifaces) sub- = INode { nodeName = objectPathToText path+ = INode { nodeName = Just $ objectPathToText path , nodeInterfaces = let propIface = if hasInterface propertiesInterfaceName ifaces then []@@ -377,7 +373,7 @@ , nodeSubnodes = (if recurse then (uncurry3 $ introspectObject True) else \(n, _, _) ->- INode { nodeName = objectPathToText n+ INode { nodeName = Just $ objectPathToText n , nodeInterfaces = [] , nodeSubnodes = [] })@@ -393,7 +389,7 @@ case Map.updateLookupWithKey (\_ _ -> Nothing) path os of (Nothing, _) -> let oss = Map.mapKeys (fromMaybe "" . stripObjectPrefix path) os- in INode { nodeName = objectPathToText path+ in INode { nodeName = Just $ objectPathToText path , nodeInterfaces = [] , nodeSubnodes = uncurry3 (introspectObject recursive )
src/DBus/MainLoop.hs view
@@ -204,7 +204,7 @@ checkAlive :: DBusConnection -> IO Bool checkAlive conn = atomically $ readTVar (connectionAliveRef conn) --- | Wait until connection is closed+-- | Wait until connection is closed. The intended use is to keep alive servers waitFor :: DBusConnection -> IO () waitFor conn = atomically $ do alive <- readTVar (connectionAliveRef conn)@@ -222,7 +222,9 @@ -- DBUS_SESSION_BUS_ADDRESS | Address String -- ^ The bus at the give addresss -type MethodCallHandler = ( DBusConnection+type MethodCallHandler = ( DBusConnection -- ^ Connection that the call was+ -- received from. Should be used to+ -- return the result or error -> MessageHeader -> [SomeDBusValue] -> IO ())@@ -232,7 +234,11 @@ -> [SomeDBusValue] -> IO ()) --- | Create a new connection to a message bus+-- | General way to connect to a message bus. Takes two callback functions:+--+-- * A 'MethodCallHandler' that is invoked when a method call is received.+--+-- * A SignalHandler that is invoked when a Mesage is received: connectBus :: ConnectionType -- ^ Bus to connect to -> MethodCallHandler -- ^ Handler for incoming method calls -> SignalHandler -- ^ Handler for incoming signals@@ -314,6 +320,7 @@ debugM "DBus" $ "Done" return conn{dBusConnectionName = connName} +-- | Create a simple server that exports @Objects@ and ignores all incoming signals makeServer :: ConnectionType -> Objects -> IO DBusConnection makeServer transport objs = do connectBus transport (objectRoot (addIntrospectable objs))
src/DBus/Scaffold.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}@@ -5,13 +6,18 @@ -- | TH helpers to build scaffolding from introspection data --module DBus.Scaffold where+module DBus.Scaffold+ ( module DBus.Scaffold+ , def+ ) where import Control.Applicative import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as BS+import Data.Char+import Data.Default+import Data.Maybe (fromMaybe, catMaybes) import Data.Monoid import Data.Singletons import Data.Singletons.Prelude.List@@ -27,7 +33,55 @@ import DBus.Types import DBus.Property +data DBusEndpointOptions =+ DBusEndpointOptions { methodNames :: SomeMethodDescription -> Maybe String+ , propertyNames :: String -> String+ , signalNames :: String -> String+ } +defaultDbusEndpointOptions :: DBusEndpointOptions+defaultDbusEndpointOptions =+ DBusEndpointOptions+ { methodNames = \(SMD md) -> filterInterfaces (methodInterface md)+ . downcase . Text.unpack $ methodMember md+ , propertyNames = downcase . (++ "P")+ , signalNames = downcase . (++ "Signal")+ }+ where+ filterInterfaces iface x =+ case iface `elem` [ introspectableInterfaceName+ , "org.freedesktop.DBus.Peer"+ , "org.freedesktop.DBus.Properties"+ ] of+ True -> Nothing+ False -> Just x+ downcase [] = []+ downcase (x:xs) = toLower x : xs++instance Default DBusEndpointOptions where+ def = defaultDbusEndpointOptions++makeDbusEndpoints :: DBusEndpointOptions -> ObjectPath -> FilePath -> Q [Dec]+makeDbusEndpoints conf root xmlFile = do -- @TODO: root+ node <- readIntrospectXml xmlFile+ let methods = nodeMethodDescriptions "" node+ propDs = nodePropertyDescriptions "" node+ sigDs = nodeSignals "" node+ downcase [] = []+ downcase (x:xs) = toLower x : xs+ mfs <- fmap catMaybes . forM methods $ \smd ->+ case methodNames conf smd of+ Nothing -> return Nothing+ Just name -> Just <$> liftMethodDescription name smd+ props <- forM propDs $ propertyFromDescription+ (propertyNames conf . Text.unpack . pdName)+ Nothing+ -- sigs <- forM sigDs $ \(ssd@(SSD sd)) ->+ -- liftSignalDescription () ssd+ return . concat $ mfs ++ props -- ++ sigs+ where+ for = flip fmap+ liftObjectPath :: ObjectPath -> ExpQ liftObjectPath op = [| objectPath $( liftText $ objectPathToText op) |] @@ -67,7 +121,7 @@ mapIInterfaces f path node = let ifaceMembers = f path =<< nodeInterfaces node subNodeMembers = nodeSubnodes node >>= \n ->- let subPath = path <> "/" <> nodeName n+ let subPath = path <> "/" <> fromMaybe "" (nodeName n) in mapIInterfaces f subPath n in ifaceMembers ++ subNodeMembers @@ -178,7 +232,6 @@ Just e -> valD (varP name) (normalB . rp $ liftText e) [] return [tp, cl] - nodeSignals :: Text -> INode -> [SomeSignalDescription] nodeSignals = mapIInterfaces interfaceSignalDs @@ -187,8 +240,6 @@ (iInterfaceName iface) <$> iInterfaceSignals iface -- signalDs :: ObjectPath -> Text -> ISignal -> SomeSignalDescription signalDs nPath iName iSig = case toSings $ iSignalArguments iSig of@@ -231,4 +282,3 @@ tpDecl <- sigD name t decl <- valD (varP name) (normalB e) [] return [tpDecl, decl]- where
src/DBus/TH.hs view
@@ -55,6 +55,33 @@ tyVar (VarT n) = [n] tyVar _ = [] +-- | Create a 'Representable' instance for a type.+--+-- The strategy used to marshal types depends on the shape of your type:+--+-- * If none of the constructor(s) have fields, the type is represented by a+-- @Byte@ where the n-th constructor (counting from 0) is marshalled to n+--+-- * If the type has a single constructor with exactly one field, is is+-- represented by the 'RepType' of it's field. (This is always the case for+-- @newtypes@)+--+-- * If the type has a single constructor with multiple fields, it is+-- represented by a @Struct@ (consisting of the translated members)+--+-- * In the general case with multiple constructors with varying numbers of+-- fields , the type is represented by a pair (2-element struct) of a @Byte@+-- (tag) and a @Variant@. The n-th constructor (counting from 0) is+-- represented by the tag n and contents of the @Variant@ depends on the+-- number of members:+--+-- * For constructors without members, a single @Byte@ with the value 0 is+-- stored (The value of the Byte is ignored when unmarshalling)+--+-- * For constructors with a single member, the translated member is stored as-is+--+-- * For constructors with multiple members, the translated members are stored in a+-- @Struct@ makeRepresentable name = do TyConI t <- reify name let (numTyParams, tyVarNames, cons) = case t of@@ -169,6 +196,10 @@ ) -- TODO: Fold into makeRepresentable++-- | Create a 'Representable' instance for a Tuple. The tuple will be+-- represented by a @Struct@. Instances for Tuples up to length 20 are already+-- provided makeRepresentableTuple :: Int -> Q Dec makeRepresentableTuple num = do let names = take num $ map (varT . mkName . (:[])) ['a' .. 'z']
src/DBus/Types.hs view
@@ -105,7 +105,8 @@ isEmpty (ObjectPath False p) = null p isEmpty _ = False --- | Types that are not composite. These can be the keys of a Dict+-- | Types that are not composite. These can be the keys of a Dict. Most of them+-- should be self-explanatory data DBusSimpleType = TypeByte | TypeBoolean@@ -116,12 +117,13 @@ | TypeInt64 | TypeUInt64 | TypeDouble- | TypeUnixFD+ | TypeUnixFD -- ^ Unix File descriptor | TypeString- | TypeObjectPath- | TypeSignature+ | TypeObjectPath -- ^ Name of an object instance+ | TypeSignature -- ^ A (DBus) type signature deriving (Show, Read, Eq, Data, Typeable) +-- | Pretty-print a simple type (this is _not_ DBUs' type format) ppSimpleType :: DBusSimpleType -> String ppSimpleType TypeByte = "Word8" ppSimpleType TypeBoolean = "Boolean"@@ -137,18 +139,22 @@ ppSimpleType TypeObjectPath = "ObjectPath" ppSimpleType TypeSignature = "Signature" +-- | Composite Types data DBusType- = DBusSimpleType DBusSimpleType- | TypeArray DBusType- | TypeStruct [DBusType]- | TypeDict DBusSimpleType DBusType- | TypeVariant- | TypeDictEntry DBusSimpleType DBusType- | TypeUnit -- TODO: Remove- -- Unit isn't actually a DBus type. It is included- -- to make it easier to use methods without a return value+ = DBusSimpleType DBusSimpleType -- ^ A simple type+ | TypeArray DBusType -- ^ Variable-length homogenous arrays+ | TypeStruct [DBusType] -- ^ Structs (Tuples) and a list of member types+ | TypeDict DBusSimpleType DBusType -- ^ Dictionary / Map+ | TypeVariant -- ^ Existentially types container. Carries it's own type+ -- information+ | TypeDictEntry DBusSimpleType DBusType -- ^ Internal helper type for+ -- Dicts. You shouldn't have to use+ -- this+ | TypeUnit -- ^ Unit isn't actually a DBus type. It is included+ -- to make it possible to use methods without a return value deriving (Show, Read, Eq, Data, Typeable) +-- | Pretty-print a type (this is _not_ DBUs' type format) ppType :: DBusType -> String ppType (DBusSimpleType t) = ppSimpleType t ppType (TypeArray ts) = "[" ++ ppType ts ++ "]"@@ -694,6 +700,8 @@ [Maybe SomeDBusValue -> IO ()] +-- | A value representing a connection to a DBus bus. Use 'connectBus' or+-- 'makeServer' to Create data DBusConnection = DBusConnection { dBusCreateSerial :: STM Serial