diff --git a/Examples/dbus-monitor.hs b/Examples/dbus-monitor.hs --- a/Examples/dbus-monitor.hs +++ b/Examples/dbus-monitor.hs @@ -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 diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 \ diff --git a/Tests.nw b/Tests.nw --- a/Tests.nw +++ b/Tests.nw @@ -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} diff --git a/dbus-core.cabal b/dbus-core.cabal --- a/dbus-core.cabal +++ b/dbus-core.cabal @@ -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: diff --git a/dbus-core.nw b/dbus-core.nw --- a/dbus-core.nw +++ b/dbus-core.nw @@ -98,2988 +98,3494 @@ <> <> -@ 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. - -<>= -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) - -<>= -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. - -<>= -typeCode :: Type -> Text - -<>= - -- * 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. - -<>= -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. - -<>= -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ExistentialQuantification #-} - -<>= -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. - -<>= -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 - -<>= - -- * 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. - -<>= -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. - -<>= -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}. - -<>= -variantType :: Variant -> Type -variantType (Variant x) = builtinDBusType x - -<>= -, variantType - -@ These helper macros will be used for defining instances of Haskell types. - -<>= -#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. - -<>= -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. - -<>= -import Data.Word (Word8, Word16, Word32, Word64) -import Data.Int (Int16, Int32, Int64) - -<>= -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. - -<>= -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. - -<>= -import qualified Data.Text as T - -<>= -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. - -<>= -{-# LANGUAGE TypeSynonymInstances #-} - -<>= -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}. - -<>= -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. - -<>= -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}. - -<>= -instance Ord Signature where - compare x y = compare (strSignature x) (strSignature y) - -<>= - -- * 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. - -<>= -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''. - -<>= -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}''. - -<>= -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 ``()''. - -<>= -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. - -<>= -import Text.Parsec ((<|>)) -import qualified Text.Parsec as P -import DBus.Util (checkLength, parseMaybe) - -<>= -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. - -<>= -import DBus.Util (mkUnsafe) - -<>= -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. - -<>= -, mkSignature -, mkSignature' - -@ \subsection{Object paths} - -<>= -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. - -<>= -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 - -<>= - -- * 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. - -<>= -INSTANCE_VARIABLE(Array) -data Array = Array - { arrayType :: Type - , arrayItems :: [Variant] - } - deriving (Eq, Typeable) - -instance Builtin Array where - builtinDBusType = DBusArray . arrayType - -<>= - -- * Arrays -, Array -, arrayType -, arrayItems - -@ Like {\tt Variant}, deriving {\tt Show} for {\tt Array} is mostly -just useful for debugging. - -<>= -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. - -<>= -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. - -<>= -toArray :: Variable a => Type -> [a] -> Maybe Array -toArray t = arrayFromItems t . map toVariant - -fromArray :: Variable a => Array -> Maybe [a] -fromArray = mapM fromVariant . arrayItems - -<>= -, 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. - -<>= -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 - -<>= - -- * Dictionaries -, Dictionary -, dictionaryItems -, dictionaryKeyType -, dictionaryValueType - -@ {\tt show}ing a {\tt Dictionary} displays the mapping in a more readable -format than a list of pairs. - -<>= -import Data.List (intercalate) - -<>= -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. - -<>= -import Control.Monad (unless) - -<>= -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. - -<>= -import Control.Arrow ((***)) -import qualified Data.Map as Map - -<>= -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 - -<>= -import Control.Monad (forM) - -<>= -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 - -<>= -, 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. - -<>= -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] - -<>= -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 - -<>= -, dictionaryToArray -, arrayToDictionary - -@ \subsection{Structures} - -A heterogeneous, fixed-length container; equivalent in purpose to a Haskell -tuple. - -<>= -INSTANCE_VARIABLE(Structure) -data Structure = Structure [Variant] - deriving (Show, Eq, Typeable) - -instance Builtin Structure where - builtinDBusType (Structure vs) = DBusStructure $ map variantType vs - -<>= - -- * 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. - -<>= -#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 - -<>= --- * 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. - -<>= -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') - -<>= - -- ** 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. - -<>= -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) - -<>= - -- ** 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. - -<>= -NAME_TYPE(ErrorName, "error name") - -mkErrorName :: Text -> Maybe ErrorName -mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName - -<>= - -- ** 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. - -<>= -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) - -<>= - -- ** 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. - -<>= -<> -module DBus.Message - (<> - ) where -import DBus.Message.Internal - -<>= -<> -module DBus.Message.Internal where -import qualified Data.Set as S -import Data.Word (Word8, Word32) -import qualified DBus.Types as T - -<>= -class Message a where - messageTypeCode :: a -> Word8 - messageHeaderFields :: a -> [HeaderField] - messageFlags :: a -> S.Set Flag - messageBody :: a -> [T.Variant] - -<>= -Message ( messageFlags - , messageBody - ) - -@ \subsection{Flags} - -The instance of {\tt Ord} only exists for storing flags in a set. Flags have -no inherent ordering. - -<>= -data Flag - = NoReplyExpected - | NoAutoStart - deriving (Show, Eq, Ord) - -<>= -, Flag (..) - -@ \subsection{Header fields} - -<>= -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. - -<>= -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. - -<>= -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. - -<>= -, Serial -, serialValue - -@ \subsection{Message types} - -<>= -maybe' :: (a -> b) -> Maybe a -> [b] -maybe' f = maybe [] (\x' -> [f x']) - -@ \subsubsection{Method calls} - -<>= -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 - ] - -<>= -, MethodCall (..) - -@ \subsubsection{Method returns} - -<>= -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 - ] - -<>= -, MethodReturn (..) - -@ \subsubsection{Errors} - -<>= -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 - ] - -<>= -, Error (..) - -@ \subsubsection{Signals} - -<>= -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 - ] - -<>= -, 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. - -<>= -data Unknown = Unknown - { unknownType :: Word8 - , unknownFlags :: S.Set Flag - , unknownBody :: [T.Variant] - } - deriving (Show, Eq) - -<>= -, 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. - -<>= -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) - -<>= -receivedSerial :: ReceivedMessage -> Serial -receivedSerial (ReceivedMethodCall s _ _) = s -receivedSerial (ReceivedMethodReturn s _ _) = s -receivedSerial (ReceivedError s _ _) = s -receivedSerial (ReceivedSignal s _ _) = s -receivedSerial (ReceivedUnknown s _ _) = s - -<>= -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 - -<>= -, ReceivedMessage (..) -, receivedSerial -, receivedSender - -@ -\section{Wire format} - -<>= -<> -<> -<> -{-# LANGUAGE DeriveDataTypeable #-} -module DBus.Wire (<>) where -<> -<> -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} - -<>= -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 - -<>= - 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. - -<>= -alignment :: T.Type -> Word8 -<> - -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 - -<>= -, alignment - -@ \subsection{Marshaling} - -Marshaling is implemented using an error transformer over an internal -state. - -<>= -import qualified Control.Monad.State as ST -import qualified Control.Monad.Error as E -import qualified Data.ByteString.Lazy as L - -<>= -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -<>= -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. - -<>= -, MarshalM -, Marshal -, marshal -, runMarshal - -<>= -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 - -<>= -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 - <> - -@ TODO: describe these functions - -<>= -append :: L.ByteString -> Marshal -append bs = do - (MarshalState e bs') <- ST.get - ST.put $ MarshalState e (L.append bs' bs) - -<>= -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. - -<>= -import qualified Data.Binary.Put as P - -<>= -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} - -<>= -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 - -<>= -, MarshalError (..) - -@ \subsection{Unmarshaling} - -Unmarshaling also uses an error transformer and internal state. - -<>= -, Unmarshal -, unmarshal -, runUnmarshal - -<>= -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) - -<>= -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 - -<>= -unmarshal :: T.Signature -> Unmarshal [T.Variant] -unmarshal = mapM unmarshalType . T.signatureTypes - -unmarshalType :: T.Type -> Unmarshal T.Variant -<> - -@ TODO: describe these functions - -<>= -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 - -<>= -skipPadding :: Word8 -> Unmarshal () -skipPadding count = do - (UnmarshalState _ _ offset) <- ST.get - bytes <- consume $ padding offset count - unless (L.all (== 0) bytes) $ - E.throwError $ InvalidPadding offset - -<>= -skipTerminator :: Unmarshal () -skipTerminator = do - (UnmarshalState _ _ offset) <- ST.get - bytes <- consume 1 - unless (L.all (== 0) bytes) $ - E.throwError $ MissingTerminator offset - -<>= -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' - -<>= -import qualified Data.Binary.Get as G - -<>= -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 - -<>= -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} - -<>= -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 - -<>= -, UnmarshalError (..) - -@ \subsection{Numerics} - -Numeric values are fixed-length, and aligned ``naturally'' -- ie, a 4-byte -integer will have a 4-byte alignment. - -<>= -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. - -<>= -marshalWord32 :: Word32 -> Marshal -marshalWord32 = marshalPut P.putWord32be - -unmarshalWord32 :: Unmarshal Word32 -unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le - -<>= -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) - -<>= -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. - -<>= -import qualified Data.Binary.IEEE754 as IEEE - -<>= -marshalType T.DBusDouble = marshalPut IEEE.putFloat64be x - -<>= -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. - -<>= -alignment T.DBusBoolean = 4 - -<>= -marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0 - -<>= -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}. - -<>= -import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) - -<>= -marshalText :: Text -> Marshal -marshalText x = do - let bytes = encodeUtf8 x - marshalWord32 . fromIntegral . L.length $ bytes - append bytes - append (L.singleton 0) - -<>= -unmarshalText :: Unmarshal Text -unmarshalText = do - byteCount <- unmarshalWord32 - bytes <- consume . fromIntegral $ byteCount - skipTerminator - return . decodeUtf8 $ bytes - -<>= -alignment T.DBusString = 4 -alignment T.DBusObjectPath = 4 - -<>= -marshalType T.DBusString = marshalText x -marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x - -<>= -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. - -<>= -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) - -<>= -unmarshalSignature :: Unmarshal T.Signature -unmarshalSignature = do - byteCount <- fmap L.head $ consume 1 - sigText <- fmap decodeUtf8 $ consume . fromIntegral $ byteCount - skipTerminator - fromMaybeU "signature" T.mkSignature sigText - -<>= -alignment T.DBusSignature = 1 - -<>= -marshalType T.DBusSignature = marshalSignature x - -<>= -unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature - -@ \subsection{Containers} - -@ \subsubsection{Arrays} - -<>= -alignment (T.DBusArray _) = 4 - -<>= -marshalType (T.DBusArray _) = marshalArray x - -<>= -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. - -<>= -import qualified DBus.Constants as C - -<>= -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 - -<>= -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 - -<>= -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} - -<>= -alignment (T.DBusDictionary _ _) = 4 - -<>= -marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x) - -<>= -unmarshalType (T.DBusDictionary kt vt) = do - let pairType = T.DBusStructure [kt, vt] - array <- unmarshalArray pairType - fromMaybeU' "dictionary" T.arrayToDictionary array - -@ \subsubsection{Structures} - -<>= -alignment (T.DBusStructure _) = 8 - -<>= -marshalType (T.DBusStructure _) = do - let T.Structure vs = x - pad 8 - mapM_ marshal vs - -<>= -unmarshalType (T.DBusStructure ts) = do - skipPadding 8 - fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts - -@ \subsubsection{Variants} - -<>= -alignment T.DBusVariant = 1 - -<>= -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 - -<>= -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} - -<>= -import qualified DBus.Message.Internal as M - -@ \subsubsection{Flags} - -<>= -import Data.Bits ((.|.), (.&.)) -import qualified Data.Set as Set - -<>= -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} - -<>= -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 - ] - -<>= -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 - -<>= -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} - -<>= -, marshalMessage - -<>= -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 - -<>= -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 - -<>= -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 - -<>= -marshalEndianness :: Endianness -> Marshal -marshalEndianness = marshal . T.toVariant . encodeEndianness - -<>= -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} - -<>= -, unmarshalMessage - -<>= -unmarshalMessage :: Monad m => (Word32 -> m L.ByteString) - -> m (Either UnmarshalError M.ReceivedMessage) -unmarshalMessage getBytes' = E.runErrorT $ do - let getBytes = E.lift . getBytes' - - <> - <> - <> - <> - -@ The first part of the header has a fixed size of 16 bytes, so it can be -retrieved without any size calculations. - -<>= -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. - -<>= -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. - -<>= -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 - -<>= -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. - -<>= -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. - -<>= -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. - -<>= -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. - -<>= -let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 -getBytes . fromIntegral $ bodyPadding - -<>= -findBodySignature :: [M.HeaderField] -> T.Signature -findBodySignature fields = fromMaybe empty signature where - empty = T.mkSignature' "" - signature = listToMaybe [x | M.Signature x <- fields] - -<>= -let bodySig = findBodySignature fields - -@ Then pull the body bytes, and unmarshal it. - -<>= -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. - -<>= -y <- case buildReceivedMessage typeCode fields of - Right x -> return x - Left x -> E.throwError $ MissingHeaderField x - -<>= -return $ y serial flags body - -@ This really belongs in the Message section... - -<>= -buildReceivedMessage :: Word8 -> [M.HeaderField] -> Either Text - (M.Serial -> (Set.Set M.Flag) -> [T.Variant] - -> M.ReceivedMessage) - -@ Method calls - -<>= -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 - -<>= -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 - -<>= -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 - -<>= -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 - -<>= -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 - -<>= -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} - -<>= -instance E.Error Text where - strMsg = TL.pack - -@ -\section{Connections} - -<>= -<> -<> -{-# LANGUAGE DeriveDataTypeable #-} -module DBus.Connection - ( <> - ) where -<> -<> - -@ A {\tt Connection} is an opaque handle to an open DBus channel, with -an internal state for maintaining the current message serial. - -<>= -import qualified Control.Concurrent as C -import qualified DBus.Address as A -import qualified DBus.Message.Internal as M - -<>= -data Connection = Connection A.Address Transport (C.MVar M.Serial) - -<>= - Connection - -@ While not particularly useful for other functions, being able to -{\tt show} a {\tt Connection} is useful when debugging. - -<>= -instance Show Connection where - showsPrec d (Connection a _ _) = showParen (d > 10) $ - showString' [""] where - showString' = foldr (.) id . map showString - -@ \subsection{Transports} - -A transport is anything which can send and receive bytestrings, typically -over a socket. - -<>= -import qualified Data.ByteString.Lazy as L -import Data.Word (Word32) - -<>= -data Transport = Transport - { transportSend :: L.ByteString -> IO () - , transportRecv :: Word32 -> IO L.ByteString - } - -<>= -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. - -<>= -import qualified Network as N -import qualified Data.Map as Map - -<>= -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 - -<>= -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. - -<>= -import qualified System.IO as I - -<>= -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. - -<>= -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. - -<>= -import qualified Control.Exception as E -import Data.Typeable (Typeable) - -<>= -data ConnectionError - = InvalidAddress Text - | BadParameters A.Address Text - | UnknownMethod A.Address - | NoWorkingAddress [A.Address] - deriving (Show, Typeable) - -instance E.Exception ConnectionError - -<>= -, 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. - -<>= -import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) - -<>= -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 - -<>= -, connect - -@ \subsection{Authentication} - -<>= -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. - -<>= -import System.Posix.User (getRealUserID) -import Data.Char (ord) -import Text.Printf (printf) - -<>= - 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 -}. The GUID is intended to enable connection sharing, which -is currently unimplemented, so it's ignored. - -<>= -import Data.List (isPrefixOf) - -<>= - response <- readUntil '\n' get - if "OK" `isPrefixOf` response - then put "BEGIN\r\n" - else do - putStrLn $ "response = " ++ show response - error "Server rejected authentication token." - -<>= -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. - -<>= -import qualified DBus.Wire as W - -<>= -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 - -<>= -, send - -<>= -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. - -<>= -receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage) -receive (Connection _ t _) = W.unmarshalMessage $ transportRecv t - -<>= -, receive - -@ -\section{The central bus} - -<>= -<> -<> -module DBus.Bus - ( getSystemBus - , getSessionBus - , getStarterBus - , getFirstBus - , getBus - ) where -<> - -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. - -<>= -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. - -<>= -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. - -<>= -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 - -<>= -getSessionBus :: IO (C.Connection, T.BusName) -getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS" - -<>= -getStarterBus :: IO (C.Connection, T.BusName) -getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS" - -<>= -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} - -<>= -hello :: M.MethodCall -hello = M.MethodCall dbusPath - (T.mkMemberName' "Hello") - (Just dbusInterface) - (Just dbusName) - Set.empty - [] - -<>= -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 - -<>= -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} - -<>= -<> -<> -module DBus.Address - ( Address - , addressMethod - , addressParameters - , mkAddresses - , strAddress - ) where -<> - -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. - -<>= -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. - -<>= -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. - -<>= -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. - -<>= -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} - - - - - - - - - - - - - - - -\end{verbatim} - -<>= -<> -<> -module DBus.Introspection - ( Object (..) - , Interface (..) - , Method (..) - , Signal (..) - , Parameter (..) - , Property (..) - , PropertyAccess (..) - , toXML - , fromXML - ) where -<> -<> -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. - -<>= -import qualified Text.XML.HaXml as H - -@ \subsection{Data types} - -<>= -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. - -<>= -import Text.XML.HaXml.Parse (xmlParse') -import DBus.Util (eitherToMaybe) - -<>= -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. - -<>= -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. - -<>= -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. - -<>= -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. - -<>= -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. - -<>= -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. - -<>= -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. - -<>= -parseParameter :: H.Element a -> Maybe Parameter -parseParameter e = do - let name = getAttr' "name" e - sig <- parseType e - return $ Parameter name sig - -<>= -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. - -<>= -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. - -<>= -import Data.Char (chr) - -<>= -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 - -<>= -import Data.Maybe (fromMaybe) - -<>= -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 - -<>= -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] - -<>= -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} - -<>= -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. - -<>= -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}. - -<>= -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. - -<>= -xmlRoot :: Object -> Maybe (H.Element a) -xmlRoot obj@(Object path _ _) = do - (H.CElem root _) <- xmlObject' (T.strObjectPath path) obj - return $ root - -<>= -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 - -<>= -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'' - ] - -<>= -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 - ] - -<>= -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 - ] - -<>= -xmlSignal :: Signal -> H.Content a -xmlSignal (Signal name params) = mkElement "signal" - [mkAttr "name" . TL.unpack . T.strMemberName $ name] - $ map (xmlParameter "out") params - -<>= -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 - ] [] - -<>= -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 - ] [] - -<>= -xmlAccess :: [PropertyAccess] -> String -xmlAccess access = read ++ write where - read = if elem Read access then "read" else "" - write = 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 - -<>= -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} - -<>= -<> -{-# LANGUAGE OverloadedStrings #-} -module DBus.Constants where -import qualified DBus.Types as T -import Data.Word (Word8, Word32) - -<>= -protocolVersion :: Word8 -protocolVersion = 1 - -messageMaximumLength :: Word32 -messageMaximumLength = 134217728 - -arrayMaximumLength :: Word32 -arrayMaximumLength = 67108864 - -@ \subsection{The message bus} - -<>= -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} - -<>= -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} - -<>= -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} - -<>= -<> -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. + +<>= +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) + +<>= +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. + +<>= +typeCode :: Type -> Text + +<>= + -- * 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. + +<>= +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. + +<>= +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} + +<>= +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. + +<>= +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 + +<>= + -- * 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. + +<>= +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. + +<>= +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}. + +<>= +variantType :: Variant -> Type +variantType (Variant x) = builtinDBusType x + +<>= +, variantType + +@ These helper macros will be used for defining instances of Haskell types. + +<>= +#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. + +<>= +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. + +<>= +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int16, Int32, Int64) + +<>= +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. + +<>= +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. + +<>= +import qualified Data.Text as T + +<>= +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. + +<>= +{-# LANGUAGE TypeSynonymInstances #-} + +<>= +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}. + +<>= +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. + +<>= +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}. + +<>= +instance Ord Signature where + compare x y = compare (strSignature x) (strSignature y) + +<>= + -- * 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. + +<>= +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''. + +<>= +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\}''. + +<>= +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 ``()''. + +<>= +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. + +<>= +import Text.Parsec ((<|>)) +import qualified Text.Parsec as P +import DBus.Util (checkLength, parseMaybe) + +<>= +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. + +<>= +import DBus.Util (mkUnsafe) + +<>= +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. + +<>= +, mkSignature +, mkSignature' + +@ \subsection{Object paths} + +<>= +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. + +<>= +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 + +<>= + -- * 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. + +<>= +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as ByteString + +<>= +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 + +<>= + -- * Arrays +, Array +, arrayType +, arrayItems + +@ Like {\tt Variant}, deriving {\tt Show} for {\tt Array} is mostly +just useful for debugging. + +<>= +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. + +<>= +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. + +<>= +toArray :: Variable a => Type -> [a] -> Maybe Array +toArray t = arrayFromItems t . map toVariant + +fromArray :: Variable a => Array -> Maybe [a] +fromArray = mapM fromVariant . arrayItems + +<>= +, toArray +, fromArray +, arrayFromItems + +@ To provide a more efficient interface for byte array literals, these +functions bypass the conversions in {\tt toArray} and {\tt fromArray} + +<>= +arrayToBytes :: Array -> Maybe ByteString +arrayToBytes (ByteArray x) = Just x +arrayToBytes _ = Nothing + +arrayFromBytes :: ByteString -> Array +arrayFromBytes = ByteArray + +<>= +, arrayToBytes +, arrayFromBytes + +@ And to simplify inclusion of {\tt ByteString}s in message, instances of +{\tt Variable} exist for both strict and lazy {\tt ByteString}. + +<>= +instance Variable ByteString where + toVariant = toVariant . arrayFromBytes + fromVariant x = fromVariant x >>= arrayToBytes + +<>= +import qualified Data.ByteString as StrictByteString + +<>= +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. + +<>= +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 + +<>= + -- * Dictionaries +, Dictionary +, dictionaryItems +, dictionaryKeyType +, dictionaryValueType + +@ {\tt show}ing a {\tt Dictionary} displays the mapping in a more readable +format than a list of pairs. + +<>= +import Data.List (intercalate) + +<>= +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. + +<>= +import Control.Monad (unless) + +<>= +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. + +<>= +import Control.Arrow ((***)) +import qualified Data.Map as Map + +<>= +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 + +<>= +import Control.Monad (forM) + +<>= +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 + +<>= +, 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. + +<>= +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] + +<>= +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 + +<>= +, dictionaryToArray +, arrayToDictionary + +@ \subsection{Structures} + +A heterogeneous, fixed-length container; equivalent in purpose to a Haskell +tuple. + +<>= +INSTANCE_VARIABLE(Structure) +data Structure = Structure [Variant] + deriving (Show, Eq, Typeable) + +instance Builtin Structure where + builtinDBusType (Structure vs) = DBusStructure $ map variantType vs + +<>= + -- * 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. + +<>= +#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 + +<>= +-- * 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. + +<>= +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') + +<>= + -- ** 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. + +<>= +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) + +<>= + -- ** 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. + +<>= +NAME_TYPE(ErrorName, "error name") + +mkErrorName :: Text -> Maybe ErrorName +mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName + +<>= + -- ** 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. + +<>= +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) + +<>= + -- ** 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. + +<>= +<> +module DBus.Message + (<> + ) where +import DBus.Message.Internal + +<>= +<> +<> +module DBus.Message.Internal where +<> +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 + messageHeaderFields :: a -> [HeaderField] + messageFlags :: a -> S.Set Flag + messageBody :: a -> [T.Variant] + +<>= +Message ( messageFlags + , messageBody + ) + +@ \subsection{Flags} + +The instance of {\tt Ord} only exists for storing flags in a set. Flags have +no inherent ordering. + +<>= +data Flag + = NoReplyExpected + | NoAutoStart + deriving (Show, Eq, Ord) + +<>= +, Flag (..) + +@ \subsection{Header fields} + +<>= +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. + +<>= +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. + +<>= +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. + +<>= +, Serial +, serialValue + +@ \subsection{Message types} + +<>= +maybe' :: (a -> b) -> Maybe a -> [b] +maybe' f = maybe [] (\x' -> [f x']) + +@ \subsubsection{Method calls} + +<>= +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 + ] + +<>= +, MethodCall (..) + +@ \subsubsection{Method returns} + +<>= +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 + ] + +<>= +, MethodReturn (..) + +@ \subsubsection{Errors} + +<>= +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. + +<>= +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 + +<>= +, Error (..) +, errorMessage + +@ \subsubsection{Signals} + +<>= +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 + ] + +<>= +, 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. + +<>= +data Unknown = Unknown + { unknownType :: Word8 + , unknownFlags :: S.Set Flag + , unknownBody :: [T.Variant] + } + deriving (Show, Eq) + +<>= +, 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. + +<>= +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) + +<>= +receivedSerial :: ReceivedMessage -> Serial +receivedSerial (ReceivedMethodCall s _ _) = s +receivedSerial (ReceivedMethodReturn s _ _) = s +receivedSerial (ReceivedError s _ _) = s +receivedSerial (ReceivedSignal s _ _) = s +receivedSerial (ReceivedUnknown s _ _) = s + +<>= +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 + +<>= +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 _ = [] + +<>= +, ReceivedMessage (..) +, receivedSerial +, receivedSender +, receivedBody + +@ +\section{Wire format} + +<>= +<> +<> +<> +module DBus.Wire (<>) where +<> +<> +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} + +<>= +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 + +<>= + 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. + +<>= +alignment :: T.Type -> Word8 +<> + +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 + +<>= +, 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. + +<>= +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 + +<>= +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} + +<>= +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. + +<>= +, MarshalM +, Marshal +, marshal +, runMarshal + +<>= +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 + +<>= +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 + <> + +@ TODO: describe these functions + +<>= +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' + +<>= +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. + +<>= +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} + +<>= +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 + +<>= +, MarshalError (..) + +@ \subsection{Unmarshaling} + +Unmarshaling also uses an error transformer and internal state. + +<>= +, Unmarshal +, unmarshal +, runUnmarshal + +<>= +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) + +<>= +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 + +<>= +unmarshal :: T.Signature -> Unmarshal [T.Variant] +unmarshal = mapM unmarshalType . T.signatureTypes + +unmarshalType :: T.Type -> Unmarshal T.Variant +<> + +@ TODO: describe these functions + +<>= +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 + +<>= +skipPadding :: Word8 -> Unmarshal () +skipPadding count = do + (UnmarshalState _ _ offset) <- ST.get + bytes <- consume $ padding offset count + unless (L.all (== 0) bytes) $ + E.throwError $ InvalidPadding offset + +<>= +skipTerminator :: Unmarshal () +skipTerminator = do + (UnmarshalState _ _ offset) <- ST.get + bytes <- consume 1 + unless (L.all (== 0) bytes) $ + E.throwError $ MissingTerminator offset + +<>= +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' + +<>= +import qualified Data.Binary.Get as G + +<>= +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 + +<>= +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} + +<>= +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 + +<>= +, UnmarshalError (..) + +@ \subsection{Numerics} + +Numeric values are fixed-length, and aligned ``naturally'' -- ie, a 4-byte +integer will have a 4-byte alignment. + +<>= +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. + +<>= +marshalWord32 :: Word32 -> Marshal +marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le + +unmarshalWord32 :: Unmarshal Word32 +unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le + +<>= +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) + +<>= +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. + +<>= +import Data.Binary.Put (runPut) +import qualified Data.Binary.IEEE754 as IEEE + +<>= +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 + +<>= +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. + +<>= +alignment T.DBusBoolean = 4 + +<>= +marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0 + +<>= +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}. + +<>= +import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) + +<>= +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) + +<>= +unmarshalText :: Unmarshal Text +unmarshalText = do + byteCount <- unmarshalWord32 + bytes <- consume . fromIntegral $ byteCount + skipTerminator + return . decodeUtf8 $ bytes + +<>= +alignment T.DBusString = 4 +alignment T.DBusObjectPath = 4 + +<>= +marshalType T.DBusString = marshalText x +marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x + +<>= +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. + +<>= +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) + +<>= +unmarshalSignature :: Unmarshal T.Signature +unmarshalSignature = do + byteCount <- L.head `fmap` consume 1 + sigText <- fmap decodeUtf8 $ consume . fromIntegral $ byteCount + skipTerminator + fromMaybeU "signature" T.mkSignature sigText + +<>= +alignment T.DBusSignature = 1 + +<>= +marshalType T.DBusSignature = marshalSignature x + +<>= +unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature + +@ \subsection{Containers} + +@ \subsubsection{Arrays} + +<>= +alignment (T.DBusArray _) = 4 + +<>= +marshalType (T.DBusArray _) = marshalArray x + +<>= +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. + +<>= +import qualified DBus.Constants as C + +<>= +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 + +<>= +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 + 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. + +<>= +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 + 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} + +<>= +alignment (T.DBusDictionary _ _) = 4 + +<>= +marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x) + +<>= +unmarshalType (T.DBusDictionary kt vt) = do + let pairType = T.DBusStructure [kt, vt] + array <- unmarshalArray pairType + fromMaybeU' "dictionary" T.arrayToDictionary array + +@ \subsubsection{Structures} + +<>= +alignment (T.DBusStructure _) = 8 + +<>= +marshalType (T.DBusStructure _) = do + let T.Structure vs = x + pad 8 + mapM_ marshal vs + +<>= +unmarshalType (T.DBusStructure ts) = do + skipPadding 8 + fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts + +@ \subsubsection{Variants} + +<>= +alignment T.DBusVariant = 1 + +<>= +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 + +<>= +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} + +<>= +import qualified DBus.Message.Internal as M + +@ \subsubsection{Flags} + +<>= +import Data.Bits ((.|.), (.&.)) +import qualified Data.Set as Set + +<>= +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} + +<>= +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 + ] + +<>= +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 + +<>= +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} + +<>= +, marshalMessage + +<>= +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 + +<>= +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 + +<>= +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 + +<>= +marshalEndianness :: Endianness -> Marshal +marshalEndianness = marshal . T.toVariant . encodeEndianness + +<>= +checkMaximumSize :: Marshal +checkMaximumSize = do + (MarshalState _ _ messageLength) <- ST.get + when (messageLength > fromIntegral C.messageMaximumLength) + (E.throwError $ MessageTooLong $ fromIntegral messageLength) + +@ \subsubsection{Unmarshaling} + +<>= +, unmarshalMessage + +<>= +unmarshalMessage :: Monad m => (Word32 -> m L.ByteString) + -> m (Either UnmarshalError M.ReceivedMessage) +unmarshalMessage getBytes' = E.runErrorT $ do + let getBytes = E.lift . getBytes' + + <> + <> + <> + <> + +@ The first part of the header has a fixed size of 16 bytes, so it can be +retrieved without any size calculations. + +<>= +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. + +<>= +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. + +<>= +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 + +<>= +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. + +<>= +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. + +<>= +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. + +<>= +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. + +<>= +let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 +getBytes . fromIntegral $ bodyPadding + +<>= +findBodySignature :: [M.HeaderField] -> T.Signature +findBodySignature fields = fromMaybe empty signature where + empty = T.mkSignature' "" + signature = listToMaybe [x | M.Signature x <- fields] + +<>= +let bodySig = findBodySignature fields + +@ Then pull the body bytes, and unmarshal it. + +<>= +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. + +<>= +y <- case buildReceivedMessage typeCode fields of + Right x -> return x + Left x -> E.throwError $ MissingHeaderField x + +<>= +return $ y serial flags body + +@ This really belongs in the Message section... + +<>= +buildReceivedMessage :: Word8 -> [M.HeaderField] -> Either Text + (M.Serial -> (Set.Set M.Flag) -> [T.Variant] + -> M.ReceivedMessage) + +@ Method calls + +<>= +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 + +<>= +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 + +<>= +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 + +<>= +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 + +<>= +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 + +<>= +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} + +<>= +instance E.Error Text where + strMsg = TL.pack + +@ +\section{Addresses} + +<>= +<> +<> +module DBus.Address + ( Address + , addressMethod + , addressParameters + , mkAddresses + , strAddress + ) where +<> + +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. + +<>= +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. + +<>= +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. + +<>= +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. + +<>= +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} + +<>= +<> +<> +{-# LANGUAGE DeriveDataTypeable #-} +module DBus.Connection + ( <> + ) where +<> +<> + +@ 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. + +<>= +import qualified Control.Concurrent as C +import qualified DBus.Address as A +import qualified DBus.Message.Internal as M + +<>= +data Connection = Connection A.Address Transport (C.MVar M.Serial) (C.MVar ()) + +<>= + Connection + +@ While not particularly useful for other functions, being able to +{\tt show} a {\tt Connection} is useful when debugging. + +<>= +instance Show Connection where + showsPrec d (Connection a _ _ _) = showParen (d > 10) $ + showString' [""] where + showString' = foldr (.) id . map showString + +@ \subsection{Transports} + +A transport is anything which can send and receive bytestrings, typically +over a socket. + +<>= +import qualified Data.ByteString.Lazy as L +import Data.Word (Word32) + +<>= +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. + +<>= +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. + +<>= +import qualified Network as N +import qualified Data.Map as Map + +<>= +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. + +<>= +import qualified Network.Socket as NS + +<>= +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... + +<>= + 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 + +@ 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}. + +<>= +import qualified Text.Parsec as P +import Control.Monad (unless) +import Data.Binary.Get (runGet, getWord16host) +import Data.Binary.Put (runPut, putWord16be) + +<>= + 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 + +@ 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. + +<>= + 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. + +<>= + 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. + +<>= +import qualified System.IO as I + +<>= +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. + +<>= +import qualified Control.Exception as E +import Data.Typeable (Typeable) + +<>= +data ConnectionError + = InvalidAddress Text + | BadParameters A.Address Text + | UnknownMethod A.Address + | NoWorkingAddress [A.Address] + deriving (Show, Typeable) + +instance E.Exception ConnectionError + +<>= +, 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. + +<>= +import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) + +<>= +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. + +<>= +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 + +<>= +, connect +, connectFirst + +@ \subsection{Authentication} + +<>= +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. + +<>= +import System.Posix.User (getRealUserID) +import Data.Char (ord) +import Text.Printf (printf) + +<>= + 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 +}. The GUID is intended to enable connection sharing, which +is currently unimplemented, so it's ignored. + +<>= +import Data.List (isPrefixOf) + +<>= + response <- readUntil '\n' get + if "OK" `isPrefixOf` response + then put "BEGIN\r\n" + else do + putStrLn $ "response = " ++ show response + error "Server rejected authentication token." + +<>= +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. + +<>= +import qualified DBus.Wire as W + +<>= +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 + +<>= +, send + +<>= +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. + +<>= +receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage) +receive (Connection _ t _ lock) = C.withMVar lock $ \_ -> + W.unmarshalMessage $ transportRecv t + +<>= +, receive + +@ +\section{The central bus} + +<>= +<> +<> +module DBus.Bus + ( getBus + , getFirstBus + , getSystemBus + , getSessionBus + , getStarterBus + ) where +<> + +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. + +<>= +busForConnection :: C.Connection -> IO (C.Connection, T.BusName) +busForConnection c = sendHello c >>= return . (,) c + +<>= +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. + +<>= +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. + +<>= +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 + +<>= +getSessionBus :: IO (C.Connection, T.BusName) +getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS" + +<>= +getStarterBus :: IO (C.Connection, T.BusName) +getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS" + +<>= +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} + +<>= +hello :: M.MethodCall +hello = M.MethodCall dbusPath + (T.mkMemberName' "Hello") + (Just dbusInterface) + (Just dbusName) + Set.empty + [] + +<>= +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 + +<>= +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} + + + + + + + + + + + + + + + +\end{verbatim} + +<>= +<> +<> +module DBus.Introspection + ( Object (..) + , Interface (..) + , Method (..) + , Signal (..) + , Parameter (..) + , Property (..) + , PropertyAccess (..) + , toXML + , fromXML + ) where +<> +<> +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. + +<>= +import qualified Text.XML.HaXml as H + +@ \subsection{Data types} + +<>= +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. + +<>= +import Text.XML.HaXml.Parse (xmlParse') +import DBus.Util (eitherToMaybe) + +<>= +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. + +<>= +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. + +<>= +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. + +<>= +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. + +<>= +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. + +<>= +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. + +<>= +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. + +<>= +parseParameter :: H.Element a -> Maybe Parameter +parseParameter e = do + let name = getAttr' "name" e + sig <- parseType e + return $ Parameter name sig + +<>= +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. + +<>= +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. + +<>= +import Data.Char (chr) + +<>= +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 + +<>= +import Data.Maybe (fromMaybe) + +<>= +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 + +<>= +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] + +<>= +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} + +<>= +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. + +<>= +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}. + +<>= +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. + +<>= +xmlRoot :: Object -> Maybe (H.Element a) +xmlRoot obj@(Object path _ _) = do + (H.CElem root _) <- xmlObject' (T.strObjectPath path) obj + return root + +<>= +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 + +<>= +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'' + ] + +<>= +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 + ] + +<>= +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 + ] + +<>= +xmlSignal :: Signal -> H.Content a +xmlSignal (Signal name params) = mkElement "signal" + [mkAttr "name" . TL.unpack . T.strMemberName $ name] + $ map (xmlParameter "out") params + +<>= +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 + ] [] + +<>= +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 + ] [] + +<>= +xmlAccess :: [PropertyAccess] -> String +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 + +<>= +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. + +<>= +<> +<> +module DBus.MatchRule ( + MatchRule (..) + , MessageType (..) + , ParameterValue (..) + , formatRule + , addMatch + , matchAll + , matches + ) where +<> +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. + +<>= +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. + +<>= +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. + +<>= +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. + +<>= +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 + +@ FIXME: what are the escaping rules for match rules? Other bindings don't +seem to perform any escaping at all. + +<>= +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" + +@ 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. + +<>= +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. + +<>= +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. + +<>= +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 + +@ +\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. + +<>= +<> +{-# 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 + +@ There are only two methods of interest here, {\tt RequestName} and +{\tt ReleaseName}. + +<>= +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 + +@ +\section{Constants} + +<>= +<> +{-# LANGUAGE OverloadedStrings #-} +module DBus.Constants where +import qualified DBus.Types as T +import Data.Word (Word8, Word32) + +<>= +protocolVersion :: Word8 +protocolVersion = 1 + +messageMaximumLength :: Word32 +messageMaximumLength = 134217728 + +arrayMaximumLength :: Word32 +arrayMaximumLength = 67108864 + +@ \subsection{The message bus} + +<>= +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} + +<>= +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} + +<>= +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} + +<>= +<> +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} diff --git a/hs/DBus/Address.hs b/hs/DBus/Address.hs --- a/hs/DBus/Address.hs +++ b/hs/DBus/Address.hs @@ -80,4 +80,3 @@ encode c | elem c optionallyEncoded = TL.singleton c | otherwise = TL.pack $ printf "%%%02X" (ord c) - diff --git a/hs/DBus/Bus.hs b/hs/DBus/Bus.hs --- a/hs/DBus/Bus.hs +++ b/hs/DBus/Bus.hs @@ -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 diff --git a/hs/DBus/Connection.hs b/hs/DBus/Connection.hs --- a/hs/DBus/Connection.hs +++ b/hs/DBus/Connection.hs @@ -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' [""] 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 diff --git a/hs/DBus/Introspection.hs b/hs/DBus/Introspection.hs --- a/hs/DBus/Introspection.hs +++ b/hs/DBus/Introspection.hs @@ -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 diff --git a/hs/DBus/MatchRule.hs b/hs/DBus/MatchRule.hs new file mode 100644 --- /dev/null +++ b/hs/DBus/MatchRule.hs @@ -0,0 +1,175 @@ +{- + Copyright (C) 2009 John Millikin + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} + +{-# 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 + diff --git a/hs/DBus/Message.hs b/hs/DBus/Message.hs --- a/hs/DBus/Message.hs +++ b/hs/DBus/Message.hs @@ -30,6 +30,7 @@ , MethodReturn (..) , Error (..) + , errorMessage , Signal (..) @@ -38,6 +39,7 @@ , ReceivedMessage (..) , receivedSerial , receivedSender + , receivedBody ) where import DBus.Message.Internal diff --git a/hs/DBus/Message/Internal.hs b/hs/DBus/Message/Internal.hs --- a/hs/DBus/Message/Internal.hs +++ b/hs/DBus/Message/Internal.hs @@ -15,10 +15,17 @@ along with this program. If not, see . -} +{-# 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 _ = [] diff --git a/hs/DBus/NameReservation.hs b/hs/DBus/NameReservation.hs new file mode 100644 --- /dev/null +++ b/hs/DBus/NameReservation.hs @@ -0,0 +1,107 @@ +{- + Copyright (C) 2009 John Millikin + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} + +{-# 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 + diff --git a/hs/DBus/Types.hs b/hs/DBus/Types.hs --- a/hs/DBus/Types.hs +++ b/hs/DBus/Types.hs @@ -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 }; diff --git a/hs/DBus/Util.hs b/hs/DBus/Util.hs --- a/hs/DBus/Util.hs +++ b/hs/DBus/Util.hs @@ -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 + diff --git a/hs/DBus/Wire.hs b/hs/DBus/Wire.hs --- a/hs/DBus/Wire.hs +++ b/hs/DBus/Wire.hs @@ -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 diff --git a/hs/Tests.hs b/hs/Tests.hs --- a/hs/Tests.hs +++ b/hs/Tests.hs @@ -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)