% 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>>=
isAtomicType :: Type -> Bool
isAtomicType DBusBoolean    = True
isAtomicType DBusByte       = True
isAtomicType DBusInt16      = True
isAtomicType DBusInt32      = True
isAtomicType DBusInt64      = True
isAtomicType DBusWord16     = True
isAtomicType DBusWord32     = True
isAtomicType DBusWord64     = True
isAtomicType DBusDouble     = True
isAtomicType DBusString     = True
isAtomicType DBusSignature  = True
isAtomicType DBusObjectPath = True
isAtomicType _              = False

@ Each type can be converted to a textual representation, used in ``type
signatures'' or for debugging.

<<DBus/Types.hs>>=
typeCode :: Type -> Text

<<type exports>>=
  -- * Available types
  Type (..)
, typeCode

@ Certain Haskell types are considered ``built-in'' D-Bus types; that is,
they are directly represented in the D-Bus protocol.

<<DBus/Types.hs>>=
class (Show a, Eq a) => Builtin a where
	builtinDBusType :: a -> Type

@ \subsection{Variants}

A wrapper type is needed for safely storing generic D-Bus values in Haskell.
The D-Bus ``variant'' type is perfect for this, because variants may store
any D-Bus value.

To cleanly store any D-Bus type, without exposing the internal storage
mechanism, requires existential quantification and some run-time casting.

<<type extensions>>=
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}

<<type imports>>=
import Data.Typeable (Typeable, cast)

@ Any type which is an instance of {\tt Variable} is considered a valid
D-Bus value, because it can be used to construct {\tt Variant}s. However,
outside of this module, {\tt Variant}s can only be constructed from
pre-defined types.

<<DBus/Types.hs>>=
data Variant = forall a. (Variable a, Builtin a, Typeable a) => Variant a
	deriving (Typeable)

class Variable a where
	toVariant :: a -> Variant
	fromVariant :: Variant -> Maybe a

<<type exports>>=
  -- * Variants
, Variant
, Variable (..)

@ Variants can be printed, for debugging purposes -- this instance shouldn't
be parsed or inspected or anything like that, since the output format might
change drastically.

<<DBus/Types.hs>>=
instance Show Variant where
	showsPrec d (Variant x) = showParen (d > 10) $
		s "Variant " . shows code . s " " . showsPrec 11 x
		where code = typeCode . builtinDBusType $ x
		      s    = showString

@ In the test suite, it's useful to test that two variants have the same
value.

<<DBus/Types.hs>>=
instance Eq Variant where
	(Variant x) == (Variant y) = cast x == Just y

@ Since many operations on D-Bus values depend on having the correct type,
{\tt variantType} is used to retrieve which type is actually stored within
a {\tt Variant}.

<<DBus/Types.hs>>=
variantType :: Variant -> Type
variantType (Variant x) = builtinDBusType x

<<type exports>>=
, variantType

@ These helper macros will be used for defining instances of Haskell types.

<<DBus/Types.hs>>=
#define INSTANCE_BUILTIN(HASKELL, DBUS) \
	instance Builtin HASKELL where \
		{ builtinDBusType _ = DBUS };

#define INSTANCE_VARIABLE(HASKELL) \
	instance Variable HASKELL where \
		{ toVariant = Variant \
		; fromVariant (Variant x) = cast x };

#define BUILTIN_VARIABLE(HASKELL, DBUS) \
	INSTANCE_BUILTIN(HASKELL, DBUS) \
	INSTANCE_VARIABLE(HASKELL)

@ Since {\tt Variant}s are D-Bus values themselves, they have a type.

<<DBus/Types.hs>>=
BUILTIN_VARIABLE(Variant, DBusVariant)

@ \subsection{Numerics}

D-Bus supports most common numeric types:

\begin{table}[h]
\caption{D-Bus Numeric types}
\begin{center}
\begin{tabular}{ll}
\toprule
Type        & Description \\
\midrule
Boolean     & Either {\tt True} or {\tt False} \\
Byte        & 8-bit unsigned integer \\
Int16       & 16-bit signed integer \\
Int32       & 32-bit signed integer \\
Int64       & 64-bit signed integer \\
Word16      & 16-bit unsigned integer \\
Word32      & 32-bit unsigned integer \\
Word64      & 64-bit unsigned integer \\
Double      & 64-bit IEEE754 floating-point \\
\bottomrule
\end{tabular}
\end{center}
\end{table}

All D-Bus numeric types are fixed-length, so the {\tt Int} and {\tt Integer}
types can't be used. Instead, instances for the fixed-length integer types
are defined and any others will have to be converted.

<<type imports>>=
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Int (Int16, Int32, Int64)

<<DBus/Types.hs>>=
BUILTIN_VARIABLE(Bool,   DBusBoolean)
BUILTIN_VARIABLE(Word8,  DBusByte)
BUILTIN_VARIABLE(Int16,  DBusInt16)
BUILTIN_VARIABLE(Int32,  DBusInt32)
BUILTIN_VARIABLE(Int64,  DBusInt64)
BUILTIN_VARIABLE(Word16, DBusWord16)
BUILTIN_VARIABLE(Word32, DBusWord32)
BUILTIN_VARIABLE(Word64, DBusWord64)
BUILTIN_VARIABLE(Double, DBusDouble)

@ \subsection{Strings}

Strings are a weird case; the built-in type, {\tt String}, is horribly
inefficent. To provide better performance for large strings, packed Unicode
strings defined in {\tt Data.Text} are used internally.

<<DBus/Types.hs>>=
BUILTIN_VARIABLE(TL.Text, DBusString)

@ There's two different {\tt Text} types, strict and lazy. It'd be a pain
to store both and have to convert later, so instead, all strict {\tt Text}
values are converted to lazy values.

<<type imports>>=
import qualified Data.Text as T

<<DBus/Types.hs>>=
instance Variable T.Text where
	toVariant = toVariant . TL.fromChunks . (:[])
	fromVariant = fmap (T.concat . TL.toChunks) . fromVariant

@ Built-in {\tt String}s can still be stored, of course, but it requires
a language extension.

<<type extensions>>=
{-# LANGUAGE TypeSynonymInstances #-}

<<DBus/Types.hs>>=
instance Variable String where
	toVariant = toVariant . TL.pack
	fromVariant = fmap TL.unpack . fromVariant

@ \subsection{Signatures}

@ Valid D-Bus types must obey certain rules, such as ``dict keys must be
atomic'', which are difficult to express in the Haskell type system.  A
{\tt Signature} is guaranteed to be valid according to these rules. Creating
one requires using the {\tt mkSignature} function, which will convert a valid
D-Bus signature string into a {\tt Signature}.

<<DBus/Types.hs>>=
BUILTIN_VARIABLE(Signature, DBusSignature)
data Signature = Signature { signatureTypes :: [Type] }
	deriving (Eq, Typeable)

instance Show Signature where
	showsPrec d x = showParen (d > 10) $
		showString "Signature " . shows (strSignature x)

@ Signatures can also be converted back into text, by concatenating the
type codes of their contained types.

<<DBus/Types.hs>>=
strSignature :: Signature -> Text
strSignature (Signature ts) = TL.concat $ map typeCode ts

@ It doesn't make much sense to sort signatures, but since they can be used
as dictionary keys, it's useful to have them as an instance of {\tt Ord}.

<<DBus/Types.hs>>=
instance Ord Signature where
	compare x y = compare (strSignature x) (strSignature y)

<<type exports>>=
  -- * Signatures
, Signature
, signatureTypes
, strSignature

@ \subsubsection{Type codes}

@ For atomic types, the type code is a single letter. Arrays, structures,
and dictionary types are multiple characters.

<<DBus/Types.hs>>=
typeCode DBusBoolean    = "b"
typeCode DBusByte       = "y"
typeCode DBusInt16      = "n"
typeCode DBusInt32      = "i"
typeCode DBusInt64      = "x"
typeCode DBusWord16     = "q"
typeCode DBusWord32     = "u"
typeCode DBusWord64     = "t"
typeCode DBusDouble     = "d"
typeCode DBusString     = "s"
typeCode DBusSignature  = "g"
typeCode DBusObjectPath = "o"
typeCode DBusVariant    = "v"

@ An array's type code is ``a'' followed by the type it contains. For example,
an array of booleans would have the type string ``ab''.

<<DBus/Types.hs>>=
typeCode (DBusArray t) = TL.cons 'a' $ typeCode t

@ A dictionary's type code is ``a\{$key\_type$ $value\_type$\}''. For example,
a dictionary of bytes to booleans would have the type string ``a\{yb\}''.

<<DBus/Types.hs>>=
typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"]

@ A structure's type code is the concatenation of its contained types,
wrapped by ``('' and ``)''. Structures may be empty, in which case their
type code is simply ``()''.

<<DBus/Types.hs>>=
typeCode (DBusStructure ts) = TL.concat $
	["("] ++ map typeCode ts ++ [")"]

@ \subsubsection{Parsing}

When parsing, additional restrictions apply which are not inherent to the
D-Bus type system:

\begin{itemize}
\item Signatures may be at most 255 characters long.
\end{itemize}

Parsec is used to parse signatures.

<<type imports>>=
import Text.Parsec ((<|>))
import qualified Text.Parsec as P
import DBus.Util (checkLength, parseMaybe)

<<DBus/Types.hs>>=
mkSignature :: Text -> Maybe Signature
mkSignature = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack where
	sigParser = do
		types <- P.many parseType
		P.eof
		return $ Signature types
	parseType = parseAtom <|> parseContainer
	parseContainer =
		    parseArray
		<|> parseStruct
		<|> (P.char 'v' >> return DBusVariant)
	parseAtom =
		    (P.char 'b' >> return DBusBoolean)
		<|> (P.char 'y' >> return DBusByte)
		<|> (P.char 'n' >> return DBusInt16)
		<|> (P.char 'i' >> return DBusInt32)
		<|> (P.char 'x' >> return DBusInt64)
		<|> (P.char 'q' >> return DBusWord16)
		<|> (P.char 'u' >> return DBusWord32)
		<|> (P.char 't' >> return DBusWord64)
		<|> (P.char 'd' >> return DBusDouble)
		<|> (P.char 's' >> return DBusString)
		<|> (P.char 'g' >> return DBusSignature)
		<|> (P.char 'o' >> return DBusObjectPath)
	parseArray = do
		P.char 'a'
		parseDict <|> do
		t <- parseType
		return $ DBusArray t
	parseDict = do
		P.char '{'
		keyType <- parseAtom
		valueType <- parseType
		P.char '}'
		return $ DBusDictionary keyType valueType
	parseStruct = do
		P.char '('
		types <- P.many parseType
		P.char ')'
		return $ DBusStructure types

@ Since many signatures are defined as string literals, it's useful to
have a helper function to construct a signature directly from a string.
If the input string is invalid, {\tt error} will be called.

<<type imports>>=
import DBus.Util (mkUnsafe)

<<DBus/Types.hs>>=
mkSignature' :: Text -> Signature
mkSignature' = mkUnsafe "signature" mkSignature

@ Most signature-related functions are exposed to clients, except the
{\tt Signature} value constructor. If that were exposed, clients could
construct invalid signatures.

<<type exports>>=
, mkSignature
, mkSignature'

@ \subsection{Object paths}

<<DBus/Types.hs>>=
BUILTIN_VARIABLE(ObjectPath, DBusObjectPath)
newtype ObjectPath = ObjectPath
	{ strObjectPath :: Text
	}
	deriving (Show, Eq, Ord, Typeable)

@ An object path may be one of

\begin{itemize}
\item The root path, {\tt "/"}.
\item {\tt '/'}, followed by one or more element names. Each element name
      contains characters in the set {\tt [a-zA-Z0-9\_]}, and must have at
      least one character.
\end{itemize}

Element names are separated by {\tt '/'}, and the path may not end in
{\tt '/'} unless it is the root path.

<<DBus/Types.hs>>=
mkObjectPath :: Text -> Maybe ObjectPath
mkObjectPath s = parseMaybe path' (TL.unpack s) where
	c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"
	path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char
	path' = path >> P.eof >> return (ObjectPath s)

mkObjectPath' :: Text -> ObjectPath
mkObjectPath' = mkUnsafe "object path" mkObjectPath

<<type exports>>=
  -- * Object paths
, ObjectPath
, strObjectPath
, mkObjectPath
, mkObjectPath'

@ \subsection{Arrays}

Arrays are homogenous sequences of any valid D-Bus type. Arrays might be
empty, so the type they contain is stored instead of being calculated from
their contents (as in {\tt variantType}).

Many D-Bus APIs represent binary data using an array of bytes; therefore,
there is a special constructor for {\tt ByteString}-based arrays.

<<type imports>>=
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as ByteString

<<DBus/Types.hs>>=
INSTANCE_VARIABLE(Array)
data Array
	= VariantArray Type [Variant]
	| ByteArray ByteString
	deriving (Eq, Typeable)

instance Builtin Array where
	builtinDBusType = DBusArray . arrayType

arrayType :: Array -> Type
arrayType (VariantArray t _) = t
arrayType (ByteArray _) = DBusByte

arrayItems :: Array -> [Variant]
arrayItems (VariantArray _ xs) = xs
arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs

<<type exports>>=
  -- * Arrays
, Array
, arrayType
, arrayItems

@ Like {\tt Variant}, deriving {\tt Show} for {\tt Array} is mostly
just useful for debugging.

<<DBus/Types.hs>>=
instance Show Array where
	showsPrec d array = showParen (d > 10) $
		s "Array " . showSig . s " [" . s valueString . s "]" where
			s = showString
			showSig = shows . typeCode . arrayType $ array
			vs = [show x | (Variant x) <- arrayItems array]
			valueString = intercalate ", " vs

@ Clients constructing an array must provide the expected item type, which
will be checked for validity. Every item in the array will be checked against
the item type, to ensure the array is homogenous.

<<DBus/Types.hs>>=
arrayFromItems :: Type -> [Variant] -> Maybe Array
arrayFromItems DBusByte vs = do
	bytes <- mapM fromVariant vs
	Just . ByteArray . ByteString.pack $ bytes

arrayFromItems t vs = do
	mkSignature (typeCode t)
	if all (\x -> variantType x == t) vs
		then Just $ VariantArray t vs
		else Nothing

@ Additionally, for ease of use, an {\tt Array} can be converted directly
to/from lists of {\tt Variable} values.

<<DBus/Types.hs>>=
toArray :: Variable a => Type -> [a] -> Maybe Array
toArray t = arrayFromItems t . map toVariant

fromArray :: Variable a => Array -> Maybe [a]
fromArray = mapM fromVariant . arrayItems

<<type exports>>=
, toArray
, fromArray
, arrayFromItems

@ To provide a more efficient interface for byte array literals, these
functions bypass the conversions in {\tt toArray} and {\tt fromArray}

<<DBus/Types.hs>>=
arrayToBytes :: Array -> Maybe ByteString
arrayToBytes (ByteArray x) = Just x
arrayToBytes _             = Nothing

arrayFromBytes :: ByteString -> Array
arrayFromBytes = ByteArray

<<type exports>>=
, arrayToBytes
, arrayFromBytes

@ And to simplify inclusion of {\tt ByteString}s in message, instances of
{\tt Variable} exist for both strict and lazy {\tt ByteString}.

<<DBus/Types.hs>>=
instance Variable ByteString where
	toVariant = toVariant . arrayFromBytes
	fromVariant x = fromVariant x >>= arrayToBytes

<<type imports>>=
import qualified Data.ByteString as StrictByteString

<<DBus/Types.hs>>=
instance Variable StrictByteString.ByteString where
	toVariant x = toVariant . arrayFromBytes $ ByteString.fromChunks [x]
	fromVariant x = do
		chunks <- ByteString.toChunks `fmap` fromVariant x
		return $ StrictByteString.concat chunks

@ \subsection{Dictionaries}

Dictionaries are a homogenous (key $\rightarrow$ value) mapping, where the
key type must be atomic. Values may be of any valid D-Bus type. Like
{\tt Array}, {\tt Dictionary} stores its contained types.

<<DBus/Types.hs>>=
INSTANCE_VARIABLE(Dictionary)
data Dictionary = Dictionary
	{ dictionaryKeyType   :: Type
	, dictionaryValueType :: Type
	, dictionaryItems     :: [(Variant, Variant)]
	}
	deriving (Eq, Typeable)

instance Builtin Dictionary where
	builtinDBusType (Dictionary kt vt _) = DBusDictionary kt vt

<<type exports>>=
  -- * Dictionaries
, Dictionary
, dictionaryItems
, dictionaryKeyType
, dictionaryValueType

@ {\tt show}ing a {\tt Dictionary} displays the mapping in a more readable
format than a list of pairs.

<<type imports>>=
import Data.List (intercalate)

<<DBus/Types.hs>>=
instance Show Dictionary where
	showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $
		s "Dictionary " . showSig . s " {" . s valueString . s "}" where
			s = showString
			showSig = shows $ TL.append (typeCode kt) (typeCode vt)
			valueString = intercalate ", " $ map showPair pairs
			showPair ((Variant k), (Variant v)) =
				show k ++ " -> " ++ show v

@ Constructing a {\tt Dictionary} works like constructing an {\tt Array},
except that there are two types to check, and the key type must be atomic.

<<type imports>>=
import Control.Monad (unless)

<<DBus/Types.hs>>=
dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary
dictionaryFromItems kt vt pairs = do
	unless (isAtomicType kt) Nothing
	mkSignature (typeCode kt)
	mkSignature (typeCode vt)
	
	let sameType (k, v) = variantType k == kt &&
	                      variantType v == vt
	if all sameType pairs
		then Just $ Dictionary kt vt pairs
		else Nothing

@ The closest match for dictionary semantics in Haskell is the
{\tt Data.Map.Map} type. Therefore, the utility conversion functions work
with {\tt Map}s instead of pair lists.

<<type imports>>=
import Control.Arrow ((***))
import qualified Data.Map as Map

<<DBus/Types.hs>>=
toDictionary :: (Variable a, Variable b) => Type -> Type -> Map.Map a b
             -> Maybe Dictionary
toDictionary kt vt = dictionaryFromItems kt vt . pairs where
	pairs = map (toVariant *** toVariant) . Map.toList

<<type imports>>=
import Control.Monad (forM)

<<DBus/Types.hs>>=
fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary
               -> Maybe (Map.Map a b)
fromDictionary (Dictionary _ _ vs) = do
	pairs <- forM vs $ \(k, v) -> do
		k' <- fromVariant k
		v' <- fromVariant v
		return (k', v')
	return $ Map.fromList pairs

<<type exports>>=
, toDictionary
, fromDictionary
, dictionaryFromItems

@ \subsubsection{Converting between {\tt Array} and {\tt Dictionary}}

Converting between {\tt Array} and {\tt Dictionary} is useful when
(un)marshaling -- dictionaries can be thought of as arrays of two-element
structures, much as a {\tt Map} is a list of pairs.

<<DBus/Types.hs>>=
dictionaryToArray :: Dictionary -> Array
dictionaryToArray (Dictionary kt vt items) = array where
	Just array = toArray itemType structs
	itemType = DBusStructure [kt, vt]
	structs = [Structure [k, v] | (k, v) <- items]

<<DBus/Types.hs>>=
arrayToDictionary :: Array -> Maybe Dictionary
arrayToDictionary array = do
	let toPair x = do
		struct <- fromVariant x
		case struct of
			Structure [k, v] -> Just (k, v)
			_                -> Nothing
	(kt, vt) <- case arrayType array of
		DBusStructure [kt, vt] -> Just (kt, vt)
		_                      -> Nothing
	pairs <- mapM toPair $ arrayItems array
	dictionaryFromItems kt vt pairs

<<type exports>>=
, dictionaryToArray
, arrayToDictionary

@ \subsection{Structures}

A heterogeneous, fixed-length container; equivalent in purpose to a Haskell
tuple.

<<DBus/Types.hs>>=
INSTANCE_VARIABLE(Structure)
data Structure = Structure [Variant]
	deriving (Show, Eq, Typeable)

instance Builtin Structure where
	builtinDBusType (Structure vs) = DBusStructure $ map variantType vs

<<type exports>>=
  -- * Structures
, Structure (..)

@ \subsection{Names}

Various aspects of D-Bus require the use of specially-formatted strings,
called ``names''. All names are limited to 255 characters, and use subsets
of ASCII.

Since all names have basically the same structure (a {\tt newtype}
declaration and some helper functions), I define a macro to automate
the definitions.

<<DBus/Types.hs>>=
#define NAME_TYPE(TYPE, NAME) \
	newtype TYPE = TYPE {str##TYPE :: Text} \
		deriving (Show, Eq, Ord); \
		                          \
	instance Variable TYPE where \
		{ toVariant = toVariant . str##TYPE \
		; fromVariant = (mk##TYPE =<<) . fromVariant }; \
		                                                \
	mk##TYPE##' :: Text -> TYPE; \
	mk##TYPE##' = mkUnsafe NAME mk##TYPE

<<type exports>>=
-- * Names

@ \subsubsection{Bus names}

There are two forms of bus names, ``unique'' and ``well-known''.

Unique names begin with {\tt `:'} and contain two or more elements, separated
by {\tt `.'}. Each element consists of characters from the set
{\tt [a-zA-Z0-9\_-]}.

Well-known names contain two or more elements, separated by {\tt `.'}. Each
element consists of characters from the set {\tt [a-zA-Z0-9\_-]}, and must
not start with a digit.

<<DBus/Types.hs>>=
NAME_TYPE(BusName, "bus name")

mkBusName :: Text -> Maybe BusName
mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where
	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"
	c' = c ++ ['0'..'9']
	parser = (unique <|> wellKnown) >> P.eof >> return (BusName s)
	unique = P.char ':' >> elems c'
	wellKnown = elems c
	elems start = elem' start >> P.many1 (P.char '.' >> elem' start)
	elem' start = P.oneOf start >> P.many (P.oneOf c')

<<type exports>>=
  -- ** Bus names
, BusName
, strBusName
, mkBusName
, mkBusName'

@ \subsubsection{Interface names}

An interface name consists of two or more {\tt '.'}-separated elements. Each
element constists of characters from the set {\tt [a-zA-Z0-9\_]}, may not
start with a digit, and must have at least one character.

<<DBus/Types.hs>>=
NAME_TYPE(InterfaceName, "interface name")

mkInterfaceName :: Text -> Maybe InterfaceName
mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where
	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"
	c' = c ++ ['0'..'9']
	element = P.oneOf c >> P.many (P.oneOf c')
	name = element >> P.many1 (P.char '.' >> element)
	parser = name >> P.eof >> return (InterfaceName s)

<<type exports>>=
  -- ** Interface names
, InterfaceName
, strInterfaceName
, mkInterfaceName
, mkInterfaceName'

@ \subsubsection{Error names}

Error names have the same format as interface names, so the parser logic
can just be re-purposed.

<<DBus/Types.hs>>=
NAME_TYPE(ErrorName, "error name")

mkErrorName :: Text -> Maybe ErrorName
mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName

<<type exports>>=
  -- ** Error names
, ErrorName
, strErrorName
, mkErrorName
, mkErrorName'

@ \subsubsection{Member names}

Member names must contain only characters from the set {\tt [a-zA-Z0-9\_]},
may not begin with a digit, and must be at least one character long.

<<DBus/Types.hs>>=
NAME_TYPE(MemberName, "member name")

mkMemberName :: Text -> Maybe MemberName
mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where
	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"
	c' = c ++ ['0'..'9']
	name = P.oneOf c >> P.many (P.oneOf c')
	parser = name >> P.eof >> return (MemberName s)

<<type exports>>=
  -- ** Member names
, MemberName
, strMemberName
, mkMemberName
, mkMemberName'

@
\section{Messages}

@ To prevent internal details of messages from leaking out to clients,
declarations are contained in an internal module and then re-exported
in the public module.

<<DBus/Message.hs>>=
<<copyright>>
module DBus.Message
	(<<message exports>>
	) where
import DBus.Message.Internal

<<DBus/Message/Internal.hs>>=
<<copyright>>
<<text extensions>>
module DBus.Message.Internal where
<<text imports>>
import qualified Data.Set as S
import Data.Word (Word8, Word32)
import Data.Maybe (fromMaybe)
import qualified DBus.Types as T
import DBus.Util (maybeIndex)

<<DBus/Message/Internal.hs>>=
class Message a where
	messageTypeCode     :: a -> Word8
	messageHeaderFields :: a -> [HeaderField]
	messageFlags        :: a -> S.Set Flag
	messageBody         :: a -> [T.Variant]

<<message exports>>=
Message ( messageFlags
        , messageBody
        )

@ \subsection{Flags}

The instance of {\tt Ord} only exists for storing flags in a set. Flags have
no inherent ordering.

<<DBus/Message/Internal.hs>>=
data Flag
	= NoReplyExpected
	| NoAutoStart
	deriving (Show, Eq, Ord)

<<message exports>>=
, Flag (..)

@ \subsection{Header fields}

<<DBus/Message/Internal.hs>>=
data HeaderField
	= Path        T.ObjectPath
	| Interface   T.InterfaceName
	| Member      T.MemberName
	| ErrorName   T.ErrorName
	| ReplySerial Serial
	| Destination T.BusName
	| Sender      T.BusName
	| Signature   T.Signature
	deriving (Show, Eq)

@ \subsection{Serials}

{\tt Serial} is just a wrapper around {\tt Word32}, to provide a bit of
added type-safety.

<<DBus/Message/Internal.hs>>=
newtype Serial = Serial { serialValue :: Word32 }
	deriving (Eq, Ord)

instance Show Serial where
	show (Serial x) = show x

instance T.Variable Serial where
	toVariant (Serial x) = T.toVariant x
	fromVariant = fmap Serial . T.fromVariant

@ Additionally, some useful functions exist for incrementing serials.

<<DBus/Message/Internal.hs>>=
firstSerial :: Serial
firstSerial = Serial 1

nextSerial :: Serial -> Serial
nextSerial (Serial x) = Serial (x + 1)

@ The {\tt Serial} constructor isn't useful to clients, because building
arbitrary serials doesn't make any sense.

<<message exports>>=
, Serial
, serialValue

@ \subsection{Message types}

<<DBus/Message/Internal.hs>>=
maybe' :: (a -> b) -> Maybe a -> [b]
maybe' f = maybe [] (\x' -> [f x'])

@ \subsubsection{Method calls}

<<DBus/Message/Internal.hs>>=
data MethodCall = MethodCall
	{ methodCallPath        :: T.ObjectPath
	, methodCallMember      :: T.MemberName
	, methodCallInterface   :: Maybe T.InterfaceName
	, methodCallDestination :: Maybe T.BusName
	, methodCallFlags       :: S.Set Flag
	, methodCallBody        :: [T.Variant]
	}
	deriving (Show, Eq)

instance Message MethodCall where
	messageTypeCode _ = 1
	messageFlags      = methodCallFlags
	messageBody       = methodCallBody
	messageHeaderFields m = concat
		[ [ Path    $ methodCallPath m
		  ,  Member $ methodCallMember m
		  ]
		, maybe' Interface . methodCallInterface $ m
		, maybe' Destination . methodCallDestination $ m
		]

<<message exports>>=
, MethodCall (..)

@ \subsubsection{Method returns}

<<DBus/Message/Internal.hs>>=
data MethodReturn = MethodReturn
	{ methodReturnSerial      :: Serial
	, methodReturnDestination :: Maybe T.BusName
	, methodReturnBody        :: [T.Variant]
	}
	deriving (Show, Eq)

instance Message MethodReturn where
	messageTypeCode _ = 2
	messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]
	messageBody       = methodReturnBody
	messageHeaderFields m = concat
		[ [ ReplySerial $ methodReturnSerial m
		  ]
		, maybe' Destination . methodReturnDestination $ m
		]

<<message exports>>=
, MethodReturn (..)

@ \subsubsection{Errors}

<<DBus/Message/Internal.hs>>=
data Error = Error
	{ errorName        :: T.ErrorName
	, errorSerial      :: Serial
	, errorDestination :: Maybe T.BusName
	, errorBody        :: [T.Variant]
	}
	deriving (Show, Eq)

instance Message Error where
	messageTypeCode _ = 3
	messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]
	messageBody       = errorBody
	messageHeaderFields m = concat
		[ [ ErrorName   $ errorName m
		  , ReplySerial $ errorSerial m
		  ]
		, maybe' Destination . errorDestination $ m
		]

@ Errors usually contain a human-readable message in their first body field.
This function lets it be retrieved easily, with a fallback if no valid
message was found.

<<DBus/Message/Internal.hs>>=
errorMessage :: Error -> Text
errorMessage msg = fromMaybe "(no error message)" $ do
	field <- maybeIndex (errorBody msg) 0
	text <- T.fromVariant field
	if TL.null text
		then Nothing
		else return text

<<message exports>>=
, Error (..)
, errorMessage

@ \subsubsection{Signals}

<<DBus/Message/Internal.hs>>=
data Signal = Signal
	{ signalPath        :: T.ObjectPath
	, signalMember      :: T.MemberName
	, signalInterface   :: T.InterfaceName
	, signalDestination :: Maybe T.BusName
	, signalBody        :: [T.Variant]
	}
	deriving (Show, Eq)

instance Message Signal where
	messageTypeCode _ = 4
	messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]
	messageBody       = signalBody
	messageHeaderFields m = concat
		[ [ Path      $ signalPath m
		  , Member    $ signalMember m
		  , Interface $ signalInterface m
		  ]
		, maybe' Destination . signalDestination $ m
		]

<<message exports>>=
, Signal (..)

@ \subsubsection{Unknown messages}

Unknown messages are used for storing information about messages without
a recognised type code. They are not instances of {\tt Message}, because
if they were, then clients could accidentally send invalid messages over
the bus.

<<DBus/Message/Internal.hs>>=
data Unknown = Unknown
	{ unknownType    :: Word8
	, unknownFlags   :: S.Set Flag
	, unknownBody    :: [T.Variant]
	}
	deriving (Show, Eq)

<<message exports>>=
, Unknown (..)

@ \subsection{Received messages}

Messages received from a bus have additional fields which do not make sense
when sending.

If a message has an unknown type, its serial and origin are still useful
for sending an error reply.

<<DBus/Message/Internal.hs>>=
data ReceivedMessage
	= ReceivedMethodCall   Serial (Maybe T.BusName) MethodCall
	| ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn
	| ReceivedError        Serial (Maybe T.BusName) Error
	| ReceivedSignal       Serial (Maybe T.BusName) Signal
	| ReceivedUnknown      Serial (Maybe T.BusName) Unknown
	deriving (Show, Eq)

<<DBus/Message/Internal.hs>>=
receivedSerial :: ReceivedMessage -> Serial
receivedSerial (ReceivedMethodCall   s _ _) = s
receivedSerial (ReceivedMethodReturn s _ _) = s
receivedSerial (ReceivedError        s _ _) = s
receivedSerial (ReceivedSignal       s _ _) = s
receivedSerial (ReceivedUnknown      s _ _) = s

<<DBus/Message/Internal.hs>>=
receivedSender :: ReceivedMessage -> Maybe T.BusName
receivedSender (ReceivedMethodCall   _ s _) = s
receivedSender (ReceivedMethodReturn _ s _) = s
receivedSender (ReceivedError        _ s _) = s
receivedSender (ReceivedSignal       _ s _) = s
receivedSender (ReceivedUnknown      _ s _) = s

<<DBus/Message/Internal.hs>>=
receivedBody :: ReceivedMessage -> [T.Variant]
receivedBody (ReceivedMethodCall   _ _ x) = messageBody x
receivedBody (ReceivedMethodReturn _ _ x) = messageBody x
receivedBody (ReceivedError        _ _ x) = messageBody x
receivedBody (ReceivedSignal       _ _ x) = messageBody x
receivedBody _ = []

<<message exports>>=
, ReceivedMessage (..)
, receivedSerial
, receivedSender
, receivedBody

@
\section{Wire format}

{\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>>=
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>>=
unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)
                 -> m (Either UnmarshalError M.ReceivedMessage)
unmarshalMessage getBytes' = E.runErrorT $ do
	let getBytes = E.lift . getBytes'
	
	<<read fixed-length header>>
	<<read full header>>
	<<read body>>
	<<build message>>

@ The first part of the header has a fixed size of 16 bytes, so it can be
retrieved without any size calculations.

<<read fixed-length header>>=
let fixedSig = T.mkSignature' "yyyyuuu"
fixedBytes <- getBytes 16

@ The first field of interest is the protocol version; if the incoming
message's version is different from this library, the message cannot be
parsed.

<<read fixed-length header>>=
let messageVersion = L.index fixedBytes 3
when (messageVersion /= C.protocolVersion) $
	E.throwError $ UnsupportedProtocolVersion messageVersion

@ Next is the endianness, used for parsing pretty much every other field.

<<read fixed-length header>>=
let eByte = L.index fixedBytes 0
endianness <- case decodeEndianness eByte of
	Just x' -> return x'
	Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte

@ With the endianness out of the way, the rest of the fixed header
can be decoded

<<read fixed-length header>>=
let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of
	Right x' -> return x'
	Left  e  -> E.throwError e
fixed <- unmarshal' fixedSig fixedBytes
let typeCode = fromJust . T.fromVariant $ fixed !! 1
let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2
let bodyLength = fromJust . T.fromVariant $ fixed !! 4
let serial = fromJust . T.fromVariant $ fixed !! 5

@ The last field of the fixed header is actually part of the field array,
but is treated as a single {\tt Word32} so it'll be known how many bytes
to retrieve.

<<read fixed-length header>>=
let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6

@ With the field byte count, the remainder of the header bytes can be
pulled out of the monad.

<<read full header>>=
let headerSig  = T.mkSignature' "yyyyuua(yv)"
fieldBytes <- getBytes fieldByteCount
let headerBytes = L.append fixedBytes fieldBytes
header <- unmarshal' headerSig headerBytes

@ And the header fields can be parsed.

<<read full header>>=
let fieldArray = fromJust . T.fromVariant $ header !! 6
let fieldStructures = fromJust . T.fromArray $ fieldArray
fields <- concat `fmap` mapM decodeField fieldStructures

@ The body is always aligned to 8 bytes, so pull out the padding before
unmarshaling it.

<<read body>>=
let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8
getBytes . fromIntegral $ bodyPadding

<<DBus/Wire/Internal.hs>>=
findBodySignature :: [M.HeaderField] -> T.Signature
findBodySignature fields = fromMaybe empty signature where
	empty = T.mkSignature' ""
	signature = listToMaybe [x | M.Signature x <- fields]

<<read body>>=
let bodySig = findBodySignature fields

@ Then pull the body bytes, and unmarshal it.

<<read body>>=
bodyBytes <- getBytes bodyLength
body <- unmarshal' bodySig bodyBytes

@ Even if the received message was structurally valid, building the
{\tt ReceivedMessage} can still fail due to missing header fields.

<<build message>>=
y <- case buildReceivedMessage typeCode fields of
	Right x -> return x
	Left x -> E.throwError $ MissingHeaderField x

<<build message>>=
return $ y serial flags body

@ This really belongs in the Message section...

<<DBus/Wire/Internal.hs>>=
buildReceivedMessage :: Word8 -> [M.HeaderField] -> Either 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] -> Either Text a
require _     (x:_) = Right x
require label _     = Left label

@ This is just needed for the Monad instance of {\tt Either Text}

<<DBus/Wire/Internal.hs>>=
instance E.Error Text where
	strMsg = TL.pack

@
\section{Addresses}

<<DBus/Address.hs>>=
<<copyright>>
<<text extensions>>
module DBus.Address
	( Address
	, addressMethod
	, addressParameters
	, mkAddresses
	, strAddress
	) where
<<text imports>>

import Data.Char (ord, chr)
import qualified Data.Map as M
import Text.Printf (printf)
import qualified Text.Parsec as P
import Text.Parsec ((<|>))
import DBus.Util (hexToInt, eitherToMaybe)

@ \subsection{Address syntax}

A bus address is in the format {\tt $method$:$key$=$value$,$key$=$value$...}
where the method may be empty and parameters are optional. An address's
parameter list, if present, may end with a comma. Addresses in environment
variables are separated by semicolons, and the full address list may end
in a semicolon. Multiple parameters may have the same key; in this case,
only the first parameter for each key will be stored.

The bytes allowed in each component of the address are given by the following
chart, where each character is understood to be its ASCII value:

\begin{table}[h]
\begin{center}
\begin{tabular}{ll}
\toprule
Component   & Allowed Characters \\
\midrule
Method      & Any except {\tt `;'} and {\tt `:'} \\
Param key   & Any except {\tt `;'}, {\tt `,'}, and {\tt `='} \\
Param value & {\tt `0'} to {\tt `9'} \\
            & {\tt `a'} to {\tt `z'} \\
            & {\tt `A'} to {\tt `Z'} \\
            & Any of: {\tt - \textunderscore{} / \textbackslash{} * . \%} \\
\bottomrule
\end{tabular}
\end{center}
\end{table}

In parameter values, any byte may be encoded by prepending the \% character
to its value in hexadecimal. \% is not allowed to appear unless it is
followed by two hexadecimal digits. Every other allowed byte is termed
an ``optionally encoded'' byte, and may appear unescaped in parameter
values.

<<DBus/Address.hs>>=
optionallyEncoded :: [Char]
optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."

@
The address simply stores its method and parameter map, with a custom
{\tt Show} instance to provide easier debugging.

<<DBus/Address.hs>>=
data Address = Address
	{ addressMethod     :: Text
	, addressParameters :: M.Map Text Text
	} deriving (Eq)

instance Show Address where
	showsPrec d x = showParen (d> 10) $
		showString "Address " . shows (strAddress x)

@
Parsing is straightforward; the input string is divided into addresses by
semicolons, then further by colons and commas. Parsing will fail if any
of the addresses in the input failed to parse.

<<DBus/Address.hs>>=
mkAddresses :: Text -> Maybe [Address]
mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where
	address = do
		method <- P.many (P.noneOf ":;")
		P.char ':'
		params <- P.sepEndBy param (P.char ',')
		return $ Address (TL.pack method) (M.fromList params)
	
	param = do
		key <- P.many1 (P.noneOf "=;,")
		P.char '='
		value <- P.many1 (encodedValue <|> unencodedValue)
		return (TL.pack key, TL.pack value)
	
	parser = do
		as <- P.sepEndBy1 address (P.char ';')
		P.eof
		return as
	
	unencodedValue = P.oneOf optionallyEncoded
	encodedValue = do
		P.char '%'
		hex <- P.count 2 P.hexDigit
		return . chr . hexToInt $ hex

@
Converting an {\tt Address} back to a {\tt String} is just the reverse
operation. Note that because the original parameter order is not preserved,
the string produced might differ from the original input.

<<DBus/Address.hs>>=
strAddress :: Address -> Text
strAddress (Address t ps) = TL.concat [t, ":", ps'] where
	ps' = TL.intercalate "," $ do
		(k, v) <- M.toList ps
		return $ TL.concat [k, "=", TL.concatMap encode v]
	encode c | elem c optionallyEncoded = TL.singleton c
	         | otherwise       = TL.pack $ printf "%%%02X" (ord c)

@
\section{Connections}

<<DBus/Connection.hs>>=
<<copyright>>
<<text extensions>>
{-# LANGUAGE DeriveDataTypeable #-}
module DBus.Connection
	( <<connection exports>>
	) where
<<text imports>>
<<connection imports>>

@ A {\tt Connection} is an opaque handle to an open D-Bus channel, with
an internal state for maintaining the current message serial.

The second {\tt MVar} doesn't really store a value, it's just used to
prevent two separate threads from reading from the transport at once.

<<connection imports>>=
import qualified Control.Concurrent as C
import qualified DBus.Address as A
import qualified DBus.Message.Internal as M

<<DBus/Connection.hs>>=
data Connection = Connection A.Address Transport (C.MVar M.Serial) (C.MVar ())

<<connection exports>>=
  Connection

@ While not particularly useful for other functions, being able to
{\tt show} a {\tt Connection} is useful when debugging.

<<DBus/Connection.hs>>=
instance Show Connection where
	showsPrec d (Connection a _ _ _) = showParen (d > 10) $
		showString' ["<connection ", show $ A.strAddress a, ">"] where
		showString' = foldr (.) id . map showString

@ \subsection{Transports}

A transport is anything which can send and receive bytestrings, typically
over a socket.

<<connection imports>>=
import qualified Data.ByteString.Lazy as L
import Data.Word (Word32)

<<DBus/Connection.hs>>=
data Transport = Transport
	{ transportSend :: L.ByteString -> IO ()
	, transportRecv :: Word32 -> IO L.ByteString
	}

@ If a method has no known transport, attempting to connect using it will
just result in an exception.

<<DBus/Connection.hs>>=
connectTransport :: A.Address -> IO Transport
connectTransport a = transport' (A.addressMethod a) a where
	transport' "unix" = unix
	transport' "tcp"  = tcp
	transport' _      = E.throwIO . UnknownMethod

@ \subsubsection{UNIX}

The {\sc unix} transport accepts two parameters: {\tt path}, which is a
simple filesystem path, and {\tt abstract}, which is a path in the
Linux-specific abstract domain. One, and only one, of these parameters must
be specified.

<<connection imports>>=
import qualified Network as N
import qualified Data.Map as Map

<<DBus/Connection.hs>>=
unix :: A.Address -> IO Transport
unix a = port >>= N.connectTo "localhost" >>= handleTransport where
	params = A.addressParameters a
	path = Map.lookup "path" params
	abstract = Map.lookup "abstract" params
	
	tooMany = "Only one of `path' or `abstract' may be specified for the\
	          \ `unix' transport."
	tooFew = "One of `path' or `abstract' must be specified for the\
	         \ `unix' transport."
	
	port = fmap N.UnixSocket path'
	path' = case (path, abstract) of
		(Just _, Just _) -> E.throwIO $ BadParameters a tooMany
		(Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew
		(Just x, Nothing) -> return $ TL.unpack x
		(Nothing, Just x) -> return $ '\x00' : TL.unpack x

@ \subsubsection{TCP}

The {\sc tcp} transport has three parameters:

\begin{itemize}
\item {\tt host} -- optional, defaults to {\tt "localhost"}
\item {\tt port} -- unsigned 16-bit integer
\item {\tt family} -- optional, defaults to {\sc unspec}, choices are
      {\tt "ipv4"} or {\tt "ipv6"}
\end{itemize}

The high-level {\tt Network} module doesn't provide enough control over
socket construction for this transport, so {\tt Network.Socket} must be
imported.

<<connection imports>>=
import qualified Network.Socket as NS

<<DBus/Connection.hs>>=
tcp :: A.Address -> IO Transport
tcp a = openHandle >>= handleTransport where
	params = A.addressParameters a
	openHandle = do
		port <- getPort
		family <- getFamily
		addresses <- getAddresses family
		socket <- openSocket port addresses
		NS.socketToHandle socket I.ReadWriteMode

@ Parameter parsing...

<<DBus/Connection.hs>>=
	hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params

<<DBus/Connection.hs>>=
	unknownFamily x = TL.concat ["Unknown socket family for TCP transport: ", x]
	getFamily = case Map.lookup "family" params of
		Just "ipv4" -> return NS.AF_INET
		Just "ipv6" -> return NS.AF_INET6
		Nothing     -> return NS.AF_UNSPEC
		Just x      -> E.throwIO $ BadParameters a $ unknownFamily x

<<DBus/Connection.hs>>=
	missingPort = "TCP transport requires the ``port'' parameter."
	badPort x = TL.concat ["Invalid socket port for TCP transport: ", x]
	getPort = case Map.lookup "port" params of
		Nothing -> E.throwIO $ BadParameters a missingPort
		Just x -> case P.parse parseWord16 "" (TL.unpack x) of
			Right x' -> return $ NS.PortNum x'
			Left  _  -> E.throwIO $ BadParameters a $ badPort x

@ Parsing the port is a bit complicated; assuming every character is an ASCII
digit, the port is converted to an {\tt Integer} and confirmed valid.
{\tt PortNumber} is expected to be in big-endian byte order, so the parsed
value must be converted from host order using {\tt Data.Binary}.

<<connection imports>>=
import qualified Text.Parsec as P
import Control.Monad (unless)
import Data.Binary.Get (runGet, getWord16host)
import Data.Binary.Put (runPut, putWord16be)

<<DBus/Connection.hs>>=
	parseWord16 = do
		chars <- P.many1 P.digit
		P.eof
		let value = read chars :: Integer
		unless (value > 0 && value <= 65535) $
			P.parserFail "bad port" >> return ()
		let word = fromIntegral value
		return $ runGet getWord16host (runPut (putWord16be word))

<<DBus/Connection.hs>>=
	getAddresses family = do
		let hints = NS.defaultHints
			{ NS.addrFlags = [NS.AI_ADDRCONFIG]
			, NS.addrFamily = family
			, NS.addrSocketType = NS.Stream
			}
		NS.getAddrInfo (Just hints) (Just hostname) Nothing

@ The {\tt SockAddr} values returned from {\tt getAddrInfo} don't have any
port set, so it must be manually changed to whatever was in the {\tt port}
option.

<<DBus/Connection.hs>>=
	setPort port (NS.SockAddrInet  _ x)     = NS.SockAddrInet port x
	setPort port (NS.SockAddrInet6 _ x y z) = NS.SockAddrInet6 port x y z
	setPort _    addr                       = addr

@ {\tt getAddrInfo} returns multiple addresses; each one is tried in turn,
until a valid address is found. If none are found, or are usable, an
exception will be thrown.

<<DBus/Connection.hs>>=
	openSocket _ [] = E.throwIO $ NoWorkingAddress [a]
	openSocket port (addr:addrs) = E.catch (openSocket' port addr) $
		\(E.SomeException _) -> openSocket port addrs
	openSocket' port addr = do
		sock <- NS.socket (NS.addrFamily addr)
		                  (NS.addrSocketType addr)
		                  (NS.addrProtocol addr)
		NS.connect sock . setPort port . NS.addrAddress $ addr
		return sock

@ \subsubsection{Generic handle-based transport}

Both UNIX and TCP are backed by standard handles, and can therefore use
a shared handle-based transport backend.

<<connection imports>>=
import qualified System.IO as I

<<DBus/Connection.hs>>=
handleTransport :: I.Handle -> IO Transport
handleTransport h = do
	I.hSetBuffering h I.NoBuffering
	I.hSetBinaryMode h True
	return $ Transport (L.hPut h) (L.hGet h . fromIntegral)

@ \subsection{Errors}

If connecting to D-Bus fails, a {\tt ConnectionError} will be thrown.
The constructor describes which exception occurred.

<<connection imports>>=
import qualified Control.Exception as E
import Data.Typeable (Typeable)

<<DBus/Connection.hs>>=
data ConnectionError
	= InvalidAddress Text
	| BadParameters A.Address Text
	| UnknownMethod A.Address
	| NoWorkingAddress [A.Address]
	deriving (Show, Typeable)

instance E.Exception ConnectionError

<<connection exports>>=
, ConnectionError (..)

@ \subsection{Establishing a connection}

A connection can be opened to any valid address, though actually connecting
might fail due to external factors.

<<connection imports>>=
import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)

<<DBus/Connection.hs>>=
connect :: A.Address -> IO Connection
connect a = do
	t <- connectTransport a
	let putS = transportSend t . encodeUtf8 . TL.pack
	let getS = fmap (TL.unpack . decodeUtf8) . transportRecv t
	authenticate putS getS
	readLock <- C.newMVar ()
	serialMVar <- C.newMVar M.firstSerial
	return $ Connection a t serialMVar readLock

@ Since addresses usually come in a list, it's sensible to have a variant
of {\tt connect} which tries multiple addresses. The first successfully
opened {\tt Connection} is returned.

<<DBus/Connection.hs>>=
connectFirst :: [A.Address] -> IO Connection
connectFirst orig = connectFirst' orig where
	connectFirst'     [] = E.throwIO $ NoWorkingAddress orig
	connectFirst' (a:as) = E.catch (connect a) $
		\(E.SomeException _) -> connectFirst' as

<<connection exports>>=
, connect
, connectFirst

@ \subsection{Authentication}

<<DBus/Connection.hs>>=
authenticate :: (String -> IO ()) -> (Word32 -> IO String)
                -> IO ()
authenticate put get = do
	put "\x00"

@ {\sc external} authentication is performed using the process's real user
ID, converted to a string, and then hex-encoded.

<<connection imports>>=
import System.Posix.User (getRealUserID)
import Data.Char (ord)
import Text.Printf (printf)

<<DBus/Connection.hs>>=
	uid <- getRealUserID
	let authToken = concatMap (printf "%02X" . ord) (show uid)
	put $ "AUTH EXTERNAL " ++ authToken ++ "\r\n"

@ If authentication was successful, the server responds with {\tt OK
<server GUID>}.  The GUID is intended to enable connection sharing, which
is currently unimplemented, so it's ignored.

<<connection imports>>=
import Data.List (isPrefixOf)

<<DBus/Connection.hs>>=
	response <- readUntil '\n' get
	if "OK" `isPrefixOf` response
		then put "BEGIN\r\n"
		else do
			putStrLn $ "response = " ++ show response
			error "Server rejected authentication token."

<<DBus/Connection.hs>>=
readUntil :: Monad m => Char -> (Word32 -> m String) -> m String
readUntil = readUntil' "" where
	readUntil' xs c f = do
		[x] <- f 1
		let xs' = xs ++ [x]
		if x == c
			then return xs'
			else readUntil' xs' c f

@ \subsection{Sending and receiving messages}

Sending a message will increment the connection's internal serial state.
The second parameter is present to allow registration of a callback before
the message has actually been sent, which avoids race conditions in
multi-threaded clients.

<<connection imports>>=
import qualified DBus.Wire as W

<<DBus/Connection.hs>>=
send :: M.Message a => Connection -> (M.Serial -> IO b) -> a
     -> IO (Either W.MarshalError b)
send (Connection _ t mvar _) io msg = withSerial mvar $ \serial ->
	case W.marshalMessage W.LittleEndian serial msg of
		Right bytes -> do
			x <- io serial
			transportSend t bytes
			return $ Right x
		Left  err   -> return $ Left err

<<connection exports>>=
, send

<<DBus/Connection.hs>>=
withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a
withSerial m io = E.block $ do
	s <- C.takeMVar m
	let s' = M.nextSerial s
	x <- E.unblock (io s) `E.onException` C.putMVar m s'
	C.putMVar m s'
	return x

@ Messages are received wrapped in a {\tt ReceivedMessage} value. If an
error is encountered while unmarshaling, an exception will be thrown.

<<DBus/Connection.hs>>=
receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage)
receive (Connection _ t _ lock) = C.withMVar lock $ \_ ->
	W.unmarshalMessage $ transportRecv t

<<connection exports>>=
, receive

@
\section{The central bus}

<<DBus/Bus.hs>>=
<<copyright>>
<<text extensions>>
module DBus.Bus
	( getBus
	, getFirstBus
	, getSystemBus
	, getSessionBus
	, getStarterBus
	) where
<<text imports>>

import qualified Control.Exception as E
import Control.Monad (when)
import Data.Maybe (fromJust, isNothing)
import qualified Data.Set as Set
import System.Environment (getEnv)

import qualified DBus.Address as A
import qualified DBus.Connection as C
import DBus.Constants (dbusName, dbusPath, dbusInterface)
import qualified DBus.Message as M
import qualified DBus.Types as T
import DBus.Util (fromRight)

@ Connecting to a message bus is a bit more involved than just connecting
over an app-to-app connection: the bus must be notified of the new client,
using a "hello message", before it will begin forwarding messages.

<<DBus/Bus.hs>>=
busForConnection :: C.Connection -> IO (C.Connection, T.BusName)
busForConnection c = sendHello c >>= return . (,) c

<<DBus/Bus.hs>>=
getBus :: A.Address -> IO (C.Connection, T.BusName)
getBus = (busForConnection =<<) . C.connect

@ Optionally, multiple addresses may be provided. The first successful
connection will be used.

<<DBus/Bus.hs>>=
getFirstBus :: [A.Address] -> IO (C.Connection, T.BusName)
getFirstBus = (busForConnection =<<) . C.connectFirst

@ \subsection{Default connections}

Two default buses are defined, the ``system'' and ``session'' buses. The system
bus is global for the OS, while the session bus runs only for the duration
of the user's session.

<<DBus/Bus.hs>>=
getSystemBus :: IO (C.Connection, T.BusName)
getSystemBus = getBus' $ fromEnv `E.catch` noEnv where
	defaultAddr = "unix:path=/var/run/dbus/system_bus_socket"
	fromEnv = getEnv "DBUS_SYSTEM_BUS_ADDRESS"
	noEnv (E.SomeException _) = return defaultAddr

<<DBus/Bus.hs>>=
getSessionBus :: IO (C.Connection, T.BusName)
getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS"

<<DBus/Bus.hs>>=
getStarterBus :: IO (C.Connection, T.BusName)
getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS"

<<DBus/Bus.hs>>=
getBus' :: IO String -> IO (C.Connection, T.BusName)
getBus' io = do
	addr <- fmap TL.pack io
	case A.mkAddresses addr of
		Just [x] -> getBus x
		Just  x  -> getFirstBus x
		_        -> E.throwIO $ C.InvalidAddress addr

@ \subsection{Sending the ``hello'' message}

<<DBus/Bus.hs>>=
hello :: M.MethodCall
hello = M.MethodCall dbusPath
	(T.mkMemberName' "Hello")
	(Just dbusInterface)
	(Just dbusName)
	Set.empty
	[]

<<DBus/Bus.hs>>=
sendHello :: C.Connection -> IO T.BusName
sendHello c = do
	serial <- fromRight `fmap` C.send c return hello
	reply <- waitForReply c serial
	let name = case M.methodReturnBody reply of
		(x:_) -> T.fromVariant x
		_     -> Nothing
	
	when (isNothing name) $
		E.throwIO $ E.AssertionFailed "Invalid response to Hello()"
	
	return . fromJust $ name

<<DBus/Bus.hs>>=
waitForReply :: C.Connection -> M.Serial -> IO M.MethodReturn
waitForReply c serial = do
	received <- C.receive c
	msg <- case received of
		Right x -> return x
		Left _  -> E.throwIO $ E.AssertionFailed "Invalid response to Hello()"
	case msg of
		(M.ReceivedMethodReturn _ _ reply) ->
			if M.methodReturnSerial reply == serial
				then return reply
				else waitForReply c serial
		_ -> waitForReply c serial

@
\section{Introspection}

@ D-Bus objects may be ``introspected'' to determine which methods, signals,
etc they support. Intospection data is sent over the bus in {\sc xml}, in
a mostly standardised but undocumented format.

An XML introspection document looks like this:

\begin{verbatim}
<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
         "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
<node name="/org/example/example">
	<interface name="org.example.ExampleInterface">
		<method name="Echo">
			<arg name="text" type="s" direction="in"/>
			<arg type="s" direction="out"/>
		</method>
		<signal name="Echoed">
			<arg type="s"/>
		</signal>
		<property name="EchoCount" type="u" access="read"/>
	</interface>
	<node name="child_a"/>
	<node name="child/b"/>
</node>
\end{verbatim}

<<DBus/Introspection.hs>>=
<<copyright>>
<<text extensions>>
module DBus.Introspection
	( Object (..)
	, Interface (..)
	, Method (..)
	, Signal (..)
	, Parameter (..)
	, Property (..)
	, PropertyAccess (..)
	, toXML
	, fromXML
	) where
<<text imports>>
<<introspection imports>>
import qualified DBus.Types as T

@ HaXml is used to do the heavy lifting of XML parsing because HXT cannot
be combined with Parsec 3.

<<introspection imports>>=
import qualified Text.XML.HaXml as H

@ \subsection{Data types}

<<DBus/Introspection.hs>>=
data Object = Object T.ObjectPath [Interface] [Object]
	deriving (Show, Eq)

data Interface = Interface T.InterfaceName [Method] [Signal] [Property]
	deriving (Show, Eq)

data Method = Method T.MemberName [Parameter] [Parameter]
	deriving (Show, Eq)

data Signal = Signal T.MemberName [Parameter]
	deriving (Show, Eq)

data Parameter = Parameter Text T.Signature
	deriving (Show, Eq)

data Property = Property Text T.Signature [PropertyAccess]
	deriving (Show, Eq)

data PropertyAccess = Read | Write
	deriving (Show, Eq)

@ \subsection{Parsing XML}

The root {\tt node} is special, in that it's the only {\tt node} which is
not required to have a {\tt name} attribute. If the root has no {\tt name},
its path will default to the path of the introspected object.

If parsing fails, {\tt fromXML} will return {\tt Nothing}. Aside from the
elements directly accessed by the parser, no effort is made to check the
document's validity because there is no DTD as of yet.

<<introspection imports>>=
import Text.XML.HaXml.Parse (xmlParse')
import DBus.Util (eitherToMaybe)

<<DBus/Introspection.hs>>=
fromXML :: T.ObjectPath -> Text -> Maybe Object
fromXML path text = do
	doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text
	let (H.Document _ _ root _) = doc
	parseRoot path root

@ Even though the root object's {\tt name} is optional, if present, it must
still be a valid object path.

<<DBus/Introspection.hs>>=
parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object
parseRoot defaultPath e = do
	path <- case getAttr "name" e of
		Nothing -> Just defaultPath
		Just x  -> T.mkObjectPath x
	parseObject' path e

@ Child {\tt nodes} have ``relative'' paths -- that is, their {\tt name}
attribute is not a valid object path, but should be valid when appended to
the root object's path.

<<DBus/Introspection.hs>>=
parseChild :: T.ObjectPath -> H.Element a -> Maybe Object
parseChild parentPath e = do
	let parentPath' = case T.strObjectPath parentPath of
		"/" -> "/"
		x   -> TL.append x "/"
	pathSegment <- getAttr "name" e
	path <- T.mkObjectPath $ TL.append parentPath' pathSegment
	parseObject' path e

@ Other than the name, both root and non-root {\tt nodes} have identical
contents.  They may contain interface definitions, and child {\tt node}s.

<<DBus/Introspection.hs>>=
parseObject' :: T.ObjectPath -> H.Element a -> Maybe Object
parseObject' path e@(H.Elem "node" _ _)  = do
	interfaces <- children parseInterface (H.tag "interface") e
	children' <- children (parseChild path) (H.tag "node") e
	return $ Object path interfaces children'
parseObject' _ _ = Nothing

@ Interfaces may contain methods, signals, and properties.

<<DBus/Introspection.hs>>=
parseInterface :: H.Element a -> Maybe Interface
parseInterface e = do
	name <- T.mkInterfaceName =<< getAttr "name" e
	methods <- children parseMethod (H.tag "method") e
	signals <- children parseSignal (H.tag "signal") e
	properties <- children parseProperty (H.tag "property") e
	return $ Interface name methods signals properties

@ Methods contain a list of parameters, which default to ``in'' parameters
if no direction is specified.

<<DBus/Introspection.hs>>=
parseMethod :: H.Element a -> Maybe Method
parseMethod e = do
	name <- T.mkMemberName =<< getAttr "name" e
	paramsIn <- children parseParameter (isParam ["in", ""]) e
	paramsOut <- children parseParameter (isParam ["out"]) e
	return $ Method name paramsIn paramsOut

@ Signals are similar to methods, except they have no ``in'' parameters.

<<DBus/Introspection.hs>>=
parseSignal :: H.Element a -> Maybe Signal
parseSignal e = do
	name <- T.mkMemberName =<< getAttr "name" e
	params <- children parseParameter (isParam ["out", ""]) e
	return $ Signal name params

@ A parameter has a free-form name, and a single valid type.

<<DBus/Introspection.hs>>=
parseParameter :: H.Element a -> Maybe Parameter
parseParameter e = do
	let name = getAttr' "name" e
	sig <- parseType e
	return $ Parameter name sig

<<DBus/Introspection.hs>>=
parseType :: H.Element a -> Maybe T.Signature
parseType e = do
	sig <- T.mkSignature =<< getAttr "type" e
	case T.signatureTypes sig of
		[_] -> Just sig
		_   -> Nothing

@ Properties are used by the {\tt org.freedesktop.DBus.Properties} interface.
Each property may be read, written, or both, and has an associated type.

<<DBus/Introspection.hs>>=
parseProperty :: H.Element a -> Maybe Property
parseProperty e = do
	let name = getAttr' "name" e
	sig <- parseType e
	access <- case getAttr' "access" e of
		""          -> Just []
		"read"      -> Just [Read]
		"write"     -> Just [Write]
		"readwrite" -> Just [Read, Write]
		_           -> Nothing
	return $ Property name sig access

@ HaXml doesn't seem to have any way to retrieve the ``real'' value of an
attribute, so {\tt attrValue} implements this.

<<introspection imports>>=
import Data.Char (chr)

<<DBus/Introspection.hs>>=
attrValue :: H.AttValue -> Maybe Text
attrValue attr = fmap (TL.pack . concat) $ mapM unescape parts where
	(H.AttValue parts) = attr
	
	unescape (Left x) = Just x
	unescape (Right (H.RefEntity x)) = lookup x namedRefs
	unescape (Right (H.RefChar x)) = Just [chr x]
	
	namedRefs =
		[ ("lt", "<")
		, ("gt", ">")
		, ("amp", "&")
		, ("apos", "'")
		, ("quot", "\"")
		]

@ Some helper functions for dealing with HaXml filters

<<introspection imports>>=
import Data.Maybe (fromMaybe)

<<DBus/Introspection.hs>>=
getAttr :: String -> H.Element a -> Maybe Text
getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue

getAttr' :: String -> H.Element a -> Text
getAttr' = (fromMaybe "" .) . getAttr

<<DBus/Introspection.hs>>=
isParam :: [Text] -> H.CFilter a
isParam dirs content = do
	arg@(H.CElem e _) <- H.tag "arg" content
	let direction = getAttr' "direction" e
	[arg | direction `elem` dirs]

<<DBus/Introspection.hs>>=
children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b]
children f filt (H.Elem _ _ contents) =
	mapM f [x | (H.CElem x _) <- concatMap filt contents]

@ \subsection{Generating XML}

<<DBus/Introspection.hs>>=
dtdPublicID, dtdSystemID :: String
dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"

@ HaXml punts to the {\tt pretty} package for serialising XML.

<<introspection imports>>=
import Text.XML.HaXml.Pretty (document)
import Text.PrettyPrint.HughesPJ (render)

@ Generating XML can fail; if a child object's path is not a sub-path of the
parent, {\tt toXML} will return {\tt Nothing}.

<<DBus/Introspection.hs>>=
toXML :: Object -> Maybe Text
toXML obj = fmap (TL.pack . render . document) doc where
	prolog = H.Prolog Nothing [] (Just doctype) []
	doctype = H.DTD "node" (Just (H.PUBLIC
		(H.PubidLiteral dtdPublicID)
		(H.SystemLiteral dtdSystemID))) []
	doc = do
		root <- xmlRoot obj
		return $ H.Document prolog H.emptyST root []

@ When writing objects to {\tt node}s, the root object must have an absolute
path, and children must have paths relative to their parent.

<<DBus/Introspection.hs>>=
xmlRoot :: Object -> Maybe (H.Element a)
xmlRoot obj@(Object path _ _) = do
	(H.CElem root _) <- xmlObject' (T.strObjectPath path) obj
	return root

<<DBus/Introspection.hs>>=
xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a)
xmlObject parentPath obj@(Object path _ _) = do
	let path' = T.strObjectPath path
	    parent' = T.strObjectPath parentPath
	relpath <- if TL.isPrefixOf parent' path'
		then Just $ if parent' == "/"
			then TL.drop 1 path'
			else TL.drop (TL.length parent' + 1) path'
		else Nothing
	xmlObject' relpath obj

<<DBus/Introspection.hs>>=
xmlObject' :: Text -> Object -> Maybe (H.Content a)
xmlObject' path (Object fullPath interfaces children') = do
	children'' <- mapM (xmlObject fullPath) children'
	return $ mkElement "node"
		[mkAttr "name" $ TL.unpack path]
		$ concat
			[ map xmlInterface interfaces
			, children''
			]

<<DBus/Introspection.hs>>=
xmlInterface :: Interface -> H.Content a
xmlInterface (Interface name methods signals properties) =
	mkElement "interface"
		[mkAttr "name" . TL.unpack . T.strInterfaceName $ name]
		$ concat
			[ map xmlMethod methods
			, map xmlSignal signals
			, map xmlProperty properties
			]

<<DBus/Introspection.hs>>=
xmlMethod :: Method -> H.Content a
xmlMethod (Method name inParams outParams) = mkElement "method"
	[mkAttr "name" . TL.unpack . T.strMemberName $ name]
	$ concat
		[ map (xmlParameter "in") inParams
		, map (xmlParameter "out") outParams
		]

<<DBus/Introspection.hs>>=
xmlSignal :: Signal -> H.Content a
xmlSignal (Signal name params) = mkElement "signal"
	[mkAttr "name" . TL.unpack . T.strMemberName $ name]
	$ map (xmlParameter "out") params

<<DBus/Introspection.hs>>=
xmlParameter :: String -> Parameter -> H.Content a
xmlParameter direction (Parameter name sig) = mkElement "arg"
	[ mkAttr "name" . TL.unpack $ name
	, mkAttr "type" . TL.unpack . T.strSignature $ sig
	, mkAttr "direction" direction
	] []

<<DBus/Introspection.hs>>=
xmlProperty :: Property -> H.Content a
xmlProperty (Property name sig access) = mkElement "property"
	[ mkAttr "name" . TL.unpack $ name
	, mkAttr "type" . TL.unpack . T.strSignature $ sig
	, mkAttr "access" $ xmlAccess access
	] []

<<DBus/Introspection.hs>>=
xmlAccess :: [PropertyAccess] -> String
xmlAccess access = readS ++ writeS where
	readS = if elem Read access then "read" else ""
	writeS = if elem Write access then "write" else ""

<<DBus/Introspection.hs>>=
mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a
mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined

<<DBus/Introspection.hs>>=
mkAttr :: String -> String -> H.Attribute
mkAttr name value = (name, H.AttValue [Left escaped]) where
	raw = H.CString True value ()
	escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw]

@
\section{Match rules}

Match rules are used indicate that the client is interested in messages
matching a particular filter. This module provides an interface for building
match rule strings. Eventually, it will support parsing them also.

<<DBus/MatchRule.hs>>=
<<copyright>>
<<text extensions>>
module DBus.MatchRule (
	  MatchRule (..)
	, MessageType (..)
	, ParameterValue (..)
	, formatRule
	, addMatch
	, matchAll
	, matches
	) where
<<text imports>>
import Data.Word (Word8)
import Data.Maybe (catMaybes, fromMaybe)
import qualified Data.Set as Set
import qualified DBus.Types as T
import qualified DBus.Message as M
import qualified DBus.Constants as C
import DBus.Util (maybeIndex)

@ A match rule is a set of filters; most filters may have one possible
value assigned, such as a single message type. The exception are parameter
filters, which are limited in number only by the server implementation.

<<DBus/MatchRule.hs>>=
data MatchRule = MatchRule
	{ matchType        :: Maybe MessageType
	, matchSender      :: Maybe T.BusName
	, matchInterface   :: Maybe T.InterfaceName
	, matchMember      :: Maybe T.MemberName
	, matchPath        :: Maybe T.ObjectPath
	, matchDestination :: Maybe T.BusName
	, matchParameters  :: [ParameterValue]
	}

@ Parameters may match against two types, strings and object paths. It's
probably an error to have two values for the same parameter.

The constructor {\tt StringValue 3 "hello"} means that the fourth parameter
in the message body must be the string ``hello''. {\tt PathValue} is the
same, but its value must be an object path.

<<DBus/MatchRule.hs>>=
data ParameterValue
	= StringValue Word8 Text
	| PathValue Word8 T.ObjectPath
	deriving (Show, Eq)

@ The set of allowed message types to filter on is separate from the set
supported for sending over the wire. This allows the server to support
additional types not yet implemented in the library, or vice-versa.

<<DBus/MatchRule.hs>>=
data MessageType
	= MethodCall
	| MethodReturn
	| Signal
	| Error
	deriving (Show, Eq)

@ There's currently only one operation to perform on match rules, and that's
to format them.

<<DBus/MatchRule.hs>>=
formatRule :: MatchRule -> Text
formatRule rule = TL.intercalate "," filters where
	filters = structureFilters ++ parameterFilters
	parameterFilters = map formatParameter $ matchParameters rule
	structureFilters = catMaybes $ map unpack
		[ ("type", fmap formatType . matchType)
		, ("sender", fmap T.strBusName . matchSender)
		, ("interface", fmap T.strInterfaceName . matchInterface)
		, ("member", fmap T.strMemberName . matchMember)
		, ("path", fmap T.strObjectPath . matchPath)
		, ("destination", fmap T.strBusName . matchDestination)
		]
	unpack (key, mkValue) = formatFilter' key `fmap` mkValue rule

<<DBus/MatchRule.hs>>=
formatParameter :: ParameterValue -> Text
formatParameter (StringValue index x) = formatFilter' key x where
	key = "arg" `TL.append` TL.pack (show index)
formatParameter (PathValue index x) = formatFilter' key value where
	key = "arg" `TL.append` TL.pack (show index) `TL.append` "path"
	value = T.strObjectPath x

@ FIXME: what are the escaping rules for match rules? Other bindings don't
seem to perform any escaping at all.

<<DBus/MatchRule.hs>>=
formatFilter' :: Text -> Text -> Text
formatFilter' key value = TL.concat [key, "='", value, "'"]

<<DBus/MatchRule.hs>>=
formatType :: MessageType -> Text
formatType MethodCall   = "method_call"
formatType MethodReturn = "method_return"
formatType Signal       = "signal"
formatType Error        = "error"

@ And since the only real reason for formatting a match rule is to send it,
it's useful to have a message-building function pre-defined.

<<DBus/MatchRule.hs>>=
addMatch :: MatchRule -> M.MethodCall
addMatch rule = M.MethodCall
	C.dbusPath
	(T.mkMemberName' "AddMatch")
	(Just C.dbusInterface)
	(Just C.dbusName)
	Set.empty
	[T.toVariant $ formatRule rule]

@ Most match rules will have only one or two fields filled in, so defining
an empty rule allows clients to set only the fields they care about.

<<DBus/MatchRule.hs>>=
matchAll :: MatchRule
matchAll = MatchRule
	{ matchType        = Nothing
	, matchSender      = Nothing
	, matchInterface   = Nothing
	, matchMember      = Nothing
	, matchPath        = Nothing
	, matchDestination = Nothing
	, matchParameters  = []
	}

@ It's useful to match against a rule client-side, eg when listening for
signals.

<<DBus/MatchRule.hs>>=
matches :: MatchRule -> M.ReceivedMessage -> Bool
matches rule msg = and . catMaybes . map ($ rule) $
	[ fmap      (typeMatches msg) . matchType
	, fmap    (senderMatches msg) . matchSender
	, fmap     (ifaceMatches msg) . matchInterface
	, fmap    (memberMatches msg) . matchMember
	, fmap      (pathMatches msg) . matchPath
	, fmap      (destMatches msg) . matchDestination
	, Just . parametersMatch msg  . matchParameters
	]

<<DBus/MatchRule.hs>>=
typeMatches :: M.ReceivedMessage -> MessageType -> Bool
typeMatches (M.ReceivedMethodCall   _ _ _) MethodCall   = True
typeMatches (M.ReceivedMethodReturn _ _ _) MethodReturn = True
typeMatches (M.ReceivedSignal       _ _ _) Signal       = True
typeMatches (M.ReceivedError        _ _ _) Error        = True
typeMatches _ _ = False


<<DBus/MatchRule.hs>>=
senderMatches :: M.ReceivedMessage -> T.BusName -> Bool
senderMatches msg name = M.receivedSender msg == Just name

<<DBus/MatchRule.hs>>=
ifaceMatches :: M.ReceivedMessage -> T.InterfaceName -> Bool
ifaceMatches (M.ReceivedMethodCall _ _ msg) name =
	Just name == M.methodCallInterface msg
ifaceMatches (M.ReceivedSignal _ _ msg) name =
	name == M.signalInterface msg
ifaceMatches _ _ = False

<<DBus/MatchRule.hs>>=
memberMatches :: M.ReceivedMessage -> T.MemberName -> Bool
memberMatches (M.ReceivedMethodCall _ _ msg) name =
	name == M.methodCallMember msg
memberMatches (M.ReceivedSignal _ _ msg) name =
	name == M.signalMember msg
memberMatches _ _ = False

<<DBus/MatchRule.hs>>=
pathMatches :: M.ReceivedMessage -> T.ObjectPath -> Bool
pathMatches (M.ReceivedMethodCall _ _ msg) path =
	path == M.methodCallPath msg
pathMatches (M.ReceivedSignal _ _ msg) path =
	path == M.signalPath msg
pathMatches _ _ = False

<<DBus/MatchRule.hs>>=
destMatches :: M.ReceivedMessage -> T.BusName -> Bool
destMatches (M.ReceivedMethodCall _ _ msg) name =
	Just name == M.methodCallDestination msg
destMatches (M.ReceivedMethodReturn _ _ msg) name =
	Just name == M.methodReturnDestination msg
destMatches (M.ReceivedError _ _ msg) name =
	Just name == M.errorDestination msg
destMatches (M.ReceivedSignal _ _ msg) name =
	Just name == M.signalDestination msg
destMatches _ _ = False

<<DBus/MatchRule.hs>>=
parametersMatch :: M.ReceivedMessage -> [ParameterValue] -> Bool
parametersMatch _ [] = True
parametersMatch msg values = all validParam values where
	body = M.receivedBody msg
	validParam (StringValue idx x) = validParam' idx x
	validParam (PathValue   idx x) = validParam' idx x
	validParam' idx x = fromMaybe False $ do
		var <- maybeIndex body $ fromIntegral idx
		fmap (== x) $ T.fromVariant var

@
\section{Name reservation}

The central bus allows clients to register a well-known bus name, which
enables other clients to connect with or start a particular application.

<<DBus/NameReservation.hs>>=
<<copyright>>
{-# LANGUAGE OverloadedStrings #-}
module DBus.NameReservation
	( RequestNameFlag (..)
	, RequestNameReply (..)
	, ReleaseNameReply (..)
	, requestName
	, releaseName
	, mkRequestNameReply
	, mkReleaseNameReply
	) where
import Data.Word (Word32)
import Data.Bits ((.|.))
import qualified Data.Set as Set
import qualified DBus.Types as T
import qualified DBus.Message as M
import qualified DBus.Constants as C
import DBus.Util (maybeIndex)

<<DBus/NameReservation.hs>>=
data RequestNameFlag
	= AllowReplacement
	| ReplaceExisting
	| DoNotQueue
	deriving (Show)

<<DBus/NameReservation.hs>>=
encodeFlags :: [RequestNameFlag] -> Word32
encodeFlags = foldr (.|.) 0 . map flagValue where
	flagValue AllowReplacement = 0x1
	flagValue ReplaceExisting  = 0x2
	flagValue DoNotQueue       = 0x4

@ There are only two methods of interest here, {\tt RequestName} and
{\tt ReleaseName}.

<<DBus/NameReservation.hs>>=
requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall
requestName name flags = M.MethodCall
	{ M.methodCallPath = C.dbusPath
	, M.methodCallInterface = Just C.dbusInterface
	, M.methodCallDestination = Just C.dbusName
	, M.methodCallFlags = Set.empty
	, M.methodCallMember = T.mkMemberName' "RequestName"
	, M.methodCallBody =
		[ T.toVariant name
		, T.toVariant . encodeFlags $ flags]
	}

<<DBus/NameReservation.hs>>=
data RequestNameReply
	= PrimaryOwner
	| InQueue
	| Exists
	| AlreadyOwner
	deriving (Show)

<<DBus/NameReservation.hs>>=
mkRequestNameReply :: M.MethodReturn -> Maybe RequestNameReply
mkRequestNameReply msg =
	maybeIndex (M.messageBody msg) 0 >>=
	T.fromVariant >>=
	decodeRequestReply

<<DBus/NameReservation.hs>>=
decodeRequestReply :: Word32 -> Maybe RequestNameReply
decodeRequestReply 1 = Just PrimaryOwner
decodeRequestReply 2 = Just InQueue
decodeRequestReply 3 = Just Exists
decodeRequestReply 4 = Just AlreadyOwner
decodeRequestReply _ = Nothing

<<DBus/NameReservation.hs>>=
releaseName :: T.BusName -> M.MethodCall
releaseName name = M.MethodCall
	{ M.methodCallPath = C.dbusPath
	, M.methodCallInterface = Just C.dbusInterface
	, M.methodCallDestination = Just C.dbusName
	, M.methodCallFlags = Set.empty
	, M.methodCallMember = T.mkMemberName' "ReleaseName"
	, M.methodCallBody = [T.toVariant name]
	}

<<DBus/NameReservation.hs>>=
data ReleaseNameReply
	= Released
	| NonExistent
	| NotOwner
	deriving (Show)

<<DBus/NameReservation.hs>>=
mkReleaseNameReply :: M.MethodReturn -> Maybe ReleaseNameReply
mkReleaseNameReply msg =
	maybeIndex (M.messageBody msg) 0 >>=
	T.fromVariant >>=
	decodeReleaseReply

<<DBus/NameReservation.hs>>=
decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply
decodeReleaseReply 1 = Just Released
decodeReleaseReply 2 = Just NonExistent
decodeReleaseReply 3 = Just NotOwner
decodeReleaseReply _ = Nothing

@
\section{Constants}

<<DBus/Constants.hs>>=
<<copyright>>
{-# LANGUAGE OverloadedStrings #-}
module DBus.Constants where
import qualified DBus.Types as T
import Data.Word (Word8, Word32)

<<DBus/Constants.hs>>=
protocolVersion :: Word8
protocolVersion = 1

messageMaximumLength :: Word32
messageMaximumLength = 134217728

arrayMaximumLength :: Word32
arrayMaximumLength = 67108864

@ \subsection{The message bus}

<<DBus/Constants.hs>>=
dbusName :: T.BusName
dbusName = T.mkBusName' "org.freedesktop.DBus"

dbusPath :: T.ObjectPath
dbusPath = T.mkObjectPath' "/org/freedesktop/DBus"

dbusInterface :: T.InterfaceName
dbusInterface = T.mkInterfaceName' "org.freedesktop.DBus"

@ \subsection{Pre-defined interfaces}

<<DBus/Constants.hs>>=
interfaceIntrospectable :: T.InterfaceName
interfaceIntrospectable = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable"

interfaceProperties :: T.InterfaceName
interfaceProperties = T.mkInterfaceName' "org.freedesktop.DBus.Properties"

interfacePeer :: T.InterfaceName
interfacePeer = T.mkInterfaceName' "org.freedesktop.DBus.Peer"

@ \subsection{Pre-defined error names}

<<DBus/Constants.hs>>=
errorFailed :: T.ErrorName
errorFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Failed"

errorNoMemory :: T.ErrorName
errorNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.NoMemory"

errorServiceUnknown :: T.ErrorName
errorServiceUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.ServiceUnknown"

errorNameHasNoOwner :: T.ErrorName
errorNameHasNoOwner = T.mkErrorName' "org.freedesktop.DBus.Error.NameHasNoOwner"

errorNoReply :: T.ErrorName
errorNoReply = T.mkErrorName' "org.freedesktop.DBus.Error.NoReply"

errorIOError :: T.ErrorName
errorIOError = T.mkErrorName' "org.freedesktop.DBus.Error.IOError"

errorBadAddress :: T.ErrorName
errorBadAddress = T.mkErrorName' "org.freedesktop.DBus.Error.BadAddress"

errorNotSupported :: T.ErrorName
errorNotSupported = T.mkErrorName' "org.freedesktop.DBus.Error.NotSupported"

errorLimitsExceeded :: T.ErrorName
errorLimitsExceeded = T.mkErrorName' "org.freedesktop.DBus.Error.LimitsExceeded"

errorAccessDenied :: T.ErrorName
errorAccessDenied = T.mkErrorName' "org.freedesktop.DBus.Error.AccessDenied"

errorAuthFailed :: T.ErrorName
errorAuthFailed = T.mkErrorName' "org.freedesktop.DBus.Error.AuthFailed"

errorNoServer :: T.ErrorName
errorNoServer = T.mkErrorName' "org.freedesktop.DBus.Error.NoServer"

errorTimeout :: T.ErrorName
errorTimeout = T.mkErrorName' "org.freedesktop.DBus.Error.Timeout"

errorNoNetwork :: T.ErrorName
errorNoNetwork = T.mkErrorName' "org.freedesktop.DBus.Error.NoNetwork"

errorAddressInUse :: T.ErrorName
errorAddressInUse = T.mkErrorName' "org.freedesktop.DBus.Error.AddressInUse"

errorDisconnected :: T.ErrorName
errorDisconnected = T.mkErrorName' "org.freedesktop.DBus.Error.Disconnected"

errorInvalidArgs :: T.ErrorName
errorInvalidArgs = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidArgs"

errorFileNotFound :: T.ErrorName
errorFileNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.FileNotFound"

errorFileExists :: T.ErrorName
errorFileExists = T.mkErrorName' "org.freedesktop.DBus.Error.FileExists"

errorUnknownMethod :: T.ErrorName
errorUnknownMethod = T.mkErrorName' "org.freedesktop.DBus.Error.UnknownMethod"

errorTimedOut :: T.ErrorName
errorTimedOut = T.mkErrorName' "org.freedesktop.DBus.Error.TimedOut"

errorMatchRuleNotFound :: T.ErrorName
errorMatchRuleNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleNotFound"

errorMatchRuleInvalid :: T.ErrorName
errorMatchRuleInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleInvalid"

errorSpawnExecFailed :: T.ErrorName
errorSpawnExecFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ExecFailed"

errorSpawnForkFailed :: T.ErrorName
errorSpawnForkFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ForkFailed"

errorSpawnChildExited :: T.ErrorName
errorSpawnChildExited = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildExited"

errorSpawnChildSignaled :: T.ErrorName
errorSpawnChildSignaled = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildSignaled"

errorSpawnFailed :: T.ErrorName
errorSpawnFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.Failed"

errorSpawnFailedToSetup :: T.ErrorName
errorSpawnFailedToSetup = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FailedToSetup"

errorSpawnConfigInvalid :: T.ErrorName
errorSpawnConfigInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ConfigInvalid"

errorSpawnServiceNotValid :: T.ErrorName
errorSpawnServiceNotValid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotValid"

errorSpawnServiceNotFound :: T.ErrorName
errorSpawnServiceNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotFound"

errorSpawnPermissionsInvalid :: T.ErrorName
errorSpawnPermissionsInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid"

errorSpawnFileInvalid :: T.ErrorName
errorSpawnFileInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FileInvalid"

errorSpawnNoMemory :: T.ErrorName
errorSpawnNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.NoMemory"

errorUnixProcessIdUnknown :: T.ErrorName
errorUnixProcessIdUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.UnixProcessIdUnknown"

errorInvalidFileContent :: T.ErrorName
errorInvalidFileContent = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidFileContent"

errorSELinuxSecurityContextUnknown :: T.ErrorName
errorSELinuxSecurityContextUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown"

errorAdtAuditDataUnknown :: T.ErrorName
errorAdtAuditDataUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.AdtAuditDataUnknown"

errorObjectPathInUse :: T.ErrorName
errorObjectPathInUse = T.mkErrorName' "org.freedesktop.DBus.Error.ObjectPathInUse"

errorInconsistentMessage :: T.ErrorName
errorInconsistentMessage = T.mkErrorName' "org.freedesktop.DBus.Error.InconsistentMessage"

@
\section{Misc. utility functions}

<<DBus/Util.hs>>=
<<copyright>>
module DBus.Util where
import Text.Parsec (Parsec, parse)
import Data.Char (digitToInt)

checkLength :: Int -> String -> Maybe String
checkLength length' s | length s <= length' = Just s
checkLength _ _ = Nothing

parseMaybe :: Parsec String () a -> String -> Maybe a
parseMaybe p = either (const Nothing) Just . parse p ""

mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b
mkUnsafe label f x = case f x of
	Just x' -> x'
	Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x

hexToInt :: String -> Int
hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt

eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe (Left  _) = Nothing
eitherToMaybe (Right x) = Just x

fromRight :: Either a b -> b
fromRight (Right x) = x
fromRight _ = error "DBus.Util.fromRight: Left"

maybeIndex :: [a] -> Int -> Maybe a
maybeIndex (x:_ ) 0         = Just x
maybeIndex (_:xs) n | n > 0 = maybeIndex xs (n - 1)
maybeIndex _ _ = Nothing

@ \end{document}