dbus-1.2.29/benchmarks/0000755000000000000000000000000014263302757013056 5ustar0000000000000000dbus-1.2.29/examples/0000755000000000000000000000000014263302757012557 5ustar0000000000000000dbus-1.2.29/idlxml/0000755000000000000000000000000014263302757012232 5ustar0000000000000000dbus-1.2.29/lib/0000755000000000000000000000000014350676323011507 5ustar0000000000000000dbus-1.2.29/lib/DBus/0000755000000000000000000000000014412616400012331 5ustar0000000000000000dbus-1.2.29/lib/DBus/Internal/0000755000000000000000000000000014263302757014120 5ustar0000000000000000dbus-1.2.29/lib/DBus/Introspection/0000755000000000000000000000000014351135773015204 5ustar0000000000000000dbus-1.2.29/tests/0000755000000000000000000000000014351135773012103 5ustar0000000000000000dbus-1.2.29/tests/DBusTests/0000755000000000000000000000000014412616400013750 5ustar0000000000000000dbus-1.2.29/lib/DBus.hs0000644000000000000000000002123714263302757012705 0ustar0000000000000000-- Copyright (C) 2009-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. -- | Basic types, useful to every D-Bus application. -- -- Authors of client applications should import "DBus.Client", which provides -- an easy RPC-oriented interface to D-Bus methods and signals. module DBus ( -- * Messages Message -- ** Method calls , MethodCall , methodCall , methodCallPath , methodCallInterface , methodCallMember , methodCallSender , methodCallDestination , methodCallAutoStart , methodCallReplyExpected , methodCallBody -- ** Method returns , MethodReturn , methodReturn , methodReturnSerial , methodReturnSender , methodReturnDestination , methodReturnBody -- ** Method errors , MethodError , methodError , methodErrorName , methodErrorSerial , methodErrorSender , methodErrorDestination , methodErrorBody , methodErrorMessage -- ** Signals , Signal , signal , signalPath , signalMember , signalInterface , signalSender , signalDestination , signalBody -- ** Received messages , ReceivedMessage(ReceivedMethodCall, ReceivedMethodReturn, ReceivedMethodError, ReceivedSignal) , receivedMessageSerial , receivedMessageSender , receivedMessageBody -- * Variants , Variant , IsVariant(..) , variantType , IsAtom , IsValue , typeOf , typeOf' -- * Signatures , Signature , Type(..) , signature , signature_ , signatureTypes , formatSignature , parseSignature -- * Object paths , ObjectPath , objectPath_ , formatObjectPath , parseObjectPath -- * Names -- ** Interface names , InterfaceName , interfaceName_ , formatInterfaceName , parseInterfaceName -- ** Member names , MemberName , memberName_ , formatMemberName , parseMemberName -- ** Error names , ErrorName , errorName_ , formatErrorName , parseErrorName -- ** Bus names , BusName , busName_ , formatBusName , parseBusName -- * Non-native containers -- ** Structures , Structure , structureItems -- ** Arrays , Array , arrayItems -- ** Dictionaries , Dictionary , dictionaryItems -- * Addresses , Address , addressMethod , addressParameters , address , formatAddress , formatAddresses , parseAddress , parseAddresses , getSystemAddress , getSessionAddress , getStarterAddress -- * Message marshaling , Endianness (..) -- ** Marshal , marshal , MarshalError , marshalErrorMessage -- ** Unmarshal , unmarshal , UnmarshalError , unmarshalErrorMessage -- ** Message serials , Serial , serialValue , firstSerial , nextSerial -- * D-Bus UUIDs , UUID , formatUUID , randomUUID ) where import Control.Monad (replicateM) import qualified Data.ByteString.Char8 as Char8 import Data.Proxy (Proxy(..)) import Data.Word (Word16) import System.Random (randomRIO) import Text.Printf (printf) import DBus.Internal.Address import DBus.Internal.Message import qualified DBus.Internal.Types import DBus.Internal.Types hiding (typeOf) import DBus.Internal.Wire -- | Deprecated. Get the D-Bus type corresponding to the given Haskell value. The value -- may be @undefined@. typeOf :: IsValue a => a -> Type typeOf = DBus.Internal.Types.typeOf -- | Get the D-Bus type corresponding to the given Haskell type 'a'. typeOf' :: IsValue a => Proxy a -> Type typeOf' = DBus.Internal.Types.typeOf_ -- | Construct a new 'MethodCall' for the given object, interface, and method. -- -- Use fields such as 'methodCallDestination' and 'methodCallBody' to populate -- a 'MethodCall'. -- -- @ --{-\# LANGUAGE OverloadedStrings \#-} -- --methodCall \"/\" \"org.example.Math\" \"Add\" -- { 'methodCallDestination' = Just \"org.example.Calculator\" -- , 'methodCallBody' = ['toVariant' (1 :: Int32), 'toVariant' (2 :: Int32)] -- } -- @ methodCall :: ObjectPath -> InterfaceName -> MemberName -> MethodCall methodCall path iface member = MethodCall path (Just iface) member Nothing Nothing True True [] -- | Construct a new 'MethodReturn', in reply to a method call with the given -- serial. -- -- Use fields such as 'methodReturnBody' to populate a 'MethodReturn'. methodReturn :: Serial -> MethodReturn methodReturn s = MethodReturn s Nothing Nothing [] -- | Construct a new 'MethodError', in reply to a method call with the given -- serial. -- -- Use fields such as 'methodErrorBody' to populate a 'MethodError'. methodError :: Serial -> ErrorName -> MethodError methodError s name = MethodError name s Nothing Nothing [] -- | Construct a new 'Signal' for the given object, interface, and signal name. -- -- Use fields such as 'signalBody' to populate a 'Signal'. signal :: ObjectPath -> InterfaceName -> MemberName -> Signal signal path iface member = Signal path iface member Nothing Nothing [] -- | No matter what sort of message was received, get its serial. receivedMessageSerial :: ReceivedMessage -> Serial receivedMessageSerial (ReceivedMethodCall s _) = s receivedMessageSerial (ReceivedMethodReturn s _) = s receivedMessageSerial (ReceivedMethodError s _) = s receivedMessageSerial (ReceivedSignal s _) = s receivedMessageSerial (ReceivedUnknown s _) = s -- | No matter what sort of message was received, get its sender (if provided). receivedMessageSender :: ReceivedMessage -> Maybe BusName receivedMessageSender (ReceivedMethodCall _ msg) = methodCallSender msg receivedMessageSender (ReceivedMethodReturn _ msg) = methodReturnSender msg receivedMessageSender (ReceivedMethodError _ msg) = methodErrorSender msg receivedMessageSender (ReceivedSignal _ msg) = signalSender msg receivedMessageSender (ReceivedUnknown _ msg) = unknownMessageSender msg -- | No matter what sort of message was received, get its body (if provided). receivedMessageBody :: ReceivedMessage -> [Variant] receivedMessageBody (ReceivedMethodCall _ msg) = methodCallBody msg receivedMessageBody (ReceivedMethodReturn _ msg) = methodReturnBody msg receivedMessageBody (ReceivedMethodError _ msg) = methodErrorBody msg receivedMessageBody (ReceivedSignal _ msg) = signalBody msg receivedMessageBody (ReceivedUnknown _ msg) = unknownMessageBody msg -- | Convert a 'Message' into a 'Char8.ByteString'. Although unusual, it is -- possible for marshaling to fail; if this occurs, an error will be -- returned instead. marshal :: Message msg => Endianness -> Serial -> msg -> Either MarshalError Char8.ByteString marshal = marshalMessage -- | Parse a 'Char8.ByteString' into a 'ReceivedMessage'. The result can be -- inspected to see what type of message was parsed. Unknown message types -- can still be parsed successfully, as long as they otherwise conform to -- the D-Bus standard. unmarshal :: Char8.ByteString -> Either UnmarshalError ReceivedMessage unmarshal = unmarshalMessage -- | A D-Bus UUID is 128 bits of data, usually randomly generated. They are -- used for identifying unique server instances to clients. -- -- Older versions of the D-Bus spec also called these values /GUIDs/. -- -- D-Bus UUIDs are not the same as the RFC-standardized UUIDs or GUIDs. newtype UUID = UUID Char8.ByteString deriving (Eq, Ord, Show) -- | Format a D-Bus UUID as hex-encoded ASCII. formatUUID :: UUID -> String formatUUID (UUID bytes) = Char8.unpack bytes -- | Generate a random D-Bus UUID. This value is suitable for use in a -- randomly-allocated address, or as a listener's socket address -- @\"guid\"@ parameter. randomUUID :: IO UUID randomUUID = do -- The version of System.Random bundled with ghc < 7.2 doesn't define -- instances for any of the fixed-length word types, so we imitate -- them using the instance for Int. -- -- 128 bits is 8 16-bit integers. We use chunks of 16 instead of 32 -- because Int is not guaranteed to be able to store a Word32. let hexInt16 i = printf "%04x" (i :: Int) int16s <- replicateM 8 (randomRIO (0, fromIntegral (maxBound :: Word16))) return (UUID (Char8.pack (concatMap hexInt16 int16s))) dbus-1.2.29/lib/DBus/Client.hs0000644000000000000000000014137214412616400014113 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -- Copyright (C) 2009-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. -- | D-Bus clients are an abstraction over the lower-level messaging -- system. When combined with an external daemon called the \"bus\", clients -- can perform remote procedure calls to other clients on the bus. -- -- Clients may also listen for or emit /signals/, which are asynchronous -- broadcast notifications. -- -- Example: connect to the session bus, and get a list of active names. -- -- @ --{-\# LANGUAGE OverloadedStrings \#-} -- --import Data.List (sort) --import DBus --import DBus.Client -- --main = do -- client <- 'connectSession' -- // -- \-- Request a list of connected clients from the bus -- reply <- 'call_' client ('methodCall' \"\/org\/freedesktop\/DBus\" \"org.freedesktop.DBus\" \"ListNames\") -- { 'methodCallDestination' = Just \"org.freedesktop.DBus\" -- } -- // -- \-- org.freedesktop.DBus.ListNames() returns a single value, which is -- \-- a list of names (here represented as [String]) -- let Just names = 'fromVariant' ('methodReturnBody' reply !! 0) -- // -- \-- Print each name on a line, sorted so reserved names are below -- \-- temporary names. -- mapM_ putStrLn (sort names) -- @ -- module DBus.Client ( -- * Clients Client(..) , DBusR -- * Path/Interface storage , PathInfo(..) , pathInterfaces , pathChildren , pathLens , findPath , Interface(..) , defaultInterface -- * Connecting to a bus , connect , connectSystem , connectSession , connectStarter , disconnect -- * Sending method calls , call , call_ , callNoReply , getProperty , getPropertyValue , setProperty , setPropertyValue , getAllProperties , getAllPropertiesMap , buildPropertiesInterface -- * Receiving method calls , export , unexport , Method(..) , makeMethod , AutoMethod , autoMethod , autoMethodWithMsg , Property(..) , autoProperty , readOnlyProperty , Reply(..) , throwError -- * Signals , SignalHandler , addMatch , removeMatch , emit , listen -- ** Match rules , MatchRule , formatMatchRule , matchAny , matchSender , matchDestination , matchPath , matchInterface , matchMember , matchPathNamespace -- * Introspection , buildIntrospectionObject , buildIntrospectionInterface , buildIntrospectionMethod , buildIntrospectionProperty , buildIntrospectableInterface -- * Name reservation , requestName , releaseName , RequestNameFlag , nameAllowReplacement , nameReplaceExisting , nameDoNotQueue , RequestNameReply(..) , ReleaseNameReply(..) -- * Client errors , ClientError , clientError , clientErrorMessage , clientErrorFatal -- * Advanced connection options , ClientOptions , clientSocketOptions , clientThreadRunner , defaultClientOptions , connectWith , connectWithName , dbusName , dbusPath , ErrorName , errorFailed , errorInvalidParameters , errorUnknownMethod ) where import Control.Applicative import Control.Arrow import Control.Concurrent import qualified Control.Exception 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, Proxy(..)) import Data.Unique import Data.Word (Word32) import Prelude hiding (foldl, foldr, concat) import DBus import DBus.Internal.Message import qualified DBus.Internal.Types as T import qualified DBus.Introspection.Types as I import qualified DBus.Introspection.Render as I import qualified DBus.Socket import DBus.Transport (TransportOpen, SocketTransport) data ClientError = ClientError { clientErrorMessage :: String , clientErrorFatal :: Bool } deriving (Eq, Show, Typeable) instance Control.Exception.Exception ClientError clientError :: String -> ClientError clientError msg = ClientError msg True -- | An active client session to a message bus. Clients may send or receive -- method calls, and listen for or emit signals. data Client = Client { clientSocket :: DBus.Socket.Socket , clientPendingCalls :: IORef (Map Serial (MVar (Either MethodError MethodReturn))) , clientSignalHandlers :: IORef (Map Unique SignalHandler) , 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 -- the "DBus.Socket" module. clientSocketOptions :: DBus.Socket.SocketOptions t -- | A function to run the client thread. The provided IO computation -- should be called repeatedly; each time it is called, it will process -- one incoming message. -- -- The provided computation will throw a 'ClientError' if it fails to -- process an incoming message, or if the connection is lost. -- -- 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 FormattedMatchRule = String 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] data Interface = Interface { interfaceName :: InterfaceName , interfaceMethods :: [Method] , interfaceProperties :: [Property] , interfaceSignals :: [I.Signal] } defaultInterface :: Interface defaultInterface = Interface { interfaceName = "" , interfaceMethods = [] , interfaceProperties = [] , interfaceSignals = [] } data PathInfo = PathInfo { _pathInterfaces :: [Interface] , _pathChildren :: Map String PathInfo } -- 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@ -- is not set. -- -- Throws a 'ClientError' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid -- address, or if connecting to the bus failed. connectSystem :: IO Client connectSystem = do env <- getSystemAddress case env of Nothing -> throwIO (clientError "connectSystem: DBUS_SYSTEM_BUS_ADDRESS is invalid.") Just addr -> connect addr -- | Connect to the bus specified in the environment variable -- @DBUS_SESSION_BUS_ADDRESS@, which must be set. -- -- Throws a 'ClientError' if @DBUS_SESSION_BUS_ADDRESS@ is unset, contains an -- invalid address, or if connecting to the bus failed. connectSession :: IO Client connectSession = do env <- getSessionAddress case env of Nothing -> throwIO (clientError "connectSession: DBUS_SESSION_BUS_ADDRESS is invalid.") Just addr -> connect addr -- | Connect to the bus specified in the environment variable -- @DBUS_STARTER_ADDRESS@, which must be set. -- -- Throws a 'ClientError' if @DBUS_STARTER_ADDRESS@ is unset, contains an -- invalid address, or if connecting to the bus failed. connectStarter :: IO Client connectStarter = do env <- getStarterAddress case env of Nothing -> throwIO (clientError "connectStarter: DBUS_STARTER_ADDRESS is missing or invalid.") Just addr -> connect addr -- | Connect to the bus at the specified address. -- -- Throws a 'ClientError' on failure. connect :: Address -> IO Client connect = connectWith defaultClientOptions -- | Connect to the bus at the specified address, with the given connection -- options. Most users should use 'connect' instead. -- -- Throws a 'ClientError' on failure. connectWith :: TransportOpen t => ClientOptions t -> Address -> IO Client connectWith opts addr = do client <- connectWith' opts addr callNoReply client (methodCall dbusPath dbusInterface "Hello") { methodCallDestination = Just dbusName } return client -- | Connect to the bus at the specified address, with the given connection -- options, and return the unique client bus name. Most users should use -- 'connect' or 'connectWith' instead. -- -- Throws a 'ClientError' on failure. connectWithName :: TransportOpen t => ClientOptions t -> Address -> IO (Client, BusName) connectWithName opts addr = do client <- connectWith' opts addr reply <- call_ client (methodCall dbusPath dbusInterface "Hello") { methodCallDestination = Just dbusName } case methodReturnBody reply of [name] | Just nameStr <- fromVariant name -> do busName <- parseBusName nameStr return (client, busName) _ -> throwIO (clientError "connectWithName: Hello response did not contain client name.") connectWith' :: TransportOpen t => ClientOptions t -> Address -> IO Client connectWith' opts addr = do sock <- DBus.Socket.openWith (clientSocketOptions opts) addr pendingCalls <- newIORef M.empty signalHandlers <- newIORef M.empty objects <- newIORef $ PathInfo [] M.empty let threadRunner = clientThreadRunner opts clientMVar <- newEmptyMVar threadID <- forkIO $ do client <- readMVar clientMVar threadRunner (mainLoop client) let client = Client { clientSocket = sock , clientPendingCalls = pendingCalls , clientSignalHandlers = signalHandlers , clientObjects = objects , clientThreadID = threadID , clientInterfaces = clientBuildInterfaces opts client } putMVar clientMVar client 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. disconnect :: Client -> IO () disconnect client = do killThread (clientThreadID client) disconnect' client disconnect' :: Client -> IO () disconnect' client = do pendingCalls <- atomicModifyIORef (clientPendingCalls client) (\p -> (M.empty, p)) forM_ (M.toList pendingCalls) $ \(k, v) -> putMVar v (Left (methodError k errorDisconnected)) atomicWriteIORef (clientSignalHandlers client) M.empty atomicWriteIORef (clientObjects client) emptyPathInfo DBus.Socket.close (clientSocket client) mainLoop :: Client -> IO () mainLoop client = do let sock = clientSocket client received <- Control.Exception.try (DBus.Socket.receive sock) msg <- case received of Left err -> do disconnect' client throwIO (clientError (DBus.Socket.socketErrorMessage err)) Right msg -> return msg 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_ (M.toAscList handlers) (\(_, SignalHandler _ _ _ h) -> forkIO $ void $ h msg) go (ReceivedMethodCall serial msg) = do pathInfo <- readIORef (clientObjects client) let sender = methodCallSender msg 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 } (\_ -> return ()) return () go _ = return () dispatchReply serial result = do pending <- atomicModifyIORef (clientPendingCalls client) (\p -> case M.lookup serial p of Nothing -> (p, Nothing) 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 | DoNotQueue deriving (Eq, Show) -- | Allow this client's reservation to be replaced, if another client -- requests it with the 'nameReplaceExisting' flag. -- -- If this client's reservation is replaced, this client will be added to the -- wait queue unless the request also included the 'nameDoNotQueue' flag. nameAllowReplacement :: RequestNameFlag nameAllowReplacement = AllowReplacement -- | If the name being requested is already reserved, attempt to replace it. -- This only works if the current owner provided the 'nameAllowReplacement' -- flag. nameReplaceExisting :: RequestNameFlag nameReplaceExisting = ReplaceExisting -- | If the name is already in use, do not add this client to the queue, just -- return an error. nameDoNotQueue :: RequestNameFlag nameDoNotQueue = DoNotQueue data RequestNameReply -- | This client is now the primary owner of the requested name. = NamePrimaryOwner -- | The name was already reserved by another client, and replacement -- was either not attempted or not successful. | NameInQueue -- | The name was already reserved by another client, 'DoNotQueue' -- was set, and replacement was either not attempted or not -- successful. | NameExists -- | This client is already the primary owner of the requested name. | NameAlreadyOwner -- | Not exported; exists to generate a compiler warning if users -- case on the reply and forget to include a default case. | UnknownRequestNameReply Word32 deriving (Eq, Show) data ReleaseNameReply -- | This client has released the provided name. = NameReleased -- | The provided name is not assigned to any client on the bus. | NameNonExistent -- | The provided name is not assigned to this client. | NameNotOwner -- | Not exported; exists to generate a compiler warning if users -- case on the reply and forget to include a default case. | UnknownReleaseNameReply Word32 deriving (Eq, Show) encodeFlags :: [RequestNameFlag] -> Word32 encodeFlags = foldr ((.|.) . flagValue) 0 where flagValue AllowReplacement = 0x1 flagValue ReplaceExisting = 0x2 flagValue DoNotQueue = 0x4 -- | Asks the message bus to assign the given name to this client. The bus -- maintains a queue of possible owners, where the head of the queue is the -- current (\"primary\") owner. -- -- There are several uses for name reservation: -- -- * Clients which export methods reserve a name so users and applications -- can send them messages. For example, the GNOME Keyring reserves the name -- @\"org.gnome.keyring\"@ on the user's session bus, and NetworkManager -- reserves @\"org.freedesktop.NetworkManager\"@ on the system bus. -- -- * When there are multiple implementations of a particular service, the -- service standard will ususally include a generic bus name for the -- service. This allows other clients to avoid depending on any particular -- implementation's name. For example, both the GNOME Keyring and KDE -- KWallet services request the @\"org.freedesktop.secrets\"@ name on the -- user's session bus. -- -- * A process with \"single instance\" behavior can use name assignment to -- check whether the instance is already running, and invoke some method -- on it (e.g. opening a new window). -- -- Throws a 'ClientError' if the call failed. requestName :: Client -> BusName -> [RequestNameFlag] -> IO RequestNameReply requestName client name flags = do reply <- call_ client (methodCall dbusPath dbusInterface "RequestName") { methodCallDestination = Just dbusName , methodCallBody = [toVariant name, toVariant (encodeFlags flags)] } var <- case listToMaybe (methodReturnBody reply) of Just x -> return x Nothing -> throwIO (clientError "requestName: received empty response") { clientErrorFatal = False } code <- case fromVariant var of Just x -> return x Nothing -> throwIO (clientError ("requestName: received invalid response code " ++ showsPrec 11 var "")) { clientErrorFatal = False } return $ case code :: Word32 of 1 -> NamePrimaryOwner 2 -> NameInQueue 3 -> NameExists 4 -> NameAlreadyOwner _ -> UnknownRequestNameReply code -- | Release a name that this client previously requested. See 'requestName' -- for an explanation of name reservation. -- -- Throws a 'ClientError' if the call failed. releaseName :: Client -> BusName -> IO ReleaseNameReply releaseName client name = do reply <- call_ client (methodCall dbusPath dbusInterface "ReleaseName") { methodCallDestination = Just dbusName , methodCallBody = [toVariant name] } var <- case listToMaybe (methodReturnBody reply) of Just x -> return x Nothing -> throwIO (clientError "releaseName: received empty response") { clientErrorFatal = False } code <- case fromVariant var of Just x -> return x Nothing -> throwIO (clientError ("releaseName: received invalid response code " ++ showsPrec 11 var "")) { clientErrorFatal = False } return $ case code :: Word32 of 1 -> NameReleased 2 -> NameNonExistent 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) case result of Right x -> return x Left err -> throwIO (clientError (DBus.Socket.socketErrorMessage err)) { clientErrorFatal = DBus.Socket.socketErrorFatal err } -- | Send a method call to the bus, and wait for the response. -- -- Throws a 'ClientError' if the method call couldn't be sent, or if the reply -- couldn't be parsed. call :: Client -> MethodCall -> IO (Either MethodError MethodReturn) call client msg = do -- If ReplyExpected is False, this function would block indefinitely -- if the remote side honors it. let safeMsg = msg { methodCallReplyExpected = True } mvar <- newEmptyMVar let ref = clientPendingCalls client 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 (M.delete serial)) -- | Send a method call to the bus, and wait for the response. -- -- Unsets the 'noReplyExpected' message flag before sending. -- -- Throws a 'ClientError' if the method call couldn't sent, if the reply -- couldn't be parsed, or if the reply was a 'MethodError'. call_ :: Client -> MethodCall -> IO MethodReturn call_ client msg = do result <- call client msg case result of Left err -> throwIO (clientError ("Call failed: " ++ methodErrorMessage err)) { clientErrorFatal = methodErrorName err == errorDisconnected } Right ret -> return ret -- | Send a method call to the bus, and do not wait for a response. -- -- Sets the 'noReplyExpected' message flag before sending. -- -- Throws a 'ClientError' if the method call couldn't be sent. callNoReply :: Client -> MethodCall -> IO () callNoReply client msg = do -- Ensure that noReplyExpected is always set. let safeMsg = msg { methodCallReplyExpected = False } 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. -- -- A received signal might be processed by more than one callback at a time. -- Callbacks each run in their own thread. -- -- The returned 'SignalHandler' can be passed to 'removeMatch' -- to stop handling this signal. -- -- Throws a 'ClientError' if the match rule couldn't be added to the bus. addMatch :: Client -> MatchRule -> (Signal -> IO ()) -> IO SignalHandler addMatch client rule io = do let formatted = case formatMatchRule rule of "" -> "type='signal'" x -> "type='signal'," ++ x handlerId <- newUnique registered <- newIORef True let handler = SignalHandler handlerId formatted registered (\msg -> when (checkMatchRule rule msg) (io msg)) atomicModifyIORef (clientSignalHandlers client) (\hs -> (M.insert handlerId handler hs, ())) _ <- call_ client (methodCall dbusPath dbusInterface "AddMatch") { methodCallDestination = Just dbusName , methodCallBody = [toVariant formatted] } return handler -- | Request that the bus stop forwarding signals for the given handler. -- -- Throws a 'ClientError' if the match rule couldn't be removed from the bus. removeMatch :: Client -> SignalHandler -> IO () removeMatch client (SignalHandler handlerId formatted registered _) = do shouldUnregister <- atomicModifyIORef registered (\wasRegistered -> (False, wasRegistered)) when shouldUnregister $ do atomicModifyIORef (clientSignalHandlers client) (\hs -> (M.delete handlerId hs, ())) _ <- call_ client (methodCall dbusPath dbusInterface "RemoveMatch") { methodCallDestination = Just dbusName , methodCallBody = [toVariant formatted] } return () -- | Equivalent to 'addMatch', but does not return the added 'SignalHandler'. listen :: Client -> MatchRule -> (Signal -> IO ()) -> IO () listen client rule io = void $ addMatch client rule io {-# DEPRECATED listen "Prefer DBus.Client.addMatch in new code." #-} -- | Emit the signal on the bus. -- -- Throws a 'ClientError' if the signal message couldn't be sent. emit :: Client -> Signal -> IO () emit client msg = send_ client msg (\_ -> return ()) -- | A match rule describes which signals a particular callback is interested -- in. Use 'matchAny' to construct match rules. -- -- Example: a match rule which matches signals sent by the root object. -- -- @ --matchFromRoot :: MatchRule --matchFromRoot = 'matchAny' { 'matchPath' = Just \"/\" } -- @ data MatchRule = MatchRule { -- | If set, only receives signals sent from the given bus name. -- -- The standard D-Bus implementation from -- almost always sets signal senders to the unique name of the sending -- client. If 'matchSender' is a requested name like -- @\"com.example.Foo\"@, it will not match any signals. -- -- The exception is for signals sent by the bus itself, which always -- have a sender of @\"org.freedesktop.DBus\"@. matchSender :: Maybe BusName -- | If set, only receives signals sent to the given bus name. , matchDestination :: Maybe BusName -- | If set, only receives signals sent with the given path. , matchPath :: Maybe ObjectPath -- | If set, only receives signals sent with the given interface name. , matchInterface :: Maybe InterfaceName -- | If set, only receives signals sent with the given member name. , matchMember :: Maybe MemberName -- | If set, only receives signals sent with the given path or any of -- its children. , matchPathNamespace :: Maybe ObjectPath } instance Show MatchRule where showsPrec d rule = showParen (d > 10) (showString "MatchRule " . shows (formatMatchRule rule)) -- | Convert a match rule into the textual format accepted by the bus. formatMatchRule :: MatchRule -> String formatMatchRule rule = intercalate "," predicates where predicates = catMaybes [ f "sender" matchSender formatBusName , f "destination" matchDestination formatBusName , f "path" matchPath formatObjectPath , f "interface" matchInterface formatInterfaceName , f "member" matchMember formatMemberName , f "path_namespace" matchPathNamespace formatObjectPath ] f :: String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String f key get text = do val <- fmap text (get rule) return (concat [key, "='", val, "'"]) -- | Match any signal. matchAny :: MatchRule matchAny = MatchRule Nothing Nothing Nothing Nothing Nothing Nothing checkMatchRule :: MatchRule -> Signal -> Bool checkMatchRule rule msg = and [ maybe True (\x -> signalSender msg == Just x) (matchSender rule) , maybe True (\x -> signalDestination msg == Just x) (matchDestination rule) , maybe True (== signalPath msg) (matchPath rule) , maybe True (== signalInterface msg) (matchInterface rule) , maybe True (== signalMember msg) (matchMember rule) , maybe True (`pathPrefix` signalPath msg) (matchPathNamespace rule) ] where pathPrefix = isPrefixOf `on` formatObjectPath data MethodExc = MethodExc ErrorName [Variant] deriving (Show, Eq, Typeable) instance Control.Exception.Exception MethodExc -- | Normally, any exceptions raised while executing a method will be -- given the generic @\"org.freedesktop.DBus.Error.Failed\"@ name. -- 'throwError' allows the programmer to specify an error name, and provide -- additional information to the remote application. You may use this instead -- of 'Control.Exception.throwIO' to abort a method call. throwError :: ErrorName -> String -- ^ Error message -> [Variant] -- ^ Additional items of the error body -> IO a throwError name message extra = Control.Exception.throwIO (MethodExc name (toVariant message : extra)) -- Method construction 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 -- return value must all be instances of 'IsValue'. -- -- This class maps Haskell idioms to D-Bus; it is therefore unable to -- generate some signatures. In particular, it does not support methods -- which accept/return a single structure, or single-element structures. -- It also cannot generate signatures for methods with parameters or return -- values which are only instances of 'IsVariant'. For these cases, please -- use 'DBus.Client.method'. -- -- To match common Haskell use, if the return value is a tuple, it will be -- converted to a list of return values. class AutoMethod a where funTypes :: a -> ([Type], [Type]) apply :: a -> [Variant] -> DBusR Reply 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 = funTypes (lift io :: DBusR a) apply io = apply (lift io :: DBusR a) instance IsValue a => AutoMethod (DBusR a) where funTypes _ = ([], outTypes) where aType :: Type aType = typeOf' (Proxy :: Proxy a) outTypes = case aType of TypeStructure ts -> ts _ -> [aType] 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' (Proxy :: Proxy 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 (a, t) -> case funTypes (fn a) of (ts, ts') -> (t : ts, ts') valueT :: IsValue a => a -> (a, Type) valueT a = (a, typeOf a) apply _ [] = returnInvalidParameters apply fn (v:vs) = case fromVariant v of Just v' -> apply (fn v') vs Nothing -> returnInvalidParameters -- | Prepare a Haskell function for export, automatically detecting the -- function's type signature. -- -- See 'AutoMethod' for details on the limitations of this function. -- -- See 'method' for exporting functions with user-defined types. 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 " , "." , 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' (Proxy :: Proxy 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" errorDisconnected :: ErrorName errorDisconnected = errorName_ "org.freedesktop.DBus.Error.Disconnected" errorUnknownObject :: ErrorName errorUnknownObject = errorName_ "org.freedesktop.DBus.Error.UnknownObject" errorUnknownInterface :: ErrorName errorUnknownInterface = errorName_ "org.freedesktop.DBus.Error.UnknownInterface" errorUnknownMethod :: ErrorName errorUnknownMethod = errorName_ "org.freedesktop.DBus.Error.UnknownMethod" 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" dbusPath :: ObjectPath dbusPath = objectPath_ "/org/freedesktop/DBus" dbusInterface :: InterfaceName dbusInterface = interfaceName_ "org.freedesktop.DBus" 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 (fn &&& const ()) #if !MIN_VERSION_base(4,6,0) atomicWriteIORef :: IORef a -> a -> IO () atomicWriteIORef ref x = atomicModifyIORef ref $ const x &&& const () #endif dbus-1.2.29/lib/DBus/Generation.hs0000644000000000000000000005720614263302757015005 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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.Parse as I import qualified DBus.Introspection.Types 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 qualified Data.Text.IO as Text import Data.Traversable import Data.Word import Language.Haskell.TH import Prelude hiding (mapM) import System.Posix.Types (Fd(..)) -- | Compatibility helper to create (total) tuple expressions mkTupE :: [Exp] -> Exp mkTupE = TupE #if MIN_VERSION_template_haskell(2,16,0) . map Just #endif 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 mkTupE finalResultTuple = mapOrHead' VarE finalOutputNames mkTupE 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 $ addTypeArg (getArgType propType) $ 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 mkTupE 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 = do xml <- runIO $ Text.readFile filepath let obj = head $ maybeToList $ I.parseXML "/" xml interface = head $ I.objectInterfaces obj signals = generateSignalsFromInterface generationParams interface client = generateClient generationParams interface in fmap (++) signals <*> client dbus-1.2.29/lib/DBus/Internal/Address.hs0000644000000000000000000001401614263302757016043 0ustar0000000000000000{-# Language LambdaCase #-} -- Copyright (C) 2009-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBus.Internal.Address where import Data.Char (digitToInt, ord, chr) import Data.Maybe (listToMaybe, fromMaybe) import Data.List (intercalate) import qualified Data.Map import Data.Map (Map) import System.Environment (lookupEnv) import Text.Printf (printf) import Text.ParserCombinators.Parsec -- | When a D-Bus server must listen for connections, or a client must connect -- to a server, the listening socket's configuration is specified with an -- /address/. An address contains the /method/, which determines the -- protocol and transport mechanism, and /parameters/, which provide -- additional method-specific information about the address. data Address = Address String (Map String String) deriving (Eq) addressMethod :: Address -> String addressMethod (Address x _ ) = x addressParameters :: Address -> Map String String addressParameters (Address _ x) = x -- | Try to convert a method string and parameter map to an 'Address'. -- -- Returns 'Nothing' if the method or parameters are invalid. address :: String -> Map String String -> Maybe Address address method params = if validMethod method && validParams params then if null method && Data.Map.null params then Nothing else Just (Address method params) else Nothing validMethod :: String -> Bool validMethod = all validChar where validChar c = c /= ';' && c /= ':' validParams :: Map String String -> Bool validParams = all validItem . Data.Map.toList where validItem (k, v) = notNull k && notNull v && validKey k validKey = all validChar validChar c = c /= ';' && c /= ',' && c /= '=' notNull = not . null optionallyEncoded :: [Char] optionallyEncoded = concat [ ['0'..'9'] , ['a'..'z'] , ['A'..'Z'] , ['-', '_', '/', '\\', '*', '.'] ] -- | Convert an address to a string in the format expected by 'parseAddress'. formatAddress :: Address -> String formatAddress (Address method params) = concat [method, ":", csvParams] where csvParams = intercalate "," $ do (k, v) <- Data.Map.toList params let v' = concatMap escape v return (concat [k, "=", v']) escape c = if elem c optionallyEncoded then [c] else printf "%%%02X" (ord c) -- | Convert a list of addresses to a string in the format expected by -- 'parseAddresses'. formatAddresses :: [Address] -> String formatAddresses = intercalate ";" . map formatAddress instance Show Address where showsPrec d x = showParen (d > 10) $ showString "Address " . shows (formatAddress x) -- | Try to parse a string containing one valid address. -- -- An address string is in the format @method:key1=val1,key2=val2@. There -- are some limitations on the characters allowed within methods and -- parameters; see the D-Bus specification for full details. parseAddress :: String -> Maybe Address parseAddress = maybeParseString $ do addr <- parsecAddress eof return addr -- | Try to parse a string containing one or more valid addresses. -- -- Addresses are separated by semicolons. See 'parseAddress' for the format -- of addresses. parseAddresses :: String -> Maybe [Address] parseAddresses = maybeParseString $ do addrs <- sepEndBy parsecAddress (char ';') eof return addrs parsecAddress :: Parser Address parsecAddress = p where p = do method <- many (noneOf ":;") _ <- char ':' params <- sepEndBy param (char ',') return (Address method (Data.Map.fromList params)) param = do key <- many1 (noneOf "=;,") _ <- char '=' value <- many1 valueChar return (key, value) valueChar = encoded <|> unencoded encoded = do _ <- char '%' hex <- count 2 hexDigit return (chr (hexToInt hex)) unencoded = oneOf optionallyEncoded -- | Returns the address in the environment variable -- @DBUS_SYSTEM_BUS_ADDRESS@, or -- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@ -- is not set. -- -- Returns 'Nothing' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid address. getSystemAddress :: IO (Maybe Address) getSystemAddress = do let system = "unix:path=/var/run/dbus/system_bus_socket" env <- lookupEnv "DBUS_SYSTEM_BUS_ADDRESS" return (parseAddress (fromMaybe system env)) -- | Returns the first address in the environment variable -- @DBUS_SESSION_BUS_ADDRESS@, which must be set. -- -- Returns 'Nothing' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid address -- or @DBUS_SESSION_BUS_ADDRESS@ is unset @XDG_RUNTIME_DIR@ doesn't have @/bus@. getSessionAddress :: IO (Maybe Address) getSessionAddress = lookupEnv "DBUS_SESSION_BUS_ADDRESS" >>= \case Just addrs -> pure (parseAddresses addrs >>= listToMaybe) Nothing -> (>>= parseFallback) <$> lookupEnv "XDG_RUNTIME_DIR" where parseFallback dir = parseAddress ("unix:path=" ++ dir ++ "/bus") -- | Returns the address in the environment variable -- @DBUS_STARTER_ADDRESS@, which must be set. -- -- Returns 'Nothing' if @DBUS_STARTER_ADDRESS@ is unset or contains an -- invalid address. getStarterAddress :: IO (Maybe Address) getStarterAddress = do env <- lookupEnv "DBUS_STARTER_ADDRESS" return (env >>= parseAddress) hexToInt :: String -> Int hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt maybeParseString :: Parser a -> String -> Maybe a maybeParseString p str = case runParser p () "" str of Left _ -> Nothing Right a -> Just a dbus-1.2.29/lib/DBus/Internal/Message.hs0000644000000000000000000002504114263302757016042 0ustar0000000000000000-- Copyright (C) 2009-2012 John Millikin -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . module DBus.Internal.Message ( Message(..) , UnknownMessage(..) , MethodCall(..) , MethodReturn(..) , MethodError(..) , methodErrorMessage , Signal(..) , ReceivedMessage(..) -- for use in Wire , HeaderField(..) , setMethodCallFlags ) where import Data.Bits ((.|.), (.&.)) import Data.Maybe (fromMaybe, listToMaybe) import Data.Word (Word8, Word32) import DBus.Internal.Types class Message a where messageTypeCode :: a -> Word8 messageHeaderFields :: a -> [HeaderField] messageBody :: a -> [Variant] messageFlags :: a -> Word8 messageFlags _ = 0 maybe' :: (a -> b) -> Maybe a -> [b] maybe' f = maybe [] (\x' -> [f x']) data UnknownMessage = UnknownMessage { unknownMessageType :: Word8 , unknownMessageSender :: Maybe BusName , unknownMessageBody :: [Variant] } deriving (Show, Eq) data HeaderField = HeaderPath ObjectPath | HeaderInterface InterfaceName | HeaderMember MemberName | HeaderErrorName ErrorName | HeaderReplySerial Serial | HeaderDestination BusName | HeaderSender BusName | HeaderSignature Signature | HeaderUnixFds Word32 deriving (Show, Eq) -- | A method call is a request to run some procedure exported by the -- remote process. Procedures are identified by an (object_path, -- interface_name, method_name) tuple. data MethodCall = MethodCall { -- | The object path of the method call. Conceptually, object paths -- act like a procedural language's pointers. Each object referenced -- by a path is a collection of procedures. methodCallPath :: ObjectPath -- | The interface of the method call. Each object may implement any -- number of interfaces. Each method is part of at least one -- interface. -- -- In certain cases, this may be @Nothing@, but most users should set -- it to a value. , methodCallInterface :: Maybe InterfaceName -- | The method name of the method call. Method names are unique within -- an interface, but might not be unique within an object. , methodCallMember :: MemberName -- | The name of the application that sent this call. -- -- Most users will just leave this empty, because the bus overwrites -- the sender for security reasons. Setting the sender manually is -- used for peer-peer connections. -- -- Defaults to @Nothing@. , methodCallSender :: Maybe BusName -- | The name of the application to send the call to. -- -- Most users should set this. If a message with no destination is -- sent to the bus, the bus will behave as if the destination was -- set to @org.freedesktop.DBus@. For peer-peer connections, the -- destination can be empty because there is only one peer. -- -- Defaults to @Nothing@. , methodCallDestination :: Maybe BusName -- | Set whether a reply is expected. This can save network and cpu -- resources by inhibiting unnecessary replies. -- -- Defaults to @True@. , methodCallReplyExpected :: Bool -- | Set whether the bus should auto-start the remote -- -- Defaults to @True@. , methodCallAutoStart :: Bool -- | The arguments to the method call. See 'toVariant'. -- -- Defaults to @[]@. , methodCallBody :: [Variant] } deriving (Eq, Show) setMethodCallFlags :: MethodCall -> Word8 -> MethodCall setMethodCallFlags c w = c { methodCallReplyExpected = w .&. 0x1 == 0 , methodCallAutoStart = w .&. 0x2 == 0 } instance Message MethodCall where messageTypeCode _ = 1 messageFlags c = foldr (.|.) 0 [ if methodCallReplyExpected c then 0 else 0x1 , if methodCallAutoStart c then 0 else 0x2 ] messageBody = methodCallBody messageHeaderFields m = concat [ [ HeaderPath (methodCallPath m) , HeaderMember (methodCallMember m) ] , maybe' HeaderInterface (methodCallInterface m) , maybe' HeaderSender (methodCallSender m) , maybe' HeaderDestination (methodCallDestination m) ] -- | A method return is a reply to a method call, indicating that the call -- succeeded. data MethodReturn = MethodReturn { -- | The serial of the original method call. This lets the original -- caller match up this reply to the pending call. methodReturnSerial :: Serial -- | The name of the application that is returning from a call. -- -- Most users will just leave this empty, because the bus overwrites -- the sender for security reasons. Setting the sender manually is -- used for peer-peer connections. -- -- Defaults to @Nothing@. , methodReturnSender :: Maybe BusName -- | The name of the application that initiated the call. -- -- Most users should set this. If a message with no destination is -- sent to the bus, the bus will behave as if the destination was -- set to @org.freedesktop.DBus@. For peer-peer connections, the -- destination can be empty because there is only one peer. -- -- Defaults to @Nothing@. , methodReturnDestination :: Maybe BusName -- | Values returned from the method call. See 'toVariant'. -- -- Defaults to @[]@. , methodReturnBody :: [Variant] } deriving (Show, Eq) instance Message MethodReturn where messageTypeCode _ = 2 messageBody = methodReturnBody messageHeaderFields m = concat [ [ HeaderReplySerial (methodReturnSerial m) ] , maybe' HeaderSender (methodReturnSender m) , maybe' HeaderDestination (methodReturnDestination m) ] -- | A method error is a reply to a method call, indicating that the call -- received an error and did not succeed. data MethodError = MethodError { -- | The name of the error type. Names are used so clients can -- handle certain classes of error differently from others. methodErrorName :: ErrorName -- | The serial of the original method call. This lets the original -- caller match up this reply to the pending call. , methodErrorSerial :: Serial -- | The name of the application that is returning from a call. -- -- Most users will just leave this empty, because the bus overwrites -- the sender for security reasons. Setting the sender manually is -- used for peer-peer connections. -- -- Defaults to @Nothing@. , methodErrorSender :: Maybe BusName -- | The name of the application that initiated the call. -- -- Most users should set this. If a message with no destination is -- sent to the bus, the bus will behave as if the destination was -- set to @org.freedesktop.DBus@. For peer-peer connections, the -- destination can be empty because there is only one peer. -- -- Defaults to @Nothing@. , methodErrorDestination :: Maybe BusName -- | Additional information about the error. By convention, if -- the error body contains any items, the first item should be a -- string describing the error. , methodErrorBody :: [Variant] } deriving (Show, Eq) instance Message MethodError where messageTypeCode _ = 3 messageBody = methodErrorBody messageHeaderFields m = concat [ [ HeaderErrorName (methodErrorName m) , HeaderReplySerial (methodErrorSerial m) ] , maybe' HeaderSender (methodErrorSender m) , maybe' HeaderDestination (methodErrorDestination m) ] -- | Get a human-readable description of the error, by returning the first -- item in the error body if it's a string. methodErrorMessage :: MethodError -> String methodErrorMessage err = fromMaybe "(no error message)" $ do field <- listToMaybe (methodErrorBody err) msg <- fromVariant field if null msg then Nothing else return msg -- | Signals are broadcast by applications to notify other clients of some -- event. data Signal = Signal { -- | The path of the object that emitted this signal. signalPath :: ObjectPath -- | The interface that this signal belongs to. , signalInterface :: InterfaceName -- | The name of this signal. , signalMember :: MemberName -- | The name of the application that emitted this signal. -- -- Most users will just leave this empty, because the bus overwrites -- the sender for security reasons. Setting the sender manually is -- used for peer-peer connections. -- -- Defaults to @Nothing@. , signalSender :: Maybe BusName -- | The name of the application to emit the signal to. If @Nothing@, -- the signal is sent to any application that has registered an -- appropriate match rule. -- -- Defaults to @Nothing@. , signalDestination :: Maybe BusName -- | Additional information about the signal, such as the new value -- or the time. -- -- Defaults to @[]@. , signalBody :: [Variant] } deriving (Show, Eq) instance Message Signal where messageTypeCode _ = 4 messageBody = signalBody messageHeaderFields m = concat [ [ HeaderPath (signalPath m) , HeaderMember (signalMember m) , HeaderInterface (signalInterface m) ] , maybe' HeaderSender (signalSender m) , maybe' HeaderDestination (signalDestination m) ] -- | Not an actual message type, but a wrapper around messages received from -- the bus. Each value contains the message's 'Serial'. -- -- If casing against these constructors, always include a default case to -- handle messages of an unknown type. New message types may be added to the -- D-Bus specification, and applications should handle them gracefully by -- either ignoring or logging them. data ReceivedMessage = ReceivedMethodCall Serial MethodCall | ReceivedMethodReturn Serial MethodReturn | ReceivedMethodError Serial MethodError | ReceivedSignal Serial Signal | ReceivedUnknown Serial UnknownMessage deriving (Show, Eq) dbus-1.2.29/lib/DBus/Internal/Types.hs0000644000000000000000000016355014263302757015572 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -- Copyright (C) 2009-2012 John Millikin -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . module DBus.Internal.Types where import Control.DeepSeq import Control.Monad (liftM, when, (>=>)) import Control.Monad.Catch import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL 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, Proxy(..)) import qualified Data.Vector import Data.Vector (Vector) import Data.Word import GHC.Generics import qualified Language.Haskell.TH.Lift as THL import System.Posix.Types (Fd) import Text.ParserCombinators.Parsec ((<|>), oneOf) import qualified Text.ParserCombinators.Parsec as Parsec data Type = TypeBoolean | TypeWord8 | TypeWord16 | TypeWord32 | TypeWord64 | TypeInt16 | TypeInt32 | TypeInt64 | TypeDouble | TypeUnixFd | TypeString | TypeSignature | TypeObjectPath | TypeVariant | TypeArray Type | TypeDictionary Type Type | TypeStructure [Type] deriving (Eq, Ord, Generic) instance NFData Type instance Show Type where showsPrec d = showString . showType (d > 10) showType :: Bool -> Type -> String showType paren t = case t of TypeBoolean -> "Bool" TypeWord8 -> "Word8" TypeWord16 -> "Word16" TypeWord32 -> "Word32" TypeWord64 -> "Word64" TypeInt16 -> "Int16" TypeInt32 -> "Int32" TypeInt64 -> "Int64" TypeDouble -> "Double" TypeUnixFd -> "UnixFd" TypeString -> "String" TypeSignature -> "Signature" TypeObjectPath -> "ObjectPath" TypeVariant -> "Variant" TypeArray t' -> concat ["[", show t', "]"] TypeDictionary kt vt -> showParen paren ( showString "Dict " . shows kt . showString " " . showsPrec 11 vt) "" TypeStructure ts -> concat ["(", intercalate ", " (map show ts), ")"] -- | A signature is a list of D-Bus types, obeying some basic rules of -- validity. -- -- The rules of signature validity are complex: see -- -- for details. newtype Signature = Signature [Type] deriving (Eq, Ord, NFData) -- | Get the list of types in a signature. The inverse of 'signature'. signatureTypes :: Signature -> [Type] signatureTypes (Signature types) = types instance Show Signature where showsPrec d sig = showParen (d > 10) $ showString "Signature " . shows (formatSignature sig) -- | Convert a signature into a signature string. The inverse of -- 'parseSignature'. formatSignature :: Signature -> String formatSignature = concatMap typeCode . signatureTypes typeCode :: Type -> String typeCode TypeBoolean = "b" typeCode TypeWord8 = "y" typeCode TypeWord16 = "q" typeCode TypeWord32 = "u" typeCode TypeWord64 = "t" typeCode TypeInt16 = "n" typeCode TypeInt32 = "i" typeCode TypeInt64 = "x" typeCode TypeDouble = "d" typeCode TypeUnixFd = "h" typeCode TypeString = "s" typeCode TypeSignature = "g" typeCode TypeObjectPath = "o" typeCode TypeVariant = "v" typeCode (TypeArray t) = 'a' : typeCode t typeCode (TypeDictionary kt vt) = concat [ "a{", typeCode kt , typeCode vt, "}"] typeCode (TypeStructure ts) = concat ["(", concatMap typeCode ts, ")"] instance Data.String.IsString Signature where fromString = forceParse "signature" parseSignature -- | Convert a list of types into a valid signature. -- -- Throws if the given types are not a valid signature. signature :: MonadThrow m => [Type] -> m Signature signature = check where check ts = if sumLen ts > 255 then throwM $ userError "invalid signature" else pure (Signature ts) sumLen :: [Type] -> Int sumLen = sum . map len len (TypeArray t) = 1 + len t len (TypeDictionary kt vt) | typeIsAtomic kt = 3 + len kt + len vt | otherwise = 256 len (TypeStructure []) = 256 len (TypeStructure ts) = 2 + sumLen ts len _ = 1 typeIsAtomic TypeVariant = False typeIsAtomic TypeArray{} = False typeIsAtomic TypeDictionary{} = False typeIsAtomic TypeStructure{} = False typeIsAtomic _ = True -- | Convert a list of types into a valid signature. -- -- Throws an exception if the given types are not a valid signature. signature_ :: [Type] -> Signature signature_ ts = case signature ts of Just sig -> sig Nothing -> error ("invalid signature: " ++ show ts) -- | Parse a signature string into a valid signature. -- -- Throws if the given string is not a valid signature. parseSignature :: MonadThrow m => String -> m Signature parseSignature s = do when (length s > 255) $ throwM $ userError "string too long" when (any (\c -> ord c > 0x7F) s) $ throwM $ userError "invalid signature" parseSignatureBytes (BS8.pack s) parseSignatureBytes :: MonadThrow m => BS.ByteString -> m Signature parseSignatureBytes bytes = case BS.length bytes of 0 -> pure (Signature []) 1 -> parseSigFast bytes len | len <= 255 -> parseSigFull bytes _ -> throwM $ userError "string too long" parseSigFast :: MonadThrow m => BS.ByteString -> m Signature parseSigFast bytes = let byte = BS.head bytes in parseAtom (fromIntegral byte) (\t -> pure (Signature [t])) (case byte of 0x76 -> pure (Signature [TypeVariant]) _ -> throwM $ userError "invalid signature") parseAtom :: Int -> (Type -> a) -> a -> a parseAtom byte yes no = case byte of 0x62 -> yes TypeBoolean 0x6E -> yes TypeInt16 0x69 -> yes TypeInt32 0x78 -> yes TypeInt64 0x79 -> yes TypeWord8 0x71 -> yes TypeWord16 0x75 -> yes TypeWord32 0x74 -> yes TypeWord64 0x64 -> yes TypeDouble 0x68 -> yes TypeUnixFd 0x73 -> yes TypeString 0x67 -> yes TypeSignature 0x6F -> yes TypeObjectPath _ -> no {-# INLINE parseAtom #-} data SigParseError = SigParseError deriving (Show, Typeable) instance Exception SigParseError peekWord8AsInt :: BS.ByteString -> Int -> Int peekWord8AsInt str i = fromIntegral $ BS.index str i parseSigFull :: MonadThrow m => BS.ByteString -> m Signature parseSigFull bytes = Signature <$> mainLoop [] 0 where len = BS.length bytes mainLoop acc ii | ii >= len = pure (reverse acc) mainLoop acc ii = do let c = peekWord8AsInt bytes ii let next t = mainLoop (t : acc) (ii + 1) parseAtom c next $ case c of 0x76 -> next TypeVariant 0x28 -> do -- '(' (ii', t) <- structure (ii + 1) mainLoop (t : acc) ii' 0x61 -> do -- 'a' (ii', t) <- array (ii + 1) mainLoop (t : acc) ii' _ -> throwM SigParseError structure = loop [] where loop _ ii | ii >= len = throwM SigParseError loop acc ii = do let c = peekWord8AsInt bytes ii let next t = loop (t : acc) (ii + 1) parseAtom c next $ case c of 0x76 -> next TypeVariant 0x28 -> do -- '(' (ii', t) <- structure (ii + 1) loop (t : acc) ii' 0x61 -> do -- 'a' (ii', t) <- array (ii + 1) loop (t : acc) ii' -- ')' 0x29 -> case acc of [] -> throwM SigParseError _ -> pure (ii + 1, TypeStructure (reverse acc)) _ -> throwM SigParseError array ii | ii >= len = throwM SigParseError array ii = do let c = peekWord8AsInt bytes ii let next t = pure (ii + 1, TypeArray t) parseAtom c next $ case c of 0x76 -> next TypeVariant 0x7B -> dict (ii + 1) -- '{' 0x28 -> do -- '(' (ii', t) <- structure (ii + 1) pure (ii', TypeArray t) 0x61 -> do -- 'a' (ii', t) <- array (ii + 1) pure (ii', TypeArray t) _ -> throwM SigParseError dict ii | ii + 1 >= len = throwM SigParseError dict ii = do let c1 = peekWord8AsInt bytes ii let c2 = peekWord8AsInt bytes (ii + 1) let next t = pure (ii + 2, t) (ii', t2) <- parseAtom c2 next $ case c2 of 0x76 -> next TypeVariant 0x28 -> structure (ii + 2) -- '(' 0x61 -> array (ii + 2) -- 'a' _ -> throwM SigParseError if ii' >= len then throwM SigParseError else do let c3 = peekWord8AsInt bytes ii' if c3 == 0x7D then do t1 <- parseAtom c1 pure (throwM SigParseError) pure (ii' + 1, TypeDictionary t1 t2) else throwM SigParseError extractFromVariant :: IsValue a => Variant -> Maybe a extractFromVariant (Variant (ValueVariant v)) = extractFromVariant v extractFromVariant v = fromVariant v typeOf :: forall a. IsValue a => a -> Type typeOf _ = typeOf_ (Proxy :: Proxy a) class IsVariant a where toVariant :: a -> Variant fromVariant :: Variant -> Maybe a -- | Value types can be used as items in containers, such as lists or -- dictionaries. -- -- Users may not provide new instances of 'IsValue' because this could allow -- containers to be created with items of heterogenous types. class IsVariant a => IsValue a where typeOf_ :: Proxy a -> Type toValue :: a -> Value fromValue :: Value -> Maybe a -- | Atomic types can be used as keys to dictionaries. -- -- Users may not provide new instances of 'IsAtom' because this could allow -- dictionaries to be created with invalid keys. class IsValue a => IsAtom a where toAtom :: a -> Atom fromAtom :: Atom -> Maybe a -- | Variants may contain any other built-in D-Bus value. Besides -- representing native @VARIANT@ values, they allow type-safe storage and -- inspection of D-Bus collections. newtype Variant = Variant Value deriving (Eq) data Value = ValueAtom Atom | ValueVariant Variant | ValueBytes BS.ByteString | ValueVector Type (Vector Value) | ValueMap Type Type (Map Atom Value) | ValueStructure [Value] deriving (Show) data Atom = AtomBool Bool | AtomWord8 Word8 | AtomWord16 Word16 | AtomWord32 Word32 | AtomWord64 Word64 | AtomInt16 Int16 | AtomInt32 Int32 | AtomInt64 Int64 | AtomDouble Double | AtomUnixFd Fd | AtomText Text | AtomSignature Signature | AtomObjectPath ObjectPath deriving (Show, Eq, Ord) instance Eq Value where (==) (ValueBytes x) y = case y of ValueBytes y' -> x == y' ValueVector TypeWord8 y' -> x == vectorToBytes y' _ -> False (==) (ValueVector TypeWord8 x) y = case y of ValueBytes y' -> vectorToBytes x == y' ValueVector TypeWord8 y' -> x == y' _ -> False (==) (ValueAtom x) (ValueAtom y) = x == y (==) (ValueVariant x) (ValueVariant y) = x == y (==) (ValueVector tx x) (ValueVector ty y) = tx == ty && x == y (==) (ValueMap ktx vtx x) (ValueMap kty vty y) = ktx == kty && vtx == vty && x == y (==) (ValueStructure x) (ValueStructure y) = x == y (==) _ _ = False showAtom :: Bool -> Atom -> String showAtom _ (AtomBool x) = show x showAtom _ (AtomWord8 x) = show x showAtom _ (AtomWord16 x) = show x showAtom _ (AtomWord32 x) = show x showAtom _ (AtomWord64 x) = show x showAtom _ (AtomInt16 x) = show x showAtom _ (AtomInt32 x) = show x showAtom _ (AtomInt64 x) = show x showAtom _ (AtomDouble x) = show x showAtom p (AtomUnixFd x) = showParen p (showString "UnixFd " . shows x) "" showAtom _ (AtomText x) = show x showAtom p (AtomSignature x) = showsPrec (if p then 11 else 0) x "" showAtom p (AtomObjectPath x) = showsPrec (if p then 11 else 0) x "" showValue :: Bool -> Value -> String showValue p (ValueAtom x) = showAtom p x showValue p (ValueVariant x) = showsPrec (if p then 11 else 0) x "" showValue _ (ValueBytes xs) = 'b' : show xs showValue _ (ValueVector TypeWord8 xs) = 'b' : show (vectorToBytes xs) showValue _ (ValueVector _ xs) = showThings "[" (showValue False) "]" (Data.Vector.toList xs) showValue _ (ValueMap _ _ xs) = showThings "{" showPair "}" (Data.Map.toList xs) where showPair (k, v) = showAtom False k ++ ": " ++ showValue False v showValue _ (ValueStructure xs) = showThings "(" (showValue False) ")" xs showThings :: String -> (a -> String) -> String -> [a] -> String showThings a s z xs = a ++ intercalate ", " (map s xs) ++ z vectorToBytes :: Vector Value -> BS.ByteString vectorToBytes = BS.pack . Data.Vector.toList . Data.Vector.map (\(ValueAtom (AtomWord8 x)) -> x) instance Show Variant where showsPrec d (Variant x) = showParen (d > 10) $ showString "Variant " . showString (showValue True x) -- | Every variant is strongly-typed; that is, the type of its contained -- value is known at all times. This function retrieves that type, so that -- the correct cast can be used to retrieve the value. variantType :: Variant -> Type variantType (Variant val) = valueType val valueType :: Value -> Type valueType (ValueAtom x) = atomType x valueType (ValueVariant _) = TypeVariant valueType (ValueVector t _) = TypeArray t valueType (ValueBytes _) = TypeArray TypeWord8 valueType (ValueMap kt vt _) = TypeDictionary kt vt valueType (ValueStructure vs) = TypeStructure (map valueType vs) atomType :: Atom -> Type atomType (AtomBool _) = TypeBoolean atomType (AtomWord8 _) = TypeWord8 atomType (AtomWord16 _) = TypeWord16 atomType (AtomWord32 _) = TypeWord32 atomType (AtomWord64 _) = TypeWord64 atomType (AtomInt16 _) = TypeInt16 atomType (AtomInt32 _) = TypeInt32 atomType (AtomInt64 _) = TypeInt64 atomType (AtomDouble _) = TypeDouble atomType (AtomUnixFd _) = TypeUnixFd atomType (AtomText _) = TypeString atomType (AtomSignature _) = TypeSignature atomType (AtomObjectPath _) = TypeObjectPath #define IS_ATOM(HsType, AtomCons, TypeCons) \ instance IsAtom HsType where \ { toAtom = AtomCons \ ; fromAtom (AtomCons x) = Just x \ ; fromAtom _ = Nothing \ }; \ instance IsValue HsType where \ { typeOf_ _ = TypeCons \ ; toValue = ValueAtom . toAtom \ ; fromValue (ValueAtom x) = fromAtom x \ ; fromValue _ = Nothing \ }; \ instance IsVariant HsType where \ { toVariant = Variant . toValue \ ; fromVariant (Variant val) = fromValue val \ } IS_ATOM(Bool, AtomBool, TypeBoolean) IS_ATOM(Word8, AtomWord8, TypeWord8) IS_ATOM(Word16, AtomWord16, TypeWord16) IS_ATOM(Word32, AtomWord32, TypeWord32) IS_ATOM(Word64, AtomWord64, TypeWord64) IS_ATOM(Int16, AtomInt16, TypeInt16) IS_ATOM(Int32, AtomInt32, TypeInt32) IS_ATOM(Int64, AtomInt64, TypeInt64) IS_ATOM(Double, AtomDouble, TypeDouble) IS_ATOM(Fd, AtomUnixFd, TypeUnixFd) IS_ATOM(Text, AtomText, TypeString) IS_ATOM(Signature, AtomSignature, TypeSignature) IS_ATOM(ObjectPath, AtomObjectPath, TypeObjectPath) instance IsValue Variant where typeOf_ _ = TypeVariant toValue = ValueVariant fromValue (ValueVariant x) = Just x fromValue _ = Nothing instance IsVariant Variant where toVariant = Variant . toValue fromVariant (Variant val) = fromValue val instance IsAtom Data.Text.Lazy.Text where toAtom = toAtom . Data.Text.Lazy.toStrict fromAtom = fmap Data.Text.Lazy.fromStrict . fromAtom instance IsValue Data.Text.Lazy.Text where typeOf_ _ = TypeString toValue = ValueAtom . toAtom fromValue (ValueAtom x) = fromAtom x fromValue _ = Nothing instance IsVariant Data.Text.Lazy.Text where toVariant = Variant . toValue fromVariant (Variant val) = fromValue val instance IsAtom String where toAtom = toAtom . Data.Text.pack fromAtom = fmap Data.Text.unpack . fromAtom instance IsValue String where typeOf_ _ = TypeString toValue = ValueAtom . toAtom fromValue (ValueAtom x) = fromAtom x fromValue _ = Nothing instance IsVariant String where toVariant = Variant . toValue fromVariant (Variant val) = fromValue val instance IsValue a => IsValue (Vector a) where typeOf_ _ = TypeArray (typeOf_ (Proxy :: Proxy a)) toValue v = ValueVector (typeOf_ (Proxy :: Proxy a)) (Data.Vector.map toValue v) fromValue (ValueVector _ v) = Data.Vector.mapM fromValue v fromValue _ = Nothing instance IsValue a => IsVariant (Vector a) where toVariant = Variant . toValue fromVariant (Variant val) = fromValue val instance IsValue a => IsValue [a] where typeOf_ _ = TypeArray (typeOf_ (Proxy :: Proxy a)) toValue = toValue . Data.Vector.fromList fromValue = fmap Data.Vector.toList . fromValue instance IsValue a => IsVariant [a] where toVariant = toVariant . Data.Vector.fromList fromVariant = fmap Data.Vector.toList . fromVariant instance IsValue BS.ByteString where typeOf_ _ = TypeArray TypeWord8 toValue = ValueBytes fromValue (ValueBytes bs) = Just bs fromValue (ValueVector TypeWord8 v) = Just (vectorToBytes v) fromValue _ = Nothing instance IsVariant BS.ByteString where toVariant = Variant . toValue fromVariant (Variant val) = fromValue val instance IsValue BL.ByteString where typeOf_ _ = TypeArray TypeWord8 toValue = toValue . BS.concat . BL.toChunks fromValue = fmap (\bs -> BL.fromChunks [bs]) . fromValue instance IsVariant BL.ByteString where toVariant = Variant . toValue fromVariant (Variant val) = fromValue val instance (Ord k, IsAtom k, IsValue v) => IsValue (Map k v) where typeOf_ _ = TypeDictionary (typeOf_ (Proxy :: Proxy k)) (typeOf_ (Proxy :: Proxy v)) toValue m = ValueMap kt vt (bimap box m) where kt = typeOf_ (Proxy :: Proxy k) vt = typeOf_ (Proxy :: Proxy v) box k v = (toAtom k, toValue v) fromValue (ValueMap _ _ m) = bimapM unbox m where unbox k v = do k' <- fromAtom k v' <- fromValue v return (k', v') fromValue _ = Nothing bimap :: Ord k' => (k -> v -> (k', v')) -> Map k v -> Map k' v' bimap f = Data.Map.fromList . map (\(k, v) -> f k v) . Data.Map.toList bimapM :: (Monad m, Ord k') => (k -> v -> m (k', v')) -> Map k v -> m (Map k' v') bimapM f = liftM Data.Map.fromList . mapM (\(k, v) -> f k v) . Data.Map.toList instance (Ord k, IsAtom k, IsValue v) => IsVariant (Map k v) where 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_ _ = TypeStructure [ typeOf_ (Proxy :: Proxy a1) , typeOf_ (Proxy :: Proxy a2) ] toValue (a1, a2) = ValueStructure [toValue a1, toValue a2] fromValue (ValueStructure [a1, a2]) = do a1' <- fromValue a1 a2' <- fromValue a2 return (a1', a2') fromValue _ = Nothing instance (IsVariant a1, IsVariant a2) => IsVariant (a1, a2) where toVariant (a1, a2) = Variant (ValueStructure [varToVal a1, varToVal a2]) fromVariant (Variant (ValueStructure [a1, a2])) = do a1' <- (fromVariant . Variant) a1 a2' <- (fromVariant . Variant) a2 return (a1', a2') fromVariant _ = Nothing varToVal :: IsVariant a => a -> Value varToVal a = case toVariant a of Variant val -> val -- | Object paths are special strings, used to identify a particular object -- exported from a D-Bus application. -- -- Object paths must begin with a slash, and consist of alphanumeric -- characters separated by slashes. -- -- See -- -- for details. 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 parseObjectPath :: MonadThrow m => String -> m ObjectPath parseObjectPath s = do maybeParseString parserObjectPath s return (ObjectPath s) objectPath_ :: String -> ObjectPath objectPath_ = forceParse "object path" parseObjectPath instance Data.String.IsString ObjectPath where fromString = objectPath_ parserObjectPath :: Parsec.Parser () parserObjectPath = root <|> object where root = Parsec.try $ do slash Parsec.eof object = do slash skipSepBy1 element slash Parsec.eof element = Parsec.skipMany1 (oneOf chars) slash = Parsec.char '/' >> return () chars = concat [ ['a'..'z'] , ['A'..'Z'] , ['0'..'9'] , "_"] -- | Interfaces are used to group a set of methods and signals within an -- exported object. Interface names consist of alphanumeric characters -- separated by periods. -- -- See -- -- for details. newtype InterfaceName = InterfaceName String deriving (Eq, Ord, Show, NFData) formatInterfaceName :: InterfaceName -> String formatInterfaceName (InterfaceName s) = s parseInterfaceName :: MonadThrow m => String -> m InterfaceName parseInterfaceName s = do when (length s > 255) $ throwM $ userError "name too long" maybeParseString parserInterfaceName s return (InterfaceName s) interfaceName_ :: String -> InterfaceName interfaceName_ = forceParse "interface name" parseInterfaceName instance Data.String.IsString InterfaceName where fromString = interfaceName_ instance IsVariant InterfaceName where toVariant = toVariant . formatInterfaceName fromVariant = fromVariant >=> parseInterfaceName parserInterfaceName :: Parsec.Parser () parserInterfaceName = name >> Parsec.eof where alpha = ['a'..'z'] ++ ['A'..'Z'] ++ "_" alphanum = alpha ++ ['0'..'9'] element = do _ <- oneOf alpha Parsec.skipMany (oneOf alphanum) name = do element _ <- Parsec.char '.' skipSepBy1 element (Parsec.char '.') -- | Member names are used to identify a single method or signal within an -- interface. Method names consist of alphanumeric characters. -- -- See -- -- for details. newtype MemberName = MemberName String deriving (Eq, Ord, Show, NFData) formatMemberName :: MemberName -> String formatMemberName (MemberName s) = s parseMemberName :: MonadThrow m => String -> m MemberName parseMemberName s = do when (length s > 255) $ throwM $ userError "name too long" maybeParseString parserMemberName s return (MemberName s) memberName_ :: String -> MemberName memberName_ = forceParse "member name" parseMemberName instance Data.String.IsString MemberName where fromString = memberName_ instance IsVariant MemberName where toVariant = toVariant . formatMemberName fromVariant = fromVariant >=> parseMemberName parserMemberName :: Parsec.Parser () parserMemberName = name >> Parsec.eof where alpha = ['a'..'z'] ++ ['A'..'Z'] ++ "_" alphanum = alpha ++ ['0'..'9'] name = do _ <- oneOf alpha Parsec.skipMany (oneOf alphanum) -- | Error names are used to identify which type of error was returned from -- a method call. Error names consist of alphanumeric characters -- separated by periods. -- -- See -- -- for details. newtype ErrorName = ErrorName String deriving (Eq, Ord, Show, NFData) formatErrorName :: ErrorName -> String formatErrorName (ErrorName s) = s parseErrorName :: MonadThrow m => String -> m ErrorName parseErrorName s = do when (length s > 255) $ throwM $ userError "name too long" maybeParseString parserInterfaceName s return (ErrorName s) errorName_ :: String -> ErrorName errorName_ = forceParse "error name" parseErrorName instance Data.String.IsString ErrorName where fromString = errorName_ instance IsVariant ErrorName where toVariant = toVariant . formatErrorName fromVariant = fromVariant >=> parseErrorName -- | Bus names are used to identify particular clients on the message bus. -- A bus name may be either /unique/ or /well-known/, where unique names -- start with a colon. Bus names consist of alphanumeric characters separated -- by periods. -- -- See -- -- for details. newtype BusName = BusName String deriving (Eq, Ord, Show, NFData) formatBusName :: BusName -> String formatBusName (BusName s) = s parseBusName :: MonadThrow m => String -> m BusName parseBusName s = do when (length s > 255) $ throwM $ userError "name too long" maybeParseString parserBusName s return (BusName s) busName_ :: String -> BusName busName_ = forceParse "bus name" parseBusName instance Data.String.IsString BusName where fromString = busName_ instance IsVariant BusName where toVariant = toVariant . formatBusName fromVariant = fromVariant >=> parseBusName parserBusName :: Parsec.Parser () parserBusName = name >> Parsec.eof where alpha = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" alphanum = alpha ++ ['0'..'9'] name = unique <|> wellKnown unique = do _ <- Parsec.char ':' elements alphanum wellKnown = elements alpha elements :: [Char] -> Parsec.Parser () elements start = do element start Parsec.skipMany1 $ do _ <- Parsec.char '.' element start element :: [Char] -> Parsec.Parser () element start = do _ <- oneOf start Parsec.skipMany (oneOf alphanum) -- | A D-Bus Structure is a container type similar to Haskell tuples, storing -- values of any type that is convertable to 'IsVariant'. A Structure may -- contain up to 255 values. -- -- Most users can use the 'IsVariant' instance for tuples to extract the -- values of a structure. This type is for very large structures, which may -- be awkward to work with as tuples. newtype Structure = Structure [Value] deriving (Eq) instance Show Structure where show (Structure xs) = showValue True (ValueStructure xs) instance IsVariant Structure where toVariant (Structure xs) = Variant (ValueStructure xs) fromVariant (Variant (ValueStructure xs)) = Just (Structure xs) fromVariant _ = Nothing structureItems :: Structure -> [Variant] structureItems (Structure xs) = map Variant xs -- | A D-Bus Array is a container type similar to Haskell lists, storing -- zero or more values of a single D-Bus type. -- -- Most users can use the 'IsVariant' instance for lists or vectors to extract -- the values of an array. This type is for advanced use cases, where the user -- wants to convert array values to Haskell types that are not instances of -- 'IsValue'. data Array = Array Type (Vector Value) | ArrayBytes BS.ByteString instance Show Array where show (Array t xs) = showValue True (ValueVector t xs) show (ArrayBytes xs) = showValue True (ValueBytes xs) instance Eq Array where x == y = norm x == norm y where norm (Array TypeWord8 xs) = Left (vectorToBytes xs) norm (Array t xs) = Right (t, xs) norm (ArrayBytes xs) = Left xs instance IsVariant Array where toVariant (Array t xs) = Variant (ValueVector t xs) toVariant (ArrayBytes bs) = Variant (ValueBytes bs) fromVariant (Variant (ValueVector t xs)) = Just (Array t xs) fromVariant (Variant (ValueBytes bs)) = Just (ArrayBytes bs) fromVariant _ = Nothing arrayItems :: Array -> [Variant] arrayItems (Array _ xs) = map Variant (Data.Vector.toList xs) arrayItems (ArrayBytes bs) = map toVariant (BS.unpack bs) -- | A D-Bus Dictionary is a container type similar to Haskell maps, storing -- zero or more associations between keys and values. -- -- Most users can use the 'IsVariant' instance for maps to extract the values -- of a dictionary. This type is for advanced use cases, where the user -- wants to convert dictionary items to Haskell types that are not instances -- of 'IsValue'. data Dictionary = Dictionary Type Type (Map Atom Value) deriving (Eq) instance Show Dictionary where show (Dictionary kt vt xs) = showValue True (ValueMap kt vt xs) instance IsVariant Dictionary where toVariant (Dictionary kt vt xs) = Variant (ValueMap kt vt xs) fromVariant (Variant (ValueMap kt vt xs)) = Just (Dictionary kt vt xs) fromVariant _ = Nothing dictionaryItems :: Dictionary -> [(Variant, Variant)] dictionaryItems (Dictionary _ _ xs) = do (k, v) <- Data.Map.toList xs return (Variant (ValueAtom k), Variant v) instance (IsValue a1, IsValue a2, IsValue a3) => IsValue (a1, a2, a3) where typeOf_ _ = TypeStructure [ typeOf_ (Proxy :: Proxy a1) , typeOf_ (Proxy :: Proxy a2) , typeOf_ (Proxy :: Proxy a3) ] toValue (a1, a2, a3) = ValueStructure [toValue a1, toValue a2, toValue a3] fromValue (ValueStructure [a1, a2, a3]) = do a1' <- fromValue a1 a2' <- fromValue a2 a3' <- fromValue a3 return (a1', a2', a3') fromValue _ = Nothing instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4) => IsValue (a1, a2, a3, a4) where typeOf_ _ = TypeStructure [ typeOf_ (Proxy :: Proxy a1) , typeOf_ (Proxy :: Proxy a2) , typeOf_ (Proxy :: Proxy a3) , typeOf_ (Proxy :: Proxy a4) ] toValue (a1, a2, a3, a4) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4] fromValue (ValueStructure [a1, a2, a3, a4]) = do a1' <- fromValue a1 a2' <- fromValue a2 a3' <- fromValue a3 a4' <- fromValue a4 return (a1', a2', a3', a4') fromValue _ = Nothing instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5) => IsValue (a1, a2, a3, a4, a5) where typeOf_ _ = TypeStructure [ typeOf_ (Proxy :: Proxy a1) , typeOf_ (Proxy :: Proxy a2) , typeOf_ (Proxy :: Proxy a3) , typeOf_ (Proxy :: Proxy a4) , typeOf_ (Proxy :: Proxy a5) ] toValue (a1, a2, a3, a4, a5) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5] fromValue (ValueStructure [a1, a2, a3, a4, a5]) = do a1' <- fromValue a1 a2' <- fromValue a2 a3' <- fromValue a3 a4' <- fromValue a4 a5' <- fromValue a5 return (a1', a2', a3', a4', a5') fromValue _ = Nothing instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6) => IsValue (a1, a2, a3, a4, a5, a6) where typeOf_ _ = TypeStructure [ typeOf_ (Proxy :: Proxy a1) , typeOf_ (Proxy :: Proxy a2) , typeOf_ (Proxy :: Proxy a3) , typeOf_ (Proxy :: Proxy a4) , typeOf_ (Proxy :: Proxy a5) , typeOf_ (Proxy :: Proxy a6) ] toValue (a1, a2, a3, a4, a5, a6) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6] fromValue (ValueStructure [a1, a2, a3, a4, a5, a6]) = do a1' <- fromValue a1 a2' <- fromValue a2 a3' <- fromValue a3 a4' <- fromValue a4 a5' <- fromValue a5 a6' <- fromValue a6 return (a1', a2', a3', a4', a5', a6') fromValue _ = Nothing instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7) => IsValue (a1, a2, a3, a4, a5, a6, a7) where typeOf_ _ = TypeStructure [ typeOf_ (Proxy :: Proxy a1) , typeOf_ (Proxy :: Proxy a2) , typeOf_ (Proxy :: Proxy a3) , typeOf_ (Proxy :: Proxy a4) , typeOf_ (Proxy :: Proxy a5) , typeOf_ (Proxy :: Proxy a6) , typeOf_ (Proxy :: Proxy a7) ] toValue (a1, a2, a3, a4, a5, a6, a7) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7] fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7]) = do a1' <- fromValue a1 a2' <- fromValue a2 a3' <- fromValue a3 a4' <- fromValue a4 a5' <- fromValue a5 a6' <- fromValue a6 a7' <- fromValue a7 return (a1', a2', a3', a4', a5', a6', a7') fromValue _ = Nothing instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8) where typeOf_ _ = TypeStructure [ typeOf_ (Proxy :: Proxy a1) , typeOf_ (Proxy :: Proxy a2) , typeOf_ (Proxy :: Proxy a3) , typeOf_ (Proxy :: Proxy a4) , typeOf_ (Proxy :: Proxy a5) , typeOf_ (Proxy :: Proxy a6) , typeOf_ (Proxy :: Proxy a7) , typeOf_ (Proxy :: Proxy a8) ] toValue (a1, a2, a3, a4, a5, a6, a7, a8) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8] fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8]) = do a1' <- fromValue a1 a2' <- fromValue a2 a3' <- fromValue a3 a4' <- fromValue a4 a5' <- fromValue a5 a6' <- fromValue a6 a7' <- fromValue a7 a8' <- fromValue a8 return (a1', a2', a3', a4', a5', a6', a7', a8') fromValue _ = Nothing instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9) where typeOf_ _ = TypeStructure [ typeOf_ (Proxy :: Proxy a1) , typeOf_ (Proxy :: Proxy a2) , typeOf_ (Proxy :: Proxy a3) , typeOf_ (Proxy :: Proxy a4) , typeOf_ (Proxy :: Proxy a5) , typeOf_ (Proxy :: Proxy a6) , typeOf_ (Proxy :: Proxy a7) , typeOf_ (Proxy :: Proxy a8) , typeOf_ (Proxy :: Proxy a9) ] toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9] fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9]) = do a1' <- fromValue a1 a2' <- fromValue a2 a3' <- fromValue a3 a4' <- fromValue a4 a5' <- fromValue a5 a6' <- fromValue a6 a7' <- fromValue a7 a8' <- fromValue a8 a9' <- fromValue a9 return (a1', a2', a3', a4', a5', a6', a7', a8', a9') fromValue _ = Nothing instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) where typeOf_ _ = TypeStructure [ typeOf_ (Proxy :: Proxy a1) , typeOf_ (Proxy :: Proxy a2) , typeOf_ (Proxy :: Proxy a3) , typeOf_ (Proxy :: Proxy a4) , typeOf_ (Proxy :: Proxy a5) , typeOf_ (Proxy :: Proxy a6) , typeOf_ (Proxy :: Proxy a7) , typeOf_ (Proxy :: Proxy a8) , typeOf_ (Proxy :: Proxy a9) , typeOf_ (Proxy :: Proxy a10) ] toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10] fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10]) = do a1' <- fromValue a1 a2' <- fromValue a2 a3' <- fromValue a3 a4' <- fromValue a4 a5' <- fromValue a5 a6' <- fromValue a6 a7' <- fromValue a7 a8' <- fromValue a8 a9' <- fromValue a9 a10' <- fromValue a10 return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10') fromValue _ = Nothing instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10, IsValue a11) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) where typeOf_ _ = TypeStructure [ typeOf_ (Proxy :: Proxy a1) , typeOf_ (Proxy :: Proxy a2) , typeOf_ (Proxy :: Proxy a3) , typeOf_ (Proxy :: Proxy a4) , typeOf_ (Proxy :: Proxy a5) , typeOf_ (Proxy :: Proxy a6) , typeOf_ (Proxy :: Proxy a7) , typeOf_ (Proxy :: Proxy a8) , typeOf_ (Proxy :: Proxy a9) , typeOf_ (Proxy :: Proxy a10) , typeOf_ (Proxy :: Proxy a11) ] toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10, toValue a11] fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11]) = do a1' <- fromValue a1 a2' <- fromValue a2 a3' <- fromValue a3 a4' <- fromValue a4 a5' <- fromValue a5 a6' <- fromValue a6 a7' <- fromValue a7 a8' <- fromValue a8 a9' <- fromValue a9 a10' <- fromValue a10 a11' <- fromValue a11 return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11') fromValue _ = Nothing instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10, IsValue a11, IsValue a12) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) where typeOf_ _ = TypeStructure [ typeOf_ (Proxy :: Proxy a1) , typeOf_ (Proxy :: Proxy a2) , typeOf_ (Proxy :: Proxy a3) , typeOf_ (Proxy :: Proxy a4) , typeOf_ (Proxy :: Proxy a5) , typeOf_ (Proxy :: Proxy a6) , typeOf_ (Proxy :: Proxy a7) , typeOf_ (Proxy :: Proxy a8) , typeOf_ (Proxy :: Proxy a9) , typeOf_ (Proxy :: Proxy a10) , typeOf_ (Proxy :: Proxy a11) , typeOf_ (Proxy :: Proxy a12) ] toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10, toValue a11, toValue a12] fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12]) = do a1' <- fromValue a1 a2' <- fromValue a2 a3' <- fromValue a3 a4' <- fromValue a4 a5' <- fromValue a5 a6' <- fromValue a6 a7' <- fromValue a7 a8' <- fromValue a8 a9' <- fromValue a9 a10' <- fromValue a10 a11' <- fromValue a11 a12' <- fromValue a12 return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12') fromValue _ = Nothing instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10, IsValue a11, IsValue a12, IsValue a13) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) where typeOf_ _ = TypeStructure [ typeOf_ (Proxy :: Proxy a1) , typeOf_ (Proxy :: Proxy a2) , typeOf_ (Proxy :: Proxy a3) , typeOf_ (Proxy :: Proxy a4) , typeOf_ (Proxy :: Proxy a5) , typeOf_ (Proxy :: Proxy a6) , typeOf_ (Proxy :: Proxy a7) , typeOf_ (Proxy :: Proxy a8) , typeOf_ (Proxy :: Proxy a9) , typeOf_ (Proxy :: Proxy a10) , typeOf_ (Proxy :: Proxy a11) , typeOf_ (Proxy :: Proxy a12) , typeOf_ (Proxy :: Proxy a13) ] toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10, toValue a11, toValue a12, toValue a13] fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13]) = do a1' <- fromValue a1 a2' <- fromValue a2 a3' <- fromValue a3 a4' <- fromValue a4 a5' <- fromValue a5 a6' <- fromValue a6 a7' <- fromValue a7 a8' <- fromValue a8 a9' <- fromValue a9 a10' <- fromValue a10 a11' <- fromValue a11 a12' <- fromValue a12 a13' <- fromValue a13 return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12', a13') fromValue _ = Nothing instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10, IsValue a11, IsValue a12, IsValue a13, IsValue a14) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) where typeOf_ _ = TypeStructure [ typeOf_ (Proxy :: Proxy a1) , typeOf_ (Proxy :: Proxy a2) , typeOf_ (Proxy :: Proxy a3) , typeOf_ (Proxy :: Proxy a4) , typeOf_ (Proxy :: Proxy a5) , typeOf_ (Proxy :: Proxy a6) , typeOf_ (Proxy :: Proxy a7) , typeOf_ (Proxy :: Proxy a8) , typeOf_ (Proxy :: Proxy a9) , typeOf_ (Proxy :: Proxy a10) , typeOf_ (Proxy :: Proxy a11) , typeOf_ (Proxy :: Proxy a12) , typeOf_ (Proxy :: Proxy a13) , typeOf_ (Proxy :: Proxy a14) ] toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10, toValue a11, toValue a12, toValue a13, toValue a14] fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14]) = do a1' <- fromValue a1 a2' <- fromValue a2 a3' <- fromValue a3 a4' <- fromValue a4 a5' <- fromValue a5 a6' <- fromValue a6 a7' <- fromValue a7 a8' <- fromValue a8 a9' <- fromValue a9 a10' <- fromValue a10 a11' <- fromValue a11 a12' <- fromValue a12 a13' <- fromValue a13 a14' <- fromValue a14 return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12', a13', a14') fromValue _ = Nothing instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10, IsValue a11, IsValue a12, IsValue a13, IsValue a14, IsValue a15) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) where typeOf_ _ = TypeStructure [ typeOf_ (Proxy :: Proxy a1) , typeOf_ (Proxy :: Proxy a2) , typeOf_ (Proxy :: Proxy a3) , typeOf_ (Proxy :: Proxy a4) , typeOf_ (Proxy :: Proxy a5) , typeOf_ (Proxy :: Proxy a6) , typeOf_ (Proxy :: Proxy a7) , typeOf_ (Proxy :: Proxy a8) , typeOf_ (Proxy :: Proxy a9) , typeOf_ (Proxy :: Proxy a10) , typeOf_ (Proxy :: Proxy a11) , typeOf_ (Proxy :: Proxy a12) , typeOf_ (Proxy :: Proxy a13) , typeOf_ (Proxy :: Proxy a14) , typeOf_ (Proxy :: Proxy a15) ] toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10, toValue a11, toValue a12, toValue a13, toValue a14, toValue a15] fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15]) = do a1' <- fromValue a1 a2' <- fromValue a2 a3' <- fromValue a3 a4' <- fromValue a4 a5' <- fromValue a5 a6' <- fromValue a6 a7' <- fromValue a7 a8' <- fromValue a8 a9' <- fromValue a9 a10' <- fromValue a10 a11' <- fromValue a11 a12' <- fromValue a12 a13' <- fromValue a13 a14' <- fromValue a14 a15' <- fromValue a15 return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12', a13', a14', a15') fromValue _ = Nothing instance (IsVariant a1, IsVariant a2, IsVariant a3) => IsVariant (a1, a2, a3) where toVariant (a1, a2, a3) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3]) fromVariant (Variant (ValueStructure [a1, a2, a3])) = do a1' <- (fromVariant . Variant) a1 a2' <- (fromVariant . Variant) a2 a3' <- (fromVariant . Variant) a3 return (a1', a2', a3') fromVariant _ = Nothing instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4) => IsVariant (a1, a2, a3, a4) where toVariant (a1, a2, a3, a4) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4]) fromVariant (Variant (ValueStructure [a1, a2, a3, a4])) = do a1' <- (fromVariant . Variant) a1 a2' <- (fromVariant . Variant) a2 a3' <- (fromVariant . Variant) a3 a4' <- (fromVariant . Variant) a4 return (a1', a2', a3', a4') fromVariant _ = Nothing instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5) => IsVariant (a1, a2, a3, a4, a5) where toVariant (a1, a2, a3, a4, a5) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5]) fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5])) = do a1' <- (fromVariant . Variant) a1 a2' <- (fromVariant . Variant) a2 a3' <- (fromVariant . Variant) a3 a4' <- (fromVariant . Variant) a4 a5' <- (fromVariant . Variant) a5 return (a1', a2', a3', a4', a5') fromVariant _ = Nothing instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6) => IsVariant (a1, a2, a3, a4, a5, a6) where toVariant (a1, a2, a3, a4, a5, a6) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6]) fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6])) = do a1' <- (fromVariant . Variant) a1 a2' <- (fromVariant . Variant) a2 a3' <- (fromVariant . Variant) a3 a4' <- (fromVariant . Variant) a4 a5' <- (fromVariant . Variant) a5 a6' <- (fromVariant . Variant) a6 return (a1', a2', a3', a4', a5', a6') fromVariant _ = Nothing instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7) => IsVariant (a1, a2, a3, a4, a5, a6, a7) where toVariant (a1, a2, a3, a4, a5, a6, a7) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7]) fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7])) = do a1' <- (fromVariant . Variant) a1 a2' <- (fromVariant . Variant) a2 a3' <- (fromVariant . Variant) a3 a4' <- (fromVariant . Variant) a4 a5' <- (fromVariant . Variant) a5 a6' <- (fromVariant . Variant) a6 a7' <- (fromVariant . Variant) a7 return (a1', a2', a3', a4', a5', a6', a7') fromVariant _ = Nothing instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8) where toVariant (a1, a2, a3, a4, a5, a6, a7, a8) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8]) fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8])) = do a1' <- (fromVariant . Variant) a1 a2' <- (fromVariant . Variant) a2 a3' <- (fromVariant . Variant) a3 a4' <- (fromVariant . Variant) a4 a5' <- (fromVariant . Variant) a5 a6' <- (fromVariant . Variant) a6 a7' <- (fromVariant . Variant) a7 a8' <- (fromVariant . Variant) a8 return (a1', a2', a3', a4', a5', a6', a7', a8') fromVariant _ = Nothing instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8, IsVariant a9) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9) where toVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8, varToVal a9]) fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9])) = do a1' <- (fromVariant . Variant) a1 a2' <- (fromVariant . Variant) a2 a3' <- (fromVariant . Variant) a3 a4' <- (fromVariant . Variant) a4 a5' <- (fromVariant . Variant) a5 a6' <- (fromVariant . Variant) a6 a7' <- (fromVariant . Variant) a7 a8' <- (fromVariant . Variant) a8 a9' <- (fromVariant . Variant) a9 return (a1', a2', a3', a4', a5', a6', a7', a8', a9') fromVariant _ = Nothing instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8, IsVariant a9, IsVariant a10) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) where toVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8, varToVal a9, varToVal a10]) fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10])) = do a1' <- (fromVariant . Variant) a1 a2' <- (fromVariant . Variant) a2 a3' <- (fromVariant . Variant) a3 a4' <- (fromVariant . Variant) a4 a5' <- (fromVariant . Variant) a5 a6' <- (fromVariant . Variant) a6 a7' <- (fromVariant . Variant) a7 a8' <- (fromVariant . Variant) a8 a9' <- (fromVariant . Variant) a9 a10' <- (fromVariant . Variant) a10 return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10') fromVariant _ = Nothing instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8, IsVariant a9, IsVariant a10, IsVariant a11) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) where toVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8, varToVal a9, varToVal a10, varToVal a11]) fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11])) = do a1' <- (fromVariant . Variant) a1 a2' <- (fromVariant . Variant) a2 a3' <- (fromVariant . Variant) a3 a4' <- (fromVariant . Variant) a4 a5' <- (fromVariant . Variant) a5 a6' <- (fromVariant . Variant) a6 a7' <- (fromVariant . Variant) a7 a8' <- (fromVariant . Variant) a8 a9' <- (fromVariant . Variant) a9 a10' <- (fromVariant . Variant) a10 a11' <- (fromVariant . Variant) a11 return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11') fromVariant _ = Nothing instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8, IsVariant a9, IsVariant a10, IsVariant a11, IsVariant a12) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) where toVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8, varToVal a9, varToVal a10, varToVal a11, varToVal a12]) fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12])) = do a1' <- (fromVariant . Variant) a1 a2' <- (fromVariant . Variant) a2 a3' <- (fromVariant . Variant) a3 a4' <- (fromVariant . Variant) a4 a5' <- (fromVariant . Variant) a5 a6' <- (fromVariant . Variant) a6 a7' <- (fromVariant . Variant) a7 a8' <- (fromVariant . Variant) a8 a9' <- (fromVariant . Variant) a9 a10' <- (fromVariant . Variant) a10 a11' <- (fromVariant . Variant) a11 a12' <- (fromVariant . Variant) a12 return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12') fromVariant _ = Nothing instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8, IsVariant a9, IsVariant a10, IsVariant a11, IsVariant a12, IsVariant a13) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) where toVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8, varToVal a9, varToVal a10, varToVal a11, varToVal a12, varToVal a13]) fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13])) = do a1' <- (fromVariant . Variant) a1 a2' <- (fromVariant . Variant) a2 a3' <- (fromVariant . Variant) a3 a4' <- (fromVariant . Variant) a4 a5' <- (fromVariant . Variant) a5 a6' <- (fromVariant . Variant) a6 a7' <- (fromVariant . Variant) a7 a8' <- (fromVariant . Variant) a8 a9' <- (fromVariant . Variant) a9 a10' <- (fromVariant . Variant) a10 a11' <- (fromVariant . Variant) a11 a12' <- (fromVariant . Variant) a12 a13' <- (fromVariant . Variant) a13 return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12', a13') fromVariant _ = Nothing instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8, IsVariant a9, IsVariant a10, IsVariant a11, IsVariant a12, IsVariant a13, IsVariant a14) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) where toVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8, varToVal a9, varToVal a10, varToVal a11, varToVal a12, varToVal a13, varToVal a14]) fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14])) = do a1' <- (fromVariant . Variant) a1 a2' <- (fromVariant . Variant) a2 a3' <- (fromVariant . Variant) a3 a4' <- (fromVariant . Variant) a4 a5' <- (fromVariant . Variant) a5 a6' <- (fromVariant . Variant) a6 a7' <- (fromVariant . Variant) a7 a8' <- (fromVariant . Variant) a8 a9' <- (fromVariant . Variant) a9 a10' <- (fromVariant . Variant) a10 a11' <- (fromVariant . Variant) a11 a12' <- (fromVariant . Variant) a12 a13' <- (fromVariant . Variant) a13 a14' <- (fromVariant . Variant) a14 return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12', a13', a14') fromVariant _ = Nothing instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8, IsVariant a9, IsVariant a10, IsVariant a11, IsVariant a12, IsVariant a13, IsVariant a14, IsVariant a15) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) where toVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8, varToVal a9, varToVal a10, varToVal a11, varToVal a12, varToVal a13, varToVal a14, varToVal a15]) fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15])) = do a1' <- (fromVariant . Variant) a1 a2' <- (fromVariant . Variant) a2 a3' <- (fromVariant . Variant) a3 a4' <- (fromVariant . Variant) a4 a5' <- (fromVariant . Variant) a5 a6' <- (fromVariant . Variant) a6 a7' <- (fromVariant . Variant) a7 a8' <- (fromVariant . Variant) a8 a9' <- (fromVariant . Variant) a9 a10' <- (fromVariant . Variant) a10 a11' <- (fromVariant . Variant) a11 a12' <- (fromVariant . Variant) a12 a13' <- (fromVariant . Variant) a13 a14' <- (fromVariant . Variant) a14 a15' <- (fromVariant . Variant) a15 return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12', a13', a14', a15') fromVariant _ = Nothing -- | A value used to uniquely identify a particular message within a session. -- Serials are 32-bit unsigned integers, and eventually wrap. newtype Serial = Serial Word32 deriving (Eq, Ord, Show) instance IsVariant Serial where toVariant (Serial x) = toVariant x fromVariant = fmap Serial . fromVariant serialValue :: Serial -> Word32 serialValue (Serial x) = x -- | Get the first serial in the sequence. firstSerial :: Serial firstSerial = Serial 1 -- | Get the next serial in the sequence. This may wrap around to -- 'firstSerial'. nextSerial :: Serial -> Serial nextSerial (Serial x) = Serial (if x + 1 == 0 then 1 -- wrap to firstSerial else x + 1) skipSepBy1 :: Parsec.Parser a -> Parsec.Parser b -> Parsec.Parser () skipSepBy1 p sep = do _ <- p Parsec.skipMany (sep >> p) forceParse :: String -> (String -> Maybe a) -> String -> a forceParse label parse str = case parse str of Just x -> x Nothing -> error ("Invalid " ++ label ++ ": " ++ show str) maybeParseString :: MonadThrow m => Parsec.Parser a -> String -> m a maybeParseString parser s = case Parsec.parse parser "" s of Left err -> throwM $ userError $ show err Right a -> pure a THL.deriveLiftMany [''BusName, ''ObjectPath, ''InterfaceName, ''MemberName] dbus-1.2.29/lib/DBus/Internal/Wire.hs0000644000000000000000000006644114263302757015375 0ustar0000000000000000-- Copyright (C) 2009-2012 John Millikin -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . module DBus.Internal.Wire ( Endianness(..) , MarshalError , marshalErrorMessage , UnmarshalError , unmarshalErrorMessage , marshalMessage , unmarshalMessage , unmarshalMessageM ) where import qualified Control.Applicative import Control.Monad (ap, liftM, when, unless) import qualified Data.ByteString import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Char8 import qualified Data.ByteString.Lazy as Lazy import Data.Int (Int16, Int32, Int64) import qualified Data.Map import Data.Map (Map) import Data.Maybe (fromJust, listToMaybe, fromMaybe) import Data.Monoid import Data.Text (Text) import qualified Data.Text.Encoding import qualified Data.Vector import Data.Vector (Vector) import Data.Word (Word8, Word16, Word32, Word64) import Foreign.C.Types (CInt) import System.Posix.Types (Fd(..)) import Prelude import qualified Data.Serialize.Get as Get import Data.Serialize.IEEE754 (getFloat64be, getFloat64le, putFloat64be, putFloat64le) import Data.Serialize.Put (runPut) import DBus.Internal.Message import DBus.Internal.Types data Endianness = LittleEndian | BigEndian deriving (Show, Eq) encodeEndianness :: Endianness -> Word8 encodeEndianness LittleEndian = 0x6C encodeEndianness BigEndian = 0x42 decodeEndianness :: Word8 -> Maybe Endianness decodeEndianness 0x6C = Just LittleEndian decodeEndianness 0x42 = Just BigEndian decodeEndianness _ = Nothing alignment :: Type -> Word8 alignment TypeBoolean = 4 alignment TypeWord8 = 1 alignment TypeWord16 = 2 alignment TypeWord32 = 4 alignment TypeWord64 = 8 alignment TypeInt16 = 2 alignment TypeInt32 = 4 alignment TypeInt64 = 8 alignment TypeDouble = 8 alignment TypeUnixFd = 4 alignment TypeString = 4 alignment TypeObjectPath = 4 alignment TypeSignature = 1 alignment (TypeArray _) = 4 alignment (TypeDictionary _ _) = 4 alignment (TypeStructure _) = 8 alignment TypeVariant = 1 {-# INLINE padding #-} padding :: Word64 -> Word8 -> Word64 padding current count = required where count' = fromIntegral count missing = mod current count' required = if missing > 0 then count' - missing else 0 data WireR s a = WireRL String | WireRR a !s newtype Wire s a = Wire { unWire :: Endianness -> s -> WireR s a } instance Functor (Wire s) where {-# INLINE fmap #-} fmap = liftM instance Control.Applicative.Applicative (Wire s) where {-# INLINE pure #-} pure = return {-# INLINE (<*>) #-} (<*>) = ap instance Monad (Wire s) where {-# INLINE return #-} return a = Wire (\_ s -> WireRR a s) {-# INLINE (>>=) #-} m >>= k = Wire $ \e s -> case unWire m e s of WireRL err -> WireRL err WireRR a s' -> unWire (k a) e s' {-# INLINE (>>) #-} m >> k = Wire $ \e s -> case unWire m e s of WireRL err -> WireRL err WireRR _ s' -> unWire k e s' throwError :: String -> Wire s a throwError err = Wire (\_ _ -> WireRL err) {-# INLINE getState #-} getState :: Wire s s getState = Wire (\_ s -> WireRR s s) {-# INLINE putState #-} putState :: s -> Wire s () putState s = Wire (\_ _ -> WireRR () s) {-# INLINE chooseEndian #-} chooseEndian :: a -> a -> Wire s a chooseEndian big little = Wire (\e s -> case e of BigEndian -> WireRR big s LittleEndian -> WireRR little s) type Marshal = Wire MarshalState newtype MarshalError = MarshalError String deriving (Show, Eq) marshalErrorMessage :: MarshalError -> String marshalErrorMessage (MarshalError s) = s data MarshalState = MarshalState !Builder.Builder {-# UNPACK #-} !Word64 marshal :: Value -> Marshal () marshal (ValueAtom x) = marshalAtom x marshal (ValueBytes xs) = marshalStrictBytes xs marshal (ValueVector t xs) = marshalVector t xs marshal (ValueMap kt vt xs) = marshalMap kt vt xs marshal (ValueStructure xs) = marshalStructure xs marshal (ValueVariant x) = marshalVariant x marshalAtom :: Atom -> Marshal () marshalAtom (AtomWord8 x) = marshalWord8 x marshalAtom (AtomWord16 x) = marshalWord16 x marshalAtom (AtomWord32 x) = marshalWord32 x marshalAtom (AtomWord64 x) = marshalWord64 x marshalAtom (AtomInt16 x) = marshalInt16 x marshalAtom (AtomInt32 x) = marshalInt32 x marshalAtom (AtomInt64 x) = marshalInt64 x marshalAtom (AtomDouble x) = marshalDouble x marshalAtom (AtomUnixFd x) = marshalUnixFd x marshalAtom (AtomBool x) = marshalBool x marshalAtom (AtomText x) = marshalText x marshalAtom (AtomObjectPath x) = marshalObjectPath x marshalAtom (AtomSignature x) = marshalSignature x appendB :: Word64 -> Builder.Builder -> Marshal () appendB size bytes = Wire (\_ (MarshalState builder count) -> let builder' = mappend builder bytes count' = count + size in WireRR () (MarshalState builder' count')) appendS :: ByteString -> Marshal () appendS bytes = appendB (fromIntegral (Data.ByteString.length bytes)) (Builder.byteString bytes) appendL :: Lazy.ByteString -> Marshal () appendL bytes = appendB (fromIntegral (Lazy.length bytes)) (Builder.lazyByteString bytes) pad :: Word8 -> Marshal () pad count = do (MarshalState _ existing) <- getState let padding' = fromIntegral (padding existing count) appendS (Data.ByteString.replicate padding' 0) marshalBuilder :: Word8 -> (a -> Builder.Builder) -> (a -> Builder.Builder) -> a -> Marshal () marshalBuilder size be le x = do builder <- chooseEndian (be x) (le x) pad size appendB (fromIntegral size) builder type Unmarshal = Wire UnmarshalState newtype UnmarshalError = UnmarshalError String deriving (Show, Eq) unmarshalErrorMessage :: UnmarshalError -> String unmarshalErrorMessage (UnmarshalError s) = s data UnmarshalState = UnmarshalState {-# UNPACK #-} !ByteString {-# UNPACK #-} !Word64 unmarshal :: Type -> Unmarshal Value unmarshal TypeWord8 = liftM toValue unmarshalWord8 unmarshal TypeWord16 = liftM toValue unmarshalWord16 unmarshal TypeWord32 = liftM toValue unmarshalWord32 unmarshal TypeWord64 = liftM toValue unmarshalWord64 unmarshal TypeInt16 = liftM toValue unmarshalInt16 unmarshal TypeInt32 = liftM toValue unmarshalInt32 unmarshal TypeInt64 = liftM toValue unmarshalInt64 unmarshal TypeDouble = liftM toValue unmarshalDouble unmarshal TypeUnixFd = liftM toValue unmarshalUnixFd unmarshal TypeBoolean = liftM toValue unmarshalBool unmarshal TypeString = liftM toValue unmarshalText unmarshal TypeObjectPath = liftM toValue unmarshalObjectPath unmarshal TypeSignature = liftM toValue unmarshalSignature unmarshal (TypeArray TypeWord8) = liftM toValue unmarshalByteArray unmarshal (TypeArray t) = liftM (ValueVector t) (unmarshalArray t) unmarshal (TypeDictionary kt vt) = unmarshalDictionary kt vt unmarshal (TypeStructure ts) = unmarshalStructure ts unmarshal TypeVariant = unmarshalVariant {-# INLINE consume #-} consume :: Word64 -> Unmarshal ByteString consume count = do (UnmarshalState bytes offset) <- getState let count' = fromIntegral count let (x, bytes') = Data.ByteString.splitAt count' bytes let lenConsumed = Data.ByteString.length x if lenConsumed == count' then do putState (UnmarshalState bytes' (offset + count)) return x else throwError ("Unexpected EOF at offset " ++ show (offset + fromIntegral lenConsumed)) skipPadding :: Word8 -> Unmarshal () skipPadding count = do (UnmarshalState _ offset) <- getState bytes <- consume (padding offset count) unless (Data.ByteString.all (== 0) bytes) (throwError ("Value padding " ++ show bytes ++ " contains invalid bytes.")) skipTerminator :: Unmarshal () skipTerminator = do byte <- unmarshalWord8 when (byte /= 0) (throwError "Textual value is not NUL-terminated.") fromMaybeU :: Show a => String -> (a -> Maybe b) -> a -> Unmarshal b fromMaybeU label f x = case f x of Just x' -> return x' Nothing -> throwError ("Invalid " ++ label ++ ": " ++ show x) unmarshalGet :: Word8 -> Get.Get a -> Get.Get a -> Unmarshal a unmarshalGet count be le = do skipPadding count bytes <- consume (fromIntegral count) get <- chooseEndian be le let Right ret = Get.runGet get bytes return ret marshalWord8 :: Word8 -> Marshal () marshalWord8 x = appendB 1 (Builder.word8 x) unmarshalWord8 :: Unmarshal Word8 unmarshalWord8 = liftM Data.ByteString.head (consume 1) marshalWord16 :: Word16 -> Marshal () marshalWord16 = marshalBuilder 2 Builder.word16BE Builder.word16LE marshalWord32 :: Word32 -> Marshal () marshalWord32 = marshalBuilder 4 Builder.word32BE Builder.word32LE marshalWord64 :: Word64 -> Marshal () marshalWord64 = marshalBuilder 8 Builder.word64BE Builder.word64LE marshalInt16 :: Int16 -> Marshal () marshalInt16 = marshalWord16 . fromIntegral marshalInt32 :: Int32 -> Marshal () marshalInt32 = marshalWord32 . fromIntegral marshalInt64 :: Int64 -> Marshal () marshalInt64 = marshalWord64 . fromIntegral unmarshalWord16 :: Unmarshal Word16 unmarshalWord16 = unmarshalGet 2 Get.getWord16be Get.getWord16le unmarshalWord32 :: Unmarshal Word32 unmarshalWord32 = unmarshalGet 4 Get.getWord32be Get.getWord32le unmarshalWord64 :: Unmarshal Word64 unmarshalWord64 = unmarshalGet 8 Get.getWord64be Get.getWord64le unmarshalInt16 :: Unmarshal Int16 unmarshalInt16 = liftM fromIntegral unmarshalWord16 unmarshalInt32 :: Unmarshal Int32 unmarshalInt32 = liftM fromIntegral unmarshalWord32 unmarshalInt64 :: Unmarshal Int64 unmarshalInt64 = liftM fromIntegral unmarshalWord64 marshalDouble :: Double -> Marshal () marshalDouble x = do put <- chooseEndian putFloat64be putFloat64le pad 8 appendS (runPut (put x)) unmarshalDouble :: Unmarshal Double unmarshalDouble = unmarshalGet 8 getFloat64be getFloat64le marshalUnixFd :: Fd -> Marshal () marshalUnixFd (Fd x) | x < 0 = throwError ("Invalid file descriptor: " ++ show x) | toInteger x > toInteger (maxBound :: Word32) = throwError ("D-Bus forbids file descriptors exceeding UINT32_MAX: " ++ show x) | otherwise = marshalWord32 (fromIntegral x) unmarshalUnixFd :: Unmarshal Fd unmarshalUnixFd = do x <- unmarshalWord32 when (toInteger x > toInteger (maxBound :: CInt)) (throwError ("Invalid file descriptor: " ++ show x)) return (Fd (fromIntegral x)) marshalBool :: Bool -> Marshal () marshalBool False = marshalWord32 0 marshalBool True = marshalWord32 1 unmarshalBool :: Unmarshal Bool unmarshalBool = do word <- unmarshalWord32 case word of 0 -> return False 1 -> return True _ -> throwError ("Invalid boolean: " ++ show word) marshalText :: Text -> Marshal () marshalText text = do let bytes = Data.Text.Encoding.encodeUtf8 text when (Data.ByteString.any (== 0) bytes) (throwError ("String " ++ show text ++ " contained forbidden character: '\\x00'")) marshalWord32 (fromIntegral (Data.ByteString.length bytes)) appendS bytes marshalWord8 0 unmarshalText :: Unmarshal Text unmarshalText = do byteCount <- unmarshalWord32 bytes <- consume (fromIntegral byteCount) skipTerminator fromMaybeU "text" maybeDecodeUtf8 bytes maybeDecodeUtf8 :: ByteString -> Maybe Text maybeDecodeUtf8 bs = case Data.Text.Encoding.decodeUtf8' bs of Right text -> Just text _ -> Nothing marshalObjectPath :: ObjectPath -> Marshal () marshalObjectPath p = do let bytes = Data.ByteString.Char8.pack (formatObjectPath p) marshalWord32 (fromIntegral (Data.ByteString.length bytes)) appendS bytes marshalWord8 0 unmarshalObjectPath :: Unmarshal ObjectPath unmarshalObjectPath = do byteCount <- unmarshalWord32 bytes <- consume (fromIntegral byteCount) skipTerminator fromMaybeU "object path" parseObjectPath (Data.ByteString.Char8.unpack bytes) signatureBytes :: Signature -> ByteString signatureBytes (Signature ts) = Data.ByteString.Char8.pack (concatMap typeCode ts) marshalSignature :: Signature -> Marshal () marshalSignature x = do let bytes = signatureBytes x marshalWord8 (fromIntegral (Data.ByteString.length bytes)) appendS bytes marshalWord8 0 unmarshalSignature :: Unmarshal Signature unmarshalSignature = do byteCount <- unmarshalWord8 bytes <- consume (fromIntegral byteCount) skipTerminator fromMaybeU "signature" parseSignatureBytes bytes arrayMaximumLength :: Int64 arrayMaximumLength = 67108864 marshalVector :: Type -> Vector Value -> Marshal () marshalVector t x = do (arrayPadding, arrayBytes) <- getArrayBytes t x let arrayLen = Lazy.length arrayBytes when (arrayLen > arrayMaximumLength) (throwError ("Marshaled array size (" ++ show arrayLen ++ " bytes) exceeds maximum limit of (" ++ show arrayMaximumLength ++ " bytes).")) marshalWord32 (fromIntegral arrayLen) appendS (Data.ByteString.replicate arrayPadding 0) appendL arrayBytes marshalStrictBytes :: ByteString -> Marshal () marshalStrictBytes bytes = do let arrayLen = Lazy.length (Lazy.fromStrict bytes) when (fromIntegral arrayLen > arrayMaximumLength) (throwError ("Marshaled array size (" ++ show arrayLen ++ " bytes) exceeds maximum limit of (" ++ show arrayMaximumLength ++ " bytes).")) marshalWord32 (fromIntegral arrayLen) appendS bytes getArrayBytes :: Type -> Vector Value -> Marshal (Int, Lazy.ByteString) getArrayBytes itemType vs = do s <- getState (MarshalState _ afterLength) <- marshalWord32 0 >> getState (MarshalState _ afterPadding) <- pad (alignment itemType) >> getState putState (MarshalState mempty afterPadding) (MarshalState itemBuilder _) <- Data.Vector.mapM_ marshal vs >> getState let itemBytes = Builder.toLazyByteString itemBuilder paddingSize = fromIntegral (afterPadding - afterLength) putState s return (paddingSize, itemBytes) unmarshalByteArray :: Unmarshal ByteString unmarshalByteArray = do byteCount <- unmarshalWord32 consume (fromIntegral byteCount) unmarshalArray :: Type -> Unmarshal (Vector Value) unmarshalArray itemType = do let getOffset = do (UnmarshalState _ o) <- getState return o byteCount <- unmarshalWord32 skipPadding (alignment itemType) start <- getOffset let end = start + fromIntegral byteCount vs <- untilM (liftM (>= end) getOffset) (unmarshal itemType) end' <- getOffset when (end' > end) (throwError ("Array data size exeeds array size of " ++ show end)) return (Data.Vector.fromList vs) dictionaryToArray :: Map Atom Value -> Vector Value dictionaryToArray = Data.Vector.fromList . map step . Data.Map.toList where step (k, v) = ValueStructure [ValueAtom k, v] arrayToDictionary :: Vector Value -> Map Atom Value arrayToDictionary = Data.Map.fromList . map step . Data.Vector.toList where step (ValueStructure [ValueAtom k, v]) = (k, v) step _ = error "arrayToDictionary: internal error" marshalMap :: Type -> Type -> Map Atom Value -> Marshal () marshalMap kt vt x = let structType = TypeStructure [kt, vt] array = dictionaryToArray x in marshalVector structType array unmarshalDictionary :: Type -> Type -> Unmarshal Value unmarshalDictionary kt vt = do let pairType = TypeStructure [kt, vt] array <- unmarshalArray pairType return (ValueMap kt vt (arrayToDictionary array)) marshalStructure :: [Value] -> Marshal () marshalStructure vs = do pad 8 mapM_ marshal vs unmarshalStructure :: [Type] -> Unmarshal Value unmarshalStructure ts = do skipPadding 8 liftM ValueStructure (mapM unmarshal ts) marshalVariant :: Variant -> Marshal () marshalVariant var@(Variant val) = do sig <- case signature [valueType val] of Just x' -> return x' Nothing -> throwError ("Signature " ++ show (typeCode (valueType val)) ++ " for variant " ++ show var ++ " is malformed or too large.") marshalSignature sig marshal val unmarshalVariant :: Unmarshal Value unmarshalVariant = do let getType sig = case signatureTypes sig of [t] -> Just t _ -> Nothing t <- fromMaybeU "variant signature" getType =<< unmarshalSignature (toValue . Variant) `liftM` unmarshal t protocolVersion :: Word8 protocolVersion = 1 messageMaximumLength :: Integer messageMaximumLength = 134217728 encodeField :: HeaderField -> Value encodeField (HeaderPath x) = encodeField' 1 x encodeField (HeaderInterface x) = encodeField' 2 x encodeField (HeaderMember x) = encodeField' 3 x encodeField (HeaderErrorName x) = encodeField' 4 x encodeField (HeaderReplySerial x) = encodeField' 5 x encodeField (HeaderDestination x) = encodeField' 6 x encodeField (HeaderSender x) = encodeField' 7 x encodeField (HeaderSignature x) = encodeField' 8 x encodeField (HeaderUnixFds x) = encodeField' 9 x encodeField' :: IsVariant a => Word8 -> a -> Value encodeField' code x = toValue (code, toVariant x) decodeField :: (Word8, Variant) -> ErrorM UnmarshalError [HeaderField] decodeField struct = case struct of (1, x) -> decodeField' x HeaderPath "path" (2, x) -> decodeField' x HeaderInterface "interface" (3, x) -> decodeField' x HeaderMember "member" (4, x) -> decodeField' x HeaderErrorName "error name" (5, x) -> decodeField' x HeaderReplySerial "reply serial" (6, x) -> decodeField' x HeaderDestination "destination" (7, x) -> decodeField' x HeaderSender "sender" (8, x) -> decodeField' x HeaderSignature "signature" (9, x) -> decodeField' x HeaderUnixFds "unix fds" _ -> return [] decodeField' :: IsVariant a => Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b] decodeField' x f label = case fromVariant x of Just x' -> return [f x'] Nothing -> throwErrorM (UnmarshalError ("Header field " ++ show label ++ " contains invalid value " ++ show x)) marshalMessage :: Message a => Endianness -> Serial -> a -> Either MarshalError ByteString marshalMessage e serial msg = runMarshal where body = messageBody msg marshaler = do sig <- checkBodySig body empty <- getState mapM_ (marshal . (\(Variant x) -> x)) body (MarshalState bodyBytesB _) <- getState putState empty marshal (toValue (encodeEndianness e)) let bodyBytes = Builder.toLazyByteString bodyBytesB marshalHeader msg serial sig (fromIntegral (Lazy.length bodyBytes)) pad 8 appendL bodyBytes checkMaximumSize emptyState = MarshalState mempty 0 runMarshal = case unWire marshaler e emptyState of WireRL err -> Left (MarshalError err) WireRR _ (MarshalState builder _) -> Right (Lazy.toStrict (Builder.toLazyByteString builder)) checkBodySig :: [Variant] -> Marshal Signature checkBodySig vs = case signature (map variantType vs) of Just x -> return x Nothing -> throwError ("Message body " ++ show vs ++ " has too many items") marshalHeader :: Message a => a -> Serial -> Signature -> Word32 -> Marshal () marshalHeader msg serial bodySig bodyLength = do let fields = HeaderSignature bodySig : messageHeaderFields msg marshalWord8 (messageTypeCode msg) marshalWord8 (messageFlags msg) marshalWord8 protocolVersion marshalWord32 bodyLength marshalWord32 (serialValue serial) let fieldType = TypeStructure [TypeWord8, TypeVariant] marshalVector fieldType (Data.Vector.fromList (map encodeField fields)) checkMaximumSize :: Marshal () checkMaximumSize = do (MarshalState _ messageLength) <- getState when (toInteger messageLength > messageMaximumLength) (throwError ("Marshaled message size (" ++ show messageLength ++ " bytes) exeeds maximum limit of (" ++ show messageMaximumLength ++ " bytes).")) unmarshalMessageM :: Monad m => (Int -> m ByteString) -> m (Either UnmarshalError ReceivedMessage) unmarshalMessageM getBytes' = runErrorT $ do let getBytes count = do bytes <- ErrorT (liftM Right (getBytes' count)) if Data.ByteString.length bytes < count then throwErrorT (UnmarshalError "Unexpected end of input while parsing message header.") else return bytes let Just fixedSig = parseSignature "yyyyuuu" fixedBytes <- getBytes 16 let messageVersion = Data.ByteString.index fixedBytes 3 when (messageVersion /= protocolVersion) (throwErrorT (UnmarshalError ("Unsupported protocol version: " ++ show messageVersion))) let eByte = Data.ByteString.index fixedBytes 0 endianness <- case decodeEndianness eByte of Just x' -> return x' Nothing -> throwErrorT (UnmarshalError ("Invalid endianness: " ++ show eByte)) let unmarshalSig = mapM unmarshal . signatureTypes let unmarshal' x bytes = case unWire (unmarshalSig x) endianness (UnmarshalState bytes 0) of WireRR x' _ -> return x' WireRL err -> throwErrorT (UnmarshalError err) fixed <- unmarshal' fixedSig fixedBytes let messageType = fromJust (fromValue (fixed !! 1)) let flags = fromJust (fromValue (fixed !! 2)) let bodyLength = fromJust (fromValue (fixed !! 4)) :: Word32 let serial = fromJust (fromVariant (Variant (fixed !! 5))) let fieldByteCount = fromJust (fromValue (fixed !! 6)) :: Word32 let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 -- Forbid messages larger than 'messageMaximumLength' let messageLength = 16 + toInteger fieldByteCount + toInteger bodyPadding + toInteger bodyLength when (messageLength > messageMaximumLength) $ throwErrorT (UnmarshalError ("Message size " ++ show messageLength ++ " exceeds limit of " ++ show messageMaximumLength)) let Just headerSig = parseSignature "yyyyuua(yv)" fieldBytes <- getBytes (fromIntegral fieldByteCount) let headerBytes = Data.ByteString.append fixedBytes fieldBytes header <- unmarshal' headerSig headerBytes let fieldArray = Data.Vector.toList (fromJust (fromValue (header !! 6))) fields <- case runErrorM $ concat `liftM` mapM decodeField fieldArray of Left err -> throwErrorT err Right x -> return x _ <- getBytes (fromIntegral bodyPadding) let bodySig = findBodySignature fields bodyBytes <- getBytes (fromIntegral bodyLength) body <- unmarshal' bodySig bodyBytes y <- case runErrorM (buildReceivedMessage messageType fields) of Right x -> return x Left err -> throwErrorT (UnmarshalError ("Header field " ++ show err ++ " is required, but missing")) return (y serial flags (map Variant body)) findBodySignature :: [HeaderField] -> Signature findBodySignature fields = fromMaybe (signature_ []) (listToMaybe [x | HeaderSignature x <- fields]) buildReceivedMessage :: Word8 -> [HeaderField] -> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage) buildReceivedMessage 1 fields = do path <- require "path" [x | HeaderPath x <- fields] member <- require "member name" [x | HeaderMember x <- fields] return $ \serial flags body -> let iface = listToMaybe [x | HeaderInterface x <- fields] dest = listToMaybe [x | HeaderDestination x <- fields] sender = listToMaybe [x | HeaderSender x <- fields] msg = MethodCall path iface member sender dest True True body in ReceivedMethodCall serial (setMethodCallFlags msg flags) buildReceivedMessage 2 fields = do replySerial <- require "reply serial" [x | HeaderReplySerial x <- fields] return $ \serial _ body -> let dest = listToMaybe [x | HeaderDestination x <- fields] sender = listToMaybe [x | HeaderSender x <- fields] msg = MethodReturn replySerial sender dest body in ReceivedMethodReturn serial msg buildReceivedMessage 3 fields = do name <- require "error name" [x | HeaderErrorName x <- fields] replySerial <- require "reply serial" [x | HeaderReplySerial x <- fields] return $ \serial _ body -> let dest = listToMaybe [x | HeaderDestination x <- fields] sender = listToMaybe [x | HeaderSender x <- fields] msg = MethodError name replySerial sender dest body in ReceivedMethodError serial msg buildReceivedMessage 4 fields = do path <- require "path" [x | HeaderPath x <- fields] member <- require "member name" [x | HeaderMember x <- fields] iface <- require "interface" [x | HeaderInterface x <- fields] return $ \serial _ body -> let dest = listToMaybe [x | HeaderDestination x <- fields] sender = listToMaybe [x | HeaderSender x <- fields] msg = Signal path iface member sender dest body in ReceivedSignal serial msg buildReceivedMessage messageType fields = return $ \serial _ body -> let sender = listToMaybe [x | HeaderSender x <- fields] msg = UnknownMessage messageType sender body in ReceivedUnknown serial msg require :: String -> [a] -> ErrorM String a require _ (x:_) = return x require label _ = throwErrorM label unmarshalMessage :: ByteString -> Either UnmarshalError ReceivedMessage unmarshalMessage bytes = checkError (Get.runGet get bytes) where get = unmarshalMessageM getBytes -- wrap getByteString, so it will behave like transportGet and return -- a truncated result on EOF instead of throwing an exception. getBytes count = do remaining <- Get.remaining Get.getByteString (min remaining count) checkError (Left err) = Left (UnmarshalError err) checkError (Right x) = x untilM :: Monad m => m Bool -> m a -> m [a] untilM test comp = do done <- test if done then return [] else do x <- comp xs <- untilM test comp return (x:xs) ------------------------------------------------------------------------------- -- local ErrorT and MonadError, which don't have the silly Error => dependency -- found in the "transformers" package. ------------------------------------------------------------------------------- newtype ErrorM e a = ErrorM { runErrorM :: Either e a } instance Functor (ErrorM e) where fmap f m = ErrorM $ case runErrorM m of Left err -> Left err Right x -> Right (f x) instance Control.Applicative.Applicative (ErrorM e) where pure = return (<*>) = ap instance Monad (ErrorM e) where return = ErrorM . Right (>>=) m k = case runErrorM m of Left err -> ErrorM (Left err) Right x -> k x throwErrorM :: e -> ErrorM e a throwErrorM = ErrorM . Left newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } instance Monad m => Functor (ErrorT e m) where fmap = liftM instance Monad m => Control.Applicative.Applicative (ErrorT e m) where pure = return (<*>) = ap instance Monad m => Monad (ErrorT e m) where return = ErrorT . return . Right (>>=) m k = ErrorT $ do x <- runErrorT m case x of Left l -> return (Left l) Right r -> runErrorT (k r) throwErrorT :: Monad m => e -> ErrorT e m a throwErrorT = ErrorT . return . Left dbus-1.2.29/lib/DBus/Introspection.hs0000644000000000000000000000024614263302757015542 0ustar0000000000000000module DBus.Introspection ( module X ) where import DBus.Introspection.Types as X import DBus.Introspection.Parse as X import DBus.Introspection.Render as X dbus-1.2.29/lib/DBus/Introspection/Parse.hs0000644000000000000000000001175614351135773016624 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module DBus.Introspection.Parse ( parseXML ) where import Conduit import Data.Maybe import Data.XML.Types import qualified Data.Text as T import qualified Text.XML.Stream.Parse as X import DBus.Internal.Types import DBus.Introspection.Types data ObjectChildren = InterfaceDefinition Interface | SubNode Object data InterfaceChildren = MethodDefinition Method | SignalDefinition Signal | PropertyDefinition Property parseXML :: ObjectPath -> T.Text -> Maybe Object parseXML path xml = runConduit $ yieldMany [xml] .| X.parseText X.def .| X.force "parse error" (parseObject $ getRootName path) getRootName :: ObjectPath -> X.AttrParser ObjectPath getRootName defaultPath = do nodeName <- X.attr "name" pure $ maybe defaultPath (objectPath_ . T.unpack) nodeName getChildName :: ObjectPath -> X.AttrParser ObjectPath getChildName parentPath = do nodeName <- X.requireAttr "name" let parentPath' = case formatObjectPath parentPath of "/" -> "/" x -> x ++ "/" pure $ objectPath_ (parentPath' ++ T.unpack nodeName) parseObject :: X.AttrParser ObjectPath -> ConduitT Event o Maybe (Maybe Object) parseObject getPath = X.tag' "node" getPath parseContent where parseContent objPath = do elems <- X.many $ X.choose [ fmap SubNode <$> parseObject (getChildName objPath) , fmap InterfaceDefinition <$> parseInterface ] let base = Object objPath [] [] addElem e (Object p is cs) = case e of InterfaceDefinition i -> Object p (i:is) cs SubNode c -> Object p is (c:cs) pure $ foldr addElem base elems parseInterface :: ConduitT Event o Maybe (Maybe Interface) parseInterface = X.tag' "interface" getName parseContent where getName = do ifName <- X.requireAttr "name" pure $ interfaceName_ (T.unpack ifName) parseContent ifName = do elems <- X.many $ do X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs X.choose [ parseMethod , parseSignal , parseProperty ] X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs let base = Interface ifName [] [] [] addElem e (Interface n ms ss ps) = case e of MethodDefinition m -> Interface n (m:ms) ss ps SignalDefinition s -> Interface n ms (s:ss) ps PropertyDefinition p -> Interface n ms ss (p:ps) pure $ foldr addElem base elems parseMethod :: ConduitT Event o Maybe (Maybe InterfaceChildren) parseMethod = X.tag' "method" getName parseArgs where getName = do ifName <- X.requireAttr "name" parseMemberName (T.unpack ifName) parseArgs name = do args <- X.many $ do X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs X.tag' "arg" getArg pure X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs pure $ MethodDefinition $ Method name args getArg = do name <- fromMaybe "" <$> X.attr "name" typeStr <- X.requireAttr "type" dirStr <- fromMaybe "in" <$> X.attr "direction" X.ignoreAttrs typ <- parseType typeStr let dir = if dirStr == "in" then In else Out pure $ MethodArg (T.unpack name) typ dir parseSignal :: ConduitT Event o Maybe (Maybe InterfaceChildren) parseSignal = X.tag' "signal" getName parseArgs where getName = do ifName <- X.requireAttr "name" parseMemberName (T.unpack ifName) parseArgs name = do args <- X.many $ do X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs X.tag' "arg" getArg pure X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs pure $ SignalDefinition $ Signal name args getArg = do name <- fromMaybe "" <$> X.attr "name" typeStr <- X.requireAttr "type" X.ignoreAttrs typ <- parseType typeStr pure $ SignalArg (T.unpack name) typ parseProperty :: ConduitT Event o Maybe (Maybe InterfaceChildren) parseProperty = X.tag' "property" getProp $ \p -> do X.many_ X.ignoreAnyTreeContent pure p where getProp = do name <- T.unpack <$> X.requireAttr "name" typeStr <- X.requireAttr "type" accessStr <- fromMaybe "" <$> X.attr "access" X.ignoreAttrs typ <- parseType typeStr (canRead, canWrite) <- case accessStr of "" -> pure (False, False) "read" -> pure (True, False) "write" -> pure (False, True) "readwrite" -> pure (True, True) _ -> throwM $ userError "invalid access value" pure $ PropertyDefinition $ Property name typ canRead canWrite parseType :: MonadThrow m => T.Text -> m Type parseType typeStr = do typ <- parseSignature (T.unpack typeStr) case signatureTypes typ of [t] -> pure t _ -> throwM $ userError "invalid type sig" dbus-1.2.29/lib/DBus/Introspection/Render.hs0000644000000000000000000000772614263302757016773 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} module DBus.Introspection.Render ( formatXML ) where import Conduit import Control.Monad.ST import Control.Monad.Trans.Maybe import Data.List (isPrefixOf) import Data.Monoid ((<>)) import Data.XML.Types (Event) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Text.XML.Stream.Render as R import DBus.Internal.Types import DBus.Introspection.Types newtype Render s a = Render { runRender :: MaybeT (ST s) a } deriving instance Functor (Render s) deriving instance Applicative (Render s) deriving instance Monad (Render s) instance MonadThrow (Render s) where throwM _ = Render $ MaybeT $ pure Nothing instance PrimMonad (Render s) where type PrimState (Render s) = s primitive f = Render $ lift $ primitive f formatXML :: Object -> Maybe String formatXML obj = do xml <- runST $ runMaybeT $ runRender $ runConduit $ renderRoot obj .| R.renderText (R.def {R.rsPretty = True}) .| sinkLazy pure $ TL.unpack xml renderRoot :: MonadThrow m => Object -> ConduitT i Event m () renderRoot obj = renderObject (formatObjectPath $ objectPath obj) obj renderObject :: MonadThrow m => String -> Object -> ConduitT i Event m () renderObject path Object{..} = R.tag "node" (R.attr "name" (T.pack path)) $ do mapM_ renderInterface objectInterfaces mapM_ (renderChild objectPath) objectChildren renderChild :: MonadThrow m => ObjectPath -> Object -> ConduitT i Event m () renderChild parentPath obj | not (parent' `isPrefixOf` path') = throwM $ userError "invalid child path" | parent' == "/" = renderObject (drop 1 path') obj | otherwise = renderObject (drop (length parent' + 1) path') obj where path' = formatObjectPath (objectPath obj) parent' = formatObjectPath parentPath renderInterface :: MonadThrow m => Interface -> ConduitT i Event m () renderInterface Interface{..} = R.tag "interface" (R.attr "name" $ T.pack $ formatInterfaceName interfaceName) $ do mapM_ renderMethod interfaceMethods mapM_ renderSignal interfaceSignals mapM_ renderProperty interfaceProperties renderMethod :: MonadThrow m => Method -> ConduitT i Event m () renderMethod Method{..} = R.tag "method" (R.attr "name" $ T.pack $ formatMemberName methodName) $ mapM_ renderMethodArg methodArgs renderMethodArg :: MonadThrow m => MethodArg -> ConduitT i Event m () renderMethodArg MethodArg{..} = do typeStr <- formatType methodArgType let typeAttr = R.attr "type" $ T.pack typeStr nameAttr = R.attr "name" $ T.pack methodArgName dirAttr = R.attr "direction" $ case methodArgDirection of In -> "in" Out -> "out" R.tag "arg" (nameAttr <> typeAttr <> dirAttr) $ pure () renderSignal :: MonadThrow m => Signal -> ConduitT i Event m () renderSignal Signal{..} = R.tag "signal" (R.attr "name" $ T.pack $ formatMemberName signalName) $ mapM_ renderSignalArg signalArgs renderSignalArg :: MonadThrow m => SignalArg -> ConduitT i Event m () renderSignalArg SignalArg{..} = do typeStr <- formatType signalArgType let typeAttr = R.attr "type" $ T.pack typeStr nameAttr = R.attr "name" $ T.pack signalArgName R.tag "arg" (nameAttr <> typeAttr) $ pure () renderProperty :: MonadThrow m => Property -> ConduitT i Event m () renderProperty Property{..} = do typeStr <- formatType propertyType let readStr = if propertyRead then "read" else "" writeStr = if propertyWrite then "write" else "" typeAttr = R.attr "type" $ T.pack typeStr nameAttr = R.attr "name" $ T.pack propertyName accessAttr = R.attr "access" $ T.pack (readStr ++ writeStr) R.tag "property" (nameAttr <> typeAttr <> accessAttr) $ pure () formatType :: MonadThrow f => Type -> f String formatType t = formatSignature <$> signature [t] dbus-1.2.29/lib/DBus/Introspection/Types.hs0000644000000000000000000000220514263302757016643 0ustar0000000000000000module DBus.Introspection.Types where import qualified DBus as T data Object = Object { objectPath :: T.ObjectPath , objectInterfaces :: [Interface] , objectChildren :: [Object] } deriving (Show, Eq) data Interface = Interface { interfaceName :: T.InterfaceName , interfaceMethods :: [Method] , interfaceSignals :: [Signal] , interfaceProperties :: [Property] } deriving (Show, Eq) data Method = Method { methodName :: T.MemberName , methodArgs :: [MethodArg] } deriving (Show, Eq) data MethodArg = MethodArg { methodArgName :: String , methodArgType :: T.Type , methodArgDirection :: Direction } deriving (Show, Eq) data Direction = In | Out deriving (Show, Eq) data Signal = Signal { signalName :: T.MemberName , signalArgs :: [SignalArg] } deriving (Show, Eq) data SignalArg = SignalArg { signalArgName :: String , signalArgType :: T.Type } deriving (Show, Eq) data Property = Property { propertyName :: String , propertyType :: T.Type , propertyRead :: Bool , propertyWrite :: Bool } deriving (Show, Eq) dbus-1.2.29/lib/DBus/Socket.hs0000644000000000000000000003374014263302757014137 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeFamilies #-} -- Copyright (C) 2009-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. -- | D-Bus sockets are used for communication between two peers. In this model, -- there is no \"bus\" or \"client\", simply two endpoints sending messages. -- -- Most users will want to use the "DBus.Client" module instead. module DBus.Socket ( -- * Sockets Socket , send , receive -- * Socket errors , SocketError , socketError , socketErrorMessage , socketErrorFatal , socketErrorAddress -- * Socket options , SocketOptions , socketAuthenticator , socketTransportOptions , defaultSocketOptions -- * Opening and closing sockets , open , openWith , close -- * Listening for connections , SocketListener , listen , listenWith , accept , closeListener , socketListenerAddress -- * Authentication , Authenticator , authenticator , authenticatorClient , authenticatorServer ) where import Prelude hiding (getLine) import Control.Concurrent import Control.Exception import Control.Monad (mplus) import qualified Data.ByteString import qualified Data.ByteString.Char8 as Char8 import Data.Char (ord) import Data.IORef import Data.List (isPrefixOf) import Data.Typeable (Typeable) import qualified System.Posix.User import Text.Printf (printf) import DBus import DBus.Transport import DBus.Internal.Wire (unmarshalMessageM) -- | Stores information about an error encountered while creating or using a -- 'Socket'. data SocketError = SocketError { socketErrorMessage :: String , socketErrorFatal :: Bool , socketErrorAddress :: Maybe Address } deriving (Eq, Show, Typeable) instance Exception SocketError socketError :: String -> SocketError socketError msg = SocketError msg True Nothing data SomeTransport = forall t. (Transport t) => SomeTransport t instance Transport SomeTransport where data TransportOptions SomeTransport = SomeTransportOptions transportDefaultOptions = SomeTransportOptions transportPut (SomeTransport t) = transportPut t transportGet (SomeTransport t) = transportGet t transportClose (SomeTransport t) = transportClose t -- | An open socket to another process. Messages can be sent to the remote -- peer using 'send', or received using 'receive'. data Socket = Socket { socketTransport :: SomeTransport , socketAddress :: Maybe Address , socketSerial :: IORef Serial , socketReadLock :: MVar () , socketWriteLock :: MVar () } -- | An Authenticator defines how the local peer (client) authenticates -- itself to the remote peer (server). data Authenticator t = Authenticator { -- | Defines the client-side half of an authenticator. authenticatorClient :: t -> IO Bool -- | Defines the server-side half of an authenticator. The UUID is -- allocated by the socket listener. , authenticatorServer :: t -> UUID -> IO Bool } -- | Used with 'openWith' and 'listenWith' to provide custom authenticators or -- transport options. data SocketOptions t = SocketOptions { -- | Used to perform authentication with the remote peer. After a -- transport has been opened, it will be passed to the authenticator. -- If the authenticator returns true, then the socket was -- authenticated. socketAuthenticator :: Authenticator t -- | Options for the underlying transport, to be used by custom transports -- for controlling how to connect to the remote peer. -- -- See "DBus.Transport" for details on defining custom transports , socketTransportOptions :: TransportOptions t } -- | Default 'SocketOptions', which uses the default Unix/TCP transport and -- authenticator. defaultSocketOptions :: SocketOptions SocketTransport defaultSocketOptions = SocketOptions { socketTransportOptions = transportDefaultOptions , socketAuthenticator = authExternal } -- | Open a socket to a remote peer listening at the given address. -- -- @ --open = 'openWith' 'defaultSocketOptions' -- @ -- -- Throws 'SocketError' on failure. open :: Address -> IO Socket open = openWith defaultSocketOptions -- | Open a socket to a remote peer listening at the given address. -- -- Most users should use 'open'. This function is for users who need to define -- custom authenticators or transports. -- -- Throws 'SocketError' on failure. openWith :: TransportOpen t => SocketOptions t -> Address -> IO Socket openWith opts addr = toSocketError (Just addr) $ bracketOnError (transportOpen (socketTransportOptions opts) addr) transportClose (\t -> do authed <- authenticatorClient (socketAuthenticator opts) t if not authed then throwIO (socketError "Authentication failed") { socketErrorAddress = Just addr } else do serial <- newIORef firstSerial readLock <- newMVar () writeLock <- newMVar () return (Socket (SomeTransport t) (Just addr) serial readLock writeLock)) data SocketListener = forall t. (TransportListen t) => SocketListener (TransportListener t) (Authenticator t) -- | Begin listening at the given address. -- -- Use 'accept' to create sockets from incoming connections. -- -- Use 'closeListener' to stop listening, and to free underlying transport -- resources such as file descriptors. -- -- Throws 'SocketError' on failure. listen :: Address -> IO SocketListener listen = listenWith defaultSocketOptions -- | Begin listening at the given address. -- -- Use 'accept' to create sockets from incoming connections. -- -- Use 'closeListener' to stop listening, and to free underlying transport -- resources such as file descriptors. -- -- This function is for users who need to define custom authenticators -- or transports. -- -- Throws 'SocketError' on failure. listenWith :: TransportListen t => SocketOptions t -> Address -> IO SocketListener listenWith opts addr = toSocketError (Just addr) $ bracketOnError (transportListen (socketTransportOptions opts) addr) transportListenerClose (\l -> return (SocketListener l (socketAuthenticator opts))) -- | Accept a new connection from a socket listener. -- -- Throws 'SocketError' on failure. accept :: SocketListener -> IO Socket accept (SocketListener l auth) = toSocketError Nothing $ bracketOnError (transportAccept l) transportClose (\t -> do let uuid = transportListenerUUID l authed <- authenticatorServer auth t uuid if not authed then throwIO (socketError "Authentication failed") else do serial <- newIORef firstSerial readLock <- newMVar () writeLock <- newMVar () return (Socket (SomeTransport t) Nothing serial readLock writeLock)) -- | Close an open 'Socket'. Once closed, the socket is no longer valid and -- must not be used. close :: Socket -> IO () close = transportClose . socketTransport -- | Close an open 'SocketListener'. Once closed, the listener is no longer -- valid and must not be used. closeListener :: SocketListener -> IO () closeListener (SocketListener l _) = transportListenerClose l -- | Get the address to use to connect to a listener. socketListenerAddress :: SocketListener -> Address socketListenerAddress (SocketListener l _) = transportListenerAddress l -- | Send a single message, with a generated 'Serial'. The second parameter -- exists to prevent race conditions when registering a reply handler; it -- receives the serial the message /will/ be sent with, before it's -- actually sent. -- -- Sockets are thread-safe. Only one message may be sent at a time; if -- multiple threads attempt to send messages concurrently, one will block -- until after the other has finished. -- -- Throws 'SocketError' on failure. send :: Message msg => Socket -> msg -> (Serial -> IO a) -> IO a send sock msg io = toSocketError (socketAddress sock) $ do serial <- nextSocketSerial sock case marshal LittleEndian serial msg of Right bytes -> do let t = socketTransport sock a <- io serial withMVar (socketWriteLock sock) (\_ -> transportPut t bytes) return a Left err -> throwIO (socketError ("Message cannot be sent: " ++ show err)) { socketErrorFatal = False } nextSocketSerial :: Socket -> IO Serial nextSocketSerial sock = atomicModifyIORef (socketSerial sock) (\x -> (nextSerial x, x)) -- | Receive the next message from the socket , blocking until one is available. -- -- Sockets are thread-safe. Only one message may be received at a time; if -- multiple threads attempt to receive messages concurrently, one will block -- until after the other has finished. -- -- Throws 'SocketError' on failure. receive :: Socket -> IO ReceivedMessage receive sock = toSocketError (socketAddress sock) $ do -- TODO: after reading the length, read all bytes from the -- handle, then return a closure to perform the parse -- outside of the lock. let t = socketTransport sock let get n = if n == 0 then return Data.ByteString.empty else transportGet t n received <- withMVar (socketReadLock sock) (\_ -> unmarshalMessageM get) case received of Left err -> throwIO (socketError ("Error reading message from socket: " ++ show err)) Right msg -> return msg toSocketError :: Maybe Address -> IO a -> IO a toSocketError addr io = catches io handlers where handlers = [ Handler catchTransportError , Handler updateSocketError , Handler catchIOException ] catchTransportError err = throwIO (socketError (transportErrorMessage err)) { socketErrorAddress = addr } updateSocketError err = throwIO err { socketErrorAddress = mplus (socketErrorAddress err) addr } catchIOException exc = throwIO (socketError (show (exc :: IOException))) { socketErrorAddress = addr } -- | An empty authenticator. Use 'authenticatorClient' or 'authenticatorServer' -- to control how the authentication is performed. -- -- @ --myAuthenticator :: Authenticator MyTransport --myAuthenticator = authenticator -- { 'authenticatorClient' = clientMyAuth -- , 'authenticatorServer' = serverMyAuth -- } -- --clientMyAuth :: MyTransport -> IO Bool --serverMyAuth :: MyTransport -> String -> IO Bool -- @ authenticator :: Authenticator t authenticator = Authenticator (\_ -> return False) (\_ _ -> return False) -- | Implements the D-Bus @EXTERNAL@ mechanism, which uses credential -- passing over a Unix socket. authExternal :: Authenticator SocketTransport authExternal = authenticator { authenticatorClient = clientAuthExternal , authenticatorServer = serverAuthExternal } clientAuthExternal :: SocketTransport -> IO Bool clientAuthExternal t = do transportPut t (Data.ByteString.pack [0]) uid <- System.Posix.User.getRealUserID let token = concatMap (printf "%02X" . ord) (show uid) transportPutLine t ("AUTH EXTERNAL " ++ token) resp <- transportGetLine t case splitPrefix "OK " resp of Just _ -> do transportPutLine t "BEGIN" return True Nothing -> return False serverAuthExternal :: SocketTransport -> UUID -> IO Bool serverAuthExternal t uuid = do let waitForBegin = do resp <- transportGetLine t if resp == "BEGIN" then return () else waitForBegin let checkToken token = do (_, uid, _) <- socketTransportCredentials t let wantToken = concatMap (printf "%02X" . ord) (maybe "XXX" show uid) if token == wantToken then do transportPutLine t ("OK " ++ formatUUID uuid) waitForBegin return True else return False c <- transportGet t 1 if c /= Char8.pack "\x00" then return False else do line <- transportGetLine t case splitPrefix "AUTH EXTERNAL " line of Just token -> checkToken token Nothing -> if line == "AUTH EXTERNAL" then do dataLine <- transportGetLine t case splitPrefix "DATA " dataLine of Just token -> checkToken token Nothing -> return False else return False transportPutLine :: Transport t => t -> String -> IO () transportPutLine t line = transportPut t (Char8.pack (line ++ "\r\n")) transportGetLine :: Transport t => t -> IO String transportGetLine t = do let getchr = Char8.head `fmap` transportGet t 1 raw <- readUntil "\r\n" getchr return (dropEnd 2 raw) -- | Drop /n/ items from the end of a list dropEnd :: Int -> [a] -> [a] dropEnd n xs = take (length xs - n) xs splitPrefix :: String -> String -> Maybe String splitPrefix prefix str = if isPrefixOf prefix str then Just (drop (length prefix) str) else Nothing -- | Read values from a monad until a guard value is read; return all -- values, including the guard. readUntil :: (Monad m, Eq a) => [a] -> m a -> m [a] readUntil guard getx = readUntil' [] where guard' = reverse guard step xs | isPrefixOf guard' xs = return (reverse xs) | otherwise = readUntil' xs readUntil' xs = do x <- getx step (x:xs) dbus-1.2.29/lib/DBus/TH.hs0000644000000000000000000000111514263302757013211 0ustar0000000000000000{-# 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" dbus-1.2.29/lib/DBus/Transport.hs0000644000000000000000000004165514263302757014707 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeFamilies #-} -- Copyright (C) 2009-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. -- | Support for defining custom transport mechanisms. Most users will not -- need to care about the types defined in this module. module DBus.Transport ( -- * Transports Transport(..) , TransportOpen(..) , TransportListen(..) -- * Transport errors , TransportError , transportError , transportErrorMessage , transportErrorAddress -- * Socket transport , SocketTransport , socketTransportOptionBacklog , socketTransportCredentials ) where import Control.Exception import qualified Data.ByteString import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as Lazy import qualified Data.Map as Map import Data.Monoid import Data.Typeable (Typeable) import Foreign.C (CUInt) import Network.Socket import Network.Socket.ByteString (sendAll, recv) import qualified System.Info import Prelude import DBus -- | Thrown from transport methods when an error occurs. data TransportError = TransportError { transportErrorMessage :: String , transportErrorAddress :: Maybe Address } deriving (Eq, Show, Typeable) instance Exception TransportError transportError :: String -> TransportError transportError msg = TransportError msg Nothing -- | A 'Transport' can exchange bytes with a remote peer. class Transport t where -- | Additional options that this transport type may use when establishing -- a connection. data TransportOptions t :: * -- | Default values for this transport's options. transportDefaultOptions :: TransportOptions t -- | Send a 'ByteString' over the transport. -- -- Throws a 'TransportError' if an error occurs. transportPut :: t -> ByteString -> IO () -- | Receive a 'ByteString' of the given size from the transport. The -- transport should block until sufficient bytes are available, and -- only return fewer than the requested amount if there will not be -- any more data. -- -- Throws a 'TransportError' if an error occurs. transportGet :: t -> Int -> IO ByteString -- | Close an open transport, and release any associated resources -- or handles. transportClose :: t -> IO () -- | A 'Transport' which can open a connection to a remote peer. class Transport t => TransportOpen t where -- | Open a connection to the given address, using the given options. -- -- Throws a 'TransportError' if the connection could not be -- established. transportOpen :: TransportOptions t -> Address -> IO t -- | A 'Transport' which can listen for and accept connections from remote -- peers. class Transport t => TransportListen t where -- | Used for transports that listen on a port or address. data TransportListener t :: * -- | Begin listening for connections on the given address, using the -- given options. -- -- Throws a 'TransportError' if it's not possible to listen at that -- address (for example, if the port is already in use). transportListen :: TransportOptions t -> Address -> IO (TransportListener t) -- | Accept a new connection. -- -- Throws a 'TransportError' if some error happens before the -- transport is ready to exchange bytes. transportAccept :: TransportListener t -> IO t -- | Close an open listener. transportListenerClose :: TransportListener t -> IO () -- | Get the address to use to connect to a listener. transportListenerAddress :: TransportListener t -> Address -- | Get the UUID allocated to this transport listener. -- -- See 'randomUUID'. transportListenerUUID :: TransportListener t -> UUID -- | Supports connecting over Unix or TCP sockets. -- -- Unix sockets are similar to pipes, but exist as special files in the -- filesystem. On Linux, /abstract sockets/ have a path-like address, but do -- not actually have entries in the filesystem. -- -- TCP sockets may use either IPv4 or IPv6. data SocketTransport = SocketTransport (Maybe Address) Socket instance Transport SocketTransport where data TransportOptions SocketTransport = SocketTransportOptions { -- | The maximum size of the connection queue for a listening -- socket. socketTransportOptionBacklog :: Int } transportDefaultOptions = SocketTransportOptions 30 transportPut (SocketTransport addr s) bytes = catchIOException addr (sendAll s bytes) transportGet (SocketTransport addr s) n = catchIOException addr (recvLoop s n) transportClose (SocketTransport addr s) = catchIOException addr (close s) recvLoop :: Socket -> Int -> IO ByteString recvLoop s = \n -> Lazy.toStrict `fmap` loop mempty n where chunkSize = 4096 loop acc n = if n > chunkSize then do chunk <- recv s chunkSize let builder = mappend acc (Builder.byteString chunk) loop builder (n - Data.ByteString.length chunk) else do chunk <- recv s n case Data.ByteString.length chunk of -- Unexpected end of connection; maybe the remote end went away. -- Return what we've got so far. 0 -> return (Builder.toLazyByteString acc) len -> do let builder = mappend acc (Builder.byteString chunk) if len == n then return (Builder.toLazyByteString builder) else loop builder (n - Data.ByteString.length chunk) instance TransportOpen SocketTransport where transportOpen _ a = case addressMethod a of "unix" -> openUnix a "tcp" -> openTcp a method -> throwIO (transportError ("Unknown address method: " ++ show method)) { transportErrorAddress = Just a } instance TransportListen SocketTransport where data TransportListener SocketTransport = SocketTransportListener Address UUID Socket transportListen opts a = do uuid <- randomUUID (a', sock) <- case addressMethod a of "unix" -> listenUnix uuid a opts "tcp" -> listenTcp uuid a opts method -> throwIO (transportError ("Unknown address method: " ++ show method)) { transportErrorAddress = Just a } return (SocketTransportListener a' uuid sock) transportAccept (SocketTransportListener a _ s) = catchIOException (Just a) $ do (s', _) <- accept s return (SocketTransport Nothing s') transportListenerClose (SocketTransportListener a _ s) = catchIOException (Just a) (close s) transportListenerAddress (SocketTransportListener a _ _) = a transportListenerUUID (SocketTransportListener _ uuid _) = uuid -- | Returns the processID, userID, and groupID of the socket's peer. -- -- See 'getPeerCredential'. socketTransportCredentials :: SocketTransport -> IO (Maybe CUInt, Maybe CUInt, Maybe CUInt) socketTransportCredentials (SocketTransport a s) = catchIOException a (getPeerCredential s) openUnix :: Address -> IO SocketTransport openUnix transportAddr = go where params = addressParameters transportAddr param key = Map.lookup key params tooMany = "Only one of 'path' or 'abstract' may be specified for the\ \ 'unix' transport." tooFew = "One of 'path' or 'abstract' must be specified for the\ \ 'unix' transport." path = case (param "path", param "abstract") of (Just x, Nothing) -> Right x (Nothing, Just x) -> Right ('\x00' : x) (Nothing, Nothing) -> Left tooFew _ -> Left tooMany go = case path of Left err -> throwIO (transportError err) { transportErrorAddress = Just transportAddr } Right p -> catchIOException (Just transportAddr) $ bracketOnError (socket AF_UNIX Stream defaultProtocol) close (\sock -> do connect sock (SockAddrUnix p) return (SocketTransport (Just transportAddr) sock)) tcpHostname :: Maybe String -> Either a Network.Socket.Family -> String tcpHostname (Just host) _ = host tcpHostname Nothing (Right AF_INET) = "127.0.0.1" tcpHostname Nothing (Right AF_INET6) = "::1" tcpHostname _ _ = "localhost" openTcp :: Address -> IO SocketTransport openTcp transportAddr = go where params = addressParameters transportAddr param key = Map.lookup key params hostname = tcpHostname (param "host") getFamily unknownFamily x = "Unknown socket family for TCP transport: " ++ show x getFamily = case param "family" of Just "ipv4" -> Right AF_INET Just "ipv6" -> Right AF_INET6 Nothing -> Right AF_UNSPEC Just x -> Left (unknownFamily x) missingPort = "TCP transport requires the `port' parameter." badPort x = "Invalid socket port for TCP transport: " ++ show x getPort = case param "port" of Nothing -> Left missingPort Just x -> case readPortNumber x of Just port -> Right port Nothing -> Left (badPort x) getAddresses family_ = getAddrInfo (Just (defaultHints { addrFlags = [AI_ADDRCONFIG] , addrFamily = family_ , addrSocketType = Stream })) (Just hostname) Nothing openOneSocket [] = throwIO (transportError "openTcp: no addresses") { transportErrorAddress = Just transportAddr } openOneSocket (addr:addrs) = do tried <- Control.Exception.try $ bracketOnError (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) close (\sock -> do connect sock (addrAddress addr) return sock) case tried of Left err -> case addrs of [] -> throwIO (transportError (show (err :: IOException))) { transportErrorAddress = Just transportAddr } _ -> openOneSocket addrs Right sock -> return sock go = case getPort of Left err -> throwIO (transportError err) { transportErrorAddress = Just transportAddr } Right port -> case getFamily of Left err -> throwIO (transportError err) { transportErrorAddress = Just transportAddr } Right family_ -> catchIOException (Just transportAddr) $ do addrs <- getAddresses family_ sock <- openOneSocket (map (setPort port) addrs) return (SocketTransport (Just transportAddr) sock) listenUnix :: UUID -> Address -> TransportOptions SocketTransport -> IO (Address, Socket) listenUnix uuid origAddr opts = getPath >>= go where params = addressParameters origAddr param key = Map.lookup key params tooMany = "Only one of 'abstract', 'path', or 'tmpdir' may be\ \ specified for the 'unix' transport." tooFew = "One of 'abstract', 'path', or 'tmpdir' must be specified\ \ for the 'unix' transport." getPath = case (param "abstract", param "path", param "tmpdir") of (Just path, Nothing, Nothing) -> let addr = address_ "unix" [ ("abstract", path) , ("guid", formatUUID uuid) ] in return (Right (addr, '\x00' : path)) (Nothing, Just path, Nothing) -> let addr = address_ "unix" [ ("path", path) , ("guid", formatUUID uuid) ] in return (Right (addr, path)) (Nothing, Nothing, Just x) -> do let fileName = x ++ "/haskell-dbus-" ++ formatUUID uuid -- Abstract paths are supported on Linux, but not on -- other Unix-like systems. let (addrParams, path) = if System.Info.os == "linux" then ([("abstract", fileName)], '\x00' : fileName) else ([("path", fileName)], fileName) let addr = address_ "unix" (addrParams ++ [("guid", formatUUID uuid)]) return (Right (addr, path)) (Nothing, Nothing, Nothing) -> return (Left tooFew) _ -> return (Left tooMany) go path = case path of Left err -> throwIO (transportError err) { transportErrorAddress = Just origAddr } Right (addr, p) -> catchIOException (Just origAddr) $ bracketOnError (socket AF_UNIX Stream defaultProtocol) close (\sock -> do bind sock (SockAddrUnix p) Network.Socket.listen sock (socketTransportOptionBacklog opts) return (addr, sock)) listenTcp :: UUID -> Address -> TransportOptions SocketTransport -> IO (Address, Socket) listenTcp uuid origAddr opts = go where params = addressParameters origAddr param key = Map.lookup key params unknownFamily x = "Unknown socket family for TCP transport: " ++ show x getFamily = case param "family" of Just "ipv4" -> Right AF_INET Just "ipv6" -> Right AF_INET6 Nothing -> Right AF_UNSPEC Just x -> Left (unknownFamily x) badPort x = "Invalid socket port for TCP transport: " ++ show x getPort = case param "port" of Nothing -> Right 0 Just x -> case readPortNumber x of Just port -> Right port Nothing -> Left (badPort x) paramBind = case param "bind" of Just "*" -> Nothing Just x -> Just x Nothing -> Just (tcpHostname (param "host") getFamily) getAddresses family_ = getAddrInfo (Just (defaultHints { addrFlags = [AI_ADDRCONFIG, AI_PASSIVE] , addrFamily = family_ , addrSocketType = Stream })) paramBind Nothing bindAddrs _ [] = throwIO (transportError "listenTcp: no addresses") { transportErrorAddress = Just origAddr } bindAddrs sock (addr:addrs) = do tried <- Control.Exception.try (bind sock (addrAddress addr)) case tried of Left err -> case addrs of [] -> throwIO (transportError (show (err :: IOException))) { transportErrorAddress = Just origAddr } _ -> bindAddrs sock addrs Right _ -> return () sockAddr port = address_ "tcp" p where p = baseParams ++ hostParam ++ familyParam baseParams = [ ("port", show port) , ("guid", formatUUID uuid) ] hostParam = case param "host" of Just x -> [("host", x)] Nothing -> [] familyParam = case param "family" of Just x -> [("family", x)] Nothing -> [] go = case getPort of Left err -> throwIO (transportError err) { transportErrorAddress = Just origAddr } Right port -> case getFamily of Left err -> throwIO (transportError err) { transportErrorAddress = Just origAddr } Right family_ -> catchIOException (Just origAddr) $ do sockAddrs <- getAddresses family_ bracketOnError (socket family_ Stream defaultProtocol) close (\sock -> do setSocketOption sock ReuseAddr 1 bindAddrs sock (map (setPort port) sockAddrs) Network.Socket.listen sock (socketTransportOptionBacklog opts) sockPort <- socketPort sock return (sockAddr sockPort, sock)) catchIOException :: Maybe Address -> IO a -> IO a catchIOException addr io = do tried <- try io case tried of Right a -> return a Left err -> throwIO (transportError (show (err :: IOException))) { transportErrorAddress = addr } address_ :: String -> [(String, String)] -> Address address_ method params = addr where Just addr = address method (Map.fromList params) setPort :: PortNumber -> AddrInfo -> AddrInfo setPort port info = case addrAddress info of (SockAddrInet _ x) -> info { addrAddress = SockAddrInet port x } (SockAddrInet6 _ x y z) -> info { addrAddress = SockAddrInet6 port x y z } _ -> info readPortNumber :: String -> Maybe PortNumber readPortNumber s = do case dropWhile (\c -> c >= '0' && c <= '9') s of [] -> return () _ -> Nothing let word = read s :: Integer if word > 0 && word <= 65535 then Just (fromInteger word) else Nothing dbus-1.2.29/tests/DBusTests.hs0000644000000000000000000000361214351135773014321 0ustar0000000000000000-- Copyright (C) 2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module Main ( tests , main ) where import Test.Tasty import DBusTests.Address import DBusTests.BusName import DBusTests.Client import DBusTests.ErrorName import DBusTests.Integration import DBusTests.InterfaceName import DBusTests.Introspection import DBusTests.MemberName import DBusTests.Message import DBusTests.ObjectPath import DBusTests.Serialization import DBusTests.Socket import DBusTests.Signature import DBusTests.Transport import DBusTests.Variant import DBusTests.Wire -- import all dbus modules here to ensure they show up in the coverage report, -- even if not tested. import DBus () import DBus.Client () import DBus.Internal.Address () import DBus.Internal.Message () import DBus.Internal.Types () import DBus.Internal.Wire () import DBus.Introspection.Parse () import DBus.Introspection.Render () import DBus.Introspection.Types () import DBus.Socket () tests :: TestTree tests = testGroup "dbus" [ test_Address , test_BusName , test_Client , test_ErrorName , test_Integration , test_InterfaceName , test_Introspection , test_MemberName , test_Message , test_ObjectPath , test_Serialization , test_Signature , test_Socket , test_Transport , test_Variant , test_Wire ] main :: IO () main = defaultMain tests dbus-1.2.29/tests/DBusTests/Address.hs0000644000000000000000000001571214263302757015712 0ustar0000000000000000-- Copyright (C) 2010-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.Address (test_Address) where import Data.Char (ord) import Data.List (intercalate) import Data.Map (Map) import Data.Maybe import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Text.Printf (printf) import qualified Data.Map import DBus import DBusTests.Util (smallListOf, smallListOf1, withEnv) test_Address :: TestTree test_Address = testGroup "Address" [ test_BuildAddress , test_ParseAddress , test_ParseAddresses , test_ParseInvalid , test_FormatAddress , test_FormatAddresses , test_GetSystemAddress , test_GetSessionAddress , test_GetStarterAddress ] test_BuildAddress :: TestTree test_BuildAddress = testProperty "address" prop where prop = forAll gen_Address check check (method, params) = case address method params of Nothing -> False Just addr -> and [ addressMethod addr == method , addressParameters addr == params ] test_ParseAddress :: TestTree test_ParseAddress = testProperty "parseAddress" prop where prop = forAll gen_AddressBytes check check (bytes, method, params) = case parseAddress bytes of Nothing -> False Just addr -> and [ addressMethod addr == method , addressParameters addr == params ] test_ParseAddresses :: TestTree test_ParseAddresses = testProperty "parseAddresses" prop where prop = forAll gen_AddressesBytes checkMany checkMany (bytes, expectedAddrs) = case parseAddresses bytes of Nothing -> False Just addrs -> and [ length addrs == length expectedAddrs , and (map checkOne (zip addrs expectedAddrs)) ] checkOne (addr, (method, params)) = and [ addressMethod addr == method , addressParameters addr == params ] test_ParseInvalid :: TestTree test_ParseInvalid = testCase "parse-invalid" $ do -- empty Nothing @=? address "" Data.Map.empty Nothing @=? parseAddress "" -- no colon Nothing @=? parseAddress "a" -- no equals sign Nothing @=? parseAddress "a:b" -- no parameter -- TODO: should this be OK? what about the trailing comma rule? Nothing @=? parseAddress "a:," -- no key Nothing @=? address "" (Data.Map.fromList [("", "c")]) Nothing @=? parseAddress "a:=c" -- no value Nothing @=? address "" (Data.Map.fromList [("b", "")]) Nothing @=? parseAddress "a:b=" test_FormatAddress :: TestTree test_FormatAddress = testProperty "formatAddress" prop where prop = forAll gen_Address check where check (method, params) = let Just addr = address method params bytes = formatAddress addr parsed = parseAddress bytes shown = show addr in and [ parsed == Just addr , shown == "Address " ++ show bytes ] test_FormatAddresses :: TestTree test_FormatAddresses = testProperty "formatAddresses" prop where prop = forAll (smallListOf1 gen_Address) check where check pairs = let addrs = do (method, params) <- pairs let Just addr = address method params return addr bytes = formatAddresses addrs parsed = parseAddresses bytes in parsed == Just addrs test_GetSystemAddress :: TestTree test_GetSystemAddress = testCase "getSystemAddress" $ do do addr <- withEnv "DBUS_SYSTEM_BUS_ADDRESS" Nothing getSystemAddress assertBool "can't get system address" $ isJust addr addr @?= address "unix" (Data.Map.fromList [("path", "/var/run/dbus/system_bus_socket")]) do addr <- withEnv "DBUS_SYSTEM_BUS_ADDRESS" (Just "a:b=c") getSystemAddress assertBool "can't get system address" $ isJust addr addr @?= address "a" (Data.Map.fromList [("b", "c")]) test_GetSessionAddress :: TestTree test_GetSessionAddress = testCase "getSessionAddress" $ do addr <- withEnv "DBUS_SESSION_BUS_ADDRESS" (Just "a:b=c") getSessionAddress assertBool "can't get session address" $ isJust addr addr @?= address "a" (Data.Map.fromList [("b", "c")]) test_GetStarterAddress :: TestTree test_GetStarterAddress = testCase "getStarterAddress" $ do addr <- withEnv "DBUS_STARTER_ADDRESS" (Just "a:b=c") getStarterAddress assertBool "can't get starter address" $ isJust addr addr @?= address "a" (Data.Map.fromList [("b", "c")]) gen_Address :: Gen (String, Map String String) gen_Address = gen where methodChars = filter (`notElem` ":;") ['!'..'~'] keyChars = filter (`notElem` "=;,") ['!'..'~'] param = do key <- smallListOf1 (elements keyChars) value <- smallListOf1 (elements ['\x00'..'\xFF']) return (key, value) gen = do params <- smallListOf param method <- if null params then smallListOf1 (elements methodChars) else smallListOf (elements methodChars) return (method, Data.Map.fromList params) gen_AddressBytes :: Gen (String, String, Map String String) gen_AddressBytes = gen where methodChars = filter (`notElem` ":;") ['!'..'~'] keyChars = filter (`notElem` "=;,") ['!'..'~'] plainChars = concat [ ['0'..'9'] , ['a'..'z'] , ['A'..'Z'] , "-_/\\*." ] encodedChars = [(printf "%%%02X" (ord x), x) | x <- ['\x00'..'\xFF']] plainChar = do x <- elements plainChars return ([x], x) encodedChar = elements encodedChars param = do key <- smallListOf1 (elements keyChars) value <- smallListOf1 (oneof [plainChar, encodedChar]) let (valueChunks, valueChars) = unzip value let str = key ++ "=" ++ concat (valueChunks) return (str, key, valueChars) gen = do params <- smallListOf param method <- if null params then smallListOf1 (elements methodChars) else smallListOf (elements methodChars) let paramStrs = [s | (s, _, _) <- params] let mapItems = [(k, v) | (_, k, v) <- params] let str = method ++ ":" ++ (intercalate "," paramStrs) return (str, method, Data.Map.fromList mapItems) gen_AddressesBytes :: Gen (String, [(String, Map String String)]) gen_AddressesBytes = do addrs <- smallListOf1 gen_AddressBytes let bytes = [b | (b, _, _) <- addrs] let expected = [(m, p) | (_, m, p) <- addrs] return (intercalate ";" bytes, expected) dbus-1.2.29/tests/DBusTests/BusName.hs0000644000000000000000000000527414263302757015661 0ustar0000000000000000-- Copyright (C) 2010-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.BusName (test_BusName) where import Data.List (intercalate) import Data.Maybe (isJust) import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import DBus import DBusTests.Util test_BusName :: TestTree test_BusName = testGroup "BusName" [ test_Parse , test_ParseInvalid , test_IsVariant ] test_Parse :: TestTree test_Parse = testProperty "parse" prop where prop = forAll gen_BusName check check x = case parseBusName x of Nothing -> False Just parsed -> formatBusName parsed == x test_ParseInvalid :: TestTree test_ParseInvalid = testCase "parse-invalid" $ do -- empty Nothing @=? parseBusName "" -- well-known starting with a digit Nothing @=? parseBusName "foo.0bar" -- well-known with one element Nothing @=? parseBusName "foo" -- unique with one element Nothing @=? parseBusName ":foo" -- trailing characters Nothing @=? parseBusName "foo.bar!" -- at most 255 characters assertBool "valid parse failed" $ isJust (parseBusName (":0." ++ replicate 251 'y')) assertBool "valid parse failed" $ isJust (parseBusName (":0." ++ replicate 252 'y')) Nothing @=? parseBusName (":0." ++ replicate 253 'y') test_IsVariant :: TestTree test_IsVariant = testCase "IsVariant" $ assertVariant TypeString (busName_ "foo.bar") gen_BusName :: Gen String gen_BusName = oneof [unique, wellKnown] where alpha = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" alphanum = alpha ++ ['0'..'9'] unique = trim $ do x <- chunks alphanum return (":" ++ x) wellKnown = trim (chunks alpha) trim gen = do x <- gen if length x > 255 then return (dropWhileEnd (== '.') (take 255 x)) else return x chunks start = do x <- chunk start xs <- listOf1 (chunk start) return (intercalate "." (x:xs)) chunk start = do x <- elements start xs <- listOf (elements alphanum) return (x:xs) instance Arbitrary BusName where arbitrary = fmap busName_ gen_BusName dbus-1.2.29/tests/DBusTests/Client.hs0000644000000000000000000006347014412616400015534 0ustar0000000000000000-- Copyright (C) 2010-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.Client (test_Client) where 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 import DBus import qualified DBus.Client import qualified DBus.Socket import DBus.Introspection.Parse import DBus.Introspection.Types 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 , test_ExportIntrospection , suite_Connect ] test_Connect :: String -> (Address -> IO DBus.Client.Client) -> TestTree test_Connect name connect = testCase name $ do (addr, sockVar) <- startDummyBus clientVar <- forkVar (connect addr) -- TODO: verify that 'hello' contains expected data, and -- send a properly formatted reply. sock <- readMVar sockVar receivedHello <- DBus.Socket.receive sock let (ReceivedMethodCall helloSerial _) = receivedHello DBus.Socket.send sock (methodReturn helloSerial) (\_ -> return ()) client <- readMVar clientVar DBus.Client.disconnect client test_ConnectWithName :: TestTree test_ConnectWithName = testCase "connectWithName" $ do (addr, sockVar) <- startDummyBus clientVar <- forkVar (DBus.Client.connectWithName DBus.Client.defaultClientOptions addr) sock <- readMVar sockVar receivedHello <- DBus.Socket.receive sock let (ReceivedMethodCall helloSerial _) = receivedHello let helloReturn = (methodReturn helloSerial) { methodReturnBody = [toVariant ":1.123"] } DBus.Socket.send sock helloReturn (\_ -> return ()) (client, clientName) <- readMVar clientVar assertEqual "client name not as expected" (busName_ ":1.123") clientName DBus.Client.disconnect client suite_Connect :: TestTree suite_Connect = testGroup "connect" [ test_ConnectSystem , test_ConnectSystem_NoAddress , test_ConnectSession , test_ConnectSession_NoAddress , test_ConnectStarter , test_ConnectStarter_NoAddress , test_ConnectWithName ] test_ConnectSystem :: TestTree test_ConnectSystem = test_Connect "connectSystem" $ \addr -> withEnv "DBUS_SYSTEM_BUS_ADDRESS" (Just (formatAddress addr)) DBus.Client.connectSystem test_ConnectSystem_NoAddress :: TestTree test_ConnectSystem_NoAddress = testCase "connectSystem-no-address" $ assertException (DBus.Client.clientError "connectSystem: DBUS_SYSTEM_BUS_ADDRESS is invalid.") (withEnv "DBUS_SYSTEM_BUS_ADDRESS" (Just "invalid") DBus.Client.connectSystem) test_ConnectSession :: TestTree test_ConnectSession = test_Connect "connectSession" $ \addr -> withEnv "DBUS_SESSION_BUS_ADDRESS" (Just (formatAddress addr)) DBus.Client.connectSession test_ConnectSession_NoAddress :: TestTree test_ConnectSession_NoAddress = testCase "connectSession-no-address" $ assertException (DBus.Client.clientError "connectSession: DBUS_SESSION_BUS_ADDRESS is invalid.") (withEnv "DBUS_SESSION_BUS_ADDRESS" (Just "invalid") DBus.Client.connectSession) test_ConnectStarter :: TestTree test_ConnectStarter = test_Connect "connectStarter" $ \addr -> withEnv "DBUS_STARTER_ADDRESS" (Just (formatAddress addr)) DBus.Client.connectStarter test_ConnectStarter_NoAddress :: TestTree test_ConnectStarter_NoAddress = testCase "connectStarter-no-address" $ assertException (DBus.Client.clientError "connectStarter: DBUS_STARTER_ADDRESS is missing or invalid.") (withEnv "DBUS_STARTER_ADDRESS" (Just "invalid") DBus.Client.connectStarter) test_RequestName :: TestTree test_RequestName = withConnectedClient $ \res -> testCase "requestName" $ do (sock, client) <- res let allFlags = [ DBus.Client.nameAllowReplacement , DBus.Client.nameReplaceExisting , DBus.Client.nameDoNotQueue ] let requestCall = (dbusCall "RequestName") { methodCallDestination = Just (busName_ "org.freedesktop.DBus") , methodCallBody = [toVariant "com.example.Foo", toVariant (7 :: Word32)] } let requestReply body serial = (methodReturn serial) { methodReturnBody = body } -- NamePrimaryOwner do reply <- stubMethodCall sock (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags) requestCall (requestReply [toVariant (1 :: Word32)]) reply @?= DBus.Client.NamePrimaryOwner -- NameInQueue do reply <- stubMethodCall sock (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags) requestCall (requestReply [toVariant (2 :: Word32)]) reply @?= DBus.Client.NameInQueue -- NameExists do reply <- stubMethodCall sock (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags) requestCall (requestReply [toVariant (3 :: Word32)]) reply @?= DBus.Client.NameExists -- NameAlreadyOwner do reply <- stubMethodCall sock (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags) requestCall (requestReply [toVariant (4 :: Word32)]) reply @?= DBus.Client.NameAlreadyOwner -- response with empty body do tried <- stubMethodCall sock (try (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags)) requestCall (requestReply []) err <- requireLeft tried err @?= (DBus.Client.clientError "requestName: received empty response") { DBus.Client.clientErrorFatal = False } -- response with invalid body do tried <- stubMethodCall sock (try (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags)) requestCall (requestReply [toVariant ""]) err <- requireLeft tried err @?= (DBus.Client.clientError "requestName: received invalid response code (Variant \"\")") { DBus.Client.clientErrorFatal = False } -- response with unknown result code do reply <- stubMethodCall sock (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags) requestCall (requestReply [toVariant (5 :: Word32)]) show reply @?= "UnknownRequestNameReply 5" test_ReleaseName :: TestTree test_ReleaseName = withConnectedClient $ \res -> testCase "releaseName" $ do (sock, client) <- res let requestCall = (dbusCall "ReleaseName") { methodCallDestination = Just (busName_ "org.freedesktop.DBus") , methodCallBody = [toVariant "com.example.Foo"] } let requestReply body serial = (methodReturn serial) { methodReturnBody = body } -- NameReleased do reply <- stubMethodCall sock (DBus.Client.releaseName client (busName_ "com.example.Foo")) requestCall (requestReply [toVariant (1 :: Word32)]) reply @?= DBus.Client.NameReleased -- NameNonExistent do reply <- stubMethodCall sock (DBus.Client.releaseName client (busName_ "com.example.Foo")) requestCall (requestReply [toVariant (2 :: Word32)]) reply @?= DBus.Client.NameNonExistent -- NameNotOwner do reply <- stubMethodCall sock (DBus.Client.releaseName client (busName_ "com.example.Foo")) requestCall (requestReply [toVariant (3 :: Word32)]) reply @?= DBus.Client.NameNotOwner -- response with empty body do tried <- stubMethodCall sock (try (DBus.Client.releaseName client (busName_ "com.example.Foo"))) requestCall (requestReply []) err <- requireLeft tried err @?= (DBus.Client.clientError "releaseName: received empty response") { DBus.Client.clientErrorFatal = False } -- response with invalid body do tried <- stubMethodCall sock (try (DBus.Client.releaseName client (busName_ "com.example.Foo"))) requestCall (requestReply [toVariant ""]) err <- requireLeft tried err @?= (DBus.Client.clientError "releaseName: received invalid response code (Variant \"\")") { DBus.Client.clientErrorFatal = False } -- response with unknown result code do reply <- stubMethodCall sock (DBus.Client.releaseName client (busName_ "com.example.Foo")) requestCall (requestReply [toVariant (5 :: Word32)]) show reply @?= "UnknownReleaseNameReply 5" test_Call :: TestTree test_Call = withConnectedClient $ \res -> testCase "call" $ do (sock, client) <- res let requestCall = (dbusCall "Hello") { methodCallSender = Just (busName_ "com.example.Foo") , methodCallDestination = Just (busName_ "org.freedesktop.DBus") , methodCallReplyExpected = False , methodCallAutoStart = False , methodCallBody = [toVariant "com.example.Foo"] } -- methodCallReplyExpected is forced to True do response <- stubMethodCall sock (DBus.Client.call client requestCall) (requestCall { methodCallReplyExpected = True }) methodReturn reply <- requireRight response 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 let requestCall = (dbusCall "Hello") { methodCallSender = Just (busName_ "com.example.Foo") , methodCallDestination = Just (busName_ "org.freedesktop.DBus") , methodCallReplyExpected = True , methodCallAutoStart = False , methodCallBody = [toVariant "com.example.Foo"] } -- methodCallReplyExpected is forced to False do stubMethodCall sock (DBus.Client.callNoReply client requestCall) (requestCall { methodCallReplyExpected = False }) methodReturn test_AddMatch :: TestTree test_AddMatch = withConnectedClient $ \res -> testCase "addMatch" $ do (sock, client) <- res let matchRule = DBus.Client.matchAny { DBus.Client.matchSender = Just (busName_ "com.example.Foo") , DBus.Client.matchDestination = Just (busName_ "com.example.Bar") , DBus.Client.matchPath = Just (objectPath_ "/") , DBus.Client.matchInterface = Just (interfaceName_ "com.example.Baz") , DBus.Client.matchMember = Just (memberName_ "Qux") } -- might as well test this while we're at it show matchRule @?= "MatchRule \"sender='com.example.Foo',destination='com.example.Bar',path='/',interface='com.example.Baz',member='Qux'\"" let requestCall = (dbusCall "AddMatch") { methodCallDestination = Just (busName_ "org.freedesktop.DBus") , methodCallBody = [toVariant "type='signal',sender='com.example.Foo',destination='com.example.Bar',path='/',interface='com.example.Baz',member='Qux'"] } signalVar <- newEmptyMVar -- add a listener for the given signal _ <- stubMethodCall sock (DBus.Client.addMatch client matchRule (putMVar signalVar)) requestCall methodReturn -- ignored signal DBus.Socket.send sock (signal (objectPath_ "/") (interfaceName_ "com.example.Baz") (memberName_ "Qux")) (\_ -> return ()) isEmptyMVar signalVar >>= assertBool "signal not ignored" -- matched signal let matchedSignal = (signal (objectPath_ "/") (interfaceName_ "com.example.Baz") (memberName_ "Qux")) { signalSender = Just (busName_ "com.example.Foo") , signalDestination = Just (busName_ "com.example.Bar") } DBus.Socket.send sock matchedSignal (\_ -> return ()) received <- takeMVar signalVar received @?= matchedSignal test_AutoMethod :: TestTree test_AutoMethod = withConnectedClient $ \res -> testCase "autoMethod" $ do (sock, client) <- res let methodMax = (\x y -> return (max x y)) :: Word32 -> Word32 -> IO Word32 let methodPair = (\x y -> return (x, y)) :: String -> String -> IO (String, String) doExport client "/" "com.example.Foo" [ DBus.Client.autoMethod (memberName_ "Max") methodMax , DBus.Client.autoMethod (memberName_ "Pair") methodPair ] -- valid call to com.example.Foo.Max do (serial, response) <- callClientMethod sock "/" "com.example.Foo" "Max" [toVariant (2 :: Word32), toVariant (1 :: Word32)] response @?= Right (methodReturn serial) { methodReturnBody = [toVariant (2 :: Word32)] } -- valid call to com.example.Foo.Pair do (serial, response) <- callClientMethod sock "/" "com.example.Foo" "Pair" [toVariant "x", toVariant "y"] response @?= Right (methodReturn serial) { methodReturnBody = [toVariant "x", toVariant "y"] } -- invalid call to com.example.Foo.Max do (serial, response) <- callClientMethod sock "/" "com.example.Foo" "Max" [toVariant "x", toVariant "y"] response @?= Left (methodError serial (errorName_ "org.freedesktop.DBus.Error.InvalidParameters")) test_ExportIntrospection :: TestTree 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 uuid <- randomUUID let Just addr = address "unix" (Map.fromList [("abstract", formatUUID uuid)]) listener <- DBus.Socket.listen addr sockVar <- forkVar (DBus.Socket.accept listener) return (DBus.Socket.socketListenerAddress listener, sockVar) withConnectedClient :: (IO (DBus.Socket.Socket, DBus.Client.Client) -> TestTree) -> TestTree withConnectedClient = withResource create remove where create = do (addr, sockVar) <- startDummyBus clientVar <- forkVar (DBus.Client.connect addr) -- TODO: verify that 'hello' contains expected data, and -- send a properly formatted reply. sock <- readMVar sockVar receivedHello <- DBus.Socket.receive sock let (ReceivedMethodCall helloSerial _) = receivedHello DBus.Socket.send sock (methodReturn helloSerial) (\_ -> return ()) client <- readMVar clientVar return (sock, client) remove (_, client) = DBus.Client.disconnect client stubMethodCall :: DBus.Socket.Socket -> IO a -> MethodCall -> (Serial -> MethodReturn) -> IO a stubMethodCall sock io expectedCall respond = do var <- forkVar io receivedCall <- DBus.Socket.receive sock let ReceivedMethodCall callSerial call = receivedCall expectedCall @?= call DBus.Socket.send sock (respond callSerial) (\_ -> return ()) takeMVar var callClientMethod :: DBus.Socket.Socket -> String -> String -> String -> [Variant] -> IO (Serial, Either MethodError MethodReturn) callClientMethod sock path iface name body = do let call = (methodCall (objectPath_ path) (interfaceName_ iface) (memberName_ name)) { methodCallBody = body } serial <- DBus.Socket.send sock call return resp <- DBus.Socket.receive sock case resp of ReceivedMethodReturn _ ret -> return (serial, Right ret) ReceivedMethodError _ err -> return (serial, Left err) _ -> assertFailure "callClientMethod: unexpected response to method call" >> undefined dbusCall :: String -> MethodCall dbusCall member = methodCall (objectPath_ "/org/freedesktop/DBus") (interfaceName_ "org.freedesktop.DBus") (memberName_ member) dbus-1.2.29/tests/DBusTests/ErrorName.hs0000644000000000000000000000475014263302757016217 0ustar0000000000000000-- Copyright (C) 2010-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.ErrorName (test_ErrorName) where import Data.List (intercalate) import Data.Maybe import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import DBus import DBusTests.Util test_ErrorName :: TestTree test_ErrorName = testGroup "ErrorName" [ test_Parse , test_ParseInvalid , test_IsVariant ] test_Parse :: TestTree test_Parse = testProperty "parse" prop where prop = forAll gen_ErrorName check check x = case parseErrorName x of Nothing -> False Just parsed -> formatErrorName parsed == x test_ParseInvalid :: TestTree test_ParseInvalid = testCase "parse-invalid" $ do -- empty Nothing @=? parseErrorName "" -- one element Nothing @=? parseErrorName "foo" -- element starting with a digit Nothing @=? parseErrorName "foo.0bar" -- trailing characters Nothing @=? parseErrorName "foo.bar!" -- at most 255 characters assertBool "valid parse failed" $ isJust (parseErrorName ("f." ++ replicate 252 'y')) assertBool "valid parse failed" $ isJust (parseErrorName ("f." ++ replicate 253 'y')) Nothing @=? parseErrorName ("f." ++ replicate 254 'y') test_IsVariant :: TestTree test_IsVariant = testCase "IsVariant" $ assertVariant TypeString (errorName_ "foo.bar") gen_ErrorName :: Gen String gen_ErrorName = trim chunks where alpha = ['a'..'z'] ++ ['A'..'Z'] ++ "_" alphanum = alpha ++ ['0'..'9'] trim gen = do x <- gen if length x > 255 then return (dropWhileEnd (== '.') (take 255 x)) else return x chunks = do x <- chunk xs <- listOf1 chunk return (intercalate "." (x:xs)) chunk = do x <- elements alpha xs <- listOf (elements alphanum) return (x:xs) instance Arbitrary ErrorName where arbitrary = fmap errorName_ gen_ErrorName dbus-1.2.29/tests/DBusTests/Generation.hs0000644000000000000000000000253114263302757016413 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module DBusTests.Generation where import DBus.Client import qualified DBus.Internal.Types as T import qualified DBus.Introspection.Types 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] , interfaceProperties = [autoProperty "SampleWriteProperty" (Just $ return (1 :: Int32)) (Just $ const $ return ()) ] , interfaceName = "org.TestInterface" , interfaceSignals = testSignals } testIntrospectionInterface :: I.Interface testIntrospectionInterface = buildIntrospectionInterface testInterface dbus-1.2.29/tests/DBusTests/Integration.hs0000644000000000000000000001156314263302757016610 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.Integration (test_Integration) where import Control.Exception (finally) import System.Directory (removeFile) import System.Exit import System.IO (hGetLine) import System.Process import Test.Tasty import Test.Tasty.HUnit import DBus import DBus.Socket import DBus.Client import DBusTests.Util test_Integration :: TestTree test_Integration = testGroup "Integration" [ test_Socket , test_Client ] test_Socket :: TestTree test_Socket = withDaemon "socket" $ \addr -> do let hello = (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "Hello") { methodCallDestination = Just "org.freedesktop.DBus" } sock <- open addr serial <- send sock hello return assertBool "invalid serial" $ serialValue serial >= 1 received <- receive sock let ReceivedMethodReturn _ ret = received methodReturnSerial ret @?= serial methodReturnSender ret @?= Just "org.freedesktop.DBus" close sock test_Client :: TestTree test_Client = withDaemon "client" $ \addr -> do clientA <- connect addr clientB <- connect addr export clientA "/" 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" -- Successful call let bodyGood = [toVariant ("test" :: String)] retGood <- call clientB (methodCall "/" "com.example.Echo" "Echo") { methodCallDestination = Just busAddrA , methodCallBody = bodyGood } ret <- requireRight retGood methodReturnBody ret @?= bodyGood -- Failed call let bodyBad = [toVariant True] retBad <- call clientB (methodCall "/" "com.example.Echo" "Echo") { methodCallDestination = Just busAddrA , methodCallBody = bodyBad } err <- requireLeft retBad methodErrorName err @?= "com.example.Error" methodErrorBody err @?= [toVariant ("bad body: [Variant True]" :: String)] disconnect clientA disconnect clientB configFileContent :: String configFileContent = "\ \\ \\ \ session\ \ \ \ unix:tmpdir=/tmp\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \" withDaemon :: String -> (Address -> Assertion) -> TestTree withDaemon name io = testCase name $ do (versionExit, _, _) <- readProcessWithExitCode "dbus-daemon" ["--version"] "" case versionExit of ExitFailure _ -> assertFailure $ "dbus-daemon failed: " ++ show versionExit ExitSuccess -> do configFilePath <- getTempPath writeFile configFilePath configFileContent daemon <- createProcess (proc "dbus-daemon" ["--config-file=" ++ configFilePath, "--print-address"]) { std_out = CreatePipe , close_fds = True } let (_, Just daemonStdout, _, daemonProc) = daemon finally (do addrString <- hGetLine daemonStdout case parseAddress addrString of Nothing -> assertFailure $ "dbus-daemon returned invalid address: " ++ show addrString Just addr -> io addr) (do terminateProcess daemonProc _ <- waitForProcess daemonProc removeFile configFilePath return ()) dbus-1.2.29/tests/DBusTests/InterfaceName.hs0000644000000000000000000000507414263302757017026 0ustar0000000000000000-- Copyright (C) 2010-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.InterfaceName (test_InterfaceName) where import Data.List (intercalate) import Data.Maybe import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import DBus import DBusTests.Util test_InterfaceName :: TestTree test_InterfaceName = testGroup "InterfaceName" [ test_Parse , test_ParseInvalid , test_IsVariant ] test_Parse :: TestTree test_Parse = testProperty "parse" prop where prop = forAll gen_InterfaceName check check x = case parseInterfaceName x of Nothing -> False Just parsed -> formatInterfaceName parsed == x test_ParseInvalid :: TestTree test_ParseInvalid = testCase "parse-invalid" $ do -- empty Nothing @=? parseInterfaceName "" -- one element Nothing @=? parseInterfaceName "foo" -- element starting with a digit Nothing @=? parseInterfaceName "foo.0bar" -- trailing characters Nothing @=? parseInterfaceName "foo.bar!" -- at most 255 characters assertBool "valid parse failed" $ isJust (parseInterfaceName ("f." ++ replicate 252 'y')) assertBool "valid parse failed" $ isJust (parseInterfaceName ("f." ++ replicate 253 'y')) Nothing @=? parseInterfaceName ("f." ++ replicate 254 'y') test_IsVariant :: TestTree test_IsVariant = testCase "IsVariant" $ assertVariant TypeString (interfaceName_ "foo.bar") gen_InterfaceName :: Gen String gen_InterfaceName = trim chunks where alpha = ['a'..'z'] ++ ['A'..'Z'] ++ "_" alphanum = alpha ++ ['0'..'9'] trim gen = do x <- gen if length x > 255 then return (dropWhileEnd (== '.') (take 255 x)) else return x chunks = do x <- chunk xs <- listOf1 chunk return (intercalate "." (x:xs)) chunk = do x <- elements alpha xs <- listOf (elements alphanum) return (x:xs) instance Arbitrary InterfaceName where arbitrary = fmap interfaceName_ gen_InterfaceName dbus-1.2.29/tests/DBusTests/Introspection.hs0000644000000000000000000001337214351135773017165 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2010-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.Introspection (test_Introspection) where import Control.Applicative ((<$>), (<*>)) import Control.Monad (liftM, liftM2) import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import qualified Data.Text as T import DBus import qualified DBus.Introspection.Parse as I import qualified DBus.Introspection.Render as I import qualified DBus.Introspection.Types as I import DBusTests.InterfaceName () import DBusTests.MemberName () import DBusTests.ObjectPath () import DBusTests.Signature () import DBusTests.Util (halfSized) test_Introspection :: TestTree test_Introspection = testGroup "Introspection" [ test_XmlPassthrough , test_XmlParse , test_XmlParseFailed , test_XmlWriteFailed ] test_XmlPassthrough :: TestTree test_XmlPassthrough = testProperty "xml-passthrough" $ \obj -> let path = I.objectPath obj Just xml = I.formatXML obj in I.parseXML path (T.pack 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 I.parseXML (objectPath_ "/") "" @?= Just (buildEmptyObject "/") { I.objectChildren = [ buildEmptyObject "/foo" ] } test_XmlParseFailed :: TestTree test_XmlParseFailed = testCase "xml-parse-failed" $ do Nothing @=? I.parseXML (objectPath_ "/") "" Nothing @=? I.parseXML (objectPath_ "/") "" -- invalid property access Nothing @=? I.parseXML (objectPath_ "/") "\ \ \ \ \ \ \ \ \ \" -- invalid parameter type Nothing @=? I.parseXML (objectPath_ "/") "\ \ \ \ \ \ \ \ \ \ \ \" test_XmlWriteFailed :: TestTree test_XmlWriteFailed = testCase "xml-write-failed" $ do -- child's object path isn't under parent's Nothing @=? I.formatXML (buildEmptyObject "/foo") { I.objectChildren = [ buildEmptyObject "/bar" ] } -- invalid type 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 atom = elements [ TypeBoolean , TypeWord8 , TypeWord16 , TypeWord32 , TypeWord64 , TypeInt16 , TypeInt32 , TypeInt64 , TypeDouble , TypeString , TypeObjectPath , TypeSignature ] container = oneof [ return TypeVariant , liftM TypeArray arbitrary , liftM2 TypeDictionary atom arbitrary , liftM TypeStructure (listOf1 (halfSized arbitrary)) ] instance Arbitrary I.Object where arbitrary = arbitrary >>= subObject subObject :: ObjectPath -> Gen I.Object subObject parentPath = sized $ \n -> resize (min n 4) $ do let nonRoot = do x <- resize 10 arbitrary case formatObjectPath x of "/" -> nonRoot x' -> return x' thisPath <- nonRoot let path' = case formatObjectPath parentPath of "/" -> thisPath x -> x ++ thisPath let path = objectPath_ path' ifaces <- arbitrary children <- halfSized (listOf (subObject path)) return $ I.Object path ifaces children instance Arbitrary I.Interface where arbitrary = do name <- arbitrary methods <- arbitrary signals <- arbitrary properties <- arbitrary return $ I.Interface name methods signals properties instance Arbitrary I.Method where arbitrary = do name <- arbitrary args <- arbitrary return $ (I.Method name args) instance Arbitrary I.Signal where arbitrary = do name <- arbitrary args <- arbitrary return $ I.Signal name args instance Arbitrary I.MethodArg where arbitrary = I.MethodArg <$> gen_Ascii <*> arbitrary <*> arbitrary instance Arbitrary I.Direction where arbitrary = elements [I.In, I.Out] instance Arbitrary I.SignalArg where arbitrary = I.SignalArg <$> gen_Ascii <*> arbitrary instance Arbitrary I.Property where arbitrary = do name <- gen_Ascii t <- arbitrary canRead <- arbitrary canWrite <- arbitrary return I.Property { I.propertyName = name , I.propertyType = t , I.propertyRead = canRead , I.propertyWrite = canWrite } gen_Ascii :: Gen String gen_Ascii = listOf (elements ['!'..'~']) dbus-1.2.29/tests/DBusTests/MemberName.hs0000644000000000000000000000415314263302757016332 0ustar0000000000000000-- Copyright (C) 2010-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.MemberName (test_MemberName) where import Data.Maybe import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import DBus import DBusTests.Util test_MemberName :: TestTree test_MemberName = testGroup "MemberName" [ test_Parse , test_ParseInvalid , test_IsVariant ] test_Parse :: TestTree test_Parse = testProperty "parse" prop where prop = forAll gen_MemberName check check x = case parseMemberName x of Nothing -> False Just parsed -> formatMemberName parsed == x test_ParseInvalid :: TestTree test_ParseInvalid = testCase "parse-invalid" $ do -- empty Nothing @=? parseMemberName "" -- starts with a digit Nothing @=? parseMemberName "@foo" -- trailing chars Nothing @=? parseMemberName "foo!" -- at most 255 characters assertBool "valid parse failed" $ isJust (parseMemberName (replicate 254 'y')) assertBool "valid parse failed" $ isJust (parseMemberName (replicate 255 'y')) Nothing @=? parseMemberName (replicate 256 'y') test_IsVariant :: TestTree test_IsVariant = testCase "IsVariant" $ assertVariant TypeString (memberName_ "foo") gen_MemberName :: Gen String gen_MemberName = gen where alpha = ['a'..'z'] ++ ['A'..'Z'] ++ "_" alphanum = alpha ++ ['0'..'9'] gen = do x <- elements alpha xs <- listOf (elements alphanum) return (x:xs) instance Arbitrary MemberName where arbitrary = fmap memberName_ gen_MemberName dbus-1.2.29/tests/DBusTests/Message.hs0000644000000000000000000000273414263302757015711 0ustar0000000000000000-- Copyright (C) 2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.Message (test_Message) where import Test.Tasty import Test.Tasty.HUnit import DBus test_Message :: TestTree test_Message = testGroup "Message" [ test_MethodErrorMessage ] test_MethodErrorMessage :: TestTree test_MethodErrorMessage = testCase "methodErrorMessage" $ do let emptyError = methodError firstSerial (errorName_ "com.example.Error") "(no error message)" @=? methodErrorMessage emptyError { methodErrorBody = [] } "(no error message)" @=? methodErrorMessage emptyError { methodErrorBody = [toVariant True] } "(no error message)" @=? methodErrorMessage emptyError { methodErrorBody = [toVariant ""] } "error" @=? methodErrorMessage emptyError { methodErrorBody = [toVariant "error"] } dbus-1.2.29/tests/DBusTests/ObjectPath.hs0000644000000000000000000000346414263302757016351 0ustar0000000000000000-- Copyright (C) 2010-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.ObjectPath (test_ObjectPath) where import Data.List (intercalate) import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import DBus test_ObjectPath :: TestTree test_ObjectPath = testGroup "ObjectPath" [ test_Parse , test_ParseInvalid ] test_Parse :: TestTree test_Parse = testProperty "parse" prop where prop = forAll gen_ObjectPath check check x = case parseObjectPath x of Nothing -> False Just parsed -> formatObjectPath parsed == x test_ParseInvalid :: TestTree test_ParseInvalid = testCase "parse-invalid" $ do -- empty Nothing @=? parseObjectPath "" -- bad char Nothing @=? parseObjectPath "/f!oo" -- ends with a slash Nothing @=? parseObjectPath "/foo/" -- empty element Nothing @=? parseObjectPath "/foo//bar" -- trailing chars Nothing @=? parseObjectPath "/foo!" gen_ObjectPath :: Gen String gen_ObjectPath = gen where chars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" gen = do xs <- listOf (listOf1 (elements chars)) return ("/" ++ intercalate "/" xs) instance Arbitrary ObjectPath where arbitrary = fmap objectPath_ gen_ObjectPath dbus-1.2.29/tests/DBusTests/Serialization.hs0000644000000000000000000001440614263302757017141 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2010-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.Serialization (test_Serialization) where import Data.ByteString (ByteString) import Data.Int (Int16, Int32, Int64) import Data.Map (Map) import Data.Text (Text) import Data.Word (Word8, Word16, Word32, Word64) import Foreign.C.Types (CInt) import System.Posix.Types (Fd) import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck import qualified Data.Map import qualified Data.Vector import DBus import qualified DBus.Internal.Types import DBusTests.BusName () import DBusTests.ErrorName () import DBusTests.InterfaceName () import DBusTests.MemberName () import DBusTests.ObjectPath () import DBusTests.Signature () import DBusTests.Util (smallListOf) test_Serialization :: TestTree test_Serialization = testGroup "Serialization" [ test_MethodCall , test_MethodReturn , test_MethodError , test_Signal ] test_MethodCall :: TestTree test_MethodCall = testProperty "MethodCall" prop where prop = forAll gen_MethodCall check check msg endianness serial = let Right bytes = marshal endianness serial msg Right received = unmarshal bytes in ReceivedMethodCall serial msg == received test_MethodReturn :: TestTree test_MethodReturn = testProperty "MethodReturn" prop where prop = forAll gen_MethodReturn check check msg endianness serial = let Right bytes = marshal endianness serial msg Right received = unmarshal bytes in ReceivedMethodReturn serial msg == received test_MethodError :: TestTree test_MethodError = testProperty "MethodError" prop where prop = forAll gen_MethodError check check msg endianness serial = let Right bytes = marshal endianness serial msg Right received = unmarshal bytes in ReceivedMethodError serial msg == received test_Signal :: TestTree test_Signal = testProperty "Signal" prop where prop = forAll gen_Signal check check msg endianness serial = let Right bytes = marshal endianness serial msg Right received = unmarshal bytes in ReceivedSignal serial msg == received gen_Atom :: Gen Variant gen_Atom = oneof [ fmap toVariant (arbitrary :: Gen Word8) , fmap toVariant (arbitrary :: Gen Word16) , fmap toVariant (arbitrary :: Gen Word32) , fmap toVariant (arbitrary :: Gen Word64) , fmap toVariant (arbitrary :: Gen Int16) , fmap toVariant (arbitrary :: Gen Int32) , fmap toVariant (arbitrary :: Gen Int64) , fmap toVariant (arbitrary :: Gen Bool) , fmap toVariant (arbitrary :: Gen Double) , fmap toVariant gen_UnixFd , fmap toVariant (arbitrary :: Gen Text) , fmap toVariant (arbitrary :: Gen ObjectPath) , fmap toVariant (arbitrary :: Gen Signature) ] gen_UnixFd :: Gen Fd gen_UnixFd = do let maxWord32 = toInteger (maxBound :: Word32) let maxCInt = toInteger (maxBound :: CInt) x <- choose (0, toInteger (min maxWord32 maxCInt)) return (fromInteger x) gen_Variant :: Gen Variant gen_Variant = oneof [ gen_Atom , fmap toVariant (arbitrary :: Gen ByteString) -- TODO: proper arbitrary vectors , elements [ toVariant (Data.Vector.fromList ([] :: [Word8])) , toVariant (Data.Vector.fromList ([0, 1, 2, 3, 4, 5] :: [Word8])) , toVariant (Data.Vector.fromList ([0, 1, 2, 3, 4, 5] :: [Word16])) , toVariant (Data.Vector.fromList ([0, 1, 2, 3, 4, 5] :: [Word32])) , toVariant (Data.Vector.fromList ([0, 1, 2, 3, 4, 5] :: [Word64])) , toVariant (Data.Vector.fromList (["foo", "bar", "baz"] :: [Text])) ] -- TODO: proper arbitrary maps , elements [ toVariant (Data.Map.fromList [] :: Map Text Text) , toVariant (Data.Map.fromList [("foo", "bar"), ("baz", "qux")] :: Map Text Text) ] -- TODO: proper arbitrary structures , elements [ toVariant (True, "foo" :: Text, ["bar" :: Text]) , toVariant (1 :: Word8, 1 :: Word16, 1 :: Word32, 1 :: Word64) ] , fmap toVariant gen_Variant ] gen_MethodCall :: Gen MethodCall gen_MethodCall = do path <- arbitrary iface <- arbitrary member <- arbitrary sender <- arbitrary dest <- arbitrary flagReplyExpected <- arbitrary flagAutoStart <- arbitrary body <- smallListOf gen_Variant return (methodCall path "com.example.ignored" member) { methodCallInterface = iface , methodCallSender = sender , methodCallDestination = dest , methodCallReplyExpected = flagReplyExpected , methodCallAutoStart = flagAutoStart , methodCallBody = body } gen_MethodReturn :: Gen MethodReturn gen_MethodReturn = do serial <- arbitrary sender <- arbitrary dest <- arbitrary body <- smallListOf gen_Variant return (methodReturn serial) { methodReturnSender = sender , methodReturnDestination = dest , methodReturnBody = body } gen_MethodError :: Gen MethodError gen_MethodError = do serial <- arbitrary name <- arbitrary sender <- arbitrary dest <- arbitrary body <- smallListOf gen_Variant return (methodError serial name) { methodErrorSender = sender , methodErrorDestination = dest , methodErrorBody = body } gen_Signal :: Gen Signal gen_Signal = do path <- arbitrary iface <- arbitrary member <- arbitrary sender <- arbitrary dest <- arbitrary body <- smallListOf gen_Variant return (signal path iface member) { signalSender = sender , signalDestination = dest , signalBody = body } instance Arbitrary Endianness where arbitrary = elements [BigEndian, LittleEndian] instance Arbitrary Serial where arbitrary = fmap DBus.Internal.Types.Serial arbitrary dbus-1.2.29/tests/DBusTests/Signature.hs0000644000000000000000000001174214263302757016265 0ustar0000000000000000-- Copyright (C) 2010-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.Signature (test_Signature) where import Data.Maybe import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import DBus import DBusTests.Util test_Signature :: TestTree test_Signature = testGroup "Signature" [ test_BuildSignature , test_ParseSignature , test_ParseInvalid , test_FormatSignature , test_IsAtom , test_ShowType ] test_BuildSignature :: TestTree test_BuildSignature = testProperty "signature" prop where prop = forAll gen_SignatureTypes check check types = case signature types of Nothing -> False Just sig -> signatureTypes sig == types test_ParseSignature :: TestTree test_ParseSignature = testProperty "parseSignature" prop where prop = forAll gen_SignatureString check check (s, types) = case parseSignature s of Nothing -> False Just sig -> signatureTypes sig == types test_ParseInvalid :: TestTree test_ParseInvalid = testCase "parse-invalid" $ do -- at most 255 characters assertBool "valid parse failed" $ isJust (parseSignature (replicate 254 'y')) assertBool "valid parse failed" $ isJust (parseSignature (replicate 255 'y')) Nothing @=? parseSignature (replicate 256 'y') -- length also enforced by 'signature' assertBool "valid parse failed" $ isJust (signature (replicate 255 TypeWord8)) Nothing @=? signature (replicate 256 TypeWord8) -- struct code Nothing @=? parseSignature "r" -- empty struct Nothing @=? parseSignature "()" Nothing @=? signature [TypeStructure []] -- dict code Nothing @=? parseSignature "e" -- non-atomic dict key Nothing @=? parseSignature "a{vy}" Nothing @=? signature [TypeDictionary TypeVariant TypeVariant] test_FormatSignature :: TestTree test_FormatSignature = testProperty "formatSignature" prop where prop = forAll gen_SignatureString check check (s, _) = let Just sig = parseSignature s in formatSignature sig == s test_IsAtom :: TestTree test_IsAtom = testCase "IsAtom" $ do let Just sig = signature [] assertAtom TypeSignature sig test_ShowType :: TestTree test_ShowType = testCase "show-type" $ do "Bool" @=? show TypeBoolean "Bool" @=? show TypeBoolean "Word8" @=? show TypeWord8 "Word16" @=? show TypeWord16 "Word32" @=? show TypeWord32 "Word64" @=? show TypeWord64 "Int16" @=? show TypeInt16 "Int32" @=? show TypeInt32 "Int64" @=? show TypeInt64 "Double" @=? show TypeDouble "UnixFd" @=? show TypeUnixFd "String" @=? show TypeString "Signature" @=? show TypeSignature "ObjectPath" @=? show TypeObjectPath "Variant" @=? show TypeVariant "[Word8]" @=? show (TypeArray TypeWord8) "Dict Word8 (Dict Word8 Word8)" @=? show (TypeDictionary TypeWord8 (TypeDictionary TypeWord8 TypeWord8)) "(Word8, Word16)" @=? show (TypeStructure [TypeWord8, TypeWord16]) gen_SignatureTypes :: Gen [Type] gen_SignatureTypes = do (_, ts) <- gen_SignatureString return ts gen_SignatureString :: Gen (String, [Type]) gen_SignatureString = gen where anyType = oneof [atom, container] atom = elements [ ("b", TypeBoolean) , ("y", TypeWord8) , ("q", TypeWord16) , ("u", TypeWord32) , ("t", TypeWord64) , ("n", TypeInt16) , ("i", TypeInt32) , ("x", TypeInt64) , ("d", TypeDouble) , ("h", TypeUnixFd) , ("s", TypeString) , ("o", TypeObjectPath) , ("g", TypeSignature) ] container = oneof [ return ("v", TypeVariant) , array , dict , struct ] array = do (tCode, tEnum) <- anyType return ('a':tCode, TypeArray tEnum) dict = do (kCode, kEnum) <- atom (vCode, vEnum) <- anyType return (concat ["a{", kCode, vCode, "}"], TypeDictionary kEnum vEnum) struct = do ts <- listOf1 (halfSized anyType) let (codes, enums) = unzip ts return ("(" ++ concat codes ++ ")", TypeStructure enums) gen = do types <- listOf anyType let (codes, enums) = unzip types let chars = concat codes if length chars > 255 then halfSized gen else return (chars, enums) instance Arbitrary Signature where arbitrary = do ts <- gen_SignatureTypes let Just sig = signature ts return sig dbus-1.2.29/tests/DBusTests/Socket.hs0000644000000000000000000001062514263302757015553 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.Socket (test_Socket) where import Control.Concurrent import Control.Exception import Test.Tasty import Test.Tasty.HUnit import qualified Data.Map as Map import DBus import DBus.Socket import DBus.Transport import DBusTests.Util (forkVar) test_Socket :: TestTree test_Socket = testGroup "Socket" [ test_Listen , test_ListenWith_CustomAuth , test_SendReceive ] test_Listen :: TestTree test_Listen = testCase "listen" $ do uuid <- randomUUID let Just addr = address "unix" (Map.fromList [ ("abstract", formatUUID uuid) ]) bracket (listen addr) closeListener $ \listener -> do acceptedVar <- forkVar (accept listener) openedVar <- forkVar (open addr) sock1 <- takeMVar acceptedVar sock2 <- takeMVar openedVar close sock1 close sock2 test_ListenWith_CustomAuth :: TestTree test_ListenWith_CustomAuth = testCase "listenWith-custom-auth" $ do uuid <- randomUUID let Just addr = address "unix" (Map.fromList [ ("abstract", formatUUID uuid) ]) bracket (listenWith (defaultSocketOptions { socketAuthenticator = dummyAuth }) addr) closeListener $ \listener -> do acceptedVar <- forkVar (accept listener) openedVar <- forkVar (openWith (defaultSocketOptions { socketAuthenticator = dummyAuth }) addr) sock1 <- takeMVar acceptedVar sock2 <- takeMVar openedVar close sock1 close sock2 test_SendReceive :: TestTree test_SendReceive = testCase "send-receive" $ do uuid <- randomUUID let Just addr = address "unix" (Map.fromList [ ("abstract", formatUUID uuid) ]) let msg = (methodCall "/" "org.example.iface" "Foo") { methodCallSender = Just "org.example.src" , methodCallDestination = Just "org.example.dst" , methodCallAutoStart = False , methodCallReplyExpected = False , methodCallBody = [toVariant True] } bracket (listen addr) closeListener $ \listener -> do acceptedVar <- forkVar (accept listener) openedVar <- forkVar (open addr) bracket (takeMVar acceptedVar) close $ \sock1 -> do bracket (takeMVar openedVar) close $ \sock2 -> do -- client -> server do serialVar <- newEmptyMVar sentVar <- forkVar (send sock2 msg (putMVar serialVar)) receivedVar <- forkVar (receive sock1) serial <- takeMVar serialVar sent <- takeMVar sentVar received <- takeMVar receivedVar sent @?= () received @?= ReceivedMethodCall serial msg -- server -> client do serialVar <- newEmptyMVar sentVar <- forkVar (send sock1 msg (putMVar serialVar)) receivedVar <- forkVar (receive sock2) serial <- takeMVar serialVar sent <- takeMVar sentVar received <- takeMVar receivedVar sent @?= () received @?= ReceivedMethodCall serial msg dummyAuth :: Transport t => Authenticator t dummyAuth = authenticator { authenticatorClient = dummyAuthClient , authenticatorServer = dummyAuthServer } dummyAuthClient :: Transport t => t -> IO Bool dummyAuthClient t = do transportPut t "\x00" resp <- transportGet t 4 return (resp == "OK\r\n") dummyAuthServer :: Transport t => t -> UUID -> IO Bool dummyAuthServer t _ = do c <- transportGet t 1 if c == "\x00" then do transportPut t "OK\r\n" return True else return False dbus-1.2.29/tests/DBusTests/TH.hs0000644000000000000000000000040314263302757014627 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module DBusTests.TH where import DBus.Generation import DBusTests.Generation generateClient defaultGenerationParams testIntrospectionInterface generateSignalsFromInterface defaultGenerationParams testIntrospectionInterface dbus-1.2.29/tests/DBusTests/Transport.hs0000644000000000000000000004306214263302757016320 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.Transport (test_Transport) where import Control.Concurrent import Control.Monad.Extra (unlessM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource import Data.Function (fix) import Data.List (isInfixOf) import Network.Socket.ByteString (sendAll, recv) import System.Directory (getTemporaryDirectory, removeFile) import Test.Tasty import Test.Tasty.HUnit import qualified Data.ByteString import qualified Data.Map as Map import qualified Network.Socket as NS import DBus import DBus.Transport import DBusTests.Util test_Transport :: TestTree test_Transport = testGroup "Transport" $ [ suite_TransportOpen , suite_TransportListen , suite_TransportAccept , test_TransportSendReceive , test_HandleLostConnection ] suite_TransportOpen :: TestTree suite_TransportOpen = testGroup "transportOpen" $ [ test_OpenUnknown , suite_OpenUnix , suite_OpenTcp ] suite_TransportListen :: TestTree suite_TransportListen = testGroup "transportListen" $ [ test_ListenUnknown , suite_ListenUnix , suite_ListenTcp ] suite_TransportAccept :: TestTree suite_TransportAccept = testGroup "transportAccept" [ test_AcceptSocket , test_AcceptSocketClosed ] test_OpenUnknown :: TestTree test_OpenUnknown = testCase "unknown" $ do let Just addr = address "noexist" Map.empty assertException ((transportError "Unknown address method: \"noexist\"") { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) suite_OpenUnix :: TestTree suite_OpenUnix = testGroup "unix" [ test_OpenUnix_Path , test_OpenUnix_Abstract , test_OpenUnix_TooFew , test_OpenUnix_TooMany , test_OpenUnix_NotListening ] test_OpenUnix_Path :: TestTree test_OpenUnix_Path = testCase "path" $ runResourceT $ do addr <- listenRandomUnixPath fdcountBefore <- countFileDescriptors t <- liftIO (transportOpen socketTransportOptions addr) liftIO (transportClose t) fdcountAfter <- countFileDescriptors liftIO (fdcountBefore @=? fdcountAfter) test_OpenUnix_Abstract :: TestTree test_OpenUnix_Abstract = testCase "abstract" $ runResourceT $ do (addr, _) <- listenRandomUnixAbstract fdcountBefore <- countFileDescriptors t <- liftIO (transportOpen socketTransportOptions addr) liftIO (transportClose t) fdcountAfter <- countFileDescriptors liftIO (fdcountBefore @=? fdcountAfter) test_OpenUnix_TooFew :: TestTree test_OpenUnix_TooFew = testCase "too-few" $ do fdcountBefore <- countFileDescriptors let Just addr = address "unix" Map.empty assertException ((transportError "One of 'path' or 'abstract' must be specified for the 'unix' transport.") { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) fdcountAfter <- countFileDescriptors fdcountBefore @=? fdcountAfter test_OpenUnix_TooMany :: TestTree test_OpenUnix_TooMany = testCase "too-many" $ do fdcountBefore <- countFileDescriptors let Just addr = address "unix" (Map.fromList [ ("path", "foo") , ("abstract", "bar") ]) assertException ((transportError "Only one of 'path' or 'abstract' may be specified for the 'unix' transport.") { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) fdcountAfter <- countFileDescriptors fdcountBefore @=? fdcountAfter test_OpenUnix_NotListening :: TestTree test_OpenUnix_NotListening = testCase "not-listening" $ runResourceT $ do fdcountBefore <- countFileDescriptors (addr, key) <- listenRandomUnixAbstract release key liftIO $ assertThrows (\err -> and [ "Connection refused" `isInfixOf` transportErrorMessage err , transportErrorAddress err == Just addr ]) (transportOpen socketTransportOptions addr) fdcountAfter <- countFileDescriptors liftIO (fdcountBefore @=? fdcountAfter) suite_OpenTcp :: TestTree suite_OpenTcp = testGroup "tcp" [ test_OpenTcp_IPv4 , test_OpenTcp_IPv6 , test_OpenTcp_Unknown , test_OpenTcp_NoPort , test_OpenTcp_InvalidPort , test_OpenTcp_NoUsableAddresses , test_OpenTcp_NotListening ] test_OpenTcp_IPv4 :: TestTree test_OpenTcp_IPv4 = testCase "ipv4" $ runResourceT $ do (addr, _, _) <- listenRandomIPv4 fdcountBefore <- countFileDescriptors t <- liftIO (transportOpen socketTransportOptions addr) liftIO (transportClose t) fdcountAfter <- countFileDescriptors liftIO (fdcountBefore @=? fdcountAfter) test_OpenTcp_IPv6 :: TestTree test_OpenTcp_IPv6 = testCase "ipv6" $ unlessM noIPv6 $ runResourceT $ do addr <- listenRandomIPv6 fdcountBefore <- countFileDescriptors t <- liftIO (transportOpen socketTransportOptions addr) liftIO (transportClose t) fdcountAfter <- countFileDescriptors liftIO (fdcountBefore @=? fdcountAfter) test_OpenTcp_Unknown :: TestTree test_OpenTcp_Unknown = testCase "unknown-family" $ do fdcountBefore <- countFileDescriptors let Just addr = address "tcp" (Map.fromList [ ("family", "noexist") , ("port", "1234") ]) assertException ((transportError "Unknown socket family for TCP transport: \"noexist\"") { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) fdcountAfter <- countFileDescriptors fdcountBefore @=? fdcountAfter test_OpenTcp_NoPort :: TestTree test_OpenTcp_NoPort = testCase "no-port" $ do fdcountBefore <- countFileDescriptors let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") ]) assertException ((transportError "TCP transport requires the `port' parameter.") { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) fdcountAfter <- countFileDescriptors fdcountBefore @=? fdcountAfter test_OpenTcp_InvalidPort :: TestTree test_OpenTcp_InvalidPort = testCase "invalid-port" $ do fdcountBefore <- countFileDescriptors let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") , ("port", "123456") ]) assertException ((transportError "Invalid socket port for TCP transport: \"123456\"") { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) fdcountAfter <- countFileDescriptors fdcountBefore @=? fdcountAfter test_OpenTcp_NoUsableAddresses :: TestTree test_OpenTcp_NoUsableAddresses = testCase "no-usable-addresses" $ do fdcountBefore <- countFileDescriptors let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") , ("port", "1234") , ("host", "256.256.256.256") ]) assertThrows (\err -> and [ "getAddrInfo" `isInfixOf` transportErrorMessage err , "does not exist" `isInfixOf` transportErrorMessage err , transportErrorAddress err == Just addr ]) (transportOpen socketTransportOptions addr) fdcountAfter <- countFileDescriptors fdcountBefore @=? fdcountAfter test_OpenTcp_NotListening :: TestTree test_OpenTcp_NotListening = testCase "not-listening" $ runResourceT $ do fdcountBefore <- countFileDescriptors (addr, _, key) <- listenRandomIPv4 release key liftIO $ assertThrows (\err -> and [ "Connection refused" `isInfixOf` transportErrorMessage err , transportErrorAddress err == Just addr ]) (transportOpen socketTransportOptions addr) fdcountAfter <- countFileDescriptors liftIO (fdcountBefore @=? fdcountAfter) test_TransportSendReceive :: TestTree test_TransportSendReceive = testCase "send-receive" $ runResourceT $ do (addr, networkSocket, _) <- listenRandomIPv4 -- a simple echo server, which sends back anything it receives. _ <- liftIO $ forkIO $ do (s, _) <- NS.accept networkSocket fix $ \loop -> do bytes <- recv s 50 if Data.ByteString.null bytes then NS.close s else do sendAll s bytes loop (_, t) <- allocate (transportOpen socketTransportOptions addr) transportClose -- small chunks of data are combined do var <- forkVar (transportGet t 3) liftIO (transportPut t "1") liftIO (transportPut t "2") liftIO (transportPut t "3") bytes <- liftIO (readMVar var) liftIO (bytes @?= "123") -- large chunks of data are read in full do let sentBytes = Data.ByteString.replicate (4096 * 100) 0 var <- forkVar (transportGet t (4096 * 100)) liftIO (transportPut t sentBytes) bytes <- liftIO (readMVar var) liftIO (bytes @?= sentBytes) test_HandleLostConnection :: TestTree test_HandleLostConnection = testCase "handle-lost-connection" $ runResourceT $ do (addr, networkSocket, _) <- listenRandomIPv4 _ <- liftIO $ forkIO $ do (s, _) <- NS.accept networkSocket sendAll s "123" NS.close s (_, t) <- allocate (transportOpen socketTransportOptions addr) transportClose bytes <- liftIO (transportGet t 4) liftIO (bytes @?= "123") test_ListenUnknown :: TestTree test_ListenUnknown = testCase "unknown" $ do let Just addr = address "noexist" Map.empty assertException ((transportError "Unknown address method: \"noexist\"") { transportErrorAddress = Just addr }) (transportListen socketTransportOptions addr) suite_ListenUnix :: TestTree suite_ListenUnix = testGroup "unix" [ test_ListenUnix_Path , test_ListenUnix_Abstract , test_ListenUnix_Tmpdir , test_ListenUnix_TooFew , test_ListenUnix_TooMany , test_ListenUnix_InvalidBind ] test_ListenUnix_Path :: TestTree test_ListenUnix_Path = testCase "path" $ runResourceT $ do (_, path) <- allocate getTempPath removeFile let Just addr = address "unix" (Map.fromList [ ("path", path) ]) (_, l) <- allocate (transportListen socketTransportOptions addr) transportListenerClose -- listener address is random, so it can't be checked directly. let addrParams = addressParameters (transportListenerAddress l) liftIO (Map.keys addrParams @=? ["guid", "path"]) liftIO (Map.lookup "path" addrParams @?= Just path) test_ListenUnix_Abstract :: TestTree test_ListenUnix_Abstract = testCase "abstract" $ runResourceT $ do path <- liftIO getTempPath let Just addr = address "unix" (Map.fromList [ ("abstract", path) ]) (_, l) <- allocate (transportListen socketTransportOptions addr) transportListenerClose -- listener address is random, so it can't be checked directly. let addrParams = addressParameters (transportListenerAddress l) liftIO (Map.keys addrParams @?= ["abstract", "guid"]) liftIO (Map.lookup "abstract" addrParams @?= Just path) test_ListenUnix_Tmpdir :: TestTree test_ListenUnix_Tmpdir = testCase "tmpdir" $ runResourceT $ do tmpdir <- liftIO getTemporaryDirectory let Just addr = address "unix" (Map.fromList [ ("tmpdir", tmpdir) ]) (_, l) <- allocate (transportListen socketTransportOptions addr) transportListenerClose -- listener address is random, so it can't be checked directly. let addrKeys = Map.keys (addressParameters (transportListenerAddress l)) liftIO $ assertBool "invalid keys" ("path" `elem` addrKeys || "abstract" `elem` addrKeys) test_ListenUnix_TooFew :: TestTree test_ListenUnix_TooFew = testCase "too-few" $ do let Just addr = address "unix" Map.empty assertException ((transportError "One of 'abstract', 'path', or 'tmpdir' must be specified for the 'unix' transport.") { transportErrorAddress = Just addr }) (transportListen socketTransportOptions addr) test_ListenUnix_TooMany :: TestTree test_ListenUnix_TooMany = testCase "too-many" $ do let Just addr = address "unix" (Map.fromList [ ("path", "foo") , ("abstract", "bar") ]) assertException ((transportError "Only one of 'abstract', 'path', or 'tmpdir' may be specified for the 'unix' transport.") { transportErrorAddress = Just addr }) (transportListen socketTransportOptions addr) test_ListenUnix_InvalidBind :: TestTree test_ListenUnix_InvalidBind = testCase "invalid-bind" $ do fdcountBefore <- countFileDescriptors let Just addr = address "unix" (Map.fromList [ ("path", "/") ]) assertThrows (\err -> and [ "Permission denied" `isInfixOf` transportErrorMessage err , transportErrorAddress err == Just addr ]) (transportListen socketTransportOptions addr) fdcountAfter <- countFileDescriptors fdcountBefore @=? fdcountAfter suite_ListenTcp :: TestTree suite_ListenTcp = testGroup "tcp" [ test_ListenTcp_IPv4 , test_ListenTcp_IPv6 , test_ListenTcp_Unknown , test_ListenTcp_InvalidPort , test_ListenTcp_InvalidBind ] test_ListenTcp_IPv4 :: TestTree test_ListenTcp_IPv4 = testCase "ipv4" $ runResourceT $ do let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") ]) (_, l) <- allocate (transportListen socketTransportOptions addr) transportListenerClose let params = addressParameters (transportListenerAddress l) liftIO (Map.lookup "family" params @?= Just "ipv4") liftIO $ assertBool "no port" ("port" `elem` Map.keys params) test_ListenTcp_IPv6 :: TestTree test_ListenTcp_IPv6 = testCase "ipv6" $ unlessM noIPv6 $ runResourceT $ do let Just addr = address "tcp" (Map.fromList [ ("family", "ipv6") ]) (_, l) <- allocate (transportListen socketTransportOptions addr) transportListenerClose let params = addressParameters (transportListenerAddress l) liftIO (Map.lookup "family" params @?= Just "ipv6") liftIO $ assertBool "no port" ("port" `elem` Map.keys params) test_ListenTcp_Unknown :: TestTree test_ListenTcp_Unknown = testCase "unknown-family" $ do let Just addr = address "tcp" (Map.fromList [ ("family", "noexist") , ("port", "1234") ]) assertException ((transportError "Unknown socket family for TCP transport: \"noexist\"") { transportErrorAddress = Just addr }) (transportListen socketTransportOptions addr) test_ListenTcp_InvalidPort :: TestTree test_ListenTcp_InvalidPort = testCase "invalid-port" $ do let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") , ("port", "123456") ]) assertException ((transportError "Invalid socket port for TCP transport: \"123456\"") { transportErrorAddress = Just addr }) (transportListen socketTransportOptions addr) test_ListenTcp_InvalidBind :: TestTree test_ListenTcp_InvalidBind = testCase "invalid-bind" $ do fdcountBefore <- countFileDescriptors let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") , ("port", "1") ]) assertThrows (\err -> and [ "Permission denied" `isInfixOf` transportErrorMessage err , transportErrorAddress err == Just addr ]) (transportListen socketTransportOptions addr) fdcountAfter <- countFileDescriptors fdcountBefore @=? fdcountAfter test_AcceptSocket :: TestTree test_AcceptSocket = testCase "socket" $ runResourceT $ do path <- liftIO getTempPath let Just addr = address "unix" (Map.fromList [ ("abstract", path) ]) (_, listener) <- allocate (transportListen socketTransportOptions addr) transportListenerClose acceptedVar <- forkVar (transportAccept listener) openedVar <- forkVar (transportOpen socketTransportOptions addr) (_, accepted) <- allocate (readMVar acceptedVar) transportClose (_, opened) <- allocate (readMVar openedVar) transportClose liftIO (transportPut opened "testing") bytes <- liftIO (transportGet accepted 7) liftIO (bytes @?= "testing") test_AcceptSocketClosed :: TestTree test_AcceptSocketClosed = testCase "socket-closed" $ do path <- getTempPath let Just addr = address "unix" (Map.fromList [ ("abstract", path) ]) listener <- transportListen socketTransportOptions addr let listeningAddr = transportListenerAddress listener transportListenerClose listener assertThrows (\err -> and [ "accept" `isInfixOf` transportErrorMessage err , transportErrorAddress err == Just listeningAddr ]) (transportAccept listener) socketTransportOptions :: TransportOptions SocketTransport socketTransportOptions = transportDefaultOptions dbus-1.2.29/tests/DBusTests/Util.hs0000644000000000000000000002260414263302757015240 0ustar0000000000000000-- Copyright (C) 2010-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.Util ( assertVariant , assertValue , assertAtom , assertException , assertThrows , getTempPath , listenRandomUnixPath , listenRandomUnixAbstract , listenRandomIPv4 , listenRandomIPv6 , noIPv6 , forkVar , withEnv , countFileDescriptors , dropWhileEnd , halfSized , clampedSize , smallListOf , smallListOf1 , DBusTests.Util.requireLeft , DBusTests.Util.requireRight ) where import Control.Concurrent import Control.Exception (Exception, IOException, try, bracket, bracket_) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Resource import Data.Bits ((.&.)) import Data.Char (chr) import System.Directory (getTemporaryDirectory, removeFile) import System.FilePath (()) import Test.QuickCheck hiding ((.&.)) import Test.Tasty.HUnit import qualified Data.ByteString import qualified Data.ByteString.Lazy import qualified Data.Map as Map import qualified Data.Text as T import qualified Network.Socket as NS import qualified System.Posix as Posix import DBus import DBus.Internal.Types assertVariant :: (Eq a, Show a, IsVariant a) => Type -> a -> Test.Tasty.HUnit.Assertion assertVariant t a = do t @=? variantType (toVariant a) Just a @=? fromVariant (toVariant a) toVariant a @=? toVariant a assertValue :: (Eq a, Show a, IsValue a) => Type -> a -> Test.Tasty.HUnit.Assertion assertValue t a = do t @=? DBus.typeOf a t @=? DBus.Internal.Types.typeOf a t @=? valueType (toValue a) fromValue (toValue a) @?= Just a toValue a @=? toValue a assertVariant t a assertAtom :: (Eq a, Show a, IsAtom a) => Type -> a -> Test.Tasty.HUnit.Assertion assertAtom t a = do t @=? (atomType (toAtom a)) fromAtom (toAtom a) @?= (Just a) toAtom a @=? toAtom a assertValue t a getTempPath :: IO String getTempPath = do tmp <- getTemporaryDirectory uuid <- randomUUID return (tmp formatUUID uuid) listenRandomUnixPath :: MonadResource m => m Address listenRandomUnixPath = do path <- liftIO getTempPath let sockAddr = NS.SockAddrUnix path (_, sock) <- allocate (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol) NS.close liftIO (NS.bind sock sockAddr) liftIO (NS.listen sock 1) _ <- register (removeFile path) let Just addr = address "unix" (Map.fromList [ ("path", path) ]) return addr listenRandomUnixAbstract :: MonadResource m => m (Address, ReleaseKey) listenRandomUnixAbstract = do uuid <- liftIO randomUUID let sockAddr = NS.SockAddrUnix ('\x00' : formatUUID uuid) (key, sock) <- allocate (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol) NS.close liftIO $ NS.bind sock sockAddr liftIO $ NS.listen sock 1 let Just addr = address "unix" (Map.fromList [ ("abstract", formatUUID uuid) ]) return (addr, key) listenRandomIPv4 :: MonadResource m => m (Address, NS.Socket, ReleaseKey) listenRandomIPv4 = do let hints = NS.defaultHints { NS.addrFlags = [NS.AI_NUMERICHOST] , NS.addrFamily = NS.AF_INET , NS.addrSocketType = NS.Stream } hostAddr <- liftIO $ NS.getAddrInfo (Just hints) (Just "127.0.0.1") Nothing let sockAddr = NS.addrAddress $ head hostAddr (key, sock) <- allocate (NS.socket NS.AF_INET NS.Stream NS.defaultProtocol) NS.close liftIO $ NS.bind sock sockAddr liftIO $ NS.listen sock 1 sockPort <- liftIO $ NS.socketPort sock let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") , ("host", "localhost") , ("port", show (toInteger sockPort)) ]) return (addr, sock, key) listenRandomIPv6 :: MonadResource m => m Address listenRandomIPv6 = do addrs <- liftIO $ NS.getAddrInfo Nothing (Just "::1") Nothing let sockAddr = case addrs of [] -> error "listenRandomIPv6: no address for localhost?" a:_ -> NS.addrAddress a (_, sock) <- allocate (NS.socket NS.AF_INET6 NS.Stream NS.defaultProtocol) NS.close liftIO $ NS.bind sock sockAddr liftIO $ NS.listen sock 1 sockPort <- liftIO $ NS.socketPort sock let Just addr = address "tcp" (Map.fromList [ ("family", "ipv6") , ("host", "::1") , ("port", show (toInteger sockPort)) ]) return addr noIPv6 :: IO Bool noIPv6 = do tried <- try (NS.getAddrInfo Nothing (Just "::1") Nothing) case (tried :: Either IOException [NS.AddrInfo]) of Left _ -> return True Right addrs -> return (null addrs) forkVar :: MonadIO m => IO a -> m (MVar a) forkVar io = liftIO $ do var <- newEmptyMVar _ <- forkIO (io >>= putMVar var) return var withEnv :: MonadIO m => String -> Maybe String -> IO a -> m a withEnv name value io = liftIO $ do let set val = case val of Just x -> Posix.setEnv name x True Nothing -> Posix.unsetEnv name old <- Posix.getEnv name bracket_ (set value) (set old) io countFileDescriptors :: MonadIO m => m Int countFileDescriptors = liftIO io where io = do pid <- Posix.getProcessID let fdDir = "/proc/" ++ show pid ++ "/fd" bracket (Posix.openDirStream fdDir) Posix.closeDirStream countDirEntries countDirEntries dir = loop 0 where loop n = do name <- Posix.readDirStream dir if null name then return n else loop (n + 1) halfSized :: Gen a -> Gen a halfSized gen = sized (\n -> if n > 0 then resize (div n 2) gen else gen) smallListOf :: Gen a -> Gen [a] smallListOf gen = clampedSize 10 (listOf gen) smallListOf1 :: Gen a -> Gen [a] smallListOf1 gen = clampedSize 10 (listOf1 gen) clampedSize :: Int -> Gen a -> Gen a clampedSize maxN gen = sized (\n -> resize (min n maxN) gen) instance Arbitrary T.Text where arbitrary = fmap T.pack genUnicode genUnicode :: Gen [Char] genUnicode = string where string = sized $ \n -> do k <- choose (0,n) sequence [ char | _ <- [1..k] ] excluding :: [a -> Bool] -> Gen a -> Gen a excluding bad gen = loop where loop = do x <- gen if or (map ($ x) bad) then loop else return x reserved = [lowSurrogate, highSurrogate, noncharacter] lowSurrogate c = c >= 0xDC00 && c <= 0xDFFF highSurrogate c = c >= 0xD800 && c <= 0xDBFF noncharacter c = masked == 0xFFFE || masked == 0xFFFF where masked = c .&. 0xFFFF ascii = choose (0x20, 0x7F) plane0 = choose (0xF0, 0xFFFF) plane1 = oneof [ choose (0x10000, 0x10FFF) , choose (0x11000, 0x11FFF) , choose (0x12000, 0x12FFF) , choose (0x13000, 0x13FFF) , choose (0x1D000, 0x1DFFF) , choose (0x1F000, 0x1FFFF) ] plane2 = oneof [ choose (0x20000, 0x20FFF) , choose (0x21000, 0x21FFF) , choose (0x22000, 0x22FFF) , choose (0x23000, 0x23FFF) , choose (0x24000, 0x24FFF) , choose (0x25000, 0x25FFF) , choose (0x26000, 0x26FFF) , choose (0x27000, 0x27FFF) , choose (0x28000, 0x28FFF) , choose (0x29000, 0x29FFF) , choose (0x2A000, 0x2AFFF) , choose (0x2B000, 0x2BFFF) , choose (0x2F000, 0x2FFFF) ] plane14 = choose (0xE0000, 0xE0FFF) planes = [ascii, plane0, plane1, plane2, plane14] char = chr `fmap` excluding reserved (oneof planes) instance Arbitrary Data.ByteString.ByteString where arbitrary = fmap Data.ByteString.pack arbitrary instance Arbitrary Data.ByteString.Lazy.ByteString where arbitrary = fmap Data.ByteString.Lazy.fromChunks arbitrary dropWhileEnd :: (Char -> Bool) -> String -> String dropWhileEnd p = T.unpack . T.dropWhileEnd p . T.pack requireLeft :: Show b => Either a b -> IO a requireLeft (Left a) = return a requireLeft (Right b) = assertFailure ("Right " ++ show b ++ " is not Left") >> undefined requireRight :: Show a => Either a b -> IO b requireRight (Right b) = return b requireRight (Left a) = assertFailure ("Left " ++ show a ++ " is not Right") >> undefined assertException :: (Eq e, Exception e) => e -> IO a -> Test.Tasty.HUnit.Assertion assertException e f = do result <- try f case result of Left ex -> ex @?= e Right _ -> assertFailure "expected exception not thrown" assertThrows :: Exception e => (e -> Bool) -> IO a -> Test.Tasty.HUnit.Assertion assertThrows check f = do result <- try f case result of Left ex -> assertBool ("unexpected exception " ++ show ex) (check ex) Right _ -> assertFailure "expected exception not thrown" dbus-1.2.29/tests/DBusTests/Variant.hs0000644000000000000000000001456014263302757015731 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- Copyright (C) 2010-2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.Variant (test_Variant) where import Test.Tasty import Test.Tasty.HUnit import Data.Int (Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64) import System.Posix.Types (Fd) import qualified Data.ByteString import qualified Data.ByteString.Lazy import qualified Data.Map import qualified Data.Text import qualified Data.Text as T import qualified Data.Text.Lazy import qualified Data.Vector import DBus import DBus.Internal.Types (toValue) import DBusTests.Util test_Variant :: TestTree test_Variant = testGroup "Variant" [ test_IsAtom , test_IsValue , test_Show , test_ByteStorage ] test_IsAtom :: TestTree test_IsAtom = testCase "IsAtom" $ do assertAtom TypeBoolean True assertAtom TypeWord8 (0 :: Word8) assertAtom TypeWord16 (0 :: Word16) assertAtom TypeWord32 (0 :: Word32) assertAtom TypeWord64 (0 :: Word64) assertAtom TypeInt16 (0 :: Int16) assertAtom TypeInt32 (0 :: Int32) assertAtom TypeInt64 (0 :: Int64) assertAtom TypeDouble (0 :: Double) assertAtom TypeUnixFd (0 :: Fd) assertAtom TypeString (Data.Text.pack "") assertAtom TypeString (Data.Text.Lazy.pack "") assertAtom TypeString ("" :: String) assertAtom TypeObjectPath (objectPath_ "/") assertAtom TypeSignature (signature_ []) test_IsValue :: TestTree test_IsValue = testCase "IsValue" $ do assertValue TypeVariant (toVariant True) assertValue (TypeArray TypeBoolean) [True] assertValue (TypeArray TypeBoolean) (Data.Vector.fromList [True]) assertValue (TypeArray TypeWord8) Data.ByteString.empty assertValue (TypeArray TypeWord8) Data.ByteString.Lazy.empty assertValue (TypeDictionary TypeBoolean TypeBoolean) (Data.Map.fromList [(True, True)]) assertValue (TypeStructure (replicate 2 TypeBoolean)) (True, True) assertValue (TypeStructure (replicate 3 TypeBoolean)) (True, True, True) assertValue (TypeStructure (replicate 4 TypeBoolean)) (True, True, True, True) assertValue (TypeStructure (replicate 5 TypeBoolean)) (True, True, True, True, True) assertValue (TypeStructure (replicate 6 TypeBoolean)) (True, True, True, True, True, True) assertValue (TypeStructure (replicate 7 TypeBoolean)) (True, True, True, True, True, True, True) assertValue (TypeStructure (replicate 8 TypeBoolean)) (True, True, True, True, True, True, True, True) assertValue (TypeStructure (replicate 9 TypeBoolean)) (True, True, True, True, True, True, True, True, True) assertValue (TypeStructure (replicate 10 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True) assertValue (TypeStructure (replicate 11 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True) assertValue (TypeStructure (replicate 12 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True, True) assertValue (TypeStructure (replicate 13 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True, True, True) assertValue (TypeStructure (replicate 14 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True, True, True, True) assertValue (TypeStructure (replicate 15 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True, True, True, True, True) test_Show :: TestTree test_Show = testCase "show" $ do "Variant True" @=? show (toVariant True) "Variant 0" @=? show (toVariant (0 :: Word8)) "Variant 0" @=? show (toVariant (0 :: Word16)) "Variant 0" @=? show (toVariant (0 :: Word32)) "Variant 0" @=? show (toVariant (0 :: Word64)) "Variant 0" @=? show (toVariant (0 :: Int16)) "Variant 0" @=? show (toVariant (0 :: Int32)) "Variant 0" @=? show (toVariant (0 :: Int64)) "Variant 0.1" @=? show (toVariant (0.1 :: Double)) "Variant (UnixFd 1)" @=? show (toVariant (1 :: Fd)) "Variant \"\"" @=? show (toVariant (T.pack "")) "Variant (ObjectPath \"/\")" @=? show (toVariant (objectPath_ "/")) "Variant (Signature \"\")" @=? show (toVariant (signature_ [])) "Variant (Variant True)" @=? show (toVariant (toVariant True)) "Variant [True, False]" @=? show (toVariant [True, False]) "Variant b\"\"" @=? show (toVariant Data.ByteString.empty) "Variant b\"\"" @=? show (toVariant Data.ByteString.Lazy.empty) "Variant b\"\"" @=? show (toVariant ([] :: [Word8])) "(Variant {False: True, True: False})" @=? showsPrec 11 (toVariant (Data.Map.fromList [(True, False), (False, True)])) "" "(Variant (True, False))" @=? showsPrec 11 (toVariant (True, False)) "" test_ByteStorage :: TestTree test_ByteStorage = testCase "byte-storage" $ do -- Vector Word8 -> Vector Word8 toValue (Data.Vector.fromList [0 :: Word8]) @=? toValue (Data.Vector.fromList [0 :: Word8]) -- Vector Word8 -> ByteString toValue (Data.Vector.fromList [0 :: Word8]) @=? toValue (Data.ByteString.pack [0]) -- Vector Word8 -> Lazy.ByteString toValue (Data.Vector.fromList [0 :: Word8]) @=? toValue (Data.ByteString.Lazy.pack [0]) -- ByteString -> Vector Word8 toValue (Data.ByteString.pack [0]) @=? toValue (Data.Vector.fromList [0 :: Word8]) -- ByteString -> ByteString toValue (Data.ByteString.pack [0]) @=? toValue (Data.ByteString.pack [0]) -- ByteString -> Lazy.ByteString toValue (Data.ByteString.pack [0]) @=? toValue (Data.ByteString.Lazy.pack [0]) -- Lazy.ByteString -> Vector Word8 toValue (Data.ByteString.Lazy.pack [0]) @=? toValue (Data.Vector.fromList [0 :: Word8]) -- Lazy.ByteString -> ByteString toValue (Data.ByteString.Lazy.pack [0]) @=? toValue (Data.ByteString.pack [0]) -- Lazy.ByteString -> Lazy.ByteString toValue (Data.ByteString.Lazy.pack [0]) @=? toValue (Data.ByteString.Lazy.pack [0]) dbus-1.2.29/tests/DBusTests/Wire.hs0000644000000000000000000000246714263302757015236 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2012 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module DBusTests.Wire (test_Wire) where import Data.Either import Test.Tasty import Test.Tasty.HUnit import qualified Data.ByteString.Char8 () import DBus test_Wire :: TestTree test_Wire = testGroup "Wire" $ [ test_Unmarshal ] test_Unmarshal :: TestTree test_Unmarshal = testGroup "unmarshal" [ test_UnmarshalUnexpectedEof ] test_UnmarshalUnexpectedEof :: TestTree test_UnmarshalUnexpectedEof = testCase "unexpected-eof" $ do let unmarshaled = unmarshal "0" assertBool "invalid unmarshalled parse" (isLeft unmarshaled) let Left err = unmarshaled unmarshalErrorMessage err @=? "Unexpected end of input while parsing message header." dbus-1.2.29/benchmarks/DBusBenchmarks.hs0000644000000000000000000000674414263302757016260 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2010-2011 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module Main (benchmarks, main) where import Criterion.Types import Data.Word (Word32) import Unsafe.Coerce (unsafeCoerce) import qualified Criterion.Main import DBus serial :: Word32 -> Serial serial = unsafeCoerce -- FIXME: should the Serial constructor be exposed to -- clients? empty_MethodCall :: MethodCall empty_MethodCall = methodCall "/" "org.i" "m" empty_MethodReturn :: MethodReturn empty_MethodReturn = methodReturn (serial 0) benchMarshal :: Message msg => String -> msg -> Benchmark benchMarshal name msg = bench name (whnf (marshal LittleEndian (serial 0)) msg) benchUnmarshal :: Message msg => String -> msg -> Benchmark benchUnmarshal name msg = bench name (whnf unmarshal bytes) where Right bytes = marshal LittleEndian (serial 0) msg parseSig :: String -> Maybe Signature parseSig = parseSignature benchmarks :: [Benchmark] benchmarks = [ bgroup "Types" [ bgroup "Signature" [ bench "parseSignature/small" (nf parseSig "y") , bench "parseSignature/medium" (nf parseSig "yyyyuua(yv)") , bench "parseSignature/large" (nf parseSig "a{s(asiiiiasa(siiia{s(iiiiv)}))}") ] , bgroup "ObjectPath" [ bench "objectPath_/small" (nf objectPath_ "/") , bench "objectPath_/medium" (nf objectPath_ "/foo/bar") , bench "objectPath_/large" (nf objectPath_ "/f0OO/b4R/baz_qux/blahblahblah") ] , bgroup "InterfaceName" [ bench "interfaceName_/small" (nf interfaceName_ "f.b") , bench "interfaceName_/medium" (nf interfaceName_ "foo.bar.baz") , bench "interfaceName_/large" (nf interfaceName_ "f0OOO.b4R.baz_qux.blahblahblah") ] , bgroup "MemberName" [ bench "memberName_/small" (nf memberName_ "f") , bench "memberName_/medium" (nf memberName_ "FooBar") , bench "memberName_/large" (nf memberName_ "f0OOOb4RBazQuxBlahBlahBlah") ] , bgroup "ErrorName" [ bench "errorName_/small" (nf errorName_ "f.b") , bench "errorName_/medium" (nf errorName_ "foo.bar.baz") , bench "errorName_/large" (nf errorName_ "f0OOO.b4R.baz_qux.blahblahblah") ] , bgroup "BusName" [ bench "busName_/small" (nf busName_ "f.b") , bench "busName_/medium" (nf busName_ "foo.bar.baz") , bench "busName_/large" (nf busName_ "f0OOO.b4R.baz-qux.blahblahblah") ] ] , bgroup "Marshal" [ benchMarshal "MethodCall/empty" empty_MethodCall , benchMarshal "MethodReturn/empty" empty_MethodReturn ] , bgroup "Unmarshal" [ benchUnmarshal "MethodCall/empty" empty_MethodCall , benchUnmarshal "MethodReturn/empty" empty_MethodReturn ] ] main :: IO () main = Criterion.Main.defaultMain benchmarks dbus-1.2.29/license.txt0000644000000000000000000002613614263302757013134 0ustar0000000000000000 Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright [yyyy] [name of copyright owner] Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. dbus-1.2.29/Setup.hs0000644000000000000000000000005614263302757012376 0ustar0000000000000000import Distribution.Simple main = defaultMain dbus-1.2.29/dbus.cabal0000644000000000000000000001072214441700757012664 0ustar0000000000000000name: dbus version: 1.2.29 license: Apache-2.0 license-file: license.txt author: John Millikin maintainer: Andrey Sverdlichenko build-type: Simple cabal-version: >= 1.10 category: Network, Desktop stability: experimental homepage: https://github.com/rblaze/haskell-dbus#readme synopsis: A client library for the D-Bus IPC system. description: D-Bus is a simple, message-based protocol for inter-process communication, which allows applications to interact with other parts of the machine and the user's session using remote procedure calls. . D-Bus is a essential part of the modern Linux desktop, where it replaces earlier protocols such as CORBA and DCOP. . This library is an implementation of the D-Bus protocol in Haskell. It can be used to add D-Bus support to Haskell applications, without the awkward interfaces common to foreign bindings. . Example: connect to the session bus, and get a list of active names. . @ {-\# LANGUAGE OverloadedStrings \#-} . import Data.List (sort) import DBus import DBus.Client . main = do client <- connectSession -- Request a list of connected clients from the bus reply <- call_ client (methodCall \"\/org\/freedesktop\/DBus\" \"org.freedesktop.DBus\" \"ListNames\") { methodCallDestination = Just \"org.freedesktop.DBus\" } -- org.freedesktop.DBus.ListNames() returns a single value, which is -- a list of names (here represented as [String]) let Just names = fromVariant (methodReturnBody reply !! 0) -- Print each name on a line, sorted so reserved names are below -- temporary names. mapM_ putStrLn (sort names) @ . >$ ghc --make list-names.hs >$ ./list-names >:1.0 >:1.1 >:1.10 >:1.106 >:1.109 >:1.110 >ca.desrt.dconf >org.freedesktop.DBus >org.freedesktop.Notifications >org.freedesktop.secrets >org.gnome.ScreenSaver extra-source-files: examples/dbus-monitor.hs examples/export.hs examples/introspect.hs examples/list-names.hs idlxml/dbus.xml source-repository head type: git location: https://github.com/rblaze/haskell-dbus library default-language: Haskell2010 ghc-options: -W -Wall hs-source-dirs: lib build-depends: base >=4.16 && <5 , bytestring < 0.12 , cereal < 0.6 , conduit >= 1.3.0 && < 1.4 , containers < 0.7 , deepseq < 1.5 , exceptions < 0.11 , filepath < 1.5 , lens < 5.3 , network >= 3.1.2.1 && < 3.2 , parsec < 3.2 , random < 1.3 , split < 0.3 , template-haskell >= 2.18 && < 2.21 , text < 2.1 , th-lift < 0.9 , transformers < 0.7 , unix < 2.9 , vector < 0.14 , xml-conduit >= 1.9.0.0 && < 1.10.0.0 , xml-types < 0.4 exposed-modules: DBus DBus.Client DBus.Generation DBus.Internal.Address DBus.Internal.Message DBus.Internal.Types DBus.Internal.Wire DBus.Introspection DBus.Introspection.Parse DBus.Introspection.Render DBus.Introspection.Types DBus.Socket DBus.TH DBus.Transport test-suite dbus_tests type: exitcode-stdio-1.0 main-is: DBusTests.hs hs-source-dirs: tests default-language: Haskell2010 ghc-options: -W -Wall -fno-warn-orphans build-depends: dbus , base >=4 && <5 , bytestring < 0.12 , cereal < 0.6 , containers < 0.7 , directory < 1.4 , extra < 1.8 , filepath < 1.5 , network >= 3.1.2.1 && < 3.2 , parsec < 3.2 , process < 1.7 , QuickCheck < 2.15 , random < 1.3 , resourcet < 1.4 , tasty < 1.5 , tasty-hunit < 0.11 , tasty-quickcheck < 0.11 , text < 2.1 , transformers < 0.7 , unix < 2.9 , vector < 0.14 other-modules: DBusTests.Address DBusTests.BusName DBusTests.Client DBusTests.ErrorName DBusTests.Generation DBusTests.Integration DBusTests.InterfaceName DBusTests.Introspection DBusTests.MemberName DBusTests.Message DBusTests.ObjectPath DBusTests.Serialization DBusTests.Signature DBusTests.Socket DBusTests.TH DBusTests.Transport DBusTests.Util DBusTests.Variant DBusTests.Wire benchmark dbus_benchmarks type: exitcode-stdio-1.0 main-is: DBusBenchmarks.hs hs-source-dirs: benchmarks default-language: Haskell2010 ghc-options: -Wall -fno-warn-orphans build-depends: dbus , base >=4 && <5 , criterion < 1.7 dbus-1.2.29/examples/dbus-monitor.hs0000644000000000000000000002134014263302757015535 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2009-2011 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module Main (main) where import Control.Monad import Data.List (intercalate) import Data.Int import Data.Word import System.Environment import System.Exit import System.IO import System.Console.GetOpt import DBus import DBus.Socket data Bus = Session | System deriving (Show) data Option = BusOption Bus | AddressOption String deriving (Show) optionInfo :: [OptDescr Option] optionInfo = [ Option [] ["session"] (NoArg (BusOption Session)) "Monitor the session message bus. (default)" , Option [] ["system"] (NoArg (BusOption System)) "Monitor the system message bus." , Option [] ["address"] (ReqArg AddressOption "ADDRESS") "Connect to a particular bus address." ] usage :: String -> String usage name = "Usage: " ++ name ++ " [OPTION...]" findSocket :: [Option] -> IO Socket findSocket opts = getAddress opts >>= open where session = do got <- getSessionAddress case got of Just addr -> return addr Nothing -> error "DBUS_SESSION_BUS_ADDRESS is not a valid address" system = do got <- getSystemAddress case got of Just addr -> return addr Nothing -> error "DBUS_SYSTEM_BUS_ADDRESS is not a valid address" getAddress [] = session getAddress ((BusOption Session):_) = session getAddress ((BusOption System):_) = system getAddress ((AddressOption addr):_) = case parseAddress addr of Nothing -> error (show addr ++ " is not a valid address") Just parsed -> return parsed addMatch :: Socket -> String -> IO () addMatch sock match = send sock (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "AddMatch") { methodCallDestination = Just "org.freedesktop.DBus" , methodCallBody = [toVariant match] } (\_ -> return ()) defaultFilters :: [String] defaultFilters = [ "type='signal',eavesdrop=true" , "type='method_call',eavesdrop=true" , "type='method_return',eavesdrop=true" , "type='error',eavesdrop=true" ] main :: IO () main = do args <- getArgs let (options, userFilters, errors) = getOpt Permute optionInfo args unless (null errors) $ do name <- getProgName hPutStrLn stderr (concat errors) hPutStrLn stderr (usageInfo (usage name) optionInfo) exitFailure sock <- findSocket options send sock (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "Hello") { methodCallDestination = Just "org.freedesktop.DBus" } (\_ -> return ()) mapM_ (addMatch sock) (if null userFilters then defaultFilters else userFilters) forever $ do received <- receive sock putStrLn (formatMessage received ++ "\n") -- Message formatting is verbose and mostly uninteresting, except as an -- excersise in string manipulation. formatMessage :: ReceivedMessage -> String -- Method call formatMessage (ReceivedMethodCall serial msg) = concat [ "method call" , " sender=" , maybe "(null)" formatBusName (methodCallSender msg) , " -> dest=" , maybe "(null)" formatBusName (methodCallDestination msg) , " serial=" , show (serialValue serial) , " path=" , formatObjectPath (methodCallPath msg) , "; interface=" , maybe "(null)" formatInterfaceName (methodCallInterface msg) , "; member=" , formatMemberName (methodCallMember msg) , formatBody (methodCallBody msg) ] -- Method return formatMessage (ReceivedMethodReturn _ msg) = concat [ "method return" , " sender=" , maybe "(null)" formatBusName (methodReturnSender msg) , " -> dest=" , maybe "(null)" formatBusName (methodReturnDestination msg) , " reply_serial=" , show (serialValue (methodReturnSerial msg)) , formatBody (methodReturnBody msg) ] -- Method error formatMessage (ReceivedMethodError _ msg) = concat [ "error" , " sender=" , maybe "(null)" formatBusName (methodErrorSender msg) , " -> dest=" , maybe "(null)" formatBusName (methodErrorDestination msg) , " error_name=" , formatErrorName (methodErrorName msg) , " reply_serial=" , show (serialValue (methodErrorSerial msg)) , formatBody (methodErrorBody msg) ] -- Signal formatMessage (ReceivedSignal serial msg) = concat [ "signal" , " sender=" , maybe "(null)" formatBusName (signalSender msg) , " -> dest=" , maybe "(null)" formatBusName (signalDestination msg) , " serial=" , show (serialValue serial) , " path=" , formatObjectPath (signalPath msg) , "; interface=" , formatInterfaceName (signalInterface msg) , "; member=" , formatMemberName (signalMember msg) , formatBody (signalBody msg) ] formatMessage msg = concat [ "unknown" , " sender=" , maybe "(null)" formatBusName (receivedMessageSender msg) , " serial=" , show (serialValue (receivedMessageSerial msg)) , formatBody (receivedMessageBody msg) ] formatBody :: [Variant] -> String formatBody body = formatted where tree = Children (map formatVariant body) formatted = intercalate "\n" ("" : collapseTree 0 tree) -- A string tree allows easy indentation of nested structures data StringTree = Line String | MultiLine [StringTree] | Children [StringTree] deriving (Show) collapseTree :: Int -> StringTree -> [String] collapseTree d (Line x) = [replicate (d*3) ' ' ++ x] collapseTree d (MultiLine xs) = concatMap (collapseTree d) xs collapseTree d (Children xs) = concatMap (collapseTree (d + 1)) xs -- Formatting for various kinds of variants, keyed to their signature type. formatVariant :: Variant -> StringTree formatVariant x = case variantType x of TypeBoolean -> Line $ let Just x' = fromVariant x in "boolean " ++ if x' then "true" else "false" TypeWord8 -> Line $ let Just x' = fromVariant x in "byte " ++ show (x' :: Word8) TypeWord16 -> Line $ let Just x' = fromVariant x in "uint16 " ++ show (x' :: Word16) TypeWord32 -> Line $ let Just x' = fromVariant x in "uint32 " ++ show (x' :: Word32) TypeWord64 -> Line $ let Just x' = fromVariant x in "uint64 " ++ show (x' :: Word64) TypeInt16 -> Line $ let Just x' = fromVariant x in "int16 " ++ show (x' :: Int16) TypeInt32 -> Line $ let Just x' = fromVariant x in "int32 " ++ show (x' :: Int32) TypeInt64 -> Line $ let Just x' = fromVariant x in "int64 " ++ show (x' :: Int64) TypeDouble -> Line $ let Just x' = fromVariant x in "double " ++ show (x' :: Double) TypeString -> Line $ let Just x' = fromVariant x in "string " ++ show (x' :: String) TypeObjectPath -> Line $ let Just x' = fromVariant x in "object path " ++ show (formatObjectPath x') TypeSignature -> Line $ let Just x' = fromVariant x in "signature " ++ show (formatSignature x') TypeArray _ -> MultiLine $ let Just x' = fromVariant x items = arrayItems x' lines' = [ Line "array [" , Children (map formatVariant items) , Line "]" ] in lines' TypeDictionary _ _ -> MultiLine $ let Just x' = fromVariant x items = dictionaryItems x' lines' = [ Line "dictionary {" , Children (map formatItem items) , Line "}" ] formatItem (k, v) = MultiLine (firstLine : vTail) where Line k' = formatVariant k v' = collapseTree 0 (formatVariant v) vHead = head v' vTail = map Line (tail v') firstLine = Line (k' ++ " -> " ++ vHead) in lines' TypeStructure _ -> MultiLine $ let Just x' = fromVariant x items = structureItems x' lines' = [ Line "struct (" , Children (map formatVariant items) , Line ")" ] in lines' TypeVariant -> let Just x' = fromVariant x in MultiLine [Line "variant", Children [formatVariant x']] dbus-1.2.29/examples/export.hs0000644000000000000000000000415714263302757014443 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2009-2011 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module Main (main) where import Control.Concurrent (threadDelay) import Control.Monad import System.Exit import DBus.Client onFoo :: String -> String -> IO (String, String) onFoo x y = do putStrLn ("Foo " ++ show x ++ " " ++ show y) return (x, y) onBar :: String -> String -> IO (String, String) onBar x y = do putStrLn ("Bar " ++ show x ++ " " ++ show y) throwError "com.example.ErrorBar" "Bar failed" [] main :: IO () main = do -- Connect to the bus client <- connectSession -- Request a unique name on the bus. requestResult <- requestName client "com.example.exporting" [] when (requestResult /= NamePrimaryOwner) $ do putStrLn "Another service owns the \"com.example.exporting\" bus name" exitFailure -- Export two example objects 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" -- Wait forever for method calls forever (threadDelay 50000) dbus-1.2.29/examples/introspect.hs0000644000000000000000000000715514263302757015315 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2009-2011 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module Main (main) where import Control.Monad (when) import Data.String (fromString) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) import DBus import DBus.Client import qualified DBus.Introspection as I main :: IO () main = do args <- getArgs (service, path) <- case args of a1:a2:_ -> return (fromString a1, fromString a2) _ -> do name <- getProgName hPutStrLn stderr ("Usage: " ++ name ++ " ") exitFailure client <- connectSession printObj (introspect client service) path introspect :: Client -> BusName -> ObjectPath -> IO I.Object introspect client service path = do reply <- call_ client (methodCall path "org.freedesktop.DBus.Introspectable" "Introspect") { methodCallDestination = Just service } let Just xml = fromVariant (methodReturnBody reply !! 0) case I.parseXML path xml of Just info -> return info Nothing -> error ("Invalid introspection XML: " ++ show xml) -- most of this stuff is just boring text formatting printObj :: (ObjectPath -> IO I.Object) -> ObjectPath -> IO () printObj get path = do obj <- get path putStrLn (formatObjectPath path) mapM_ printIface (I.objectInterfaces obj) putStrLn "" mapM_ (printObj get) [I.objectPath x | x <- I.objectChildren obj] printIface :: I.Interface -> IO () printIface iface = do putStr " " putStrLn (formatInterfaceName (I.interfaceName iface)) mapM_ printMethod (I.interfaceMethods iface) mapM_ printSignal (I.interfaceSignals iface) mapM_ printProperty (I.interfaceProperties iface) putStrLn "" printMethod :: I.Method -> IO () printMethod method = do putStr " method " putStrLn (formatMemberName (I.methodName method)) mapM_ printMethodArg (I.methodArgs method) printMethodArg :: I.MethodArg -> IO () printMethodArg arg = do 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) printSignal :: I.Signal -> IO () printSignal sig = do putStr " signal " putStrLn (formatMemberName (I.signalName sig)) mapM_ printSignalArg (I.signalArgs sig) printSignalArg :: I.SignalArg -> IO () printSignalArg arg = do putStr " [" putStr (show (formatSignature (signature_ [I.signalArgType arg])) ++ "] ") putStrLn (I.signalArgName arg) printProperty :: I.Property -> IO () printProperty prop = do putStr " property " putStr (show (formatSignature (signature_ [I.propertyType prop])) ++ " ") putStrLn (I.propertyName prop) putStr " " when (I.propertyRead prop) (putStr "Read") when (I.propertyWrite prop) (putStr "Write") putStrLn "" dbus-1.2.29/examples/list-names.hs0000644000000000000000000000253014263302757015167 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2009-2011 John Millikin -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. module Main (main) where import Data.List (sort) import DBus import DBus.Client main :: IO () main = do client <- connectSession -- Request a list of connected clients from the bus reply <- call_ client (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "ListNames") { methodCallDestination = Just "org.freedesktop.DBus" } -- org.freedesktop.DBus.ListNames returns a single value, which is -- a list of names (here represented as [String]) let Just names = fromVariant (methodReturnBody reply !! 0) -- Print each name on a line, sorted so reserved names are below -- temporary names. mapM_ putStrLn (sort names) dbus-1.2.29/idlxml/dbus.xml0000644000000000000000000000535014263302757013714 0ustar0000000000000000