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