dbus-core 0.5 → 0.6

raw patch · 17 files changed

+4045/−3111 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Examples/dbus-monitor.hs +3/−2
• Makefile +2/−0
• Tests.nw +3/−6
• dbus-core.cabal +3/−1
• dbus-core.nw +3489/−2983
• hs/DBus/Address.hs +0/−1
• hs/DBus/Bus.hs +9/−15
• hs/DBus/Connection.hs +85/−14
• hs/DBus/Introspection.hs +5/−5
• hs/DBus/MatchRule.hs +175/−0
• hs/DBus/Message.hs +2/−0
• hs/DBus/Message/Internal.hs +25/−6
• hs/DBus/NameReservation.hs +107/−0
• hs/DBus/Types.hs +48/−12
• hs/DBus/Util.hs +5/−0
• hs/DBus/Wire.hs +81/−60
• hs/Tests.hs +3/−6

@@ -85,8 +85,9 @@ 	, "type='error'" 	] -onMessage :: ReceivedMessage -> IO ()-onMessage msg = putStrLn $ (TL.unpack $ formatMessage msg) ++ "\n"+onMessage :: Either UnmarshalError ReceivedMessage -> IO ()+onMessage (Right msg) = putStrLn $ (TL.unpack $ formatMessage msg) ++ "\n"+onMessage (Left err) = error $ show err  main :: IO () main = do

@@ -4,8 +4,10 @@ 	hs/DBus/Connection.hs \ 	hs/DBus/Constants.hs \ 	hs/DBus/Introspection.hs \+	hs/DBus/MatchRule.hs \ 	hs/DBus/Message.hs \ 	hs/DBus/Message/Internal.hs \+	hs/DBus/NameReservation.hs \ 	hs/DBus/Types.hs \ 	hs/DBus/Util.hs \ 	hs/DBus/Wire.hs \

@@ -463,18 +463,16 @@ 	arbitrary = do 		serial <- arbitrary 		dest   <- arbitrary-		flags  <- fmap Set.fromList arbitrary 		Structure body <- arbitrary-		return $ MethodReturn serial dest flags body+		return $ MethodReturn serial dest body  instance Arbitrary Error where 	arbitrary = do 		name   <- arbitrary 		serial <- arbitrary 		dest   <- arbitrary-		flags  <- fmap Set.fromList arbitrary 		Structure body <- arbitrary-		return $ Error name serial dest flags body+		return $ Error name serial dest body  instance Arbitrary Signal where 	arbitrary = do@@ -482,9 +480,8 @@ 		member <- arbitrary 		iface  <- arbitrary 		dest   <- arbitrary-		flags  <- fmap Set.fromList arbitrary 		Structure body <- arbitrary-		return $ Signal path member iface dest flags body+		return $ Signal path member iface dest body  @ \subsection{Wire format} 

@@ -1,5 +1,5 @@ name: dbus-core-version: 0.5+version: 0.6 synopsis: Low-level D-Bus protocol implementation license: GPL license-file: License.txt@@ -51,7 +51,9 @@     DBus.Connection     DBus.Constants     DBus.Introspection+    DBus.MatchRule     DBus.Message+    DBus.NameReservation     DBus.Types    other-modules:

@@ -98,2988 +98,3494 @@ <<text imports>> <<type imports>> -@ DBus types are divided into two categories, ``atomic'' and ``container''-types. Atoms are actual values -- strings, numbers, etc. Containers store-atoms and other containers. The most interesting difference between the two-is that atoms may be used as the keys in associative mappings-(``dictionaries'').--Internally, types are represented using an enumeration.--<<DBus/Types.hs>>=-data Type-	= DBusBoolean-	| DBusByte-	| DBusInt16-	| DBusInt32-	| DBusInt64-	| DBusWord16-	| DBusWord32-	| DBusWord64-	| DBusDouble-	| DBusString-	| DBusSignature-	| DBusObjectPath-	| DBusVariant-	| DBusArray Type-	| DBusDictionary Type Type-	| DBusStructure [Type]-	deriving (Show, Eq)--<<DBus/Types.hs>>=-isAtomicType :: Type -> Bool-isAtomicType DBusBoolean    = True-isAtomicType DBusByte       = True-isAtomicType DBusInt16      = True-isAtomicType DBusInt32      = True-isAtomicType DBusInt64      = True-isAtomicType DBusWord16     = True-isAtomicType DBusWord32     = True-isAtomicType DBusWord64     = True-isAtomicType DBusDouble     = True-isAtomicType DBusString     = True-isAtomicType DBusSignature  = True-isAtomicType DBusObjectPath = True-isAtomicType _              = False--@ Each type can be converted to a textual representation, used in ``type-signatures'' or for debugging.--<<DBus/Types.hs>>=-typeCode :: Type -> Text--<<type exports>>=-  -- * Available types-  Type (..)-, typeCode--@ Certain Haskell types are considered ``built-in'' D-Bus types; that is,-they are directly represented in the D-Bus protocol.--<<DBus/Types.hs>>=-class (Show a, Eq a) => Builtin a where-	builtinDBusType :: a -> Type--@ \subsection{Variants}--A wrapper type is needed for safely storing generic D-Bus values in Haskell.-The D-Bus ``variant'' type is perfect for this, because variants may store-any D-Bus value.--To cleanly store any D-Bus type, without exposing the internal storage-mechanism, requires existential quantification and some run-time casting.--<<type extensions>>=-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ExistentialQuantification #-}--<<type imports>>=-import Data.Typeable (Typeable, cast)--@ Any type which is an instance of {\tt Variable} is considered a valid-D-Bus value, because it can be used to construct {\tt Variant}s. However,-outside of this module, {\tt Variant}s can only be constructed from-pre-defined types.--<<DBus/Types.hs>>=-data Variant = forall a. (Variable a, Builtin a, Typeable a) => Variant a-	deriving (Typeable)--class Variable a where-	toVariant :: a -> Variant-	fromVariant :: Variant -> Maybe a--<<type exports>>=-  -- * Variants-, Variant-, Variable (..)--@ Variants can be printed, for debugging purposes -- this instance shouldn't-be parsed or inspected or anything like that, since the output format might-change drastically.--<<DBus/Types.hs>>=-instance Show Variant where-	showsPrec d (Variant x) = showParen (d > 10) $-		s "Variant " . shows code . s " " . showsPrec 11 x-		where code = typeCode . builtinDBusType $ x-		      s    = showString--@ In the test suite, it's useful to test that two variants have the same-value.--<<DBus/Types.hs>>=-instance Eq Variant where-	(Variant x) == (Variant y) = cast x == Just y--@ Since many operations on D-Bus values depend on having the correct type,-{\tt variantType} is used to retrieve which type is actually stored within-a {\tt Variant}.--<<DBus/Types.hs>>=-variantType :: Variant -> Type-variantType (Variant x) = builtinDBusType x--<<type exports>>=-, variantType--@ These helper macros will be used for defining instances of Haskell types.--<<DBus/Types.hs>>=-#define INSTANCE_BUILTIN(HASKELL, DBUS) \-	instance Builtin HASKELL where \-		{ builtinDBusType _ = DBUS };--#define INSTANCE_VARIABLE(HASKELL) \-	instance Variable HASKELL where \-		{ toVariant = Variant \-		; fromVariant (Variant x) = cast x };--#define BUILTIN_VARIABLE(HASKELL, DBUS) \-	INSTANCE_BUILTIN(HASKELL, DBUS) \-	INSTANCE_VARIABLE(HASKELL)--@ Since {\tt Variant}s are D-Bus values themselves, they have a type.--<<DBus/Types.hs>>=-BUILTIN_VARIABLE(Variant, DBusVariant)--@ \subsection{Numerics}--D-Bus supports most common numeric types:--\begin{table}[h]-\caption{D-Bus Numeric types}-\begin{center}-\begin{tabular}{ll}-\toprule-Type        & Description \\-\midrule-Boolean     & Either {\tt True} or {\tt False} \\-Byte        & 8-bit unsigned integer \\-Int16       & 16-bit signed integer \\-Int32       & 32-bit signed integer \\-Int64       & 64-bit signed integer \\-Word16      & 16-bit unsigned integer \\-Word32      & 32-bit unsigned integer \\-Word64      & 64-bit unsigned integer \\-Double      & 64-bit IEEE754 floating-point \\-\bottomrule-\end{tabular}-\end{center}-\end{table}--All D-Bus numeric types are fixed-length, so the {\tt Int} and {\tt Integer}-types can't be used. Instead, instances for the fixed-length integer types-are defined and any others will have to be converted.--<<type imports>>=-import Data.Word (Word8, Word16, Word32, Word64)-import Data.Int (Int16, Int32, Int64)--<<DBus/Types.hs>>=-BUILTIN_VARIABLE(Bool,   DBusBoolean)-BUILTIN_VARIABLE(Word8,  DBusByte)-BUILTIN_VARIABLE(Int16,  DBusInt16)-BUILTIN_VARIABLE(Int32,  DBusInt32)-BUILTIN_VARIABLE(Int64,  DBusInt64)-BUILTIN_VARIABLE(Word16, DBusWord16)-BUILTIN_VARIABLE(Word32, DBusWord32)-BUILTIN_VARIABLE(Word64, DBusWord64)-BUILTIN_VARIABLE(Double, DBusDouble)--@ \subsection{Strings}--Strings are a weird case; the built-in type, {\tt String}, is horribly-inefficent. To provide better performance for large strings, packed Unicode-strings defined in {\tt Data.Text} are used internally.--<<DBus/Types.hs>>=-BUILTIN_VARIABLE(TL.Text, DBusString)--@ There's two different {\tt Text} types, strict and lazy. It'd be a pain-to store both and have to convert later, so instead, all strict {\tt Text}-values are converted to lazy values.--<<type imports>>=-import qualified Data.Text as T--<<DBus/Types.hs>>=-instance Variable T.Text where-	toVariant = toVariant . TL.fromChunks . (:[])-	fromVariant = fmap (T.concat . TL.toChunks) . fromVariant--@ Built-in {\tt String}s can still be stored, of course, but it requires-a language extension.--<<type extensions>>=-{-# LANGUAGE TypeSynonymInstances #-}--<<DBus/Types.hs>>=-instance Variable String where-	toVariant = toVariant . TL.pack-	fromVariant = fmap TL.unpack . fromVariant--@ \subsection{Signatures}--@ Valid DBus types must obey certain rules, such as ``dict keys must be-atomic'', which are difficult to express in the Haskell type system.  A-{\tt Signature} is guaranteed to be valid according to these rules. Creating-one requires using the {\tt mkSignature} function, which will convert a valid-DBus signature string into a {\tt Signature}.--<<DBus/Types.hs>>=-BUILTIN_VARIABLE(Signature, DBusSignature)-data Signature = Signature { signatureTypes :: [Type] }-	deriving (Eq, Typeable)--instance Show Signature where-	showsPrec d x = showParen (d > 10) $-		showString "Signature " . shows (strSignature x)--@ Signatures can also be converted back into text, by concatenating the-type codes of their contained types.--<<DBus/Types.hs>>=-strSignature :: Signature -> Text-strSignature (Signature ts) = TL.concat $ map typeCode ts--@ It doesn't make much sense to sort signatures, but since they can be used-as dictionary keys, it's useful to have them as an instance of {\tt Ord}.--<<DBus/Types.hs>>=-instance Ord Signature where-	compare x y = compare (strSignature x) (strSignature y)--<<type exports>>=-  -- * Signatures-, Signature-, signatureTypes-, strSignature--@ \subsubsection{Type codes}--@ For atomic types, the type code is a single letter. Arrays, structures,-and dictionary types are multiple characters.--<<DBus/Types.hs>>=-typeCode DBusBoolean    = "b"-typeCode DBusByte       = "y"-typeCode DBusInt16      = "n"-typeCode DBusInt32      = "i"-typeCode DBusInt64      = "x"-typeCode DBusWord16     = "q"-typeCode DBusWord32     = "u"-typeCode DBusWord64     = "t"-typeCode DBusDouble     = "d"-typeCode DBusString     = "s"-typeCode DBusSignature  = "g"-typeCode DBusObjectPath = "o"-typeCode DBusVariant    = "v"--@ An array's type code is ``a'' followed by the type it contains. For example,-an array of booleans would have the type string ``ab''.--<<DBus/Types.hs>>=-typeCode (DBusArray t) = TL.cons 'a' $ typeCode t--@ A dictionary's type code is ``a\{$key\_type$ $value\_type$\}''. For example,-a dictionary of bytes to booleans would have the type string ``a{yb}''.--<<DBus/Types.hs>>=-typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"]--@ A structure's type code is the concatenation of its contained types,-wrapped by ``('' and ``)''. Structures may be empty, in which case their-type code is simply ``()''.--<<DBus/Types.hs>>=-typeCode (DBusStructure ts) = TL.concat $-	["("] ++ map typeCode ts ++ [")"]--@ \subsubsection{Parsing}--When parsing, additional restrictions apply which are not inherent to the-D-Bus type system:--\begin{itemize}-\item Signatures may be at most 255 characters long.-\end{itemize}--Parsec is used to parse signatures.--<<type imports>>=-import Text.Parsec ((<|>))-import qualified Text.Parsec as P-import DBus.Util (checkLength, parseMaybe)--<<DBus/Types.hs>>=-mkSignature :: Text -> Maybe Signature-mkSignature = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack where-	sigParser = do-		types <- P.many parseType-		P.eof-		return $ Signature types-	parseType = parseAtom <|> parseContainer-	parseContainer =-		    parseArray-		<|> parseStruct-		<|> (P.char 'v' >> return DBusVariant)-	parseAtom =-		    (P.char 'b' >> return DBusBoolean)-		<|> (P.char 'y' >> return DBusByte)-		<|> (P.char 'n' >> return DBusInt16)-		<|> (P.char 'i' >> return DBusInt32)-		<|> (P.char 'x' >> return DBusInt64)-		<|> (P.char 'q' >> return DBusWord16)-		<|> (P.char 'u' >> return DBusWord32)-		<|> (P.char 't' >> return DBusWord64)-		<|> (P.char 'd' >> return DBusDouble)-		<|> (P.char 's' >> return DBusString)-		<|> (P.char 'g' >> return DBusSignature)-		<|> (P.char 'o' >> return DBusObjectPath)-	parseArray = do-		P.char 'a'-		parseDict <|> do-		t <- parseType-		return $ DBusArray t-	parseDict = do-		P.char '{'-		keyType <- parseAtom-		valueType <- parseType-		P.char '}'-		return $ DBusDictionary keyType valueType-	parseStruct = do-		P.char '('-		types <- P.many parseType-		P.char ')'-		return $ DBusStructure types--@ Since many signatures are defined as string literals, it's useful to-have a helper function to construct a signature directly from a string.-If the input string is invalid, {\tt error} will be called.--<<type imports>>=-import DBus.Util (mkUnsafe)--<<DBus/Types.hs>>=-mkSignature' :: Text -> Signature-mkSignature' = mkUnsafe "signature" mkSignature--@ Most signature-related functions are exposed to clients, except the-{\tt Signature} value constructor. If that were exposed, clients could-construct invalid signatures.--<<type exports>>=-, mkSignature-, mkSignature'--@ \subsection{Object paths}--<<DBus/Types.hs>>=-BUILTIN_VARIABLE(ObjectPath, DBusObjectPath)-newtype ObjectPath = ObjectPath-	{ strObjectPath :: Text-	}-	deriving (Show, Eq, Ord, Typeable)--@ An object path may be one of--\begin{itemize}-\item The root path, {\tt "/"}.-\item {\tt '/'}, followed by one or more element names. Each element name-      contains characters in the set {\tt [a-zA-Z0-9\_]}, and must have at-      least one character.-\end{itemize}--Element names are separated by {\tt '/'}, and the path may not end in-{\tt '/'} unless it is the root path.--<<DBus/Types.hs>>=-mkObjectPath :: Text -> Maybe ObjectPath-mkObjectPath s = parseMaybe path' (TL.unpack s) where-	c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"-	path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char-	path' = path >> P.eof >> return (ObjectPath s)--mkObjectPath' :: Text -> ObjectPath-mkObjectPath' = mkUnsafe "object path" mkObjectPath--<<type exports>>=-  -- * Object paths-, ObjectPath-, strObjectPath-, mkObjectPath-, mkObjectPath'--@ \subsection{Arrays}--Arrays are homogenous sequences of any valid DBus type. Arrays might be-empty, so the type they contain is stored instead of being calculated from-their contents (as in {\tt variantType}).--TODO: There ought to be a specialised constructor for arrays of bytes, based-on the {\tt ByteString} type. Storing bytes individually in a list of-{\tt Variant}s is inefficient.--<<DBus/Types.hs>>=-INSTANCE_VARIABLE(Array)-data Array = Array-	{ arrayType  :: Type-	, arrayItems :: [Variant]-	}-	deriving (Eq, Typeable)--instance Builtin Array where-	builtinDBusType = DBusArray . arrayType--<<type exports>>=-  -- * Arrays-, Array-, arrayType-, arrayItems--@ Like {\tt Variant}, deriving {\tt Show} for {\tt Array} is mostly-just useful for debugging.--<<DBus/Types.hs>>=-instance Show Array where-	showsPrec d (Array t vs) = showParen (d > 10) $-		s "Array " . showSig . s " [" . s valueString . s "]" where-			s = showString-			showSig = shows $ typeCode t-			vs' = [show x | (Variant x) <- vs]-			valueString = intercalate ", " vs'--@ Clients constructing an array must provide the expected item type, which-will be checked for validity. Every item in the array will be checked against-the item type, to ensure the array is homogenous.--<<DBus/Types.hs>>=-arrayFromItems :: Type -> [Variant] -> Maybe Array-arrayFromItems t vs = do-	mkSignature (typeCode t)-	if all (\x -> variantType x == t) vs-		then Just $ Array t vs-		else Nothing--@ Additionally, for ease of use, an {\tt Array} can be converted directly-to/from lists of {\tt Variable} values.--<<DBus/Types.hs>>=-toArray :: Variable a => Type -> [a] -> Maybe Array-toArray t = arrayFromItems t . map toVariant--fromArray :: Variable a => Array -> Maybe [a]-fromArray = mapM fromVariant . arrayItems--<<type exports>>=-, toArray-, fromArray-, arrayFromItems--@ \subsection{Dictionaries}--Dictionaries are a homogenous (key $\rightarrow$ value) mapping, where the-key type must be atomic. Values may be of any valid DBus type. Like-{\tt Array}, {\tt Dictionary} stores its contained types.--<<DBus/Types.hs>>=-INSTANCE_VARIABLE(Dictionary)-data Dictionary = Dictionary-	{ dictionaryKeyType   :: Type-	, dictionaryValueType :: Type-	, dictionaryItems     :: [(Variant, Variant)]-	}-	deriving (Eq, Typeable)--instance Builtin Dictionary where-	builtinDBusType (Dictionary kt vt _) = DBusDictionary kt vt--<<type exports>>=-  -- * Dictionaries-, Dictionary-, dictionaryItems-, dictionaryKeyType-, dictionaryValueType--@ {\tt show}ing a {\tt Dictionary} displays the mapping in a more readable-format than a list of pairs.--<<type imports>>=-import Data.List (intercalate)--<<DBus/Types.hs>>=-instance Show Dictionary where-	showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $-		s "Dictionary " . showSig . s " {" . s valueString . s "}" where-			s = showString-			showSig = shows $ TL.append (typeCode kt) (typeCode vt)-			valueString = intercalate ", " $ map showPair pairs-			showPair ((Variant k), (Variant v)) =-				show k ++ " -> " ++ show v--@ Constructing a {\tt Dictionary} works like constructing an {\tt Array},-except that there are two types to check, and the key type must be atomic.--<<type imports>>=-import Control.Monad (unless)--<<DBus/Types.hs>>=-dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary-dictionaryFromItems kt vt pairs = do-	unless (isAtomicType kt) Nothing-	mkSignature (typeCode kt)-	mkSignature (typeCode vt)-	-	let sameType (k, v) = variantType k == kt &&-	                      variantType v == vt-	if all sameType pairs-		then Just $ Dictionary kt vt pairs-		else Nothing--@ The closest match for dictionary semantics in Haskell is the-{\tt Data.Map.Map} type. Therefore, the utility conversion functions work-with {\tt Map}s instead of pair lists.--<<type imports>>=-import Control.Arrow ((***))-import qualified Data.Map as Map--<<DBus/Types.hs>>=-toDictionary :: (Variable a, Variable b) => Type -> Type -> Map.Map a b-             -> Maybe Dictionary-toDictionary kt vt = dictionaryFromItems kt vt . pairs where-	pairs = map (toVariant *** toVariant) . Map.toList--<<type imports>>=-import Control.Monad (forM)--<<DBus/Types.hs>>=-fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary-               -> Maybe (Map.Map a b)-fromDictionary (Dictionary _ _ vs) = do-	pairs <- forM vs $ \(k, v) -> do-		k' <- fromVariant k-		v' <- fromVariant v-		return (k', v')-	return $ Map.fromList pairs--<<type exports>>=-, toDictionary-, fromDictionary-, dictionaryFromItems--@ \subsubsection{Converting between {\tt Array} and {\tt Dictionary}}--Converting between {\tt Array} and {\tt Dictionary} is useful when-(un)marshaling -- dictionaries can be thought of as arrays of two-element-structures, much as a {\tt Map} is a list of pairs.--<<DBus/Types.hs>>=-dictionaryToArray :: Dictionary -> Array-dictionaryToArray (Dictionary kt vt items) = array where-	Just array = toArray itemType structs-	itemType = DBusStructure [kt, vt]-	structs = [Structure [k, v] | (k, v) <- items]--<<DBus/Types.hs>>=-arrayToDictionary :: Array -> Maybe Dictionary-arrayToDictionary (Array t items) = do-	let toPair x = do-		struct <- fromVariant x-		case struct of-			Structure [k, v] -> Just (k, v)-			_                -> Nothing-	(kt, vt) <- case t of-		DBusStructure [kt, vt] -> Just (kt, vt)-		_                      -> Nothing-	pairs <- mapM toPair items-	dictionaryFromItems kt vt pairs--<<type exports>>=-, dictionaryToArray-, arrayToDictionary--@ \subsection{Structures}--A heterogeneous, fixed-length container; equivalent in purpose to a Haskell-tuple.--<<DBus/Types.hs>>=-INSTANCE_VARIABLE(Structure)-data Structure = Structure [Variant]-	deriving (Show, Eq, Typeable)--instance Builtin Structure where-	builtinDBusType (Structure vs) = DBusStructure $ map variantType vs--<<type exports>>=-  -- * Structures-, Structure (..)--@ \subsection{Names}--Various aspects of DBus require the use of specially-formatted strings,-called ``names''. All names are limited to 255 characters, and use subsets-of ASCII.--Since all names have basically the same structure (a {\tt newtype}-declaration and some helper functions), I define a macro to automate-the definitions.--<<DBus/Types.hs>>=-#define NAME_TYPE(TYPE, NAME) \-	newtype TYPE = TYPE {str##TYPE :: Text} \-		deriving (Show, Eq, Ord); \-		                          \-	instance Variable TYPE where \-		{ toVariant = toVariant . str##TYPE \-		; fromVariant = (mk##TYPE =<<) . fromVariant }; \-		                                                \-	mk##TYPE##' :: Text -> TYPE; \-	mk##TYPE##' = mkUnsafe NAME mk##TYPE--<<type exports>>=--- * Names--@ \subsubsection{Bus names}--There are two forms of bus names, ``unique'' and ``well-known''.--Unique names begin with {\tt `:'} and contain two or more elements, separated-by {\tt `.'}. Each element consists of characters from the set-{\tt [a-zA-Z0-9\_-]}.--Well-known names contain two or more elements, separated by {\tt `.'}. Each-element consists of characters from the set {\tt [a-zA-Z0-9\_-]}, and must-not start with a digit.--<<DBus/Types.hs>>=-NAME_TYPE(BusName, "bus name")--mkBusName :: Text -> Maybe BusName-mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where-	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"-	c' = c ++ ['0'..'9']-	parser = (unique <|> wellKnown) >> P.eof >> return (BusName s)-	unique = P.char ':' >> elems c'-	wellKnown = elems c-	elems start = elem' start >> P.many1 (P.char '.' >> elem' start)-	elem' start = P.oneOf start >> P.many (P.oneOf c')--<<type exports>>=-  -- ** Bus names-, BusName-, strBusName-, mkBusName-, mkBusName'--@ \subsubsection{Interface names}--An interface name consists of two or more {\tt '.'}-separated elements. Each-element constists of characters from the set {\tt [a-zA-Z0-9\_]}, may not-start with a digit, and must have at least one character.--<<DBus/Types.hs>>=-NAME_TYPE(InterfaceName, "interface name")--mkInterfaceName :: Text -> Maybe InterfaceName-mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where-	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"-	c' = c ++ ['0'..'9']-	element = P.oneOf c >> P.many (P.oneOf c')-	name = element >> P.many1 (P.char '.' >> element)-	parser = name >> P.eof >> return (InterfaceName s)--<<type exports>>=-  -- ** Interface names-, InterfaceName-, strInterfaceName-, mkInterfaceName-, mkInterfaceName'--@ \subsubsection{Error names}--Error names have the same format as interface names, so the parser logic-can just be re-purposed.--<<DBus/Types.hs>>=-NAME_TYPE(ErrorName, "error name")--mkErrorName :: Text -> Maybe ErrorName-mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName--<<type exports>>=-  -- ** Error names-, ErrorName-, strErrorName-, mkErrorName-, mkErrorName'--@ \subsubsection{Member names}--Member names must contain only characters from the set {\tt [a-zA-Z0-9\_]},-may not begin with a digit, and must be at least one character long.--<<DBus/Types.hs>>=-NAME_TYPE(MemberName, "member name")--mkMemberName :: Text -> Maybe MemberName-mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where-	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"-	c' = c ++ ['0'..'9']-	name = P.oneOf c >> P.many (P.oneOf c')-	parser = name >> P.eof >> return (MemberName s)--<<type exports>>=-  -- ** Member names-, MemberName-, strMemberName-, mkMemberName-, mkMemberName'--@-\section{Messages}--@ To prevent internal details of messages from leaking out to clients,-declarations are contained in an internal module and then re-exported-in the public module.--<<DBus/Message.hs>>=-<<copyright>>-module DBus.Message-	(<<message exports>>-	) where-import DBus.Message.Internal--<<DBus/Message/Internal.hs>>=-<<copyright>>-module DBus.Message.Internal where-import qualified Data.Set as S-import Data.Word (Word8, Word32)-import qualified DBus.Types as T--<<DBus/Message/Internal.hs>>=-class Message a where-	messageTypeCode     :: a -> Word8-	messageHeaderFields :: a -> [HeaderField]-	messageFlags        :: a -> S.Set Flag-	messageBody         :: a -> [T.Variant]--<<message exports>>=-Message ( messageFlags-        , messageBody-        )--@ \subsection{Flags}--The instance of {\tt Ord} only exists for storing flags in a set. Flags have-no inherent ordering.--<<DBus/Message/Internal.hs>>=-data Flag-	= NoReplyExpected-	| NoAutoStart-	deriving (Show, Eq, Ord)--<<message exports>>=-, Flag (..)--@ \subsection{Header fields}--<<DBus/Message/Internal.hs>>=-data HeaderField-	= Path        T.ObjectPath-	| Interface   T.InterfaceName-	| Member      T.MemberName-	| ErrorName   T.ErrorName-	| ReplySerial Serial-	| Destination T.BusName-	| Sender      T.BusName-	| Signature   T.Signature-	deriving (Show, Eq)--@ \subsection{Serials}--{\tt Serial} is just a wrapper around {\tt Word32}, to provide a bit of-added type-safety.--<<DBus/Message/Internal.hs>>=-newtype Serial = Serial { serialValue :: Word32 }-	deriving (Eq, Ord)--instance Show Serial where-	show (Serial x) = show x--instance T.Variable Serial where-	toVariant (Serial x) = T.toVariant x-	fromVariant = fmap Serial . T.fromVariant--@ Additionally, some useful functions exist for incrementing serials.--<<DBus/Message/Internal.hs>>=-firstSerial :: Serial-firstSerial = Serial 1--nextSerial :: Serial -> Serial-nextSerial (Serial x) = Serial (x + 1)--@ The {\tt Serial} constructor isn't useful to clients, because building-arbitrary serials doesn't make any sense.--<<message exports>>=-, Serial-, serialValue--@ \subsection{Message types}--<<DBus/Message/Internal.hs>>=-maybe' :: (a -> b) -> Maybe a -> [b]-maybe' f = maybe [] (\x' -> [f x'])--@ \subsubsection{Method calls}--<<DBus/Message/Internal.hs>>=-data MethodCall = MethodCall-	{ methodCallPath        :: T.ObjectPath-	, methodCallMember      :: T.MemberName-	, methodCallInterface   :: Maybe T.InterfaceName-	, methodCallDestination :: Maybe T.BusName-	, methodCallFlags       :: S.Set Flag-	, methodCallBody        :: [T.Variant]-	}-	deriving (Show, Eq)--instance Message MethodCall where-	messageTypeCode _ = 1-	messageFlags      = methodCallFlags-	messageBody       = methodCallBody-	messageHeaderFields m = concat-		[ [ Path    $ methodCallPath m-		  ,  Member $ methodCallMember m-		  ]-		, maybe' Interface . methodCallInterface $ m-		, maybe' Destination . methodCallDestination $ m-		]--<<message exports>>=-, MethodCall (..)--@ \subsubsection{Method returns}--<<DBus/Message/Internal.hs>>=-data MethodReturn = MethodReturn-	{ methodReturnSerial      :: Serial-	, methodReturnDestination :: Maybe T.BusName-	, methodReturnFlags       :: S.Set Flag-	, methodReturnBody        :: [T.Variant]-	}-	deriving (Show, Eq)--instance Message MethodReturn where-	messageTypeCode _ = 2-	messageFlags      = methodReturnFlags-	messageBody       = methodReturnBody-	messageHeaderFields m = concat-		[ [ ReplySerial $ methodReturnSerial m-		  ]-		, maybe' Destination . methodReturnDestination $ m-		]--<<message exports>>=-, MethodReturn (..)--@ \subsubsection{Errors}--<<DBus/Message/Internal.hs>>=-data Error = Error-	{ errorName        :: T.ErrorName-	, errorSerial      :: Serial-	, errorDestination :: Maybe T.BusName-	, errorFlags       :: S.Set Flag-	, errorBody        :: [T.Variant]-	}-	deriving (Show, Eq)--instance Message Error where-	messageTypeCode _ = 3-	messageFlags      = errorFlags-	messageBody       = errorBody-	messageHeaderFields m = concat-		[ [ ErrorName   $ errorName m-		  , ReplySerial $ errorSerial m-		  ]-		, maybe' Destination . errorDestination $ m-		]--<<message exports>>=-, Error (..)--@ \subsubsection{Signals}--<<DBus/Message/Internal.hs>>=-data Signal = Signal-	{ signalPath        :: T.ObjectPath-	, signalMember      :: T.MemberName-	, signalInterface   :: T.InterfaceName-	, signalDestination :: Maybe T.BusName-	, signalFlags       :: S.Set Flag-	, signalBody        :: [T.Variant]-	}-	deriving (Show, Eq)--instance Message Signal where-	messageTypeCode _ = 4-	messageFlags      = signalFlags-	messageBody       = signalBody-	messageHeaderFields m = concat-		[ [ Path      $ signalPath m-		  , Member    $ signalMember m-		  , Interface $ signalInterface m-		  ]-		, maybe' Destination . signalDestination $ m-		]--<<message exports>>=-, Signal (..)--@ \subsubsection{Unknown messages}--Unknown messages are used for storing information about messages without-a recognized type code. They are not instances of {\tt Message}, because-if they were, then clients could accidentally send invalid messages over-the bus.--<<DBus/Message/Internal.hs>>=-data Unknown = Unknown-	{ unknownType    :: Word8-	, unknownFlags   :: S.Set Flag-	, unknownBody    :: [T.Variant]-	}-	deriving (Show, Eq)--<<message exports>>=-, Unknown (..)--@ \subsection{Received messages}--Messages received from a bus have additional fields which do not make sense-when sending.--If a message has an unknown type, its serial and origin are still useful-for sending an error reply.--<<DBus/Message/Internal.hs>>=-data ReceivedMessage-	= ReceivedMethodCall   Serial (Maybe T.BusName) MethodCall-	| ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn-	| ReceivedError        Serial (Maybe T.BusName) Error-	| ReceivedSignal       Serial (Maybe T.BusName) Signal-	| ReceivedUnknown      Serial (Maybe T.BusName) Unknown-	deriving (Show, Eq)--<<DBus/Message/Internal.hs>>=-receivedSerial :: ReceivedMessage -> Serial-receivedSerial (ReceivedMethodCall   s _ _) = s-receivedSerial (ReceivedMethodReturn s _ _) = s-receivedSerial (ReceivedError        s _ _) = s-receivedSerial (ReceivedSignal       s _ _) = s-receivedSerial (ReceivedUnknown      s _ _) = s--<<DBus/Message/Internal.hs>>=-receivedSender :: ReceivedMessage -> Maybe T.BusName-receivedSender (ReceivedMethodCall   _ s _) = s-receivedSender (ReceivedMethodReturn _ s _) = s-receivedSender (ReceivedError        _ s _) = s-receivedSender (ReceivedSignal       _ s _) = s-receivedSender (ReceivedUnknown      _ s _) = s--<<message exports>>=-, ReceivedMessage (..)-, receivedSerial-, receivedSender--@-\section{Wire format}--<<DBus/Wire.hs>>=-<<copyright>>-<<text extensions>>-<<wire extensions>>-{-# LANGUAGE DeriveDataTypeable #-}-module DBus.Wire (<<wire exports>>) where-<<text imports>>-<<wire imports>>-import Control.Monad (when, unless)-import Data.Maybe (fromJust, listToMaybe, fromMaybe)-import Data.Word (Word8, Word32, Word64)-import Data.Int (Int16, Int32, Int64)-import Data.Typeable (Typeable)--import qualified DBus.Types as T--@ \subsection{Endianness}--<<DBus/Wire.hs>>=-data Endianness = LittleEndian | BigEndian-	deriving (Show, Eq)--encodeEndianness :: Endianness -> Word8-encodeEndianness LittleEndian = 108-encodeEndianness BigEndian    = 66--decodeEndianness :: Word8 -> Maybe Endianness-decodeEndianness 108 = Just LittleEndian-decodeEndianness 66  = Just BigEndian-decodeEndianness _   = Nothing--<<wire exports>>=-  Endianness (..)--@ \subsection{Alignment}--Every built-in type has an associated alignment. If a value of the given-type is marshaled, it must have {\sc nul} bytes inserted until it starts-on a byte index divisible by its alignment.--<<DBus/Wire.hs>>=-alignment :: T.Type -> Word8-<<alignments>>--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--<<wire exports>>=-, alignment--@ \subsection{Marshaling}--Marshaling is implemented using an error transformer over an internal-state.--<<wire imports>>=-import qualified Control.Monad.State as ST-import qualified Control.Monad.Error as E-import qualified Data.ByteString.Lazy as L--<<wire extensions>>=-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--<<DBus/Wire.hs>>=-data MarshalState = MarshalState Endianness L.ByteString-newtype MarshalM a = MarshalM (E.ErrorT MarshalError (ST.State MarshalState) a)-	deriving (Monad, E.MonadError MarshalError, ST.MonadState MarshalState)-type Marshal = MarshalM ()--@ Clients can perform marshaling via {\tt marshal} and {\tt runMarshal},-which will generate a {\tt ByteString} with the fully marshaled data.--<<wire exports>>=-, MarshalM-, Marshal-, marshal-, runMarshal--<<DBus/Wire.hs>>=-runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString-runMarshal (MarshalM m) e = case ST.runState (E.runErrorT m) initialState of-	(Right _, MarshalState _ bytes) -> Right bytes-	(Left  x, _) -> Left x-	where initialState = MarshalState e L.empty--<<DBus/Wire.hs>>=-marshal :: T.Variant -> Marshal-marshal v = marshalType (T.variantType v) where-	x :: T.Variable a => a-	x = fromJust . T.fromVariant $ v-	marshalType :: T.Type -> Marshal-	<<marshalers>>--@ TODO: describe these functions--<<DBus/Wire.hs>>=-append :: L.ByteString -> Marshal-append bs = do-	(MarshalState e bs') <- ST.get-	ST.put $ MarshalState e (L.append bs' bs)--<<DBus/Wire.hs>>=-pad :: Word8 -> Marshal-pad count = do-	(MarshalState _ bytes) <- ST.get-	let padding' = padding (fromIntegral . L.length $ bytes) count-	append $ L.replicate (fromIntegral padding') 0--@ Most numeric values already have marshalers implemented in the-{\tt Data.Binary.Put} module; this function lets them be re-used easily.--<<wire imports>>=-import qualified Data.Binary.Put as P--<<DBus/Wire.hs>>=-marshalPut :: (a -> P.Put) -> a -> Marshal-marshalPut put x = do-	let bytes = P.runPut $ put x-	(MarshalState e _) <- ST.get-	pad . fromIntegral . L.length $ bytes-	append $ case e of-		BigEndian -> bytes-		LittleEndian -> L.reverse bytes--@ \subsubsection{Errors}--Marshaling can fail for four reasons:--\begin{itemize}-\item The message exceeds the maximum message size of $2^{27}$ bytes.-\item An array in the message exceeds the maximum array size of $2^{26}$ bytes.-\item The body's signature is not valid (for example, more than 255 fields).-\item A variant's signature is not valid -- same causes as an invalid body-      signature.-\end{itemize}--<<DBus/Wire.hs>>=-data MarshalError-	= MessageTooLong Word64-	| ArrayTooLong Word64-	| InvalidBodySignature Text-	| InvalidVariantSignature Text-	deriving (Eq, Typeable)--instance Show MarshalError where-	show (MessageTooLong x) = concat-		["Message too long (", show x, " bytes)."]-	show (ArrayTooLong x) = concat-		["Array too long (", show x, " bytes)."]-	show (InvalidBodySignature x) = concat-		["Invalid body signature: ", show x]-	show (InvalidVariantSignature x) = concat-		["Invalid variant signature: ", show x]--instance E.Error MarshalError--<<wire exports>>=-, MarshalError (..)--@ \subsection{Unmarshaling}--Unmarshaling also uses an error transformer and internal state.--<<wire exports>>=-, Unmarshal-, unmarshal-, runUnmarshal--<<DBus/Wire.hs>>=-data UnmarshalState = UnmarshalState Endianness L.ByteString Word64-newtype Unmarshal a = Unmarshal (E.ErrorT UnmarshalError (ST.State UnmarshalState) a)-	deriving (Monad, Functor, E.MonadError UnmarshalError, ST.MonadState UnmarshalState)--<<DBus/Wire.hs>>=-runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a-runUnmarshal (Unmarshal m) e bytes = ST.evalState (E.runErrorT m) state where-	state = UnmarshalState e bytes 0--<<DBus/Wire.hs>>=-unmarshal :: T.Signature -> Unmarshal [T.Variant]-unmarshal = mapM unmarshalType . T.signatureTypes--unmarshalType :: T.Type -> Unmarshal T.Variant-<<unmarshalers>>--@ TODO: describe these functions--<<DBus/Wire.hs>>=-consume :: Word64 -> Unmarshal L.ByteString-consume count = do-	(UnmarshalState e bytes offset) <- ST.get-	let bytes' = L.drop (fromIntegral offset) bytes-	let x = L.take (fromIntegral count) bytes'-	unless (L.length x == fromIntegral count) $-		E.throwError $ UnexpectedEOF offset-	-	ST.put $ UnmarshalState e bytes (offset + count)-	return x--<<DBus/Wire.hs>>=-skipPadding :: Word8 -> Unmarshal ()-skipPadding count = do-	(UnmarshalState _ _ offset) <- ST.get-	bytes <- consume $ padding offset count-	unless (L.all (== 0) bytes) $-		E.throwError $ InvalidPadding offset--<<DBus/Wire.hs>>=-skipTerminator :: Unmarshal ()-skipTerminator = do-	(UnmarshalState _ _ offset) <- ST.get-	bytes <- consume 1-	unless (L.all (== 0) bytes) $-		E.throwError $ MissingTerminator offset--<<DBus/Wire.hs>>=-fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b-fromMaybeU label f x = case f x of-	Just x' -> return x'-	Nothing -> E.throwError . Invalid label . TL.pack . show $ x--fromMaybeU' :: (Show a, T.Variable b) => Text -> (a -> Maybe b) -> a-           -> Unmarshal T.Variant-fromMaybeU' label f x = do-	x' <- fromMaybeU label f x-	return $ T.toVariant x'--<<wire imports>>=-import qualified Data.Binary.Get as G--<<DBus/Wire.hs>>=-unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a-unmarshalGet count be le = do-	skipPadding count-	(UnmarshalState e _ _) <- ST.get-	bs <- consume . fromIntegral $ count-	let get' = case e of-		BigEndian -> be-		LittleEndian -> le-	return $ G.runGet get' bs--unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a-              -> Unmarshal T.Variant-unmarshalGet' count be le = fmap T.toVariant $ unmarshalGet count be le--<<DBus/Wire.hs>>=-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--@ \subsubsection{Errors}--Unmarshaling can fail for four reasons:--\begin{itemize}-\item The message's declared protocol version is unsupported.-\item Unexpected {\sc eof}, when there are less bytes remaining than are-      required.-\item An invalid byte sequence for a given value type.-\item Missing required header fields for the declared message type.-\item Non-zero bytes were found where padding was expected.-\item A string, signature, or object path was not {\sc null}-terminated.-\item An array's size didn't match the number of elements-\end{itemize}--<<DBus/Wire.hs>>=-data UnmarshalError-	= UnsupportedProtocolVersion Word8-	| UnexpectedEOF Word64-	| Invalid Text Text-	| MissingHeaderField Text-	| InvalidHeaderField Text T.Variant-	| InvalidPadding Word64-	| MissingTerminator Word64-	| ArraySizeMismatch-	deriving (Eq, Typeable)--instance Show UnmarshalError where-	show (UnsupportedProtocolVersion x) = concat-		["Unsupported protocol version: ", show x]-	show (UnexpectedEOF pos) = concat-		["Unexpected EOF at position ", show pos]-	show (Invalid label x) = TL.unpack $ TL.concat-		["Invalid ", label, ": ", x]-	show (MissingHeaderField x) = concat-		["Required field " , show x , " is missing."]-	show (InvalidHeaderField x got) = concat-		[ "Invalid header field ", show x, ": ", show got]-	show (InvalidPadding pos) = concat-		["Invalid padding at position ", show pos]-	show (MissingTerminator pos) = concat-		["Missing NUL terminator at position ", show pos]-	show ArraySizeMismatch = "Array size mismatch"--instance E.Error UnmarshalError--<<wire exports>>=-, UnmarshalError (..)--@ \subsection{Numerics}--Numeric values are fixed-length, and aligned ``naturally'' -- ie, a 4-byte-integer will have a 4-byte alignment.--<<alignments>>=-alignment T.DBusByte    = 1-alignment T.DBusWord16  = 2-alignment T.DBusWord32  = 4-alignment T.DBusWord64  = 8-alignment T.DBusInt16   = 2-alignment T.DBusInt32   = 4-alignment T.DBusInt64   = 8-alignment T.DBusDouble  = 8--@ Because {\tt Word32}s are often used for other types, there's-separate functions for handling them.--<<DBus/Wire.hs>>=-marshalWord32 :: Word32 -> Marshal-marshalWord32 = marshalPut P.putWord32be--unmarshalWord32 :: Unmarshal Word32-unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le--<<marshalers>>=-marshalType T.DBusByte   = append $ L.singleton x-marshalType T.DBusWord16 = marshalPut P.putWord16be x-marshalType T.DBusWord32 = marshalPut P.putWord32be x-marshalType T.DBusWord64 = marshalPut P.putWord64be x-marshalType T.DBusInt16  = marshalPut P.putWord16be $ fromIntegral (x :: Int16)-marshalType T.DBusInt32  = marshalPut P.putWord32be $ fromIntegral (x :: Int32)-marshalType T.DBusInt64  = marshalPut P.putWord64be $ fromIntegral (x :: Int64)--<<unmarshalers>>=-unmarshalType T.DBusByte = fmap (T.toVariant . L.head) $ consume 1-unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le-unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le-unmarshalType T.DBusWord64 = unmarshalGet' 8 G.getWord64be G.getWord64le--unmarshalType T.DBusInt16  = do-	x <- unmarshalGet 2 G.getWord16be G.getWord16le-	return . T.toVariant $ (fromIntegral x :: Int16)--unmarshalType T.DBusInt32  = do-	x <- unmarshalGet 4 G.getWord32be G.getWord32le-	return . T.toVariant $ (fromIntegral x :: Int32)--unmarshalType T.DBusInt64  = do-	x <- unmarshalGet 8 G.getWord64be G.getWord64le-	return . T.toVariant $ (fromIntegral x :: Int64)--@ {\tt Double}s are marshaled as in-bit IEEE-754 floating-point format.--<<wire imports>>=-import qualified Data.Binary.IEEE754 as IEEE--<<marshalers>>=-marshalType T.DBusDouble = marshalPut IEEE.putFloat64be x--<<unmarshalers>>=-unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le--@ \subsection{Booleans}--Booleans are marshaled as 4-byte unsigned integers containing either of-the values 0 or 1. Yes, really.--<<alignments>>=-alignment T.DBusBoolean = 4--<<marshalers>>=-marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0--<<unmarshalers>>=-unmarshalType T.DBusBoolean = unmarshalWord32 >>=-	fromMaybeU' "boolean" (\x -> case x of-		0 -> Just False-		1 -> Just True-		_ -> Nothing)--@ \subsection{Strings and object paths}--Strings are encoded in {\sc utf-8}, terminated with {\tt NUL}, and prefixed-with their length as an unsigned 32-bit integer. Their alignment is that of-their length. Object paths are marshaled just like strings, though additional-checks are required when unmarshaling.--TODO: If the input is invalid, these {\sc utf8} functions will raise an-exception, rather than return an error value. Eventually they should be-wrapped with {\tt unsafePerformIO} and be tweaked to return a proper-{\tt Maybe} or {\tt Either}.--<<wire imports>>=-import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)--<<DBus/Wire.hs>>=-marshalText :: Text -> Marshal-marshalText x = do-	let bytes = encodeUtf8 x-	marshalWord32 . fromIntegral . L.length $ bytes-	append bytes-	append (L.singleton 0)--<<DBus/Wire.hs>>=-unmarshalText :: Unmarshal Text-unmarshalText = do-	byteCount <- unmarshalWord32-	bytes <- consume . fromIntegral $ byteCount-	skipTerminator-	return . decodeUtf8 $ bytes--<<alignments>>=-alignment T.DBusString     = 4-alignment T.DBusObjectPath = 4--<<marshalers>>=-marshalType T.DBusString = marshalText x-marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x--<<unmarshalers>>=-unmarshalType T.DBusString = fmap T.toVariant unmarshalText--unmarshalType T.DBusObjectPath = unmarshalText >>=-	fromMaybeU' "object path" T.mkObjectPath--@ \subsection{Signatures}--Signatures are similar to strings, except their length is limited to 255-characters and is therefore stored as a single byte.--<<DBus/Wire.hs>>=-marshalSignature :: T.Signature -> Marshal-marshalSignature x = do-	let bytes = encodeUtf8 . T.strSignature $ x-	let size = fromIntegral . L.length $ bytes-	append (L.singleton size)-	append bytes-	append (L.singleton 0)--<<DBus/Wire.hs>>=-unmarshalSignature :: Unmarshal T.Signature-unmarshalSignature = do-	byteCount <- fmap L.head $ consume 1-	sigText <- fmap decodeUtf8 $ consume . fromIntegral $ byteCount-	skipTerminator-	fromMaybeU "signature" T.mkSignature sigText--<<alignments>>=-alignment T.DBusSignature  = 1--<<marshalers>>=-marshalType T.DBusSignature = marshalSignature x--<<unmarshalers>>=-unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature--@ \subsection{Containers}--@ \subsubsection{Arrays}--<<alignments>>=-alignment (T.DBusArray _) = 4--<<marshalers>>=-marshalType (T.DBusArray _) = marshalArray x--<<unmarshalers>>=-unmarshalType (T.DBusArray t) = fmap T.toVariant $ unmarshalArray t--@ Marshaling arrays is complicated, because the array body must be marshaled-\emph{first} to calculate the array length. This requires building a-temporary marshaler, to get the padding right.--<<wire imports>>=-import qualified DBus.Constants as C--<<DBus/Wire.hs>>=-marshalArray :: T.Array -> Marshal-marshalArray x = do-	(arrayPadding, arrayBytes) <- getArrayBytes x-	let arrayLen = L.length arrayBytes-	when (arrayLen > fromIntegral C.arrayMaximumLength)-		(E.throwError $ ArrayTooLong $ fromIntegral arrayLen)-	marshalWord32 $ fromIntegral arrayLen-	append arrayPadding-	append arrayBytes--<<DBus/Wire.hs>>=-getArrayBytes :: T.Array -> MarshalM (L.ByteString, L.ByteString)-getArrayBytes x = do-	let vs = T.arrayItems x-	let itemType = T.arrayType x-	s <- ST.get-	(MarshalState _ afterLength) <- marshalWord32 0 >> ST.get-	(MarshalState _ afterPadding) <- pad (alignment itemType) >> ST.get-	(MarshalState _ afterItems) <- mapM_ marshal vs >> ST.get-	-	let paddingBytes = L.drop (L.length afterLength) afterPadding-	let itemBytes = L.drop (L.length afterPadding) afterItems-	-	ST.put s-	return (paddingBytes, itemBytes)--@ Unmarshaling is much easier--<<DBus/Wire.hs>>=-unmarshalArray :: T.Type -> Unmarshal T.Array-unmarshalArray itemType = do-	let getOffset = do-		(UnmarshalState _ _ o) <- ST.get-		return o-	byteCount <- unmarshalWord32-	skipPadding (alignment itemType)-	start <- getOffset-	let end = start + fromIntegral byteCount-	vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType)-	end' <- getOffset-	when (end' > end) $-		E.throwError ArraySizeMismatch-	fromMaybeU "array" (T.arrayFromItems itemType) vs--@ \subsubsection{Dictionaries}--<<alignments>>=-alignment (T.DBusDictionary _ _) = 4--<<marshalers>>=-marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x)--<<unmarshalers>>=-unmarshalType (T.DBusDictionary kt vt) = do-	let pairType = T.DBusStructure [kt, vt]-	array <- unmarshalArray pairType-	fromMaybeU' "dictionary" T.arrayToDictionary array--@ \subsubsection{Structures}--<<alignments>>=-alignment (T.DBusStructure _) = 8--<<marshalers>>=-marshalType (T.DBusStructure _) = do-	let T.Structure vs = x-	pad 8-	mapM_ marshal vs--<<unmarshalers>>=-unmarshalType (T.DBusStructure ts) = do-	skipPadding 8-	fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts--@ \subsubsection{Variants}--<<alignments>>=-alignment T.DBusVariant = 1--<<marshalers>>=-marshalType T.DBusVariant = do-	let rawSig = T.typeCode . T.variantType $ x-	sig <- case T.mkSignature rawSig of-		Just x' -> return x'-		Nothing -> E.throwError $ InvalidVariantSignature rawSig-	marshalSignature sig-	marshal x--<<unmarshalers>>=-unmarshalType T.DBusVariant = do-	let getType sig = case T.signatureTypes sig of-		[t] -> Just t-		_   -> Nothing-	-	t <- fromMaybeU "variant signature" getType =<< unmarshalSignature-	fmap T.toVariant $ unmarshalType t--@ \subsection{Messages}--<<wire imports>>=-import qualified DBus.Message.Internal as M--@ \subsubsection{Flags}--<<wire imports>>=-import Data.Bits ((.|.), (.&.))-import qualified Data.Set as Set--<<DBus/Wire.hs>>=-encodeFlags :: Set.Set M.Flag -> Word8-encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where-	flagValue M.NoReplyExpected = 0x1-	flagValue M.NoAutoStart     = 0x2--decodeFlags :: Word8 -> Set.Set M.Flag-decodeFlags word = Set.fromList flags where-	flagSet = [ (0x1, M.NoReplyExpected)-	          , (0x2, M.NoAutoStart)-	          ]-	flags = flagSet >>= \(x, y) -> [y | word .&. x > 0]--@ \subsubsection{Header fields}--<<DBus/Wire.hs>>=-encodeField :: M.HeaderField -> T.Structure-encodeField (M.Path x)        = encodeField' 1 x-encodeField (M.Interface x)   = encodeField' 2 x-encodeField (M.Member x)      = encodeField' 3 x-encodeField (M.ErrorName x)   = encodeField' 4 x-encodeField (M.ReplySerial x) = encodeField' 5 x-encodeField (M.Destination x) = encodeField' 6 x-encodeField (M.Sender x)      = encodeField' 7 x-encodeField (M.Signature x)   = encodeField' 8 x--encodeField' :: T.Variable a => Word8 -> a -> T.Structure-encodeField' code x = T.Structure-	[ T.toVariant code-	, T.toVariant $ T.toVariant x-	]--<<DBus/Wire.hs>>=-decodeField :: Monad m => T.Structure-            -> E.ErrorT UnmarshalError m [M.HeaderField]-decodeField struct = case unpackField struct of-	(1, x) -> decodeField' x M.Path "path"-	(2, x) -> decodeField' x M.Interface "interface"-	(3, x) -> decodeField' x M.Member "member"-	(4, x) -> decodeField' x M.ErrorName "error name"-	(5, x) -> decodeField' x M.ReplySerial "reply serial"-	(6, x) -> decodeField' x M.Destination "destination"-	(7, x) -> decodeField' x M.Sender "sender"-	(8, x) -> decodeField' x M.Signature "signature"-	_      -> return []--decodeField' :: (Monad m, T.Variable a) => T.Variant -> (a -> b) -> Text-             -> E.ErrorT UnmarshalError m [b]-decodeField' x f label = case T.fromVariant x of-	Just x' -> return [f x']-	Nothing -> E.throwError $ InvalidHeaderField label x--<<DBus/Wire.hs>>=-unpackField :: T.Structure -> (Word8, T.Variant)-unpackField struct = (c', v') where-	T.Structure [c, v] = struct-	c' = fromJust . T.fromVariant $ c-	v' = fromJust . T.fromVariant $ v--@ \subsubsection{Header layout}--TODO: describe header layout here--@ \subsubsection{Marshaling}--<<wire exports>>=-, marshalMessage--<<DBus/Wire.hs>>=-marshalMessage :: M.Message a => Endianness -> M.Serial -> a-               -> Either MarshalError L.ByteString-marshalMessage e serial msg = runMarshal marshaler e where-	body = M.messageBody msg-	marshaler = do-		sig <- checkBodySig body-		empty <- ST.get-		mapM_ marshal body-		(MarshalState _ bodyBytes) <- ST.get-		ST.put empty-		marshalEndianness e-		marshalHeader msg serial sig-			$ fromIntegral . L.length $ bodyBytes-		pad 8-		append bodyBytes-		checkMaximumSize--<<DBus/Wire.hs>>=-checkBodySig :: [T.Variant] -> MarshalM T.Signature-checkBodySig vs = let-	sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs-	invalid = E.throwError $ InvalidBodySignature sigStr-	in case T.mkSignature sigStr of-		Just x -> return x-		Nothing -> invalid--<<DBus/Wire.hs>>=-marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32-              -> Marshal-marshalHeader msg serial bodySig bodyLength = do-	let fields = M.Signature bodySig : M.messageHeaderFields msg-	marshal . T.toVariant . M.messageTypeCode $ msg-	marshal . T.toVariant . encodeFlags . M.messageFlags $ msg-	marshal . T.toVariant $ C.protocolVersion-	marshalWord32 bodyLength-	marshal . T.toVariant $ serial-	let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant]-	marshal . T.toVariant . fromJust . T.toArray fieldType-	        $ map encodeField fields--<<DBus/Wire.hs>>=-marshalEndianness :: Endianness -> Marshal-marshalEndianness = marshal . T.toVariant . encodeEndianness--<<DBus/Wire.hs>>=-checkMaximumSize :: Marshal-checkMaximumSize = do-	(MarshalState _ messageBytes) <- ST.get-	let messageLength = L.length messageBytes-	when (messageLength > fromIntegral C.messageMaximumLength)-		(E.throwError $ MessageTooLong $ fromIntegral messageLength)--@ \subsubsection{Unmarshaling}--<<wire exports>>=-, unmarshalMessage--<<DBus/Wire.hs>>=-unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)-                 -> m (Either UnmarshalError M.ReceivedMessage)-unmarshalMessage getBytes' = E.runErrorT $ do-	let getBytes = E.lift . getBytes'-	-	<<read fixed-length header>>-	<<read full header>>-	<<read body>>-	<<build message>>--@ The first part of the header has a fixed size of 16 bytes, so it can be-retrieved without any size calculations.--<<read fixed-length header>>=-let fixedSig = T.mkSignature' "yyyyuuu"-fixedBytes <- getBytes 16--@ The first field of interest is the protocol version; if the incoming-message's version is different from this library, the message cannot be-parsed.--<<read fixed-length header>>=-let messageVersion = L.index fixedBytes 3-when (messageVersion /= C.protocolVersion) $-	E.throwError $ UnsupportedProtocolVersion messageVersion--@ Next is the endianness, used for parsing pretty much every other field.--<<read fixed-length header>>=-let eByte = L.index fixedBytes 0-endianness <- case decodeEndianness eByte of-	Just x' -> return x'-	Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte--@ With the endianness out of the way, the rest of the fixed header-can be decoded--<<read fixed-length header>>=-let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of-	Right x' -> return x'-	Left  e  -> E.throwError e-fixed <- unmarshal' fixedSig fixedBytes-let typeCode = fromJust . T.fromVariant $ fixed !! 1-let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2-let bodyLength = fromJust . T.fromVariant $ fixed !! 4-let serial = fromJust . T.fromVariant $ fixed !! 5--@ The last field of the fixed header is actually part of the field array,-but is treated as a single {\tt Word32} so it'll be known how many bytes-to retrieve.--<<read fixed-length header>>=-let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6--@ With the field byte count, the remainder of the header bytes can be-pulled out of the monad.--<<read full header>>=-let headerSig  = T.mkSignature' "yyyyuua(yv)"-fieldBytes <- getBytes fieldByteCount-let headerBytes = L.append fixedBytes fieldBytes-header <- unmarshal' headerSig headerBytes--@ And the header fields can be parsed.--<<read full header>>=-let fieldArray = fromJust . T.fromVariant $ header !! 6-let fieldStructures = fromJust . T.fromArray $ fieldArray-fields <- fmap concat $ mapM decodeField fieldStructures--@ The body is always aligned to 8 bytes, so pull out the padding before-unmarshaling it.--<<read body>>=-let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8-getBytes . fromIntegral $ bodyPadding--<<DBus/Wire.hs>>=-findBodySignature :: [M.HeaderField] -> T.Signature-findBodySignature fields = fromMaybe empty signature where-	empty = T.mkSignature' ""-	signature = listToMaybe [x | M.Signature x <- fields]--<<read body>>=-let bodySig = findBodySignature fields--@ Then pull the body bytes, and unmarshal it.--<<read body>>=-bodyBytes <- getBytes bodyLength-body <- unmarshal' bodySig bodyBytes--@ Even if the received message was structurally valid, building the-{\tt ReceivedMessage} can still fail due to missing header fields.--<<build message>>=-y <- case buildReceivedMessage typeCode fields of-	Right x -> return x-	Left x -> E.throwError $ MissingHeaderField x--<<build message>>=-return $ y serial flags body--@ This really belongs in the Message section...--<<DBus/Wire.hs>>=-buildReceivedMessage :: Word8 -> [M.HeaderField] -> Either Text -                        (M.Serial -> (Set.Set M.Flag) -> [T.Variant]-                         -> M.ReceivedMessage)--@ Method calls--<<DBus/Wire.hs>>=-buildReceivedMessage 1 fields = do-	path <- require "path" [x | M.Path x <- fields]-	member <- require "member name" [x | M.Member x <- fields]-	return $ \serial flags body -> let-		iface = listToMaybe [x | M.Interface x <- fields]-		dest = listToMaybe [x | M.Destination x <- fields]-		sender = listToMaybe [x | M.Sender x <- fields]-		msg = M.MethodCall path member iface dest flags body-		in M.ReceivedMethodCall serial sender msg--@ Method returns--<<DBus/Wire.hs>>=-buildReceivedMessage 2 fields = do-	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]-	return $ \serial flags body -> let-		dest = listToMaybe [x | M.Destination x <- fields]-		sender = listToMaybe [x | M.Sender x <- fields]-		msg = M.MethodReturn replySerial dest flags body-		in M.ReceivedMethodReturn serial sender msg--@ Errors--<<DBus/Wire.hs>>=-buildReceivedMessage 3 fields = do-	name <- require "error name" [x | M.ErrorName x <- fields]-	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]-	return $ \serial flags body -> let-		dest = listToMaybe [x | M.Destination x <- fields]-		sender = listToMaybe [x | M.Sender x <- fields]-		msg = M.Error name replySerial dest flags body-		in M.ReceivedError serial sender msg--@ Signals--<<DBus/Wire.hs>>=-buildReceivedMessage 4 fields = do-	path <- require "path" [x | M.Path x <- fields]-	member <- require "member name" [x | M.Member x <- fields]-	iface <- require "interface" [x | M.Interface x <- fields]-	return $ \serial flags body -> let-		dest = listToMaybe [x | M.Destination x <- fields]-		sender = listToMaybe [x | M.Sender x <- fields]-		msg = M.Signal path member iface dest flags body-		in M.ReceivedSignal serial sender msg--@ Unknown--<<DBus/Wire.hs>>=-buildReceivedMessage typeCode fields = return $ \serial flags body -> let-	sender = listToMaybe [x | M.Sender x <- fields]-	msg = M.Unknown typeCode flags body-	in M.ReceivedUnknown serial sender msg--<<DBus/Wire.hs>>=-require :: Text -> [a] -> Either Text a-require _     (x:_) = Right x-require label _     = Left label--@ This is just needed for the Monad instance of {\tt Either Text}--<<DBus/Wire.hs>>=-instance E.Error Text where-	strMsg = TL.pack--@-\section{Connections}--<<DBus/Connection.hs>>=-<<copyright>>-<<text extensions>>-{-# LANGUAGE DeriveDataTypeable #-}-module DBus.Connection-	( <<connection exports>>-	) where-<<text imports>>-<<connection imports>>--@ A {\tt Connection} is an opaque handle to an open DBus channel, with-an internal state for maintaining the current message serial.--<<connection imports>>=-import qualified Control.Concurrent as C-import qualified DBus.Address as A-import qualified DBus.Message.Internal as M--<<DBus/Connection.hs>>=-data Connection = Connection A.Address Transport (C.MVar M.Serial)--<<connection exports>>=-  Connection--@ While not particularly useful for other functions, being able to-{\tt show} a {\tt Connection} is useful when debugging.--<<DBus/Connection.hs>>=-instance Show Connection where-	showsPrec d (Connection a _ _) = showParen (d > 10) $-		showString' ["<connection ", show $ A.strAddress a, ">"] where-		showString' = foldr (.) id . map showString--@ \subsection{Transports}--A transport is anything which can send and receive bytestrings, typically-over a socket.--<<connection imports>>=-import qualified Data.ByteString.Lazy as L-import Data.Word (Word32)--<<DBus/Connection.hs>>=-data Transport = Transport-	{ transportSend :: L.ByteString -> IO ()-	, transportRecv :: Word32 -> IO L.ByteString-	}--<<DBus/Connection.hs>>=-connectTransport :: A.Address -> IO Transport-connectTransport a = transport' (A.addressMethod a) a where-	transport' "unix" = unix-	transport' _      = unknownTransport--@ \subsubsection{UNIX}--The {\sc unix} transport accepts two parameters: {\tt path}, which is a-simple filesystem path, and {\tt abstract}, which is a path in the-Linux-specific abstract domain. One, and only one, of these parameters must-be specified.--<<connection imports>>=-import qualified Network as N-import qualified Data.Map as Map--<<DBus/Connection.hs>>=-unix :: A.Address -> IO Transport-unix a = handleTransport . N.connectTo "localhost" =<< port where-	params = A.addressParameters a-	path = Map.lookup "path" params-	abstract = Map.lookup "abstract" params-	-	tooMany = "Only one of `path' or `abstract' may be specified for the\-	          \ `unix' method."-	tooFew = "One of `path' or `abstract' must be specified for the\-	         \ `unix' transport."-	-	port = fmap N.UnixSocket path'-	path' = case (path, abstract) of-		(Just _, Just _) -> E.throwIO $ BadParameters a tooMany-		(Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew-		(Just x, Nothing) -> return $ TL.unpack x-		(Nothing, Just x) -> return $ '\x00' : TL.unpack x--@ \subsubsection{TCP}--known parameters:--\begin{itemize}-\item {\tt host} (optional, default "{\tt localhost}")-\item {\tt port}-\item {\tt family} (optional, choices are "{\tt ipv4}" or "{\tt ipv6}"-\end{itemize}--TCP support is TODO--<<TODO>>=-tcp :: A.Address -> IO Transport-tcp a@(A.Address _ params) = handleTransport a connect' where-	host = lookup "host" params-	port = parsePort =<< lookup "post" params-	family = parseFamily =<< lookup "family" params-	connect' = do-		-- check host-		-- check port-		-- check family-		-- return handle-parsePort :: String -> Maybe PortNumber--parseFamily :: String -> Maybe Family--@ \subsubsection{Generic handle-based transport}--Both UNIX and TCP are backed by standard handles, and can therefore use-a shared handle-based transport backend.--<<connection imports>>=-import qualified System.IO as I--<<DBus/Connection.hs>>=-handleTransport :: IO I.Handle -> IO Transport-handleTransport io = do-	h <- io-	I.hSetBuffering h I.NoBuffering-	I.hSetBinaryMode h True-	return $ Transport (L.hPut h) (L.hGet h . fromIntegral)--@ \subsubsection{Unknown transports}--If a method has no known transport, attempting to connect using it will-just result in an exception.--<<DBus/Connection.hs>>=-unknownTransport :: A.Address -> IO Transport-unknownTransport = E.throwIO . UnknownMethod--@ \subsection{Errors}--If connecting to DBus fails, a {\tt ConnectionError} will be thrown.-The constructor describes which exception occurred.--<<connection imports>>=-import qualified Control.Exception as E-import Data.Typeable (Typeable)--<<DBus/Connection.hs>>=-data ConnectionError-	= InvalidAddress Text-	| BadParameters A.Address Text-	| UnknownMethod A.Address-	| NoWorkingAddress [A.Address]-	deriving (Show, Typeable)--instance E.Exception ConnectionError--<<connection exports>>=-, ConnectionError (..)-, W.MarshalError (..)-, W.UnmarshalError (..)--@ \subsection{Establishing a connection}--A connection can be opened to any valid address, though actually connecting-might fail due to external factors.--<<connection imports>>=-import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)--<<DBus/Connection.hs>>=-connect :: A.Address -> IO Connection-connect a = do-	t <- connectTransport a-	let putS = transportSend t . encodeUtf8 . TL.pack-	let getS = fmap (TL.unpack . decodeUtf8) . transportRecv t-	authenticate putS getS-	serialMVar <- C.newMVar M.firstSerial-	return $ Connection a t serialMVar--<<connection exports>>=-, connect--@ \subsection{Authentication}--<<DBus/Connection.hs>>=-authenticate :: (String -> IO ()) -> (Word32 -> IO String)-                -> IO ()-authenticate put get = do-	put "\x00"--@ {\sc external} authentication is performed using the process's real user-ID, converted to a string, and then hex-encoded.--<<connection imports>>=-import System.Posix.User (getRealUserID)-import Data.Char (ord)-import Text.Printf (printf)--<<DBus/Connection.hs>>=-	uid <- getRealUserID-	let authToken = concatMap (printf "%02X" . ord) (show uid)-	put $ "AUTH EXTERNAL " ++ authToken ++ "\r\n"--@ If authentication was successful, the server responds with {\tt OK-<server GUID>}.  The GUID is intended to enable connection sharing, which-is currently unimplemented, so it's ignored.--<<connection imports>>=-import Data.List (isPrefixOf)--<<DBus/Connection.hs>>=-	response <- readUntil '\n' get-	if "OK" `isPrefixOf` response-		then put "BEGIN\r\n"-		else do-			putStrLn $ "response = " ++ show response-			error "Server rejected authentication token."--<<DBus/Connection.hs>>=-readUntil :: Monad m => Char -> (Word32 -> m String) -> m String-readUntil = readUntil' "" where-	readUntil' xs c f = do-		[x] <- f 1-		let xs' = xs ++ [x]-		if x == c-			then return xs'-			else readUntil' xs' c f--@ \subsection{Sending and receiving messages}--Sending a message will increment the connection's internal serial state.-The second parameter is present to allow registration of a callback before-the message has actually been sent, which avoids race conditions in-multi-threaded clients.--<<connection imports>>=-import qualified DBus.Wire as W--<<DBus/Connection.hs>>=-send :: M.Message a => Connection -> (M.Serial -> IO b) -> a-     -> IO (Either W.MarshalError b)-send (Connection _ t mvar) io msg = withSerial mvar $ \serial ->-	case W.marshalMessage W.LittleEndian serial msg of-		Right bytes -> do-			x <- io serial-			transportSend t bytes-			return $ Right x-		Left  err   -> return $ Left err--<<connection exports>>=-, send--<<DBus/Connection.hs>>=-withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a-withSerial m io = E.block $ do-	s <- C.takeMVar m-	let s' = M.nextSerial s-	x <- E.unblock (io s) `E.onException` C.putMVar m s'-	C.putMVar m s'-	return x--@ Messages are received wrapped in a {\tt ReceivedMessage} value. If an-error is encountered while unmarshaling, an exception will be thrown.--<<DBus/Connection.hs>>=-receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage)-receive (Connection _ t _) = W.unmarshalMessage $ transportRecv t--<<connection exports>>=-, receive--@-\section{The central bus}--<<DBus/Bus.hs>>=-<<copyright>>-<<text extensions>>-module DBus.Bus-	( getSystemBus-	, getSessionBus-	, getStarterBus-	, getFirstBus-	, getBus-	) where-<<text imports>>--import qualified Control.Exception as E-import Control.Monad (when)-import Data.Maybe (fromJust, isNothing)-import qualified Data.Set as Set-import System.Environment (getEnv)--import qualified DBus.Address as A-import qualified DBus.Connection as C-import DBus.Constants (dbusName, dbusPath, dbusInterface)-import qualified DBus.Message as M-import qualified DBus.Types as T-import DBus.Util (fromRight)--@ Connecting to a message bus is a bit more involved than just connecting-over an app-to-app connection: the bus must be notified of the new client,-using a "hello message", before it will begin forwarding messages.--<<DBus/Bus.hs>>=-getBus :: A.Address -> IO (C.Connection, T.BusName)-getBus addr = do-	c <- C.connect addr-	name <- sendHello c-	return (c, name)--@ Optionally, multiple addresses may be provided. The first successfully-connected bus will be returned.--<<DBus/Bus.hs>>=-getFirstBus :: [A.Address] -> IO (C.Connection, T.BusName)-getFirstBus as = getFirstBus' as as--getFirstBus' :: [A.Address] -> [A.Address] -> IO (C.Connection, T.BusName)-getFirstBus' orig     [] = E.throwIO $ C.NoWorkingAddress orig-getFirstBus' orig (a:as) = E.catch (getBus a) onError where-	onError :: E.SomeException -> IO (C.Connection, T.BusName)-	onError _ = getFirstBus' orig as--@ \subsection{Default connections}--Two default buses are defined, the ``system'' and ``session'' buses. The system-bus is global for the OS, while the session bus runs only for the duration-of the user's session.--<<DBus/Bus.hs>>=-getSystemBus :: IO (C.Connection, T.BusName)-getSystemBus = getBus' $ fromEnv `E.catch` noEnv where-	defaultAddr = "unix:path=/var/run/dbus/system_bus_socket"-	fromEnv = getEnv "DBUS_SYSTEM_BUS_ADDRESS"-	noEnv (E.SomeException _) = return defaultAddr--<<DBus/Bus.hs>>=-getSessionBus :: IO (C.Connection, T.BusName)-getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS"--<<DBus/Bus.hs>>=-getStarterBus :: IO (C.Connection, T.BusName)-getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS"--<<DBus/Bus.hs>>=-getBus' :: IO String -> IO (C.Connection, T.BusName)-getBus' io = do-	addr <- fmap TL.pack io-	case A.mkAddresses addr of-		Just [x] -> getBus x-		Just  x  -> getFirstBus x-		_        -> E.throwIO $ C.InvalidAddress addr--@ \subsection{Sending the ``hello'' message}--<<DBus/Bus.hs>>=-hello :: M.MethodCall-hello = M.MethodCall dbusPath-	(T.mkMemberName' "Hello")-	(Just dbusInterface)-	(Just dbusName)-	Set.empty-	[]--<<DBus/Bus.hs>>=-sendHello :: C.Connection -> IO T.BusName-sendHello c = do-	serial <- fromRight `fmap` C.send c return hello-	reply <- waitForReply c serial-	let name = case M.methodReturnBody reply of-		(x:_) -> T.fromVariant x-		_     -> Nothing-	-	when (isNothing name) $-		E.throwIO $ E.AssertionFailed "Invalid response to Hello()"-	-	return . fromJust $ name--<<DBus/Bus.hs>>=-waitForReply :: C.Connection -> M.Serial -> IO M.MethodReturn-waitForReply c serial = do-	received <- C.receive c-	msg <- case received of-		Right x -> return x-		Left err -> E.throwIO $ E.AssertionFailed "Invalid response to Hello()"-	case msg of-		(M.ReceivedMethodReturn _ _ reply) ->-			if M.methodReturnSerial reply == serial-				then return reply-				else waitForReply c serial-		_ -> waitForReply c serial--@-\section{Addresses}--<<DBus/Address.hs>>=-<<copyright>>-<<text extensions>>-module DBus.Address-	( Address-	, addressMethod-	, addressParameters-	, mkAddresses-	, strAddress-	) where-<<text imports>>--import Data.Char (ord, chr)-import qualified Data.Map as M-import Text.Printf (printf)-import qualified Text.Parsec as P-import Text.Parsec ((<|>))-import DBus.Util (hexToInt, eitherToMaybe)--@ \subsection{Address syntax}--A bus address is in the format {\tt $method$:$key$=$value$,$key$=$value$...}-where the method may be empty and parameters are optional. An address's-parameter list, if present, may end with a comma. Addresses in environment-variables are separated by semicolons, and the full address list may end-in a semicolon. Multiple parameters may have the same key; in this case,-only the first parameter for each key will be stored.--The bytes allowed in each component of the address are given by the following-chart, where each character is understood to be its ASCII value:--\begin{table}[h]-\begin{center}-\begin{tabular}{ll}-\toprule-Component   & Allowed Characters \\-\midrule-Method      & Any except {\tt `;'} and {\tt `:'} \\-Param key   & Any except {\tt `;'}, {\tt `,'}, and {\tt `='} \\-Param value & {\tt `0'} to {\tt `9'} \\-            & {\tt `a'} to {\tt `z'} \\-            & {\tt `A'} to {\tt `Z'} \\-            & Any of: {\tt - \textunderscore{} / \textbackslash{} * . \%} \\-\bottomrule-\end{tabular}-\end{center}-\end{table}--In parameter values, any byte may be encoded by prepending the \% character-to its value in hexadecimal. \% is not allowed to appear unless it is-followed by two hexadecimal digits. Every other allowed byte is termed-an ``optionally encoded'' byte, and may appear unescaped in parameter-values.--<<DBus/Address.hs>>=-optionallyEncoded :: [Char]-optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."--@-The address simply stores its method and parameter map, with a custom-{\tt Show} instance to provide easier debugging.--<<DBus/Address.hs>>=-data Address = Address-	{ addressMethod     :: Text-	, addressParameters :: M.Map Text Text-	} deriving (Eq)--instance Show Address where-	showsPrec d x = showParen (d> 10) $-		showString "Address " . shows (strAddress x)--@-Parsing is straightforward; the input string is divided into addresses by-semicolons, then further by colons and commas. Parsing will fail if any-of the addresses in the input failed to parse.--<<DBus/Address.hs>>=-mkAddresses :: Text -> Maybe [Address]-mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where-	address = do-		method <- P.many (P.noneOf ":;")-		P.char ':'-		params <- P.sepEndBy param (P.char ',')-		return $ Address (TL.pack method) (M.fromList params)-	-	param = do-		key <- P.many1 (P.noneOf "=;,")-		P.char '='-		value <- P.many1 (encodedValue <|> unencodedValue)-		return (TL.pack key, TL.pack value)-	-	parser = do-		as <- P.sepEndBy1 address (P.char ';')-		P.eof-		return as-	-	unencodedValue = P.oneOf optionallyEncoded-	encodedValue = do-		P.char '%'-		hex <- P.count 2 P.hexDigit-		return . chr . hexToInt $ hex--@-Converting an {\tt Address} back to a {\tt String} is just the reverse-operation. Note that because the original parameter order is not preserved,-the string produced might differ from the original input.--<<DBus/Address.hs>>=-strAddress :: Address -> Text-strAddress (Address t ps) = TL.concat [t, ":", ps'] where-	ps' = TL.intercalate "," $ do-		(k, v) <- M.toList ps-		return $ TL.concat [k, "=", TL.concatMap encode v]-	encode c | elem c optionallyEncoded = TL.singleton c-	         | otherwise       = TL.pack $ printf "%%%02X" (ord c)---@-\section{Introspection}--@ DBus objects may be ``introspected'' to determine which methods, signals,-etc they support. Intospection data is sent over the bus in {\sc xml}, in-a mostly standardised but undocumented format.--An XML introspection document looks like this:--\begin{verbatim}-<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"-         "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">-<node name="/org/example/example">-	<interface name="org.example.ExampleInterface">-		<method name="Echo">-			<arg name="text" type="s" direction="in"/>-			<arg type="s" direction="out"/>-		</method>-		<signal name="Echoed">-			<arg type="s"/>-		</signal>-		<property name="EchoCount" type="u" access="read"/>-	</interface>-	<node name="child_a"/>-	<node name="child/b"/>-</node>-\end{verbatim}--<<DBus/Introspection.hs>>=-<<copyright>>-<<text extensions>>-module DBus.Introspection-	( Object (..)-	, Interface (..)-	, Method (..)-	, Signal (..)-	, Parameter (..)-	, Property (..)-	, PropertyAccess (..)-	, toXML-	, fromXML-	) where-<<text imports>>-<<introspection imports>>-import qualified DBus.Types as T--@ HaXml is used to do the heavy lifting of XML parsing because HXT cannot-be combined with Parsec 3.--<<introspection imports>>=-import qualified Text.XML.HaXml as H--@ \subsection{Data types}--<<DBus/Introspection.hs>>=-data Object = Object T.ObjectPath [Interface] [Object]-	deriving (Show, Eq)--data Interface = Interface T.InterfaceName [Method] [Signal] [Property]-	deriving (Show, Eq)--data Method = Method T.MemberName [Parameter] [Parameter]-	deriving (Show, Eq)--data Signal = Signal T.MemberName [Parameter]-	deriving (Show, Eq)--data Parameter = Parameter Text T.Signature-	deriving (Show, Eq)--data Property = Property Text T.Signature [PropertyAccess]-	deriving (Show, Eq)--data PropertyAccess = Read | Write-	deriving (Show, Eq)--@ \subsection{Parsing XML}--The root {\tt node} is special, in that it's the only {\tt node} which is-not required to have a {\tt name} attribute. If the root has no {\tt name},-its path will default to the path of the introspected object.--If parsing fails, {\tt fromXML} will return {\tt Nothing}. Aside from the-elements directly accessed by the parser, no effort is made to check the-document's validity because there is no DTD as of yet.--<<introspection imports>>=-import Text.XML.HaXml.Parse (xmlParse')-import DBus.Util (eitherToMaybe)--<<DBus/Introspection.hs>>=-fromXML :: T.ObjectPath -> Text -> Maybe Object-fromXML path text = do-	doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text-	let (H.Document _ _ root _) = doc-	parseRoot path root--@ Even though the root object's {\tt name} is optional, if present, it must-still be a valid object path.--<<DBus/Introspection.hs>>=-parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object-parseRoot defaultPath e = do-	path <- case getAttr "name" e of-		Nothing -> Just defaultPath-		Just x  -> T.mkObjectPath x-	parseObject' path e--@ Child {\tt nodes} have ``relative'' paths -- that is, their {\tt name}-attribute is not a valid object path, but should be valid when appended to-the root object's path.--<<DBus/Introspection.hs>>=-parseChild :: T.ObjectPath -> H.Element a -> Maybe Object-parseChild parentPath e = do-	let parentPath' = case T.strObjectPath parentPath of-		"/" -> "/"-		x   -> TL.append x "/"-	pathSegment <- getAttr "name" e-	path <- T.mkObjectPath $ TL.append parentPath' pathSegment-	parseObject' path e--@ Other than the name, both root and non-root {\tt nodes} have identical-contents.  They may contain interface definitions, and child {\tt node}s.--<<DBus/Introspection.hs>>=-parseObject' :: T.ObjectPath -> H.Element a -> Maybe Object-parseObject' path e@(H.Elem "node" _ _)  = do-	interfaces <- children parseInterface (H.tag "interface") e-	children' <- children (parseChild path) (H.tag "node") e-	return $ Object path interfaces children'-parseObject' _ _ = Nothing--@ Interfaces may contain methods, signals, and properties.--<<DBus/Introspection.hs>>=-parseInterface :: H.Element a -> Maybe Interface-parseInterface e = do-	name <- T.mkInterfaceName =<< getAttr "name" e-	methods <- children parseMethod (H.tag "method") e-	signals <- children parseSignal (H.tag "signal") e-	properties <- children parseProperty (H.tag "property") e-	return $ Interface name methods signals properties--@ Methods contain a list of parameters, which default to ``in'' parameters-if no direction is specified.--<<DBus/Introspection.hs>>=-parseMethod :: H.Element a -> Maybe Method-parseMethod e = do-	name <- T.mkMemberName =<< getAttr "name" e-	paramsIn <- children parseParameter (isParam ["in", ""]) e-	paramsOut <- children parseParameter (isParam ["out"]) e-	return $ Method name paramsIn paramsOut--@ Signals are similar to methods, except they have no ``in'' parameters.--<<DBus/Introspection.hs>>=-parseSignal :: H.Element a -> Maybe Signal-parseSignal e = do-	name <- T.mkMemberName =<< getAttr "name" e-	params <- children parseParameter (isParam ["out", ""]) e-	return $ Signal name params--@ A parameter has a free-form name, and a single valid type.--<<DBus/Introspection.hs>>=-parseParameter :: H.Element a -> Maybe Parameter-parseParameter e = do-	let name = getAttr' "name" e-	sig <- parseType e-	return $ Parameter name sig--<<DBus/Introspection.hs>>=-parseType :: H.Element a -> Maybe T.Signature-parseType e = do-	sig <- T.mkSignature =<< getAttr "type" e-	case T.signatureTypes sig of-		[_] -> Just sig-		_   -> Nothing--@ Properties are used by the {\tt org.freedesktop.DBus.Properties} interface.-Each property may be read, written, or both, and has an associated type.--<<DBus/Introspection.hs>>=-parseProperty :: H.Element a -> Maybe Property-parseProperty e = do-	let name = getAttr' "name" e-	sig <- parseType e-	access <- case getAttr' "access" e of-		""          -> Just []-		"read"      -> Just [Read]-		"write"     -> Just [Write]-		"readwrite" -> Just [Read, Write]-		_           -> Nothing-	return $ Property name sig access--@ HaXml doesn't seem to have any way to retrieve the ``real'' value of an-attribute, so {\tt attrValue} implements this.--<<introspection imports>>=-import Data.Char (chr)--<<DBus/Introspection.hs>>=-attrValue :: H.AttValue -> Maybe Text-attrValue attr = fmap (TL.pack . concat) $ mapM unescape parts where-	(H.AttValue parts) = attr-	-	unescape (Left x) = Just x-	unescape (Right (H.RefEntity x)) = lookup x namedRefs-	unescape (Right (H.RefChar x)) = Just [chr x]-	-	namedRefs =-		[ ("lt", "<")-		, ("gt", ">")-		, ("amp", "&")-		, ("apos", "'")-		, ("quot", "\"")-		]--@ Some helper functions for dealing with HaXml filters--<<introspection imports>>=-import Data.Maybe (fromMaybe)--<<DBus/Introspection.hs>>=-getAttr :: String -> H.Element a -> Maybe Text-getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue--getAttr' :: String -> H.Element a -> Text-getAttr' = (fromMaybe "" .) . getAttr--<<DBus/Introspection.hs>>=-isParam :: [Text] -> H.CFilter a-isParam dirs content = do-	arg@(H.CElem e _) <- H.tag "arg" content-	let direction = getAttr' "direction" e-	[arg | direction `elem` dirs]--<<DBus/Introspection.hs>>=-children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b]-children f filt (H.Elem _ _ contents) = do-	mapM f [x | (H.CElem x _) <- concatMap filt contents]--@ \subsection{Generating XML}--<<DBus/Introspection.hs>>=-dtdPublicID, dtdSystemID :: String-dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"-dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"--@ HaXml punts to the {\tt pretty} package for serialising XML.--<<introspection imports>>=-import Text.XML.HaXml.Pretty (document)-import Text.PrettyPrint.HughesPJ (render)--@ Generating XML can fail; if a child object's path is not a sub-path of the-parent, {\tt toXML} will return {\tt Nothing}.--<<DBus/Introspection.hs>>=-toXML :: Object -> Maybe Text-toXML obj = fmap (TL.pack . render . document) doc where-	prolog = H.Prolog Nothing [] (Just doctype) []-	doctype = H.DTD "node" (Just (H.PUBLIC-		(H.PubidLiteral dtdPublicID)-		(H.SystemLiteral dtdSystemID))) []-	doc = do-		root <- xmlRoot obj-		return $ H.Document prolog H.emptyST root []--@ When writing objects to {\tt node}s, the root object must have an absolute-path, and children must have paths relative to their parent.--<<DBus/Introspection.hs>>=-xmlRoot :: Object -> Maybe (H.Element a)-xmlRoot obj@(Object path _ _) = do-	(H.CElem root _) <- xmlObject' (T.strObjectPath path) obj-	return $ root--<<DBus/Introspection.hs>>=-xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a)-xmlObject parentPath obj@(Object path _ _) = do-	let path' = T.strObjectPath path-	    parent' = T.strObjectPath parentPath-	relpath <- if TL.isPrefixOf parent' path'-		then Just $ if parent' == "/"-			then TL.drop 1 path'-			else TL.drop (TL.length parent' + 1) path'-		else Nothing-	xmlObject' relpath obj--<<DBus/Introspection.hs>>=-xmlObject' :: Text -> Object -> Maybe (H.Content a)-xmlObject' path (Object fullPath interfaces children') = do-	children'' <- mapM (xmlObject fullPath) children'-	return $ mkElement "node"-		[mkAttr "name" $ TL.unpack path]-		$ concat-			[ map xmlInterface interfaces-			, children''-			]--<<DBus/Introspection.hs>>=-xmlInterface :: Interface -> H.Content a-xmlInterface (Interface name methods signals properties) =-	mkElement "interface"-		[mkAttr "name" . TL.unpack . T.strInterfaceName $ name]-		$ concat-			[ map xmlMethod methods-			, map xmlSignal signals-			, map xmlProperty properties-			]--<<DBus/Introspection.hs>>=-xmlMethod :: Method -> H.Content a-xmlMethod (Method name inParams outParams) = mkElement "method"-	[mkAttr "name" . TL.unpack . T.strMemberName $ name]-	$ concat-		[ map (xmlParameter "in") inParams-		, map (xmlParameter "out") outParams-		]--<<DBus/Introspection.hs>>=-xmlSignal :: Signal -> H.Content a-xmlSignal (Signal name params) = mkElement "signal"-	[mkAttr "name" . TL.unpack . T.strMemberName $ name]-	$ map (xmlParameter "out") params--<<DBus/Introspection.hs>>=-xmlParameter :: String -> Parameter -> H.Content a-xmlParameter direction (Parameter name sig) = mkElement "arg"-	[ mkAttr "name" . TL.unpack $ name-	, mkAttr "type" . TL.unpack . T.strSignature $ sig-	, mkAttr "direction" direction-	] []--<<DBus/Introspection.hs>>=-xmlProperty :: Property -> H.Content a-xmlProperty (Property name sig access) = mkElement "property"-	[ mkAttr "name" . TL.unpack $ name-	, mkAttr "type" . TL.unpack . T.strSignature $ sig-	, mkAttr "access" $ xmlAccess access-	] []--<<DBus/Introspection.hs>>=-xmlAccess :: [PropertyAccess] -> String-xmlAccess access = read ++ write where-	read = if elem Read access then "read" else ""-	write = if elem Write access then "write" else ""--<<DBus/Introspection.hs>>=-mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a-mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined--<<DBus/Introspection.hs>>=-mkAttr :: String -> String -> H.Attribute-mkAttr name value = (name, H.AttValue [Left escaped]) where-	raw = H.CString True value ()-	escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw]--@-\section{Constants}--<<DBus/Constants.hs>>=-<<copyright>>-{-# LANGUAGE OverloadedStrings #-}-module DBus.Constants where-import qualified DBus.Types as T-import Data.Word (Word8, Word32)--<<DBus/Constants.hs>>=-protocolVersion :: Word8-protocolVersion = 1--messageMaximumLength :: Word32-messageMaximumLength = 134217728--arrayMaximumLength :: Word32-arrayMaximumLength = 67108864--@ \subsection{The message bus}--<<DBus/Constants.hs>>=-dbusName :: T.BusName-dbusName = T.mkBusName' "org.freedesktop.DBus"--dbusPath :: T.ObjectPath-dbusPath = T.mkObjectPath' "/org/freedesktop/DBus"--dbusInterface :: T.InterfaceName-dbusInterface = T.mkInterfaceName' "org.freedesktop.DBus"--@ \subsection{Pre-defined interfaces}--<<DBus/Constants.hs>>=-interfaceIntrospectable :: T.InterfaceName-interfaceIntrospectable = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable"--interfaceProperties :: T.InterfaceName-interfaceProperties = T.mkInterfaceName' "org.freedesktop.DBus.Properties"--interfacePeer :: T.InterfaceName-interfacePeer = T.mkInterfaceName' "org.freedesktop.DBus.Peer"--@ \subsection{Pre-defined error names}--<<DBus/Constants.hs>>=-errorFailed :: T.ErrorName-errorFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Failed"--errorNoMemory :: T.ErrorName-errorNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.NoMemory"--errorServiceUnknown :: T.ErrorName-errorServiceUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.ServiceUnknown"--errorNameHasNoOwner :: T.ErrorName-errorNameHasNoOwner = T.mkErrorName' "org.freedesktop.DBus.Error.NameHasNoOwner"--errorNoReply :: T.ErrorName-errorNoReply = T.mkErrorName' "org.freedesktop.DBus.Error.NoReply"--errorIOError :: T.ErrorName-errorIOError = T.mkErrorName' "org.freedesktop.DBus.Error.IOError"--errorBadAddress :: T.ErrorName-errorBadAddress = T.mkErrorName' "org.freedesktop.DBus.Error.BadAddress"--errorNotSupported :: T.ErrorName-errorNotSupported = T.mkErrorName' "org.freedesktop.DBus.Error.NotSupported"--errorLimitsExceeded :: T.ErrorName-errorLimitsExceeded = T.mkErrorName' "org.freedesktop.DBus.Error.LimitsExceeded"--errorAccessDenied :: T.ErrorName-errorAccessDenied = T.mkErrorName' "org.freedesktop.DBus.Error.AccessDenied"--errorAuthFailed :: T.ErrorName-errorAuthFailed = T.mkErrorName' "org.freedesktop.DBus.Error.AuthFailed"--errorNoServer :: T.ErrorName-errorNoServer = T.mkErrorName' "org.freedesktop.DBus.Error.NoServer"--errorTimeout :: T.ErrorName-errorTimeout = T.mkErrorName' "org.freedesktop.DBus.Error.Timeout"--errorNoNetwork :: T.ErrorName-errorNoNetwork = T.mkErrorName' "org.freedesktop.DBus.Error.NoNetwork"--errorAddressInUse :: T.ErrorName-errorAddressInUse = T.mkErrorName' "org.freedesktop.DBus.Error.AddressInUse"--errorDisconnected :: T.ErrorName-errorDisconnected = T.mkErrorName' "org.freedesktop.DBus.Error.Disconnected"--errorInvalidArgs :: T.ErrorName-errorInvalidArgs = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidArgs"--errorFileNotFound :: T.ErrorName-errorFileNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.FileNotFound"--errorFileExists :: T.ErrorName-errorFileExists = T.mkErrorName' "org.freedesktop.DBus.Error.FileExists"--errorUnknownMethod :: T.ErrorName-errorUnknownMethod = T.mkErrorName' "org.freedesktop.DBus.Error.UnknownMethod"--errorTimedOut :: T.ErrorName-errorTimedOut = T.mkErrorName' "org.freedesktop.DBus.Error.TimedOut"--errorMatchRuleNotFound :: T.ErrorName-errorMatchRuleNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleNotFound"--errorMatchRuleInvalid :: T.ErrorName-errorMatchRuleInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleInvalid"--errorSpawnExecFailed :: T.ErrorName-errorSpawnExecFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ExecFailed"--errorSpawnForkFailed :: T.ErrorName-errorSpawnForkFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ForkFailed"--errorSpawnChildExited :: T.ErrorName-errorSpawnChildExited = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildExited"--errorSpawnChildSignaled :: T.ErrorName-errorSpawnChildSignaled = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildSignaled"--errorSpawnFailed :: T.ErrorName-errorSpawnFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.Failed"--errorSpawnFailedToSetup :: T.ErrorName-errorSpawnFailedToSetup = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FailedToSetup"--errorSpawnConfigInvalid :: T.ErrorName-errorSpawnConfigInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ConfigInvalid"--errorSpawnServiceNotValid :: T.ErrorName-errorSpawnServiceNotValid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotValid"--errorSpawnServiceNotFound :: T.ErrorName-errorSpawnServiceNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotFound"--errorSpawnPermissionsInvalid :: T.ErrorName-errorSpawnPermissionsInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid"--errorSpawnFileInvalid :: T.ErrorName-errorSpawnFileInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FileInvalid"--errorSpawnNoMemory :: T.ErrorName-errorSpawnNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.NoMemory"--errorUnixProcessIdUnknown :: T.ErrorName-errorUnixProcessIdUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.UnixProcessIdUnknown"--errorInvalidFileContent :: T.ErrorName-errorInvalidFileContent = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidFileContent"--errorSELinuxSecurityContextUnknown :: T.ErrorName-errorSELinuxSecurityContextUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown"--errorAdtAuditDataUnknown :: T.ErrorName-errorAdtAuditDataUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.AdtAuditDataUnknown"--errorObjectPathInUse :: T.ErrorName-errorObjectPathInUse = T.mkErrorName' "org.freedesktop.DBus.Error.ObjectPathInUse"--errorInconsistentMessage :: T.ErrorName-errorInconsistentMessage = T.mkErrorName' "org.freedesktop.DBus.Error.InconsistentMessage"--@-\section{Misc. utility functions}--<<DBus/Util.hs>>=-<<copyright>>-module DBus.Util where-import Text.Parsec (Parsec, parse)-import Data.Char (digitToInt)--checkLength :: Int -> String -> Maybe String-checkLength length' s | length s <= length' = Just s-checkLength _ _ = Nothing--parseMaybe :: Parsec String () a -> String -> Maybe a-parseMaybe p = either (const Nothing) Just . parse p ""--mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b-mkUnsafe label f x = case f x of-	Just x' -> x'-	Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x--hexToInt :: String -> Int-hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt--eitherToMaybe :: Either a b -> Maybe b-eitherToMaybe (Left  _) = Nothing-eitherToMaybe (Right x) = Just x--fromRight :: Either a b -> b-fromRight (Right x) = x-fromRight _ = error "DBus.Util.fromRight: Left"+@ D-Bus types are divided into two categories, ``atomic'' and ``container''+types. Atoms are actual values -- strings, numbers, etc. Containers store+atoms and other containers. The most interesting difference between the two+is that atoms may be used as the keys in associative mappings+(``dictionaries'').++Internally, types are represented using an enumeration.++<<DBus/Types.hs>>=+data Type+	= DBusBoolean+	| DBusByte+	| DBusInt16+	| DBusInt32+	| DBusInt64+	| DBusWord16+	| DBusWord32+	| DBusWord64+	| DBusDouble+	| DBusString+	| DBusSignature+	| DBusObjectPath+	| DBusVariant+	| DBusArray Type+	| DBusDictionary Type Type+	| DBusStructure [Type]+	deriving (Show, Eq)++<<DBus/Types.hs>>=+isAtomicType :: Type -> Bool+isAtomicType DBusBoolean    = True+isAtomicType DBusByte       = True+isAtomicType DBusInt16      = True+isAtomicType DBusInt32      = True+isAtomicType DBusInt64      = True+isAtomicType DBusWord16     = True+isAtomicType DBusWord32     = True+isAtomicType DBusWord64     = True+isAtomicType DBusDouble     = True+isAtomicType DBusString     = True+isAtomicType DBusSignature  = True+isAtomicType DBusObjectPath = True+isAtomicType _              = False++@ Each type can be converted to a textual representation, used in ``type+signatures'' or for debugging.++<<DBus/Types.hs>>=+typeCode :: Type -> Text++<<type exports>>=+  -- * Available types+  Type (..)+, typeCode++@ Certain Haskell types are considered ``built-in'' D-Bus types; that is,+they are directly represented in the D-Bus protocol.++<<DBus/Types.hs>>=+class (Show a, Eq a) => Builtin a where+	builtinDBusType :: a -> Type++@ \subsection{Variants}++A wrapper type is needed for safely storing generic D-Bus values in Haskell.+The D-Bus ``variant'' type is perfect for this, because variants may store+any D-Bus value.++To cleanly store any D-Bus type, without exposing the internal storage+mechanism, requires existential quantification and some run-time casting.++<<type extensions>>=+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}++<<type imports>>=+import Data.Typeable (Typeable, cast)++@ Any type which is an instance of {\tt Variable} is considered a valid+D-Bus value, because it can be used to construct {\tt Variant}s. However,+outside of this module, {\tt Variant}s can only be constructed from+pre-defined types.++<<DBus/Types.hs>>=+data Variant = forall a. (Variable a, Builtin a, Typeable a) => Variant a+	deriving (Typeable)++class Variable a where+	toVariant :: a -> Variant+	fromVariant :: Variant -> Maybe a++<<type exports>>=+  -- * Variants+, Variant+, Variable (..)++@ Variants can be printed, for debugging purposes -- this instance shouldn't+be parsed or inspected or anything like that, since the output format might+change drastically.++<<DBus/Types.hs>>=+instance Show Variant where+	showsPrec d (Variant x) = showParen (d > 10) $+		s "Variant " . shows code . s " " . showsPrec 11 x+		where code = typeCode . builtinDBusType $ x+		      s    = showString++@ In the test suite, it's useful to test that two variants have the same+value.++<<DBus/Types.hs>>=+instance Eq Variant where+	(Variant x) == (Variant y) = cast x == Just y++@ Since many operations on D-Bus values depend on having the correct type,+{\tt variantType} is used to retrieve which type is actually stored within+a {\tt Variant}.++<<DBus/Types.hs>>=+variantType :: Variant -> Type+variantType (Variant x) = builtinDBusType x++<<type exports>>=+, variantType++@ These helper macros will be used for defining instances of Haskell types.++<<DBus/Types.hs>>=+#define INSTANCE_BUILTIN(HASKELL, DBUS) \+	instance Builtin HASKELL where \+		{ builtinDBusType _ = DBUS };++#define INSTANCE_VARIABLE(HASKELL) \+	instance Variable HASKELL where \+		{ toVariant = Variant \+		; fromVariant (Variant x) = cast x };++#define BUILTIN_VARIABLE(HASKELL, DBUS) \+	INSTANCE_BUILTIN(HASKELL, DBUS) \+	INSTANCE_VARIABLE(HASKELL)++@ Since {\tt Variant}s are D-Bus values themselves, they have a type.++<<DBus/Types.hs>>=+BUILTIN_VARIABLE(Variant, DBusVariant)++@ \subsection{Numerics}++D-Bus supports most common numeric types:++\begin{table}[h]+\caption{D-Bus Numeric types}+\begin{center}+\begin{tabular}{ll}+\toprule+Type        & Description \\+\midrule+Boolean     & Either {\tt True} or {\tt False} \\+Byte        & 8-bit unsigned integer \\+Int16       & 16-bit signed integer \\+Int32       & 32-bit signed integer \\+Int64       & 64-bit signed integer \\+Word16      & 16-bit unsigned integer \\+Word32      & 32-bit unsigned integer \\+Word64      & 64-bit unsigned integer \\+Double      & 64-bit IEEE754 floating-point \\+\bottomrule+\end{tabular}+\end{center}+\end{table}++All D-Bus numeric types are fixed-length, so the {\tt Int} and {\tt Integer}+types can't be used. Instead, instances for the fixed-length integer types+are defined and any others will have to be converted.++<<type imports>>=+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Int (Int16, Int32, Int64)++<<DBus/Types.hs>>=+BUILTIN_VARIABLE(Bool,   DBusBoolean)+BUILTIN_VARIABLE(Word8,  DBusByte)+BUILTIN_VARIABLE(Int16,  DBusInt16)+BUILTIN_VARIABLE(Int32,  DBusInt32)+BUILTIN_VARIABLE(Int64,  DBusInt64)+BUILTIN_VARIABLE(Word16, DBusWord16)+BUILTIN_VARIABLE(Word32, DBusWord32)+BUILTIN_VARIABLE(Word64, DBusWord64)+BUILTIN_VARIABLE(Double, DBusDouble)++@ \subsection{Strings}++Strings are a weird case; the built-in type, {\tt String}, is horribly+inefficent. To provide better performance for large strings, packed Unicode+strings defined in {\tt Data.Text} are used internally.++<<DBus/Types.hs>>=+BUILTIN_VARIABLE(TL.Text, DBusString)++@ There's two different {\tt Text} types, strict and lazy. It'd be a pain+to store both and have to convert later, so instead, all strict {\tt Text}+values are converted to lazy values.++<<type imports>>=+import qualified Data.Text as T++<<DBus/Types.hs>>=+instance Variable T.Text where+	toVariant = toVariant . TL.fromChunks . (:[])+	fromVariant = fmap (T.concat . TL.toChunks) . fromVariant++@ Built-in {\tt String}s can still be stored, of course, but it requires+a language extension.++<<type extensions>>=+{-# LANGUAGE TypeSynonymInstances #-}++<<DBus/Types.hs>>=+instance Variable String where+	toVariant = toVariant . TL.pack+	fromVariant = fmap TL.unpack . fromVariant++@ \subsection{Signatures}++@ Valid D-Bus types must obey certain rules, such as ``dict keys must be+atomic'', which are difficult to express in the Haskell type system.  A+{\tt Signature} is guaranteed to be valid according to these rules. Creating+one requires using the {\tt mkSignature} function, which will convert a valid+D-Bus signature string into a {\tt Signature}.++<<DBus/Types.hs>>=+BUILTIN_VARIABLE(Signature, DBusSignature)+data Signature = Signature { signatureTypes :: [Type] }+	deriving (Eq, Typeable)++instance Show Signature where+	showsPrec d x = showParen (d > 10) $+		showString "Signature " . shows (strSignature x)++@ Signatures can also be converted back into text, by concatenating the+type codes of their contained types.++<<DBus/Types.hs>>=+strSignature :: Signature -> Text+strSignature (Signature ts) = TL.concat $ map typeCode ts++@ It doesn't make much sense to sort signatures, but since they can be used+as dictionary keys, it's useful to have them as an instance of {\tt Ord}.++<<DBus/Types.hs>>=+instance Ord Signature where+	compare x y = compare (strSignature x) (strSignature y)++<<type exports>>=+  -- * Signatures+, Signature+, signatureTypes+, strSignature++@ \subsubsection{Type codes}++@ For atomic types, the type code is a single letter. Arrays, structures,+and dictionary types are multiple characters.++<<DBus/Types.hs>>=+typeCode DBusBoolean    = "b"+typeCode DBusByte       = "y"+typeCode DBusInt16      = "n"+typeCode DBusInt32      = "i"+typeCode DBusInt64      = "x"+typeCode DBusWord16     = "q"+typeCode DBusWord32     = "u"+typeCode DBusWord64     = "t"+typeCode DBusDouble     = "d"+typeCode DBusString     = "s"+typeCode DBusSignature  = "g"+typeCode DBusObjectPath = "o"+typeCode DBusVariant    = "v"++@ An array's type code is ``a'' followed by the type it contains. For example,+an array of booleans would have the type string ``ab''.++<<DBus/Types.hs>>=+typeCode (DBusArray t) = TL.cons 'a' $ typeCode t++@ A dictionary's type code is ``a\{$key\_type$ $value\_type$\}''. For example,+a dictionary of bytes to booleans would have the type string ``a\{yb\}''.++<<DBus/Types.hs>>=+typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"]++@ A structure's type code is the concatenation of its contained types,+wrapped by ``('' and ``)''. Structures may be empty, in which case their+type code is simply ``()''.++<<DBus/Types.hs>>=+typeCode (DBusStructure ts) = TL.concat $+	["("] ++ map typeCode ts ++ [")"]++@ \subsubsection{Parsing}++When parsing, additional restrictions apply which are not inherent to the+D-Bus type system:++\begin{itemize}+\item Signatures may be at most 255 characters long.+\end{itemize}++Parsec is used to parse signatures.++<<type imports>>=+import Text.Parsec ((<|>))+import qualified Text.Parsec as P+import DBus.Util (checkLength, parseMaybe)++<<DBus/Types.hs>>=+mkSignature :: Text -> Maybe Signature+mkSignature = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack where+	sigParser = do+		types <- P.many parseType+		P.eof+		return $ Signature types+	parseType = parseAtom <|> parseContainer+	parseContainer =+		    parseArray+		<|> parseStruct+		<|> (P.char 'v' >> return DBusVariant)+	parseAtom =+		    (P.char 'b' >> return DBusBoolean)+		<|> (P.char 'y' >> return DBusByte)+		<|> (P.char 'n' >> return DBusInt16)+		<|> (P.char 'i' >> return DBusInt32)+		<|> (P.char 'x' >> return DBusInt64)+		<|> (P.char 'q' >> return DBusWord16)+		<|> (P.char 'u' >> return DBusWord32)+		<|> (P.char 't' >> return DBusWord64)+		<|> (P.char 'd' >> return DBusDouble)+		<|> (P.char 's' >> return DBusString)+		<|> (P.char 'g' >> return DBusSignature)+		<|> (P.char 'o' >> return DBusObjectPath)+	parseArray = do+		P.char 'a'+		parseDict <|> do+		t <- parseType+		return $ DBusArray t+	parseDict = do+		P.char '{'+		keyType <- parseAtom+		valueType <- parseType+		P.char '}'+		return $ DBusDictionary keyType valueType+	parseStruct = do+		P.char '('+		types <- P.many parseType+		P.char ')'+		return $ DBusStructure types++@ Since many signatures are defined as string literals, it's useful to+have a helper function to construct a signature directly from a string.+If the input string is invalid, {\tt error} will be called.++<<type imports>>=+import DBus.Util (mkUnsafe)++<<DBus/Types.hs>>=+mkSignature' :: Text -> Signature+mkSignature' = mkUnsafe "signature" mkSignature++@ Most signature-related functions are exposed to clients, except the+{\tt Signature} value constructor. If that were exposed, clients could+construct invalid signatures.++<<type exports>>=+, mkSignature+, mkSignature'++@ \subsection{Object paths}++<<DBus/Types.hs>>=+BUILTIN_VARIABLE(ObjectPath, DBusObjectPath)+newtype ObjectPath = ObjectPath+	{ strObjectPath :: Text+	}+	deriving (Show, Eq, Ord, Typeable)++@ An object path may be one of++\begin{itemize}+\item The root path, {\tt "/"}.+\item {\tt '/'}, followed by one or more element names. Each element name+      contains characters in the set {\tt [a-zA-Z0-9\_]}, and must have at+      least one character.+\end{itemize}++Element names are separated by {\tt '/'}, and the path may not end in+{\tt '/'} unless it is the root path.++<<DBus/Types.hs>>=+mkObjectPath :: Text -> Maybe ObjectPath+mkObjectPath s = parseMaybe path' (TL.unpack s) where+	c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"+	path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char+	path' = path >> P.eof >> return (ObjectPath s)++mkObjectPath' :: Text -> ObjectPath+mkObjectPath' = mkUnsafe "object path" mkObjectPath++<<type exports>>=+  -- * Object paths+, ObjectPath+, strObjectPath+, mkObjectPath+, mkObjectPath'++@ \subsection{Arrays}++Arrays are homogenous sequences of any valid D-Bus type. Arrays might be+empty, so the type they contain is stored instead of being calculated from+their contents (as in {\tt variantType}).++Many D-Bus APIs represent binary data using an array of bytes; therefore,+there is a special constructor for {\tt ByteString}-based arrays.++<<type imports>>=+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as ByteString++<<DBus/Types.hs>>=+INSTANCE_VARIABLE(Array)+data Array+	= VariantArray Type [Variant]+	| ByteArray ByteString+	deriving (Eq, Typeable)++instance Builtin Array where+	builtinDBusType = DBusArray . arrayType++arrayType :: Array -> Type+arrayType (VariantArray t _) = t+arrayType (ByteArray _) = DBusByte++arrayItems :: Array -> [Variant]+arrayItems (VariantArray _ xs) = xs+arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs++<<type exports>>=+  -- * Arrays+, Array+, arrayType+, arrayItems++@ Like {\tt Variant}, deriving {\tt Show} for {\tt Array} is mostly+just useful for debugging.++<<DBus/Types.hs>>=+instance Show Array where+	showsPrec d array = showParen (d > 10) $+		s "Array " . showSig . s " [" . s valueString . s "]" where+			s = showString+			showSig = shows . typeCode . arrayType $ array+			vs = [show x | (Variant x) <- arrayItems array]+			valueString = intercalate ", " vs++@ Clients constructing an array must provide the expected item type, which+will be checked for validity. Every item in the array will be checked against+the item type, to ensure the array is homogenous.++<<DBus/Types.hs>>=+arrayFromItems :: Type -> [Variant] -> Maybe Array+arrayFromItems DBusByte vs = do+	bytes <- mapM fromVariant vs+	Just . ByteArray . ByteString.pack $ bytes++arrayFromItems t vs = do+	mkSignature (typeCode t)+	if all (\x -> variantType x == t) vs+		then Just $ VariantArray t vs+		else Nothing++@ Additionally, for ease of use, an {\tt Array} can be converted directly+to/from lists of {\tt Variable} values.++<<DBus/Types.hs>>=+toArray :: Variable a => Type -> [a] -> Maybe Array+toArray t = arrayFromItems t . map toVariant++fromArray :: Variable a => Array -> Maybe [a]+fromArray = mapM fromVariant . arrayItems++<<type exports>>=+, toArray+, fromArray+, arrayFromItems++@ To provide a more efficient interface for byte array literals, these+functions bypass the conversions in {\tt toArray} and {\tt fromArray}++<<DBus/Types.hs>>=+arrayToBytes :: Array -> Maybe ByteString+arrayToBytes (ByteArray x) = Just x+arrayToBytes _             = Nothing++arrayFromBytes :: ByteString -> Array+arrayFromBytes = ByteArray++<<type exports>>=+, arrayToBytes+, arrayFromBytes++@ And to simplify inclusion of {\tt ByteString}s in message, instances of+{\tt Variable} exist for both strict and lazy {\tt ByteString}.++<<DBus/Types.hs>>=+instance Variable ByteString where+	toVariant = toVariant . arrayFromBytes+	fromVariant x = fromVariant x >>= arrayToBytes++<<type imports>>=+import qualified Data.ByteString as StrictByteString++<<DBus/Types.hs>>=+instance Variable StrictByteString.ByteString where+	toVariant x = toVariant . arrayFromBytes $ ByteString.fromChunks [x]+	fromVariant x = do+		chunks <- ByteString.toChunks `fmap` fromVariant x+		return $ StrictByteString.concat chunks++@ \subsection{Dictionaries}++Dictionaries are a homogenous (key $\rightarrow$ value) mapping, where the+key type must be atomic. Values may be of any valid D-Bus type. Like+{\tt Array}, {\tt Dictionary} stores its contained types.++<<DBus/Types.hs>>=+INSTANCE_VARIABLE(Dictionary)+data Dictionary = Dictionary+	{ dictionaryKeyType   :: Type+	, dictionaryValueType :: Type+	, dictionaryItems     :: [(Variant, Variant)]+	}+	deriving (Eq, Typeable)++instance Builtin Dictionary where+	builtinDBusType (Dictionary kt vt _) = DBusDictionary kt vt++<<type exports>>=+  -- * Dictionaries+, Dictionary+, dictionaryItems+, dictionaryKeyType+, dictionaryValueType++@ {\tt show}ing a {\tt Dictionary} displays the mapping in a more readable+format than a list of pairs.++<<type imports>>=+import Data.List (intercalate)++<<DBus/Types.hs>>=+instance Show Dictionary where+	showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $+		s "Dictionary " . showSig . s " {" . s valueString . s "}" where+			s = showString+			showSig = shows $ TL.append (typeCode kt) (typeCode vt)+			valueString = intercalate ", " $ map showPair pairs+			showPair ((Variant k), (Variant v)) =+				show k ++ " -> " ++ show v++@ Constructing a {\tt Dictionary} works like constructing an {\tt Array},+except that there are two types to check, and the key type must be atomic.++<<type imports>>=+import Control.Monad (unless)++<<DBus/Types.hs>>=+dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary+dictionaryFromItems kt vt pairs = do+	unless (isAtomicType kt) Nothing+	mkSignature (typeCode kt)+	mkSignature (typeCode vt)+	+	let sameType (k, v) = variantType k == kt &&+	                      variantType v == vt+	if all sameType pairs+		then Just $ Dictionary kt vt pairs+		else Nothing++@ The closest match for dictionary semantics in Haskell is the+{\tt Data.Map.Map} type. Therefore, the utility conversion functions work+with {\tt Map}s instead of pair lists.++<<type imports>>=+import Control.Arrow ((***))+import qualified Data.Map as Map++<<DBus/Types.hs>>=+toDictionary :: (Variable a, Variable b) => Type -> Type -> Map.Map a b+             -> Maybe Dictionary+toDictionary kt vt = dictionaryFromItems kt vt . pairs where+	pairs = map (toVariant *** toVariant) . Map.toList++<<type imports>>=+import Control.Monad (forM)++<<DBus/Types.hs>>=+fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary+               -> Maybe (Map.Map a b)+fromDictionary (Dictionary _ _ vs) = do+	pairs <- forM vs $ \(k, v) -> do+		k' <- fromVariant k+		v' <- fromVariant v+		return (k', v')+	return $ Map.fromList pairs++<<type exports>>=+, toDictionary+, fromDictionary+, dictionaryFromItems++@ \subsubsection{Converting between {\tt Array} and {\tt Dictionary}}++Converting between {\tt Array} and {\tt Dictionary} is useful when+(un)marshaling -- dictionaries can be thought of as arrays of two-element+structures, much as a {\tt Map} is a list of pairs.++<<DBus/Types.hs>>=+dictionaryToArray :: Dictionary -> Array+dictionaryToArray (Dictionary kt vt items) = array where+	Just array = toArray itemType structs+	itemType = DBusStructure [kt, vt]+	structs = [Structure [k, v] | (k, v) <- items]++<<DBus/Types.hs>>=+arrayToDictionary :: Array -> Maybe Dictionary+arrayToDictionary array = do+	let toPair x = do+		struct <- fromVariant x+		case struct of+			Structure [k, v] -> Just (k, v)+			_                -> Nothing+	(kt, vt) <- case arrayType array of+		DBusStructure [kt, vt] -> Just (kt, vt)+		_                      -> Nothing+	pairs <- mapM toPair $ arrayItems array+	dictionaryFromItems kt vt pairs++<<type exports>>=+, dictionaryToArray+, arrayToDictionary++@ \subsection{Structures}++A heterogeneous, fixed-length container; equivalent in purpose to a Haskell+tuple.++<<DBus/Types.hs>>=+INSTANCE_VARIABLE(Structure)+data Structure = Structure [Variant]+	deriving (Show, Eq, Typeable)++instance Builtin Structure where+	builtinDBusType (Structure vs) = DBusStructure $ map variantType vs++<<type exports>>=+  -- * Structures+, Structure (..)++@ \subsection{Names}++Various aspects of D-Bus require the use of specially-formatted strings,+called ``names''. All names are limited to 255 characters, and use subsets+of ASCII.++Since all names have basically the same structure (a {\tt newtype}+declaration and some helper functions), I define a macro to automate+the definitions.++<<DBus/Types.hs>>=+#define NAME_TYPE(TYPE, NAME) \+	newtype TYPE = TYPE {str##TYPE :: Text} \+		deriving (Show, Eq, Ord); \+		                          \+	instance Variable TYPE where \+		{ toVariant = toVariant . str##TYPE \+		; fromVariant = (mk##TYPE =<<) . fromVariant }; \+		                                                \+	mk##TYPE##' :: Text -> TYPE; \+	mk##TYPE##' = mkUnsafe NAME mk##TYPE++<<type exports>>=+-- * Names++@ \subsubsection{Bus names}++There are two forms of bus names, ``unique'' and ``well-known''.++Unique names begin with {\tt `:'} and contain two or more elements, separated+by {\tt `.'}. Each element consists of characters from the set+{\tt [a-zA-Z0-9\_-]}.++Well-known names contain two or more elements, separated by {\tt `.'}. Each+element consists of characters from the set {\tt [a-zA-Z0-9\_-]}, and must+not start with a digit.++<<DBus/Types.hs>>=+NAME_TYPE(BusName, "bus name")++mkBusName :: Text -> Maybe BusName+mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where+	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"+	c' = c ++ ['0'..'9']+	parser = (unique <|> wellKnown) >> P.eof >> return (BusName s)+	unique = P.char ':' >> elems c'+	wellKnown = elems c+	elems start = elem' start >> P.many1 (P.char '.' >> elem' start)+	elem' start = P.oneOf start >> P.many (P.oneOf c')++<<type exports>>=+  -- ** Bus names+, BusName+, strBusName+, mkBusName+, mkBusName'++@ \subsubsection{Interface names}++An interface name consists of two or more {\tt '.'}-separated elements. Each+element constists of characters from the set {\tt [a-zA-Z0-9\_]}, may not+start with a digit, and must have at least one character.++<<DBus/Types.hs>>=+NAME_TYPE(InterfaceName, "interface name")++mkInterfaceName :: Text -> Maybe InterfaceName+mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where+	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+	c' = c ++ ['0'..'9']+	element = P.oneOf c >> P.many (P.oneOf c')+	name = element >> P.many1 (P.char '.' >> element)+	parser = name >> P.eof >> return (InterfaceName s)++<<type exports>>=+  -- ** Interface names+, InterfaceName+, strInterfaceName+, mkInterfaceName+, mkInterfaceName'++@ \subsubsection{Error names}++Error names have the same format as interface names, so the parser logic+can just be re-purposed.++<<DBus/Types.hs>>=+NAME_TYPE(ErrorName, "error name")++mkErrorName :: Text -> Maybe ErrorName+mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName++<<type exports>>=+  -- ** Error names+, ErrorName+, strErrorName+, mkErrorName+, mkErrorName'++@ \subsubsection{Member names}++Member names must contain only characters from the set {\tt [a-zA-Z0-9\_]},+may not begin with a digit, and must be at least one character long.++<<DBus/Types.hs>>=+NAME_TYPE(MemberName, "member name")++mkMemberName :: Text -> Maybe MemberName+mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where+	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+	c' = c ++ ['0'..'9']+	name = P.oneOf c >> P.many (P.oneOf c')+	parser = name >> P.eof >> return (MemberName s)++<<type exports>>=+  -- ** Member names+, MemberName+, strMemberName+, mkMemberName+, mkMemberName'++@+\section{Messages}++@ To prevent internal details of messages from leaking out to clients,+declarations are contained in an internal module and then re-exported+in the public module.++<<DBus/Message.hs>>=+<<copyright>>+module DBus.Message+	(<<message exports>>+	) where+import DBus.Message.Internal++<<DBus/Message/Internal.hs>>=+<<copyright>>+<<text extensions>>+module DBus.Message.Internal where+<<text imports>>+import qualified Data.Set as S+import Data.Word (Word8, Word32)+import Data.Maybe (fromMaybe)+import qualified DBus.Types as T+import DBus.Util (maybeIndex)++<<DBus/Message/Internal.hs>>=+class Message a where+	messageTypeCode     :: a -> Word8+	messageHeaderFields :: a -> [HeaderField]+	messageFlags        :: a -> S.Set Flag+	messageBody         :: a -> [T.Variant]++<<message exports>>=+Message ( messageFlags+        , messageBody+        )++@ \subsection{Flags}++The instance of {\tt Ord} only exists for storing flags in a set. Flags have+no inherent ordering.++<<DBus/Message/Internal.hs>>=+data Flag+	= NoReplyExpected+	| NoAutoStart+	deriving (Show, Eq, Ord)++<<message exports>>=+, Flag (..)++@ \subsection{Header fields}++<<DBus/Message/Internal.hs>>=+data HeaderField+	= Path        T.ObjectPath+	| Interface   T.InterfaceName+	| Member      T.MemberName+	| ErrorName   T.ErrorName+	| ReplySerial Serial+	| Destination T.BusName+	| Sender      T.BusName+	| Signature   T.Signature+	deriving (Show, Eq)++@ \subsection{Serials}++{\tt Serial} is just a wrapper around {\tt Word32}, to provide a bit of+added type-safety.++<<DBus/Message/Internal.hs>>=+newtype Serial = Serial { serialValue :: Word32 }+	deriving (Eq, Ord)++instance Show Serial where+	show (Serial x) = show x++instance T.Variable Serial where+	toVariant (Serial x) = T.toVariant x+	fromVariant = fmap Serial . T.fromVariant++@ Additionally, some useful functions exist for incrementing serials.++<<DBus/Message/Internal.hs>>=+firstSerial :: Serial+firstSerial = Serial 1++nextSerial :: Serial -> Serial+nextSerial (Serial x) = Serial (x + 1)++@ The {\tt Serial} constructor isn't useful to clients, because building+arbitrary serials doesn't make any sense.++<<message exports>>=+, Serial+, serialValue++@ \subsection{Message types}++<<DBus/Message/Internal.hs>>=+maybe' :: (a -> b) -> Maybe a -> [b]+maybe' f = maybe [] (\x' -> [f x'])++@ \subsubsection{Method calls}++<<DBus/Message/Internal.hs>>=+data MethodCall = MethodCall+	{ methodCallPath        :: T.ObjectPath+	, methodCallMember      :: T.MemberName+	, methodCallInterface   :: Maybe T.InterfaceName+	, methodCallDestination :: Maybe T.BusName+	, methodCallFlags       :: S.Set Flag+	, methodCallBody        :: [T.Variant]+	}+	deriving (Show, Eq)++instance Message MethodCall where+	messageTypeCode _ = 1+	messageFlags      = methodCallFlags+	messageBody       = methodCallBody+	messageHeaderFields m = concat+		[ [ Path    $ methodCallPath m+		  ,  Member $ methodCallMember m+		  ]+		, maybe' Interface . methodCallInterface $ m+		, maybe' Destination . methodCallDestination $ m+		]++<<message exports>>=+, MethodCall (..)++@ \subsubsection{Method returns}++<<DBus/Message/Internal.hs>>=+data MethodReturn = MethodReturn+	{ methodReturnSerial      :: Serial+	, methodReturnDestination :: Maybe T.BusName+	, methodReturnBody        :: [T.Variant]+	}+	deriving (Show, Eq)++instance Message MethodReturn where+	messageTypeCode _ = 2+	messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]+	messageBody       = methodReturnBody+	messageHeaderFields m = concat+		[ [ ReplySerial $ methodReturnSerial m+		  ]+		, maybe' Destination . methodReturnDestination $ m+		]++<<message exports>>=+, MethodReturn (..)++@ \subsubsection{Errors}++<<DBus/Message/Internal.hs>>=+data Error = Error+	{ errorName        :: T.ErrorName+	, errorSerial      :: Serial+	, errorDestination :: Maybe T.BusName+	, errorBody        :: [T.Variant]+	}+	deriving (Show, Eq)++instance Message Error where+	messageTypeCode _ = 3+	messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]+	messageBody       = errorBody+	messageHeaderFields m = concat+		[ [ ErrorName   $ errorName m+		  , ReplySerial $ errorSerial m+		  ]+		, maybe' Destination . errorDestination $ m+		]++@ Errors usually contain a human-readable message in their first body field.+This function lets it be retrieved easily, with a fallback if no valid+message was found.++<<DBus/Message/Internal.hs>>=+errorMessage :: Error -> Text+errorMessage msg = fromMaybe "(no error message)" $ do+	field <- maybeIndex (errorBody msg) 0+	text <- T.fromVariant field+	if TL.null text+		then Nothing+		else return text++<<message exports>>=+, Error (..)+, errorMessage++@ \subsubsection{Signals}++<<DBus/Message/Internal.hs>>=+data Signal = Signal+	{ signalPath        :: T.ObjectPath+	, signalMember      :: T.MemberName+	, signalInterface   :: T.InterfaceName+	, signalDestination :: Maybe T.BusName+	, signalBody        :: [T.Variant]+	}+	deriving (Show, Eq)++instance Message Signal where+	messageTypeCode _ = 4+	messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]+	messageBody       = signalBody+	messageHeaderFields m = concat+		[ [ Path      $ signalPath m+		  , Member    $ signalMember m+		  , Interface $ signalInterface m+		  ]+		, maybe' Destination . signalDestination $ m+		]++<<message exports>>=+, Signal (..)++@ \subsubsection{Unknown messages}++Unknown messages are used for storing information about messages without+a recognised type code. They are not instances of {\tt Message}, because+if they were, then clients could accidentally send invalid messages over+the bus.++<<DBus/Message/Internal.hs>>=+data Unknown = Unknown+	{ unknownType    :: Word8+	, unknownFlags   :: S.Set Flag+	, unknownBody    :: [T.Variant]+	}+	deriving (Show, Eq)++<<message exports>>=+, Unknown (..)++@ \subsection{Received messages}++Messages received from a bus have additional fields which do not make sense+when sending.++If a message has an unknown type, its serial and origin are still useful+for sending an error reply.++<<DBus/Message/Internal.hs>>=+data ReceivedMessage+	= ReceivedMethodCall   Serial (Maybe T.BusName) MethodCall+	| ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn+	| ReceivedError        Serial (Maybe T.BusName) Error+	| ReceivedSignal       Serial (Maybe T.BusName) Signal+	| ReceivedUnknown      Serial (Maybe T.BusName) Unknown+	deriving (Show, Eq)++<<DBus/Message/Internal.hs>>=+receivedSerial :: ReceivedMessage -> Serial+receivedSerial (ReceivedMethodCall   s _ _) = s+receivedSerial (ReceivedMethodReturn s _ _) = s+receivedSerial (ReceivedError        s _ _) = s+receivedSerial (ReceivedSignal       s _ _) = s+receivedSerial (ReceivedUnknown      s _ _) = s++<<DBus/Message/Internal.hs>>=+receivedSender :: ReceivedMessage -> Maybe T.BusName+receivedSender (ReceivedMethodCall   _ s _) = s+receivedSender (ReceivedMethodReturn _ s _) = s+receivedSender (ReceivedError        _ s _) = s+receivedSender (ReceivedSignal       _ s _) = s+receivedSender (ReceivedUnknown      _ s _) = s++<<DBus/Message/Internal.hs>>=+receivedBody :: ReceivedMessage -> [T.Variant]+receivedBody (ReceivedMethodCall   _ _ x) = messageBody x+receivedBody (ReceivedMethodReturn _ _ x) = messageBody x+receivedBody (ReceivedError        _ _ x) = messageBody x+receivedBody (ReceivedSignal       _ _ x) = messageBody x+receivedBody _ = []++<<message exports>>=+, ReceivedMessage (..)+, receivedSerial+, receivedSender+, receivedBody++@+\section{Wire format}++<<DBus/Wire.hs>>=+<<copyright>>+<<text extensions>>+<<wire extensions>>+module DBus.Wire (<<wire exports>>) where+<<text imports>>+<<wire imports>>+import Control.Monad (when, unless)+import Data.Maybe (fromJust, listToMaybe, fromMaybe)+import Data.Word (Word8, Word32, Word64)+import Data.Int (Int16, Int32, Int64)++import qualified DBus.Types as T++@ \subsection{Endianness}++<<DBus/Wire.hs>>=+data Endianness = LittleEndian | BigEndian+	deriving (Show, Eq)++encodeEndianness :: Endianness -> Word8+encodeEndianness LittleEndian = 108+encodeEndianness BigEndian    = 66++decodeEndianness :: Word8 -> Maybe Endianness+decodeEndianness 108 = Just LittleEndian+decodeEndianness 66  = Just BigEndian+decodeEndianness _   = Nothing++<<wire exports>>=+  Endianness (..)++@ \subsection{Alignment}++Every built-in type has an associated alignment. If a value of the given+type is marshaled, it must have {\sc nul} bytes inserted until it starts+on a byte index divisible by its alignment.++<<DBus/Wire.hs>>=+alignment :: T.Type -> Word8+<<alignments>>++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++<<wire exports>>=+, alignment++@ \subsection{Marshaling}++Marshaling is implemented using an error transformer over an internal+state. The {\tt Builder} type is used for efficient construction of lazy+byte strings, but it doesn't provide any way to retrieve the length of its+internal buffer, so the byte count is tracked separately.++<<wire imports>>=+import qualified Control.Monad.State as ST+import qualified Control.Monad.Error as E+import qualified Data.ByteString.Lazy as L+import qualified Data.Binary.Builder as B++<<wire extensions>>=+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-}++<<DBus/Wire.hs>>=+data MarshalState = MarshalState Endianness B.Builder !Word64+newtype MarshalM a = MarshalM (E.ErrorT MarshalError (ST.State MarshalState) a)+	deriving (Monad, E.MonadError MarshalError, ST.MonadState MarshalState)+type Marshal = MarshalM ()++@ Clients can perform marshaling via {\tt marshal} and {\tt runMarshal},+which will generate a {\tt ByteString} with the fully marshaled data.++<<wire exports>>=+, MarshalM+, Marshal+, marshal+, runMarshal++<<DBus/Wire.hs>>=+runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString+runMarshal (MarshalM m) e = case ST.runState (E.runErrorT m) initialState of+	(Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder)+	(Left  x, _) -> Left x+	where initialState = MarshalState e B.empty 0++<<DBus/Wire.hs>>=+marshal :: T.Variant -> Marshal+marshal v = marshalType (T.variantType v) where+	x :: T.Variable a => a+	x = fromJust . T.fromVariant $ v+	marshalType :: T.Type -> Marshal+	<<marshalers>>++@ TODO: describe these functions++<<DBus/Wire.hs>>=+append :: L.ByteString -> Marshal+append bytes = do+	(MarshalState e builder count) <- ST.get+	let builder' = B.append builder $ B.fromLazyByteString bytes+	    count' = count + (fromIntegral $ L.length bytes)+	ST.put $ MarshalState e builder' count'++<<DBus/Wire.hs>>=+pad :: Word8 -> Marshal+pad count = do+	(MarshalState _ _ existing) <- ST.get+	let padding' = fromIntegral $ padding existing count+	append $ L.replicate padding' 0++@ Most numeric values already have marshalers implemented in the+{\tt Data.Binary.Builder} module; this function lets them be re-used easily.++<<DBus/Wire.hs>>=+marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal+marshalBuilder size be le x = do+	pad size+	(MarshalState e builder count) <- ST.get+	let builder' = B.append builder $ case e of+		BigEndian -> be x+		LittleEndian -> le x+	let count' = count + (fromIntegral size)+	ST.put $ MarshalState e builder' count'++@ \subsubsection{Errors}++Marshaling can fail for four reasons:++\begin{itemize}+\item The message exceeds the maximum message size of $2^{27}$ bytes.+\item An array in the message exceeds the maximum array size of $2^{26}$ bytes.+\item The body's signature is not valid (for example, more than 255 fields).+\item A variant's signature is not valid -- same causes as an invalid body+      signature.+\item Some text contains {\sc nul} ({\tt '\textbackslash{}0'}).+\end{itemize}++<<DBus/Wire.hs>>=+data MarshalError+	= MessageTooLong Word64+	| ArrayTooLong Word64+	| InvalidBodySignature Text+	| InvalidVariantSignature Text+	| TextContainsNUL Text+	deriving (Eq)++instance Show MarshalError where+	show (MessageTooLong x) = concat+		["Message too long (", show x, " bytes)."]+	show (ArrayTooLong x) = concat+		["Array too long (", show x, " bytes)."]+	show (InvalidBodySignature x) = concat+		["Invalid body signature: ", show x]+	show (InvalidVariantSignature x) = concat+		["Invalid variant signature: ", show x]+	show (TextContainsNUL x) = concat+		["Text contains NUL: ", show x]++instance E.Error MarshalError++<<wire exports>>=+, MarshalError (..)++@ \subsection{Unmarshaling}++Unmarshaling also uses an error transformer and internal state.++<<wire exports>>=+, Unmarshal+, unmarshal+, runUnmarshal++<<DBus/Wire.hs>>=+data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64+newtype Unmarshal a = Unmarshal (E.ErrorT UnmarshalError (ST.State UnmarshalState) a)+	deriving (Monad, Functor, E.MonadError UnmarshalError, ST.MonadState UnmarshalState)++<<DBus/Wire.hs>>=+runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a+runUnmarshal (Unmarshal m) e bytes = ST.evalState (E.runErrorT m) state where+	state = UnmarshalState e bytes 0++<<DBus/Wire.hs>>=+unmarshal :: T.Signature -> Unmarshal [T.Variant]+unmarshal = mapM unmarshalType . T.signatureTypes++unmarshalType :: T.Type -> Unmarshal T.Variant+<<unmarshalers>>++@ TODO: describe these functions++<<DBus/Wire.hs>>=+consume :: Word64 -> Unmarshal L.ByteString+consume count = do+	(UnmarshalState e bytes offset) <- ST.get+	let (x, bytes') = L.splitAt (fromIntegral count) bytes+	unless (L.length x == fromIntegral count) $+		E.throwError $ UnexpectedEOF offset+	+	ST.put $ UnmarshalState e bytes' (offset + count)+	return x++<<DBus/Wire.hs>>=+skipPadding :: Word8 -> Unmarshal ()+skipPadding count = do+	(UnmarshalState _ _ offset) <- ST.get+	bytes <- consume $ padding offset count+	unless (L.all (== 0) bytes) $+		E.throwError $ InvalidPadding offset++<<DBus/Wire.hs>>=+skipTerminator :: Unmarshal ()+skipTerminator = do+	(UnmarshalState _ _ offset) <- ST.get+	bytes <- consume 1+	unless (L.all (== 0) bytes) $+		E.throwError $ MissingTerminator offset++<<DBus/Wire.hs>>=+fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b+fromMaybeU label f x = case f x of+	Just x' -> return x'+	Nothing -> E.throwError . Invalid label . TL.pack . show $ x++fromMaybeU' :: (Show a, T.Variable b) => Text -> (a -> Maybe b) -> a+           -> Unmarshal T.Variant+fromMaybeU' label f x = do+	x' <- fromMaybeU label f x+	return $ T.toVariant x'++<<wire imports>>=+import qualified Data.Binary.Get as G++<<DBus/Wire.hs>>=+unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a+unmarshalGet count be le = do+	skipPadding count+	(UnmarshalState e _ _) <- ST.get+	bs <- consume . fromIntegral $ count+	let get' = case e of+		BigEndian -> be+		LittleEndian -> le+	return $ G.runGet get' bs++unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a+              -> Unmarshal T.Variant+unmarshalGet' count be le = T.toVariant `fmap` unmarshalGet count be le++<<DBus/Wire.hs>>=+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++@ \subsubsection{Errors}++Unmarshaling can fail for four reasons:++\begin{itemize}+\item The message's declared protocol version is unsupported.+\item Unexpected {\sc eof}, when there are less bytes remaining than are+      required.+\item An invalid byte sequence for a given value type.+\item Missing required header fields for the declared message type.+\item Non-zero bytes were found where padding was expected.+\item A string, signature, or object path was not {\sc null}-terminated.+\item An array's size didn't match the number of elements+\end{itemize}++<<DBus/Wire.hs>>=+data UnmarshalError+	= UnsupportedProtocolVersion Word8+	| UnexpectedEOF Word64+	| Invalid Text Text+	| MissingHeaderField Text+	| InvalidHeaderField Text T.Variant+	| InvalidPadding Word64+	| MissingTerminator Word64+	| ArraySizeMismatch+	deriving (Eq)++instance Show UnmarshalError where+	show (UnsupportedProtocolVersion x) = concat+		["Unsupported protocol version: ", show x]+	show (UnexpectedEOF pos) = concat+		["Unexpected EOF at position ", show pos]+	show (Invalid label x) = TL.unpack $ TL.concat+		["Invalid ", label, ": ", x]+	show (MissingHeaderField x) = concat+		["Required field " , show x , " is missing."]+	show (InvalidHeaderField x got) = concat+		[ "Invalid header field ", show x, ": ", show got]+	show (InvalidPadding pos) = concat+		["Invalid padding at position ", show pos]+	show (MissingTerminator pos) = concat+		["Missing NUL terminator at position ", show pos]+	show ArraySizeMismatch = "Array size mismatch"++instance E.Error UnmarshalError++<<wire exports>>=+, UnmarshalError (..)++@ \subsection{Numerics}++Numeric values are fixed-length, and aligned ``naturally'' -- ie, a 4-byte+integer will have a 4-byte alignment.++<<alignments>>=+alignment T.DBusByte    = 1+alignment T.DBusWord16  = 2+alignment T.DBusWord32  = 4+alignment T.DBusWord64  = 8+alignment T.DBusInt16   = 2+alignment T.DBusInt32   = 4+alignment T.DBusInt64   = 8+alignment T.DBusDouble  = 8++@ Because {\tt Word32}s are often used for other types, there's+separate functions for handling them.++<<DBus/Wire.hs>>=+marshalWord32 :: Word32 -> Marshal+marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le++unmarshalWord32 :: Unmarshal Word32+unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le++<<marshalers>>=+marshalType T.DBusByte   = append $ L.singleton x+marshalType T.DBusWord16 = marshalBuilder 2 B.putWord16be B.putWord16le x+marshalType T.DBusWord32 = marshalBuilder 4 B.putWord32be B.putWord32le x+marshalType T.DBusWord64 = marshalBuilder 8 B.putWord64be B.putWord64le x+marshalType T.DBusInt16  = marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral (x :: Int16)+marshalType T.DBusInt32  = marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral (x :: Int32)+marshalType T.DBusInt64  = marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral (x :: Int64)++<<unmarshalers>>=+unmarshalType T.DBusByte = fmap (T.toVariant . L.head) $ consume 1+unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le+unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le+unmarshalType T.DBusWord64 = unmarshalGet' 8 G.getWord64be G.getWord64le++unmarshalType T.DBusInt16  = do+	x <- unmarshalGet 2 G.getWord16be G.getWord16le+	return . T.toVariant $ (fromIntegral x :: Int16)++unmarshalType T.DBusInt32  = do+	x <- unmarshalGet 4 G.getWord32be G.getWord32le+	return . T.toVariant $ (fromIntegral x :: Int32)++unmarshalType T.DBusInt64  = do+	x <- unmarshalGet 8 G.getWord64be G.getWord64le+	return . T.toVariant $ (fromIntegral x :: Int64)++@ {\tt Double}s are marshaled as in-bit IEEE-754 floating-point format.++<<wire imports>>=+import Data.Binary.Put (runPut)+import qualified Data.Binary.IEEE754 as IEEE++<<marshalers>>=+marshalType T.DBusDouble = do+	pad 8+	(MarshalState e _ _) <- ST.get+	let put = case e of+		BigEndian -> IEEE.putFloat64be+		LittleEndian -> IEEE.putFloat64le+	let bytes = runPut $ put x+	append bytes++<<unmarshalers>>=+unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le++@ \subsection{Booleans}++Booleans are marshaled as 4-byte unsigned integers containing either of+the values 0 or 1. Yes, really.++<<alignments>>=+alignment T.DBusBoolean = 4++<<marshalers>>=+marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0++<<unmarshalers>>=+unmarshalType T.DBusBoolean = unmarshalWord32 >>=+	fromMaybeU' "boolean" (\x -> case x of+		0 -> Just False+		1 -> Just True+		_ -> Nothing)++@ \subsection{Strings and object paths}++Strings are encoded in {\sc utf-8}, terminated with {\tt NUL}, and prefixed+with their length as an unsigned 32-bit integer. Their alignment is that of+their length. Object paths are marshaled just like strings, though additional+checks are required when unmarshaling.++TODO: If the input is invalid, these {\sc utf8} functions will raise an+exception, rather than return an error value. Eventually they should be+wrapped with {\tt unsafePerformIO} and be tweaked to return a proper+{\tt Maybe} or {\tt Either}.++<<wire imports>>=+import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)++<<DBus/Wire.hs>>=+marshalText :: Text -> Marshal+marshalText x = do+	let bytes = encodeUtf8 x+	when (L.any (== 0) bytes) $+		E.throwError $ TextContainsNUL x+	marshalWord32 . fromIntegral . L.length $ bytes+	append bytes+	append (L.singleton 0)++<<DBus/Wire.hs>>=+unmarshalText :: Unmarshal Text+unmarshalText = do+	byteCount <- unmarshalWord32+	bytes <- consume . fromIntegral $ byteCount+	skipTerminator+	return . decodeUtf8 $ bytes++<<alignments>>=+alignment T.DBusString     = 4+alignment T.DBusObjectPath = 4++<<marshalers>>=+marshalType T.DBusString = marshalText x+marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x++<<unmarshalers>>=+unmarshalType T.DBusString = fmap T.toVariant unmarshalText++unmarshalType T.DBusObjectPath = unmarshalText >>=+	fromMaybeU' "object path" T.mkObjectPath++@ \subsection{Signatures}++Signatures are similar to strings, except their length is limited to 255+characters and is therefore stored as a single byte.++<<DBus/Wire.hs>>=+marshalSignature :: T.Signature -> Marshal+marshalSignature x = do+	let bytes = encodeUtf8 . T.strSignature $ x+	let size = fromIntegral . L.length $ bytes+	append (L.singleton size)+	append bytes+	append (L.singleton 0)++<<DBus/Wire.hs>>=+unmarshalSignature :: Unmarshal T.Signature+unmarshalSignature = do+	byteCount <- L.head `fmap` consume 1+	sigText <- fmap decodeUtf8 $ consume . fromIntegral $ byteCount+	skipTerminator+	fromMaybeU "signature" T.mkSignature sigText++<<alignments>>=+alignment T.DBusSignature  = 1++<<marshalers>>=+marshalType T.DBusSignature = marshalSignature x++<<unmarshalers>>=+unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature++@ \subsection{Containers}++@ \subsubsection{Arrays}++<<alignments>>=+alignment (T.DBusArray _) = 4++<<marshalers>>=+marshalType (T.DBusArray _) = marshalArray x++<<unmarshalers>>=+unmarshalType (T.DBusArray t) = T.toVariant `fmap` unmarshalArray t++@ Marshaling arrays is complicated, because the array body must be marshaled+\emph{first} to calculate the array length. This requires building a+temporary marshaler, to get the padding right.++<<wire imports>>=+import qualified DBus.Constants as C++<<DBus/Wire.hs>>=+marshalArray :: T.Array -> Marshal+marshalArray x = do+	(arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x+	let arrayLen = L.length arrayBytes+	when (arrayLen > fromIntegral C.arrayMaximumLength)+		(E.throwError $ ArrayTooLong $ fromIntegral arrayLen)+	marshalWord32 $ fromIntegral arrayLen+	append $ L.replicate arrayPadding 0+	append arrayBytes++<<DBus/Wire.hs>>=+getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString)+getArrayBytes T.DBusByte x = return (0, bytes) where+	Just bytes = T.arrayToBytes x++<<DBus/Wire.hs>>=+getArrayBytes itemType x = do+	let vs = T.arrayItems x+	s <- ST.get+	(MarshalState _ _ afterLength) <- marshalWord32 0 >> ST.get+	(MarshalState e _ afterPadding) <- pad (alignment itemType) >> ST.get+	+	ST.put $ MarshalState e B.empty afterPadding+	(MarshalState _ itemBuilder _) <- mapM_ marshal vs >> ST.get+	+	let itemBytes = B.toLazyByteString itemBuilder+	    paddingSize = fromIntegral $ afterPadding - afterLength+	+	ST.put s+	return (paddingSize, itemBytes)++@ Unmarshaling is much easier, especially if it's a byte array.++<<DBus/Wire.hs>>=+unmarshalArray :: T.Type -> Unmarshal T.Array+unmarshalArray T.DBusByte = do+	byteCount <- unmarshalWord32+	T.arrayFromBytes `fmap` consume (fromIntegral byteCount)++<<DBus/Wire.hs>>=+unmarshalArray itemType = do+	let getOffset = do+		(UnmarshalState _ _ o) <- ST.get+		return o+	byteCount <- unmarshalWord32+	skipPadding (alignment itemType)+	start <- getOffset+	let end = start + fromIntegral byteCount+	vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType)+	end' <- getOffset+	when (end' > end) $+		E.throwError ArraySizeMismatch+	fromMaybeU "array" (T.arrayFromItems itemType) vs++@ \subsubsection{Dictionaries}++<<alignments>>=+alignment (T.DBusDictionary _ _) = 4++<<marshalers>>=+marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x)++<<unmarshalers>>=+unmarshalType (T.DBusDictionary kt vt) = do+	let pairType = T.DBusStructure [kt, vt]+	array <- unmarshalArray pairType+	fromMaybeU' "dictionary" T.arrayToDictionary array++@ \subsubsection{Structures}++<<alignments>>=+alignment (T.DBusStructure _) = 8++<<marshalers>>=+marshalType (T.DBusStructure _) = do+	let T.Structure vs = x+	pad 8+	mapM_ marshal vs++<<unmarshalers>>=+unmarshalType (T.DBusStructure ts) = do+	skipPadding 8+	fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts++@ \subsubsection{Variants}++<<alignments>>=+alignment T.DBusVariant = 1++<<marshalers>>=+marshalType T.DBusVariant = do+	let rawSig = T.typeCode . T.variantType $ x+	sig <- case T.mkSignature rawSig of+		Just x' -> return x'+		Nothing -> E.throwError $ InvalidVariantSignature rawSig+	marshalSignature sig+	marshal x++<<unmarshalers>>=+unmarshalType T.DBusVariant = do+	let getType sig = case T.signatureTypes sig of+		[t] -> Just t+		_   -> Nothing+	+	t <- fromMaybeU "variant signature" getType =<< unmarshalSignature+	T.toVariant `fmap` unmarshalType t++@ \subsection{Messages}++<<wire imports>>=+import qualified DBus.Message.Internal as M++@ \subsubsection{Flags}++<<wire imports>>=+import Data.Bits ((.|.), (.&.))+import qualified Data.Set as Set++<<DBus/Wire.hs>>=+encodeFlags :: Set.Set M.Flag -> Word8+encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where+	flagValue M.NoReplyExpected = 0x1+	flagValue M.NoAutoStart     = 0x2++decodeFlags :: Word8 -> Set.Set M.Flag+decodeFlags word = Set.fromList flags where+	flagSet = [ (0x1, M.NoReplyExpected)+	          , (0x2, M.NoAutoStart)+	          ]+	flags = flagSet >>= \(x, y) -> [y | word .&. x > 0]++@ \subsubsection{Header fields}++<<DBus/Wire.hs>>=+encodeField :: M.HeaderField -> T.Structure+encodeField (M.Path x)        = encodeField' 1 x+encodeField (M.Interface x)   = encodeField' 2 x+encodeField (M.Member x)      = encodeField' 3 x+encodeField (M.ErrorName x)   = encodeField' 4 x+encodeField (M.ReplySerial x) = encodeField' 5 x+encodeField (M.Destination x) = encodeField' 6 x+encodeField (M.Sender x)      = encodeField' 7 x+encodeField (M.Signature x)   = encodeField' 8 x++encodeField' :: T.Variable a => Word8 -> a -> T.Structure+encodeField' code x = T.Structure+	[ T.toVariant code+	, T.toVariant $ T.toVariant x+	]++<<DBus/Wire.hs>>=+decodeField :: Monad m => T.Structure+            -> E.ErrorT UnmarshalError m [M.HeaderField]+decodeField struct = case unpackField struct of+	(1, x) -> decodeField' x M.Path "path"+	(2, x) -> decodeField' x M.Interface "interface"+	(3, x) -> decodeField' x M.Member "member"+	(4, x) -> decodeField' x M.ErrorName "error name"+	(5, x) -> decodeField' x M.ReplySerial "reply serial"+	(6, x) -> decodeField' x M.Destination "destination"+	(7, x) -> decodeField' x M.Sender "sender"+	(8, x) -> decodeField' x M.Signature "signature"+	_      -> return []++decodeField' :: (Monad m, T.Variable a) => T.Variant -> (a -> b) -> Text+             -> E.ErrorT UnmarshalError m [b]+decodeField' x f label = case T.fromVariant x of+	Just x' -> return [f x']+	Nothing -> E.throwError $ InvalidHeaderField label x++<<DBus/Wire.hs>>=+unpackField :: T.Structure -> (Word8, T.Variant)+unpackField struct = (c', v') where+	T.Structure [c, v] = struct+	c' = fromJust . T.fromVariant $ c+	v' = fromJust . T.fromVariant $ v++@ \subsubsection{Header layout}++TODO: describe header layout here++@ \subsubsection{Marshaling}++<<wire exports>>=+, marshalMessage++<<DBus/Wire.hs>>=+marshalMessage :: M.Message a => Endianness -> M.Serial -> a+               -> Either MarshalError L.ByteString+marshalMessage e serial msg = runMarshal marshaler e where+	body = M.messageBody msg+	marshaler = do+		sig <- checkBodySig body+		empty <- ST.get+		mapM_ marshal body+		(MarshalState _ bodyBytesB _) <- ST.get+		ST.put empty+		marshalEndianness e+		let bodyBytes = B.toLazyByteString bodyBytesB+		marshalHeader msg serial sig+			$ fromIntegral . L.length $ bodyBytes+		pad 8+		append bodyBytes+		checkMaximumSize++<<DBus/Wire.hs>>=+checkBodySig :: [T.Variant] -> MarshalM T.Signature+checkBodySig vs = let+	sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs+	invalid = E.throwError $ InvalidBodySignature sigStr+	in case T.mkSignature sigStr of+		Just x -> return x+		Nothing -> invalid++<<DBus/Wire.hs>>=+marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32+              -> Marshal+marshalHeader msg serial bodySig bodyLength = do+	let fields = M.Signature bodySig : M.messageHeaderFields msg+	marshal . T.toVariant . M.messageTypeCode $ msg+	marshal . T.toVariant . encodeFlags . M.messageFlags $ msg+	marshal . T.toVariant $ C.protocolVersion+	marshalWord32 bodyLength+	marshal . T.toVariant $ serial+	let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant]+	marshal . T.toVariant . fromJust . T.toArray fieldType+	        $ map encodeField fields++<<DBus/Wire.hs>>=+marshalEndianness :: Endianness -> Marshal+marshalEndianness = marshal . T.toVariant . encodeEndianness++<<DBus/Wire.hs>>=+checkMaximumSize :: Marshal+checkMaximumSize = do+	(MarshalState _ _ messageLength) <- ST.get+	when (messageLength > fromIntegral C.messageMaximumLength)+		(E.throwError $ MessageTooLong $ fromIntegral messageLength)++@ \subsubsection{Unmarshaling}++<<wire exports>>=+, unmarshalMessage++<<DBus/Wire.hs>>=+unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)+                 -> m (Either UnmarshalError M.ReceivedMessage)+unmarshalMessage getBytes' = E.runErrorT $ do+	let getBytes = E.lift . getBytes'+	+	<<read fixed-length header>>+	<<read full header>>+	<<read body>>+	<<build message>>++@ The first part of the header has a fixed size of 16 bytes, so it can be+retrieved without any size calculations.++<<read fixed-length header>>=+let fixedSig = T.mkSignature' "yyyyuuu"+fixedBytes <- getBytes 16++@ The first field of interest is the protocol version; if the incoming+message's version is different from this library, the message cannot be+parsed.++<<read fixed-length header>>=+let messageVersion = L.index fixedBytes 3+when (messageVersion /= C.protocolVersion) $+	E.throwError $ UnsupportedProtocolVersion messageVersion++@ Next is the endianness, used for parsing pretty much every other field.++<<read fixed-length header>>=+let eByte = L.index fixedBytes 0+endianness <- case decodeEndianness eByte of+	Just x' -> return x'+	Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte++@ With the endianness out of the way, the rest of the fixed header+can be decoded++<<read fixed-length header>>=+let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of+	Right x' -> return x'+	Left  e  -> E.throwError e+fixed <- unmarshal' fixedSig fixedBytes+let typeCode = fromJust . T.fromVariant $ fixed !! 1+let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2+let bodyLength = fromJust . T.fromVariant $ fixed !! 4+let serial = fromJust . T.fromVariant $ fixed !! 5++@ The last field of the fixed header is actually part of the field array,+but is treated as a single {\tt Word32} so it'll be known how many bytes+to retrieve.++<<read fixed-length header>>=+let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6++@ With the field byte count, the remainder of the header bytes can be+pulled out of the monad.++<<read full header>>=+let headerSig  = T.mkSignature' "yyyyuua(yv)"+fieldBytes <- getBytes fieldByteCount+let headerBytes = L.append fixedBytes fieldBytes+header <- unmarshal' headerSig headerBytes++@ And the header fields can be parsed.++<<read full header>>=+let fieldArray = fromJust . T.fromVariant $ header !! 6+let fieldStructures = fromJust . T.fromArray $ fieldArray+fields <- concat `fmap` mapM decodeField fieldStructures++@ The body is always aligned to 8 bytes, so pull out the padding before+unmarshaling it.++<<read body>>=+let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8+getBytes . fromIntegral $ bodyPadding++<<DBus/Wire.hs>>=+findBodySignature :: [M.HeaderField] -> T.Signature+findBodySignature fields = fromMaybe empty signature where+	empty = T.mkSignature' ""+	signature = listToMaybe [x | M.Signature x <- fields]++<<read body>>=+let bodySig = findBodySignature fields++@ Then pull the body bytes, and unmarshal it.++<<read body>>=+bodyBytes <- getBytes bodyLength+body <- unmarshal' bodySig bodyBytes++@ Even if the received message was structurally valid, building the+{\tt ReceivedMessage} can still fail due to missing header fields.++<<build message>>=+y <- case buildReceivedMessage typeCode fields of+	Right x -> return x+	Left x -> E.throwError $ MissingHeaderField x++<<build message>>=+return $ y serial flags body++@ This really belongs in the Message section...++<<DBus/Wire.hs>>=+buildReceivedMessage :: Word8 -> [M.HeaderField] -> Either Text +                        (M.Serial -> (Set.Set M.Flag) -> [T.Variant]+                         -> M.ReceivedMessage)++@ Method calls++<<DBus/Wire.hs>>=+buildReceivedMessage 1 fields = do+	path <- require "path" [x | M.Path x <- fields]+	member <- require "member name" [x | M.Member x <- fields]+	return $ \serial flags body -> let+		iface = listToMaybe [x | M.Interface x <- fields]+		dest = listToMaybe [x | M.Destination x <- fields]+		sender = listToMaybe [x | M.Sender x <- fields]+		msg = M.MethodCall path member iface dest flags body+		in M.ReceivedMethodCall serial sender msg++@ Method returns++<<DBus/Wire.hs>>=+buildReceivedMessage 2 fields = do+	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]+	return $ \serial _ body -> let+		dest = listToMaybe [x | M.Destination x <- fields]+		sender = listToMaybe [x | M.Sender x <- fields]+		msg = M.MethodReturn replySerial dest body+		in M.ReceivedMethodReturn serial sender msg++@ Errors++<<DBus/Wire.hs>>=+buildReceivedMessage 3 fields = do+	name <- require "error name" [x | M.ErrorName x <- fields]+	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]+	return $ \serial _ body -> let+		dest = listToMaybe [x | M.Destination x <- fields]+		sender = listToMaybe [x | M.Sender x <- fields]+		msg = M.Error name replySerial dest body+		in M.ReceivedError serial sender msg++@ Signals++<<DBus/Wire.hs>>=+buildReceivedMessage 4 fields = do+	path <- require "path" [x | M.Path x <- fields]+	member <- require "member name" [x | M.Member x <- fields]+	iface <- require "interface" [x | M.Interface x <- fields]+	return $ \serial _ body -> let+		dest = listToMaybe [x | M.Destination x <- fields]+		sender = listToMaybe [x | M.Sender x <- fields]+		msg = M.Signal path member iface dest body+		in M.ReceivedSignal serial sender msg++@ Unknown++<<DBus/Wire.hs>>=+buildReceivedMessage typeCode fields = return $ \serial flags body -> let+	sender = listToMaybe [x | M.Sender x <- fields]+	msg = M.Unknown typeCode flags body+	in M.ReceivedUnknown serial sender msg++<<DBus/Wire.hs>>=+require :: Text -> [a] -> Either Text a+require _     (x:_) = Right x+require label _     = Left label++@ This is just needed for the Monad instance of {\tt Either Text}++<<DBus/Wire.hs>>=+instance E.Error Text where+	strMsg = TL.pack++@+\section{Addresses}++<<DBus/Address.hs>>=+<<copyright>>+<<text extensions>>+module DBus.Address+	( Address+	, addressMethod+	, addressParameters+	, mkAddresses+	, strAddress+	) where+<<text imports>>++import Data.Char (ord, chr)+import qualified Data.Map as M+import Text.Printf (printf)+import qualified Text.Parsec as P+import Text.Parsec ((<|>))+import DBus.Util (hexToInt, eitherToMaybe)++@ \subsection{Address syntax}++A bus address is in the format {\tt $method$:$key$=$value$,$key$=$value$...}+where the method may be empty and parameters are optional. An address's+parameter list, if present, may end with a comma. Addresses in environment+variables are separated by semicolons, and the full address list may end+in a semicolon. Multiple parameters may have the same key; in this case,+only the first parameter for each key will be stored.++The bytes allowed in each component of the address are given by the following+chart, where each character is understood to be its ASCII value:++\begin{table}[h]+\begin{center}+\begin{tabular}{ll}+\toprule+Component   & Allowed Characters \\+\midrule+Method      & Any except {\tt `;'} and {\tt `:'} \\+Param key   & Any except {\tt `;'}, {\tt `,'}, and {\tt `='} \\+Param value & {\tt `0'} to {\tt `9'} \\+            & {\tt `a'} to {\tt `z'} \\+            & {\tt `A'} to {\tt `Z'} \\+            & Any of: {\tt - \textunderscore{} / \textbackslash{} * . \%} \\+\bottomrule+\end{tabular}+\end{center}+\end{table}++In parameter values, any byte may be encoded by prepending the \% character+to its value in hexadecimal. \% is not allowed to appear unless it is+followed by two hexadecimal digits. Every other allowed byte is termed+an ``optionally encoded'' byte, and may appear unescaped in parameter+values.++<<DBus/Address.hs>>=+optionallyEncoded :: [Char]+optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."++@+The address simply stores its method and parameter map, with a custom+{\tt Show} instance to provide easier debugging.++<<DBus/Address.hs>>=+data Address = Address+	{ addressMethod     :: Text+	, addressParameters :: M.Map Text Text+	} deriving (Eq)++instance Show Address where+	showsPrec d x = showParen (d> 10) $+		showString "Address " . shows (strAddress x)++@+Parsing is straightforward; the input string is divided into addresses by+semicolons, then further by colons and commas. Parsing will fail if any+of the addresses in the input failed to parse.++<<DBus/Address.hs>>=+mkAddresses :: Text -> Maybe [Address]+mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where+	address = do+		method <- P.many (P.noneOf ":;")+		P.char ':'+		params <- P.sepEndBy param (P.char ',')+		return $ Address (TL.pack method) (M.fromList params)+	+	param = do+		key <- P.many1 (P.noneOf "=;,")+		P.char '='+		value <- P.many1 (encodedValue <|> unencodedValue)+		return (TL.pack key, TL.pack value)+	+	parser = do+		as <- P.sepEndBy1 address (P.char ';')+		P.eof+		return as+	+	unencodedValue = P.oneOf optionallyEncoded+	encodedValue = do+		P.char '%'+		hex <- P.count 2 P.hexDigit+		return . chr . hexToInt $ hex++@+Converting an {\tt Address} back to a {\tt String} is just the reverse+operation. Note that because the original parameter order is not preserved,+the string produced might differ from the original input.++<<DBus/Address.hs>>=+strAddress :: Address -> Text+strAddress (Address t ps) = TL.concat [t, ":", ps'] where+	ps' = TL.intercalate "," $ do+		(k, v) <- M.toList ps+		return $ TL.concat [k, "=", TL.concatMap encode v]+	encode c | elem c optionallyEncoded = TL.singleton c+	         | otherwise       = TL.pack $ printf "%%%02X" (ord c)++@+\section{Connections}++<<DBus/Connection.hs>>=+<<copyright>>+<<text extensions>>+{-# LANGUAGE DeriveDataTypeable #-}+module DBus.Connection+	( <<connection exports>>+	) where+<<text imports>>+<<connection imports>>++@ A {\tt Connection} is an opaque handle to an open D-Bus channel, with+an internal state for maintaining the current message serial.++The second {\tt MVar} doesn't really store a value, it's just used to+prevent two separate threads from reading from the transport at once.++<<connection imports>>=+import qualified Control.Concurrent as C+import qualified DBus.Address as A+import qualified DBus.Message.Internal as M++<<DBus/Connection.hs>>=+data Connection = Connection A.Address Transport (C.MVar M.Serial) (C.MVar ())++<<connection exports>>=+  Connection++@ While not particularly useful for other functions, being able to+{\tt show} a {\tt Connection} is useful when debugging.++<<DBus/Connection.hs>>=+instance Show Connection where+	showsPrec d (Connection a _ _ _) = showParen (d > 10) $+		showString' ["<connection ", show $ A.strAddress a, ">"] where+		showString' = foldr (.) id . map showString++@ \subsection{Transports}++A transport is anything which can send and receive bytestrings, typically+over a socket.++<<connection imports>>=+import qualified Data.ByteString.Lazy as L+import Data.Word (Word32)++<<DBus/Connection.hs>>=+data Transport = Transport+	{ transportSend :: L.ByteString -> IO ()+	, transportRecv :: Word32 -> IO L.ByteString+	}++@ If a method has no known transport, attempting to connect using it will+just result in an exception.++<<DBus/Connection.hs>>=+connectTransport :: A.Address -> IO Transport+connectTransport a = transport' (A.addressMethod a) a where+	transport' "unix" = unix+	transport' "tcp"  = tcp+	transport' _      = E.throwIO . UnknownMethod++@ \subsubsection{UNIX}++The {\sc unix} transport accepts two parameters: {\tt path}, which is a+simple filesystem path, and {\tt abstract}, which is a path in the+Linux-specific abstract domain. One, and only one, of these parameters must+be specified.++<<connection imports>>=+import qualified Network as N+import qualified Data.Map as Map++<<DBus/Connection.hs>>=+unix :: A.Address -> IO Transport+unix a = port >>= N.connectTo "localhost" >>= handleTransport where+	params = A.addressParameters a+	path = Map.lookup "path" params+	abstract = Map.lookup "abstract" 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."+	+	port = fmap N.UnixSocket path'+	path' = case (path, abstract) of+		(Just _, Just _) -> E.throwIO $ BadParameters a tooMany+		(Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew+		(Just x, Nothing) -> return $ TL.unpack x+		(Nothing, Just x) -> return $ '\x00' : TL.unpack x++@ \subsubsection{TCP}++The {\sc tcp} transport has three parameters:++\begin{itemize}+\item {\tt host} -- optional, defaults to {\tt "localhost"}+\item {\tt port} -- unsigned 16-bit integer+\item {\tt family} -- optional, defaults to {\sc unspec}, choices are+      {\tt "ipv4"} or {\tt "ipv6"}+\end{itemize}++The high-level {\tt Network} module doesn't provide enough control over+socket construction for this transport, so {\tt Network.Socket} must be+imported.++<<connection imports>>=+import qualified Network.Socket as NS++<<DBus/Connection.hs>>=+tcp :: A.Address -> IO Transport+tcp a = openHandle >>= handleTransport where+	params = A.addressParameters a+	openHandle = do+		port <- getPort+		family <- getFamily+		addresses <- getAddresses family+		socket <- openSocket port addresses+		NS.socketToHandle socket I.ReadWriteMode++@ Parameter parsing...++<<DBus/Connection.hs>>=+	hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params++<<DBus/Connection.hs>>=+	unknownFamily x = TL.concat ["Unknown socket family for TCP transport: ", x]+	getFamily = case Map.lookup "family" params of+		Just "ipv4" -> return NS.AF_INET+		Just "ipv6" -> return NS.AF_INET6+		Nothing     -> return NS.AF_UNSPEC+		Just x      -> E.throwIO $ BadParameters a $ unknownFamily x++<<DBus/Connection.hs>>=+	missingPort = "TCP transport requires the ``port'' parameter."+	badPort x = TL.concat ["Invalid socket port for TCP transport: ", x]+	getPort = case Map.lookup "port" params of+		Nothing -> E.throwIO $ BadParameters a missingPort+		Just x -> case P.parse parseWord16 "" (TL.unpack x) of+			Right x' -> return $ NS.PortNum x'+			Left  _  -> E.throwIO $ BadParameters a $ badPort x++@ Parsing the port is a bit complicated; assuming every character is an ASCII+digit, the port is converted to an {\tt Integer} and confirmed valid.+{\tt PortNumber} is expected to be in big-endian byte order, so the parsed+value must be converted from host order using {\tt Data.Binary}.++<<connection imports>>=+import qualified Text.Parsec as P+import Control.Monad (unless)+import Data.Binary.Get (runGet, getWord16host)+import Data.Binary.Put (runPut, putWord16be)++<<DBus/Connection.hs>>=+	parseWord16 = do+		chars <- P.many1 P.digit+		P.eof+		let value = read chars :: Integer+		unless (value > 0 && value <= 65535) $+			P.parserFail "bad port" >> return ()+		let word = fromIntegral value+		return $ runGet getWord16host (runPut (putWord16be word))++<<DBus/Connection.hs>>=+	getAddresses family = do+		let hints = NS.defaultHints+			{ NS.addrFlags = [NS.AI_ADDRCONFIG]+			, NS.addrFamily = family+			, NS.addrSocketType = NS.Stream+			}+		NS.getAddrInfo (Just hints) (Just hostname) Nothing++@ The {\tt SockAddr} values returned from {\tt getAddrInfo} don't have any+port set, so it must be manually changed to whatever was in the {\tt port}+option.++<<DBus/Connection.hs>>=+	setPort port (NS.SockAddrInet  _ x)     = NS.SockAddrInet port x+	setPort port (NS.SockAddrInet6 _ x y z) = NS.SockAddrInet6 port x y z+	setPort _    addr                       = addr++@ {\tt getAddrInfo} returns multiple addresses; each one is tried in turn,+until a valid address is found. If none are found, or are usable, an+exception will be thrown.++<<DBus/Connection.hs>>=+	openSocket _ [] = E.throwIO $ NoWorkingAddress [a]+	openSocket port (addr:addrs) = E.catch (openSocket' port addr) $+		\(E.SomeException _) -> openSocket port addrs+	openSocket' port addr = do+		sock <- NS.socket (NS.addrFamily addr)+		                  (NS.addrSocketType addr)+		                  (NS.addrProtocol addr)+		NS.connect sock . setPort port . NS.addrAddress $ addr+		return sock++@ \subsubsection{Generic handle-based transport}++Both UNIX and TCP are backed by standard handles, and can therefore use+a shared handle-based transport backend.++<<connection imports>>=+import qualified System.IO as I++<<DBus/Connection.hs>>=+handleTransport :: I.Handle -> IO Transport+handleTransport h = do+	I.hSetBuffering h I.NoBuffering+	I.hSetBinaryMode h True+	return $ Transport (L.hPut h) (L.hGet h . fromIntegral)++@ \subsection{Errors}++If connecting to D-Bus fails, a {\tt ConnectionError} will be thrown.+The constructor describes which exception occurred.++<<connection imports>>=+import qualified Control.Exception as E+import Data.Typeable (Typeable)++<<DBus/Connection.hs>>=+data ConnectionError+	= InvalidAddress Text+	| BadParameters A.Address Text+	| UnknownMethod A.Address+	| NoWorkingAddress [A.Address]+	deriving (Show, Typeable)++instance E.Exception ConnectionError++<<connection exports>>=+, ConnectionError (..)+, W.MarshalError (..)+, W.UnmarshalError (..)++@ \subsection{Establishing a connection}++A connection can be opened to any valid address, though actually connecting+might fail due to external factors.++<<connection imports>>=+import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)++<<DBus/Connection.hs>>=+connect :: A.Address -> IO Connection+connect a = do+	t <- connectTransport a+	let putS = transportSend t . encodeUtf8 . TL.pack+	let getS = fmap (TL.unpack . decodeUtf8) . transportRecv t+	authenticate putS getS+	readLock <- C.newMVar ()+	serialMVar <- C.newMVar M.firstSerial+	return $ Connection a t serialMVar readLock++@ Since addresses usually come in a list, it's sensible to have a variant+of {\tt connect} which tries multiple addresses. The first successfully+opened {\tt Connection} is returned.++<<DBus/Connection.hs>>=+connectFirst :: [A.Address] -> IO Connection+connectFirst orig = connectFirst' orig where+	connectFirst'     [] = E.throwIO $ NoWorkingAddress orig+	connectFirst' (a:as) = E.catch (connect a) $+		\(E.SomeException _) -> connectFirst' as++<<connection exports>>=+, connect+, connectFirst++@ \subsection{Authentication}++<<DBus/Connection.hs>>=+authenticate :: (String -> IO ()) -> (Word32 -> IO String)+                -> IO ()+authenticate put get = do+	put "\x00"++@ {\sc external} authentication is performed using the process's real user+ID, converted to a string, and then hex-encoded.++<<connection imports>>=+import System.Posix.User (getRealUserID)+import Data.Char (ord)+import Text.Printf (printf)++<<DBus/Connection.hs>>=+	uid <- getRealUserID+	let authToken = concatMap (printf "%02X" . ord) (show uid)+	put $ "AUTH EXTERNAL " ++ authToken ++ "\r\n"++@ If authentication was successful, the server responds with {\tt OK+<server GUID>}.  The GUID is intended to enable connection sharing, which+is currently unimplemented, so it's ignored.++<<connection imports>>=+import Data.List (isPrefixOf)++<<DBus/Connection.hs>>=+	response <- readUntil '\n' get+	if "OK" `isPrefixOf` response+		then put "BEGIN\r\n"+		else do+			putStrLn $ "response = " ++ show response+			error "Server rejected authentication token."++<<DBus/Connection.hs>>=+readUntil :: Monad m => Char -> (Word32 -> m String) -> m String+readUntil = readUntil' "" where+	readUntil' xs c f = do+		[x] <- f 1+		let xs' = xs ++ [x]+		if x == c+			then return xs'+			else readUntil' xs' c f++@ \subsection{Sending and receiving messages}++Sending a message will increment the connection's internal serial state.+The second parameter is present to allow registration of a callback before+the message has actually been sent, which avoids race conditions in+multi-threaded clients.++<<connection imports>>=+import qualified DBus.Wire as W++<<DBus/Connection.hs>>=+send :: M.Message a => Connection -> (M.Serial -> IO b) -> a+     -> IO (Either W.MarshalError b)+send (Connection _ t mvar _) io msg = withSerial mvar $ \serial ->+	case W.marshalMessage W.LittleEndian serial msg of+		Right bytes -> do+			x <- io serial+			transportSend t bytes+			return $ Right x+		Left  err   -> return $ Left err++<<connection exports>>=+, send++<<DBus/Connection.hs>>=+withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a+withSerial m io = E.block $ do+	s <- C.takeMVar m+	let s' = M.nextSerial s+	x <- E.unblock (io s) `E.onException` C.putMVar m s'+	C.putMVar m s'+	return x++@ Messages are received wrapped in a {\tt ReceivedMessage} value. If an+error is encountered while unmarshaling, an exception will be thrown.++<<DBus/Connection.hs>>=+receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage)+receive (Connection _ t _ lock) = C.withMVar lock $ \_ ->+	W.unmarshalMessage $ transportRecv t++<<connection exports>>=+, receive++@+\section{The central bus}++<<DBus/Bus.hs>>=+<<copyright>>+<<text extensions>>+module DBus.Bus+	( getBus+	, getFirstBus+	, getSystemBus+	, getSessionBus+	, getStarterBus+	) where+<<text imports>>++import qualified Control.Exception as E+import Control.Monad (when)+import Data.Maybe (fromJust, isNothing)+import qualified Data.Set as Set+import System.Environment (getEnv)++import qualified DBus.Address as A+import qualified DBus.Connection as C+import DBus.Constants (dbusName, dbusPath, dbusInterface)+import qualified DBus.Message as M+import qualified DBus.Types as T+import DBus.Util (fromRight)++@ Connecting to a message bus is a bit more involved than just connecting+over an app-to-app connection: the bus must be notified of the new client,+using a "hello message", before it will begin forwarding messages.++<<DBus/Bus.hs>>=+busForConnection :: C.Connection -> IO (C.Connection, T.BusName)+busForConnection c = sendHello c >>= return . (,) c++<<DBus/Bus.hs>>=+getBus :: A.Address -> IO (C.Connection, T.BusName)+getBus = (busForConnection =<<) . C.connect++@ Optionally, multiple addresses may be provided. The first successful+connection will be used.++<<DBus/Bus.hs>>=+getFirstBus :: [A.Address] -> IO (C.Connection, T.BusName)+getFirstBus = (busForConnection =<<) . C.connectFirst++@ \subsection{Default connections}++Two default buses are defined, the ``system'' and ``session'' buses. The system+bus is global for the OS, while the session bus runs only for the duration+of the user's session.++<<DBus/Bus.hs>>=+getSystemBus :: IO (C.Connection, T.BusName)+getSystemBus = getBus' $ fromEnv `E.catch` noEnv where+	defaultAddr = "unix:path=/var/run/dbus/system_bus_socket"+	fromEnv = getEnv "DBUS_SYSTEM_BUS_ADDRESS"+	noEnv (E.SomeException _) = return defaultAddr++<<DBus/Bus.hs>>=+getSessionBus :: IO (C.Connection, T.BusName)+getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS"++<<DBus/Bus.hs>>=+getStarterBus :: IO (C.Connection, T.BusName)+getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS"++<<DBus/Bus.hs>>=+getBus' :: IO String -> IO (C.Connection, T.BusName)+getBus' io = do+	addr <- fmap TL.pack io+	case A.mkAddresses addr of+		Just [x] -> getBus x+		Just  x  -> getFirstBus x+		_        -> E.throwIO $ C.InvalidAddress addr++@ \subsection{Sending the ``hello'' message}++<<DBus/Bus.hs>>=+hello :: M.MethodCall+hello = M.MethodCall dbusPath+	(T.mkMemberName' "Hello")+	(Just dbusInterface)+	(Just dbusName)+	Set.empty+	[]++<<DBus/Bus.hs>>=+sendHello :: C.Connection -> IO T.BusName+sendHello c = do+	serial <- fromRight `fmap` C.send c return hello+	reply <- waitForReply c serial+	let name = case M.methodReturnBody reply of+		(x:_) -> T.fromVariant x+		_     -> Nothing+	+	when (isNothing name) $+		E.throwIO $ E.AssertionFailed "Invalid response to Hello()"+	+	return . fromJust $ name++<<DBus/Bus.hs>>=+waitForReply :: C.Connection -> M.Serial -> IO M.MethodReturn+waitForReply c serial = do+	received <- C.receive c+	msg <- case received of+		Right x -> return x+		Left _  -> E.throwIO $ E.AssertionFailed "Invalid response to Hello()"+	case msg of+		(M.ReceivedMethodReturn _ _ reply) ->+			if M.methodReturnSerial reply == serial+				then return reply+				else waitForReply c serial+		_ -> waitForReply c serial++@+\section{Introspection}++@ D-Bus objects may be ``introspected'' to determine which methods, signals,+etc they support. Intospection data is sent over the bus in {\sc xml}, in+a mostly standardised but undocumented format.++An XML introspection document looks like this:++\begin{verbatim}+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"+         "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">+<node name="/org/example/example">+	<interface name="org.example.ExampleInterface">+		<method name="Echo">+			<arg name="text" type="s" direction="in"/>+			<arg type="s" direction="out"/>+		</method>+		<signal name="Echoed">+			<arg type="s"/>+		</signal>+		<property name="EchoCount" type="u" access="read"/>+	</interface>+	<node name="child_a"/>+	<node name="child/b"/>+</node>+\end{verbatim}++<<DBus/Introspection.hs>>=+<<copyright>>+<<text extensions>>+module DBus.Introspection+	( Object (..)+	, Interface (..)+	, Method (..)+	, Signal (..)+	, Parameter (..)+	, Property (..)+	, PropertyAccess (..)+	, toXML+	, fromXML+	) where+<<text imports>>+<<introspection imports>>+import qualified DBus.Types as T++@ HaXml is used to do the heavy lifting of XML parsing because HXT cannot+be combined with Parsec 3.++<<introspection imports>>=+import qualified Text.XML.HaXml as H++@ \subsection{Data types}++<<DBus/Introspection.hs>>=+data Object = Object T.ObjectPath [Interface] [Object]+	deriving (Show, Eq)++data Interface = Interface T.InterfaceName [Method] [Signal] [Property]+	deriving (Show, Eq)++data Method = Method T.MemberName [Parameter] [Parameter]+	deriving (Show, Eq)++data Signal = Signal T.MemberName [Parameter]+	deriving (Show, Eq)++data Parameter = Parameter Text T.Signature+	deriving (Show, Eq)++data Property = Property Text T.Signature [PropertyAccess]+	deriving (Show, Eq)++data PropertyAccess = Read | Write+	deriving (Show, Eq)++@ \subsection{Parsing XML}++The root {\tt node} is special, in that it's the only {\tt node} which is+not required to have a {\tt name} attribute. If the root has no {\tt name},+its path will default to the path of the introspected object.++If parsing fails, {\tt fromXML} will return {\tt Nothing}. Aside from the+elements directly accessed by the parser, no effort is made to check the+document's validity because there is no DTD as of yet.++<<introspection imports>>=+import Text.XML.HaXml.Parse (xmlParse')+import DBus.Util (eitherToMaybe)++<<DBus/Introspection.hs>>=+fromXML :: T.ObjectPath -> Text -> Maybe Object+fromXML path text = do+	doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text+	let (H.Document _ _ root _) = doc+	parseRoot path root++@ Even though the root object's {\tt name} is optional, if present, it must+still be a valid object path.++<<DBus/Introspection.hs>>=+parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object+parseRoot defaultPath e = do+	path <- case getAttr "name" e of+		Nothing -> Just defaultPath+		Just x  -> T.mkObjectPath x+	parseObject' path e++@ Child {\tt nodes} have ``relative'' paths -- that is, their {\tt name}+attribute is not a valid object path, but should be valid when appended to+the root object's path.++<<DBus/Introspection.hs>>=+parseChild :: T.ObjectPath -> H.Element a -> Maybe Object+parseChild parentPath e = do+	let parentPath' = case T.strObjectPath parentPath of+		"/" -> "/"+		x   -> TL.append x "/"+	pathSegment <- getAttr "name" e+	path <- T.mkObjectPath $ TL.append parentPath' pathSegment+	parseObject' path e++@ Other than the name, both root and non-root {\tt nodes} have identical+contents.  They may contain interface definitions, and child {\tt node}s.++<<DBus/Introspection.hs>>=+parseObject' :: T.ObjectPath -> H.Element a -> Maybe Object+parseObject' path e@(H.Elem "node" _ _)  = do+	interfaces <- children parseInterface (H.tag "interface") e+	children' <- children (parseChild path) (H.tag "node") e+	return $ Object path interfaces children'+parseObject' _ _ = Nothing++@ Interfaces may contain methods, signals, and properties.++<<DBus/Introspection.hs>>=+parseInterface :: H.Element a -> Maybe Interface+parseInterface e = do+	name <- T.mkInterfaceName =<< getAttr "name" e+	methods <- children parseMethod (H.tag "method") e+	signals <- children parseSignal (H.tag "signal") e+	properties <- children parseProperty (H.tag "property") e+	return $ Interface name methods signals properties++@ Methods contain a list of parameters, which default to ``in'' parameters+if no direction is specified.++<<DBus/Introspection.hs>>=+parseMethod :: H.Element a -> Maybe Method+parseMethod e = do+	name <- T.mkMemberName =<< getAttr "name" e+	paramsIn <- children parseParameter (isParam ["in", ""]) e+	paramsOut <- children parseParameter (isParam ["out"]) e+	return $ Method name paramsIn paramsOut++@ Signals are similar to methods, except they have no ``in'' parameters.++<<DBus/Introspection.hs>>=+parseSignal :: H.Element a -> Maybe Signal+parseSignal e = do+	name <- T.mkMemberName =<< getAttr "name" e+	params <- children parseParameter (isParam ["out", ""]) e+	return $ Signal name params++@ A parameter has a free-form name, and a single valid type.++<<DBus/Introspection.hs>>=+parseParameter :: H.Element a -> Maybe Parameter+parseParameter e = do+	let name = getAttr' "name" e+	sig <- parseType e+	return $ Parameter name sig++<<DBus/Introspection.hs>>=+parseType :: H.Element a -> Maybe T.Signature+parseType e = do+	sig <- T.mkSignature =<< getAttr "type" e+	case T.signatureTypes sig of+		[_] -> Just sig+		_   -> Nothing++@ Properties are used by the {\tt org.freedesktop.DBus.Properties} interface.+Each property may be read, written, or both, and has an associated type.++<<DBus/Introspection.hs>>=+parseProperty :: H.Element a -> Maybe Property+parseProperty e = do+	let name = getAttr' "name" e+	sig <- parseType e+	access <- case getAttr' "access" e of+		""          -> Just []+		"read"      -> Just [Read]+		"write"     -> Just [Write]+		"readwrite" -> Just [Read, Write]+		_           -> Nothing+	return $ Property name sig access++@ HaXml doesn't seem to have any way to retrieve the ``real'' value of an+attribute, so {\tt attrValue} implements this.++<<introspection imports>>=+import Data.Char (chr)++<<DBus/Introspection.hs>>=+attrValue :: H.AttValue -> Maybe Text+attrValue attr = fmap (TL.pack . concat) $ mapM unescape parts where+	(H.AttValue parts) = attr+	+	unescape (Left x) = Just x+	unescape (Right (H.RefEntity x)) = lookup x namedRefs+	unescape (Right (H.RefChar x)) = Just [chr x]+	+	namedRefs =+		[ ("lt", "<")+		, ("gt", ">")+		, ("amp", "&")+		, ("apos", "'")+		, ("quot", "\"")+		]++@ Some helper functions for dealing with HaXml filters++<<introspection imports>>=+import Data.Maybe (fromMaybe)++<<DBus/Introspection.hs>>=+getAttr :: String -> H.Element a -> Maybe Text+getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue++getAttr' :: String -> H.Element a -> Text+getAttr' = (fromMaybe "" .) . getAttr++<<DBus/Introspection.hs>>=+isParam :: [Text] -> H.CFilter a+isParam dirs content = do+	arg@(H.CElem e _) <- H.tag "arg" content+	let direction = getAttr' "direction" e+	[arg | direction `elem` dirs]++<<DBus/Introspection.hs>>=+children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b]+children f filt (H.Elem _ _ contents) =+	mapM f [x | (H.CElem x _) <- concatMap filt contents]++@ \subsection{Generating XML}++<<DBus/Introspection.hs>>=+dtdPublicID, dtdSystemID :: String+dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"+dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"++@ HaXml punts to the {\tt pretty} package for serialising XML.++<<introspection imports>>=+import Text.XML.HaXml.Pretty (document)+import Text.PrettyPrint.HughesPJ (render)++@ Generating XML can fail; if a child object's path is not a sub-path of the+parent, {\tt toXML} will return {\tt Nothing}.++<<DBus/Introspection.hs>>=+toXML :: Object -> Maybe Text+toXML obj = fmap (TL.pack . render . document) doc where+	prolog = H.Prolog Nothing [] (Just doctype) []+	doctype = H.DTD "node" (Just (H.PUBLIC+		(H.PubidLiteral dtdPublicID)+		(H.SystemLiteral dtdSystemID))) []+	doc = do+		root <- xmlRoot obj+		return $ H.Document prolog H.emptyST root []++@ When writing objects to {\tt node}s, the root object must have an absolute+path, and children must have paths relative to their parent.++<<DBus/Introspection.hs>>=+xmlRoot :: Object -> Maybe (H.Element a)+xmlRoot obj@(Object path _ _) = do+	(H.CElem root _) <- xmlObject' (T.strObjectPath path) obj+	return root++<<DBus/Introspection.hs>>=+xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a)+xmlObject parentPath obj@(Object path _ _) = do+	let path' = T.strObjectPath path+	    parent' = T.strObjectPath parentPath+	relpath <- if TL.isPrefixOf parent' path'+		then Just $ if parent' == "/"+			then TL.drop 1 path'+			else TL.drop (TL.length parent' + 1) path'+		else Nothing+	xmlObject' relpath obj++<<DBus/Introspection.hs>>=+xmlObject' :: Text -> Object -> Maybe (H.Content a)+xmlObject' path (Object fullPath interfaces children') = do+	children'' <- mapM (xmlObject fullPath) children'+	return $ mkElement "node"+		[mkAttr "name" $ TL.unpack path]+		$ concat+			[ map xmlInterface interfaces+			, children''+			]++<<DBus/Introspection.hs>>=+xmlInterface :: Interface -> H.Content a+xmlInterface (Interface name methods signals properties) =+	mkElement "interface"+		[mkAttr "name" . TL.unpack . T.strInterfaceName $ name]+		$ concat+			[ map xmlMethod methods+			, map xmlSignal signals+			, map xmlProperty properties+			]++<<DBus/Introspection.hs>>=+xmlMethod :: Method -> H.Content a+xmlMethod (Method name inParams outParams) = mkElement "method"+	[mkAttr "name" . TL.unpack . T.strMemberName $ name]+	$ concat+		[ map (xmlParameter "in") inParams+		, map (xmlParameter "out") outParams+		]++<<DBus/Introspection.hs>>=+xmlSignal :: Signal -> H.Content a+xmlSignal (Signal name params) = mkElement "signal"+	[mkAttr "name" . TL.unpack . T.strMemberName $ name]+	$ map (xmlParameter "out") params++<<DBus/Introspection.hs>>=+xmlParameter :: String -> Parameter -> H.Content a+xmlParameter direction (Parameter name sig) = mkElement "arg"+	[ mkAttr "name" . TL.unpack $ name+	, mkAttr "type" . TL.unpack . T.strSignature $ sig+	, mkAttr "direction" direction+	] []++<<DBus/Introspection.hs>>=+xmlProperty :: Property -> H.Content a+xmlProperty (Property name sig access) = mkElement "property"+	[ mkAttr "name" . TL.unpack $ name+	, mkAttr "type" . TL.unpack . T.strSignature $ sig+	, mkAttr "access" $ xmlAccess access+	] []++<<DBus/Introspection.hs>>=+xmlAccess :: [PropertyAccess] -> String+xmlAccess access = readS ++ writeS where+	readS = if elem Read access then "read" else ""+	writeS = if elem Write access then "write" else ""++<<DBus/Introspection.hs>>=+mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a+mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined++<<DBus/Introspection.hs>>=+mkAttr :: String -> String -> H.Attribute+mkAttr name value = (name, H.AttValue [Left escaped]) where+	raw = H.CString True value ()+	escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw]++@+\section{Match rules}++Match rules are used indicate that the client is interested in messages+matching a particular filter. This module provides an interface for building+match rule strings. Eventually, it will support parsing them also.++<<DBus/MatchRule.hs>>=+<<copyright>>+<<text extensions>>+module DBus.MatchRule (+	  MatchRule (..)+	, MessageType (..)+	, ParameterValue (..)+	, formatRule+	, addMatch+	, matchAll+	, matches+	) where+<<text imports>>+import Data.Word (Word8)+import Data.Maybe (catMaybes, fromMaybe)+import qualified Data.Set as Set+import qualified DBus.Types as T+import qualified DBus.Message as M+import qualified DBus.Constants as C+import DBus.Util (maybeIndex)++@ A match rule is a set of filters; most filters may have one possible+value assigned, such as a single message type. The exception are parameter+filters, which are limited in number only by the server implementation.++<<DBus/MatchRule.hs>>=+data MatchRule = MatchRule+	{ matchType        :: Maybe MessageType+	, matchSender      :: Maybe T.BusName+	, matchInterface   :: Maybe T.InterfaceName+	, matchMember      :: Maybe T.MemberName+	, matchPath        :: Maybe T.ObjectPath+	, matchDestination :: Maybe T.BusName+	, matchParameters  :: [ParameterValue]+	}++@ Parameters may match against two types, strings and object paths. It's+probably an error to have two values for the same parameter.++The constructor {\tt StringValue 3 "hello"} means that the fourth parameter+in the message body must be the string ``hello''. {\tt PathValue} is the+same, but its value must be an object path.++<<DBus/MatchRule.hs>>=+data ParameterValue+	= StringValue Word8 Text+	| PathValue Word8 T.ObjectPath+	deriving (Show, Eq)++@ The set of allowed message types to filter on is separate from the set+supported for sending over the wire. This allows the server to support+additional types not yet implemented in the library, or vice-versa.++<<DBus/MatchRule.hs>>=+data MessageType+	= MethodCall+	| MethodReturn+	| Signal+	| Error+	deriving (Show, Eq)++@ There's currently only one operation to perform on match rules, and that's+to format them.++<<DBus/MatchRule.hs>>=+formatRule :: MatchRule -> Text+formatRule rule = TL.intercalate "," filters where+	filters = structureFilters ++ parameterFilters+	parameterFilters = map formatParameter $ matchParameters rule+	structureFilters = catMaybes $ map unpack+		[ ("type", fmap formatType . matchType)+		, ("sender", fmap T.strBusName . matchSender)+		, ("interface", fmap T.strInterfaceName . matchInterface)+		, ("member", fmap T.strMemberName . matchMember)+		, ("path", fmap T.strObjectPath . matchPath)+		, ("destination", fmap T.strBusName . matchDestination)+		]+	unpack (key, mkValue) = formatFilter' key `fmap` mkValue rule++<<DBus/MatchRule.hs>>=+formatParameter :: ParameterValue -> Text+formatParameter (StringValue index x) = formatFilter' key x where+	key = "arg" `TL.append` TL.pack (show index)+formatParameter (PathValue index x) = formatFilter' key value where+	key = "arg" `TL.append` TL.pack (show index) `TL.append` "path"+	value = T.strObjectPath x++@ FIXME: what are the escaping rules for match rules? Other bindings don't+seem to perform any escaping at all.++<<DBus/MatchRule.hs>>=+formatFilter' :: Text -> Text -> Text+formatFilter' key value = TL.concat [key, "='", value, "'"]++<<DBus/MatchRule.hs>>=+formatType :: MessageType -> Text+formatType MethodCall   = "method_call"+formatType MethodReturn = "method_return"+formatType Signal       = "signal"+formatType Error        = "error"++@ And since the only real reason for formatting a match rule is to send it,+it's useful to have a message-building function pre-defined.++<<DBus/MatchRule.hs>>=+addMatch :: MatchRule -> M.MethodCall+addMatch rule = M.MethodCall+	C.dbusPath+	(T.mkMemberName' "AddMatch")+	(Just C.dbusInterface)+	(Just C.dbusName)+	Set.empty+	[T.toVariant $ formatRule rule]++@ Most match rules will have only one or two fields filled in, so defining+an empty rule allows clients to set only the fields they care about.++<<DBus/MatchRule.hs>>=+matchAll :: MatchRule+matchAll = MatchRule+	{ matchType        = Nothing+	, matchSender      = Nothing+	, matchInterface   = Nothing+	, matchMember      = Nothing+	, matchPath        = Nothing+	, matchDestination = Nothing+	, matchParameters  = []+	}++@ It's useful to match against a rule client-side, eg when listening for+signals.++<<DBus/MatchRule.hs>>=+matches :: MatchRule -> M.ReceivedMessage -> Bool+matches rule msg = and . catMaybes . map ($ rule) $+	[ fmap      (typeMatches msg) . matchType+	, fmap    (senderMatches msg) . matchSender+	, fmap     (ifaceMatches msg) . matchInterface+	, fmap    (memberMatches msg) . matchMember+	, fmap      (pathMatches msg) . matchPath+	, fmap      (destMatches msg) . matchDestination+	, Just . parametersMatch msg  . matchParameters+	]++<<DBus/MatchRule.hs>>=+typeMatches :: M.ReceivedMessage -> MessageType -> Bool+typeMatches (M.ReceivedMethodCall   _ _ _) MethodCall   = True+typeMatches (M.ReceivedMethodReturn _ _ _) MethodReturn = True+typeMatches (M.ReceivedSignal       _ _ _) Signal       = True+typeMatches (M.ReceivedError        _ _ _) Error        = True+typeMatches _ _ = False+++<<DBus/MatchRule.hs>>=+senderMatches :: M.ReceivedMessage -> T.BusName -> Bool+senderMatches msg name = M.receivedSender msg == Just name++<<DBus/MatchRule.hs>>=+ifaceMatches :: M.ReceivedMessage -> T.InterfaceName -> Bool+ifaceMatches (M.ReceivedMethodCall _ _ msg) name =+	Just name == M.methodCallInterface msg+ifaceMatches (M.ReceivedSignal _ _ msg) name =+	name == M.signalInterface msg+ifaceMatches _ _ = False++<<DBus/MatchRule.hs>>=+memberMatches :: M.ReceivedMessage -> T.MemberName -> Bool+memberMatches (M.ReceivedMethodCall _ _ msg) name =+	name == M.methodCallMember msg+memberMatches (M.ReceivedSignal _ _ msg) name =+	name == M.signalMember msg+memberMatches _ _ = False++<<DBus/MatchRule.hs>>=+pathMatches :: M.ReceivedMessage -> T.ObjectPath -> Bool+pathMatches (M.ReceivedMethodCall _ _ msg) path =+	path == M.methodCallPath msg+pathMatches (M.ReceivedSignal _ _ msg) path =+	path == M.signalPath msg+pathMatches _ _ = False++<<DBus/MatchRule.hs>>=+destMatches :: M.ReceivedMessage -> T.BusName -> Bool+destMatches (M.ReceivedMethodCall _ _ msg) name =+	Just name == M.methodCallDestination msg+destMatches (M.ReceivedMethodReturn _ _ msg) name =+	Just name == M.methodReturnDestination msg+destMatches (M.ReceivedError _ _ msg) name =+	Just name == M.errorDestination msg+destMatches (M.ReceivedSignal _ _ msg) name =+	Just name == M.signalDestination msg+destMatches _ _ = False++<<DBus/MatchRule.hs>>=+parametersMatch :: M.ReceivedMessage -> [ParameterValue] -> Bool+parametersMatch _ [] = True+parametersMatch msg values = all validParam values where+	body = M.receivedBody msg+	validParam (StringValue idx x) = validParam' idx x+	validParam (PathValue   idx x) = validParam' idx x+	validParam' idx x = fromMaybe False $ do+		var <- maybeIndex body $ fromIntegral idx+		fmap (== x) $ T.fromVariant var++@+\section{Name reservation}++The central bus allows clients to register a well-known bus name, which+enables other clients to connect with or start a particular application.++<<DBus/NameReservation.hs>>=+<<copyright>>+{-# LANGUAGE OverloadedStrings #-}+module DBus.NameReservation+	( RequestNameFlag (..)+	, RequestNameReply (..)+	, ReleaseNameReply (..)+	, requestName+	, releaseName+	, mkRequestNameReply+	, mkReleaseNameReply+	) where+import Data.Word (Word32)+import Data.Bits ((.|.))+import qualified Data.Set as Set+import qualified DBus.Types as T+import qualified DBus.Message as M+import qualified DBus.Constants as C+import DBus.Util (maybeIndex)++<<DBus/NameReservation.hs>>=+data RequestNameFlag+	= AllowReplacement+	| ReplaceExisting+	| DoNotQueue+	deriving (Show)++<<DBus/NameReservation.hs>>=+encodeFlags :: [RequestNameFlag] -> Word32+encodeFlags = foldr (.|.) 0 . map flagValue where+	flagValue AllowReplacement = 0x1+	flagValue ReplaceExisting  = 0x2+	flagValue DoNotQueue       = 0x4++@ There are only two methods of interest here, {\tt RequestName} and+{\tt ReleaseName}.++<<DBus/NameReservation.hs>>=+requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall+requestName name flags = M.MethodCall+	{ M.methodCallPath = C.dbusPath+	, M.methodCallInterface = Just C.dbusInterface+	, M.methodCallDestination = Just C.dbusName+	, M.methodCallFlags = Set.empty+	, M.methodCallMember = T.mkMemberName' "RequestName"+	, M.methodCallBody =+		[ T.toVariant name+		, T.toVariant . encodeFlags $ flags]+	}++<<DBus/NameReservation.hs>>=+data RequestNameReply+	= PrimaryOwner+	| InQueue+	| Exists+	| AlreadyOwner+	deriving (Show)++<<DBus/NameReservation.hs>>=+mkRequestNameReply :: M.MethodReturn -> Maybe RequestNameReply+mkRequestNameReply msg =+	maybeIndex (M.messageBody msg) 0 >>=+	T.fromVariant >>=+	decodeRequestReply++<<DBus/NameReservation.hs>>=+decodeRequestReply :: Word32 -> Maybe RequestNameReply+decodeRequestReply 1 = Just PrimaryOwner+decodeRequestReply 2 = Just InQueue+decodeRequestReply 3 = Just Exists+decodeRequestReply 4 = Just AlreadyOwner+decodeRequestReply _ = Nothing++<<DBus/NameReservation.hs>>=+releaseName :: T.BusName -> M.MethodCall+releaseName name = M.MethodCall+	{ M.methodCallPath = C.dbusPath+	, M.methodCallInterface = Just C.dbusInterface+	, M.methodCallDestination = Just C.dbusName+	, M.methodCallFlags = Set.empty+	, M.methodCallMember = T.mkMemberName' "ReleaseName"+	, M.methodCallBody = [T.toVariant name]+	}++<<DBus/NameReservation.hs>>=+data ReleaseNameReply+	= Released+	| NonExistent+	| NotOwner+	deriving (Show)++<<DBus/NameReservation.hs>>=+mkReleaseNameReply :: M.MethodReturn -> Maybe ReleaseNameReply+mkReleaseNameReply msg =+	maybeIndex (M.messageBody msg) 0 >>=+	T.fromVariant >>=+	decodeReleaseReply++<<DBus/NameReservation.hs>>=+decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply+decodeReleaseReply 1 = Just Released+decodeReleaseReply 2 = Just NonExistent+decodeReleaseReply 3 = Just NotOwner+decodeReleaseReply _ = Nothing++@+\section{Constants}++<<DBus/Constants.hs>>=+<<copyright>>+{-# LANGUAGE OverloadedStrings #-}+module DBus.Constants where+import qualified DBus.Types as T+import Data.Word (Word8, Word32)++<<DBus/Constants.hs>>=+protocolVersion :: Word8+protocolVersion = 1++messageMaximumLength :: Word32+messageMaximumLength = 134217728++arrayMaximumLength :: Word32+arrayMaximumLength = 67108864++@ \subsection{The message bus}++<<DBus/Constants.hs>>=+dbusName :: T.BusName+dbusName = T.mkBusName' "org.freedesktop.DBus"++dbusPath :: T.ObjectPath+dbusPath = T.mkObjectPath' "/org/freedesktop/DBus"++dbusInterface :: T.InterfaceName+dbusInterface = T.mkInterfaceName' "org.freedesktop.DBus"++@ \subsection{Pre-defined interfaces}++<<DBus/Constants.hs>>=+interfaceIntrospectable :: T.InterfaceName+interfaceIntrospectable = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable"++interfaceProperties :: T.InterfaceName+interfaceProperties = T.mkInterfaceName' "org.freedesktop.DBus.Properties"++interfacePeer :: T.InterfaceName+interfacePeer = T.mkInterfaceName' "org.freedesktop.DBus.Peer"++@ \subsection{Pre-defined error names}++<<DBus/Constants.hs>>=+errorFailed :: T.ErrorName+errorFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Failed"++errorNoMemory :: T.ErrorName+errorNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.NoMemory"++errorServiceUnknown :: T.ErrorName+errorServiceUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.ServiceUnknown"++errorNameHasNoOwner :: T.ErrorName+errorNameHasNoOwner = T.mkErrorName' "org.freedesktop.DBus.Error.NameHasNoOwner"++errorNoReply :: T.ErrorName+errorNoReply = T.mkErrorName' "org.freedesktop.DBus.Error.NoReply"++errorIOError :: T.ErrorName+errorIOError = T.mkErrorName' "org.freedesktop.DBus.Error.IOError"++errorBadAddress :: T.ErrorName+errorBadAddress = T.mkErrorName' "org.freedesktop.DBus.Error.BadAddress"++errorNotSupported :: T.ErrorName+errorNotSupported = T.mkErrorName' "org.freedesktop.DBus.Error.NotSupported"++errorLimitsExceeded :: T.ErrorName+errorLimitsExceeded = T.mkErrorName' "org.freedesktop.DBus.Error.LimitsExceeded"++errorAccessDenied :: T.ErrorName+errorAccessDenied = T.mkErrorName' "org.freedesktop.DBus.Error.AccessDenied"++errorAuthFailed :: T.ErrorName+errorAuthFailed = T.mkErrorName' "org.freedesktop.DBus.Error.AuthFailed"++errorNoServer :: T.ErrorName+errorNoServer = T.mkErrorName' "org.freedesktop.DBus.Error.NoServer"++errorTimeout :: T.ErrorName+errorTimeout = T.mkErrorName' "org.freedesktop.DBus.Error.Timeout"++errorNoNetwork :: T.ErrorName+errorNoNetwork = T.mkErrorName' "org.freedesktop.DBus.Error.NoNetwork"++errorAddressInUse :: T.ErrorName+errorAddressInUse = T.mkErrorName' "org.freedesktop.DBus.Error.AddressInUse"++errorDisconnected :: T.ErrorName+errorDisconnected = T.mkErrorName' "org.freedesktop.DBus.Error.Disconnected"++errorInvalidArgs :: T.ErrorName+errorInvalidArgs = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidArgs"++errorFileNotFound :: T.ErrorName+errorFileNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.FileNotFound"++errorFileExists :: T.ErrorName+errorFileExists = T.mkErrorName' "org.freedesktop.DBus.Error.FileExists"++errorUnknownMethod :: T.ErrorName+errorUnknownMethod = T.mkErrorName' "org.freedesktop.DBus.Error.UnknownMethod"++errorTimedOut :: T.ErrorName+errorTimedOut = T.mkErrorName' "org.freedesktop.DBus.Error.TimedOut"++errorMatchRuleNotFound :: T.ErrorName+errorMatchRuleNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleNotFound"++errorMatchRuleInvalid :: T.ErrorName+errorMatchRuleInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleInvalid"++errorSpawnExecFailed :: T.ErrorName+errorSpawnExecFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ExecFailed"++errorSpawnForkFailed :: T.ErrorName+errorSpawnForkFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ForkFailed"++errorSpawnChildExited :: T.ErrorName+errorSpawnChildExited = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildExited"++errorSpawnChildSignaled :: T.ErrorName+errorSpawnChildSignaled = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildSignaled"++errorSpawnFailed :: T.ErrorName+errorSpawnFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.Failed"++errorSpawnFailedToSetup :: T.ErrorName+errorSpawnFailedToSetup = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FailedToSetup"++errorSpawnConfigInvalid :: T.ErrorName+errorSpawnConfigInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ConfigInvalid"++errorSpawnServiceNotValid :: T.ErrorName+errorSpawnServiceNotValid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotValid"++errorSpawnServiceNotFound :: T.ErrorName+errorSpawnServiceNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotFound"++errorSpawnPermissionsInvalid :: T.ErrorName+errorSpawnPermissionsInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid"++errorSpawnFileInvalid :: T.ErrorName+errorSpawnFileInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FileInvalid"++errorSpawnNoMemory :: T.ErrorName+errorSpawnNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.NoMemory"++errorUnixProcessIdUnknown :: T.ErrorName+errorUnixProcessIdUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.UnixProcessIdUnknown"++errorInvalidFileContent :: T.ErrorName+errorInvalidFileContent = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidFileContent"++errorSELinuxSecurityContextUnknown :: T.ErrorName+errorSELinuxSecurityContextUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown"++errorAdtAuditDataUnknown :: T.ErrorName+errorAdtAuditDataUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.AdtAuditDataUnknown"++errorObjectPathInUse :: T.ErrorName+errorObjectPathInUse = T.mkErrorName' "org.freedesktop.DBus.Error.ObjectPathInUse"++errorInconsistentMessage :: T.ErrorName+errorInconsistentMessage = T.mkErrorName' "org.freedesktop.DBus.Error.InconsistentMessage"++@+\section{Misc. utility functions}++<<DBus/Util.hs>>=+<<copyright>>+module DBus.Util where+import Text.Parsec (Parsec, parse)+import Data.Char (digitToInt)++checkLength :: Int -> String -> Maybe String+checkLength length' s | length s <= length' = Just s+checkLength _ _ = Nothing++parseMaybe :: Parsec String () a -> String -> Maybe a+parseMaybe p = either (const Nothing) Just . parse p ""++mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b+mkUnsafe label f x = case f x of+	Just x' -> x'+	Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x++hexToInt :: String -> Int+hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt++eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe (Left  _) = Nothing+eitherToMaybe (Right x) = Just x++fromRight :: Either a b -> b+fromRight (Right x) = x+fromRight _ = error "DBus.Util.fromRight: Left"++maybeIndex :: [a] -> Int -> Maybe a+maybeIndex (x:_ ) 0         = Just x+maybeIndex (_:xs) n | n > 0 = maybeIndex xs (n - 1)+maybeIndex _ _ = Nothing  @ \end{document}

@@ -80,4 +80,3 @@         encode c | elem c optionallyEncoded = TL.singleton c                  | otherwise       = TL.pack $ printf "%%%02X" (ord c) -

@@ -18,11 +18,11 @@ {-# LANGUAGE OverloadedStrings #-}  module DBus.Bus-        ( getSystemBus+        ( getBus+        , getFirstBus+        , getSystemBus         , getSessionBus         , getStarterBus-        , getFirstBus-        , getBus         ) where import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL@@ -41,20 +41,14 @@ import qualified DBus.Types as T import DBus.Util (fromRight) +busForConnection :: C.Connection -> IO (C.Connection, T.BusName)+busForConnection c = sendHello c >>= return . (,) c+ getBus :: A.Address -> IO (C.Connection, T.BusName)-getBus addr = do-        c <- C.connect addr-        name <- sendHello c-        return (c, name)+getBus = (busForConnection =<<) . C.connect  getFirstBus :: [A.Address] -> IO (C.Connection, T.BusName)-getFirstBus as = getFirstBus' as as--getFirstBus' :: [A.Address] -> [A.Address] -> IO (C.Connection, T.BusName)-getFirstBus' orig     [] = E.throwIO $ C.NoWorkingAddress orig-getFirstBus' orig (a:as) = E.catch (getBus a) onError where-        onError :: E.SomeException -> IO (C.Connection, T.BusName)-        onError _ = getFirstBus' orig as+getFirstBus = (busForConnection =<<) . C.connectFirst  getSystemBus :: IO (C.Connection, T.BusName) getSystemBus = getBus' $ fromEnv `E.catch` noEnv where@@ -102,7 +96,7 @@         received <- C.receive c         msg <- case received of                 Right x -> return x-                Left err -> E.throwIO $ E.AssertionFailed "Invalid response to Hello()"+                Left _  -> E.throwIO $ E.AssertionFailed "Invalid response to Hello()"         case msg of                 (M.ReceivedMethodReturn _ _ reply) ->                         if M.methodReturnSerial reply == serial

@@ -26,6 +26,7 @@           , W.UnmarshalError (..)            , connect+          , connectFirst            , send @@ -45,6 +46,13 @@ import qualified Network as N import qualified Data.Map as Map +import qualified Network.Socket as NS++import qualified Text.Parsec as P+import Control.Monad (unless)+import Data.Binary.Get (runGet, getWord16host)+import Data.Binary.Put (runPut, putWord16be)+ import qualified System.IO as I  import qualified Control.Exception as E@@ -61,10 +69,10 @@ import qualified DBus.Wire as W  -data Connection = Connection A.Address Transport (C.MVar M.Serial)+data Connection = Connection A.Address Transport (C.MVar M.Serial) (C.MVar ())  instance Show Connection where-        showsPrec d (Connection a _ _) = showParen (d > 10) $+        showsPrec d (Connection a _ _ _) = showParen (d > 10) $                 showString' ["<connection ", show $ A.strAddress a, ">"] where                 showString' = foldr (.) id . map showString @@ -76,16 +84,17 @@ connectTransport :: A.Address -> IO Transport connectTransport a = transport' (A.addressMethod a) a where         transport' "unix" = unix-        transport' _      = unknownTransport+        transport' "tcp"  = tcp+        transport' _      = E.throwIO . UnknownMethod  unix :: A.Address -> IO Transport-unix a = handleTransport . N.connectTo "localhost" =<< port where+unix a = port >>= N.connectTo "localhost" >>= handleTransport where         params = A.addressParameters a         path = Map.lookup "path" params         abstract = Map.lookup "abstract" params                  tooMany = "Only one of `path' or `abstract' may be specified for the\-                  \ `unix' method."+                  \ `unix' transport."         tooFew = "One of `path' or `abstract' must be specified for the\                  \ `unix' transport."         @@ -96,16 +105,70 @@                 (Just x, Nothing) -> return $ TL.unpack x                 (Nothing, Just x) -> return $ '\x00' : TL.unpack x -handleTransport :: IO I.Handle -> IO Transport-handleTransport io = do-        h <- io+tcp :: A.Address -> IO Transport+tcp a = openHandle >>= handleTransport where+        params = A.addressParameters a+        openHandle = do+                port <- getPort+                family <- getFamily+                addresses <- getAddresses family+                socket <- openSocket port addresses+                NS.socketToHandle socket I.ReadWriteMode++        hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params++        unknownFamily x = TL.concat ["Unknown socket family for TCP transport: ", x]+        getFamily = case Map.lookup "family" params of+                Just "ipv4" -> return NS.AF_INET+                Just "ipv6" -> return NS.AF_INET6+                Nothing     -> return NS.AF_UNSPEC+                Just x      -> E.throwIO $ BadParameters a $ unknownFamily x++        missingPort = "TCP transport requires the ``port'' parameter."+        badPort x = TL.concat ["Invalid socket port for TCP transport: ", x]+        getPort = case Map.lookup "port" params of+                Nothing -> E.throwIO $ BadParameters a missingPort+                Just x -> case P.parse parseWord16 "" (TL.unpack x) of+                        Right x' -> return $ NS.PortNum x'+                        Left  _  -> E.throwIO $ BadParameters a $ badPort x++        parseWord16 = do+                chars <- P.many1 P.digit+                P.eof+                let value = read chars :: Integer+                unless (value > 0 && value <= 65535) $+                        P.parserFail "bad port" >> return ()+                let word = fromIntegral value+                return $ runGet getWord16host (runPut (putWord16be word))++        getAddresses family = do+                let hints = NS.defaultHints+                        { NS.addrFlags = [NS.AI_ADDRCONFIG]+                        , NS.addrFamily = family+                        , NS.addrSocketType = NS.Stream+                        }+                NS.getAddrInfo (Just hints) (Just hostname) Nothing++        setPort port (NS.SockAddrInet  _ x)     = NS.SockAddrInet port x+        setPort port (NS.SockAddrInet6 _ x y z) = NS.SockAddrInet6 port x y z+        setPort _    addr                       = addr++        openSocket _ [] = E.throwIO $ NoWorkingAddress [a]+        openSocket port (addr:addrs) = E.catch (openSocket' port addr) $+                \(E.SomeException _) -> openSocket port addrs+        openSocket' port addr = do+                sock <- NS.socket (NS.addrFamily addr)+                                  (NS.addrSocketType addr)+                                  (NS.addrProtocol addr)+                NS.connect sock . setPort port . NS.addrAddress $ addr+                return sock++handleTransport :: I.Handle -> IO Transport+handleTransport h = do         I.hSetBuffering h I.NoBuffering         I.hSetBinaryMode h True         return $ Transport (L.hPut h) (L.hGet h . fromIntegral) -unknownTransport :: A.Address -> IO Transport-unknownTransport = E.throwIO . UnknownMethod- data ConnectionError         = InvalidAddress Text         | BadParameters A.Address Text@@ -121,9 +184,16 @@         let putS = transportSend t . encodeUtf8 . TL.pack         let getS = fmap (TL.unpack . decodeUtf8) . transportRecv t         authenticate putS getS+        readLock <- C.newMVar ()         serialMVar <- C.newMVar M.firstSerial-        return $ Connection a t serialMVar+        return $ Connection a t serialMVar readLock +connectFirst :: [A.Address] -> IO Connection+connectFirst orig = connectFirst' orig where+        connectFirst'     [] = E.throwIO $ NoWorkingAddress orig+        connectFirst' (a:as) = E.catch (connect a) $+                \(E.SomeException _) -> connectFirst' as+ authenticate :: (String -> IO ()) -> (Word32 -> IO String)                 -> IO () authenticate put get = do@@ -151,7 +221,7 @@  send :: M.Message a => Connection -> (M.Serial -> IO b) -> a      -> IO (Either W.MarshalError b)-send (Connection _ t mvar) io msg = withSerial mvar $ \serial ->+send (Connection _ t mvar _) io msg = withSerial mvar $ \serial ->         case W.marshalMessage W.LittleEndian serial msg of                 Right bytes -> do                         x <- io serial@@ -168,5 +238,6 @@         return x  receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage)-receive (Connection _ t _) = W.unmarshalMessage $ transportRecv t+receive (Connection _ t _ lock) = C.withMVar lock $ \_ ->+        W.unmarshalMessage $ transportRecv t 

@@ -170,7 +170,7 @@         [arg | direction `elem` dirs]  children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b]-children f filt (H.Elem _ _ contents) = do+children f filt (H.Elem _ _ contents) =         mapM f [x | (H.CElem x _) <- concatMap filt contents]  dtdPublicID, dtdSystemID :: String@@ -190,7 +190,7 @@ xmlRoot :: Object -> Maybe (H.Element a) xmlRoot obj@(Object path _ _) = do         (H.CElem root _) <- xmlObject' (T.strObjectPath path) obj-        return $ root+        return root  xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a) xmlObject parentPath obj@(Object path _ _) = do@@ -251,9 +251,9 @@         ] []  xmlAccess :: [PropertyAccess] -> String-xmlAccess access = read ++ write where-        read = if elem Read access then "read" else ""-        write = if elem Write access then "write" else ""+xmlAccess access = readS ++ writeS where+        readS = if elem Read access then "read" else ""+        writeS = if elem Write access then "write" else ""  mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined

@@ -0,0 +1,175 @@+{-+  Copyright (C) 2009 John Millikin <jmillikin@gmail.com>+  +  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 <http://www.gnu.org/licenses/>.+-}++{-# LANGUAGE OverloadedStrings #-}++module DBus.MatchRule (+          MatchRule (..)+        , MessageType (..)+        , ParameterValue (..)+        , formatRule+        , addMatch+        , matchAll+        , matches+        ) where+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL++import Data.Word (Word8)+import Data.Maybe (catMaybes, fromMaybe)+import qualified Data.Set as Set+import qualified DBus.Types as T+import qualified DBus.Message as M+import qualified DBus.Constants as C+import DBus.Util (maybeIndex)++data MatchRule = MatchRule+        { matchType        :: Maybe MessageType+        , matchSender      :: Maybe T.BusName+        , matchInterface   :: Maybe T.InterfaceName+        , matchMember      :: Maybe T.MemberName+        , matchPath        :: Maybe T.ObjectPath+        , matchDestination :: Maybe T.BusName+        , matchParameters  :: [ParameterValue]+        }++data ParameterValue+        = StringValue Word8 Text+        | PathValue Word8 T.ObjectPath+        deriving (Show, Eq)++data MessageType+        = MethodCall+        | MethodReturn+        | Signal+        | Error+        deriving (Show, Eq)++formatRule :: MatchRule -> Text+formatRule rule = TL.intercalate "," filters where+        filters = structureFilters ++ parameterFilters+        parameterFilters = map formatParameter $ matchParameters rule+        structureFilters = catMaybes $ map unpack+                [ ("type", fmap formatType . matchType)+                , ("sender", fmap T.strBusName . matchSender)+                , ("interface", fmap T.strInterfaceName . matchInterface)+                , ("member", fmap T.strMemberName . matchMember)+                , ("path", fmap T.strObjectPath . matchPath)+                , ("destination", fmap T.strBusName . matchDestination)+                ]+        unpack (key, mkValue) = formatFilter' key `fmap` mkValue rule++formatParameter :: ParameterValue -> Text+formatParameter (StringValue index x) = formatFilter' key x where+        key = "arg" `TL.append` TL.pack (show index)+formatParameter (PathValue index x) = formatFilter' key value where+        key = "arg" `TL.append` TL.pack (show index) `TL.append` "path"+        value = T.strObjectPath x++formatFilter' :: Text -> Text -> Text+formatFilter' key value = TL.concat [key, "='", value, "'"]++formatType :: MessageType -> Text+formatType MethodCall   = "method_call"+formatType MethodReturn = "method_return"+formatType Signal       = "signal"+formatType Error        = "error"++addMatch :: MatchRule -> M.MethodCall+addMatch rule = M.MethodCall+        C.dbusPath+        (T.mkMemberName' "AddMatch")+        (Just C.dbusInterface)+        (Just C.dbusName)+        Set.empty+        [T.toVariant $ formatRule rule]++matchAll :: MatchRule+matchAll = MatchRule+        { matchType        = Nothing+        , matchSender      = Nothing+        , matchInterface   = Nothing+        , matchMember      = Nothing+        , matchPath        = Nothing+        , matchDestination = Nothing+        , matchParameters  = []+        }++matches :: MatchRule -> M.ReceivedMessage -> Bool+matches rule msg = and . catMaybes . map ($ rule) $+        [ fmap      (typeMatches msg) . matchType+        , fmap    (senderMatches msg) . matchSender+        , fmap     (ifaceMatches msg) . matchInterface+        , fmap    (memberMatches msg) . matchMember+        , fmap      (pathMatches msg) . matchPath+        , fmap      (destMatches msg) . matchDestination+        , Just . parametersMatch msg  . matchParameters+        ]++typeMatches :: M.ReceivedMessage -> MessageType -> Bool+typeMatches (M.ReceivedMethodCall   _ _ _) MethodCall   = True+typeMatches (M.ReceivedMethodReturn _ _ _) MethodReturn = True+typeMatches (M.ReceivedSignal       _ _ _) Signal       = True+typeMatches (M.ReceivedError        _ _ _) Error        = True+typeMatches _ _ = False+++senderMatches :: M.ReceivedMessage -> T.BusName -> Bool+senderMatches msg name = M.receivedSender msg == Just name++ifaceMatches :: M.ReceivedMessage -> T.InterfaceName -> Bool+ifaceMatches (M.ReceivedMethodCall _ _ msg) name =+        Just name == M.methodCallInterface msg+ifaceMatches (M.ReceivedSignal _ _ msg) name =+        name == M.signalInterface msg+ifaceMatches _ _ = False++memberMatches :: M.ReceivedMessage -> T.MemberName -> Bool+memberMatches (M.ReceivedMethodCall _ _ msg) name =+        name == M.methodCallMember msg+memberMatches (M.ReceivedSignal _ _ msg) name =+        name == M.signalMember msg+memberMatches _ _ = False++pathMatches :: M.ReceivedMessage -> T.ObjectPath -> Bool+pathMatches (M.ReceivedMethodCall _ _ msg) path =+        path == M.methodCallPath msg+pathMatches (M.ReceivedSignal _ _ msg) path =+        path == M.signalPath msg+pathMatches _ _ = False++destMatches :: M.ReceivedMessage -> T.BusName -> Bool+destMatches (M.ReceivedMethodCall _ _ msg) name =+        Just name == M.methodCallDestination msg+destMatches (M.ReceivedMethodReturn _ _ msg) name =+        Just name == M.methodReturnDestination msg+destMatches (M.ReceivedError _ _ msg) name =+        Just name == M.errorDestination msg+destMatches (M.ReceivedSignal _ _ msg) name =+        Just name == M.signalDestination msg+destMatches _ _ = False++parametersMatch :: M.ReceivedMessage -> [ParameterValue] -> Bool+parametersMatch _ [] = True+parametersMatch msg values = all validParam values where+        body = M.receivedBody msg+        validParam (StringValue idx x) = validParam' idx x+        validParam (PathValue   idx x) = validParam' idx x+        validParam' idx x = fromMaybe False $ do+                var <- maybeIndex body $ fromIntegral idx+                fmap (== x) $ T.fromVariant var+

@@ -30,6 +30,7 @@          , MethodReturn (..)           , Error (..)+         , errorMessage           , Signal (..) @@ -38,6 +39,7 @@          , ReceivedMessage (..)          , receivedSerial          , receivedSender+         , receivedBody          ) where import DBus.Message.Internal

@@ -15,10 +15,17 @@   along with this program.  If not, see <http://www.gnu.org/licenses/>. -} +{-# LANGUAGE OverloadedStrings #-}+ module DBus.Message.Internal where+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL+ import qualified Data.Set as S import Data.Word (Word8, Word32)+import Data.Maybe (fromMaybe) import qualified DBus.Types as T+import DBus.Util (maybeIndex)  class Message a where         messageTypeCode     :: a -> Word8@@ -86,14 +93,13 @@ data MethodReturn = MethodReturn         { methodReturnSerial      :: Serial         , methodReturnDestination :: Maybe T.BusName-        , methodReturnFlags       :: S.Set Flag         , methodReturnBody        :: [T.Variant]         }         deriving (Show, Eq)  instance Message MethodReturn where         messageTypeCode _ = 2-        messageFlags      = methodReturnFlags+        messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]         messageBody       = methodReturnBody         messageHeaderFields m = concat                 [ [ ReplySerial $ methodReturnSerial m@@ -105,14 +111,13 @@         { errorName        :: T.ErrorName         , errorSerial      :: Serial         , errorDestination :: Maybe T.BusName-        , errorFlags       :: S.Set Flag         , errorBody        :: [T.Variant]         }         deriving (Show, Eq)  instance Message Error where         messageTypeCode _ = 3-        messageFlags      = errorFlags+        messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]         messageBody       = errorBody         messageHeaderFields m = concat                 [ [ ErrorName   $ errorName m@@ -121,19 +126,26 @@                 , maybe' Destination . errorDestination $ m                 ] +errorMessage :: Error -> Text+errorMessage msg = fromMaybe "(no error message)" $ do+        field <- maybeIndex (errorBody msg) 0+        text <- T.fromVariant field+        if TL.null text+                then Nothing+                else return text+ data Signal = Signal         { signalPath        :: T.ObjectPath         , signalMember      :: T.MemberName         , signalInterface   :: T.InterfaceName         , signalDestination :: Maybe T.BusName-        , signalFlags       :: S.Set Flag         , signalBody        :: [T.Variant]         }         deriving (Show, Eq)  instance Message Signal where         messageTypeCode _ = 4-        messageFlags      = signalFlags+        messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]         messageBody       = signalBody         messageHeaderFields m = concat                 [ [ Path      $ signalPath m@@ -171,4 +183,11 @@ receivedSender (ReceivedError        _ s _) = s receivedSender (ReceivedSignal       _ s _) = s receivedSender (ReceivedUnknown      _ s _) = s++receivedBody :: ReceivedMessage -> [T.Variant]+receivedBody (ReceivedMethodCall   _ _ x) = messageBody x+receivedBody (ReceivedMethodReturn _ _ x) = messageBody x+receivedBody (ReceivedError        _ _ x) = messageBody x+receivedBody (ReceivedSignal       _ _ x) = messageBody x+receivedBody _ = [] 

@@ -0,0 +1,107 @@+{-+  Copyright (C) 2009 John Millikin <jmillikin@gmail.com>+  +  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 <http://www.gnu.org/licenses/>.+-}++{-# LANGUAGE OverloadedStrings #-}+module DBus.NameReservation+        ( RequestNameFlag (..)+        , RequestNameReply (..)+        , ReleaseNameReply (..)+        , requestName+        , releaseName+        , mkRequestNameReply+        , mkReleaseNameReply+        ) where+import Data.Word (Word32)+import Data.Bits ((.|.))+import qualified Data.Set as Set+import qualified DBus.Types as T+import qualified DBus.Message as M+import qualified DBus.Constants as C+import DBus.Util (maybeIndex)++data RequestNameFlag+        = AllowReplacement+        | ReplaceExisting+        | DoNotQueue+        deriving (Show)++encodeFlags :: [RequestNameFlag] -> Word32+encodeFlags = foldr (.|.) 0 . map flagValue where+        flagValue AllowReplacement = 0x1+        flagValue ReplaceExisting  = 0x2+        flagValue DoNotQueue       = 0x4++requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall+requestName name flags = M.MethodCall+        { M.methodCallPath = C.dbusPath+        , M.methodCallInterface = Just C.dbusInterface+        , M.methodCallDestination = Just C.dbusName+        , M.methodCallFlags = Set.empty+        , M.methodCallMember = T.mkMemberName' "RequestName"+        , M.methodCallBody =+                [ T.toVariant name+                , T.toVariant . encodeFlags $ flags]+        }++data RequestNameReply+        = PrimaryOwner+        | InQueue+        | Exists+        | AlreadyOwner+        deriving (Show)++mkRequestNameReply :: M.MethodReturn -> Maybe RequestNameReply+mkRequestNameReply msg =+        maybeIndex (M.messageBody msg) 0 >>=+        T.fromVariant >>=+        decodeRequestReply++decodeRequestReply :: Word32 -> Maybe RequestNameReply+decodeRequestReply 1 = Just PrimaryOwner+decodeRequestReply 2 = Just InQueue+decodeRequestReply 3 = Just Exists+decodeRequestReply 4 = Just AlreadyOwner+decodeRequestReply _ = Nothing++releaseName :: T.BusName -> M.MethodCall+releaseName name = M.MethodCall+        { M.methodCallPath = C.dbusPath+        , M.methodCallInterface = Just C.dbusInterface+        , M.methodCallDestination = Just C.dbusName+        , M.methodCallFlags = Set.empty+        , M.methodCallMember = T.mkMemberName' "ReleaseName"+        , M.methodCallBody = [T.toVariant name]+        }++data ReleaseNameReply+        = Released+        | NonExistent+        | NotOwner+        deriving (Show)++mkReleaseNameReply :: M.MethodReturn -> Maybe ReleaseNameReply+mkReleaseNameReply msg =+        maybeIndex (M.messageBody msg) 0 >>=+        T.fromVariant >>=+        decodeReleaseReply++decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply+decodeReleaseReply 1 = Just Released+decodeReleaseReply 2 = Just NonExistent+decodeReleaseReply 3 = Just NotOwner+decodeReleaseReply _ = Nothing+

@@ -55,6 +55,9 @@                    , fromArray                    , arrayFromItems +                   , arrayToBytes+                   , arrayFromBytes+                      -- * Dictionaries                    , Dictionary                    , dictionaryItems@@ -113,6 +116,11 @@  import DBus.Util (mkUnsafe) +import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as ByteString++import qualified Data.ByteString as StrictByteString+ import Data.List (intercalate)  import Control.Monad (unless)@@ -311,28 +319,39 @@ mkObjectPath' = mkUnsafe "object path" mkObjectPath  instance Variable Array where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };-data Array = Array-        { arrayType  :: Type-        , arrayItems :: [Variant]-        }+data Array+        = VariantArray Type [Variant]+        | ByteArray ByteString         deriving (Eq, Typeable)  instance Builtin Array where         builtinDBusType = DBusArray . arrayType +arrayType :: Array -> Type+arrayType (VariantArray t _) = t+arrayType (ByteArray _) = DBusByte++arrayItems :: Array -> [Variant]+arrayItems (VariantArray _ xs) = xs+arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs+ instance Show Array where-        showsPrec d (Array t vs) = showParen (d > 10) $+        showsPrec d array = showParen (d > 10) $                 s "Array " . showSig . s " [" . s valueString . s "]" where                         s = showString-                        showSig = shows $ typeCode t-                        vs' = [show x | (Variant x) <- vs]-                        valueString = intercalate ", " vs'+                        showSig = shows . typeCode . arrayType $ array+                        vs = [show x | (Variant x) <- arrayItems array]+                        valueString = intercalate ", " vs  arrayFromItems :: Type -> [Variant] -> Maybe Array+arrayFromItems DBusByte vs = do+        bytes <- mapM fromVariant vs+        Just . ByteArray . ByteString.pack $ bytes+ arrayFromItems t vs = do         mkSignature (typeCode t)         if all (\x -> variantType x == t) vs-                then Just $ Array t vs+                then Just $ VariantArray t vs                 else Nothing  toArray :: Variable a => Type -> [a] -> Maybe Array@@ -341,6 +360,23 @@ fromArray :: Variable a => Array -> Maybe [a] fromArray = mapM fromVariant . arrayItems +arrayToBytes :: Array -> Maybe ByteString+arrayToBytes (ByteArray x) = Just x+arrayToBytes _             = Nothing++arrayFromBytes :: ByteString -> Array+arrayFromBytes = ByteArray++instance Variable ByteString where+        toVariant = toVariant . arrayFromBytes+        fromVariant x = fromVariant x >>= arrayToBytes++instance Variable StrictByteString.ByteString where+        toVariant x = toVariant . arrayFromBytes $ ByteString.fromChunks [x]+        fromVariant x = do+                chunks <- ByteString.toChunks `fmap` fromVariant x+                return $ StrictByteString.concat chunks+ instance Variable Dictionary where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x }; data Dictionary = Dictionary         { dictionaryKeyType   :: Type@@ -394,16 +430,16 @@         structs = [Structure [k, v] | (k, v) <- items]  arrayToDictionary :: Array -> Maybe Dictionary-arrayToDictionary (Array t items) = do+arrayToDictionary array = do         let toPair x = do                 struct <- fromVariant x                 case struct of                         Structure [k, v] -> Just (k, v)                         _                -> Nothing-        (kt, vt) <- case t of+        (kt, vt) <- case arrayType array of                 DBusStructure [kt, vt] -> Just (kt, vt)                 _                      -> Nothing-        pairs <- mapM toPair items+        pairs <- mapM toPair $ arrayItems array         dictionaryFromItems kt vt pairs  instance Variable Structure where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };

@@ -42,3 +42,8 @@ fromRight (Right x) = x fromRight _ = error "DBus.Util.fromRight: Left" +maybeIndex :: [a] -> Int -> Maybe a+maybeIndex (x:_ ) 0         = Just x+maybeIndex (_:xs) n | n > 0 = maybeIndex xs (n - 1)+maybeIndex _ _ = Nothing+

@@ -18,8 +18,8 @@ {-# LANGUAGE OverloadedStrings #-}  {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} module DBus.Wire (  Endianness (..)                    , alignment@@ -47,11 +47,11 @@ import qualified Control.Monad.State as ST import qualified Control.Monad.Error as E import qualified Data.ByteString.Lazy as L--import qualified Data.Binary.Put as P+import qualified Data.Binary.Builder as B  import qualified Data.Binary.Get as G +import Data.Binary.Put (runPut) import qualified Data.Binary.IEEE754 as IEEE  import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)@@ -67,7 +67,6 @@ import Data.Maybe (fromJust, listToMaybe, fromMaybe) import Data.Word (Word8, Word32, Word64) import Data.Int (Int16, Int32, Int64)-import Data.Typeable (Typeable)  import qualified DBus.Types as T @@ -117,16 +116,16 @@                 then count' - missing                 else 0 -data MarshalState = MarshalState Endianness L.ByteString+data MarshalState = MarshalState Endianness B.Builder !Word64 newtype MarshalM a = MarshalM (E.ErrorT MarshalError (ST.State MarshalState) a)         deriving (Monad, E.MonadError MarshalError, ST.MonadState MarshalState) type Marshal = MarshalM ()  runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString runMarshal (MarshalM m) e = case ST.runState (E.runErrorT m) initialState of-        (Right _, MarshalState _ bytes) -> Right bytes+        (Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder)         (Left  x, _) -> Left x-        where initialState = MarshalState e L.empty+        where initialState = MarshalState e B.empty 0  marshal :: T.Variant -> Marshal marshal v = marshalType (T.variantType v) where@@ -134,14 +133,21 @@         x = fromJust . T.fromVariant $ v         marshalType :: T.Type -> Marshal         marshalType T.DBusByte   = append $ L.singleton x-        marshalType T.DBusWord16 = marshalPut P.putWord16be x-        marshalType T.DBusWord32 = marshalPut P.putWord32be x-        marshalType T.DBusWord64 = marshalPut P.putWord64be x-        marshalType T.DBusInt16  = marshalPut P.putWord16be $ fromIntegral (x :: Int16)-        marshalType T.DBusInt32  = marshalPut P.putWord32be $ fromIntegral (x :: Int32)-        marshalType T.DBusInt64  = marshalPut P.putWord64be $ fromIntegral (x :: Int64)+        marshalType T.DBusWord16 = marshalBuilder 2 B.putWord16be B.putWord16le x+        marshalType T.DBusWord32 = marshalBuilder 4 B.putWord32be B.putWord32le x+        marshalType T.DBusWord64 = marshalBuilder 8 B.putWord64be B.putWord64le x+        marshalType T.DBusInt16  = marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral (x :: Int16)+        marshalType T.DBusInt32  = marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral (x :: Int32)+        marshalType T.DBusInt64  = marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral (x :: Int64) -        marshalType T.DBusDouble = marshalPut IEEE.putFloat64be x+        marshalType T.DBusDouble = do+                pad 8+                (MarshalState e _ _) <- ST.get+                let put = case e of+                        BigEndian -> IEEE.putFloat64be+                        LittleEndian -> IEEE.putFloat64le+                let bytes = runPut $ put x+                append bytes          marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0 @@ -169,31 +175,35 @@   append :: L.ByteString -> Marshal-append bs = do-        (MarshalState e bs') <- ST.get-        ST.put $ MarshalState e (L.append bs' bs)+append bytes = do+        (MarshalState e builder count) <- ST.get+        let builder' = B.append builder $ B.fromLazyByteString bytes+            count' = count + (fromIntegral $ L.length bytes)+        ST.put $ MarshalState e builder' count'  pad :: Word8 -> Marshal pad count = do-        (MarshalState _ bytes) <- ST.get-        let padding' = padding (fromIntegral . L.length $ bytes) count-        append $ L.replicate (fromIntegral padding') 0+        (MarshalState _ _ existing) <- ST.get+        let padding' = fromIntegral $ padding existing count+        append $ L.replicate padding' 0 -marshalPut :: (a -> P.Put) -> a -> Marshal-marshalPut put x = do-        let bytes = P.runPut $ put x-        (MarshalState e _) <- ST.get-        pad . fromIntegral . L.length $ bytes-        append $ case e of-                BigEndian -> bytes-                LittleEndian -> L.reverse bytes+marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal+marshalBuilder size be le x = do+        pad size+        (MarshalState e builder count) <- ST.get+        let builder' = B.append builder $ case e of+                BigEndian -> be x+                LittleEndian -> le x+        let count' = count + (fromIntegral size)+        ST.put $ MarshalState e builder' count'  data MarshalError         = MessageTooLong Word64         | ArrayTooLong Word64         | InvalidBodySignature Text         | InvalidVariantSignature Text-        deriving (Eq, Typeable)+        | TextContainsNUL Text+        deriving (Eq)  instance Show MarshalError where         show (MessageTooLong x) = concat@@ -204,10 +214,12 @@                 ["Invalid body signature: ", show x]         show (InvalidVariantSignature x) = concat                 ["Invalid variant signature: ", show x]+        show (TextContainsNUL x) = concat+                ["Text contains NUL: ", show x]  instance E.Error MarshalError -data UnmarshalState = UnmarshalState Endianness L.ByteString Word64+data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64 newtype Unmarshal a = Unmarshal (E.ErrorT UnmarshalError (ST.State UnmarshalState) a)         deriving (Monad, Functor, E.MonadError UnmarshalError, ST.MonadState UnmarshalState) @@ -251,7 +263,7 @@  unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature -unmarshalType (T.DBusArray t) = fmap T.toVariant $ unmarshalArray t+unmarshalType (T.DBusArray t) = T.toVariant `fmap` unmarshalArray t  unmarshalType (T.DBusDictionary kt vt) = do         let pairType = T.DBusStructure [kt, vt]@@ -268,18 +280,17 @@                 _   -> Nothing                  t <- fromMaybeU "variant signature" getType =<< unmarshalSignature-        fmap T.toVariant $ unmarshalType t+        T.toVariant `fmap` unmarshalType t   consume :: Word64 -> Unmarshal L.ByteString consume count = do         (UnmarshalState e bytes offset) <- ST.get-        let bytes' = L.drop (fromIntegral offset) bytes-        let x = L.take (fromIntegral count) bytes'+        let (x, bytes') = L.splitAt (fromIntegral count) bytes         unless (L.length x == fromIntegral count) $                 E.throwError $ UnexpectedEOF offset         -        ST.put $ UnmarshalState e bytes (offset + count)+        ST.put $ UnmarshalState e bytes' (offset + count)         return x  skipPadding :: Word8 -> Unmarshal ()@@ -319,7 +330,7 @@  unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a               -> Unmarshal T.Variant-unmarshalGet' count be le = fmap T.toVariant $ unmarshalGet count be le+unmarshalGet' count be le = T.toVariant `fmap` unmarshalGet count be le  untilM :: Monad m => m Bool -> m a -> m [a] untilM test comp = do@@ -340,7 +351,7 @@         | InvalidPadding Word64         | MissingTerminator Word64         | ArraySizeMismatch-        deriving (Eq, Typeable)+        deriving (Eq)  instance Show UnmarshalError where         show (UnsupportedProtocolVersion x) = concat@@ -362,7 +373,7 @@ instance E.Error UnmarshalError  marshalWord32 :: Word32 -> Marshal-marshalWord32 = marshalPut P.putWord32be+marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le  unmarshalWord32 :: Unmarshal Word32 unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le@@ -370,6 +381,8 @@ marshalText :: Text -> Marshal marshalText x = do         let bytes = encodeUtf8 x+        when (L.any (== 0) bytes) $+                E.throwError $ TextContainsNUL x         marshalWord32 . fromIntegral . L.length $ bytes         append bytes         append (L.singleton 0)@@ -391,37 +404,45 @@  unmarshalSignature :: Unmarshal T.Signature unmarshalSignature = do-        byteCount <- fmap L.head $ consume 1+        byteCount <- L.head `fmap` consume 1         sigText <- fmap decodeUtf8 $ consume . fromIntegral $ byteCount         skipTerminator         fromMaybeU "signature" T.mkSignature sigText  marshalArray :: T.Array -> Marshal marshalArray x = do-        (arrayPadding, arrayBytes) <- getArrayBytes x+        (arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x         let arrayLen = L.length arrayBytes         when (arrayLen > fromIntegral C.arrayMaximumLength)                 (E.throwError $ ArrayTooLong $ fromIntegral arrayLen)         marshalWord32 $ fromIntegral arrayLen-        append arrayPadding+        append $ L.replicate arrayPadding 0         append arrayBytes -getArrayBytes :: T.Array -> MarshalM (L.ByteString, L.ByteString)-getArrayBytes x = do+getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString)+getArrayBytes T.DBusByte x = return (0, bytes) where+        Just bytes = T.arrayToBytes x++getArrayBytes itemType x = do         let vs = T.arrayItems x-        let itemType = T.arrayType x         s <- ST.get-        (MarshalState _ afterLength) <- marshalWord32 0 >> ST.get-        (MarshalState _ afterPadding) <- pad (alignment itemType) >> ST.get-        (MarshalState _ afterItems) <- mapM_ marshal vs >> ST.get+        (MarshalState _ _ afterLength) <- marshalWord32 0 >> ST.get+        (MarshalState e _ afterPadding) <- pad (alignment itemType) >> ST.get         -        let paddingBytes = L.drop (L.length afterLength) afterPadding-        let itemBytes = L.drop (L.length afterPadding) afterItems+        ST.put $ MarshalState e B.empty afterPadding+        (MarshalState _ itemBuilder _) <- mapM_ marshal vs >> ST.get         +        let itemBytes = B.toLazyByteString itemBuilder+            paddingSize = fromIntegral $ afterPadding - afterLength+                 ST.put s-        return (paddingBytes, itemBytes)+        return (paddingSize, itemBytes)  unmarshalArray :: T.Type -> Unmarshal T.Array+unmarshalArray T.DBusByte = do+        byteCount <- unmarshalWord32+        T.arrayFromBytes `fmap` consume (fromIntegral byteCount)+ unmarshalArray itemType = do         let getOffset = do                 (UnmarshalState _ _ o) <- ST.get@@ -497,9 +518,10 @@                 sig <- checkBodySig body                 empty <- ST.get                 mapM_ marshal body-                (MarshalState _ bodyBytes) <- ST.get+                (MarshalState _ bodyBytesB _) <- ST.get                 ST.put empty                 marshalEndianness e+                let bodyBytes = B.toLazyByteString bodyBytesB                 marshalHeader msg serial sig                         $ fromIntegral . L.length $ bodyBytes                 pad 8@@ -532,8 +554,7 @@  checkMaximumSize :: Marshal checkMaximumSize = do-        (MarshalState _ messageBytes) <- ST.get-        let messageLength = L.length messageBytes+        (MarshalState _ _ messageLength) <- ST.get         when (messageLength > fromIntegral C.messageMaximumLength)                 (E.throwError $ MessageTooLong $ fromIntegral messageLength) @@ -572,7 +593,7 @@          let fieldArray = fromJust . T.fromVariant $ header !! 6         let fieldStructures = fromJust . T.fromArray $ fieldArray-        fields <- fmap concat $ mapM decodeField fieldStructures+        fields <- concat `fmap` mapM decodeField fieldStructures          let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8         getBytes . fromIntegral $ bodyPadding@@ -610,29 +631,29 @@  buildReceivedMessage 2 fields = do         replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]-        return $ \serial flags body -> let+        return $ \serial _ body -> let                 dest = listToMaybe [x | M.Destination x <- fields]                 sender = listToMaybe [x | M.Sender x <- fields]-                msg = M.MethodReturn replySerial dest flags body+                msg = M.MethodReturn replySerial dest body                 in M.ReceivedMethodReturn serial sender msg  buildReceivedMessage 3 fields = do         name <- require "error name" [x | M.ErrorName x <- fields]         replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]-        return $ \serial flags body -> let+        return $ \serial _ body -> let                 dest = listToMaybe [x | M.Destination x <- fields]                 sender = listToMaybe [x | M.Sender x <- fields]-                msg = M.Error name replySerial dest flags body+                msg = M.Error name replySerial dest body                 in M.ReceivedError serial sender msg  buildReceivedMessage 4 fields = do         path <- require "path" [x | M.Path x <- fields]         member <- require "member name" [x | M.Member x <- fields]         iface <- require "interface" [x | M.Interface x <- fields]-        return $ \serial flags body -> let+        return $ \serial _ body -> let                 dest = listToMaybe [x | M.Destination x <- fields]                 sender = listToMaybe [x | M.Sender x <- fields]-                msg = M.Signal path member iface dest flags body+                msg = M.Signal path member iface dest body                 in M.ReceivedSignal serial sender msg  buildReceivedMessage typeCode fields = return $ \serial flags body -> let

@@ -426,18 +426,16 @@         arbitrary = do                 serial <- arbitrary                 dest   <- arbitrary-                flags  <- fmap Set.fromList arbitrary                 Structure body <- arbitrary-                return $ MethodReturn serial dest flags body+                return $ MethodReturn serial dest body  instance Arbitrary Error where         arbitrary = do                 name   <- arbitrary                 serial <- arbitrary                 dest   <- arbitrary-                flags  <- fmap Set.fromList arbitrary                 Structure body <- arbitrary-                return $ Error name serial dest flags body+                return $ Error name serial dest body  instance Arbitrary Signal where         arbitrary = do@@ -445,9 +443,8 @@                 member <- arbitrary                 iface  <- arbitrary                 dest   <- arbitrary-                flags  <- fmap Set.fromList arbitrary                 Structure body <- arbitrary-                return $ Signal path member iface dest flags body+                return $ Signal path member iface dest body  isRight :: Either a b -> Bool isRight = either (const False) (const True)