diff --git a/d-bus.cabal b/d-bus.cabal --- a/d-bus.cabal +++ b/d-bus.cabal @@ -1,5 +1,5 @@ name: d-bus -version: 0.1.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 diff --git a/dbus-introspect/Main.hs b/dbus-introspect/Main.hs new file mode 100644 --- /dev/null +++ b/dbus-introspect/Main.hs @@ -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 []" + hPutStrLn stderr " where 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 diff --git a/liferea-example/Main.hs b/liferea-example/Main.hs new file mode 100644 --- /dev/null +++ b/liferea-example/Main.hs @@ -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 + } diff --git a/src/DBus.hs b/src/DBus.hs --- a/src/DBus.hs +++ b/src/DBus.hs @@ -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 +-- +-- +-- 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 diff --git a/src/DBus/Introspect.hs b/src/DBus/Introspect.hs --- a/src/DBus/Introspect.hs +++ b/src/DBus/Introspect.hs @@ -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 ) diff --git a/src/DBus/MainLoop.hs b/src/DBus/MainLoop.hs --- a/src/DBus/MainLoop.hs +++ b/src/DBus/MainLoop.hs @@ -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)) diff --git a/src/DBus/Scaffold.hs b/src/DBus/Scaffold.hs --- a/src/DBus/Scaffold.hs +++ b/src/DBus/Scaffold.hs @@ -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 diff --git a/src/DBus/TH.hs b/src/DBus/TH.hs --- a/src/DBus/TH.hs +++ b/src/DBus/TH.hs @@ -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'] diff --git a/src/DBus/Types.hs b/src/DBus/Types.hs --- a/src/DBus/Types.hs +++ b/src/DBus/Types.hs @@ -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