diff --git a/dbus.cabal b/dbus.cabal --- a/dbus.cabal +++ b/dbus.cabal @@ -1,5 +1,5 @@ name: dbus -version: 0.10.15 +version: 1.0.0 license: GPL-3 license-file: license.txt author: John Millikin @@ -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 diff --git a/examples/export.hs b/examples/export.hs --- a/examples/export.hs +++ b/examples/export.hs @@ -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" diff --git a/examples/introspect.hs b/examples/introspect.hs --- a/examples/introspect.hs +++ b/examples/introspect.hs @@ -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) diff --git a/idlxml/dbus.xml b/idlxml/dbus.xml new file mode 100644 --- /dev/null +++ b/idlxml/dbus.xml @@ -0,0 +1,90 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/lib/DBus/Client.hs b/lib/DBus/Client.hs --- a/lib/DBus/Client.hs +++ b/lib/DBus/Client.hs @@ -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 -- @@ -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 diff --git a/lib/DBus/Generation.hs b/lib/DBus/Generation.hs new file mode 100644 --- /dev/null +++ b/lib/DBus/Generation.hs @@ -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 diff --git a/lib/DBus/Internal/Types.hs b/lib/DBus/Internal/Types.hs --- a/lib/DBus/Internal/Types.hs +++ b/lib/DBus/Internal/Types.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} -- Copyright (C) 2009-2012 John Millikin @@ -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] diff --git a/lib/DBus/Introspection.hs b/lib/DBus/Introspection.hs --- a/lib/DBus/Introspection.hs +++ b/lib/DBus/Introspection.hs @@ -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) ] diff --git a/lib/DBus/TH.hs b/lib/DBus/TH.hs new file mode 100644 --- /dev/null +++ b/lib/DBus/TH.hs @@ -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" diff --git a/tests/DBusTests/Client.hs b/tests/DBusTests/Client.hs --- a/tests/DBusTests/Client.hs +++ b/tests/DBusTests/Client.hs @@ -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 @?= - "\n\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \" - - foo <- introspect "/foo" - foo @?= - "\n\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \" +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 diff --git a/tests/DBusTests/Generation.hs b/tests/DBusTests/Generation.hs new file mode 100644 --- /dev/null +++ b/tests/DBusTests/Generation.hs @@ -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 diff --git a/tests/DBusTests/Integration.hs b/tests/DBusTests/Integration.hs --- a/tests/DBusTests/Integration.hs +++ b/tests/DBusTests/Integration.hs @@ -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" diff --git a/tests/DBusTests/Introspection.hs b/tests/DBusTests/Introspection.hs --- a/tests/DBusTests/Introspection.hs +++ b/tests/DBusTests/Introspection.hs @@ -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_ "/") "" - @?= Just (Introspection.object (objectPath_ "/")) - { Introspection.objectChildren = - [ Introspection.object (objectPath_ "/foo") + I.parseXML (objectPath_ "/") "" + @?= Just (buildEmptyObject "/") + { I.objectChildren = + [ buildEmptyObject "/foo" ] } test_XmlParseFailed :: TestTree test_XmlParseFailed = testCase "xml-parse-failed" $ do - Nothing @=? Introspection.parseXML (objectPath_ "/") "" - Nothing @=? Introspection.parseXML (objectPath_ "/") "" + Nothing @=? I.parseXML (objectPath_ "/") "" + Nothing @=? I.parseXML (objectPath_ "/") "" -- invalid property access - Nothing @=? Introspection.parseXML (objectPath_ "/") + Nothing @=? I.parseXML (objectPath_ "/") "\ \ \ \ \ @@ -70,7 +73,7 @@ \" -- invalid parameter type - Nothing @=? Introspection.parseXML (objectPath_ "/") + Nothing @=? I.parseXML (objectPath_ "/") "\ \ \ \ \ @@ -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 diff --git a/tests/DBusTests/Serialization.hs b/tests/DBusTests/Serialization.hs --- a/tests/DBusTests/Serialization.hs +++ b/tests/DBusTests/Serialization.hs @@ -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 diff --git a/tests/DBusTests/TH.hs b/tests/DBusTests/TH.hs new file mode 100644 --- /dev/null +++ b/tests/DBusTests/TH.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} + +module DBusTests.TH where + +import DBus.Generation +import DBusTests.Generation + +generateClient defaultGenerationParams testIntrospectionInterface +generateSignalsFromInterface defaultGenerationParams testIntrospectionInterface diff --git a/tests/DBusTests/Transport.hs b/tests/DBusTests/Transport.hs --- a/tests/DBusTests/Transport.hs +++ b/tests/DBusTests/Transport.hs @@ -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) diff --git a/tests/DBusTests/Util.hs b/tests/DBusTests/Util.hs --- a/tests/DBusTests/Util.hs +++ b/tests/DBusTests/Util.hs @@ -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