dbus 0.10.15 → 1.0.0

raw patch · 17 files changed

+1745/−503 lines, 17 filesdep +lensdep +splitdep +template-haskelldep ~basedep ~bytestringdep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: lens, split, template-haskell, th-lift

Dependency ranges changed: base, bytestring, containers

API changes (from Hackage documentation)

Files

• dbus.cabal +14/−4
• examples/export.hs +14/−8
• examples/introspect.hs +4/−4
• idlxml/dbus.xml +90/−0
• lib/DBus/Client.hs +649/−250
• lib/DBus/Generation.hs +544/−0
• lib/DBus/Internal/Types.hs +43/−16
• lib/DBus/Introspection.hs +12/−83
• lib/DBus/TH.hs +16/−0
• tests/DBusTests/Client.hs +242/−59
• tests/DBusTests/Generation.hs +34/−0
• tests/DBusTests/Integration.hs +12/−5
• tests/DBusTests/Introspection.hs +44/−55
• tests/DBusTests/Serialization.hs +0/−1
• tests/DBusTests/TH.hs +9/−0
• tests/DBusTests/Transport.hs +8/−8
• tests/DBusTests/Util.hs +10/−10

@@ -1,5 +1,5 @@ name: dbus-version: 0.10.15+version: 1.0.0 license: GPL-3 license-file: license.txt author: John Millikin <john@john-millikin.com>@@ -69,6 +69,7 @@   examples/export.hs   examples/introspect.hs   examples/list-names.hs+  idlxml/dbus.xml  source-repository head   type: git@@ -84,11 +85,16 @@     , cereal     , containers     , deepseq+    , filepath+    , lens     , libxml-sax     , network     , parsec     , random+    , split+    , template-haskell     , text+    , th-lift     , transformers     , unix     , vector@@ -97,13 +103,15 @@   exposed-modules:     DBus     DBus.Client-    DBus.Introspection-    DBus.Socket-    DBus.Transport+    DBus.Generation     DBus.Internal.Address     DBus.Internal.Message     DBus.Internal.Types     DBus.Internal.Wire+    DBus.Introspection+    DBus.Socket+    DBus.TH+    DBus.Transport  test-suite dbus_tests   type: exitcode-stdio-1.0@@ -141,6 +149,7 @@     DBusTests.BusName     DBusTests.Client     DBusTests.ErrorName+    DBusTests.Generation     DBusTests.Integration     DBusTests.InterfaceName     DBusTests.Introspection@@ -150,6 +159,7 @@     DBusTests.Serialization     DBusTests.Signature     DBusTests.Socket+    DBusTests.TH     DBusTests.Transport     DBusTests.Util     DBusTests.Variant

@@ -45,14 +45,20 @@         exitFailure      -- Export two example objects-    export client "/a"-        [ autoMethod "test.iface_1" "Foo" (onFoo "hello" "a")-        , autoMethod "test.iface_1" "Bar" (onBar "hello" "a")-        ]-    export client "/b"-        [ autoMethod "test.iface_1" "Foo" (onFoo "hello")-        , autoMethod "test.iface_1" "Bar" (onBar "hello")-        ]+    export client "/a" defaultInterface+             { interfaceName = "test.iface_1"+             , interfaceMethods =+               [ autoMethod "Foo" (onFoo "hello" "a")+               , autoMethod "Bar" (onBar "hello" "a")+               ]+             }+    export client "/b" defaultInterface+             { interfaceName = "test.iface_2"+             , interfaceMethods =+               [ autoMethod "Foo" (onFoo "hello")+               , autoMethod "Bar" (onBar "hello")+               ]+             }      putStrLn "Exported objects /a and /b to bus name com.example.exporting" 

@@ -77,10 +77,10 @@  printMethodArg :: I.MethodArg -> IO () printMethodArg arg = do-    let dir = case I.methodArgDirection arg of-        d | d == I.directionIn -> "IN "-        d | d == I.directionOut -> "OUT"-        _ -> "   "+    let dir =+          case I.methodArgDirection arg of+            I.In -> "IN "+            I.Out -> "OUT"     putStr ("            [" ++ dir ++ " ")     putStr (show (formatSignature (signature_ [I.methodArgType arg])) ++ "] ")     putStrLn (I.methodArgName arg)

@@ -0,0 +1,90 @@+<node>+  <interface name="org.freedesktop.DBus">+    <method name="Hello">+      <arg direction="out" type="s"/>+    </method>+    <method name="RequestName">+      <arg direction="in" type="s"/>+      <arg direction="in" type="u"/>+      <arg direction="out" type="u"/>+    </method>+    <method name="ReleaseName">+      <arg direction="in" type="s"/>+      <arg direction="out" type="u"/>+    </method>+    <method name="StartServiceByName">+      <arg direction="in" type="s"/>+      <arg direction="in" type="u"/>+      <arg direction="out" type="u"/>+    </method>+    <method name="UpdateActivationEnvironment">+      <arg direction="in" type="a{ss}"/>+    </method>+    <method name="NameHasOwner">+      <arg direction="in" type="s"/>+      <arg direction="out" type="b"/>+    </method>+    <method name="ListNames">+      <arg direction="out" type="as"/>+    </method>+    <method name="ListActivatableNames">+      <arg direction="out" type="as"/>+    </method>+    <method name="AddMatch">+      <arg direction="in" type="s"/>+    </method>+    <method name="RemoveMatch">+      <arg direction="in" type="s"/>+    </method>+    <method name="GetNameOwner">+      <arg direction="in" type="s"/>+      <arg direction="out" type="s"/>+    </method>+    <method name="ListQueuedOwners">+      <arg direction="in" type="s"/>+      <arg direction="out" type="as"/>+    </method>+    <method name="GetConnectionUnixUser">+      <arg direction="in" type="s"/>+      <arg direction="out" type="u"/>+    </method>+    <method name="GetConnectionUnixProcessID">+      <arg direction="in" type="s"/>+      <arg direction="out" type="u"/>+    </method>+    <method name="GetAdtAuditSessionData">+      <arg direction="in" type="s"/>+      <arg direction="out" type="ay"/>+    </method>+    <method name="GetConnectionSELinuxSecurityContext">+      <arg direction="in" type="s"/>+      <arg direction="out" type="ay"/>+    </method>+    <method name="ReloadConfig">+    </method>+    <method name="GetId">+      <arg direction="out" type="s"/>+    </method>+    <method name="GetConnectionCredentials">+      <arg direction="in" type="s"/>+      <arg direction="out" type="a{sv}"/>+    </method>+    <property name="Features" type="as" access="read">+      <annotation name="org.freedesktop.DBus.Property.EmitsChangedSignal" value="const"/>+    </property>+    <property name="Interfaces" type="as" access="read">+      <annotation name="org.freedesktop.DBus.Property.EmitsChangedSignal" value="const"/>+    </property>+    <signal name="NameOwnerChanged">+      <arg type="s"/>+      <arg type="s"/>+      <arg type="s"/>+    </signal>+    <signal name="NameLost">+      <arg type="s"/>+    </signal>+    <signal name="NameAcquired">+      <arg type="s"/>+    </signal>+  </interface>+</node>

@@ -1,8 +1,16 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}  -- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com> --@@ -55,8 +63,18 @@ module DBus.Client     (     -- * Clients-      Client+      Client(..)+    , DBusR +    -- * Path/Interface storage+    , PathInfo(..)+    , pathInterfaces+    , pathChildren+    , pathLens+    , findPath+    , Interface(..)+    , defaultInterface+     -- * Connecting to a bus     , connect     , connectSystem@@ -68,20 +86,27 @@     , call     , call_     , callNoReply+    , getProperty+    , getPropertyValue+    , setProperty+    , setPropertyValue+    , getAllProperties+    , getAllPropertiesMap+    , buildPropertiesInterface      -- * Receiving method calls     , export     , unexport-    , Method-    , method-    , Reply-    , replyReturn-    , replyError-    , throwError--    -- ** Automatic method signatures+    , Method(..)+    , makeMethod     , AutoMethod     , autoMethod+    , autoMethodWithMsg+    , Property(..)+    , autoProperty+    , readOnlyProperty+    , Reply(..)+    , throwError      -- * Signals     , SignalHandler@@ -101,6 +126,13 @@     , matchMember     , matchPathNamespace +    -- * Introspection+    , buildIntrospectionObject+    , buildIntrospectionInterface+    , buildIntrospectionMethod+    , buildIntrospectionProperty+    , buildIntrospectableInterface+     -- * Name reservation     , requestName     , releaseName@@ -110,8 +142,8 @@     , nameReplaceExisting     , nameDoNotQueue -    , RequestNameReply(NamePrimaryOwner, NameInQueue, NameExists, NameAlreadyOwner)-    , ReleaseNameReply(NameReleased, NameNonExistent, NameNotOwner)+    , RequestNameReply(..)+    , ReleaseNameReply(..)      -- * Client errors     , ClientError@@ -125,27 +157,50 @@     , clientThreadRunner     , defaultClientOptions     , connectWith++    , dbusName+    , dbusPath++    , ErrorName+    , errorFailed+    , errorInvalidParameters+    , errorUnknownMethod     ) where -import           Control.Concurrent-import           Control.Exception (SomeException, throwIO)+import Control.Applicative+import Control.Arrow+import Control.Concurrent import qualified Control.Exception-import           Control.Monad (forever, forM_, when)-import           Data.Bits ((.|.))-import           Data.IORef-import           Data.List (foldl', intercalate, isPrefixOf)-import qualified Data.Map-import           Data.Map (Map)-import           Data.Maybe (catMaybes, listToMaybe)-import           Data.Typeable (Typeable)-import           Data.Unique-import           Data.Word (Word32)-import           Data.Function+import Control.Exception (SomeException, throwIO)+import Control.Lens+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Except+import Data.Bits ((.|.))+import Data.Coerce+import Data.Foldable hiding (forM_, and)+import Data.Function+import Data.Functor ((<$>))+import Data.IORef+import Data.List (intercalate, isPrefixOf)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Monoid+import Data.String+import qualified Data.Traversable as T+import Data.Typeable (Typeable)+import Data.Unique+import Data.Word (Word32)+import Prelude hiding (foldl, foldr, concat) -import           DBus+import DBus+import DBus.Internal.Message+import qualified DBus.Internal.Types as T import qualified DBus.Introspection as I import qualified DBus.Socket-import           DBus.Transport (TransportOpen, SocketTransport)+import DBus.Transport (TransportOpen, SocketTransport)  data ClientError = ClientError     { clientErrorMessage :: String@@ -164,10 +219,13 @@     { clientSocket :: DBus.Socket.Socket     , clientPendingCalls :: IORef (Map Serial (MVar (Either MethodError MethodReturn)))     , clientSignalHandlers :: IORef (Map Unique SignalHandler)-    , clientObjects :: IORef (Map ObjectPath ObjectInfo)+    , clientObjects :: IORef PathInfo     , clientThreadID :: ThreadId+    , clientInterfaces :: [Interface]     } +type DBusR a = ReaderT Client IO a+ data ClientOptions t = ClientOptions     {     -- | Options for the underlying socket, for advanced use cases. See@@ -183,35 +241,142 @@     --     -- The default implementation is 'forever'.     , clientThreadRunner :: IO () -> IO ()+    -- | A function to build the interfaces that should be present at every+    -- point where there is an object present. The default value builds the+    -- property and introspection interfaces.+    , clientBuildInterfaces :: Client -> [Interface]     } -type Callback = (ReceivedMessage -> IO ())- type FormattedMatchRule = String-data SignalHandler = SignalHandler Unique FormattedMatchRule (IORef Bool) (Signal -> IO ())+data SignalHandler =+  SignalHandler Unique FormattedMatchRule (IORef Bool) (Signal -> IO ()) +data Method = Method+  { methodName :: MemberName+  , inSignature :: Signature+  , outSignature :: Signature+  , methodHandler :: MethodCall -> DBusR Reply+  }++data Property = Property+  { propertyName :: MemberName+  , propertyType :: Type+  , propertyGetter :: Maybe (IO Variant)+  , propertySetter :: Maybe (Variant -> IO ())+  }+ data Reply     = ReplyReturn [Variant]     | ReplyError ErrorName [Variant] --- | Reply to a method call with a successful return, containing the given body.-replyReturn :: [Variant] -> Reply-replyReturn = ReplyReturn+data Interface = Interface+  { interfaceName :: InterfaceName+  , interfaceMethods :: [Method]+  , interfaceProperties :: [Property]+  , interfaceSignals :: [I.Signal]+  } --- | Reply to a method call with an error, containing the given error name and--- body.------ Typically, the first item of the error body is a string with a message--- describing the error.-replyError :: ErrorName -> [Variant] -> Reply-replyError = ReplyError+defaultInterface :: Interface+defaultInterface =+  Interface { interfaceName = ""+            , interfaceMethods = []+            , interfaceProperties = []+            , interfaceSignals = []+            } -data Method = Method InterfaceName MemberName Signature Signature (MethodCall -> IO Reply)+data PathInfo = PathInfo+  { _pathInterfaces :: [Interface]+  , _pathChildren :: Map String PathInfo+  } -type ObjectInfo = Map InterfaceName InterfaceInfo-type InterfaceInfo = Map MemberName MethodInfo-data MethodInfo = MethodInfo Signature Signature Callback+-- NOTE: This instance is needed to make modifyNothingHandler work, but it+-- shouldn't really be used for much else. A more complete implementation can't+-- be provided because PathInfo > Interface > Method conatain functions which+-- can't/don't have an eq instance.+instance Eq PathInfo where+  a == b = null (_pathInterfaces a) &&+           null (_pathInterfaces b) &&+           M.null (_pathChildren a) &&+           M.null (_pathChildren b) +makeLenses ''PathInfo++emptyPathInfo :: PathInfo+emptyPathInfo = PathInfo+  { _pathInterfaces = []+  , _pathChildren = M.empty+  }++traverseElement+  :: Applicative f+  => (a -> Maybe PathInfo -> f (Maybe PathInfo))+  -> String+  -> a+  -> PathInfo+  -> f PathInfo+traverseElement nothingHandler pathElement =+  pathChildren . at pathElement . nothingHandler++lookupNothingHandler+  :: (a -> Const (Data.Monoid.First PathInfo) b)+  -> Maybe a+  -> Const (Data.Monoid.First PathInfo) (Maybe b)+lookupNothingHandler = _Just++modifyNothingHandler ::+  (PathInfo -> Identity PathInfo)+    -> Maybe PathInfo+    -> Identity (Maybe PathInfo)+modifyNothingHandler = non emptyPathInfo++pathLens ::+  Applicative f =>+  ObjectPath+  -> ((PathInfo -> f PathInfo) -> Maybe PathInfo -> f (Maybe PathInfo))+  -> (PathInfo -> f PathInfo)+  -> PathInfo+  -> f PathInfo+pathLens path nothingHandler =+  foldl (\f pathElem -> f . traverseElement nothingHandler pathElem) id $+  T.pathElements path++modifyPathInfoLens+  :: ObjectPath+     -> (PathInfo -> Identity PathInfo) -> PathInfo -> Identity PathInfo+modifyPathInfoLens path = pathLens path modifyNothingHandler++modifyPathInterfacesLens+  :: ObjectPath+     -> ([Interface] -> Identity [Interface])+     -> PathInfo+     -> Identity PathInfo+modifyPathInterfacesLens path = modifyPathInfoLens path . pathInterfaces++addInterface :: ObjectPath -> Interface -> PathInfo -> PathInfo+addInterface path interface =+  over (modifyPathInterfacesLens path) (interface :)++findPath :: ObjectPath -> PathInfo -> Maybe PathInfo+findPath path = preview (pathLens path lookupNothingHandler)++findByGetterAndName ::+  (Coercible a2 a1, Eq a1, Foldable t) =>+  t a3 -> (a3 -> a2) -> a1 -> Maybe a3+findByGetterAndName options getter name =+  find ((== name) . coerce . getter) options++findInterface :: [Interface] -> InterfaceName -> PathInfo -> Maybe Interface+findInterface alwaysPresent (T.InterfaceName name) info =+  findByGetterAndName (_pathInterfaces info ++ alwaysPresent) interfaceName name++findMethod :: MemberName -> Interface -> Maybe Method+findMethod (T.MemberName name) interface =+  findByGetterAndName (interfaceMethods interface) methodName name++findProperty :: MemberName -> Interface -> Maybe Property+findProperty (T.MemberName name) interface =+  findByGetterAndName (interfaceProperties interface) propertyName name+ -- | Connect to the bus specified in the environment variable -- @DBUS_SYSTEM_BUS_ADDRESS@, or to -- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@@@ -264,9 +429,9 @@ connectWith opts addr = do     sock <- DBus.Socket.openWith (clientSocketOptions opts) addr -    pendingCalls <- newIORef Data.Map.empty-    signalHandlers <- newIORef Data.Map.empty-    objects <- newIORef Data.Map.empty+    pendingCalls <- newIORef M.empty+    signalHandlers <- newIORef M.empty+    objects <- newIORef $ PathInfo [] M.empty      let threadRunner = clientThreadRunner opts @@ -281,23 +446,112 @@             , clientSignalHandlers = signalHandlers             , clientObjects = objects             , clientThreadID = threadID+            , clientInterfaces = clientBuildInterfaces opts client             }     putMVar clientMVar client -    export client "/" [introspectRoot client]-     callNoReply client (methodCall dbusPath dbusInterface "Hello")         { methodCallDestination = Just dbusName         }      return client +makeErrorReply :: ErrorName -> Reply+makeErrorReply errorName = ReplyError errorName []++buildPropertiesInterface :: Client -> Interface+buildPropertiesInterface client =+  let alwaysPresent = clientInterfaces client+      getPropertyObjF propertyInterfaceName memberName path info =+        findInterfaceAtPath alwaysPresent info path+        (Just $ fromString propertyInterfaceName) >>=+        (maybeToEither errorUnknownMethod . findProperty (fromString memberName))+      getPropertyObj propertyInterfaceName memberName path =+        getPropertyObjF propertyInterfaceName memberName path <$>+                        readIORef (clientObjects client)+      callGet MethodCall { methodCallPath = path }+              propertyInterfaceName memberName =+        left makeErrorReply <$>+        runExceptT (do+          property <- ExceptT $ getPropertyObj propertyInterfaceName+                      memberName path+          ExceptT $ sequenceA $ maybeToEither errorNotAuthorized $+                  propertyGetter property)+      callSet MethodCall { methodCallPath = path }+              propertyInterfaceName memberName value =+        left makeErrorReply <$>+        runExceptT (do+          property <- ExceptT $ getPropertyObj propertyInterfaceName memberName path+          setter <- ExceptT $ return $ maybeToEither errorNotAuthorized $+                    propertySetter property+          lift $ setter value)+      callGetAll MethodCall { methodCallPath = path } propertyInterfaceName =+        left makeErrorReply <$>+        runExceptT (do+          info <- lift $ readIORef (clientObjects client)+          propertyInterface <-+            ExceptT $ return $ findInterfaceAtPath alwaysPresent info path $+                    Just $ fromString propertyInterfaceName+          let properties = interfaceProperties propertyInterface+              nameGetters :: [IO (String, Variant)]+              nameGetters = [ (coerce name,) <$> getter |+                              Property { propertyName = name+                                       , propertyGetter = Just getter+                                       } <- properties]+          lift $ M.fromList <$> T.sequenceA nameGetters)+  in+    defaultInterface+    { interfaceName = propertiesInterfaceName+    , interfaceMethods =+      [ autoMethodWithMsg "Get" callGet+      , autoMethodWithMsg "GetAll" callGetAll+      , autoMethodWithMsg "Set" callSet+      ]+    , interfaceSignals =+      [ I.Signal+        { I.signalName = "PropertiesChanged"+        , I.signalArgs =+          [ I.SignalArg+            { I.signalArgName = "interface_name"+            , I.signalArgType = T.TypeString+            }+          , I.SignalArg+            { I.signalArgName = "changed_properties"+            , I.signalArgType = T.TypeDictionary T.TypeString T.TypeVariant+            }+          , I.SignalArg+            { I.signalArgName = "invalidated_properties"+            , I.signalArgType = T.TypeArray T.TypeString+            }+          ]+        }+      ]+    }++buildIntrospectableInterface :: Client -> Interface+buildIntrospectableInterface client =+  defaultInterface+  { interfaceName = introspectableInterfaceName+  , interfaceMethods = [ autoMethodWithMsg "Introspect" callIntrospect ]+  } where+  callIntrospect MethodCall { methodCallPath = path } = do+    info <- readIORef (clientObjects client)+    return $ left makeErrorReply $ do+      targetInfo <- maybeToEither errorUnknownObject $ findPath path info+      -- TODO: We should probably return a better error here:+      maybeToEither errorUnknownObject $ I.formatXML $+                    buildIntrospectionObject defaultInterfaces+                    targetInfo (T.pathElements path)+  defaultInterfaces = map buildIntrospectionInterface $ clientInterfaces client+ -- | Default client options. Uses the built-in Socket-based transport, which -- supports the @tcp:@ and @unix:@ methods. defaultClientOptions :: ClientOptions SocketTransport defaultClientOptions = ClientOptions     { clientSocketOptions = DBus.Socket.defaultSocketOptions     , clientThreadRunner = forever+    , clientBuildInterfaces =+      \client -> map ($ client) [buildPropertiesInterface, buildIntrospectableInterface]     }  -- | Stop a 'Client''s callback thread and close its underlying socket.@@ -308,13 +562,14 @@  disconnect' :: Client -> IO () disconnect' client = do-    pendingCalls <- atomicModifyIORef (clientPendingCalls client) (\p -> (Data.Map.empty, p))-    forM_ (Data.Map.toList pendingCalls) $ \(k, v) -> do+    pendingCalls <- atomicModifyIORef (clientPendingCalls client) (\p -> (M.empty, p))+    forM_ (M.toList pendingCalls) $ \(k, v) ->         putMVar v (Left (methodError k errorDisconnected)) -    atomicWriteIORef (clientSignalHandlers client) Data.Map.empty-    atomicWriteIORef (clientObjects client) Data.Map.empty+    atomicWriteIORef (clientSignalHandlers client) M.empty +    atomicWriteIORef (clientObjects client) emptyPathInfo+     DBus.Socket.close (clientSocket client)  mainLoop :: Client -> IO ()@@ -330,22 +585,34 @@      dispatch client msg ++-- Dispatch+ dispatch :: Client -> ReceivedMessage -> IO () dispatch client = go where     go (ReceivedMethodReturn _ msg) = dispatchReply (methodReturnSerial msg) (Right msg)     go (ReceivedMethodError _ msg) = dispatchReply (methodErrorSerial msg) (Left msg)     go (ReceivedSignal _ msg) = do         handlers <- readIORef (clientSignalHandlers client)-        forM_ (Data.Map.toAscList handlers) (\(_, SignalHandler _ _ _ h) -> forkIO (h msg) >> return ())-    go received@(ReceivedMethodCall serial msg) = do-        objects <- readIORef (clientObjects client)+        forM_ (M.toAscList handlers) (\(_, SignalHandler _ _ _ h) -> forkIO $ void $ h msg)+    go (ReceivedMethodCall serial msg) = do+        pathInfo <- readIORef (clientObjects client)         let sender = methodCallSender msg-        _ <- forkIO $ case findMethod objects msg of-            Right io -> io received+            sendResult reply =+              case reply of+                ReplyReturn vs -> send_ client (methodReturn serial)+                                  { methodReturnDestination = sender+                                  , methodReturnBody = vs+                                  } (\_ -> return ())+                ReplyError name vs -> send_ client (methodError serial name)+                                      { methodErrorDestination = sender+                                      , methodErrorBody = vs+                                      } (\_ -> return ())+        _ <- forkIO $ case findMethodForCall (clientInterfaces client) pathInfo msg of+            Right Method { methodHandler = handler } ->+              runReaderT (handler msg) client >>= sendResult             Left errName -> send_ client-                (methodError serial errName)-                    { methodErrorDestination = sender-                    }+                (methodError serial errName) { methodErrorDestination = sender }                 (\_ -> return ())         return ()     go _ = return ()@@ -353,13 +620,37 @@     dispatchReply serial result = do         pending <- atomicModifyIORef             (clientPendingCalls client)-            (\p -> case Data.Map.lookup serial p of+            (\p -> case M.lookup serial p of                 Nothing -> (p, Nothing)-                Just mvar -> (Data.Map.delete serial p, Just mvar))+                Just mvar -> (M.delete serial p, Just mvar))         case pending of             Just mvar -> putMVar mvar result             Nothing -> return () +findInterfaceAtPath+  :: [Interface]+  -> PathInfo+  -> ObjectPath+  -> Maybe InterfaceName+  -> Either ErrorName Interface+findInterfaceAtPath defaultInterfaces info path name =+  maybeToEither errorUnknownObject (findPath path info) >>=+  (maybeToEither errorUnknownInterface .+                 maybe (const Nothing) (findInterface defaultInterfaces) name)++findMethodForCall ::+  [Interface] -> PathInfo -> MethodCall -> Either ErrorName Method+findMethodForCall defaultInterfaces info+                  MethodCall { methodCallInterface = interface+                             , methodCallMember = member+                             , methodCallPath = path+                             } =+  findInterfaceAtPath defaultInterfaces info path interface >>=+  (maybeToEither errorUnknownMethod . findMethod member)+++-- Request name+ data RequestNameFlag     = AllowReplacement     | ReplaceExisting@@ -422,7 +713,7 @@     deriving (Eq, Show)  encodeFlags :: [RequestNameFlag] -> Word32-encodeFlags = foldr (.|.) 0 . map flagValue where+encodeFlags = foldr ((.|.) . flagValue) 0  where     flagValue AllowReplacement = 0x1     flagValue ReplaceExisting  = 0x2     flagValue DoNotQueue       = 0x4@@ -499,6 +790,9 @@         3 -> NameNotOwner         _ -> UnknownReleaseNameReply code ++-- Requests+ send_ :: Message msg => Client -> msg -> (Serial -> IO a) -> IO a send_ client msg io = do     result <- Control.Exception.try (DBus.Socket.send (clientSocket client) msg io)@@ -521,14 +815,14 @@             }     mvar <- newEmptyMVar     let ref = clientPendingCalls client-    serial <- send_ client safeMsg (\serial -> atomicModifyIORef ref (\p -> (Data.Map.insert serial mvar p, serial)))+    serial <- send_ client safeMsg (\serial -> atomicModifyIORef ref (\p -> (M.insert serial mvar p, serial)))      -- At this point, we wait for the reply to arrive. The user may cancel     -- a pending call by sending this thread an exception via something     -- like 'timeout'; in that case, we want to clean up the pending call.     Control.Exception.onException         (takeMVar mvar)-        (atomicModifyIORef_ ref (Data.Map.delete serial))+        (atomicModifyIORef_ ref (M.delete serial))  -- | Send a method call to the bus, and wait for the response. --@@ -558,6 +852,84 @@             }     send_ client safeMsg (\_ -> return ()) +orDefaultInterface :: Maybe InterfaceName -> InterfaceName+orDefaultInterface = fromMaybe "org.freedesktop.DBus"++dummyMethodError :: MethodError+dummyMethodError =+  MethodError { methodErrorName = errorName_ "org.ClientTypeMismatch"+              , methodErrorSerial = T.Serial 1+              , methodErrorSender = Nothing+              , methodErrorDestination = Nothing+              , methodErrorBody = []+              }++unpackVariant :: IsValue a => MethodCall -> Variant -> Either MethodError a+unpackVariant MethodCall { methodCallSender = sender } variant =+  maybeToEither dummyMethodError { methodErrorBody =+                                     [variant, toVariant $ show $ variantType variant]+                                 , methodErrorSender = sender+                                 } $ fromVariant variant++-- | Retrieve a property using the method call parameters that were provided.+--+-- Throws a 'ClientError' if the property request couldn't be sent.+getProperty :: Client -> MethodCall -> IO (Either MethodError Variant)+getProperty client+            msg@MethodCall { methodCallInterface = interface+                           , methodCallMember = member+                           } =+  (>>= (unpackVariant msg . head . methodReturnBody)) <$>+    call client msg { methodCallInterface = Just propertiesInterfaceName+                    , methodCallMember = getMemberName+                    , methodCallBody = [ toVariant (coerce (orDefaultInterface interface) :: String)+                                       , toVariant (coerce member :: String)+                                       ]+                    }++getPropertyValue :: IsValue a => Client -> MethodCall -> IO (Either MethodError a)+getPropertyValue client msg =+  (>>= unpackVariant msg) <$> getProperty client msg++setProperty :: Client -> MethodCall -> Variant -> IO (Either MethodError MethodReturn)+setProperty client+            msg@MethodCall { methodCallInterface = interface+                           , methodCallMember = member+                           } value =+  call client msg { methodCallInterface = Just propertiesInterfaceName+                  , methodCallMember = setMemberName+                  , methodCallBody =+                    [ toVariant (coerce (orDefaultInterface interface) :: String)+                    , toVariant (coerce member :: String)+                    , value+                    ]+                  }++setPropertyValue+  :: IsValue a+  => Client -> MethodCall -> a -> IO (Maybe MethodError)+setPropertyValue client msg v = eitherToMaybe <$> setProperty client msg (toVariant v)+  where eitherToMaybe (Left a) = Just a+        eitherToMaybe (Right _) = Nothing++getAllProperties :: Client -> MethodCall -> IO (Either MethodError MethodReturn)+getAllProperties client+               msg@MethodCall { methodCallInterface = interface } =+  call client msg { methodCallInterface = Just propertiesInterfaceName+                  , methodCallMember = getAllMemberName+                  , methodCallBody = [toVariant (coerce (orDefaultInterface interface) :: String)]+                  }++getAllPropertiesMap :: Client -> MethodCall -> IO (Either MethodError (M.Map String Variant))+getAllPropertiesMap client msg =+  -- NOTE: We should never hit the error case here really unless the client+  -- returns the wrong type of object.+  (>>= (maybeToEither dummyMethodError . fromVariant . head . methodReturnBody))+  <$> getAllProperties client msg+++-- Signals+ -- | Request that the bus forward signals matching the given rule to this -- client, and process them in a callback. --@@ -578,7 +950,7 @@     registered <- newIORef True     let handler = SignalHandler handlerId formatted registered (\msg -> when (checkMatchRule rule msg) (io msg)) -    atomicModifyIORef (clientSignalHandlers client) (\hs -> (Data.Map.insert handlerId handler hs, ()))+    atomicModifyIORef (clientSignalHandlers client) (\hs -> (M.insert handlerId handler hs, ()))     _ <- call_ client (methodCall dbusPath dbusInterface "AddMatch")         { methodCallDestination = Just dbusName         , methodCallBody = [toVariant formatted]@@ -592,7 +964,7 @@ removeMatch client (SignalHandler handlerId formatted registered _) = do     shouldUnregister <- atomicModifyIORef registered (\wasRegistered -> (False, wasRegistered))     when shouldUnregister $ do-        atomicModifyIORef (clientSignalHandlers client) (\hs -> (Data.Map.delete handlerId hs, ()))+        atomicModifyIORef (clientSignalHandlers client) (\hs -> (M.delete handlerId hs, ()))         _ <- call_ client (methodCall dbusPath dbusInterface "RemoveMatch")             { methodCallDestination = Just dbusName             , methodCallBody = [toVariant formatted]@@ -601,7 +973,7 @@  -- | Equivalent to 'addMatch', but does not return the added 'SignalHandler'. listen :: Client -> MatchRule -> (Signal -> IO ()) -> IO ()-listen client rule io = addMatch client rule io >> return ()+listen client rule io = void $ addMatch client rule io {-# DEPRECATED listen "Prefer DBus.Client.addMatch in new code." #-}  -- | Emit the signal on the bus.@@ -700,149 +1072,11 @@            -> IO a throwError name message extra = Control.Exception.throwIO (MethodExc name (toVariant message : extra)) --- | Define a method handler, which will accept method calls with the given--- interface and member name.------ Note that the input and output parameter signatures are used for--- introspection, but are not checked when executing a method.------ See 'autoMethod' for an easier way to export functions with simple--- parameter and return types.-method :: InterfaceName-       -> MemberName-       -> Signature -- ^ Input parameter signature-       -> Signature -- ^ Output parameter signature-       -> (MethodCall -> IO Reply)-       -> Method-method iface name inSig outSig io = Method iface name inSig outSig-    (\msg -> Control.Exception.catch-        (Control.Exception.catch-            (io msg)-            (\(MethodExc name' vs') -> return (ReplyError name' vs')))-        (\exc -> return (ReplyError errorFailed-            [toVariant (show (exc :: SomeException))])))---- | Export the given functions under the given 'ObjectPath' and--- 'InterfaceName'.------ Use 'autoMethod' to construct a 'Method' from a function that accepts and--- returns simple types.------ Use 'method' to construct a 'Method' from a function that handles parameter--- conversion manually.------ @---ping :: MethodCall -> IO 'Reply'---ping _ = replyReturn []------sayHello :: String -> IO String---sayHello name = return (\"Hello \" ++ name ++ \"!\")------export client \"/hello_world\"---    [ 'method' \"com.example.HelloWorld\" \"Ping\" ping---    , 'autoMethod' \"com.example.HelloWorld\" \"Hello\" sayHello---    ]--- @-export :: Client -> ObjectPath -> [Method] -> IO ()-export client path methods = atomicModifyIORef (clientObjects client) addObject where-    addObject objs = (Data.Map.insert path info objs, ())--    info = foldl' addMethod Data.Map.empty (defaultIntrospect : methods)-    addMethod m (Method iface name inSig outSig cb) = Data.Map.insertWith'-        Data.Map.union iface-        (Data.Map.fromList [(name, MethodInfo inSig outSig (wrapCB cb))]) m--    wrapCB cb (ReceivedMethodCall serial msg) = do-        reply <- cb msg-        let sender = methodCallSender msg-        case reply of-            ReplyReturn vs -> send_ client (methodReturn serial)-                { methodReturnDestination = sender-                , methodReturnBody = vs-                } (\_ -> return ())-            ReplyError name vs -> send_ client (methodError serial name)-                { methodErrorDestination = sender-                , methodErrorBody = vs-                } (\_ -> return ())-    wrapCB _ _ = return ()--    defaultIntrospect = methodIntrospect $ do-        objects <- readIORef (clientObjects client)-        let Just obj = Data.Map.lookup path objects-        return (introspect path obj)---- | Revokes the export of the given 'ObjectPath'. This will remove all--- interfaces and methods associated with the path.-unexport :: Client -> ObjectPath -> IO ()-unexport client path = atomicModifyIORef (clientObjects client) deleteObject where-    deleteObject objs = (Data.Map.delete path objs, ())--findMethod :: Map ObjectPath ObjectInfo -> MethodCall -> Either ErrorName Callback-findMethod objects msg = case Data.Map.lookup (methodCallPath msg) objects of-    Nothing -> Left errorUnknownObject-    Just obj -> case methodCallInterface msg of-        Nothing -> let-            members = do-                iface <- Data.Map.elems obj-                case Data.Map.lookup (methodCallMember msg) iface of-                    Just member -> [member]-                    Nothing -> []-            in case members of-                [MethodInfo _ _ io] -> Right io-                _ -> Left errorUnknownMethod-        Just ifaceName -> case Data.Map.lookup ifaceName obj of-            Nothing -> Left errorUnknownInterface-            Just iface -> case Data.Map.lookup (methodCallMember msg) iface of-                Just (MethodInfo _ _ io) -> Right io-                _ -> Left errorUnknownMethod--introspectRoot :: Client -> Method-introspectRoot client = methodIntrospect $ do-    objects <- readIORef (clientObjects client)-    let paths = filter (/= "/") (Data.Map.keys objects)-    return (I.object "/")-        { I.objectInterfaces =-            [ (I.interface interfaceIntrospectable)-                { I.interfaceMethods =-                    [ (I.method "Introspect")-                        { I.methodArgs =-                            [ I.methodArg "" TypeString I.directionOut-                            ]-                        }-                    ]-                }-            ]-        , I.objectChildren = [I.object p | p <- paths]-        }--methodIntrospect :: IO I.Object -> Method-methodIntrospect get = method interfaceIntrospectable "Introspect" "" "s" $-    \msg -> case methodCallBody msg of-        [] -> do-            obj <- get-            let Just xml = I.formatXML obj-            return (replyReturn [toVariant xml])-        _ -> return (replyError errorInvalidParameters [])--introspect :: ObjectPath -> ObjectInfo -> I.Object-introspect path obj = (I.object path) { I.objectInterfaces = interfaces } where-    interfaces = map introspectIface (Data.Map.toList obj)--    introspectIface (name, iface) = (I.interface name)-        { I.interfaceMethods = concatMap introspectMethod (Data.Map.toList iface)-        }--    args inSig outSig =-        map (introspectArg I.directionIn) (signatureTypes inSig) ++-        map (introspectArg I.directionOut) (signatureTypes outSig)--    introspectMethod (name, MethodInfo inSig outSig _) =-        [ (I.method name)-            { I.methodArgs = args inSig outSig-            }-        ]++-- Method construction -    introspectArg dir t = I.methodArg "" t dir+returnInvalidParameters :: Monad m => m Reply+returnInvalidParameters = return $ ReplyError errorInvalidParameters []  -- | Used to automatically generate method signatures for introspection -- documents. To support automatic signatures, a method's parameters and@@ -859,31 +1093,46 @@ -- converted to a list of return values. class AutoMethod a where     funTypes :: a -> ([Type], [Type])-    apply :: a -> [Variant] -> Maybe (IO [Variant])--instance AutoMethod (IO ()) where-    funTypes _ = ([], [])+    apply :: a -> [Variant] -> DBusR Reply -    apply io [] = Just (io >> return [])-    apply _ _ = Nothing+handleTopLevelReturn :: IsVariant a => a -> [Variant]+handleTopLevelReturn value =+  case toVariant value of+    T.Variant (T.ValueStructure xs) -> fmap T.Variant xs+    v -> [v]  instance IsValue a => AutoMethod (IO a) where-    funTypes io = cased where-        cased = ([], case ioT io undefined of-            (_, t) -> case t of-                TypeStructure ts -> ts-                _ -> [t])+  funTypes io = funTypes (lift io :: DBusR a)+  apply io = apply (lift io :: DBusR a) -        ioT :: IsValue a => IO a -> a -> (a, Type)-        ioT _ a = (a, typeOf a)+instance IsValue a => AutoMethod (DBusR a) where+    funTypes _ = ([], outTypes) where+      aType :: Type+      aType = typeOf (undefined :: a)+      outTypes =+        case aType of+          TypeStructure ts -> ts+          _ -> [aType] -    apply io [] = Just (do-        var <- fmap toVariant io-        case fromVariant var of-            Just struct -> return (structureItems struct)-            Nothing -> return [var])-    apply _ _ = Nothing+    apply io [] = ReplyReturn . handleTopLevelReturn <$> io+    apply _ _ = returnInvalidParameters +instance IsValue a => AutoMethod (IO (Either Reply a)) where+  funTypes io = funTypes (lift io :: DBusR (Either Reply a))+  apply io = apply (lift io :: DBusR (Either Reply a))++instance IsValue a => AutoMethod (DBusR (Either Reply a)) where+    funTypes _ = ([], outTypes) where+      aType :: Type+      aType = typeOf (undefined :: a)+      outTypes =+        case aType of+          TypeStructure ts -> ts+          _ -> [aType]++    apply io [] = either id (ReplyReturn . handleTopLevelReturn) <$> io+    apply _ _ = returnInvalidParameters+ instance (IsValue a, AutoMethod fn) => AutoMethod (a -> fn) where     funTypes fn = cased where         cased = case valueT undefined of@@ -893,10 +1142,10 @@         valueT :: IsValue a => a -> (a, Type)         valueT a = (a, typeOf a) -    apply _ [] = Nothing+    apply _ [] = returnInvalidParameters     apply fn (v:vs) = case fromVariant v of         Just v' -> apply (fn v') vs-        Nothing -> Nothing+        Nothing -> returnInvalidParameters  -- | Prepare a Haskell function for export, automatically detecting the -- function's type signature.@@ -904,28 +1153,157 @@ -- See 'AutoMethod' for details on the limitations of this function. -- -- See 'method' for exporting functions with user-defined types.-autoMethod :: (AutoMethod fn) => InterfaceName -> MemberName -> fn -> Method-autoMethod iface name fun = DBus.Client.method iface name inSig outSig io where-    (typesIn, typesOut) = funTypes fun-    inSig = case signature typesIn of-        Just sig -> sig-        Nothing -> invalid "input"-    outSig = case signature typesOut of-        Just sig -> sig-        Nothing -> invalid "output"-    io msg = case apply fun (methodCallBody msg) of-        Nothing -> return (ReplyError errorInvalidParameters [])-        Just io' -> fmap ReplyReturn io'+autoMethod :: (AutoMethod fn) => MemberName -> fn -> Method+autoMethod name fun = autoMethodWithMsg name $ const fun +autoMethodWithMsg :: (AutoMethod fn) => MemberName -> (MethodCall -> fn) -> Method+autoMethodWithMsg name fun = makeMethod name inSig outSig io where+    (typesIn, typesOut) = funTypes (fun undefined)+    inSig = fromMaybe (invalid "input") $ signature typesIn+    outSig = fromMaybe (invalid "output") $ signature typesOut+    io msg = apply (fun msg) (methodCallBody msg)+     invalid label = error (concat         [ "Method "-        , formatInterfaceName iface         , "."         , formatMemberName name         , " has an invalid "         , label         , " signature."]) +autoProperty+  :: forall v. (IsValue v)+  => MemberName -> Maybe (IO v) -> Maybe (v -> IO ()) -> Property+autoProperty name mgetter msetter =+  Property name propType (fmap toVariant <$> mgetter) (variantSetter <$> msetter)+    where propType = typeOf (undefined :: v)+          variantSetter setter =+            let newFun variant = maybe (return ()) setter (fromVariant variant)+            in newFun++readOnlyProperty :: (IsValue v) => MemberName -> IO v -> Property+readOnlyProperty name getter = autoProperty name (Just getter) Nothing++-- | Define a method handler, which will accept method calls with the given+-- interface and member name.+--+-- Note that the input and output parameter signatures are used for+-- introspection, but are not checked when executing a method.+--+-- See 'autoMethod' for an easier way to export functions with simple+-- parameter and return types.+makeMethod+  :: MemberName+  -> Signature -- ^ Input parameter signature+  -> Signature -- ^ Output parameter signature+  -> (MethodCall -> DBusR Reply)+  -> Method+makeMethod name inSig outSig io = Method name inSig outSig+    (\msg -> do+       fromReader <- ask+       lift $ Control.Exception.catch+        (Control.Exception.catch+            (runReaderT (io msg) fromReader)+            (\(MethodExc name' vs') -> return (ReplyError name' vs')))+        (\exc -> return (ReplyError errorFailed+            [toVariant (show (exc :: SomeException))])))++-- | Export the given 'Interface' at the given 'ObjectPath'+--+-- Use 'autoMethod' to construct a 'Method' from a function that accepts and+-- returns simple types.+--+-- Use 'method' to construct a 'Method' from a function that handles parameter+-- conversion manually.+--+-- @+--ping :: MethodCall -> IO 'Reply'+--ping _ = ReplyReturn []+--+--sayHello :: String -> IO String+--sayHello name = return (\"Hello \" ++ name ++ \"!\")+--+-- export client \"/hello_world\"+--   defaultInterface { interfaceName = \"com.example.HelloWorld\"+--                    , interfaceMethods =+--                      [ 'method' \"com.example.HelloWorld\" \"Ping\" ping+--                      , 'autoMethod' \"com.example.HelloWorld\" \"Hello\" sayHello+--                      ]+--                    }+-- @+export :: Client -> ObjectPath -> Interface -> IO ()+export client path interface =+  atomicModifyIORef_ (clientObjects client) $ addInterface path interface++-- | Revokes the export of the given 'ObjectPath'. This will remove all+-- interfaces and methods associated with the path.+unexport :: Client -> ObjectPath -> IO ()+unexport client path = atomicModifyIORef_ (clientObjects client) clear+  where clear = over (modifyPathInterfacesLens path) $ const []+++-- Introspection++buildIntrospectionObject :: [I.Interface] -> PathInfo -> [String] -> I.Object+buildIntrospectionObject defaultInterfaces+                         PathInfo+                         { _pathInterfaces = interfaces+                         , _pathChildren = infoChildren+                         } elems =+  I.Object+     { I.objectPath = T.fromElements elems+     , I.objectInterfaces =+       (if null interfaces then [] else defaultInterfaces) +++       map buildIntrospectionInterface interfaces+     -- TODO: Eventually we should support not outputting everything if there is+     -- a lot of stuff.+     , I.objectChildren = M.elems $ M.mapWithKey recurseFromString infoChildren+     }+    where recurseFromString stringNode nodeInfo =+            buildIntrospectionObject defaultInterfaces nodeInfo $ elems ++ [stringNode]++buildIntrospectionInterface :: Interface -> I.Interface+buildIntrospectionInterface Interface+  { interfaceName = name+  , interfaceMethods = methods+  , interfaceProperties = properties+  , interfaceSignals = signals+  } =+  I.Interface+   { I.interfaceName = name+   , I.interfaceMethods = map buildIntrospectionMethod methods+   , I.interfaceProperties = map buildIntrospectionProperty properties+   , I.interfaceSignals = signals+   }++buildIntrospectionProperty :: Property -> I.Property+buildIntrospectionProperty (Property memberName ptype getter setter) =+  I.Property { I.propertyName = coerce memberName+             , I.propertyType = ptype+             , I.propertyRead = isJust getter+             , I.propertyWrite = isJust setter+             }++buildIntrospectionMethod :: Method -> I.Method+buildIntrospectionMethod Method+  { methodName = name+  , inSignature = inSig+  , outSignature = outSig+  } = I.Method+    { I.methodName = name+    , I.methodArgs = zipWith makeMethodArg ['a'..'z'] $ inTuples ++ outTuples+    }+  where inTuples = map (, I.In) $ coerce inSig+        outTuples = map (, I.Out) $ coerce outSig+        makeMethodArg nameChar (t, dir) =+          I.MethodArg { I.methodArgName = [nameChar]+                      , I.methodArgType = t+                      , I.methodArgDirection = dir+                      }+++-- Constants+ errorFailed :: ErrorName errorFailed = errorName_ "org.freedesktop.DBus.Error.Failed" @@ -944,6 +1322,9 @@ errorInvalidParameters :: ErrorName errorInvalidParameters = errorName_ "org.freedesktop.DBus.Error.InvalidParameters" +errorNotAuthorized :: ErrorName+errorNotAuthorized = errorName_ "org.freedesktop.DBus.Error.NotAuthorized"+ dbusName :: BusName dbusName = busName_ "org.freedesktop.DBus" @@ -953,13 +1334,31 @@ dbusInterface :: InterfaceName dbusInterface = interfaceName_ "org.freedesktop.DBus" -interfaceIntrospectable :: InterfaceName-interfaceIntrospectable = interfaceName_ "org.freedesktop.DBus.Introspectable"+introspectableInterfaceName :: InterfaceName+introspectableInterfaceName = interfaceName_ "org.freedesktop.DBus.Introspectable" +propertiesInterfaceName :: InterfaceName+propertiesInterfaceName = fromString "org.freedesktop.DBus.Properties"++getAllMemberName :: MemberName+getAllMemberName = fromString "GetAll"++getMemberName :: MemberName+getMemberName = fromString "Get"++setMemberName :: MemberName+setMemberName = fromString "Set"+++-- Miscellaneous++maybeToEither :: b -> Maybe a -> Either b a+maybeToEither = flip maybe Right . Left+ atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()-atomicModifyIORef_ ref fn = atomicModifyIORef ref (\x -> (fn x, ()))+atomicModifyIORef_ ref fn = atomicModifyIORef ref (fn &&& const ())  #if !MIN_VERSION_base(4,6,0) atomicWriteIORef :: IORef a -> a -> IO ()-atomicWriteIORef ref x = atomicModifyIORef ref (\_ -> (x, ()))+atomicWriteIORef ref x = atomicModifyIORef ref $ const x &&& const () #endif

@@ -0,0 +1,544 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module DBus.Generation where++import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Reader+import           DBus.Client as C+import qualified DBus.Internal.Message as M+import qualified DBus.Internal.Types as T+import qualified DBus.Introspection as I+import qualified Data.ByteString as BS+import qualified Data.Char as Char+import           Data.Coerce+import           Data.Functor ((<$>))+import           Data.Int+import           Data.List+import qualified Data.Map as Map+import           Data.Maybe+import           Data.Monoid+import           Data.String+import           Data.Traversable+import           Data.Word+import           Language.Haskell.TH+import           Prelude hiding (mapM)+import           System.IO.Unsafe+import           System.Posix.Types (Fd(..))++type ClientBusPathR a = ReaderT (Client, T.BusName, T.ObjectPath) IO a++dbusInvoke :: (Client -> T.BusName -> T.ObjectPath -> a) -> ClientBusPathR a+dbusInvoke fn = (\(c, b, p) -> fn c b p) <$> ask++-- Use these operators together with dbusInvoke to invoke functions of the form+-- Client -> T.BusName -> T.ObjectPath+infixl 4 ??+(??) :: Functor f => f (a -> b) -> a -> f b+fab ?? a = fmap ($ a) fab+{-# INLINE (??) #-}++infixl 4 ?/?+(?/?) :: ClientBusPathR (a -> IO b) -> a -> ClientBusPathR b+soFar ?/? arg = do+  returnValue <- fmap ($ arg) soFar+  lift returnValue++data GenerationParams = GenerationParams+  { genBusName :: Maybe T.BusName+  , genObjectPath :: Maybe T.ObjectPath+  , genInterfaceName :: T.InterfaceName+  , genTakeSignalErrorHandler :: Bool+  , getTHType :: T.Type -> Type+  }++defaultGetDictType :: Type -> Type -> Type+defaultGetDictType k =+  AppT (AppT (ConT ''Map.Map) k)++defaultGetTHType :: T.Type -> Type+defaultGetTHType = buildGetTHType (AppT ListT) defaultGetDictType++buildGetTHType ::+  (Type -> Type) -> (Type -> Type -> Type) -> T.Type -> Type+buildGetTHType arrayTypeBuilder dictTypeBuilder = fn+  where fn t =+          case t of+            -- Because of a quirk in how we unmarshal things, we currently HAVE+            -- to decorde arrays of Word8 in this way.+            T.TypeArray T.TypeWord8 -> ConT ''BS.ByteString+            T.TypeBoolean -> ConT ''Bool+            T.TypeWord8 -> ConT ''Word8+            T.TypeWord16 -> ConT ''Word16+            T.TypeWord32 -> ConT ''Word32+            T.TypeWord64 -> ConT ''Word64+            T.TypeInt16 -> ConT ''Int16+            T.TypeInt32 -> ConT ''Int32+            T.TypeInt64 -> ConT ''Int64+            T.TypeDouble -> ConT ''Double+            T.TypeUnixFd -> ConT ''Fd+            T.TypeString -> ConT ''String+            T.TypeSignature -> ConT ''T.Signature+            T.TypeObjectPath -> ConT ''T.ObjectPath+            T.TypeVariant -> ConT ''T.Variant+            T.TypeArray arrayType -> arrayTypeBuilder $ fn arrayType+            T.TypeDictionary k v -> dictTypeBuilder (fn k) (fn v)+            T.TypeStructure ts -> foldl AppT (TupleT $ length ts) $ map fn ts++newNameDef :: String -> Q Name+newNameDef n =+  case n of+    "" -> newName "arg"+    "data" -> newName "arg"+    _ -> newName n++defaultGenerationParams :: GenerationParams+defaultGenerationParams =+  GenerationParams+  { genBusName = Nothing+  , genInterfaceName = fromString ""+  , getTHType = defaultGetTHType+  , genObjectPath = Nothing+  , genTakeSignalErrorHandler = False+  }++addTypeArg :: Type -> Type -> Type+addTypeArg argT = AppT (AppT ArrowT argT)++addTypeArgIf :: Bool -> Type -> Type -> Type+addTypeArgIf condition theType = if condition then addTypeArg theType else id++unitIOType :: Type+unitIOType = AppT (ConT ''IO) (TupleT 0)++addArgIf :: Bool -> a -> [a] -> [a]+addArgIf condition name = if condition then (name:) else id++mkFunD :: Name -> [Name] -> Exp -> Dec+mkFunD name argNames body =+  FunD name [Clause (map VarP argNames) (NormalB body) []]++generateClient :: GenerationParams -> I.Interface -> Q [Dec]+generateClient params+               I.Interface{ I.interfaceName = name+                          , I.interfaceProperties = properties+                          , I.interfaceMethods = methods+                          } =+  let params' = params { genInterfaceName = coerce name } in+  fmap concat <$> sequenceA $+                  map (generateClientMethod params') methods+                  +++                  map (generateClientProperty params') properties++maybeName :: a -> Bool -> Maybe a+maybeName name condition = if condition then Just name else Nothing++makeToVariantApp :: Name -> Exp+makeToVariantApp name = AppE (VarE 'T.toVariant) $ VarE name++makeFromVariantApp :: Name -> Exp+makeFromVariantApp name = AppE (VarE 'T.fromVariant) $ VarE name++makeJustPattern :: Name -> Pat+makeJustPattern name = ConP 'Just [VarP name]++mapOrHead ::+  (Num a, Eq a) => a -> (t -> b) -> [t] -> ([b] -> b) -> b+mapOrHead outputLength fn names cons =+  case outputLength of+    1 -> fn $ head names+    _ -> cons $ map fn names++runGetFirst :: [Maybe a] -> Maybe a+runGetFirst options = getFirst $  mconcat $ map First options++buildGeneratedSignature :: Bool -> Bool -> Type -> Type+buildGeneratedSignature takeBusArg takeObjectPathArg =+  addTypeArg (ConT ''C.Client) . addTypeArgIf takeBusArg (ConT ''T.BusName) .+  addTypeArgIf takeObjectPathArg (ConT ''T.ObjectPath)++getSetMethodCallParams ::+  Name -> Maybe Name -> Maybe Name -> ExpQ -> ExpQ+getSetMethodCallParams methodCallN mBusN mObjectPathN variantsE =+  case (mBusN, mObjectPathN) of+    (Just busN, Just objectPathN) -> [|+                       $( varE methodCallN )+                          { M.methodCallDestination = Just $( varE busN )+                          , M.methodCallPath = $( varE objectPathN )+                          , M.methodCallBody = $( variantsE )+                          }+                     |]+    (Just busN, Nothing) -> [|+                        $( varE methodCallN )+                          { M.methodCallDestination = Just $( varE busN )+                          , M.methodCallBody = $( variantsE )+                          }+                      |]+    (Nothing, Just objectPathN) -> [|+                        $( varE methodCallN )+                          { M.methodCallPath = $( varE objectPathN )+                          , M.methodCallBody = $( variantsE )+                          }+                      |]+    (Nothing, Nothing) -> [|+                         $( varE methodCallN ) { M.methodCallBody = $( variantsE ) }+                      |]++clientArgumentUnpackingMessage :: String+clientArgumentUnpackingMessage =+  "The client method could not unpack the message that was received."++clientArgumentUnpackingError :: [T.Variant] -> M.MethodError+clientArgumentUnpackingError variants =+  M.MethodError+  { M.methodErrorName = C.errorFailed+  , M.methodErrorSerial = T.Serial 0+  , M.methodErrorSender = Nothing+  , M.methodErrorDestination = Nothing+  , M.methodErrorBody = T.toVariant clientArgumentUnpackingMessage : variants+  }++generateClientMethod :: GenerationParams -> I.Method -> Q [Dec]+generateClientMethod GenerationParams+                       { getTHType = getArgType+                       , genInterfaceName = methodInterface+                       , genObjectPath = objectPathM+                       , genBusName = busNameM+                       }+                     I.Method+                       { I.methodArgs = args+                       , I.methodName = methodNameMN+                       } =+  do+    let (inputArgs, outputArgs) = partition ((== I.In) . I.methodArgDirection) args+        outputLength = length outputArgs+        buildArgNames = mapM (newNameDef . I.methodArgName) inputArgs+        buildOutputNames = mapM (newNameDef . I.methodArgName) outputArgs+        takeBusArg = isNothing busNameM+        takeObjectPathArg = isNothing objectPathM+        functionNameFirst:functionNameRest = coerce methodNameMN+        functionName = Char.toLower functionNameFirst:functionNameRest+        functionN = mkName $ Char.toLower functionNameFirst:functionNameRest+        methodCallDefN = mkName $ functionName ++ "MethodCall"+        defObjectPath = fromMaybe (fromString "/") objectPathM+    clientN <- newName "client"+    busN <- newName "busName"+    objectPathN <- newName "objectPath"+    methodCallN <- newName "methodCall"+    callResultN <- newName "callResult"+    replySuccessN <- newName "replySuccess"+    methodArgNames <- buildArgNames+    fromVariantOutputNames <- buildOutputNames+    finalOutputNames <- buildOutputNames+    let variantListExp = map makeToVariantApp methodArgNames+        mapOrHead' = mapOrHead outputLength+        fromVariantExp = mapOrHead' makeFromVariantApp fromVariantOutputNames TupE+        finalResultTuple = mapOrHead' VarE finalOutputNames TupE+        maybeExtractionPattern = mapOrHead' makeJustPattern finalOutputNames TupP+        getMethodCallDefDec = [d|+               $( varP methodCallDefN ) =+                 M.MethodCall { M.methodCallPath = defObjectPath+                              , M.methodCallInterface = Just methodInterface+                              , M.methodCallMember = methodNameMN+                              , M.methodCallDestination = busNameM+                              , M.methodCallSender = Nothing+                              , M.methodCallReplyExpected = True+                              , M.methodCallAutoStart = True+                              , M.methodCallBody = []+                              }+                 |]+        setMethodCallParamsE = getSetMethodCallParams methodCallDefN+                               (maybeName busN takeBusArg)+                               (maybeName objectPathN takeObjectPathArg)+                               (return $ ListE variantListExp)+        handleReplySuccess =+          if outputLength == 0+          then+            [| Right () |]+          else+            [|+               case M.methodReturnBody $( varE replySuccessN ) of+                     $( return $ ListP $ map VarP fromVariantOutputNames ) ->+                       case $( return fromVariantExp ) of+                         $( return maybeExtractionPattern ) -> Right $( return finalResultTuple )+                         _ -> Left $ clientArgumentUnpackingError $+                              M.methodReturnBody $( varE replySuccessN )+                     _ -> Left $ clientArgumentUnpackingError $+                          M.methodReturnBody $( varE replySuccessN )+             |]+        getFunctionBody = [|+             do+               let $( varP methodCallN ) = $( setMethodCallParamsE )+               $( varP callResultN ) <- call $( return $ VarE clientN ) $( varE methodCallN )+               return $ case $( varE callResultN ) of+                 Right $( return rightPattern  ) -> $( handleReplySuccess )+                 Left e -> Left e+               |]+                    where rightPattern = if outputLength == 0+                                         then WildP+                                         else VarP replySuccessN+    functionBody <- getFunctionBody+    methodCallDef <- getMethodCallDefDec+    let methodSignature = foldr addInArg fullOutputSignature inputArgs+        addInArg arg = addTypeArg $ getArgType $ I.methodArgType arg+        fullOutputSignature = AppT (ConT ''IO) $+                              AppT (AppT (ConT ''Either)+                                         (ConT ''M.MethodError))+                              outputSignature+        outputSignature =+          case outputLength of+            1 -> getArgType $ I.methodArgType $ head outputArgs+            _ -> foldl addOutArg (TupleT outputLength) outputArgs+        addOutArg target arg = AppT target $ getArgType $ I.methodArgType arg+        fullSignature = buildGeneratedSignature takeBusArg takeObjectPathArg methodSignature+        fullArgNames =+          clientN:addArgIf takeBusArg busN+                   (addArgIf takeObjectPathArg objectPathN methodArgNames)+        definitionDec = SigD functionN fullSignature+        function = mkFunD functionN fullArgNames functionBody+        methodCallSignature = SigD methodCallDefN $ ConT ''M.MethodCall+    return $ methodCallSignature:methodCallDef ++ [definitionDec, function]++generateClientProperty :: GenerationParams -> I.Property -> Q [Dec]+generateClientProperty GenerationParams+                         { getTHType = getArgType+                         , genInterfaceName = propertyInterface+                         , genObjectPath = objectPathM+                         , genBusName = busNameM+                         }+                       I.Property+                         { I.propertyName = name+                         , I.propertyType = propType+                         , I.propertyRead = readable+                         , I.propertyWrite = writable+                         } =+  do+    clientN <- newName "client"+    busN <- newName "busName"+    objectPathN <- newName "objectPath"+    methodCallN <- newName "methodCall"+    argN <- newName "arg"+    let takeBusArg = isNothing busNameM+        takeObjectPathArg = isNothing objectPathM+        defObjectPath = fromMaybe (fromString "/") objectPathM+        methodCallDefN = mkName $ "methodCallFor" ++ name+        getMethodCallDefDec = [d|+               $( varP methodCallDefN ) =+                 M.MethodCall { M.methodCallPath = defObjectPath+                              , M.methodCallInterface = Just propertyInterface+                              , M.methodCallMember = fromString name+                              , M.methodCallDestination = busNameM+                              , M.methodCallSender = Nothing+                              , M.methodCallReplyExpected = True+                              , M.methodCallAutoStart = True+                              , M.methodCallBody = []+                              }+                 |]+        setMethodCallParamsE = getSetMethodCallParams methodCallDefN+                                   (maybeName busN takeBusArg)+                                   (maybeName objectPathN takeObjectPathArg)+                                   (return $ ListE [])+        makeGetterBody = [|+          do+            let $( varP methodCallN ) = $( setMethodCallParamsE )+            getPropertyValue $( return $ VarE clientN )+                             $( varE methodCallN )+          |]+        makeSetterBody = [|+          do+            let $( varP methodCallN ) = $( setMethodCallParamsE )+            setPropertyValue $( varE clientN ) $( varE methodCallN ) $( varE argN )+          |]+    methodCallDefs <- getMethodCallDefDec+    getterBody <- makeGetterBody+    setterBody <- makeSetterBody+    let buildSignature = buildGeneratedSignature takeBusArg takeObjectPathArg+        getterSigType =+          buildSignature $ AppT (ConT ''IO) $+                         AppT (AppT (ConT ''Either)+                                      (ConT ''M.MethodError)) $ getArgType propType+        setterSigType = buildSignature $+                        AppT (ConT ''IO) $ AppT (ConT ''Maybe) (ConT ''M.MethodError)+        buildArgs rest = clientN:addArgIf takeBusArg busN+                         (addArgIf takeObjectPathArg objectPathN rest)+        getterArgNames = buildArgs []+        setterArgNames = buildArgs [argN]+        propertyString = coerce name+        getterName = mkName $ "get" ++ propertyString+        setterName = mkName $ "set" ++ propertyString+        getterFunction = mkFunD getterName getterArgNames getterBody+        setterFunction = mkFunD setterName setterArgNames setterBody+        getterSignature = SigD getterName getterSigType+        setterSignature = SigD setterName setterSigType+        getterDefs = if readable then [getterSignature, getterFunction] else []+        setterDefs = if writable then [setterSignature, setterFunction] else []+        methodCallSignature = SigD methodCallDefN $ ConT ''M.MethodCall+    return $ methodCallSignature:methodCallDefs ++ getterDefs ++ setterDefs++generateSignalsFromInterface :: GenerationParams -> I.Interface -> Q [Dec]+generateSignalsFromInterface params+                             I.Interface{ I.interfaceName = name+                                        , I.interfaceSignals = signals+                                        } = generateSignals params name signals++generateSignals :: GenerationParams -> T.InterfaceName -> [I.Signal] -> Q [Dec]+generateSignals params name signals =+  fmap concat <$> sequenceA $+                map (generateSignal params { genInterfaceName = coerce name })+                    signals++generateSignal :: GenerationParams -> I.Signal -> Q [Dec]+generateSignal GenerationParams+                 { getTHType = getArgType+                 , genInterfaceName = signalInterface+                 , genObjectPath = objectPathM+                 , genBusName = busNameM+                 , genTakeSignalErrorHandler = takeErrorHandler+                 }+               I.Signal+                 { I.signalName = name+                 , I.signalArgs = args+                 } =+  do+    let buildArgNames = mapM (newNameDef . I.signalArgName) args++    argNames <- buildArgNames+    fromVariantOutputNames <- buildArgNames+    toHandlerOutputNames <- buildArgNames+    objectPathN <- newName "objectPath"+    variantsN <- newName "variants"+    signalN <- newName "signal"+    receivedSignalN <- newName "signal"+    clientN <- newName "client"+    handlerArgN <- newName "handlerArg"+    errorHandlerN <- newName "errorHandler"+    matchRuleN <- newName "matchRule"+    matchRuleArgN <- newName "matchRuleArg"++    let variantListExp = map makeToVariantApp argNames+        signalString = coerce name+        signalDefN = mkName $ "signalFor" ++ signalString+        takeObjectPathArg = isNothing objectPathM+        defObjectPath = fromMaybe (fromString "/") objectPathM+        argCount = length argNames+        getSignalDefDec = [d|+          $( varP signalDefN ) =+            M.Signal { M.signalPath = defObjectPath+                     , M.signalInterface = signalInterface+                     , M.signalMember = name+                     , M.signalDestination = Nothing+                     , M.signalSender = Nothing+                     , M.signalBody = []+                     }+                 |]+    let mapOrHead' = mapOrHead argCount+        fromVariantExp = mapOrHead' makeFromVariantApp fromVariantOutputNames TupE+        maybeExtractionPattern = mapOrHead' makeJustPattern toHandlerOutputNames TupP+        applyToName toApply n = AppE toApply $ VarE n+        finalApplication = foldl applyToName (VarE handlerArgN)+                           (receivedSignalN:toHandlerOutputNames)+        makeHandlerN = mkName $ "makeHandlerFor" ++ signalString+        makeHandlerCall =+          if takeErrorHandler+          then AppE base (VarE errorHandlerN)+          else base+            where base = AppE (VarE makeHandlerN) (VarE handlerArgN)+        getSetSignal  =+          if takeObjectPathArg+          then [|+                  $( varE signalDefN )+                     { M.signalPath = $( varE objectPathN )+                     , M.signalBody = $( varE variantsN )+                     }+                 |]+          else [| $( varE signalDefN )+                  { M.signalBody = $( varE variantsN ) }+                |]+        getEmitBody = [|+          let $( varP variantsN ) = $( return $ ListE variantListExp )+              $( varP signalN ) = $( getSetSignal )+          in+            emit $( varE clientN ) $( varE signalN )+          |]+        getErrorHandler =+          if takeErrorHandler then+            [| $( varE errorHandlerN  ) $( varE receivedSignalN )|]+          else [| return () |]+        getMakeHandlerBody =+          if argCount == 0+          then+            [| $( return finalApplication ) |]+          else+            [|+               case M.signalBody $( varE receivedSignalN ) of+                 $( return $ ListP $ map VarP fromVariantOutputNames ) ->+                   case $( return fromVariantExp ) of+                     $( return maybeExtractionPattern ) -> $( return finalApplication )+                     _ -> $( getErrorHandler )+                 _ -> $( getErrorHandler )+                   |]+        getRegisterBody = [|+          let $( varP matchRuleN ) = $( varE matchRuleArgN )+                                       { C.matchInterface = Just signalInterface+                                       , C.matchMember = Just name+                                       , C.matchSender =+                                         runGetFirst+                                         [ C.matchSender $( varE matchRuleArgN )+                                         , busNameM+                                         ]+                                       , C.matchPath =+                                         runGetFirst+                                         [ C.matchPath $( varE matchRuleArgN )+                                         , objectPathM+                                         ]+                                       }+          in+            C.addMatch $( varE clientN ) $( varE matchRuleN ) $ $( return makeHandlerCall )+            |]+    registerBody <- getRegisterBody+    makeHandlerBody <- getMakeHandlerBody+    signalDef <- getSignalDefDec+    emitBody <- getEmitBody+    let methodSignature = foldr addInArg unitIOType args+        addInArg arg = addTypeArg $ getArgType $ I.signalArgType arg+        fullArgNames = clientN:addArgIf takeObjectPathArg objectPathN argNames+        -- Never take bus arg because it is set automatically anyway+        fullSignature =+            buildGeneratedSignature False takeObjectPathArg methodSignature+        functionN = mkName $ "emit" ++ signalString+        emitSignature = SigD functionN fullSignature+        emitFunction = mkFunD functionN fullArgNames emitBody+        handlerType = addTypeArg (ConT ''M.Signal) methodSignature+        errorHandlerType = addTypeArg (ConT ''M.Signal) unitIOType+        registerN = mkName $ "registerFor" ++ signalString+        registerArgs = clientN:matchRuleArgN:handlerArgN:+                       addArgIf takeErrorHandler errorHandlerN []+        registerFunction = mkFunD registerN registerArgs registerBody+        registerType =+          addTypeArg (ConT ''C.Client) $+          addTypeArg (ConT ''C.MatchRule) $+          addTypeArg handlerType $+          addTypeArgIf takeErrorHandler (addTypeArg (ConT ''M.Signal) unitIOType) $+          AppT (ConT ''IO) (ConT ''C.SignalHandler)+        registerSignature = SigD registerN registerType+        makeHandlerArgs =+          handlerArgN:addArgIf takeErrorHandler errorHandlerN [receivedSignalN]+        makeHandlerFunction = mkFunD makeHandlerN makeHandlerArgs makeHandlerBody+        makeHandlerType = addTypeArg handlerType $+                          addTypeArgIf takeErrorHandler errorHandlerType $+                          addTypeArg (ConT ''M.Signal) unitIOType+        makeHandlerSignature = SigD makeHandlerN makeHandlerType+        signalSignature = SigD signalDefN (ConT ''M.Signal)+    return $ signalSignature:+           signalDef ++ [ emitSignature, emitFunction+                        , makeHandlerSignature, makeHandlerFunction+                        , registerSignature, registerFunction+                        ]++generateFromFilePath :: GenerationParams -> FilePath -> Q [Dec]+generateFromFilePath generationParams filepath =+  let obj = unsafePerformIO $+            head . maybeToList . I.parseXML "/" <$> readFile filepath+      interface = head $ I.objectInterfaces obj+      signals = generateSignalsFromInterface generationParams interface+      client = generateClient generationParams interface+  in fmap (++) signals <*> client

@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-}  -- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>@@ -23,32 +24,35 @@  module DBus.Internal.Types where -import Control.DeepSeq-import Control.Exception (Exception, handle, throwIO)-import Control.Monad (liftM, when, (>=>))-import Data.ByteString (ByteString)-import Data.Char (ord)-import Data.Int-import Data.List (intercalate)-import Data.Map (Map)-import Data.Text (Text)-import Data.Typeable (Typeable)-import Data.Vector (Vector)-import Data.Word-import GHC.Generics-import System.IO.Unsafe (unsafePerformIO)-import System.Posix.Types (Fd)-import Text.ParserCombinators.Parsec ((<|>), oneOf)+import           Control.DeepSeq+import           Control.Exception (Exception, handle, throwIO)+import           Control.Monad (liftM, when, (>=>)) import qualified Data.ByteString+import           Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Lazy import qualified Data.ByteString.Unsafe+import           Data.Char (ord)+import           Data.Coerce+import           Data.Int+import           Data.List (intercalate)+import           Data.List.Split (splitOn) import qualified Data.Map+import           Data.Map (Map) import qualified Data.String import qualified Data.Text+import           Data.Text (Text) import qualified Data.Text.Lazy+import           Data.Typeable (Typeable) import qualified Data.Vector+import           Data.Vector (Vector)+import           Data.Word import qualified Foreign+import           GHC.Generics+import qualified Language.Haskell.TH.Lift as THL+import           System.IO.Unsafe (unsafePerformIO)+import           System.Posix.Types (Fd)+import           Text.ParserCombinators.Parsec ((<|>), oneOf) import qualified Text.ParserCombinators.Parsec as Parsec  data Type@@ -320,6 +324,10 @@                             return (ii' + 1, TypeDictionary t1 t2)                         else throwIO SigParseError +extractFromVariant :: IsValue a => Variant -> Maybe a+extractFromVariant (Variant (ValueVariant v)) = extractFromVariant v+extractFromVariant v = fromVariant v+ class IsVariant a where     toVariant :: a -> Variant     fromVariant :: Variant -> Maybe a@@ -602,6 +610,17 @@     toVariant = Variant . toValue     fromVariant (Variant val) = fromValue val +instance IsValue () where+  typeOf _ = TypeStructure []+  toValue _ = ValueStructure []+  fromValue (ValueStructure []) = return ()+  fromValue _ = Nothing++instance IsVariant () where+  toVariant () = Variant (ValueStructure [])+  fromVariant (Variant (ValueStructure [])) = Just ()+  fromVariant _ = Nothing+ instance (IsValue a1, IsValue a2) => IsValue (a1, a2) where     typeOf ~(a1, a2) = TypeStructure [typeOf a1, typeOf a2]     toValue (a1, a2) = ValueStructure [toValue a1, toValue a2]@@ -635,6 +654,12 @@ newtype ObjectPath = ObjectPath String     deriving (Eq, Ord, Show, NFData) +pathElements :: ObjectPath -> [String]+pathElements = filter (not . null) . splitOn "/" . coerce++fromElements :: [String] -> ObjectPath+fromElements elems = objectPath_ $ '/':intercalate "/" elems+ formatObjectPath :: ObjectPath -> String formatObjectPath (ObjectPath s) = s @@ -1344,3 +1369,5 @@ maybeParseString parser s = case Parsec.parse parser "" s of     Left _ -> Nothing     Right a -> Just a++THL.deriveLiftMany [''BusName, ''ObjectPath, ''InterfaceName, ''MemberName]

@@ -20,58 +20,14 @@     -- * XML conversion       parseXML     , formatXML--    -- * Objects-    , Object-    , object-    , objectPath-    , objectInterfaces-    , objectChildren--    -- * Interfaces-    , Interface-    , interface-    , interfaceName-    , interfaceMethods-    , interfaceSignals-    , interfaceProperties--    -- * Methods-    , Method-    , method-    , methodName-    , methodArgs--    -- ** Method arguments-    , MethodArg-    , methodArg-    , methodArgName-    , methodArgType-    , methodArgDirection--    , Direction-    , directionIn-    , directionOut--    -- * Signals-    , Signal-    , signal-    , signalName-    , signalArgs--    -- ** Signal arguments-    , SignalArg-    , signalArg-    , signalArgName-    , signalArgType--    -- * Properties-    , Property-    , property-    , propertyName-    , propertyType-    , propertyRead-    , propertyWrite+    , Object(..)+    , Interface(..)+    , Method(..)+    , MethodArg(..)+    , Direction(..)+    , Signal(..)+    , SignalArg(..)+    , Property(..)     ) where  import qualified Control.Applicative@@ -94,9 +50,6 @@     }     deriving (Show, Eq) -object :: T.ObjectPath -> Object-object path = Object path [] []- data Interface = Interface     { interfaceName :: T.InterfaceName     , interfaceMethods :: [Method]@@ -105,18 +58,12 @@     }     deriving (Show, Eq) -interface :: T.InterfaceName -> Interface-interface name = Interface name [] [] []- data Method = Method     { methodName :: T.MemberName     , methodArgs :: [MethodArg]     }     deriving (Show, Eq) -method :: T.MemberName -> Method-method name = Method name []- data MethodArg = MethodArg     { methodArgName :: String     , methodArgType :: T.Type@@ -124,36 +71,21 @@     }     deriving (Show, Eq) -methodArg :: String -> T.Type -> Direction -> MethodArg-methodArg = MethodArg- data Direction = In | Out     deriving (Show, Eq) -directionIn :: Direction-directionIn = In--directionOut :: Direction-directionOut = Out- data Signal = Signal     { signalName :: T.MemberName     , signalArgs :: [SignalArg]     }     deriving (Show, Eq) -signal :: T.MemberName -> Signal-signal name = Signal name []- data SignalArg = SignalArg     { signalArgName :: String     , signalArgType :: T.Type     }     deriving (Show, Eq) -signalArg :: String -> T.Type -> SignalArg-signalArg = SignalArg- data Property = Property     { propertyName :: String     , propertyType :: T.Type@@ -162,9 +94,6 @@     }     deriving (Show, Eq) -property :: String -> T.Type -> Property-property name t = Property name t False False- parseXML :: T.ObjectPath -> String -> Maybe Object parseXML path xml = do     root <- parseElement (Data.Text.pack xml)@@ -343,12 +272,12 @@  writeMethod :: Method -> XmlWriter () writeMethod (Method name args) = writeElement "method"-    [("name", T.formatMemberName name)] $ do+    [("name", T.formatMemberName name)] $         mapM_ writeMethodArg args  writeSignal :: Signal -> XmlWriter () writeSignal (Signal name args) = writeElement "signal"-    [("name", T.formatMemberName name)] $ do+    [("name", T.formatMemberName name)] $         mapM_ writeSignalArg args  formatType :: T.Type -> XmlWriter String@@ -364,7 +293,7 @@     let dirAttr = case dir of             In -> "in"             Out -> "out"-    writeEmptyElement "arg" $+    writeEmptyElement "arg"         [ ("name", name)         , ("type", typeStr)         , ("direction", dirAttr)@@ -373,7 +302,7 @@ writeSignalArg :: SignalArg -> XmlWriter () writeSignalArg (SignalArg name t) = do     typeStr <- formatType t-    writeEmptyElement "arg" $+    writeEmptyElement "arg"         [ ("name", name)         , ("type", typeStr)         ]

@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module DBus.TH where++import           DBus.Client+import           DBus.Generation+import           System.FilePath+++generateSignalsFromInterface defaultGenerationParams $+                             buildIntrospectionInterface $+                             buildPropertiesInterface undefined++generateFromFilePath defaultGenerationParams { genBusName = Just dbusName+                                             , genObjectPath = Just dbusPath+                                             } $ "idlxml" </> "dbus.xml"

@@ -18,6 +18,7 @@ import Control.Concurrent import Control.Exception (try) import Data.Word+import Data.Int import Test.Tasty import Test.Tasty.HUnit import qualified Data.Map as Map@@ -25,14 +26,26 @@ import DBus import qualified DBus.Client import qualified DBus.Socket+import DBus.Introspection+import DBus.Internal.Types  import DBusTests.Util+import qualified DBusTests.TH as TH+import qualified DBusTests.Generation as G +doExport :: DBus.Client.Client -> String -> String -> [DBus.Client.Method] -> IO ()+doExport client path name methods =+  DBus.Client.export client (objectPath_ path) DBus.Client.defaultInterface+        { DBus.Client.interfaceMethods = methods+        , DBus.Client.interfaceName = interfaceName_ name+        }+ test_Client :: TestTree test_Client = testGroup "Client" $     [ test_RequestName     , test_ReleaseName     , test_Call+    , test_CallWithGeneration     , test_CallNoReply     , test_AddMatch     , test_AutoMethod@@ -277,6 +290,31 @@          reply @?= methodReturn (methodReturnSerial reply) +test_CallWithGeneration :: TestTree+test_CallWithGeneration = withConnectedClient $ \res -> testCase "callGeneration" $ do+    (sock, client) <- res+    let string = "test"+        busName = busName_ "org.freeDesktop.DBus"+        int = 32 :: Int32+        path = objectPath_ "/a/b/c"+        returnValue = Map.fromList [(string, int)]++    DBus.Client.export client path G.testInterface++    do+        response <- stubMethodCall sock+            (TH.sampleMethod1 client busName path string int)+            (methodCall path (DBus.Client.interfaceName G.testInterface) $+                        memberName_ "SampleMethod1")+             { methodCallDestination = Just busName+             , methodCallBody = [toVariant string, toVariant int]+             }+            (\x -> (methodReturn x)+                   { methodReturnBody = [toVariant returnValue]})+        reply <- requireRight response++        reply @?= returnValue+ test_CallNoReply :: TestTree test_CallNoReply = withConnectedClient $ \res -> testCase "callNoReply" $ do     (sock, client) <- res@@ -346,9 +384,9 @@      let methodPair = (\x y -> return (x, y)) :: String -> String -> IO (String, String) -    DBus.Client.export client (objectPath_ "/")-        [ DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Max") methodMax-        , DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Pair") methodPair+    doExport client "/" "com.example.Foo"+        [ DBus.Client.autoMethod (memberName_ "Max") methodMax+        , DBus.Client.autoMethod (memberName_ "Pair") methodPair         ]      -- valid call to com.example.Foo.Max@@ -371,62 +409,207 @@         response @?= Left (methodError serial (errorName_ "org.freedesktop.DBus.Error.InvalidParameters"))  test_ExportIntrospection :: TestTree-test_ExportIntrospection = withConnectedClient $ \res -> testCase "exportIntrospection" $ do-    (sock, client) <- res-    DBus.Client.export client (objectPath_ "/foo")-        [ DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Method1")-          (undefined :: String -> IO ())-        , DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Method2")-          (undefined :: String -> IO String)-        , DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Method3")-          (undefined :: String -> IO (String, String))-        ]--    let introspect path = do-        (_, response) <- callClientMethod sock path "org.freedesktop.DBus.Introspectable" "Introspect" []-        ret <- requireRight response-        let body = methodReturnBody ret--        length body @?= 1-        let Just xml = fromVariant (head body)-        return xml--    root <- introspect "/"-    root @?=-        "<!DOCTYPE node PUBLIC '-//freedesktop//DTD D-BUS Object Introspection 1.0//EN' 'http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd'>\n\-        \<node name='/'>\-            \<interface name='org.freedesktop.DBus.Introspectable'>\-                \<method name='Introspect'>\-                    \<arg name='' type='s' direction='out'/>\-                \</method>\-            \</interface>\-            \<node name='foo'></node>\-        \</node>"--    foo <- introspect "/foo"-    foo @?=-        "<!DOCTYPE node PUBLIC '-//freedesktop//DTD D-BUS Object Introspection 1.0//EN' 'http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd'>\n\-        \<node name='/foo'>\-            \<interface name='com.example.Foo'>\-                \<method name='Method1'>\-                    \<arg name='' type='s' direction='in'/>\-                \</method>\-                \<method name='Method2'>\-                    \<arg name='' type='s' direction='in'/>\-                    \<arg name='' type='s' direction='out'/>\-                \</method>\-                \<method name='Method3'>\-                    \<arg name='' type='s' direction='in'/>\-                    \<arg name='' type='s' direction='out'/>\-                    \<arg name='' type='s' direction='out'/>\-                \</method>\-            \</interface>\-            \<interface name='org.freedesktop.DBus.Introspectable'>\-                \<method name='Introspect'>\-                    \<arg name='' type='s' direction='out'/>\-                \</method>\-            \</interface>\-        \</node>"+test_ExportIntrospection =+  withConnectedClient $ \res ->+    testCase "exportIntrospection" $ do+      (sock, client) <- res+      let interface =+            DBus.Client.defaultInterface+            { DBus.Client.interfaceMethods =+                [ DBus.Client.autoMethod+                    (memberName_ "Method1")+                    (undefined :: String -> IO ())+                , DBus.Client.autoMethod+                    (memberName_ "Method2")+                    (undefined :: String -> IO String)+                , DBus.Client.autoMethod+                    (memberName_ "Method3")+                    (undefined :: String -> IO (String, String))+                ]+            , DBus.Client.interfaceName = interfaceName_ "com.example.Echo"+            }+          expectedIntrospectionInterface =+            Object+            { objectPath = ObjectPath "/foo"+            , objectInterfaces =+                [ Interface+                  { interfaceName =+                      InterfaceName "org.freedesktop.DBus.Properties"+                  , interfaceMethods =+                      [ Method+                        { methodName = MemberName "Get"+                        , methodArgs =+                            [ MethodArg+                              { methodArgName = "a"+                              , methodArgType = TypeString+                              , methodArgDirection = In+                              }+                            , MethodArg+                              { methodArgName = "b"+                              , methodArgType = TypeString+                              , methodArgDirection = In+                              }+                            , MethodArg+                              { methodArgName = "c"+                              , methodArgType = TypeVariant+                              , methodArgDirection = Out+                              }+                            ]+                        }+                      , Method+                        { methodName = MemberName "GetAll"+                        , methodArgs =+                            [ MethodArg+                              { methodArgName = "a"+                              , methodArgType = TypeString+                              , methodArgDirection = In+                              }+                            , MethodArg+                              { methodArgName = "b"+                              , methodArgType = TypeDictionary TypeString TypeVariant+                              , methodArgDirection = Out+                              }+                            ]+                        }+                      , Method+                        { methodName = MemberName "Set"+                        , methodArgs =+                            [ MethodArg+                              { methodArgName = "a"+                              , methodArgType = TypeString+                              , methodArgDirection = In+                              }+                            , MethodArg+                              { methodArgName = "b"+                              , methodArgType = TypeString+                              , methodArgDirection = In+                              }+                            , MethodArg+                              { methodArgName = "c"+                              , methodArgType = TypeVariant+                              , methodArgDirection = In+                              }+                            ]+                        }+                      ]+                  , interfaceSignals =+                      [ Signal+                        { signalName = MemberName "PropertiesChanged"+                        , signalArgs =+                            [ SignalArg+                              { signalArgName = "interface_name"+                              , signalArgType = TypeString+                              }+                            , SignalArg+                              { signalArgName = "changed_properties"+                              , signalArgType = TypeDictionary TypeString TypeVariant+                              }+                            , SignalArg+                              { signalArgName = "invalidated_properties"+                              , signalArgType = TypeArray TypeString+                              }+                            ]+                        }+                      ]+                  , interfaceProperties = []+                  }+                , Interface+                  { interfaceName =+                      InterfaceName "org.freedesktop.DBus.Introspectable"+                  , interfaceMethods =+                      [ Method+                        { methodName = MemberName "Introspect"+                        , methodArgs =+                            [ MethodArg+                              { methodArgName = "a"+                              , methodArgType = TypeString+                              , methodArgDirection = Out+                              }+                            ]+                        }+                      ]+                  , interfaceSignals = []+                  , interfaceProperties = []+                  }+                , Interface+                  { interfaceName = InterfaceName "com.example.Echo"+                  , interfaceMethods =+                      [ Method+                        { methodName = MemberName "Method1"+                        , methodArgs =+                            [ MethodArg+                              { methodArgName = "a"+                              , methodArgType = TypeString+                              , methodArgDirection = In+                              }+                            ]+                        }+                      , Method+                        { methodName = MemberName "Method2"+                        , methodArgs =+                            [ MethodArg+                              { methodArgName = "a"+                              , methodArgType = TypeString+                              , methodArgDirection = In+                              }+                            , MethodArg+                              { methodArgName = "b"+                              , methodArgType = TypeString+                              , methodArgDirection = Out+                              }+                            ]+                        }+                      , Method+                        { methodName = MemberName "Method3"+                        , methodArgs =+                            [ MethodArg+                              { methodArgName = "a"+                              , methodArgType = TypeString+                              , methodArgDirection = In+                              }+                            , MethodArg+                              { methodArgName = "b"+                              , methodArgType = TypeString+                              , methodArgDirection = Out+                              }+                            , MethodArg+                              { methodArgName = "c"+                              , methodArgType = TypeString+                              , methodArgDirection = Out+                              }+                            ]+                        }+                      ]+                  , interfaceSignals = []+                  , interfaceProperties = []+                  }+                ]+            , objectChildren = []+            }+      DBus.Client.export client (objectPath_ "/foo") interface+      let introspect path = do+            (_, response) <-+              callClientMethod+                sock+                path+                "org.freedesktop.DBus.Introspectable"+                "Introspect"+                []+            ret <- requireRight response+            let body = methodReturnBody ret+            length body @?= 1+            let Just xml = fromVariant (head body)+            return $ parseXML (objectPath_ "/") xml+      root <- introspect "/"+      root @?=+        Just+          (Object+           { objectPath = ObjectPath "/"+           , objectInterfaces = []+           , objectChildren = [ expectedIntrospectionInterface ]+           })+      foo <- introspect "/foo"+      foo @?= Just expectedIntrospectionInterface  startDummyBus :: IO (Address, MVar DBus.Socket.Socket) startDummyBus = do

@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}++module DBusTests.Generation where++import           DBus.Client+import qualified DBus.Internal.Types as T+import qualified DBus.Introspection as I+import           Data.Int+import           Data.Map as M++sampleMethod1 :: String -> Int32 -> IO (M.Map String Int32)+sampleMethod1 a b = return $ M.insert a b M.empty++serviceArg :: I.SignalArg+serviceArg = I.SignalArg { I.signalArgName = "service"+                         , I.signalArgType = T.TypeString+                         }++testSignals :: [I.Signal]+testSignals = [ I.Signal { I.signalName = "StatusNotifierItemRegistered"+                         , I.signalArgs = [serviceArg]+                         }+              ]++testInterface :: Interface+testInterface =+  defaultInterface { interfaceMethods =+                       [autoMethod "SampleMethod1" sampleMethod1]+                   , interfaceName = "org.TestInterface"+                   , interfaceSignals = testSignals+                   }++testIntrospectionInterface :: I.Interface+testIntrospectionInterface = buildIntrospectionInterface testInterface

@@ -59,11 +59,18 @@     clientB <- connect addr      export clientA "/"-        [ method "com.example.Echo" "Echo" (signature_ [TypeString]) (signature_ []) (-            \msg -> if map variantType (methodCallBody msg) == [TypeString]-                then return (replyReturn (methodCallBody msg))-                else return (replyError "com.example.Error" [toVariant ("bad body: " ++ show (methodCallBody msg))]))-        ]+           defaultInterface+           { interfaceName = "com.example.Echo"+           , interfaceMethods =+               [ Method "Echo" (signature_ [TypeString]) (signature_ []) (+                 \msg -> if map variantType (methodCallBody msg) == [TypeString]+                         then return (ReplyReturn (methodCallBody msg))+                         else+                           return $ ReplyError+                                    "com.example.Error"+                                    [toVariant ("bad body: " ++ show (methodCallBody msg))])+               ]+           }      -- TODO: get bus address of clientA with a function     let busAddrA = ":1.0"

@@ -23,7 +23,7 @@ import Test.Tasty.QuickCheck  import DBus-import qualified DBus.Introspection as Introspection+import qualified DBus.Introspection as I  import DBusTests.InterfaceName () import DBusTests.MemberName ()@@ -41,27 +41,30 @@  test_XmlPassthrough :: TestTree test_XmlPassthrough = testProperty "xml-passthrough" $ \obj -> let-    path = Introspection.objectPath obj-    Just xml = Introspection.formatXML obj-    in Introspection.parseXML path xml == Just obj+    path = I.objectPath obj+    Just xml = I.formatXML obj+    in I.parseXML path xml == Just obj +buildEmptyObject :: String -> I.Object+buildEmptyObject name = I.Object (objectPath_ name) [] []+ test_XmlParse :: TestTree test_XmlParse = testCase "xml-parse" $ do     -- root object path can be inferred-    Introspection.parseXML (objectPath_ "/") "<node><node name='foo'/></node>"-        @?= Just (Introspection.object (objectPath_ "/"))-            { Introspection.objectChildren =-                [ Introspection.object (objectPath_ "/foo")+    I.parseXML (objectPath_ "/") "<node><node name='foo'/></node>"+        @?= Just (buildEmptyObject "/")+            { I.objectChildren =+                [ buildEmptyObject "/foo"                 ]             }  test_XmlParseFailed :: TestTree test_XmlParseFailed = testCase "xml-parse-failed" $ do-    Nothing @=? Introspection.parseXML (objectPath_ "/") "<invalid>"-    Nothing @=? Introspection.parseXML (objectPath_ "/") "<invalid/>"+    Nothing @=? I.parseXML (objectPath_ "/") "<invalid>"+    Nothing @=? I.parseXML (objectPath_ "/") "<invalid/>"      -- invalid property access-    Nothing @=? Introspection.parseXML (objectPath_ "/")+    Nothing @=? I.parseXML (objectPath_ "/")         "<node>\         \  <interface name='com.example.Foo'>\         \    <property type='s' access='invalid'>\@@ -70,7 +73,7 @@         \</node>"      -- invalid parameter type-    Nothing @=? Introspection.parseXML (objectPath_ "/")+    Nothing @=? I.parseXML (objectPath_ "/")         "<node>\         \  <interface name='com.example.Foo'>\         \    <method name='Foo'>\@@ -82,22 +85,17 @@ test_XmlWriteFailed :: TestTree test_XmlWriteFailed = testCase "xml-write-failed" $ do     -- child's object path isn't under parent's-    Nothing @=? Introspection.formatXML (Introspection.object (objectPath_ "/foo"))-        { Introspection.objectChildren =-            [ Introspection.object (objectPath_ "/bar")-            ]+    Nothing @=? I.formatXML (buildEmptyObject "/foo")+        { I.objectChildren =+            [ buildEmptyObject "/bar" ]         }      -- invalid type-    Nothing @=? Introspection.formatXML (Introspection.object (objectPath_ "/foo"))-        { Introspection.objectInterfaces =-            [ (Introspection.interface (interfaceName_ "/bar"))-                { Introspection.interfaceProperties =-                    [ Introspection.property "prop" (TypeDictionary TypeVariant TypeVariant)-                    ]-                }-            ]-        }+    Nothing @=? I.formatXML+            ((buildEmptyObject "/foo")+            { I.objectInterfaces =+                [ I.Interface (interfaceName_ "/bar") [] []+                                [ I.Property "prop" (TypeDictionary TypeVariant TypeVariant) True True ]]})  instance Arbitrary Type where     arbitrary = oneof [atom, container] where@@ -122,10 +120,10 @@             , liftM TypeStructure (listOf1 (halfSized arbitrary))             ] -instance Arbitrary Introspection.Object where+instance Arbitrary I.Object where     arbitrary = arbitrary >>= subObject -subObject :: ObjectPath -> Gen Introspection.Object+subObject :: ObjectPath -> Gen I.Object subObject parentPath = sized $ \n -> resize (min n 4) $ do     let nonRoot = do         x <- resize 10 arbitrary@@ -140,62 +138,53 @@     let path = objectPath_ path'     ifaces <- arbitrary     children <- halfSized (listOf (subObject path))-    return (Introspection.object path)-        { Introspection.objectInterfaces = ifaces-        , Introspection.objectChildren = children-        }+    return $ I.Object path ifaces children -instance Arbitrary Introspection.Interface where+instance Arbitrary I.Interface where     arbitrary = do         name <- arbitrary         methods <- arbitrary         signals <- arbitrary         properties <- arbitrary-        return (Introspection.interface name)-            { Introspection.interfaceMethods = methods-            , Introspection.interfaceSignals = signals-            , Introspection.interfaceProperties = properties-            }+        return $ I.Interface name methods signals properties -instance Arbitrary Introspection.Method where+instance Arbitrary I.Method where     arbitrary = do         name <- arbitrary         args <- arbitrary-        return (Introspection.method name)-            { Introspection.methodArgs = args-            }+        return $ (I.Method name args) -instance Arbitrary Introspection.Signal where+instance Arbitrary I.Signal where     arbitrary = do         name <- arbitrary         args <- arbitrary-        return (Introspection.signal name)-            { Introspection.signalArgs = args-            }+        return $ I.Signal name args -instance Arbitrary Introspection.MethodArg where-    arbitrary = Introspection.methodArg+instance Arbitrary I.MethodArg where+    arbitrary = I.MethodArg         <$> gen_Ascii         <*> arbitrary         <*> arbitrary -instance Arbitrary Introspection.Direction where-    arbitrary = elements [Introspection.directionIn, Introspection.directionOut]+instance Arbitrary I.Direction where+    arbitrary = elements [I.In, I.Out] -instance Arbitrary Introspection.SignalArg where-    arbitrary = Introspection.signalArg+instance Arbitrary I.SignalArg where+    arbitrary = I.SignalArg         <$> gen_Ascii         <*> arbitrary -instance Arbitrary Introspection.Property where+instance Arbitrary I.Property where     arbitrary = do         name <- gen_Ascii         t <- arbitrary         canRead <- arbitrary         canWrite <- arbitrary-        return (Introspection.property name t)-            { Introspection.propertyRead = canRead-            , Introspection.propertyWrite = canWrite+        return I.Property+            { I.propertyName = name+            , I.propertyType = t+            , I.propertyRead = canRead+            , I.propertyWrite = canWrite             }  gen_Ascii :: Gen String

@@ -26,7 +26,6 @@ import System.Posix.Types (Fd) import Test.QuickCheck import Test.Tasty-import Test.Tasty.HUnit import Test.Tasty.QuickCheck import qualified Data.Map import qualified Data.Vector

@@ -0,0 +1,9 @@+{-# LANGUAGE TemplateHaskell #-}++module DBusTests.TH where++import DBus.Generation+import DBusTests.Generation++generateClient defaultGenerationParams testIntrospectionInterface+generateSignalsFromInterface defaultGenerationParams testIntrospectionInterface

@@ -85,7 +85,7 @@  test_OpenUnix_Path :: TestTree test_OpenUnix_Path = testCase "path" $ runResourceT $ do-    (addr, networkSocket) <- listenRandomUnixPath+    addr <- listenRandomUnixPath     fdcountBefore <- countFileDescriptors      t <- liftIO (transportOpen socketTransportOptions addr)@@ -96,7 +96,7 @@  test_OpenUnix_Abstract :: TestTree test_OpenUnix_Abstract = testCase "abstract" $ runResourceT $ do-    (addr, networkSocket, _) <- listenRandomUnixAbstract+    (addr, _) <- listenRandomUnixAbstract     fdcountBefore <- countFileDescriptors      t <- liftIO (transportOpen socketTransportOptions addr)@@ -140,7 +140,7 @@ test_OpenUnix_NotListening = testCase "not-listening" $ runResourceT $ do     fdcountBefore <- countFileDescriptors -    (addr, networkSocket, key) <- listenRandomUnixAbstract+    (addr, key) <- listenRandomUnixAbstract     release key      liftIO $ assertThrows@@ -166,7 +166,7 @@  test_OpenTcp_IPv4 :: TestTree test_OpenTcp_IPv4 = testCase "ipv4" $ runResourceT $ do-    (addr, networkSocket, _) <- listenRandomIPv4+    (addr, _, _) <- listenRandomIPv4     fdcountBefore <- countFileDescriptors      t <- liftIO (transportOpen socketTransportOptions addr)@@ -177,7 +177,7 @@  test_OpenTcp_IPv6 :: TestTree test_OpenTcp_IPv6 = testCase "ipv6" $ unlessM noIPv6 $ runResourceT $ do-    (addr, networkSocket) <- listenRandomIPv6+    addr <- listenRandomIPv6     fdcountBefore <- countFileDescriptors      t <- liftIO (transportOpen socketTransportOptions addr)@@ -260,7 +260,7 @@ test_OpenTcp_NotListening = testCase "too-many" $ runResourceT $ do     fdcountBefore <- countFileDescriptors -    (addr, networkSocket, key) <- listenRandomIPv4+    (addr, _, key) <- listenRandomIPv4     release key     liftIO $ assertThrows         (\err -> and@@ -282,7 +282,7 @@         fix $ \loop -> do             bytes <- recv s 50             if Data.ByteString.null bytes-                then NS.sClose s+                then NS.close s                 else do                     sendAll s bytes                     loop@@ -315,7 +315,7 @@     _ <- liftIO $ forkIO $ do         (s, _) <- NS.accept networkSocket         sendAll s "123"-        NS.sClose s+        NS.close s      (_, t) <- allocate         (transportOpen socketTransportOptions addr)

@@ -91,7 +91,7 @@     uuid <- randomUUID     return (tmp </> formatUUID uuid) -listenRandomUnixPath :: MonadResource m => m (Address, N.Socket)+listenRandomUnixPath :: MonadResource m => m Address listenRandomUnixPath = do     path <- liftIO getTempPath @@ -99,16 +99,16 @@     (_, sock) <- allocate         (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol)         N.sClose-    liftIO (NS.bindSocket sock sockAddr)+    liftIO (NS.bind sock sockAddr)     liftIO (NS.listen sock 1)     _ <- register (removeFile path)      let Just addr = address "unix" (Map.fromList             [ ("path", path)             ])-    return (addr, sock)+    return addr -listenRandomUnixAbstract :: MonadResource m => m (Address, N.Socket, ReleaseKey)+listenRandomUnixAbstract :: MonadResource m => m (Address, ReleaseKey) listenRandomUnixAbstract = do     uuid <- liftIO randomUUID     let sockAddr = NS.SockAddrUnix ('\x00' : formatUUID uuid)@@ -117,13 +117,13 @@         (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol)         N.sClose -    liftIO $ NS.bindSocket sock sockAddr+    liftIO $ NS.bind sock sockAddr     liftIO $ NS.listen sock 1      let Just addr = address "unix" (Map.fromList             [ ("abstract", formatUUID uuid)             ])-    return (addr, sock, key)+    return (addr, key)  listenRandomIPv4 :: MonadResource m => m (Address, N.Socket, ReleaseKey) listenRandomIPv4 = do@@ -133,7 +133,7 @@     (key, sock) <- allocate         (NS.socket NS.AF_INET NS.Stream NS.defaultProtocol)         N.sClose-    liftIO $ NS.bindSocket sock sockAddr+    liftIO $ NS.bind sock sockAddr     liftIO $ NS.listen sock 1      sockPort <- liftIO $ NS.socketPort sock@@ -144,7 +144,7 @@             ])     return (addr, sock, key) -listenRandomIPv6 :: MonadResource m => m (Address, N.Socket)+listenRandomIPv6 :: MonadResource m => m Address listenRandomIPv6 = do     addrs <- liftIO $ NS.getAddrInfo Nothing (Just "::1") Nothing     let sockAddr = case addrs of@@ -154,7 +154,7 @@     (_, sock) <- allocate         (NS.socket NS.AF_INET6 NS.Stream NS.defaultProtocol)         N.sClose-    liftIO $ NS.bindSocket sock sockAddr+    liftIO $ NS.bind sock sockAddr     liftIO $ NS.listen sock 1      sockPort <- liftIO $ NS.socketPort sock@@ -163,7 +163,7 @@             , ("host", "::1")             , ("port", show (toInteger sockPort))             ])-    return (addr, sock)+    return addr  noIPv6 :: IO Bool noIPv6 = do