packages feed

dbus-core 0.8.2 → 0.8.3

raw patch · 41 files changed

+8184/−7225 lines, 41 filesdep ~test-frameworkPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: test-framework

API changes (from Hackage documentation)

Files

− Makefile 
@@ -1,53 +0,0 @@-HS_SOURCES=\-	hs/DBus/Address.hs \-	hs/DBus/Authentication.hs \-	hs/DBus/Bus.hs \-	hs/DBus/Connection.hs \-	hs/DBus/Constants.hs \-	hs/DBus/Introspection.hs \-	hs/DBus/MatchRule.hs \-	hs/DBus/Message.hs \-	hs/DBus/Message/Internal.hs \-	hs/DBus/NameReservation.hs \-	hs/DBus/Types.hs \-	hs/DBus/Util.hs \-	hs/DBus/Util/MonadError.hs \-	hs/DBus/UUID.hs \-	hs/DBus/Wire.hs \-	hs/DBus/Wire/Internal.hs \-	hs/DBus/Wire/Marshal.hs \-	hs/DBus/Wire/Unmarshal.hs \-	hs/DBus/Wire/Unicode.hs \-	hs/Tests.hs--all: $(HS_SOURCES)--%.tex: %.nw-	noweave -delay "$<" | cpif "$@"--hs/%.hs: dbus-core.nw hs/DBus/Message hs/DBus/Wire hs/DBus/Util-	notangle -R"$*.hs" "$<" | cpphs --hashes --noline | cpif "$@"--hs/Tests.hs: Tests.nw hs-	notangle -R"Tests.hs" "$<" dbus-core.nw | cpphs --hashes --noline | cpif "$@"--hs:-	mkdir -p hs--hs/DBus:-	mkdir -p hs/DBus--hs/DBus/Message:-	mkdir -p hs/DBus/Message--hs/DBus/Wire:-	mkdir -p hs/DBus/Wire--hs/DBus/Util:-	mkdir -p hs/DBus/Util--%.pdf: %.tex-	xelatex "$<"-	xelatex "$<"--pdfs: dbus-core.pdf manual.pdf
− Tests.nw 
@@ -1,681 +0,0 @@-% 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/>.--<<Tests.hs>>=-<<copyright>>-{-# LANGUAGE OverloadedStrings #-}-module Main (tests) where--import Test.QuickCheck-import Test.Framework (Test, testGroup)-import qualified Test.Framework as F-import Test.Framework.Providers.QuickCheck2 (testProperty)--import Control.Arrow ((&&&))-import Control.Monad (replicateM)-import qualified Data.Binary.Get as G-import Data.Char (isPrint)-import Data.List (intercalate, isInfixOf)-import Data.Maybe (fromJust, isJust, isNothing)-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import Data.Word (Word8, Word16, Word32, Word64)-import Data.Int (Int16, Int32, Int64)--import DBus.Address-import DBus.Message.Internal-import DBus.Types-import DBus.Wire.Internal-import DBus.Wire.Marshal-import DBus.Wire.Unmarshal-import qualified DBus.Introspection as I--@ \section{Tests}--<<Tests.hs>>=-tests :: [Test]-tests = [<<tests>>-	]--main :: IO ()-main = F.defaultMain tests--@ \subsection{Types}--<<tests>>=-  testGroup "Types"-	[ testGroup "Atomic types"-		[<<atom tests>>-		]-	, testGroup "Container types"-		[<<container tests>>-		]-	]--<<atom tests>>=--<<container tests>>=--@ \subsubsection{Atoms}--<<atom tests>>=-  testGroup "Bool" $ commonVariantTests (arbitrary :: Gen Bool)-, testGroup "Word8"   $ commonVariantTests (arbitrary :: Gen Word8)-, testGroup "Word16"  $ commonVariantTests (arbitrary :: Gen Word16)-, testGroup "Word32"  $ commonVariantTests (arbitrary :: Gen Word32)-, testGroup "Word64"  $ commonVariantTests (arbitrary :: Gen Word64)-, testGroup "Int16"   $ commonVariantTests (arbitrary :: Gen Int16)-, testGroup "Int32"   $ commonVariantTests (arbitrary :: Gen Int32)-, testGroup "Int64"   $ commonVariantTests (arbitrary :: Gen Int64)-, testGroup "Double"  $ commonVariantTests (arbitrary :: Gen Double)-, testGroup "String"  $ commonVariantTests (arbitrary :: Gen String) ++-	[ testProperty "String -> strict Text"-		$ \x -> (fromVariant . toVariant) x == (Just $ T.pack x)-	, testProperty "String <- strict Text"-		$ \x -> (fromVariant . toVariant) x == (Just $ T.unpack x)-	, testProperty "String -> lazy Text"-		$ \x -> (fromVariant . toVariant) x == (Just $ TL.pack x)-	, testProperty "String <- lazy Text"-		$ \x -> (fromVariant . toVariant) x == (Just $ TL.unpack x)-	, testProperty "Strict Text -> lazy Text"-		$ \x -> (fromVariant . toVariant) x == (Just $ TL.pack . T.unpack $ x)-	, testProperty "Strict Text <- lazy Text"-		$ \x -> (fromVariant . toVariant) x == (Just $ T.pack . TL.unpack $ x)-	]--<<Tests.hs>>=-atomicType :: Gen Type-atomicType = elements-	[ DBusBoolean-	, DBusByte-	, DBusWord16-	, DBusWord32-	, DBusWord64-	, DBusInt16-	, DBusInt32-	, DBusInt64-	, DBusDouble-	, DBusString-	, DBusObjectPath-	, DBusSignature-	]--containerType :: Gen Type-containerType = do-	c <- choose (0,3) :: Gen Int-	case c of-		0 -> fmap DBusArray arbitrary-		1 -> do-			kt <- atomicType-			vt <- arbitrary-			return $ DBusDictionary kt vt-		2 -> fmap DBusStructure $ shrinkingGen arbitrary-		3 -> return DBusVariant--instance Arbitrary Type where-	arbitrary = oneof [atomicType, containerType]--instance Arbitrary Signature where-	arbitrary = clampedSize 255 genSig mkSignature_ where-		genSig = fmap (TL.concat . map typeCode) arbitrary--<<atom tests>>=-, testGroup "Signature" $ commonVariantTests (arbitrary :: Gen Signature) ++-	[ testProperty "Signature identity"-		$ \x -> (mkSignature . strSignature) x == Just x-	, testProperty "Signature show"-		$ \x -> show (strSignature x) `isInfixOf` show x-	]--<<Tests.hs>>=-instance Arbitrary ObjectPath where-	arbitrary = fmap (mkObjectPath_ . TL.pack) path' where-		c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"-		path = fmap (intercalate "/" . ([] :)) genElements-		path' = frequency [(1, return "/"), (9, path)]-		genElements = sized' 1 (sized' 1 (elements c))--<<atom tests>>=-, testGroup "ObjectPath" $ commonVariantTests (arbitrary :: Gen ObjectPath) ++-	[ testProperty "ObjectPath identity"-		$ \x -> (mkObjectPath . strObjectPath) x == Just x-	]--<<Tests.hs>>=-instance Arbitrary BusName where-	arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName_ where-		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"-		c' = c ++ ['0'..'9']-		-		unique = do-			elems' <- sized' 2 $ elems c'-			return . TL.pack $ ':' : intercalate "." elems'-		-		wellKnown = do-			elems' <- sized' 2 $ elems c-			return . TL.pack $ intercalate "." elems'-		-		elems start = do-			x <- elements start-			xs <- sized' 0 (elements c')-			return (x:xs)--<<atom tests>>=-, testGroup "BusName" $ commonVariantTests (arbitrary :: Gen BusName) ++-	[ testProperty "BusName identity"-		$ \x -> (mkBusName . strBusName) x == Just x-	]--<<Tests.hs>>=-instance Arbitrary InterfaceName where-	arbitrary = clampedSize 255 genName mkInterfaceName_ where-		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"-		c' = c ++ ['0'..'9']-		-		genName = fmap (TL.pack . intercalate ".") genElements-		genElements = sized' 2 genElement-		genElement = do-			x <- elements c-			xs <- sized' 0 (elements c')-			return (x:xs)--<<atom tests>>=-, testGroup "InterfaceName" $ commonVariantTests (arbitrary :: Gen InterfaceName) ++-	[ testProperty "InterfaceName identity"-		$ \x -> (mkInterfaceName . strInterfaceName) x == Just x-	]--<<Tests.hs>>=-instance Arbitrary ErrorName where-	arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary--<<atom tests>>=-, testGroup "ErrorName" $ commonVariantTests (arbitrary :: Gen ErrorName) ++-	[ testProperty "ErrorName identity"-		$ \x -> (mkErrorName . strErrorName) x == Just x-	]--<<Tests.hs>>=-instance Arbitrary MemberName where-	arbitrary = clampedSize 255 genName mkMemberName_ where-		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"-		c' = c ++ ['0'..'9']-		-		genName = do-			x <- elements c-			xs <- sized' 0 (elements c')-			return . TL.pack $ (x:xs)--<<atom tests>>=-, testGroup "MemberName" $ commonVariantTests (arbitrary :: Gen MemberName) ++-	[ testProperty "MemberName identity"-		$ \x -> (mkMemberName . strMemberName) x == Just x-	]--@ \subsubsection{Containers}--@ All variable types must obey these properties.--<<Tests.hs>>=-prop_VariantIdentity gen = testProperty "Variant identity" . forAll gen-	$ \x -> (fromVariant . toVariant) x == Just x--prop_VariantEquality gen = testProperty "Variant equality" . forAll gen-	$ \x y -> (x == y) == (toVariant x == toVariant y)--@ Since all atomic types are also variable, the Variant properties are-added to the set of common Atom tests.--<<common atom tests>>=-, prop_VariantIdentity gen-, prop_VariantEquality gen--<<Tests.hs>>=-commonVariantTests gen =-	[ prop_VariantIdentity gen-	, prop_VariantEquality gen-	]--<<Tests.hs>>=-genVariant :: Type -> Gen Variant-genVariant  DBusBoolean         = fmap toVariant (arbitrary :: Gen Bool)-genVariant  DBusByte            = fmap toVariant (arbitrary :: Gen Word8)-genVariant  DBusWord16          = fmap toVariant (arbitrary :: Gen Word16)-genVariant  DBusWord32          = fmap toVariant (arbitrary :: Gen Word32)-genVariant  DBusWord64          = fmap toVariant (arbitrary :: Gen Word64)-genVariant  DBusInt16           = fmap toVariant (arbitrary :: Gen Int16)-genVariant  DBusInt32           = fmap toVariant (arbitrary :: Gen Int32)-genVariant  DBusInt64           = fmap toVariant (arbitrary :: Gen Int64)-genVariant  DBusDouble          = fmap toVariant (arbitrary :: Gen Double)-genVariant  DBusString          = fmap toVariant (arbitrary :: Gen String)-genVariant  DBusObjectPath      = fmap toVariant (arbitrary :: Gen ObjectPath)-genVariant  DBusSignature       = fmap toVariant (arbitrary :: Gen Signature)-genVariant (DBusArray _)        = fmap toVariant (arbitrary :: Gen Array)-genVariant (DBusDictionary _ _) = fmap toVariant (arbitrary :: Gen Dictionary)-genVariant (DBusStructure _)    = fmap toVariant (arbitrary :: Gen Structure)-genVariant  DBusVariant         = fmap toVariant (arbitrary :: Gen Variant)--instance Arbitrary Variant where-	arbitrary = arbitrary >>= genVariant--<<Tests.hs>>=-genAtom :: Type -> Gen Variant-genAtom DBusBoolean    = fmap toVariant (arbitrary :: Gen Bool)-genAtom DBusByte       = fmap toVariant (arbitrary :: Gen Word8)-genAtom DBusWord16     = fmap toVariant (arbitrary :: Gen Word16)-genAtom DBusWord32     = fmap toVariant (arbitrary :: Gen Word32)-genAtom DBusWord64     = fmap toVariant (arbitrary :: Gen Word64)-genAtom DBusInt16      = fmap toVariant (arbitrary :: Gen Int16)-genAtom DBusInt32      = fmap toVariant (arbitrary :: Gen Int32)-genAtom DBusInt64      = fmap toVariant (arbitrary :: Gen Int64)-genAtom DBusDouble     = fmap toVariant (arbitrary :: Gen Double)-genAtom DBusString     = fmap toVariant (arbitrary :: Gen String)-genAtom DBusObjectPath = fmap toVariant (arbitrary :: Gen ObjectPath)-genAtom DBusSignature  = fmap toVariant (arbitrary :: Gen Signature)--<<container tests>>=-  testGroup "Variant" $ commonVariantTests (arbitrary :: Gen Variant)--<<Tests.hs>>=-instance Arbitrary Array where-	arbitrary = do-		-- Only generate arrays of atomic values, as generating-		-- containers randomly almost never results in a valid-		-- array.-		t <- atomicType-		xs <- listOf $ genVariant t-		return . fromJust $ arrayFromItems t xs--prop_ArrayHomogeneous vs = isJust array == homogeneousTypes where-	array = arrayFromItems firstType vs-	homogeneousTypes = all (== firstType) types-	types = map variantType vs-	firstType = if null types-		then DBusByte-		else head types--<<container tests>>=-, testGroup "Array" $ commonVariantTests (arbitrary :: Gen Array) ++-	[ testProperty "Array identity"-		$ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x)-	, testProperty "Array homogeneity" prop_ArrayHomogeneous-	]--<<Tests.hs>>=-instance Arbitrary Dictionary where-	arbitrary = do-		-- Only generate dictionaries of atomic values, as generating-		-- containers randomly almost never results in a valid-		-- dictionary.-		kt <- atomicType-		vt <- atomicType-		ks <- listOf $ genAtom kt-		vs <- vectorOf (length ks) $ genVariant vt-		-		return . fromJust $ dictionaryFromItems kt vt $ zip ks vs--prop_DictionaryHomogeneous x = all correctType pairs where-	pairs = dictionaryItems x-	kType = dictionaryKeyType x-	vType = dictionaryValueType x-	correctType (k, v) = variantType k == kType &&-	                     variantType v == vType--<<container tests>>=-, testGroup "Dictionary" $ commonVariantTests (arbitrary :: Gen Dictionary) ++-	[ testProperty "Dictionary identity"-		$ \x -> Just x == dictionaryFromItems-			(dictionaryKeyType x)-			(dictionaryValueType x)-			(dictionaryItems x)-	, testProperty "Dictionary homogeneity" prop_DictionaryHomogeneous-	, testProperty "Dictionary must have atomic keys" -		$ \vt -> forAll containerType $ \kt ->-			isNothing (dictionaryFromItems kt vt [])-	, testProperty "Dictionary <-> Array conversion"-		$ \x -> arrayToDictionary (dictionaryToArray x) == Just x-	]--<<Tests.hs>>=-instance Arbitrary Structure where-	arbitrary = sized $ \n ->-		fmap Structure $ shrinkingGen arbitrary--<<container tests>>=-, testGroup "Structure" $ commonVariantTests (arbitrary :: Gen Structure)--@ \subsection{Addresses}--<<Tests.hs>>=-singleTests :: Testable a => [a] -> [Test]-singleTests ts = singleTests' 1 ts where-	singleTests' _ []     = []-	singleTests' n (t:ts') = plusOptions (testProperty (name n) t)-	                         : singleTests' (n + 1) ts'-	-	total = length ts-	options = F.TestOptions Nothing (Just 1) Nothing Nothing-	plusOptions = F.plusTestOptions options-	name n = "Test " ++ show n ++ "/" ++ show total--<<tests>>=-, testGroup "Addresses"-	[ testProperty "Address identity"-		$ \x -> mkAddresses (strAddress x) == Just [x]-	, testProperty "Multiple addresses"-		$ \x y -> let-		joined = TL.concat [strAddress x, ";", strAddress y]-		in mkAddresses joined == Just [x, y]-	, testProperty "Ignore trailing semicolon"-		$ \x -> mkAddresses (TL.append (strAddress x) ";") == Just [x]-	, testProperty "Ignore trailing comma"-		$ \x -> let-		hasParams = not . Map.null . addressParameters $ x-		parsed = mkAddresses (TL.append (strAddress x) ",")-		in hasParams ==> parsed == Just [x]-	, testGroup "Valid addresses" $ singleTests-		[ isJust . mkAddresses $ ":"-		, isJust . mkAddresses $ "a:"-		, isJust . mkAddresses $ "a:b=c"-		, isJust . mkAddresses $ "a:;"-		, isJust . mkAddresses $ "a:;b:"-		, isJust . mkAddresses $ "a:b=c,"-		]-	, testGroup "Invalid addresses" $ singleTests-		[ isNothing . mkAddresses $ ""-		, isNothing . mkAddresses $ "a"-		, isNothing . mkAddresses $ "a:b"-		, isNothing . mkAddresses $ "a:b="-		, isNothing . mkAddresses $ "a:,"-		]-	]--<<Tests.hs>>=-instance Arbitrary Address where-	arbitrary = genAddress where-		optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."-		methodChars = filter (flip notElem ":;") ['!'..'~']-		keyChars = filter (flip notElem "=;,") ['!'..'~']-		-		genMethod = sized' 0 $ elements methodChars-		genParam = do-			key <- genKey-			value <- genValue-			return . concat $ [key, "=", value]-		-		genKey = sized' 1 $ elements keyChars-		genValue = oneof [encodedValue, plainValue]-		genHex = elements $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']-		encodedValue = do-			x1 <- genHex-			x2 <- genHex-			return ['%', x1, x2]-		plainValue = sized' 1 $ elements optional-		-		genParams = do-			params <- sized' 0 genParam-			let params' = intercalate "," params-			extraComma <- if null params-				then return ""-				else elements ["", ","]-			return $ concat [params', extraComma]-		-		genAddress = do-			m <- genMethod-			params <- genParams-			extraSemicolon <- elements ["", ";"]-			let addrStr = concat [m, ":", params, extraSemicolon]-			let Just [addr] = mkAddresses $ TL.pack addrStr-			return addr--@ \subsection{Messages}--<<Tests.hs>>=-instance Arbitrary Serial where-	arbitrary = fmap Serial arbitrary--instance Arbitrary Flag where-	arbitrary = elements [NoReplyExpected, NoAutoStart]--instance Arbitrary MethodCall where-	arbitrary = do-		path   <- arbitrary-		member <- arbitrary-		iface  <- arbitrary-		dest   <- arbitrary-		flags  <- fmap Set.fromList arbitrary-		Structure body <- arbitrary-		return $ MethodCall path member iface dest flags body--instance Arbitrary MethodReturn where-	arbitrary = do-		serial <- arbitrary-		dest   <- arbitrary-		Structure body <- arbitrary-		return $ MethodReturn serial dest body--instance Arbitrary Error where-	arbitrary = do-		name   <- arbitrary-		serial <- arbitrary-		dest   <- arbitrary-		Structure body <- arbitrary-		return $ Error name serial dest body--instance Arbitrary Signal where-	arbitrary = do-		path   <- arbitrary-		member <- arbitrary-		iface  <- arbitrary-		dest   <- arbitrary-		Structure body <- arbitrary-		return $ Signal path member iface dest body--@ \subsection{Wire format}--<<Tests.hs>>=-isRight :: Either a b -> Bool-isRight = either (const False) (const True)--prop_Unmarshal :: Endianness -> Variant -> Property-prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where-	sig = mkSignature . typeCode . variantType $ x-	Just sig' = sig-	-	bytes = runMarshal (marshal x) e-	Right bytes' = bytes-	-	valid = isJust sig && isRight bytes-	unmarshaled = runUnmarshal (unmarshal sig') e bytes'--prop_MarshalMessage e serial msg expected = valid ==> correct where-	bytes = marshalMessage e serial msg-	Right bytes' = bytes-	-	getBytes = G.getLazyByteString . fromIntegral-	unmarshaled = G.runGet (unmarshalMessage getBytes) bytes'-	-	valid = isRight bytes-	correct = unmarshaled == Right expected--prop_WireMethodCall e serial msg = prop_MarshalMessage e serial msg-	$ ReceivedMethodCall serial Nothing msg--prop_WireMethodReturn e serial msg = prop_MarshalMessage e serial msg-	$ ReceivedMethodReturn serial Nothing msg--prop_WireError e serial msg = prop_MarshalMessage e serial msg-	$ ReceivedError serial Nothing msg--prop_WireSignal e serial msg = prop_MarshalMessage e serial msg-	$ ReceivedSignal serial Nothing msg--<<tests>>=-, testGroup "Wire format"-	[ testProperty "Marshal -> Ummarshal" prop_Unmarshal-	, testGroup "Messages"-		[ testProperty "Method calls" prop_WireMethodCall-		, testProperty "Method returns" prop_WireMethodReturn-		, testProperty "Errors" prop_WireError-		, testProperty "Signals" prop_WireSignal-		]-	]--<<Tests.hs>>=-instance Arbitrary Endianness where-	arbitrary = elements [LittleEndian, BigEndian]--@ \subsection{Introspection}--<<tests>>=-, testGroup "Introspection"-	[ testProperty "Generate -> Parse"-		$ \x@(I.Object path _ _) -> let-		xml = I.toXML x-		Just xml' = xml-		parsed = I.fromXML path xml'-		in isJust xml ==> I.fromXML path xml' == Just x-	]--<<Tests.hs>>=-subObject :: ObjectPath -> Gen I.Object-subObject parentPath = sized $ \n -> resize (min n 4) $ do-	let nonRoot = do-		x <- arbitrary-		case strObjectPath x of-			"/" -> nonRoot-			x'  -> return x'-	-	thisPath <- nonRoot-	let path' = case strObjectPath parentPath of-		"/" -> thisPath-		x   -> TL.append x thisPath-	let path = mkObjectPath_ path'-	ifaces <- arbitrary-	children <- shrinkingGen . listOf . subObject $ path-	return $ I.Object path ifaces children--instance Arbitrary I.Object where-	arbitrary = arbitrary >>= subObject--instance Arbitrary I.Interface where-	arbitrary = do-		name <- arbitrary-		methods <- arbitrary-		signals <- arbitrary-		properties <- arbitrary-		return $ I.Interface name methods signals properties--instance Arbitrary I.Method where-	arbitrary = do-		name <- arbitrary-		inParams <- arbitrary-		outParams <- arbitrary-		return $ I.Method name inParams outParams--instance Arbitrary I.Signal where-	arbitrary = do-		name <- arbitrary-		params <- arbitrary-		return $ I.Signal name params--singleType :: Gen Signature-singleType = do-	t <- arbitrary-	case mkSignature $ typeCode t of-		Just x -> return x-		Nothing -> singleType--instance Arbitrary I.Parameter where-	arbitrary = do-		name <- listOf $ arbitrary `suchThat` isPrint-		sig <- singleType-		return $ I.Parameter (TL.pack name) sig--instance Arbitrary I.Property where-	arbitrary = do-		name <- listOf $ arbitrary `suchThat` isPrint-		sig <- singleType-		access <- elements-			[[], [I.Read], [I.Write],-			 [I.Read, I.Write]]-		return $ I.Property (TL.pack name) sig access--@ \subsection{Other instances}--<<Tests.hs>>=-iexp :: Integral a => a -> a -> a-iexp x y = floor $ fromIntegral x ** fromIntegral y--instance Arbitrary Word8 where-	arbitrary = fmap fromIntegral gen where-		gen = choose (0, max') :: Gen Integer-		max' = iexp 2 8 - 1--instance Arbitrary Word16 where-	arbitrary = fmap fromIntegral gen where-		gen = choose (0, max') :: Gen Integer-		max' = iexp 2 16 - 1--instance Arbitrary Word32 where-	arbitrary = fmap fromIntegral gen where-		gen = choose (0, max') :: Gen Integer-		max' = iexp 2 32 - 1--instance Arbitrary Word64 where-	arbitrary = fmap fromIntegral gen where-		gen = choose (0, max') :: Gen Integer-		max' = iexp 2 64 - 1--instance Arbitrary Int16 where-	arbitrary = fmap fromIntegral gen where-		gen = choose (0, max') :: Gen Integer-		max' = iexp 2 16 - 1--instance Arbitrary Int32 where-	arbitrary = fmap fromIntegral gen where-		gen = choose (0, max') :: Gen Integer-		max' = iexp 2 32 - 1--instance Arbitrary Int64 where-	arbitrary = fmap fromIntegral gen where-		gen = choose (0, max') :: Gen Integer-		max' = iexp 2 64 - 1--instance Arbitrary T.Text where-	arbitrary = fmap T.pack arbitrary--instance Arbitrary TL.Text where-	arbitrary = fmap TL.pack arbitrary--sized' :: Int -> Gen a -> Gen [a]-sized' atLeast g = sized $ \n -> do-	n' <- choose (atLeast, max atLeast n)-	replicateM n' g--clampedSize :: Arbitrary a => Int64 -> Gen TL.Text -> (TL.Text -> a) -> Gen a-clampedSize maxSize gen f = do-	s <- gen-	if TL.length s > maxSize-		then shrinkingGen arbitrary-		else return . f $ s--shrinkingGen :: Gen a -> Gen a-shrinkingGen gen = sized $ \n -> if n > 0 then-	resize (n `div` 2) gen-	else gen-
dbus-core.cabal view
@@ -1,5 +1,5 @@ name: dbus-core-version: 0.8.2+version: 0.8.3 synopsis: Low-level D-Bus protocol implementation license: GPL-3 license-file: License.txt@@ -11,13 +11,12 @@ stability: experimental bug-reports: mailto:jmillikin@gmail.com homepage: http://ianen.org/haskell/dbus/-tested-with: GHC==6.10.4, GHC==6.12.1+tested-with: GHC==6.12.1  extra-source-files:-  dbus-core.nw+  src/*.anansi   Examples/*.hs-  Makefile-  Tests.nw+  readme.txt  source-repository head   type: darcs@@ -78,7 +77,7 @@   if flag(test)     build-depends:         QuickCheck >= 2.1 && < 2.2-      , test-framework >= 0.2 && < 0.3+      , test-framework >= 0.2 && < 0.4       , test-framework-quickcheck2 >= 0.2 && < 0.3   else     buildable: False
− dbus-core.nw 
@@ -1,4105 +0,0 @@--% Copyright (C) 2009 John Millikin <jmillikin@gmail.com>-% -% This program is free software: you can redistribute it and/or modify-% it under the terms of the GNU General Public License as published by-% the Free Software Foundation, either version 3 of the License, or-% any later version.-% -% This program is distributed in the hope that it will be useful,-% but WITHOUT ANY WARRANTY; without even the implied warranty of-% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-% GNU General Public License for more details.-% -% You should have received a copy of the GNU General Public License-% along with this program.  If not, see <http://www.gnu.org/licenses/>.--\documentclass[12pt]{article}--\usepackage{color}-\usepackage{hyperref}-\usepackage{booktabs}-\usepackage{multirow}-\usepackage{noweb}-\usepackage{url}--% Smaller margins-\usepackage[left=1.5cm,top=2cm,right=1.5cm,nohead,nofoot]{geometry}--% Remove boxes from hyperlinks-\hypersetup{-    colorlinks,-    linkcolor=blue,-}--\makeindex--\begin{document}--\addcontentsline{toc}{section}{Contents}-\tableofcontents--@-\section{Introduction}--D-Bus is a low-latency, asynchronous IPC protocol. It is primarily used on-Linux, BSD, and other free UNIX-like systems. More information is available-at \url{http://dbus.freedesktop.org/}.--This package is an implementation of the D-Bus protocol. It is intended-for use in either a client or server, though currently only the client-portion of connection establishment is implemented. Additionally, it-implements the introspection file format.--All source code is licensed under the terms of the GNU GPL v3 or later.--<<copyright>>=-{--  Copyright (C) 2009 John Millikin <jmillikin@gmail.com>-  -  This program is free software: you can redistribute it and/or modify-  it under the terms of the GNU General Public License as published by-  the Free Software Foundation, either version 3 of the License, or-  any later version.-  -  This program is distributed in the hope that it will be useful,-  but WITHOUT ANY WARRANTY; without even the implied warranty of-  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-  GNU General Public License for more details.-  -  You should have received a copy of the GNU General Public License-  along with this program.  If not, see <http://www.gnu.org/licenses/>.--}--@-\section{Text values}--Most of the functions in this library use the types and functions defined-in {\tt Data.Text}, in preference to the {\tt String} type.--<<text extensions>>=-{-# LANGUAGE OverloadedStrings #-}--<<text imports>>=-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as TL--@-\section{Types}--The {\tt DBus.Types module} defines interfaces for storing, building, and-deconstructing D-Bus values.--<<DBus/Types.hs>>=-<<copyright>>-<<text extensions>>-<<type extensions>>-module DBus.Types (<<type exports>>) where-<<text imports>>-<<type imports>>--@ D-Bus types are divided into two categories, ``atomic'' and ``container''-types. Atoms are actual values -- strings, numbers, etc. Containers store-atoms and other containers. The most interesting difference between the two-is that atoms may be used as the keys in associative mappings-(``dictionaries'').--Internally, types are represented using an enumeration.--<<DBus/Types.hs>>=-data Type-	= DBusBoolean-	| DBusByte-	| DBusInt16-	| DBusInt32-	| DBusInt64-	| DBusWord16-	| DBusWord32-	| DBusWord64-	| DBusDouble-	| DBusString-	| DBusSignature-	| DBusObjectPath-	| DBusVariant-	| DBusArray Type-	| DBusDictionary Type Type-	| DBusStructure [Type]-	deriving (Show, Eq)--<<DBus/Types.hs>>=-<<apidoc isAtomicType>>-isAtomicType :: Type -> Bool-isAtomicType DBusBoolean    = True-isAtomicType DBusByte       = True-isAtomicType DBusInt16      = True-isAtomicType DBusInt32      = True-isAtomicType DBusInt64      = True-isAtomicType DBusWord16     = True-isAtomicType DBusWord32     = True-isAtomicType DBusWord64     = True-isAtomicType DBusDouble     = True-isAtomicType DBusString     = True-isAtomicType DBusSignature  = True-isAtomicType DBusObjectPath = True-isAtomicType _              = False--@ Each type can be converted to a textual representation, used in ``type-signatures'' or for debugging.--<<DBus/Types.hs>>=-<<apidoc typeCode>>-typeCode :: Type -> Text-<<type codes>>--<<type exports>>=-  -- * Available types-  Type (..)-, typeCode--@ \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.--@ Any type which is an instance of {\tt Variable} is considered a valid-D-Bus value, because it can be used to construct {\tt Variant}s. However,-outside of this module, {\tt Variant}s can only be constructed from-pre-defined types.--<<DBus/Types.hs>>=-<<apidoc Variant>>-data Variant-	= VarBoxBool Bool-	| VarBoxWord8 Word8-	| VarBoxInt16 Int16-	| VarBoxInt32 Int32-	| VarBoxInt64 Int64-	| VarBoxWord16 Word16-	| VarBoxWord32 Word32-	| VarBoxWord64 Word64-	| VarBoxDouble Double-	| VarBoxString Text-	| VarBoxSignature Signature-	| VarBoxObjectPath ObjectPath-	| VarBoxVariant Variant-	| VarBoxArray Array-	| VarBoxDictionary Dictionary-	| VarBoxStructure Structure-	deriving (Eq)--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 var = showParen (d > 10) full where-		full = s "Variant " . shows code . s " " . valueStr-		code = typeCode $ variantType var-		s = showString-		valueStr = showsPrecVar 11 var--showsPrecVar :: Int -> Variant -> ShowS-showsPrecVar d var = case var of-	(VarBoxBool x) -> showsPrec d x-	(VarBoxWord8 x) -> showsPrec d x-	(VarBoxInt16 x) -> showsPrec d x-	(VarBoxInt32 x) -> showsPrec d x-	(VarBoxInt64 x) -> showsPrec d x-	(VarBoxWord16 x) -> showsPrec d x-	(VarBoxWord32 x) -> showsPrec d x-	(VarBoxWord64 x) -> showsPrec d x-	(VarBoxDouble x) -> showsPrec d x-	(VarBoxString x) -> showsPrec d x-	(VarBoxSignature x) -> showsPrec d x-	(VarBoxObjectPath x) -> showsPrec d x-	(VarBoxVariant x) -> showsPrec d x-	(VarBoxArray x) -> showsPrec d x-	(VarBoxDictionary x) -> showsPrec d x-	(VarBoxStructure x) -> showsPrec d x--@ Since many operations on D-Bus values depend on having the correct type,-{\tt variantType} is used to retrieve which type is actually stored within-a {\tt Variant}.--<<DBus/Types.hs>>=-<<apidoc variantType>>-variantType :: Variant -> Type-variantType var = case var of-	(VarBoxBool _) -> DBusBoolean-	(VarBoxWord8 _) -> DBusByte-	(VarBoxInt16 _) -> DBusInt16-	(VarBoxInt32 _) -> DBusInt32-	(VarBoxInt64 _) -> DBusInt64-	(VarBoxWord16 _) -> DBusWord16-	(VarBoxWord32 _) -> DBusWord32-	(VarBoxWord64 _) -> DBusWord64-	(VarBoxDouble _) -> DBusDouble-	(VarBoxString _) -> DBusString-	(VarBoxSignature _) -> DBusSignature-	(VarBoxObjectPath _) -> DBusObjectPath-	(VarBoxVariant _) -> DBusVariant-	(VarBoxArray x) -> DBusArray (arrayType x)-	(VarBoxDictionary x) -> let-		keyT = dictionaryKeyType x-		valueT = dictionaryValueType x-		in DBusDictionary keyT valueT-	(VarBoxStructure x) -> let-		Structure items = x-		in DBusStructure (map variantType items)--<<type exports>>=-, variantType--@ A macro is useful for reducing verbosity in simple {\tt Variable}-instances.--<<DBus/Types.hs>>=-#define INSTANCE_VARIABLE(TYPE) \-	instance Variable TYPE where \-		{ toVariant = VarBox##TYPE \-		; fromVariant (VarBox##TYPE x) = Just x \-		; fromVariant _ = Nothing \-		}--@ Since {\tt Variant}s are D-Bus values themselves, they can be stored in variants.--<<DBus/Types.hs>>=-INSTANCE_VARIABLE(Variant)--@ \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>>=-INSTANCE_VARIABLE(Bool)-INSTANCE_VARIABLE(Word8)-INSTANCE_VARIABLE(Int16)-INSTANCE_VARIABLE(Int32)-INSTANCE_VARIABLE(Int64)-INSTANCE_VARIABLE(Word16)-INSTANCE_VARIABLE(Word32)-INSTANCE_VARIABLE(Word64)-INSTANCE_VARIABLE(Double)--@ \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>>=-instance Variable TL.Text where-	toVariant = VarBoxString-	fromVariant (VarBoxString x) = Just x-	fromVariant _ = Nothing--@ 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>>=-INSTANCE_VARIABLE(Signature)-data Signature = Signature { signatureTypes :: [Type] }-	deriving (Eq)--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}.--<<type imports>>=-import Data.Ord (comparing)--<<DBus/Types.hs>>=-instance Ord Signature where-	compare = comparing strSignature--<<type exports>>=-  -- * Signatures-, Signature-, signatureTypes-, strSignature--@ \subsubsection{Type codes}--@ For atomic types, the type code is a single letter. Arrays, structures,-and dictionary types are multiple characters.--<<type codes>>=-typeCode DBusBoolean    = "b"-typeCode DBusByte       = "y"-typeCode DBusInt16      = "n"-typeCode DBusInt32      = "i"-typeCode DBusInt64      = "x"-typeCode DBusWord16     = "q"-typeCode DBusWord32     = "u"-typeCode DBusWord64     = "t"-typeCode DBusDouble     = "d"-typeCode DBusString     = "s"-typeCode DBusSignature  = "g"-typeCode DBusObjectPath = "o"-typeCode DBusVariant    = "v"--@ An array's type code is ``a'' followed by the type it contains. For example,-an array of booleans would have the type string ``ab''.--<<type codes>>=-typeCode (DBusArray t) = TL.cons 'a' $ typeCode t--@ A dictionary's type code is ``a\{$key\_type$ $value\_type$\}''. For example,-a dictionary of bytes to booleans would have the type string ``a\{yb\}''.--<<type codes>>=-typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"]--@ A structure's type code is the concatenation of its contained types,-wrapped by ``('' and ``)''. Structures may be empty, in which case their-type code is simply ``()''.--<<type codes>>=-typeCode (DBusStructure ts) = TL.concat $-	["("] ++ map typeCode ts ++ [")"]--@ \subsubsection{Parsing}--When parsing, additional restrictions apply which are not inherent to the-D-Bus type system. {\tt mkSignature} guarantees that any {\tt Signature} is-valid according to D-Bus rules.--<<DBus/Types.hs>>=-mkSignature :: Text -> Maybe Signature-mkSignature text = parsed where-	<<fast signature parser>>-	<<slow signature parser>>-	parsed = case TL.length text of-		0 -> Just $ Signature []-		1 -> fast-		_ -> slow--@ Since single-type and empty signatures are very common, they are-special-cased for performance.--<<fast signature parser>>=-just t = Just $ Signature [t]-fast = case TL.head text of-	'b' -> just DBusBoolean-	'y' -> just DBusByte-	'n' -> just DBusInt16-	'i' -> just DBusInt32-	'x' -> just DBusInt64-	'q' -> just DBusWord16-	'u' -> just DBusWord32-	't' -> just DBusWord64-	'd' -> just DBusDouble-	's' -> just DBusString-	'g' -> just DBusSignature-	'o' -> just DBusObjectPath-	'v' -> just DBusVariant-	_   -> Nothing--@ Parsec is used to parse more complex signatures.--<<type imports>>=-import Text.Parsec ((<|>))-import qualified Text.Parsec as P-import DBus.Util (checkLength, parseMaybe)--<<slow signature parser>>=-slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text-sigParser = do-	types <- P.many parseType-	P.eof-	return $ Signature types--@ Types may be either containers or atoms. Containers can't be dictionary-keys.--<<slow signature parser>>=-parseType = parseAtom <|> parseContainer-parseContainer =-	    parseArray-	<|> parseStruct-	<|> (P.char 'v' >> return DBusVariant)--<<slow signature parser>>=-parseArray = do-	P.char 'a'-	parseDict <|> fmap DBusArray parseType-parseDict = do-	P.char '{'-	keyType <- parseAtom-	valueType <- parseType-	P.char '}'-	return $ DBusDictionary keyType valueType--@ Structures can contain any types.--<<slow signature parser>>=-parseStruct = do-	P.char '('-	types <- P.many parseType-	P.char ')'-	return $ DBusStructure types--<<slow signature parser>>=-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)--@ Since many signatures are defined as string literals, it's useful to-have a helper function to construct a signature directly from a string.-If the input string is invalid, {\tt error} will be called.--<<type imports>>=-import DBus.Util (mkUnsafe)--<<DBus/Types.hs>>=-mkSignature_ :: Text -> Signature-mkSignature_ = mkUnsafe "signature" mkSignature--<<type imports>>=-import qualified Data.String as String--<<DBus/Types.hs>>=-instance String.IsString Signature where-	fromString = mkSignature_ . TL.pack--@ Most signature-related functions are exposed to clients, except the-{\tt Signature} value constructor. If that were exposed, clients could-construct invalid signatures.--<<type exports>>=-, mkSignature-, mkSignature_--@ \subsection{Object paths}--<<DBus/Types.hs>>=-INSTANCE_VARIABLE(ObjectPath)-newtype ObjectPath = ObjectPath-	{ strObjectPath :: Text-	}-	deriving (Eq, Ord)--instance Show ObjectPath where-	showsPrec d (ObjectPath x) = showParen (d > 10) $-		showString "ObjectPath " . shows x--instance String.IsString ObjectPath where-	fromString = mkObjectPath_ . TL.pack--@ An object path may be one of--\begin{itemize}-\item The root path, {\tt "/"}.-\item {\tt '/'}, followed by one or more element names. Each element name-      contains characters in the set {\tt [a-zA-Z0-9\_]}, and must have at-      least one character.-\end{itemize}--Element names are separated by {\tt '/'}, and the path may not end in-{\tt '/'} unless it is the root path.--<<DBus/Types.hs>>=-mkObjectPath :: Text -> Maybe ObjectPath-mkObjectPath s = parseMaybe path' (TL.unpack s) where-	c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"-	path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char-	path' = path >> P.eof >> return (ObjectPath s)--mkObjectPath_ :: Text -> ObjectPath-mkObjectPath_ = mkUnsafe "object path" mkObjectPath--<<type exports>>=-  -- * Object paths-, ObjectPath-, strObjectPath-, mkObjectPath-, mkObjectPath_--@ \subsection{Arrays}--Arrays are homogenous sequences of any valid D-Bus type. Arrays might be-empty, so the type they contain is stored instead of being calculated from-their contents (as in {\tt variantType}).--Many D-Bus APIs represent binary data using an array of bytes; therefore,-there is a special constructor for {\tt ByteString}-based arrays.--<<type imports>>=-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as ByteString--<<DBus/Types.hs>>=-INSTANCE_VARIABLE(Array)-data Array-	= VariantArray Type [Variant]-	| ByteArray ByteString-	deriving (Eq)--<<apidoc arrayType>>-arrayType :: Array -> Type-arrayType (VariantArray t _) = t-arrayType (ByteArray _) = DBusByte--arrayItems :: Array -> [Variant]-arrayItems (VariantArray _ xs) = xs-arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs--<<type exports>>=-  -- * Arrays-, Array-, arrayType-, arrayItems--@ Like {\tt Variant}, deriving {\tt Show} for {\tt Array} is mostly-just useful for debugging.--<<DBus/Types.hs>>=-instance Show Array where-	showsPrec d array = showParen (d > 10) $-		s "Array " . showSig . s " [" . s valueString . s "]" where-			s = showString-			showSig = shows . typeCode . arrayType $ array-			showVar var = showsPrecVar 0 var ""-			valueString = intercalate ", " $ map showVar $ arrayItems array--@ 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 = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs)--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)--<<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 (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 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)--<<type exports>>=-  -- * Structures-, Structure (..)--@ \subsection{Names}--Various aspects of D-Bus require the use of specially-formatted strings,-called ``names''. All names are limited to 255 characters, and use subsets-of ASCII.--Since all names have basically the same structure (a {\tt newtype}-declaration and some helper functions), I define a macro to automate-the definitions.--<<DBus/Types.hs>>=-#define NAME_TYPE(TYPE, NAME) \-	newtype TYPE = TYPE {str##TYPE :: Text} \-		deriving (Eq, Ord); \-		\-	instance Show TYPE where \-		{ showsPrec d (TYPE x) = showParen (d > 10) $ \-			showString "TYPE " . shows x \-		}; \-		\-	instance String.IsString TYPE where \-		{ fromString = mk##TYPE##_ . TL.pack }; \-		\-	instance Variable TYPE where \-		{ toVariant = toVariant . str##TYPE \-		; fromVariant = (mk##TYPE =<<) . fromVariant }; \-		                                                \-	mk##TYPE##_ :: Text -> TYPE; \-	mk##TYPE##_ = mkUnsafe NAME mk##TYPE--<<type exports>>=--- * Names--@ \subsubsection{Bus names}--There are two forms of bus names, ``unique'' and ``well-known''.--Unique names begin with {\tt `:'} and contain two or more elements, separated-by {\tt `.'}. Each element consists of characters from the set-{\tt [a-zA-Z0-9\_-]}.--Well-known names contain two or more elements, separated by {\tt `.'}. Each-element consists of characters from the set {\tt [a-zA-Z0-9\_-]}, and must-not start with a digit.--<<DBus/Types.hs>>=-NAME_TYPE(BusName, "bus name")--mkBusName :: Text -> Maybe BusName-mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where-	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"-	c' = c ++ ['0'..'9']-	parser = (unique <|> wellKnown) >> P.eof >> return (BusName s)-	unique = P.char ':' >> elems c'-	wellKnown = elems c-	elems start = elem' start >> P.many1 (P.char '.' >> elem' start)-	elem' start = P.oneOf start >> P.many (P.oneOf c')--<<type exports>>=-  -- ** Bus names-, BusName-, strBusName-, mkBusName-, mkBusName_--@ \subsubsection{Interface names}--An interface name consists of two or more {\tt '.'}-separated elements. Each-element constists of characters from the set {\tt [a-zA-Z0-9\_]}, may not-start with a digit, and must have at least one character.--<<DBus/Types.hs>>=-NAME_TYPE(InterfaceName, "interface name")--mkInterfaceName :: Text -> Maybe InterfaceName-mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where-	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"-	c' = c ++ ['0'..'9']-	element = P.oneOf c >> P.many (P.oneOf c')-	name = element >> P.many1 (P.char '.' >> element)-	parser = name >> P.eof >> return (InterfaceName s)--<<type exports>>=-  -- ** Interface names-, InterfaceName-, strInterfaceName-, mkInterfaceName-, mkInterfaceName_--@ \subsubsection{Error names}--Error names have the same format as interface names, so the parser logic-can just be re-purposed.--<<DBus/Types.hs>>=-NAME_TYPE(ErrorName, "error name")--mkErrorName :: Text -> Maybe ErrorName-mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName--<<type exports>>=-  -- ** Error names-, ErrorName-, strErrorName-, mkErrorName-, mkErrorName_--@ \subsubsection{Member names}--Member names must contain only characters from the set {\tt [a-zA-Z0-9\_]},-may not begin with a digit, and must be at least one character long.--<<DBus/Types.hs>>=-NAME_TYPE(MemberName, "member name")--mkMemberName :: Text -> Maybe MemberName-mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where-	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"-	c' = c ++ ['0'..'9']-	name = P.oneOf c >> P.many (P.oneOf c')-	parser = name >> P.eof >> return (MemberName s)--<<type exports>>=-  -- ** Member names-, MemberName-, strMemberName-, mkMemberName-, mkMemberName_--@-\section{Messages}--@ To prevent internal details of messages from leaking out to clients,-declarations are contained in an internal module and then re-exported-in the public module.--<<DBus/Message.hs>>=-<<copyright>>-module DBus.Message-	(<<message exports>>-	) where-import DBus.Message.Internal--<<DBus/Message/Internal.hs>>=-<<copyright>>-<<text extensions>>-module DBus.Message.Internal where-<<text imports>>-import qualified Data.Set as S-import Data.Word (Word8, Word32)-import Data.Maybe (fromMaybe)-import qualified DBus.Types as T-import DBus.Util (maybeIndex)--<<DBus/Message/Internal.hs>>=-class Message a where-	messageTypeCode     :: a -> Word8-	messageHeaderFields :: a -> [HeaderField]-	messageFlags        :: a -> S.Set Flag-	messageBody         :: a -> [T.Variant]--<<message exports>>=-Message ( messageFlags-        , messageBody-        )--@ \subsection{Flags}--The instance of {\tt Ord} only exists for storing flags in a set. Flags have-no inherent ordering.--<<DBus/Message/Internal.hs>>=-data Flag-	= NoReplyExpected-	| NoAutoStart-	deriving (Show, Eq, Ord)--<<message exports>>=-, Flag (..)--@ \subsection{Header fields}--<<DBus/Message/Internal.hs>>=-data HeaderField-	= Path        T.ObjectPath-	| Interface   T.InterfaceName-	| Member      T.MemberName-	| ErrorName   T.ErrorName-	| ReplySerial Serial-	| Destination T.BusName-	| Sender      T.BusName-	| Signature   T.Signature-	deriving (Show, Eq)--@ \subsection{Serials}--{\tt Serial} is just a wrapper around {\tt Word32}, to provide a bit of-added type-safety.--<<DBus/Message/Internal.hs>>=-<<apidoc Serial>>-newtype Serial = Serial { serialValue :: Word32 }-	deriving (Eq, Ord)--instance Show Serial where-	show (Serial x) = show x--instance T.Variable Serial where-	toVariant (Serial x) = T.toVariant x-	fromVariant = fmap Serial . T.fromVariant--@ Additionally, some useful functions exist for incrementing serials.--<<DBus/Message/Internal.hs>>=-firstSerial :: Serial-firstSerial = Serial 1--nextSerial :: Serial -> Serial-nextSerial (Serial x) = Serial (x + 1)--@ The {\tt Serial} constructor isn't useful to clients, because building-arbitrary serials doesn't make any sense.--<<message exports>>=-, Serial-, serialValue-, firstSerial-, nextSerial--@ \subsection{Message types}--<<DBus/Message/Internal.hs>>=-maybe' :: (a -> b) -> Maybe a -> [b]-maybe' f = maybe [] (\x' -> [f x'])--@ \subsubsection{Method calls}--<<DBus/Message/Internal.hs>>=-data MethodCall = MethodCall-	{ methodCallPath        :: T.ObjectPath-	, methodCallMember      :: T.MemberName-	, methodCallInterface   :: Maybe T.InterfaceName-	, methodCallDestination :: Maybe T.BusName-	, methodCallFlags       :: S.Set Flag-	, methodCallBody        :: [T.Variant]-	}-	deriving (Show, Eq)--instance Message MethodCall where-	messageTypeCode _ = 1-	messageFlags      = methodCallFlags-	messageBody       = methodCallBody-	messageHeaderFields m = concat-		[ [ Path    $ methodCallPath m-		  ,  Member $ methodCallMember m-		  ]-		, maybe' Interface . methodCallInterface $ m-		, maybe' Destination . methodCallDestination $ m-		]--<<message exports>>=-, MethodCall (..)--@ \subsubsection{Method returns}--<<DBus/Message/Internal.hs>>=-data MethodReturn = MethodReturn-	{ methodReturnSerial      :: Serial-	, methodReturnDestination :: Maybe T.BusName-	, methodReturnBody        :: [T.Variant]-	}-	deriving (Show, Eq)--instance Message MethodReturn where-	messageTypeCode _ = 2-	messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]-	messageBody       = methodReturnBody-	messageHeaderFields m = concat-		[ [ ReplySerial $ methodReturnSerial m-		  ]-		, maybe' Destination . methodReturnDestination $ m-		]--<<message exports>>=-, MethodReturn (..)--@ \subsubsection{Errors}--<<DBus/Message/Internal.hs>>=-data Error = Error-	{ errorName        :: T.ErrorName-	, errorSerial      :: Serial-	, errorDestination :: Maybe T.BusName-	, errorBody        :: [T.Variant]-	}-	deriving (Show, Eq)--instance Message Error where-	messageTypeCode _ = 3-	messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]-	messageBody       = errorBody-	messageHeaderFields m = concat-		[ [ ErrorName   $ errorName m-		  , ReplySerial $ errorSerial m-		  ]-		, maybe' Destination . errorDestination $ m-		]--@ Errors usually contain a human-readable message in their first body field.-This function lets it be retrieved easily, with a fallback if no valid-message was found.--<<DBus/Message/Internal.hs>>=-errorMessage :: Error -> Text-errorMessage msg = fromMaybe "(no error message)" $ do-	field <- maybeIndex (errorBody msg) 0-	text <- T.fromVariant field-	if TL.null text-		then Nothing-		else return text--<<message exports>>=-, Error (..)-, errorMessage--@ \subsubsection{Signals}--<<DBus/Message/Internal.hs>>=-data Signal = Signal-	{ signalPath        :: T.ObjectPath-	, signalMember      :: T.MemberName-	, signalInterface   :: T.InterfaceName-	, signalDestination :: Maybe T.BusName-	, signalBody        :: [T.Variant]-	}-	deriving (Show, Eq)--instance Message Signal where-	messageTypeCode _ = 4-	messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]-	messageBody       = signalBody-	messageHeaderFields m = concat-		[ [ Path      $ signalPath m-		  , Member    $ signalMember m-		  , Interface $ signalInterface m-		  ]-		, maybe' Destination . signalDestination $ m-		]--<<message exports>>=-, Signal (..)--@ \subsubsection{Unknown messages}--Unknown messages are used for storing information about messages without-a recognised type code. They are not instances of {\tt Message}, because-if they were, then clients could accidentally send invalid messages over-the bus.--<<DBus/Message/Internal.hs>>=-data Unknown = Unknown-	{ unknownType    :: Word8-	, unknownFlags   :: S.Set Flag-	, unknownBody    :: [T.Variant]-	}-	deriving (Show, Eq)--<<message exports>>=-, Unknown (..)--@ \subsection{Received messages}--Messages received from a bus have additional fields which do not make sense-when sending.--If a message has an unknown type, its serial and origin are still useful-for sending an error reply.--<<DBus/Message/Internal.hs>>=-<<apidoc ReceivedMessage>>-data ReceivedMessage-	= ReceivedMethodCall   Serial (Maybe T.BusName) MethodCall-	| ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn-	| ReceivedError        Serial (Maybe T.BusName) Error-	| ReceivedSignal       Serial (Maybe T.BusName) Signal-	| ReceivedUnknown      Serial (Maybe T.BusName) Unknown-	deriving (Show, Eq)--<<DBus/Message/Internal.hs>>=-receivedSerial :: ReceivedMessage -> Serial-receivedSerial (ReceivedMethodCall   s _ _) = s-receivedSerial (ReceivedMethodReturn s _ _) = s-receivedSerial (ReceivedError        s _ _) = s-receivedSerial (ReceivedSignal       s _ _) = s-receivedSerial (ReceivedUnknown      s _ _) = s--<<DBus/Message/Internal.hs>>=-receivedSender :: ReceivedMessage -> Maybe T.BusName-receivedSender (ReceivedMethodCall   _ s _) = s-receivedSender (ReceivedMethodReturn _ s _) = s-receivedSender (ReceivedError        _ s _) = s-receivedSender (ReceivedSignal       _ s _) = s-receivedSender (ReceivedUnknown      _ s _) = s--<<DBus/Message/Internal.hs>>=-receivedBody :: ReceivedMessage -> [T.Variant]-receivedBody (ReceivedMethodCall   _ _ x) = messageBody x-receivedBody (ReceivedMethodReturn _ _ x) = messageBody x-receivedBody (ReceivedError        _ _ x) = messageBody x-receivedBody (ReceivedSignal       _ _ x) = messageBody x-receivedBody (ReceivedUnknown      _ _ x) = unknownBody x--<<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-import DBus.Wire.Marshal-import DBus.Wire.Unmarshal--<<DBus/Wire/Internal.hs>>=-<<copyright>>-module DBus.Wire.Internal where-import Data.Word (Word8, Word64)-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.--<<DBus/Wire/Marshal.hs>>=-<<copyright>>-{-# LANGUAGE TypeFamilies #-}-module DBus.Wire.Marshal where-<<text imports>>-<<marshal imports>>-import DBus.Wire.Internal-import Control.Monad (when)-import Data.Maybe (fromJust)-import Data.Word (Word8, Word32, Word64)-import Data.Int (Int16, Int32, Int64)--import qualified DBus.Types as T--<<marshal imports>>=-import qualified Control.Monad.State as State-import qualified DBus.Util.MonadError as E-import qualified Data.ByteString.Lazy as L-import qualified Data.Binary.Builder as B--<<DBus/Wire/Marshal.hs>>=-data MarshalState = MarshalState Endianness B.Builder !Word64-type MarshalM = E.ErrorT MarshalError (State.State 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/Marshal.hs>>=-runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString-runMarshal m e = case State.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/Marshal.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/Marshal.hs>>=-append :: L.ByteString -> Marshal-append bytes = do-	(MarshalState e builder count) <- State.get-	let builder' = B.append builder $ B.fromLazyByteString bytes-	    count' = count + fromIntegral (L.length bytes)-	State.put $ MarshalState e builder' count'--<<DBus/Wire/Marshal.hs>>=-pad :: Word8 -> Marshal-pad count = do-	(MarshalState _ _ existing) <- State.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/Marshal.hs>>=-marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal-marshalBuilder size be le x = do-	pad size-	(MarshalState e builder count) <- State.get-	let builder' = B.append builder $ case e of-		BigEndian -> be x-		LittleEndian -> le x-	let count' = count + fromIntegral size-	State.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/Marshal.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]--<<wire exports>>=-, MarshalError (..)--@ \subsection{Unmarshaling}--Unmarshaling also uses an error transformer and internal state.--<<DBus/Wire/Unmarshal.hs>>=-<<copyright>>-<<text extensions>>-{-# LANGUAGE TypeFamilies #-}-module DBus.Wire.Unmarshal where-<<text imports>>-<<unmarshal imports>>-import Control.Monad (when, unless, liftM)-import Data.Maybe (fromJust, listToMaybe, fromMaybe)-import Data.Word (Word8, Word32, Word64)-import Data.Int (Int16, Int32, Int64)--import DBus.Wire.Internal-import qualified DBus.Types as T--<<unmarshal imports>>=-import qualified Control.Monad.State as State-import Control.Monad.Trans.Class (lift)-import qualified DBus.Util.MonadError as E-import qualified Data.ByteString.Lazy as L--<<DBus/Wire/Unmarshal.hs>>=-data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64-type Unmarshal = E.ErrorT UnmarshalError (State.State UnmarshalState)--<<DBus/Wire/Unmarshal.hs>>=-runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a-runUnmarshal m e bytes = State.evalState (E.runErrorT m) state where-	state = UnmarshalState e bytes 0--<<DBus/Wire/Unmarshal.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/Unmarshal.hs>>=-consume :: Word64 -> Unmarshal L.ByteString-consume count = do-	(UnmarshalState e bytes offset) <- State.get-	let (x, bytes') = L.splitAt (fromIntegral count) bytes-	unless (L.length x == fromIntegral count) $-		E.throwError $ UnexpectedEOF offset-	-	State.put $ UnmarshalState e bytes' (offset + count)-	return x--<<DBus/Wire/Unmarshal.hs>>=-skipPadding :: Word8 -> Unmarshal ()-skipPadding count = do-	(UnmarshalState _ _ offset) <- State.get-	bytes <- consume $ padding offset count-	unless (L.all (== 0) bytes) $-		E.throwError $ InvalidPadding offset--<<DBus/Wire/Unmarshal.hs>>=-skipTerminator :: Unmarshal ()-skipTerminator = do-	(UnmarshalState _ _ offset) <- State.get-	bytes <- consume 1-	unless (L.all (== 0) bytes) $-		E.throwError $ MissingTerminator offset--<<DBus/Wire/Unmarshal.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'--<<unmarshal imports>>=-import qualified Data.Binary.Get as G--<<DBus/Wire/Unmarshal.hs>>=-unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a-unmarshalGet count be le = do-	skipPadding count-	(UnmarshalState e _ _) <- State.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/Unmarshal.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/Unmarshal.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"--<<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/Marshal.hs>>=-marshalWord32 :: Word32 -> Marshal-marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le--<<DBus/Wire/Unmarshal.hs>>=-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.--<<marshal imports>>=-import Data.Binary.Put (runPut)-import qualified Data.Binary.IEEE754 as IEEE--<<unmarshal imports>>=-import qualified Data.Binary.IEEE754 as IEEE--<<marshalers>>=-marshalType T.DBusDouble = do-	pad 8-	(MarshalState e _ _) <- State.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.--<<DBus/Wire/Unicode.hs>>=-<<copyright>>-module DBus.Wire.Unicode-	( maybeEncodeUtf8-	, maybeDecodeUtf8) where-import Data.ByteString.Lazy (ByteString)-import Data.Text.Lazy (Text)-import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)-import Data.Text.Encoding.Error (UnicodeException)-import qualified Control.Exception as Exc-import System.IO.Unsafe (unsafePerformIO)--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 ByteString-maybeEncodeUtf8 = excToMaybe . encodeUtf8--maybeDecodeUtf8 :: ByteString -> Maybe Text-maybeDecodeUtf8 = excToMaybe . decodeUtf8--<<marshal imports>>=-import DBus.Wire.Unicode (maybeEncodeUtf8)--<<DBus/Wire/Marshal.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)--<<unmarshal imports>>=-import DBus.Wire.Unicode (maybeDecodeUtf8)--<<DBus/Wire/Unmarshal.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.--<<marshal imports>>=-import Data.Text.Lazy.Encoding (encodeUtf8)--<<DBus/Wire/Marshal.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/Unmarshal.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.--<<marshal imports>>=-import qualified DBus.Constants as C--<<DBus/Wire/Marshal.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/Marshal.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/Marshal.hs>>=-getArrayBytes itemType x = do-	let vs = T.arrayItems x-	s <- State.get-	(MarshalState _ _ afterLength) <- marshalWord32 0 >> State.get-	(MarshalState e _ afterPadding) <- pad (alignment itemType) >> State.get-	-	State.put $ MarshalState e B.empty afterPadding-	(MarshalState _ itemBuilder _) <- mapM_ marshal vs >> State.get-	-	let itemBytes = B.toLazyByteString itemBuilder-	    paddingSize = fromIntegral $ afterPadding - afterLength-	-	State.put s-	return (paddingSize, itemBytes)--@ Unmarshaling is much easier, especially if it's a byte array.--<<DBus/Wire/Unmarshal.hs>>=-unmarshalArray :: T.Type -> Unmarshal T.Array-unmarshalArray T.DBusByte = do-	byteCount <- unmarshalWord32-	T.arrayFromBytes `fmap` consume (fromIntegral byteCount)--<<DBus/Wire/Unmarshal.hs>>=-unmarshalArray itemType = do-	let getOffset = do-		(UnmarshalState _ _ o) <- State.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}--<<marshal imports>>=-import qualified DBus.Message.Internal as M--<<unmarshal imports>>=-import qualified DBus.Message.Internal as M--@ \subsubsection{Flags}--<<unmarshal imports>>=-import Data.Bits ((.&.))-import qualified Data.Set as Set--<<marshal imports>>=-import Data.Bits ((.|.))-import qualified Data.Set as Set--<<DBus/Wire/Marshal.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--<<DBus/Wire/Unmarshal.hs>>=-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/Marshal.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/Unmarshal.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/Unmarshal.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/Marshal.hs>>=-<<apidoc marshalMessage>>-marshalMessage :: M.Message a => Endianness -> M.Serial -> a-               -> Either MarshalError L.ByteString-marshalMessage e serial msg = runMarshal marshaler e where-	body = M.messageBody msg-	marshaler = do-		sig <- checkBodySig body-		empty <- State.get-		mapM_ marshal body-		(MarshalState _ bodyBytesB _) <- State.get-		State.put empty-		marshalEndianness e-		let bodyBytes = B.toLazyByteString bodyBytesB-		marshalHeader msg serial sig-			$ fromIntegral . L.length $ bodyBytes-		pad 8-		append bodyBytes-		checkMaximumSize--<<DBus/Wire/Marshal.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/Marshal.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/Marshal.hs>>=-marshalEndianness :: Endianness -> Marshal-marshalEndianness = marshal . T.toVariant . encodeEndianness--<<DBus/Wire/Marshal.hs>>=-checkMaximumSize :: Marshal-checkMaximumSize = do-	(MarshalState _ _ messageLength) <- State.get-	when (messageLength > fromIntegral C.messageMaximumLength)-		(E.throwError $ MessageTooLong $ fromIntegral messageLength)--@ \subsubsection{Unmarshaling}--<<unmarshal imports>>=-import qualified DBus.Constants as C--<<wire exports>>=-, unmarshalMessage--<<DBus/Wire/Unmarshal.hs>>=-<<apidoc unmarshalMessage>>-unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)-                 -> m (Either UnmarshalError M.ReceivedMessage)-unmarshalMessage getBytes' = E.runErrorT $ do-	let getBytes = lift . getBytes'-	-	<<read fixed-length header>>-	<<read full header>>-	<<read body>>-	<<build message>>--@ The first part of the header has a fixed size of 16 bytes, so it can be-retrieved without any size calculations.--<<read fixed-length header>>=-let fixedSig = "yyyyuuu"-fixedBytes <- getBytes 16--@ The first field of interest is the protocol version; if the incoming-message's version is different from this library, the message cannot be-parsed.--<<read fixed-length header>>=-let messageVersion = L.index fixedBytes 3-when (messageVersion /= C.protocolVersion) $-	E.throwError $ UnsupportedProtocolVersion messageVersion--@ Next is the endianness, used for parsing pretty much every other field.--<<read fixed-length header>>=-let eByte = L.index fixedBytes 0-endianness <- case decodeEndianness eByte of-	Just x' -> return x'-	Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte--@ With the endianness out of the way, the rest of the fixed header-can be decoded--<<read fixed-length header>>=-let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of-	Right x' -> return x'-	Left  e  -> E.throwError e-fixed <- unmarshal' fixedSig fixedBytes-let typeCode = fromJust . T.fromVariant $ fixed !! 1-let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2-let bodyLength = fromJust . T.fromVariant $ fixed !! 4-let serial = fromJust . T.fromVariant $ fixed !! 5--@ The last field of the fixed header is actually part of the field array,-but is treated as a single {\tt Word32} so it'll be known how many bytes-to retrieve.--<<read fixed-length header>>=-let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6--@ With the field byte count, the remainder of the header bytes can be-pulled out of the monad.--<<read full header>>=-let headerSig  = "yyyyuua(yv)"-fieldBytes <- getBytes fieldByteCount-let headerBytes = L.append fixedBytes fieldBytes-header <- unmarshal' headerSig headerBytes--@ And the header fields can be parsed.--<<read full header>>=-let fieldArray = fromJust . T.fromVariant $ header !! 6-let fieldStructures = fromJust . T.fromArray $ fieldArray-fields <- concat `liftM` 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/Unmarshal.hs>>=-findBodySignature :: [M.HeaderField] -> T.Signature-findBodySignature fields = fromMaybe "" signature where-	signature = listToMaybe [x | M.Signature x <- fields]--<<read body>>=-let bodySig = findBodySignature fields--@ Then pull the body bytes, and unmarshal it.--<<read body>>=-bodyBytes <- getBytes bodyLength-body <- unmarshal' bodySig bodyBytes--@ Even if the received message was structurally valid, building the-{\tt ReceivedMessage} can still fail due to missing header fields.--Slightly ugly; to avoid orphan instances of either {\tt Text} or-{\tt Either}, a newtype is used to turn {\tt Either} into a monad.--<<DBus/Wire/Unmarshal.hs>>=-newtype EitherM a b = EitherM (Either a b)--instance Monad (EitherM a) where-	return = EitherM . Right-	(EitherM (Left x)) >>= _ = EitherM (Left x)-	(EitherM (Right x)) >>= k = k x--<<build message>>=-y <- case buildReceivedMessage typeCode fields of-	EitherM (Right x) -> return x-	EitherM (Left x) -> E.throwError $ MissingHeaderField x--<<build message>>=-return $ y serial flags body--@ This really belongs in the Message section...--<<DBus/Wire/Unmarshal.hs>>=-buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text-                        (M.Serial -> (Set.Set M.Flag) -> [T.Variant]-                         -> M.ReceivedMessage)--@ Method calls--<<DBus/Wire/Unmarshal.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/Unmarshal.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/Unmarshal.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/Unmarshal.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/Unmarshal.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/Unmarshal.hs>>=-require :: Text -> [a] -> EitherM Text a-require _     (x:_) = return x-require label _     = EitherM $ Left label--@-\section{Addresses}--<<DBus/Address.hs>>=-<<copyright>>-<<text extensions>>-module DBus.Address-	( Address-	, addressMethod-	, addressParameters-	, mkAddresses-	, strAddress-	) where-<<text imports>>--import Data.Char (ord, chr)-import qualified Data.Map as M-import Text.Printf (printf)-import qualified Text.Parsec as P-import Text.Parsec ((<|>))-import DBus.Util (hexToInt, eitherToMaybe)--@ \subsection{Address syntax}--A bus address is in the format {\tt $method$:$key$=$value$,$key$=$value$...}-where the method may be empty and parameters are optional. An address's-parameter list, if present, may end with a comma. Addresses in environment-variables are separated by semicolons, and the full address list may end-in a semicolon. Multiple parameters may have the same key; in this case,-only the first parameter for each key will be stored.--The bytes allowed in each component of the address are given by the following-chart, where each character is understood to be its ASCII value:--\begin{table}[h]-\begin{center}-\begin{tabular}{ll}-\toprule-Component   & Allowed Characters \\-\midrule-Method      & Any except {\tt `;'} and {\tt `:'} \\-Param key   & Any except {\tt `;'}, {\tt `,'}, and {\tt `='} \\-Param value & {\tt `0'} to {\tt `9'} \\-            & {\tt `a'} to {\tt `z'} \\-            & {\tt `A'} to {\tt `Z'} \\-            & Any of: {\tt - \textunderscore{} / \textbackslash{} * . \%} \\-\bottomrule-\end{tabular}-\end{center}-\end{table}--In parameter values, any byte may be encoded by prepending the \% character-to its value in hexadecimal. \% is not allowed to appear unless it is-followed by two hexadecimal digits. Every other allowed byte is termed-an ``optionally encoded'' byte, and may appear unescaped in parameter-values.--<<DBus/Address.hs>>=-optionallyEncoded :: [Char]-optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."--@-The address simply stores its method and parameter map, with a custom-{\tt Show} instance to provide easier debugging.--<<DBus/Address.hs>>=-data Address = Address-	{ addressMethod     :: Text-	, addressParameters :: M.Map Text Text-	} deriving (Eq)--instance Show Address where-	showsPrec d x = showParen (d> 10) $-		showString "Address " . shows (strAddress x)--@-Parsing is straightforward; the input string is divided into addresses by-semicolons, then further by colons and commas. Parsing will fail if any-of the addresses in the input failed to parse.--<<DBus/Address.hs>>=-mkAddresses :: Text -> Maybe [Address]-mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where-	address = do-		method <- P.many (P.noneOf ":;")-		P.char ':'-		params <- P.sepEndBy param (P.char ',')-		return $ Address (TL.pack method) (M.fromList params)-	-	param = do-		key <- P.many1 (P.noneOf "=;,")-		P.char '='-		value <- P.many1 (encodedValue <|> unencodedValue)-		return (TL.pack key, TL.pack value)-	-	parser = do-		as <- P.sepEndBy1 address (P.char ';')-		P.eof-		return as-	-	unencodedValue = P.oneOf optionallyEncoded-	encodedValue = do-		P.char '%'-		hex <- P.count 2 P.hexDigit-		return . chr . hexToInt $ hex--@-Converting an {\tt Address} back to a {\tt String} is just the reverse-operation. Note that because the original parameter order is not preserved,-the string produced might differ from the original input.--<<DBus/Address.hs>>=-strAddress :: Address -> Text-strAddress (Address t ps) = TL.concat [t, ":", ps'] where-	ps' = TL.intercalate "," $ do-		(k, v) <- M.toList ps-		return $ TL.concat [k, "=", TL.concatMap encode v]-	encode c | elem c optionallyEncoded = TL.singleton c-	         | otherwise       = TL.pack $ printf "%%%02X" (ord c)--@-\section{Connections}--<<DBus/Connection.hs>>=-<<copyright>>-<<text extensions>>-{-# LANGUAGE DeriveDataTypeable #-}-module DBus.Connection-	( <<connection exports>>-	) where-<<text imports>>-<<connection imports>>--@ A {\tt Connection} is an opaque handle to an open D-Bus channel, with-an internal state for maintaining the current message serial.--The second {\tt MVar} doesn't really store a value, it's just used to-prevent two separate threads from reading from the transport at once.--<<connection imports>>=-import qualified Control.Concurrent as C-import qualified DBus.Address as A-import qualified DBus.Message as M-import qualified DBus.UUID as UUID--<<DBus/Connection.hs>>=-data Connection = Connection-	{ connectionAddress    :: A.Address-	, connectionTransport  :: Transport-	, connectionSerialMVar :: C.MVar M.Serial-	, connectionReadMVar   :: C.MVar ()-	, connectionUUID       :: UUID.UUID-	}--<<connection exports>>=-  Connection-, connectionAddress-, connectionUUID--@ While not particularly useful for other functions, being able to-{\tt show} a {\tt Connection} is useful when debugging.--<<DBus/Connection.hs>>=-instance Show Connection where-	showsPrec d con = showParen (d > 10) strCon where-		addr = A.strAddress $ connectionAddress con-		strCon = s "<Connection " . shows addr . s ">"-		s = showString--@ \subsection{Transports}--A transport is anything which can send and receive bytestrings, typically-via a socket.--<<connection imports>>=-import qualified Data.ByteString.Lazy as L-import Data.Word (Word32)--<<DBus/Connection.hs>>=-<<apidoc Transport>>-data Transport = Transport-	{ transportSend :: L.ByteString -> IO ()-	, transportRecv :: Word32 -> IO L.ByteString-	, transportClose :: IO ()-	}--@ 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) (I.hClose h)--@ \subsection{Errors}--If connecting to D-Bus fails, a {\tt ConnectionError} will be thrown.-The constructor describes which exception occurred.--<<connection imports>>=-import qualified Control.Exception as E-import Data.Typeable (Typeable)--<<DBus/Connection.hs>>=-data ConnectionError-	= InvalidAddress Text-	| BadParameters A.Address Text-	| UnknownMethod A.Address-	| NoWorkingAddress [A.Address]-	deriving (Show, Typeable)--instance E.Exception ConnectionError--<<connection exports>>=-, ConnectionError (..)--@ \subsection{Establishing a connection}--A connection can be opened to any valid address, though actually connecting-might fail due to external factors.--<<connection imports>>=-import qualified DBus.Authentication as Auth--<<DBus/Connection.hs>>=-<<apidoc connect>>-connect :: Auth.Mechanism -> A.Address -> IO Connection-connect mechanism a = do-	t <- connectTransport a-	let getByte = L.head `fmap` transportRecv t 1-	uuid <- Auth.authenticate mechanism (transportSend t) getByte-	readLock <- C.newMVar ()-	serialMVar <- C.newMVar M.firstSerial-	return $ Connection a t serialMVar readLock uuid--@ Since addresses usually come in a list, it's sensible to have a variant-of {\tt connect} which tries multiple addresses. The first successfully-opened {\tt Connection} is returned.--<<DBus/Connection.hs>>=-<<apidoc connectFirst>>-connectFirst :: [(Auth.Mechanism, A.Address)] -> IO Connection-connectFirst orig = connectFirst' orig where-	allAddrs = [a | (_, a) <- orig]-	connectFirst'     [] = E.throwIO $ NoWorkingAddress allAddrs-	connectFirst' ((mech, a):as) = E.catch (connect mech a) $-		\(E.SomeException _) -> connectFirst' as--<<connection exports>>=-, connect-, connectFirst--@ \subsection{Closing connections}--<<DBus/Connection.hs>>=-<<apidoc connectionClose>>-connectionClose :: Connection -> IO ()-connectionClose = transportClose . connectionTransport--<<connection exports>>=-, connectionClose--@ \subsection{Authentication}--Authentication is a bit iffy; currently, there's a one specified-authentication mechanism ({\tt DBUS\_COOKIE\_SHA1}), which I've never seen-in the wild. Everybody seems to use {\tt EXTERNAL}, described below.--To support multiple modes more easily in the future, and for user-defined-authentication handling (eg, in proxy servers), authentication is handled by-a separate module.--<<DBus/Authentication.hs>>=-<<copyright>>-<<text extensions>>-{-# LANGUAGE DeriveDataTypeable #-}-module DBus.Authentication-	( <<authentication exports>>-	) where-<<text imports>>-<<authentication imports>>--@ The authentication protocol is based on {\sc ascii} text, initiated by the-client. Commands and mechanisms are represented by a couple data types:--<<authentication imports>>=-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as ByteString-import qualified DBus.UUID as UUID--<<DBus/Authentication.hs>>=-type Command = Text-newtype Mechanism = Mechanism-	{ mechanismRun :: (Command -> IO Command) -> IO UUID.UUID-	}--<<authentication exports>>=-  Command-, Mechanism (..)--@ If authentication fails, an exception will be raised.--<<authentication imports>>=-import Data.Typeable (Typeable)-import qualified Control.Exception as E--<<DBus/Authentication.hs>>=-data AuthenticationError-	= AuthenticationError Text-	deriving (Show, Typeable)--instance E.Exception AuthenticationError--<<authentication exports>>=-, AuthenticationError (..)--@ The process begins by the client sending a single {\sc nul} byte, followed-by exchanges of {\sc ascii} commands until authentication is complete. Which-commands are sent depends on the selected mechanism.--<<authentication imports>>=-import Data.Word (Word8)--<<DBus/Authentication.hs>>=-authenticate :: Mechanism -> (ByteString -> IO ()) -> IO Word8-             -> IO UUID.UUID-authenticate mech put getByte = do-	put $ ByteString.singleton 0-	uuid <- mechanismRun mech (putCommand put getByte)-	put "BEGIN\r\n"-	return uuid--<<authentication exports>>=-, authenticate--@ TODO: describe {\tt putCommand} here--<<authentication imports>>=-import Control.Monad (liftM)-import Data.Char (chr)-import Data.Text.Lazy.Encoding (encodeUtf8)-import DBus.Util (readUntil, dropEnd)--<<DBus/Authentication.hs>>=-putCommand :: Monad m => (ByteString -> m ()) -> m Word8 -> Command -> m Command-putCommand put get cmd = do-	let getC = liftM (chr . fromIntegral) get-	put $ encodeUtf8 cmd-	put "\r\n"-	liftM (TL.pack . dropEnd 2) $ readUntil "\r\n" getC--@ \subsubsection{Support authentication mechanisms}--Currently, the only supported authentication mechanism is sending the local-user's ``real user ID''.--<<authentication exports>>=-, realUserID--<<authentication imports>>=-import System.Posix.User (getRealUserID)-import Data.Char (ord)-import Text.Printf (printf)--<<DBus/Authentication.hs>>=-realUserID :: Mechanism-realUserID = Mechanism $ \sendCmd -> do-	uid <- getRealUserID-	let token = concatMap (printf "%02X" . ord) (show uid)-	let cmd = "AUTH EXTERNAL " ++ token-	eitherUUID <- checkOK `fmap` sendCmd (TL.pack cmd)-	case eitherUUID of-		Right uuid -> return uuid-		Left err -> E.throwIO $ AuthenticationError err--@ If authentication was successful, the server responds with {\tt OK-<server GUID>}.--<<authentication imports>>=-import Data.Maybe (isJust)--<<DBus/Authentication.hs>>=-checkOK :: Command -> Either Text UUID.UUID-checkOK cmd = if validUUID then Right uuid else Left errorMsg where-	validUUID = TL.isPrefixOf "OK " cmd && isJust maybeUUID-	maybeUUID = UUID.fromHex $ TL.drop 3 cmd-	Just uuid = maybeUUID-	errorMsg = if TL.isPrefixOf "ERROR " cmd-		then TL.drop 6 cmd-		else TL.pack $ "Unexpected response: " ++ show cmd--@ \subsection{Sending and receiving messages}--Sending a message will increment the connection's internal serial state.-The second parameter is present to allow registration of a callback before-the message has actually been sent, which avoids race conditions in-multi-threaded clients.--<<connection imports>>=-import qualified DBus.Wire as W--<<DBus/Connection.hs>>=-<<apidoc send>>-send :: M.Message a => Connection -> (M.Serial -> IO b) -> a-     -> IO (Either W.MarshalError b)-send (Connection _ t mvar _ _) io msg = withSerial mvar $ \serial ->-	case W.marshalMessage W.LittleEndian serial msg of-		Right bytes -> do-			x <- io serial-			transportSend t bytes-			return $ Right x-		Left  err   -> return $ Left err--<<connection exports>>=-, send--<<DBus/Connection.hs>>=-withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a-withSerial m io = E.block $ do-	s <- C.takeMVar m-	let s' = M.nextSerial s-	x <- E.unblock (io s) `E.onException` C.putMVar m s'-	C.putMVar m s'-	return x--@ Messages are received wrapped in a {\tt ReceivedMessage} value. If an-error is encountered while unmarshaling, an exception will be thrown.--<<DBus/Connection.hs>>=-<<apidoc receive>>-receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage)-receive (Connection _ t _ lock _) = C.withMVar lock $ \_ ->-	W.unmarshalMessage $ transportRecv t--<<connection exports>>=-, receive--@-\section{The central bus}--<<DBus/Bus.hs>>=-<<copyright>>-<<text extensions>>-module DBus.Bus-	( getBus-	, getFirstBus-	, getSystemBus-	, getSessionBus-	, getStarterBus-	) where-<<text imports>>--import qualified Control.Exception as E-import Control.Monad (when)-import Data.Maybe (fromJust, isNothing)-import qualified Data.Set as Set-import System.Environment (getEnv)--import qualified DBus.Address as A-import qualified DBus.Authentication as Auth-import qualified DBus.Connection as C-import DBus.Constants (dbusName, dbusPath, dbusInterface)-import qualified DBus.Message as M-import qualified DBus.Types as T-import DBus.Util (fromRight)--@ Connecting to a message bus is a bit more involved than just connecting-over an app-to-app connection: the bus must be notified of the new client,-using a "hello message", before it will begin forwarding messages.--<<DBus/Bus.hs>>=-busForConnection :: C.Connection -> IO (C.Connection, T.BusName)-busForConnection c = fmap ((,) c) $ sendHello c--<<DBus/Bus.hs>>=-<<apidoc getBus>>-getBus :: Auth.Mechanism -> A.Address -> IO (C.Connection, T.BusName)-getBus = ((busForConnection =<<) .) . C.connect--@ Optionally, multiple addresses may be provided. The first successful-connection will be used.--<<DBus/Bus.hs>>=-<<apidoc getFirstBus>>-getFirstBus :: [(Auth.Mechanism, A.Address)] -> IO (C.Connection, T.BusName)-getFirstBus = (busForConnection =<<) . C.connectFirst--@ \subsection{Default connections}--Two default buses are defined, the ``system'' and ``session'' buses. The system-bus is global for the OS, while the session bus runs only for the duration-of the user's session.--<<DBus/Bus.hs>>=-<<apidoc getSystemBus>>-getSystemBus :: IO (C.Connection, T.BusName)-getSystemBus = getBus' $ fromEnv `E.catch` noEnv where-	defaultAddr = "unix:path=/var/run/dbus/system_bus_socket"-	fromEnv = getEnv "DBUS_SYSTEM_BUS_ADDRESS"-	noEnv (E.SomeException _) = return defaultAddr--<<DBus/Bus.hs>>=-<<apidoc getSessionBus>>-getSessionBus :: IO (C.Connection, T.BusName)-getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS"--<<DBus/Bus.hs>>=-<<apidoc getStarterBus>>-getStarterBus :: IO (C.Connection, T.BusName)-getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS"--<<DBus/Bus.hs>>=-getBus' :: IO String -> IO (C.Connection, T.BusName)-getBus' io = do-	addr <- fmap TL.pack io-	case A.mkAddresses addr of-		Just [x] -> getBus Auth.realUserID x-		Just  xs -> getFirstBus [(Auth.realUserID,x) | x <- xs]-		_        -> E.throwIO $ C.InvalidAddress addr--@ \subsection{Sending the ``hello'' message}--<<DBus/Bus.hs>>=-hello :: M.MethodCall-hello = M.MethodCall dbusPath-	"Hello"-	(Just dbusInterface)-	(Just dbusName)-	Set.empty-	[]--<<DBus/Bus.hs>>=-sendHello :: C.Connection -> IO T.BusName-sendHello c = do-	serial <- fromRight `fmap` C.send c return hello-	reply <- waitForReply c serial-	let name = case M.methodReturnBody reply of-		(x:_) -> T.fromVariant x-		_     -> Nothing-	-	when (isNothing name) $-		E.throwIO $ E.AssertionFailed "Invalid response to Hello()"-	-	return . fromJust $ name--<<DBus/Bus.hs>>=-waitForReply :: C.Connection -> M.Serial -> IO M.MethodReturn-waitForReply c serial = do-	received <- C.receive c-	msg <- case received of-		Right x -> return x-		Left _  -> E.throwIO $ E.AssertionFailed "Invalid response to Hello()"-	case msg of-		(M.ReceivedMethodReturn _ _ reply) ->-			if M.methodReturnSerial reply == serial-				then return reply-				else waitForReply c serial-		_ -> waitForReply c serial--@-\section{Introspection}--@ D-Bus objects may be ``introspected'' to determine which methods, signals,-etc they support. Intospection data is sent over the bus in {\sc xml}, in-a mostly standardised but undocumented format.--An XML introspection document looks like this:--\begin{verbatim}-<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"-         "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">-<node name="/org/example/example">-	<interface name="org.example.ExampleInterface">-		<method name="Echo">-			<arg name="text" type="s" direction="in"/>-			<arg type="s" direction="out"/>-		</method>-		<signal name="Echoed">-			<arg type="s"/>-		</signal>-		<property name="EchoCount" type="u" access="read"/>-	</interface>-	<node name="child_a"/>-	<node name="child/b"/>-</node>-\end{verbatim}--<<DBus/Introspection.hs>>=-<<copyright>>-<<text extensions>>-module DBus.Introspection-	( Object (..)-	, Interface (..)-	, Method (..)-	, Signal (..)-	, Parameter (..)-	, Property (..)-	, PropertyAccess (..)-	, toXML-	, fromXML-	) where-<<text imports>>-<<introspection imports>>-import qualified DBus.Types as T--@ HaXml is used to do the heavy lifting of XML parsing because HXT cannot-be combined with Parsec 3.--<<introspection imports>>=-import qualified Text.XML.HaXml as H--@ \subsection{Data types}--<<DBus/Introspection.hs>>=-data Object = Object T.ObjectPath [Interface] [Object]-	deriving (Show, Eq)--data Interface = Interface T.InterfaceName [Method] [Signal] [Property]-	deriving (Show, Eq)--data Method = Method T.MemberName [Parameter] [Parameter]-	deriving (Show, Eq)--data Signal = Signal T.MemberName [Parameter]-	deriving (Show, Eq)--data Parameter = Parameter Text T.Signature-	deriving (Show, Eq)--data Property = Property Text T.Signature [PropertyAccess]-	deriving (Show, Eq)--data PropertyAccess = Read | Write-	deriving (Show, Eq)--@ \subsection{Parsing XML}--The root {\tt node} is special, in that it's the only {\tt node} which is-not required to have a {\tt name} attribute. If the root has no {\tt name},-its path will default to the path of the introspected object.--If parsing fails, {\tt fromXML} will return {\tt Nothing}. Aside from the-elements directly accessed by the parser, no effort is made to check the-document's validity because there is no DTD as of yet.--<<introspection imports>>=-import Text.XML.HaXml.Parse (xmlParse')-import DBus.Util (eitherToMaybe)--<<DBus/Introspection.hs>>=-fromXML :: T.ObjectPath -> Text -> Maybe Object-fromXML path text = do-	doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text-	let (H.Document _ _ root _) = doc-	parseRoot path root--@ Even though the root object's {\tt name} is optional, if present, it must-still be a valid object path.--<<DBus/Introspection.hs>>=-parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object-parseRoot defaultPath e = do-	path <- case getAttr "name" e of-		Nothing -> Just defaultPath-		Just x  -> T.mkObjectPath x-	parseObject' path e--@ Child {\tt nodes} have ``relative'' paths -- that is, their {\tt name}-attribute is not a valid object path, but should be valid when appended to-the root object's path.--<<DBus/Introspection.hs>>=-parseChild :: T.ObjectPath -> H.Element a -> Maybe Object-parseChild parentPath e = do-	let parentPath' = case T.strObjectPath parentPath of-		"/" -> "/"-		x   -> TL.append x "/"-	pathSegment <- getAttr "name" e-	path <- T.mkObjectPath $ TL.append parentPath' pathSegment-	parseObject' path e--@ Other than the name, both root and non-root {\tt nodes} have identical-contents.  They may contain interface definitions, and child {\tt node}s.--<<DBus/Introspection.hs>>=-parseObject' :: T.ObjectPath -> H.Element a -> Maybe Object-parseObject' path e@(H.Elem "node" _ _)  = do-	interfaces <- children parseInterface (H.tag "interface") e-	children' <- children (parseChild path) (H.tag "node") e-	return $ Object path interfaces children'-parseObject' _ _ = Nothing--@ Interfaces may contain methods, signals, and properties.--<<DBus/Introspection.hs>>=-parseInterface :: H.Element a -> Maybe Interface-parseInterface e = do-	name <- T.mkInterfaceName =<< getAttr "name" e-	methods <- children parseMethod (H.tag "method") e-	signals <- children parseSignal (H.tag "signal") e-	properties <- children parseProperty (H.tag "property") e-	return $ Interface name methods signals properties--@ Methods contain a list of parameters, which default to ``in'' parameters-if no direction is specified.--<<DBus/Introspection.hs>>=-parseMethod :: H.Element a -> Maybe Method-parseMethod e = do-	name <- T.mkMemberName =<< getAttr "name" e-	paramsIn <- children parseParameter (isParam ["in", ""]) e-	paramsOut <- children parseParameter (isParam ["out"]) e-	return $ Method name paramsIn paramsOut--@ Signals are similar to methods, except they have no ``in'' parameters.--<<DBus/Introspection.hs>>=-parseSignal :: H.Element a -> Maybe Signal-parseSignal e = do-	name <- T.mkMemberName =<< getAttr "name" e-	params <- children parseParameter (isParam ["out", ""]) e-	return $ Signal name params--@ A parameter has a free-form name, and a single valid type.--<<DBus/Introspection.hs>>=-parseParameter :: H.Element a -> Maybe Parameter-parseParameter e = do-	let name = getAttr' "name" e-	sig <- parseType e-	return $ Parameter name sig--<<DBus/Introspection.hs>>=-parseType :: H.Element a -> Maybe T.Signature-parseType e = do-	sig <- T.mkSignature =<< getAttr "type" e-	case T.signatureTypes sig of-		[_] -> Just sig-		_   -> Nothing--@ Properties are used by the {\tt org.freedesktop.DBus.Properties} interface.-Each property may be read, written, or both, and has an associated type.--<<DBus/Introspection.hs>>=-parseProperty :: H.Element a -> Maybe Property-parseProperty e = do-	let name = getAttr' "name" e-	sig <- parseType e-	access <- case getAttr' "access" e of-		""          -> Just []-		"read"      -> Just [Read]-		"write"     -> Just [Write]-		"readwrite" -> Just [Read, Write]-		_           -> Nothing-	return $ Property name sig access--@ HaXml doesn't seem to have any way to retrieve the ``real'' value of an-attribute, so {\tt attrValue} implements this.--<<introspection imports>>=-import Data.Char (chr)--<<DBus/Introspection.hs>>=-attrValue :: H.AttValue -> Maybe Text-attrValue attr = fmap (TL.pack . concat) $ mapM unescape parts where-	(H.AttValue parts) = attr-	-	unescape (Left x) = Just x-	unescape (Right (H.RefEntity x)) = lookup x namedRefs-	unescape (Right (H.RefChar x)) = Just [chr x]-	-	namedRefs =-		[ ("lt", "<")-		, ("gt", ">")-		, ("amp", "&")-		, ("apos", "'")-		, ("quot", "\"")-		]--@ Some helper functions for dealing with HaXml filters--<<introspection imports>>=-import Data.Maybe (fromMaybe)--<<DBus/Introspection.hs>>=-getAttr :: String -> H.Element a -> Maybe Text-getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue--getAttr' :: String -> H.Element a -> Text-getAttr' = (fromMaybe "" .) . getAttr--<<DBus/Introspection.hs>>=-isParam :: [Text] -> H.CFilter a-isParam dirs content = do-	arg@(H.CElem e _) <- H.tag "arg" content-	let direction = getAttr' "direction" e-	[arg | direction `elem` dirs]--<<DBus/Introspection.hs>>=-children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b]-children f filt (H.Elem _ _ contents) =-	mapM f [x | (H.CElem x _) <- concatMap filt contents]--@ \subsection{Generating XML}--<<DBus/Introspection.hs>>=-dtdPublicID, dtdSystemID :: String-dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"-dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"--@ HaXml punts to the {\tt pretty} package for serialising XML.--<<introspection imports>>=-import Text.XML.HaXml.Pretty (document)-import Text.PrettyPrint.HughesPJ (render)--@ Generating XML can fail; if a child object's path is not a sub-path of the-parent, {\tt toXML} will return {\tt Nothing}.--<<DBus/Introspection.hs>>=-toXML :: Object -> Maybe Text-toXML obj = fmap (TL.pack . render . document) doc where-	prolog = H.Prolog Nothing [] (Just doctype) []-	doctype = H.DTD "node" (Just (H.PUBLIC-		(H.PubidLiteral dtdPublicID)-		(H.SystemLiteral dtdSystemID))) []-	doc = do-		root <- xmlRoot obj-		return $ H.Document prolog H.emptyST root []--@ When writing objects to {\tt node}s, the root object must have an absolute-path, and children must have paths relative to their parent.--<<DBus/Introspection.hs>>=-xmlRoot :: Object -> Maybe (H.Element a)-xmlRoot obj@(Object path _ _) = do-	(H.CElem root _) <- xmlObject' (T.strObjectPath path) obj-	return root--<<DBus/Introspection.hs>>=-xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a)-xmlObject parentPath obj@(Object path _ _) = do-	let path' = T.strObjectPath path-	    parent' = T.strObjectPath parentPath-	relpath <- if TL.isPrefixOf parent' path'-		then Just $ if parent' == "/"-			then TL.drop 1 path'-			else TL.drop (TL.length parent' + 1) path'-		else Nothing-	xmlObject' relpath obj--<<DBus/Introspection.hs>>=-xmlObject' :: Text -> Object -> Maybe (H.Content a)-xmlObject' path (Object fullPath interfaces children') = do-	children'' <- mapM (xmlObject fullPath) children'-	return $ mkElement "node"-		[mkAttr "name" $ TL.unpack path]-		$ concat-			[ map xmlInterface interfaces-			, children''-			]--<<DBus/Introspection.hs>>=-xmlInterface :: Interface -> H.Content a-xmlInterface (Interface name methods signals properties) =-	mkElement "interface"-		[mkAttr "name" . TL.unpack . T.strInterfaceName $ name]-		$ concat-			[ map xmlMethod methods-			, map xmlSignal signals-			, map xmlProperty properties-			]--<<DBus/Introspection.hs>>=-xmlMethod :: Method -> H.Content a-xmlMethod (Method name inParams outParams) = mkElement "method"-	[mkAttr "name" . TL.unpack . T.strMemberName $ name]-	$ concat-		[ map (xmlParameter "in") inParams-		, map (xmlParameter "out") outParams-		]--<<DBus/Introspection.hs>>=-xmlSignal :: Signal -> H.Content a-xmlSignal (Signal name params) = mkElement "signal"-	[mkAttr "name" . TL.unpack . T.strMemberName $ name]-	$ map (xmlParameter "out") params--<<DBus/Introspection.hs>>=-xmlParameter :: String -> Parameter -> H.Content a-xmlParameter direction (Parameter name sig) = mkElement "arg"-	[ mkAttr "name" . TL.unpack $ name-	, mkAttr "type" . TL.unpack . T.strSignature $ sig-	, mkAttr "direction" direction-	] []--<<DBus/Introspection.hs>>=-xmlProperty :: Property -> H.Content a-xmlProperty (Property name sig access) = mkElement "property"-	[ mkAttr "name" . TL.unpack $ name-	, mkAttr "type" . TL.unpack . T.strSignature $ sig-	, mkAttr "access" $ xmlAccess access-	] []--<<DBus/Introspection.hs>>=-xmlAccess :: [PropertyAccess] -> String-xmlAccess access = readS ++ writeS where-	readS = if elem Read access then "read" else ""-	writeS = if elem Write access then "write" else ""--<<DBus/Introspection.hs>>=-mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a-mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined--<<DBus/Introspection.hs>>=-mkAttr :: String -> String -> H.Attribute-mkAttr name value = (name, H.AttValue [Left escaped]) where-	raw = H.CString True value ()-	escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw]--@-\section{Match rules}--Match rules are used to indicate that the client is interested in messages-matching a particular filter. This module provides an interface for building-match rule strings. Eventually, it will support parsing them also.--<<DBus/MatchRule.hs>>=-<<copyright>>-<<text extensions>>-module DBus.MatchRule (-	  MatchRule (..)-	, MessageType (..)-	, ParameterValue (..)-	, formatRule-	, addMatch-	, matchAll-	, matches-	) where-<<text imports>>-import Data.Word (Word8)-import Data.Maybe (fromMaybe, mapMaybe)-import qualified Data.Set as Set-import qualified DBus.Types as T-import qualified DBus.Message as M-import qualified DBus.Constants as C-import DBus.Util (maybeIndex)---<<DBus/MatchRule.hs>>=--- | A match rule is a set of filters; most filters may have one possible--- value assigned, such as a single message type. The exception are parameter--- filters, which are limited in number only by the server implementation.--- -data MatchRule = MatchRule-	{ matchType        :: Maybe MessageType-	, matchSender      :: Maybe T.BusName-	, matchInterface   :: Maybe T.InterfaceName-	, matchMember      :: Maybe T.MemberName-	, matchPath        :: Maybe T.ObjectPath-	, matchDestination :: Maybe T.BusName-	, matchParameters  :: [ParameterValue]-	}-	deriving (Show)--<<DBus/MatchRule.hs>>=--- | Parameters may match against two types, strings and object paths. It's--- probably an error to have two values for the same parameter.--- --- The constructor @StringValue 3 \"hello\"@ means that the fourth parameter--- in the message body must be the string @\"hello\"@. @PathValue@ is the--- same, but its value must be an object path.--- -data ParameterValue-	= StringValue Word8 Text-	| PathValue Word8 T.ObjectPath-	deriving (Show, Eq)--<<DBus/MatchRule.hs>>=--- | The set of allowed message types to filter on is separate from the set--- supported for sending over the wire. This allows the server to support--- additional types not yet implemented in the library, or vice-versa.--- -data MessageType-	= MethodCall-	| MethodReturn-	| Signal-	| Error-	deriving (Show, Eq)--@ There's currently only one operation to perform on match rules, and that's-to format them.--<<DBus/MatchRule.hs>>=-<<apidoc formatRule>>-formatRule :: MatchRule -> Text-formatRule rule = TL.intercalate "," filters where-	filters = structureFilters ++ parameterFilters-	parameterFilters = map formatParameter $ matchParameters rule-	structureFilters = mapMaybe unpack-		[ ("type", fmap formatType . matchType)-		, ("sender", fmap T.strBusName . matchSender)-		, ("interface", fmap T.strInterfaceName . matchInterface)-		, ("member", fmap T.strMemberName . matchMember)-		, ("path", fmap T.strObjectPath . matchPath)-		, ("destination", fmap T.strBusName . matchDestination)-		]-	unpack (key, mkValue) = formatFilter' key `fmap` mkValue rule--<<DBus/MatchRule.hs>>=-formatParameter :: ParameterValue -> Text-formatParameter (StringValue index x) = formatFilter' key x where-	key = "arg" `TL.append` TL.pack (show index)-formatParameter (PathValue index x) = formatFilter' key value where-	key = "arg" `TL.append` TL.pack (show index) `TL.append` "path"-	value = T.strObjectPath x--@ FIXME: what are the escaping rules for match rules? Other bindings don't-seem to perform any escaping at all.--<<DBus/MatchRule.hs>>=-formatFilter' :: Text -> Text -> Text-formatFilter' key value = TL.concat [key, "='", value, "'"]--<<DBus/MatchRule.hs>>=-formatType :: MessageType -> Text-formatType MethodCall   = "method_call"-formatType MethodReturn = "method_return"-formatType Signal       = "signal"-formatType Error        = "error"--@ And since the only real reason for formatting a match rule is to send it,-it's useful to have a message-building function pre-defined.--<<DBus/MatchRule.hs>>=-<<apidoc addMatch>>-addMatch :: MatchRule -> M.MethodCall-addMatch rule = M.MethodCall-	C.dbusPath-	"AddMatch"-	(Just C.dbusInterface)-	(Just C.dbusName)-	Set.empty-	[T.toVariant $ formatRule rule]--@ Most match rules will have only one or two fields filled in, so defining-an empty rule allows clients to set only the fields they care about.--<<DBus/MatchRule.hs>>=-<<apidoc matchAll>>-matchAll :: MatchRule-matchAll = MatchRule-	{ matchType        = Nothing-	, matchSender      = Nothing-	, matchInterface   = Nothing-	, matchMember      = Nothing-	, matchPath        = Nothing-	, matchDestination = Nothing-	, matchParameters  = []-	}--@ It's useful to match against a rule client-side, eg when listening for-signals.--<<DBus/MatchRule.hs>>=-<<apidoc matches>>-matches :: MatchRule -> M.ReceivedMessage -> Bool-matches rule msg = and . mapMaybe ($ rule) $-	[ fmap      (typeMatches msg) . matchType-	, fmap    (senderMatches msg) . matchSender-	, fmap     (ifaceMatches msg) . matchInterface-	, fmap    (memberMatches msg) . matchMember-	, fmap      (pathMatches msg) . matchPath-	, fmap      (destMatches msg) . matchDestination-	, Just . parametersMatch msg  . matchParameters-	]--<<DBus/MatchRule.hs>>=-typeMatches :: M.ReceivedMessage -> MessageType -> Bool-typeMatches (M.ReceivedMethodCall   _ _ _) MethodCall   = True-typeMatches (M.ReceivedMethodReturn _ _ _) MethodReturn = True-typeMatches (M.ReceivedSignal       _ _ _) Signal       = True-typeMatches (M.ReceivedError        _ _ _) Error        = True-typeMatches _ _ = False---<<DBus/MatchRule.hs>>=-senderMatches :: M.ReceivedMessage -> T.BusName -> Bool-senderMatches msg name = M.receivedSender msg == Just name--<<DBus/MatchRule.hs>>=-ifaceMatches :: M.ReceivedMessage -> T.InterfaceName -> Bool-ifaceMatches (M.ReceivedMethodCall _ _ msg) name =-	Just name == M.methodCallInterface msg-ifaceMatches (M.ReceivedSignal _ _ msg) name =-	name == M.signalInterface msg-ifaceMatches _ _ = False--<<DBus/MatchRule.hs>>=-memberMatches :: M.ReceivedMessage -> T.MemberName -> Bool-memberMatches (M.ReceivedMethodCall _ _ msg) name =-	name == M.methodCallMember msg-memberMatches (M.ReceivedSignal _ _ msg) name =-	name == M.signalMember msg-memberMatches _ _ = False--<<DBus/MatchRule.hs>>=-pathMatches :: M.ReceivedMessage -> T.ObjectPath -> Bool-pathMatches (M.ReceivedMethodCall _ _ msg) path =-	path == M.methodCallPath msg-pathMatches (M.ReceivedSignal _ _ msg) path =-	path == M.signalPath msg-pathMatches _ _ = False--<<DBus/MatchRule.hs>>=-destMatches :: M.ReceivedMessage -> T.BusName -> Bool-destMatches (M.ReceivedMethodCall _ _ msg) name =-	Just name == M.methodCallDestination msg-destMatches (M.ReceivedMethodReturn _ _ msg) name =-	Just name == M.methodReturnDestination msg-destMatches (M.ReceivedError _ _ msg) name =-	Just name == M.errorDestination msg-destMatches (M.ReceivedSignal _ _ msg) name =-	Just name == M.signalDestination msg-destMatches _ _ = False--<<DBus/MatchRule.hs>>=-parametersMatch :: M.ReceivedMessage -> [ParameterValue] -> Bool-parametersMatch _ [] = True-parametersMatch msg values = all validParam values where-	body = M.receivedBody msg-	validParam (StringValue idx x) = validParam' idx x-	validParam (PathValue   idx x) = validParam' idx x-	validParam' idx x = fromMaybe False $ do-		var <- maybeIndex body $ fromIntegral idx-		fmap (== x) $ T.fromVariant var--@-\section{Name reservation}--The central bus allows clients to register a well-known bus name, which-enables other clients to connect with or start a particular application.--<<DBus/NameReservation.hs>>=-<<copyright>>-{-# LANGUAGE OverloadedStrings #-}-module DBus.NameReservation-	( RequestNameFlag (..)-	, RequestNameReply (..)-	, ReleaseNameReply (..)-	, requestName-	, releaseName-	, mkRequestNameReply-	, mkReleaseNameReply-	) where-import Data.Word (Word32)-import Data.Bits ((.|.))-import qualified Data.Set as Set-import qualified DBus.Types as T-import qualified DBus.Message as M-import qualified DBus.Constants as C-import DBus.Util (maybeIndex)--<<DBus/NameReservation.hs>>=-data RequestNameFlag-	= AllowReplacement-	| ReplaceExisting-	| DoNotQueue-	deriving (Show)--<<DBus/NameReservation.hs>>=-encodeFlags :: [RequestNameFlag] -> Word32-encodeFlags = foldr (.|.) 0 . map flagValue where-	flagValue AllowReplacement = 0x1-	flagValue ReplaceExisting  = 0x2-	flagValue DoNotQueue       = 0x4--@ There are only two methods of interest here, {\tt RequestName} and-{\tt ReleaseName}.--<<DBus/NameReservation.hs>>=-<<apidoc requestName>>-requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall-requestName name flags = M.MethodCall-	{ M.methodCallPath = C.dbusPath-	, M.methodCallInterface = Just C.dbusInterface-	, M.methodCallDestination = Just C.dbusName-	, M.methodCallFlags = Set.empty-	, M.methodCallMember = "RequestName"-	, M.methodCallBody =-		[ T.toVariant name-		, T.toVariant . encodeFlags $ flags]-	}--<<DBus/NameReservation.hs>>=-data RequestNameReply-	= PrimaryOwner-	| InQueue-	| Exists-	| AlreadyOwner-	deriving (Show)--<<DBus/NameReservation.hs>>=-mkRequestNameReply :: M.MethodReturn -> Maybe RequestNameReply-mkRequestNameReply msg =-	maybeIndex (M.messageBody msg) 0 >>=-	T.fromVariant >>=-	decodeRequestReply--<<DBus/NameReservation.hs>>=-decodeRequestReply :: Word32 -> Maybe RequestNameReply-decodeRequestReply 1 = Just PrimaryOwner-decodeRequestReply 2 = Just InQueue-decodeRequestReply 3 = Just Exists-decodeRequestReply 4 = Just AlreadyOwner-decodeRequestReply _ = Nothing--<<DBus/NameReservation.hs>>=-<<apidoc releaseName>>-releaseName :: T.BusName -> M.MethodCall-releaseName name = M.MethodCall-	{ M.methodCallPath = C.dbusPath-	, M.methodCallInterface = Just C.dbusInterface-	, M.methodCallDestination = Just C.dbusName-	, M.methodCallFlags = Set.empty-	, M.methodCallMember = "ReleaseName"-	, M.methodCallBody = [T.toVariant name]-	}--<<DBus/NameReservation.hs>>=-data ReleaseNameReply-	= Released-	| NonExistent-	| NotOwner-	deriving (Show)--<<DBus/NameReservation.hs>>=-mkReleaseNameReply :: M.MethodReturn -> Maybe ReleaseNameReply-mkReleaseNameReply msg =-	maybeIndex (M.messageBody msg) 0 >>=-	T.fromVariant >>=-	decodeReleaseReply--<<DBus/NameReservation.hs>>=-decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply-decodeReleaseReply 1 = Just Released-decodeReleaseReply 2 = Just NonExistent-decodeReleaseReply 3 = Just NotOwner-decodeReleaseReply _ = Nothing--@-\section{Constants}--<<DBus/Constants.hs>>=-<<copyright>>-{-# LANGUAGE OverloadedStrings #-}-module DBus.Constants where-import qualified DBus.Types as T-import Data.Word (Word8, Word32)--<<DBus/Constants.hs>>=-protocolVersion :: Word8-protocolVersion = 1--messageMaximumLength :: Word32-messageMaximumLength = 134217728--arrayMaximumLength :: Word32-arrayMaximumLength = 67108864--@ \subsection{The message bus}--<<DBus/Constants.hs>>=-dbusName :: T.BusName-dbusName = "org.freedesktop.DBus"--dbusPath :: T.ObjectPath-dbusPath = "/org/freedesktop/DBus"--dbusInterface :: T.InterfaceName-dbusInterface = "org.freedesktop.DBus"--@ \subsection{Pre-defined interfaces}--<<DBus/Constants.hs>>=-interfaceIntrospectable :: T.InterfaceName-interfaceIntrospectable = "org.freedesktop.DBus.Introspectable"--interfaceProperties :: T.InterfaceName-interfaceProperties = "org.freedesktop.DBus.Properties"--interfacePeer :: T.InterfaceName-interfacePeer = "org.freedesktop.DBus.Peer"--@ \subsection{Pre-defined error names}--<<DBus/Constants.hs>>=-errorFailed :: T.ErrorName-errorFailed = "org.freedesktop.DBus.Error.Failed"--errorNoMemory :: T.ErrorName-errorNoMemory = "org.freedesktop.DBus.Error.NoMemory"--errorServiceUnknown :: T.ErrorName-errorServiceUnknown = "org.freedesktop.DBus.Error.ServiceUnknown"--errorNameHasNoOwner :: T.ErrorName-errorNameHasNoOwner = "org.freedesktop.DBus.Error.NameHasNoOwner"--errorNoReply :: T.ErrorName-errorNoReply = "org.freedesktop.DBus.Error.NoReply"--errorIOError :: T.ErrorName-errorIOError = "org.freedesktop.DBus.Error.IOError"--errorBadAddress :: T.ErrorName-errorBadAddress = "org.freedesktop.DBus.Error.BadAddress"--errorNotSupported :: T.ErrorName-errorNotSupported = "org.freedesktop.DBus.Error.NotSupported"--errorLimitsExceeded :: T.ErrorName-errorLimitsExceeded = "org.freedesktop.DBus.Error.LimitsExceeded"--errorAccessDenied :: T.ErrorName-errorAccessDenied = "org.freedesktop.DBus.Error.AccessDenied"--errorAuthFailed :: T.ErrorName-errorAuthFailed = "org.freedesktop.DBus.Error.AuthFailed"--errorNoServer :: T.ErrorName-errorNoServer = "org.freedesktop.DBus.Error.NoServer"--errorTimeout :: T.ErrorName-errorTimeout = "org.freedesktop.DBus.Error.Timeout"--errorNoNetwork :: T.ErrorName-errorNoNetwork = "org.freedesktop.DBus.Error.NoNetwork"--errorAddressInUse :: T.ErrorName-errorAddressInUse = "org.freedesktop.DBus.Error.AddressInUse"--errorDisconnected :: T.ErrorName-errorDisconnected = "org.freedesktop.DBus.Error.Disconnected"--errorInvalidArgs :: T.ErrorName-errorInvalidArgs = "org.freedesktop.DBus.Error.InvalidArgs"--errorFileNotFound :: T.ErrorName-errorFileNotFound = "org.freedesktop.DBus.Error.FileNotFound"--errorFileExists :: T.ErrorName-errorFileExists = "org.freedesktop.DBus.Error.FileExists"--errorUnknownMethod :: T.ErrorName-errorUnknownMethod = "org.freedesktop.DBus.Error.UnknownMethod"--errorTimedOut :: T.ErrorName-errorTimedOut = "org.freedesktop.DBus.Error.TimedOut"--errorMatchRuleNotFound :: T.ErrorName-errorMatchRuleNotFound = "org.freedesktop.DBus.Error.MatchRuleNotFound"--errorMatchRuleInvalid :: T.ErrorName-errorMatchRuleInvalid = "org.freedesktop.DBus.Error.MatchRuleInvalid"--errorSpawnExecFailed :: T.ErrorName-errorSpawnExecFailed = "org.freedesktop.DBus.Error.Spawn.ExecFailed"--errorSpawnForkFailed :: T.ErrorName-errorSpawnForkFailed = "org.freedesktop.DBus.Error.Spawn.ForkFailed"--errorSpawnChildExited :: T.ErrorName-errorSpawnChildExited = "org.freedesktop.DBus.Error.Spawn.ChildExited"--errorSpawnChildSignaled :: T.ErrorName-errorSpawnChildSignaled = "org.freedesktop.DBus.Error.Spawn.ChildSignaled"--errorSpawnFailed :: T.ErrorName-errorSpawnFailed = "org.freedesktop.DBus.Error.Spawn.Failed"--errorSpawnFailedToSetup :: T.ErrorName-errorSpawnFailedToSetup = "org.freedesktop.DBus.Error.Spawn.FailedToSetup"--errorSpawnConfigInvalid :: T.ErrorName-errorSpawnConfigInvalid = "org.freedesktop.DBus.Error.Spawn.ConfigInvalid"--errorSpawnServiceNotValid :: T.ErrorName-errorSpawnServiceNotValid = "org.freedesktop.DBus.Error.Spawn.ServiceNotValid"--errorSpawnServiceNotFound :: T.ErrorName-errorSpawnServiceNotFound = "org.freedesktop.DBus.Error.Spawn.ServiceNotFound"--errorSpawnPermissionsInvalid :: T.ErrorName-errorSpawnPermissionsInvalid = "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid"--errorSpawnFileInvalid :: T.ErrorName-errorSpawnFileInvalid = "org.freedesktop.DBus.Error.Spawn.FileInvalid"--errorSpawnNoMemory :: T.ErrorName-errorSpawnNoMemory = "org.freedesktop.DBus.Error.Spawn.NoMemory"--errorUnixProcessIdUnknown :: T.ErrorName-errorUnixProcessIdUnknown = "org.freedesktop.DBus.Error.UnixProcessIdUnknown"--errorInvalidFileContent :: T.ErrorName-errorInvalidFileContent = "org.freedesktop.DBus.Error.InvalidFileContent"--errorSELinuxSecurityContextUnknown :: T.ErrorName-errorSELinuxSecurityContextUnknown = "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown"--errorAdtAuditDataUnknown :: T.ErrorName-errorAdtAuditDataUnknown = "org.freedesktop.DBus.Error.AdtAuditDataUnknown"--errorObjectPathInUse :: T.ErrorName-errorObjectPathInUse = "org.freedesktop.DBus.Error.ObjectPathInUse"--errorInconsistentMessage :: T.ErrorName-errorInconsistentMessage = "org.freedesktop.DBus.Error.InconsistentMessage"--@-\section{UUIDs}--D-Bus {\sc uuid}s are 128-bit unique identifiers, used for server instances-and machine {\sc id}s. They are not compatible with {\sc rfc4122}.--<<DBus/UUID.hs>>=-<<copyright>>-module DBus.UUID-	( UUID-	, toHex-	, fromHex-	) where-<<text imports>>--newtype UUID = UUID Text -- TODO: (Word64, Word64)?-	deriving (Eq)--instance Show UUID where-	showsPrec d uuid = showParen (d > 10) $-		showString "UUID " . shows (toHex uuid)--toHex :: UUID -> Text-toHex (UUID text) = text--fromHex :: Text -> Maybe UUID-fromHex text = if validUUID text-	then Just $ UUID text-	else Nothing--validUUID :: Text -> Bool-validUUID text = valid where-	valid = and [TL.length text == 32, TL.all validChar text]-	validChar c = or-		[ c >= '0' && c <= '9'-		, c >= 'a' && c <= 'f'-		, c >= 'A' && c <= 'F'-		]--@-\section{Misc. utility functions}--<<DBus/Util.hs>>=-<<copyright>>-module DBus.Util where-import Text.Parsec (Parsec, parse)-import Data.Char (digitToInt)-import Data.List (isPrefixOf)--checkLength :: Int -> String -> Maybe String-checkLength length' s | length s <= length' = Just s-checkLength _ _ = Nothing--parseMaybe :: Parsec String () a -> String -> Maybe a-parseMaybe p = either (const Nothing) Just . parse p ""--mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b-mkUnsafe label f x = case f x of-	Just x' -> x'-	Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x--hexToInt :: String -> Int-hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt--eitherToMaybe :: Either a b -> Maybe b-eitherToMaybe (Left  _) = Nothing-eitherToMaybe (Right x) = Just x--fromRight :: Either a b -> b-fromRight (Right x) = x-fromRight _ = error "DBus.Util.fromRight: Left"--maybeIndex :: [a] -> Int -> Maybe a-maybeIndex (x:_ ) 0         = Just x-maybeIndex (_:xs) n | n > 0 = maybeIndex xs (n - 1)-maybeIndex _ _ = Nothing---- | Read values from a monad until a guard value is read; return all--- values, including the guard.----readUntil :: (Monad m, Eq a) => [a] -> m a -> m [a]-readUntil guard getx = readUntil' [] where-	guard' = reverse guard-	step xs | isPrefixOf guard' xs = return . reverse $ xs-	        | otherwise            = readUntil' xs-	readUntil' xs = do-		x <- getx-		step $ x:xs---- | Drop /n/ items from the end of a list-dropEnd :: Int -> [a] -> [a]-dropEnd n xs = take (length xs - n) xs--@-\section{Bundled MonadError variant}--The default {\tt ErrorT} and {\tt MonadError} classes in the-{\tt transformers} package have an idiotic dependency on the {\tt Error}-class, which is used to implement the obsolete {\tt fail} function. This-module is a variant, which doesn't include this dependency.--<<DBus/Util/MonadError.hs>>=-<<copyright>>-{-# LANGUAGE TypeFamilies #-}-module DBus.Util.MonadError where-import Control.Monad.Trans.Class-import Control.Monad.State--newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }--instance Functor m => Functor (ErrorT e m) where-	fmap f = ErrorT . fmap (fmap f) . runErrorT--instance Monad m => Monad (ErrorT e m) where-	return = ErrorT . return . Right-	(>>=) m k = ErrorT $ do-		x <- runErrorT m-		case x of-			Left l -> return $ Left l-			Right r -> runErrorT $ k r--instance MonadTrans (ErrorT e) where-	lift = ErrorT . liftM Right--class Monad m => MonadError m where-	type ErrorType m-	throwError :: ErrorType m -> m a-	catchError :: m a -> (ErrorType m -> m a) -> m a--instance Monad m => MonadError (ErrorT e m) where-	type ErrorType (ErrorT e m) = e-	throwError = ErrorT . return . Left-	catchError m h = ErrorT $ do-		x <- runErrorT m-		case x of-			Left l -> runErrorT $ h l-			Right r -> return $ Right r--instance MonadState m => MonadState (ErrorT e m) where-	type StateType (ErrorT e m) = StateType m-	get = lift get-	put = lift . put--@-\section{Haddock API documentation}--The \LaTeX{} documentation is great for somebody reading the source code-or trying to fix an error, but it's not useful for people who just want-to add D-Bus support to their applications. These documentation sections-will be included in Haddock output for public functions.--There's no real order to this section; it exists only because Haddock-can't merge documentation from external files.--<<apidoc isAtomicType>>=--- | \"Atomic\" types are any which can't contain any other types. Only--- atomic types may be used as dictionary keys.--<<apidoc typeCode>>=--- | Every type has an associated type code; a textual representation of--- the type, useful for debugging.--<<apidoc Variant>>=--- | 'Variant's may contain any other built-in D-Bus value. Besides--- representing native @VARIANT@ values, they allow type-safe storage and--- deconstruction of heterogeneous collections.--<<apidoc variantType>>=--- | Every variant is strongly-typed; that is, the type of its contained--- value is known at all times. This function retrieves that type, so that--- the correct cast can be used to retrieve the value.--<<apidoc arrayType>>=--- | This is the type contained within the array, not the type of the array--- itself.--<<apidoc Connection>>=--- | A 'Connection' is an opaque handle to an open D-Bus channel, with an--- internal state for maintaining the current message serial.--<<apidoc Transport>>=--- | A 'Transport' is anything which can send and receive bytestrings,--- typically via a socket.--<<apidoc connect>>=--- | Open a connection to some address, using a given authentication--- mechanism. If the connection fails, a 'ConnectionError' will be thrown.--<<apidoc connectFirst>>=--- | Try to open a connection to various addresses, returning the first--- connection which could be successfully opened.--<<apidoc connectionClose>>=--- | Close an open connection. Once closed, the 'Connection' is no longer--- valid and must not be used.--<<apidoc send>>=--- | Send a single message, with a generated 'M.Serial'. The second parameter--- exists to prevent race conditions when registering a reply handler; it--- receives the serial the message /will/ be sent with, before it's actually--- sent.------ Only one message may be sent at a time; if multiple threads attempt to--- send messages in parallel, one will block until after the other has--- finished.--<<apidoc receive>>=--- | Receive the next message from the connection, blocking until one is--- available.------ Only one message may be received at a time; if multiple threads attempt--- to receive messages in parallel, one will block until after the other has--- finished.--<<apidoc getBus>>=--- | Similar to 'C.connect', but additionally sends @Hello@ messages to the--- central bus.--<<apidoc getFirstBus>>=--- | Similar to 'C.connectFirst', but additionally sends @Hello@ messages to--- the central bus.--<<apidoc getSystemBus>>=--- | Connect to the bus specified in the environment variable--- @DBUS_SYSTEM_BUS_ADDRESS@, or to--- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@--- is not set.--<<apidoc getSessionBus>>=--- | Connect to the bus specified in the environment variable--- @DBUS_SESSION_BUS_ADDRESS@, which must be set.--<<apidoc getStarterBus>>=--- | Connect to the bus specified in the environment variable--- @DBUS_STARTER_ADDRESS@, which must be set.--<<apidoc formatRule>>=--- | Format a 'MatchRule' as the bus expects to receive in a call to--- @AddMatch@.--<<apidoc addMatch>>=--- | Build a 'M.MethodCall' for adding a match rule to the bus.--<<apidoc matchAll>>=--- | An empty match rule, which matches everything.--<<apidoc matches>>=--- | Whether a 'M.ReceivedMessage' matches a given rule. This is useful--- for implementing signal handlers.--<<apidoc requestName>>=--- | Build a 'M.MethodCall' for requesting a registered bus name.--<<apidoc releaseName>>=--- | Build a 'M.MethodCall' for releasing a registered bus name.--<<apidoc Serial>>=--- | A value used to uniquely identify a particular message within a session.--- 'Serial's are 32-bit unsigned integers, and eventually wrap.--<<apidoc ReceivedMessage>>=--- | Not an actual message type, but a wrapper around messages received from--- the bus. Each value contains the message's 'Serial' and possibly the--- origin's 'T.BusName'--<<apidoc marshalMessage>>=--- | Convert a 'M.Message' into a 'L.ByteString'. Although unusual, it is--- possible for marshaling to fail -- if this occurs, an appropriate error--- will be returned instead.--<<apidoc unmarshalMessage>>=--- | Read bytes from a monad until a complete message has been received.--@ \end{document}
hs/DBus/Address.hs view
@@ -1,32 +1,41 @@-{--  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/>.--} +#line 19 "src/addresses.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 20 "src/addresses.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} +#line 21 "src/addresses.anansi" module DBus.Address-        ( Address-        , addressMethod-        , addressParameters-        , mkAddresses-        , strAddress-        ) where+	( Address+	, addressMethod+	, addressParameters+	, mkAddresses+	, strAddress+	) where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 29 "src/addresses.anansi"  import Data.Char (ord, chr) import qualified Data.Map as M@@ -35,48 +44,51 @@ import Text.Parsec ((<|>)) import DBus.Util (hexToInt, eitherToMaybe) +#line 74 "src/addresses.anansi" optionallyEncoded :: [Char] optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." +#line 82 "src/addresses.anansi" data Address = Address-        { addressMethod     :: Text-        , addressParameters :: M.Map Text Text-        } deriving (Eq)+	{ addressMethod     :: Text+	, addressParameters :: M.Map Text Text+	} deriving (Eq)  instance Show Address where-        showsPrec d x = showParen (d> 10) $-                showString "Address " . shows (strAddress x)+	showsPrec d x = showParen (d> 10) $+		showString "Address " . shows (strAddress x) +#line 97 "src/addresses.anansi" 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+	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 +#line 128 "src/addresses.anansi" 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)-+	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)
hs/DBus/Authentication.hs view
@@ -1,100 +1,116 @@-{--  Copyright (C) 2009 John Millikin <jmillikin@gmail.com>-  -  This program is free software: you can redistribute it and/or modify-  it under the terms of the GNU General Public License as published by-  the Free Software Foundation, either version 3 of the License, or-  any later version.-  -  This program is distributed in the hope that it will be useful,-  but WITHOUT ANY WARRANTY; without even the implied warranty of-  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-  GNU General Public License for more details.-  -  You should have received a copy of the GNU General Public License-  along with this program.  If not, see <http://www.gnu.org/licenses/>.--} -{-# LANGUAGE OverloadedStrings #-}+#line 27 "src/authentication.anansi" -{-# LANGUAGE DeriveDataTypeable #-}-module DBus.Authentication-        (   Command-          , Mechanism (..)+#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>. -          , AuthenticationError (..)+#line 28 "src/authentication.anansi" -          , authenticate+#line 52 "src/introduction.anansi"+{-# LANGUAGE OverloadedStrings #-} -          , realUserID+#line 29 "src/authentication.anansi"+{-# LANGUAGE DeriveDataTypeable #-}+module DBus.Authentication+	( Command+	, Mechanism (..)+	, AuthenticationError (..)+	, authenticate+	, realUserID+	) where -        ) where+#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 38 "src/authentication.anansi"++#line 45 "src/authentication.anansi" import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as ByteString import qualified DBus.UUID as UUID +#line 60 "src/authentication.anansi" import Data.Typeable (Typeable) import qualified Control.Exception as E +#line 77 "src/authentication.anansi" import Data.Word (Word8) +#line 93 "src/authentication.anansi" import Control.Monad (liftM) import Data.Char (chr) import Data.Text.Lazy.Encoding (encodeUtf8) import DBus.Util (readUntil, dropEnd) +#line 114 "src/authentication.anansi" import System.Posix.User (getRealUserID) import Data.Char (ord) import Text.Printf (printf) +#line 135 "src/authentication.anansi" import Data.Maybe (isJust) -+#line 51 "src/authentication.anansi" type Command = Text newtype Mechanism = Mechanism-        { mechanismRun :: (Command -> IO Command) -> IO UUID.UUID-        }+	{ mechanismRun :: (Command -> IO Command) -> IO UUID.UUID+	} +#line 65 "src/authentication.anansi" data AuthenticationError-        = AuthenticationError Text-        deriving (Show, Typeable)+	= AuthenticationError Text+	deriving (Show, Typeable)  instance E.Exception AuthenticationError +#line 81 "src/authentication.anansi" authenticate :: Mechanism -> (ByteString -> IO ()) -> IO Word8              -> IO UUID.UUID authenticate mech put getByte = do-        put $ ByteString.singleton 0-        uuid <- mechanismRun mech (putCommand put getByte)-        put "BEGIN\r\n"-        return uuid+	put $ ByteString.singleton 0+	uuid <- mechanismRun mech (putCommand put getByte)+	put "BEGIN\r\n"+	return uuid +#line 100 "src/authentication.anansi" putCommand :: Monad m => (ByteString -> m ()) -> m Word8 -> Command -> m Command putCommand put get cmd = do-        let getC = liftM (chr . fromIntegral) get-        put $ encodeUtf8 cmd-        put "\r\n"-        liftM (TL.pack . dropEnd 2) $ readUntil "\r\n" getC+	let getC = liftM (chr . fromIntegral) get+	put $ encodeUtf8 cmd+	put "\r\n"+	liftM (TL.pack . dropEnd 2) $ readUntil "\r\n" getC +#line 120 "src/authentication.anansi" realUserID :: Mechanism realUserID = Mechanism $ \sendCmd -> do-        uid <- getRealUserID-        let token = concatMap (printf "%02X" . ord) (show uid)-        let cmd = "AUTH EXTERNAL " ++ token-        eitherUUID <- checkOK `fmap` sendCmd (TL.pack cmd)-        case eitherUUID of-                Right uuid -> return uuid-                Left err -> E.throwIO $ AuthenticationError err+	uid <- getRealUserID+	let token = concatMap (printf "%02X" . ord) (show uid)+	let cmd = "AUTH EXTERNAL " ++ token+	eitherUUID <- checkOK `fmap` sendCmd (TL.pack cmd)+	case eitherUUID of+		Right uuid -> return uuid+		Left err -> E.throwIO $ AuthenticationError err +#line 139 "src/authentication.anansi" checkOK :: Command -> Either Text UUID.UUID checkOK cmd = if validUUID then Right uuid else Left errorMsg where-        validUUID = TL.isPrefixOf "OK " cmd && isJust maybeUUID-        maybeUUID = UUID.fromHex $ TL.drop 3 cmd-        Just uuid = maybeUUID-        errorMsg = if TL.isPrefixOf "ERROR " cmd-                then TL.drop 6 cmd-                else TL.pack $ "Unexpected response: " ++ show cmd-+	validUUID = TL.isPrefixOf "OK " cmd && isJust maybeUUID+	maybeUUID = UUID.fromHex $ TL.drop 3 cmd+	Just uuid = maybeUUID+	errorMsg = if TL.isPrefixOf "ERROR " cmd+		then TL.drop 6 cmd+		else TL.pack $ "Unexpected response: " ++ show cmd
hs/DBus/Bus.hs view
@@ -1,32 +1,41 @@-{--  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/>.--} +#line 19 "src/bus.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 20 "src/bus.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} +#line 21 "src/bus.anansi" module DBus.Bus-        ( getBus-        , getFirstBus-        , getSystemBus-        , getSessionBus-        , getStarterBus-        ) where+	( getBus+	, getFirstBus+	, getSystemBus+	, getSessionBus+	, getStarterBus+	) where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 29 "src/bus.anansi"  import qualified Control.Exception as E import Control.Monad (when)@@ -42,83 +51,104 @@ import qualified DBus.Types as T import DBus.Util (fromRight) +#line 50 "src/bus.anansi" busForConnection :: C.Connection -> IO (C.Connection, T.BusName) busForConnection c = fmap ((,) c) $ sendHello c ++#line 99 "src/api-docs.anansi" -- | Similar to 'C.connect', but additionally sends @Hello@ messages to the -- central bus. +#line 54 "src/bus.anansi" getBus :: Auth.Mechanism -> A.Address -> IO (C.Connection, T.BusName) getBus = ((busForConnection =<<) .) . C.connect +#line 62 "src/bus.anansi"++#line 104 "src/api-docs.anansi" -- | Similar to 'C.connectFirst', but additionally sends @Hello@ messages to -- the central bus. +#line 63 "src/bus.anansi" getFirstBus :: [(Auth.Mechanism, A.Address)] -> IO (C.Connection, T.BusName) getFirstBus = (busForConnection =<<) . C.connectFirst +#line 74 "src/bus.anansi"++#line 109 "src/api-docs.anansi" -- | Connect to the bus specified in the environment variable -- @DBUS_SYSTEM_BUS_ADDRESS@, or to -- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@ -- is not set. +#line 75 "src/bus.anansi" 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+	defaultAddr = "unix:path=/var/run/dbus/system_bus_socket"+	fromEnv = getEnv "DBUS_SYSTEM_BUS_ADDRESS"+	noEnv (E.SomeException _) = return defaultAddr ++#line 116 "src/api-docs.anansi" -- | Connect to the bus specified in the environment variable -- @DBUS_SESSION_BUS_ADDRESS@, which must be set. +#line 82 "src/bus.anansi" getSessionBus :: IO (C.Connection, T.BusName) getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS" ++#line 121 "src/api-docs.anansi" -- | Connect to the bus specified in the environment variable -- @DBUS_STARTER_ADDRESS@, which must be set. +#line 86 "src/bus.anansi" getStarterBus :: IO (C.Connection, T.BusName) getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS" +#line 91 "src/bus.anansi" getBus' :: IO String -> IO (C.Connection, T.BusName) getBus' io = do-        addr <- fmap TL.pack io-        case A.mkAddresses addr of-                Just [x] -> getBus Auth.realUserID x-                Just  xs -> getFirstBus [(Auth.realUserID,x) | x <- xs]-                _        -> E.throwIO $ C.InvalidAddress addr+	addr <- fmap TL.pack io+	case A.mkAddresses addr of+		Just [x] -> getBus Auth.realUserID x+		Just  xs -> getFirstBus [(Auth.realUserID,x) | x <- xs]+		_        -> E.throwIO $ C.InvalidAddress addr +#line 103 "src/bus.anansi" hello :: M.MethodCall hello = M.MethodCall dbusPath-        "Hello"-        (Just dbusInterface)-        (Just dbusName)-        Set.empty-        []+	"Hello"+	(Just dbusInterface)+	(Just dbusName)+	Set.empty+	[] +#line 113 "src/bus.anansi" 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+	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 +#line 128 "src/bus.anansi" 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-+	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
hs/DBus/Connection.hs view
@@ -1,219 +1,278 @@-{--  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/>.--} +#line 19 "src/connections.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 20 "src/connections.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} +#line 21 "src/connections.anansi" {-# LANGUAGE DeriveDataTypeable #-}-module DBus.Connection-        (   Connection-          , connectionAddress-          , connectionUUID+module DBus.Connection ( -          , ConnectionError (..)+#line 53 "src/connections.anansi"+	  Connection+	, connectionAddress+	, connectionUUID -          , connect-          , connectFirst+#line 285 "src/connections.anansi"+	, ConnectionError (..) -          , connectionClose+#line 324 "src/connections.anansi"+	, connect+	, connectFirst -          , send+#line 337 "src/connections.anansi"+	, connectionClose -          , receive+#line 367 "src/connections.anansi"+	, send -        ) where+#line 391 "src/connections.anansi"+	, receive++#line 24 "src/connections.anansi"+	) where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 26 "src/connections.anansi"++#line 36 "src/connections.anansi" import qualified Control.Concurrent as C import qualified DBus.Address as A import qualified DBus.Message as M import qualified DBus.UUID as UUID +#line 75 "src/connections.anansi" import qualified Data.ByteString.Lazy as L import Data.Word (Word32) +#line 107 "src/connections.anansi" import qualified Network as N import qualified Data.Map as Map +#line 147 "src/connections.anansi" import qualified Network.Socket as NS +#line 193 "src/connections.anansi" import qualified Text.Parsec as P import Control.Monad (unless) import Data.Binary.Get (runGet, getWord16host) import Data.Binary.Put (runPut, putWord16be) +#line 252 "src/connections.anansi" import qualified System.IO as I +#line 269 "src/connections.anansi" import qualified Control.Exception as E import Data.Typeable (Typeable) +#line 294 "src/connections.anansi" import qualified DBus.Authentication as Auth +#line 350 "src/connections.anansi" import qualified DBus.Wire as W -+#line 43 "src/connections.anansi" data Connection = Connection-        { connectionAddress    :: A.Address-        , connectionTransport  :: Transport-        , connectionSerialMVar :: C.MVar M.Serial-        , connectionReadMVar   :: C.MVar ()-        , connectionUUID       :: UUID.UUID-        }+	{ connectionAddress    :: A.Address+	, connectionTransport  :: Transport+	, connectionSerialMVar :: C.MVar M.Serial+	, connectionReadMVar   :: C.MVar ()+	, connectionUUID       :: UUID.UUID+	} +#line 62 "src/connections.anansi" instance Show Connection where-        showsPrec d con = showParen (d > 10) strCon where-                addr = A.strAddress $ connectionAddress con-                strCon = s "<Connection " . shows addr . s ">"-                s = showString+	showsPrec d con = showParen (d > 10) strCon where+		addr = A.strAddress $ connectionAddress con+		strCon = s "<Connection " . shows addr . s ">"+		s = showString +#line 80 "src/connections.anansi"++#line 59 "src/api-docs.anansi" -- | A 'Transport' is anything which can send and receive bytestrings, -- typically via a socket. +#line 81 "src/connections.anansi" data Transport = Transport-        { transportSend :: L.ByteString -> IO ()-        , transportRecv :: Word32 -> IO L.ByteString-        , transportClose :: IO ()-        }+	{ transportSend :: L.ByteString -> IO ()+	, transportRecv :: Word32 -> IO L.ByteString+	, transportClose :: IO ()+	} +#line 92 "src/connections.anansi" connectTransport :: A.Address -> IO Transport connectTransport a = transport' (A.addressMethod a) a where-        transport' "unix" = unix-        transport' "tcp"  = tcp-        transport' _      = E.throwIO . UnknownMethod+	transport' "unix" = unix+	transport' "tcp"  = tcp+	transport' _      = E.throwIO . UnknownMethod +#line 112 "src/connections.anansi" 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+	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 +#line 151 "src/connections.anansi" 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+	params = A.addressParameters a+	openHandle = do+		port <- getPort+		family <- getFamily+		addresses <- getAddresses family+		socket <- openSocket port addresses+		NS.socketToHandle socket I.ReadWriteMode -        hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params+#line 165 "src/connections.anansi"+	hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params -        unknownFamily x = TL.concat ["Unknown socket family for TCP transport: ", x]-        getFamily = case Map.lookup "family" params of-                Just "ipv4" -> return NS.AF_INET-                Just "ipv6" -> return NS.AF_INET6-                Nothing     -> return NS.AF_UNSPEC-                Just x      -> E.throwIO $ BadParameters a $ unknownFamily x+#line 169 "src/connections.anansi"+	unknownFamily x = TL.concat ["Unknown socket family for TCP transport: ", x]+	getFamily = case Map.lookup "family" params of+		Just "ipv4" -> return NS.AF_INET+		Just "ipv6" -> return NS.AF_INET6+		Nothing     -> return NS.AF_UNSPEC+		Just x      -> E.throwIO $ BadParameters a $ unknownFamily x -        missingPort = "TCP transport requires the ``port'' parameter."-        badPort x = TL.concat ["Invalid socket port for TCP transport: ", x]-        getPort = case Map.lookup "port" params of-                Nothing -> E.throwIO $ BadParameters a missingPort-                Just x -> case P.parse parseWord16 "" (TL.unpack x) of-                        Right x' -> return $ NS.PortNum x'-                        Left  _  -> E.throwIO $ BadParameters a $ badPort x+#line 178 "src/connections.anansi"+	missingPort = "TCP transport requires the ``port'' parameter."+	badPort x = TL.concat ["Invalid socket port for TCP transport: ", x]+	getPort = case Map.lookup "port" params of+		Nothing -> E.throwIO $ BadParameters a missingPort+		Just x -> case P.parse parseWord16 "" (TL.unpack x) of+			Right x' -> return $ NS.PortNum x'+			Left  _  -> E.throwIO $ BadParameters a $ badPort x -        parseWord16 = do-                chars <- P.many1 P.digit-                P.eof-                let value = read chars :: Integer-                unless (value > 0 && value <= 65535) $-                        P.parserFail "bad port" >> return ()-                let word = fromIntegral value-                return $ runGet getWord16host (runPut (putWord16be word))+#line 200 "src/connections.anansi"+	parseWord16 = do+		chars <- P.many1 P.digit+		P.eof+		let value = read chars :: Integer+		unless (value > 0 && value <= 65535) $+			P.parserFail "bad port" >> return ()+		let word = fromIntegral value+		return $ runGet getWord16host (runPut (putWord16be word)) -        getAddresses family = do-                let hints = NS.defaultHints-                        { NS.addrFlags = [NS.AI_ADDRCONFIG]-                        , NS.addrFamily = family-                        , NS.addrSocketType = NS.Stream-                        }-                NS.getAddrInfo (Just hints) (Just hostname) Nothing+#line 211 "src/connections.anansi"+	getAddresses family = do+		let hints = NS.defaultHints+			{ NS.addrFlags = [NS.AI_ADDRCONFIG]+			, NS.addrFamily = family+			, NS.addrSocketType = NS.Stream+			}+		NS.getAddrInfo (Just hints) (Just hostname) Nothing -        setPort port (NS.SockAddrInet  _ x)     = NS.SockAddrInet port x-        setPort port (NS.SockAddrInet6 _ x y z) = NS.SockAddrInet6 port x y z-        setPort _    addr                       = addr+#line 225 "src/connections.anansi"+	setPort port (NS.SockAddrInet  _ x)     = NS.SockAddrInet port x+	setPort port (NS.SockAddrInet6 _ x y z) = NS.SockAddrInet6 port x y z+	setPort _    addr                       = addr -        openSocket _ [] = E.throwIO $ NoWorkingAddress [a]-        openSocket port (addr:addrs) = E.catch (openSocket' port addr) $-                \(E.SomeException _) -> openSocket port addrs-        openSocket' port addr = do-                sock <- NS.socket (NS.addrFamily addr)-                                  (NS.addrSocketType addr)-                                  (NS.addrProtocol addr)-                NS.connect sock . setPort port . NS.addrAddress $ addr-                return sock+#line 235 "src/connections.anansi"+	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 +#line 256 "src/connections.anansi" 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) (I.hClose h)+	I.hSetBuffering h I.NoBuffering+	I.hSetBinaryMode h True+	return $ Transport (L.hPut h) (L.hGet h . fromIntegral) (I.hClose h) +#line 274 "src/connections.anansi" data ConnectionError-        = InvalidAddress Text-        | BadParameters A.Address Text-        | UnknownMethod A.Address-        | NoWorkingAddress [A.Address]-        deriving (Show, Typeable)+	= InvalidAddress Text+	| BadParameters A.Address Text+	| UnknownMethod A.Address+	| NoWorkingAddress [A.Address]+	deriving (Show, Typeable)  instance E.Exception ConnectionError +#line 298 "src/connections.anansi"++#line 64 "src/api-docs.anansi" -- | Open a connection to some address, using a given authentication -- mechanism. If the connection fails, a 'ConnectionError' will be thrown. +#line 299 "src/connections.anansi" connect :: Auth.Mechanism -> A.Address -> IO Connection connect mechanism a = do-        t <- connectTransport a-        let getByte = L.head `fmap` transportRecv t 1-        uuid <- Auth.authenticate mechanism (transportSend t) getByte-        readLock <- C.newMVar ()-        serialMVar <- C.newMVar M.firstSerial-        return $ Connection a t serialMVar readLock uuid+	t <- connectTransport a+	let getByte = L.head `fmap` transportRecv t 1+	uuid <- Auth.authenticate mechanism (transportSend t) getByte+	readLock <- C.newMVar ()+	serialMVar <- C.newMVar M.firstSerial+	return $ Connection a t serialMVar readLock uuid +#line 314 "src/connections.anansi"++#line 69 "src/api-docs.anansi" -- | Try to open a connection to various addresses, returning the first -- connection which could be successfully opened. +#line 315 "src/connections.anansi" connectFirst :: [(Auth.Mechanism, A.Address)] -> IO Connection connectFirst orig = connectFirst' orig where-        allAddrs = [a | (_, a) <- orig]-        connectFirst'     [] = E.throwIO $ NoWorkingAddress allAddrs-        connectFirst' ((mech, a):as) = E.catch (connect mech a) $-                \(E.SomeException _) -> connectFirst' as+	allAddrs = [a | (_, a) <- orig]+	connectFirst'     [] = E.throwIO $ NoWorkingAddress allAddrs+	connectFirst' ((mech, a):as) = E.catch (connect mech a) $+		\(E.SomeException _) -> connectFirst' as +#line 331 "src/connections.anansi"++#line 74 "src/api-docs.anansi" -- | Close an open connection. Once closed, the 'Connection' is no longer -- valid and must not be used. +#line 332 "src/connections.anansi" connectionClose :: Connection -> IO () connectionClose = transportClose . connectionTransport +#line 354 "src/connections.anansi"++#line 79 "src/api-docs.anansi" -- | Send a single message, with a generated 'M.Serial'. The second parameter -- exists to prevent race conditions when registering a reply handler; it -- receives the serial the message /will/ be sent with, before it's actually@@ -223,24 +282,29 @@ -- send messages in parallel, one will block until after the other has -- finished. +#line 355 "src/connections.anansi" 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+	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 +#line 371 "src/connections.anansi" 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+	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 +#line 384 "src/connections.anansi"++#line 90 "src/api-docs.anansi" -- | Receive the next message from the connection, blocking until one is -- available. --@@ -248,7 +312,7 @@ -- to receive messages in parallel, one will block until after the other has -- finished. +#line 385 "src/connections.anansi" receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage) receive (Connection _ t _ lock _) = C.withMVar lock $ \_ ->-        W.unmarshalMessage $ transportRecv t-+	W.unmarshalMessage $ transportRecv t
hs/DBus/Constants.hs view
@@ -1,20 +1,23 @@-{--  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/>.--} +#line 19 "src/constants.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 20 "src/constants.anansi" {-# LANGUAGE OverloadedStrings #-} module DBus.Constants where import qualified DBus.Types as T@@ -29,6 +32,7 @@ arrayMaximumLength :: Word32 arrayMaximumLength = 67108864 +#line 38 "src/constants.anansi" dbusName :: T.BusName dbusName = "org.freedesktop.DBus" @@ -38,6 +42,7 @@ dbusInterface :: T.InterfaceName dbusInterface = "org.freedesktop.DBus" +#line 51 "src/constants.anansi" interfaceIntrospectable :: T.InterfaceName interfaceIntrospectable = "org.freedesktop.DBus.Introspectable" @@ -47,6 +52,7 @@ interfacePeer :: T.InterfaceName interfacePeer = "org.freedesktop.DBus.Peer" +#line 64 "src/constants.anansi" errorFailed :: T.ErrorName errorFailed = "org.freedesktop.DBus.Error.Failed" @@ -169,4 +175,3 @@  errorInconsistentMessage :: T.ErrorName errorInconsistentMessage = "org.freedesktop.DBus.Error.InconsistentMessage"-
hs/DBus/Introspection.hs view
@@ -1,162 +1,191 @@-{--  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/>.--} +#line 44 "src/introspection.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 45 "src/introspection.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} +#line 46 "src/introspection.anansi" module DBus.Introspection-        ( Object (..)-        , Interface (..)-        , Method (..)-        , Signal (..)-        , Parameter (..)-        , Property (..)-        , PropertyAccess (..)-        , toXML-        , fromXML-        ) where+	( Object (..)+	, Interface (..)+	, Method (..)+	, Signal (..)+	, Parameter (..)+	, Property (..)+	, PropertyAccess (..)+	, toXML+	, fromXML+	) where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 58 "src/introspection.anansi"++#line 66 "src/introspection.anansi" import qualified Text.XML.HaXml as H +#line 105 "src/introspection.anansi" import Text.XML.HaXml.Parse (xmlParse') import DBus.Util (eitherToMaybe) +#line 230 "src/introspection.anansi" import Data.Char (chr) +#line 254 "src/introspection.anansi" import Data.Maybe (fromMaybe) +#line 286 "src/introspection.anansi" import Text.XML.HaXml.Pretty (document) import Text.PrettyPrint.HughesPJ (render) +#line 59 "src/introspection.anansi" import qualified DBus.Types as T +#line 72 "src/introspection.anansi" data Object = Object T.ObjectPath [Interface] [Object]-        deriving (Show, Eq)+	deriving (Show, Eq)  data Interface = Interface T.InterfaceName [Method] [Signal] [Property]-        deriving (Show, Eq)+	deriving (Show, Eq)  data Method = Method T.MemberName [Parameter] [Parameter]-        deriving (Show, Eq)+	deriving (Show, Eq)  data Signal = Signal T.MemberName [Parameter]-        deriving (Show, Eq)+	deriving (Show, Eq)  data Parameter = Parameter Text T.Signature-        deriving (Show, Eq)+	deriving (Show, Eq)  data Property = Property Text T.Signature [PropertyAccess]-        deriving (Show, Eq)+	deriving (Show, Eq)  data PropertyAccess = Read | Write-        deriving (Show, Eq)+	deriving (Show, Eq) +#line 110 "src/introspection.anansi" fromXML :: T.ObjectPath -> Text -> Maybe Object fromXML path text = do-        doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text-        let (H.Document _ _ root _) = doc-        parseRoot path root+	doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text+	let (H.Document _ _ root _) = doc+	parseRoot path root +#line 121 "src/introspection.anansi" 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+	path <- case getAttr "name" e of+		Nothing -> Just defaultPath+		Just x  -> T.mkObjectPath x+	parseObject' path e +#line 134 "src/introspection.anansi" 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+	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 +#line 148 "src/introspection.anansi" 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'+	interfaces <- children parseInterface (H.tag "interface") e+	children' <- children (parseChild path) (H.tag "node") e+	return $ Object path interfaces children' parseObject' _ _ = Nothing +#line 159 "src/introspection.anansi" 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+	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 +#line 172 "src/introspection.anansi" 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+	name <- T.mkMemberName =<< getAttr "name" e+	paramsIn <- children parseParameter (isParam ["in", ""]) e+	paramsOut <- children parseParameter (isParam ["out"]) e+	return $ Method name paramsIn paramsOut +#line 183 "src/introspection.anansi" 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+	name <- T.mkMemberName =<< getAttr "name" e+	params <- children parseParameter (isParam ["out", ""]) e+	return $ Signal name params +#line 193 "src/introspection.anansi" parseParameter :: H.Element a -> Maybe Parameter parseParameter e = do-        let name = getAttr' "name" e-        sig <- parseType e-        return $ Parameter name sig+	let name = getAttr' "name" e+	sig <- parseType e+	return $ Parameter name sig +#line 201 "src/introspection.anansi" parseType :: H.Element a -> Maybe T.Signature parseType e = do-        sig <- T.mkSignature =<< getAttr "type" e-        case T.signatureTypes sig of-                [_] -> Just sig-                _   -> Nothing+	sig <- T.mkSignature =<< getAttr "type" e+	case T.signatureTypes sig of+		[_] -> Just sig+		_   -> Nothing +#line 213 "src/introspection.anansi" 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+	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 +#line 234 "src/introspection.anansi" 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", "\"")-                ]+	(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", "\"")+		] +#line 258 "src/introspection.anansi" getAttr :: String -> H.Element a -> Maybe Text getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue @@ -165,101 +194,112 @@  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]+	arg@(H.CElem e _) <- H.tag "arg" content+	let direction = getAttr' "direction" e+	[arg | direction `elem` dirs]  children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b] children f filt (H.Elem _ _ contents) =-        mapM f [x | (H.CElem x _) <- concatMap filt contents]+	mapM f [x | (H.CElem x _) <- concatMap filt contents] +#line 278 "src/introspection.anansi" dtdPublicID, dtdSystemID :: String dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN" dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd" +#line 294 "src/introspection.anansi" 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 []+	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 [] +#line 309 "src/introspection.anansi" xmlRoot :: Object -> Maybe (H.Element a) xmlRoot obj@(Object path _ _) = do-        (H.CElem root _) <- xmlObject' (T.strObjectPath path) obj-        return root+	(H.CElem root _) <- xmlObject' (T.strObjectPath path) obj+	return root +#line 316 "src/introspection.anansi" 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+	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 +#line 329 "src/introspection.anansi" 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''-                        ]+	children'' <- mapM (xmlObject fullPath) children'+	return $ mkElement "node"+		[mkAttr "name" $ TL.unpack path]+		$ concat+			[ map xmlInterface interfaces+			, children''+			] +#line 341 "src/introspection.anansi" 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-                        ]+	mkElement "interface"+		[mkAttr "name" . TL.unpack . T.strInterfaceName $ name]+		$ concat+			[ map xmlMethod methods+			, map xmlSignal signals+			, map xmlProperty properties+			] +#line 353 "src/introspection.anansi" 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-                ]+	[mkAttr "name" . TL.unpack . T.strMemberName $ name]+	$ concat+		[ map (xmlParameter "in") inParams+		, map (xmlParameter "out") outParams+		] +#line 363 "src/introspection.anansi" xmlSignal :: Signal -> H.Content a xmlSignal (Signal name params) = mkElement "signal"-        [mkAttr "name" . TL.unpack . T.strMemberName $ name]-        $ map (xmlParameter "out") params+	[mkAttr "name" . TL.unpack . T.strMemberName $ name]+	$ map (xmlParameter "out") params +#line 370 "src/introspection.anansi" 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-        ] []+	[ mkAttr "name" . TL.unpack $ name+	, mkAttr "type" . TL.unpack . T.strSignature $ sig+	, mkAttr "direction" direction+	] [] +#line 379 "src/introspection.anansi" 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-        ] []+	[ mkAttr "name" . TL.unpack $ name+	, mkAttr "type" . TL.unpack . T.strSignature $ sig+	, mkAttr "access" $ xmlAccess access+	] [] +#line 388 "src/introspection.anansi" xmlAccess :: [PropertyAccess] -> String xmlAccess access = readS ++ writeS where-        readS = if elem Read access then "read" else ""-        writeS = if elem Write access then "write" else ""+	readS = if elem Read access then "read" else ""+	writeS = if elem Write access then "write" else "" +#line 395 "src/introspection.anansi" mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined  mkAttr :: String -> String -> H.Attribute mkAttr name value = (name, H.AttValue [Left escaped]) where-        raw = H.CString True value ()-        escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw]-+	raw = H.CString True value ()+	escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw]
hs/DBus/MatchRule.hs view
@@ -1,34 +1,43 @@-{--  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/>.--} +#line 23 "src/match-rules.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 24 "src/match-rules.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} +#line 25 "src/match-rules.anansi" module DBus.MatchRule (-          MatchRule (..)-        , MessageType (..)-        , ParameterValue (..)-        , formatRule-        , addMatch-        , matchAll-        , matches-        ) where+	  MatchRule (..)+	, MessageType (..)+	, ParameterValue (..)+	, formatRule+	, addMatch+	, matchAll+	, matches+	) where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 35 "src/match-rules.anansi" import Data.Word (Word8) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set@@ -37,22 +46,23 @@ import qualified DBus.Constants as C import DBus.Util (maybeIndex) -+#line 45 "src/match-rules.anansi" -- | A match rule is a set of filters; most filters may have one possible -- value assigned, such as a single message type. The exception are parameter -- filters, which are limited in number only by the server implementation. --  data MatchRule = MatchRule-        { matchType        :: Maybe MessageType-        , matchSender      :: Maybe T.BusName-        , matchInterface   :: Maybe T.InterfaceName-        , matchMember      :: Maybe T.MemberName-        , matchPath        :: Maybe T.ObjectPath-        , matchDestination :: Maybe T.BusName-        , matchParameters  :: [ParameterValue]-        }-        deriving (Show)+	{ matchType        :: Maybe MessageType+	, matchSender      :: Maybe T.BusName+	, matchInterface   :: Maybe T.InterfaceName+	, matchMember      :: Maybe T.MemberName+	, matchPath        :: Maybe T.ObjectPath+	, matchDestination :: Maybe T.BusName+	, matchParameters  :: [ParameterValue]+	}+	deriving (Show) +#line 62 "src/match-rules.anansi" -- | Parameters may match against two types, strings and object paths. It's -- probably an error to have two values for the same parameter. -- @@ -61,45 +71,52 @@ -- same, but its value must be an object path. --  data ParameterValue-        = StringValue Word8 Text-        | PathValue Word8 T.ObjectPath-        deriving (Show, Eq)+	= StringValue Word8 Text+	| PathValue Word8 T.ObjectPath+	deriving (Show, Eq) +#line 76 "src/match-rules.anansi" -- | The set of allowed message types to filter on is separate from the set -- supported for sending over the wire. This allows the server to support -- additional types not yet implemented in the library, or vice-versa. --  data MessageType-        = MethodCall-        | MethodReturn-        | Signal-        | Error-        deriving (Show, Eq)+	= MethodCall+	| MethodReturn+	| Signal+	| Error+	deriving (Show, Eq) +#line 92 "src/match-rules.anansi"++#line 126 "src/api-docs.anansi" -- | Format a 'MatchRule' as the bus expects to receive in a call to -- @AddMatch@. +#line 93 "src/match-rules.anansi" formatRule :: MatchRule -> Text formatRule rule = TL.intercalate "," filters where-        filters = structureFilters ++ parameterFilters-        parameterFilters = map formatParameter $ matchParameters rule-        structureFilters = mapMaybe 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+	filters = structureFilters ++ parameterFilters+	parameterFilters = map formatParameter $ matchParameters rule+	structureFilters = mapMaybe 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 +#line 109 "src/match-rules.anansi" formatParameter :: ParameterValue -> Text formatParameter (StringValue index x) = formatFilter' key x where-        key = "arg" `TL.append` TL.pack (show index)+	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+	key = "arg" `TL.append` TL.pack (show index) `TL.append` "path"+	value = T.strObjectPath x +#line 121 "src/match-rules.anansi" formatFilter' :: Text -> Text -> Text formatFilter' key value = TL.concat [key, "='", value, "'"] @@ -109,44 +126,57 @@ formatType Signal       = "signal" formatType Error        = "error" +#line 135 "src/match-rules.anansi"++#line 131 "src/api-docs.anansi" -- | Build a 'M.MethodCall' for adding a match rule to the bus. +#line 136 "src/match-rules.anansi" addMatch :: MatchRule -> M.MethodCall addMatch rule = M.MethodCall-        C.dbusPath-        "AddMatch"-        (Just C.dbusInterface)-        (Just C.dbusName)-        Set.empty-        [T.toVariant $ formatRule rule]+	C.dbusPath+	"AddMatch"+	(Just C.dbusInterface)+	(Just C.dbusName)+	Set.empty+	[T.toVariant $ formatRule rule] +#line 150 "src/match-rules.anansi"++#line 135 "src/api-docs.anansi" -- | An empty match rule, which matches everything. +#line 151 "src/match-rules.anansi" matchAll :: MatchRule matchAll = MatchRule-        { matchType        = Nothing-        , matchSender      = Nothing-        , matchInterface   = Nothing-        , matchMember      = Nothing-        , matchPath        = Nothing-        , matchDestination = Nothing-        , matchParameters  = []-        }+	{ matchType        = Nothing+	, matchSender      = Nothing+	, matchInterface   = Nothing+	, matchMember      = Nothing+	, matchPath        = Nothing+	, matchDestination = Nothing+	, matchParameters  = []+	} +#line 167 "src/match-rules.anansi"++#line 139 "src/api-docs.anansi" -- | Whether a 'M.ReceivedMessage' matches a given rule. This is useful -- for implementing signal handlers. +#line 168 "src/match-rules.anansi" matches :: MatchRule -> M.ReceivedMessage -> Bool matches rule msg = and . mapMaybe ($ 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-        ]+	[ 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+	] +#line 181 "src/match-rules.anansi" typeMatches :: M.ReceivedMessage -> MessageType -> Bool typeMatches (M.ReceivedMethodCall   _ _ _) MethodCall   = True typeMatches (M.ReceivedMethodReturn _ _ _) MethodReturn = True@@ -154,49 +184,53 @@ typeMatches (M.ReceivedError        _ _ _) Error        = True typeMatches _ _ = False -+#line 190 "src/match-rules.anansi" senderMatches :: M.ReceivedMessage -> T.BusName -> Bool senderMatches msg name = M.receivedSender msg == Just name +#line 195 "src/match-rules.anansi" ifaceMatches :: M.ReceivedMessage -> T.InterfaceName -> Bool ifaceMatches (M.ReceivedMethodCall _ _ msg) name =-        Just name == M.methodCallInterface msg+	Just name == M.methodCallInterface msg ifaceMatches (M.ReceivedSignal _ _ msg) name =-        name == M.signalInterface msg+	name == M.signalInterface msg ifaceMatches _ _ = False +#line 204 "src/match-rules.anansi" memberMatches :: M.ReceivedMessage -> T.MemberName -> Bool memberMatches (M.ReceivedMethodCall _ _ msg) name =-        name == M.methodCallMember msg+	name == M.methodCallMember msg memberMatches (M.ReceivedSignal _ _ msg) name =-        name == M.signalMember msg+	name == M.signalMember msg memberMatches _ _ = False +#line 213 "src/match-rules.anansi" pathMatches :: M.ReceivedMessage -> T.ObjectPath -> Bool pathMatches (M.ReceivedMethodCall _ _ msg) path =-        path == M.methodCallPath msg+	path == M.methodCallPath msg pathMatches (M.ReceivedSignal _ _ msg) path =-        path == M.signalPath msg+	path == M.signalPath msg pathMatches _ _ = False +#line 222 "src/match-rules.anansi" destMatches :: M.ReceivedMessage -> T.BusName -> Bool destMatches (M.ReceivedMethodCall _ _ msg) name =-        Just name == M.methodCallDestination msg+	Just name == M.methodCallDestination msg destMatches (M.ReceivedMethodReturn _ _ msg) name =-        Just name == M.methodReturnDestination msg+	Just name == M.methodReturnDestination msg destMatches (M.ReceivedError _ _ msg) name =-        Just name == M.errorDestination msg+	Just name == M.errorDestination msg destMatches (M.ReceivedSignal _ _ msg) name =-        Just name == M.signalDestination msg+	Just name == M.signalDestination msg destMatches _ _ = False +#line 235 "src/match-rules.anansi" 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-+	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
hs/DBus/Message.hs view
@@ -1,48 +1,61 @@-{--  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/>.--} -module DBus.Message-        (Message ( messageFlags-                 , messageBody-                 )+#line 23 "src/messages.anansi" -         , Flag (..)+#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>. -         , Serial-         , serialValue-         , firstSerial-         , nextSerial+#line 24 "src/messages.anansi"+module DBus.Message ( -         , MethodCall (..)+#line 51 "src/messages.anansi"+	Message ( messageFlags+	        , messageBody+	        ) -         , MethodReturn (..)+#line 69 "src/messages.anansi"+	, Flag (..) -         , Error (..)-         , errorMessage+#line 124 "src/messages.anansi"+	, Serial+	, serialValue+	, firstSerial+	, nextSerial -         , Signal (..)+#line 169 "src/messages.anansi"+	, MethodCall (..) -         , Unknown (..)+#line 206 "src/messages.anansi"+	, MethodReturn (..) -         , ReceivedMessage (..)-         , receivedSerial-         , receivedSender-         , receivedBody+#line 256 "src/messages.anansi"+	, Error (..)+	, errorMessage -        ) where-import DBus.Message.Internal+#line 296 "src/messages.anansi"+	, Signal (..) +#line 327 "src/messages.anansi"+	, Unknown (..)++#line 377 "src/messages.anansi"+	, ReceivedMessage (..)+	, receivedSerial+	, receivedSender+	, receivedBody++#line 26 "src/messages.anansi"+	) where+import DBus.Message.Internal
hs/DBus/Message/Internal.hs view
@@ -1,182 +1,211 @@-{--  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/>.--} +#line 31 "src/messages.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 32 "src/messages.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} +#line 33 "src/messages.anansi" module DBus.Message.Internal where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 35 "src/messages.anansi" 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) +#line 43 "src/messages.anansi" class Message a where-        messageTypeCode     :: a -> Word8-        messageHeaderFields :: a -> [HeaderField]-        messageFlags        :: a -> S.Set Flag-        messageBody         :: a -> [T.Variant]+	messageTypeCode     :: a -> Word8+	messageHeaderFields :: a -> [HeaderField]+	messageFlags        :: a -> S.Set Flag+	messageBody         :: a -> [T.Variant] +#line 62 "src/messages.anansi" data Flag-        = NoReplyExpected-        | NoAutoStart-        deriving (Show, Eq, Ord)+	= NoReplyExpected+	| NoAutoStart+	deriving (Show, Eq, Ord) +#line 80 "src/messages.anansi" 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)+	= 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) +#line 98 "src/messages.anansi"++#line 152 "src/api-docs.anansi" -- | A value used to uniquely identify a particular message within a session. -- 'Serial's are 32-bit unsigned integers, and eventually wrap. +#line 99 "src/messages.anansi" newtype Serial = Serial { serialValue :: Word32 }-        deriving (Eq, Ord)+	deriving (Eq, Ord)  instance Show Serial where-        show (Serial x) = show x+	show (Serial x) = show x  instance T.Variable Serial where-        toVariant (Serial x) = T.toVariant x-        fromVariant = fmap Serial . T.fromVariant+	toVariant (Serial x) = T.toVariant x+	fromVariant = fmap Serial . T.fromVariant +#line 113 "src/messages.anansi" firstSerial :: Serial firstSerial = Serial 1  nextSerial :: Serial -> Serial nextSerial (Serial x) = Serial (x + 1) +#line 138 "src/messages.anansi" maybe' :: (a -> b) -> Maybe a -> [b] maybe' f = maybe [] (\x' -> [f x']) +#line 145 "src/messages.anansi" 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)+	{ 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-                ]+	messageTypeCode _ = 1+	messageFlags      = methodCallFlags+	messageBody       = methodCallBody+	messageHeaderFields m = concat+		[ [ Path    $ methodCallPath m+		  ,  Member $ methodCallMember m+		  ]+		, maybe' Interface . methodCallInterface $ m+		, maybe' Destination . methodCallDestination $ m+		] +#line 187 "src/messages.anansi" data MethodReturn = MethodReturn-        { methodReturnSerial      :: Serial-        , methodReturnDestination :: Maybe T.BusName-        , methodReturnBody        :: [T.Variant]-        }-        deriving (Show, Eq)+	{ 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-                ]+	messageTypeCode _ = 2+	messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]+	messageBody       = methodReturnBody+	messageHeaderFields m = concat+		[ [ ReplySerial $ methodReturnSerial m+		  ]+		, maybe' Destination . methodReturnDestination $ m+		] +#line 221 "src/messages.anansi" data Error = Error-        { errorName        :: T.ErrorName-        , errorSerial      :: Serial-        , errorDestination :: Maybe T.BusName-        , errorBody        :: [T.Variant]-        }-        deriving (Show, Eq)+	{ 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-                ]+	messageTypeCode _ = 3+	messageFlags    _ = S.fromList [NoReplyExpected, NoAutoStart]+	messageBody       = errorBody+	messageHeaderFields m = concat+		[ [ ErrorName   $ errorName m+		  , ReplySerial $ errorSerial m+		  ]+		, maybe' Destination . errorDestination $ m+		] +#line 246 "src/messages.anansi" 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+	field <- maybeIndex (errorBody msg) 0+	text <- T.fromVariant field+	if TL.null text+		then Nothing+		else return text +#line 273 "src/messages.anansi" data Signal = Signal-        { signalPath        :: T.ObjectPath-        , signalMember      :: T.MemberName-        , signalInterface   :: T.InterfaceName-        , signalDestination :: Maybe T.BusName-        , signalBody        :: [T.Variant]-        }-        deriving (Show, Eq)+	{ 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-                ]+	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+		] +#line 318 "src/messages.anansi" data Unknown = Unknown-        { unknownType    :: Word8-        , unknownFlags   :: S.Set Flag-        , unknownBody    :: [T.Variant]-        }-        deriving (Show, Eq)+	{ unknownType    :: Word8+	, unknownFlags   :: S.Set Flag+	, unknownBody    :: [T.Variant]+	}+	deriving (Show, Eq) +#line 339 "src/messages.anansi"++#line 157 "src/api-docs.anansi" -- | Not an actual message type, but a wrapper around messages received from -- the bus. Each value contains the message's 'Serial' and possibly the -- origin's 'T.BusName' +#line 340 "src/messages.anansi" 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)+	= 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) +#line 350 "src/messages.anansi" receivedSerial :: ReceivedMessage -> Serial receivedSerial (ReceivedMethodCall   s _ _) = s receivedSerial (ReceivedMethodReturn s _ _) = s@@ -184,6 +213,7 @@ receivedSerial (ReceivedSignal       s _ _) = s receivedSerial (ReceivedUnknown      s _ _) = s +#line 359 "src/messages.anansi" receivedSender :: ReceivedMessage -> Maybe T.BusName receivedSender (ReceivedMethodCall   _ s _) = s receivedSender (ReceivedMethodReturn _ s _) = s@@ -191,10 +221,10 @@ receivedSender (ReceivedSignal       _ s _) = s receivedSender (ReceivedUnknown      _ s _) = s +#line 368 "src/messages.anansi" 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 (ReceivedUnknown      _ _ x) = unknownBody x-
hs/DBus/NameReservation.hs view
@@ -1,30 +1,33 @@-{--  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/>.--} +#line 22 "src/name-reservation.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 23 "src/name-reservation.anansi" {-# LANGUAGE OverloadedStrings #-} module DBus.NameReservation-        ( RequestNameFlag (..)-        , RequestNameReply (..)-        , ReleaseNameReply (..)-        , requestName-        , releaseName-        , mkRequestNameReply-        , mkReleaseNameReply-        ) where+	( RequestNameFlag (..)+	, RequestNameReply (..)+	, ReleaseNameReply (..)+	, requestName+	, releaseName+	, mkRequestNameReply+	, mkReleaseNameReply+	) where import Data.Word (Word32) import Data.Bits ((.|.)) import qualified Data.Set as Set@@ -33,45 +36,54 @@ import qualified DBus.Constants as C import DBus.Util (maybeIndex) +#line 43 "src/name-reservation.anansi" data RequestNameFlag-        = AllowReplacement-        | ReplaceExisting-        | DoNotQueue-        deriving (Show)+	= AllowReplacement+	| ReplaceExisting+	| DoNotQueue+	deriving (Show) +#line 51 "src/name-reservation.anansi" encodeFlags :: [RequestNameFlag] -> Word32 encodeFlags = foldr (.|.) 0 . map flagValue where-        flagValue AllowReplacement = 0x1-        flagValue ReplaceExisting  = 0x2-        flagValue DoNotQueue       = 0x4+	flagValue AllowReplacement = 0x1+	flagValue ReplaceExisting  = 0x2+	flagValue DoNotQueue       = 0x4 +#line 62 "src/name-reservation.anansi"++#line 144 "src/api-docs.anansi" -- | Build a 'M.MethodCall' for requesting a registered bus name. +#line 63 "src/name-reservation.anansi" requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall requestName name flags = M.MethodCall-        { M.methodCallPath = C.dbusPath-        , M.methodCallInterface = Just C.dbusInterface-        , M.methodCallDestination = Just C.dbusName-        , M.methodCallFlags = Set.empty-        , M.methodCallMember = "RequestName"-        , M.methodCallBody =-                [ T.toVariant name-                , T.toVariant . encodeFlags $ flags]-        }+	{ M.methodCallPath = C.dbusPath+	, M.methodCallInterface = Just C.dbusInterface+	, M.methodCallDestination = Just C.dbusName+	, M.methodCallFlags = Set.empty+	, M.methodCallMember = "RequestName"+	, M.methodCallBody =+		[ T.toVariant name+		, T.toVariant . encodeFlags $ flags]+	} +#line 77 "src/name-reservation.anansi" data RequestNameReply-        = PrimaryOwner-        | InQueue-        | Exists-        | AlreadyOwner-        deriving (Show)+	= PrimaryOwner+	| InQueue+	| Exists+	| AlreadyOwner+	deriving (Show) +#line 86 "src/name-reservation.anansi" mkRequestNameReply :: M.MethodReturn -> Maybe RequestNameReply mkRequestNameReply msg =-        maybeIndex (M.messageBody msg) 0 >>=-        T.fromVariant >>=-        decodeRequestReply+	maybeIndex (M.messageBody msg) 0 >>=+	T.fromVariant >>=+	decodeRequestReply +#line 94 "src/name-reservation.anansi" decodeRequestReply :: Word32 -> Maybe RequestNameReply decodeRequestReply 1 = Just PrimaryOwner decodeRequestReply 2 = Just InQueue@@ -79,33 +91,39 @@ decodeRequestReply 4 = Just AlreadyOwner decodeRequestReply _ = Nothing +#line 103 "src/name-reservation.anansi"++#line 148 "src/api-docs.anansi" -- | Build a 'M.MethodCall' for releasing a registered bus name. +#line 104 "src/name-reservation.anansi" releaseName :: T.BusName -> M.MethodCall releaseName name = M.MethodCall-        { M.methodCallPath = C.dbusPath-        , M.methodCallInterface = Just C.dbusInterface-        , M.methodCallDestination = Just C.dbusName-        , M.methodCallFlags = Set.empty-        , M.methodCallMember = "ReleaseName"-        , M.methodCallBody = [T.toVariant name]-        }+	{ M.methodCallPath = C.dbusPath+	, M.methodCallInterface = Just C.dbusInterface+	, M.methodCallDestination = Just C.dbusName+	, M.methodCallFlags = Set.empty+	, M.methodCallMember = "ReleaseName"+	, M.methodCallBody = [T.toVariant name]+	} +#line 116 "src/name-reservation.anansi" data ReleaseNameReply-        = Released-        | NonExistent-        | NotOwner-        deriving (Show)+	= Released+	| NonExistent+	| NotOwner+	deriving (Show) +#line 124 "src/name-reservation.anansi" mkReleaseNameReply :: M.MethodReturn -> Maybe ReleaseNameReply mkReleaseNameReply msg =-        maybeIndex (M.messageBody msg) 0 >>=-        T.fromVariant >>=-        decodeReleaseReply+	maybeIndex (M.messageBody msg) 0 >>=+	T.fromVariant >>=+	decodeReleaseReply +#line 132 "src/name-reservation.anansi" decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply decodeReleaseReply 1 = Just Released decodeReleaseReply 2 = Just NonExistent decodeReleaseReply 3 = Just NotOwner decodeReleaseReply _ = Nothing-
+ hs/DBus/Types.cpphs view
@@ -0,0 +1,704 @@++#line 22 "src/types.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 23 "src/types.anansi"++#line 52 "src/introduction.anansi"+{-# LANGUAGE OverloadedStrings #-}++#line 24 "src/types.anansi"++#line 358 "src/types.anansi"+{-# LANGUAGE TypeSynonymInstances #-}++#line 25 "src/types.anansi"+module DBus.Types (++#line 89 "src/types.anansi"+	  -- * Available types+	  Type (..)+	, typeCode++#line 165 "src/types.anansi"+	  -- * Variants+	, Variant+	, Variable (..)++#line 234 "src/types.anansi"+	, variantType++#line 425 "src/types.anansi"+	  -- * Signatures+	, Signature+	, signatureTypes+	, strSignature++#line 601 "src/types.anansi"+	, mkSignature+	, mkSignature_++#line 658 "src/types.anansi"+	  -- * Object paths+	, ObjectPath+	, strObjectPath+	, mkObjectPath+	, mkObjectPath_++#line 713 "src/types.anansi"+	  -- * Arrays+	, Array+	, arrayType+	, arrayItems++#line 759 "src/types.anansi"+	, toArray+	, fromArray+	, arrayFromItems++#line 777 "src/types.anansi"+	, arrayToBytes+	, arrayFromBytes++#line 846 "src/types.anansi"+	  -- * Dictionaries+	, Dictionary+	, dictionaryItems+	, dictionaryKeyType+	, dictionaryValueType++#line 923 "src/types.anansi"+	, toDictionary+	, fromDictionary+	, dictionaryFromItems++#line 995 "src/types.anansi"+	, dictionaryToArray+	, arrayToDictionary++#line 1011 "src/types.anansi"+	  -- * Structures+	, Structure (..)++#line 1052 "src/types.anansi"+	-- * Names++#line 1082 "src/types.anansi"+	  -- ** Bus names+	, BusName+	, strBusName+	, mkBusName+	, mkBusName_++#line 1135 "src/types.anansi"+	  -- ** Interface names+	, InterfaceName+	, strInterfaceName+	, mkInterfaceName+	, mkInterfaceName_++#line 1176 "src/types.anansi"+	  -- ** Error names+	, ErrorName+	, strErrorName+	, mkErrorName+	, mkErrorName_++#line 1212 "src/types.anansi"+	  -- ** Member names+	, MemberName+	, strMemberName+	, mkMemberName+	, mkMemberName_++#line 27 "src/types.anansi"+	) where++#line 56 "src/introduction.anansi"+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL++#line 29 "src/types.anansi"++#line 311 "src/types.anansi"+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Int (Int16, Int32, Int64)++#line 345 "src/types.anansi"+import qualified Data.Text as T++#line 416 "src/types.anansi"+import Data.Ord (comparing)++#line 517 "src/types.anansi"+import Text.Parsec ((<|>))+import qualified Text.Parsec as P+import DBus.Util (checkLength, parseMaybe)++#line 584 "src/types.anansi"+import DBus.Util (mkUnsafe)+import qualified Data.String as String++#line 691 "src/types.anansi"+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as ByteString++#line 791 "src/types.anansi"+import qualified Data.ByteString as StrictByteString++#line 857 "src/types.anansi"+import Data.List (intercalate)++#line 874 "src/types.anansi"+import Control.Monad (unless)++#line 896 "src/types.anansi"+import Control.Arrow ((***))+import qualified Data.Map as Map++#line 908 "src/types.anansi"+import Control.Monad (forM)++#line 41 "src/types.anansi"+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)++#line 62 "src/types.anansi"++#line 27 "src/api-docs.anansi"+-- | \"Atomic\" types are any which can't contain any other types. Only+-- atomic types may be used as dictionary keys.++#line 63 "src/types.anansi"+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++#line 83 "src/types.anansi"++#line 32 "src/api-docs.anansi"+-- | Every type has an associated type code; a textual representation of+-- the type, useful for debugging.++#line 84 "src/types.anansi"+typeCode :: Type -> Text++#line 437 "src/types.anansi"+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"++#line 456 "src/types.anansi"+typeCode (DBusArray t) = TL.cons 'a' $ typeCode t++#line 463 "src/types.anansi"+typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"]++#line 471 "src/types.anansi"+typeCode (DBusStructure ts) = TL.concat $+	["("] ++ map typeCode ts ++ [")"]++#line 139 "src/types.anansi"++#line 37 "src/api-docs.anansi"+-- | 'Variant's may contain any other built-in D-Bus value. Besides+-- representing native @VARIANT@ values, they allow type-safe storage and+-- deconstruction of heterogeneous collections.++#line 140 "src/types.anansi"+data Variant+	= VarBoxBool Bool+	| VarBoxWord8 Word8+	| VarBoxInt16 Int16+	| VarBoxInt32 Int32+	| VarBoxInt64 Int64+	| VarBoxWord16 Word16+	| VarBoxWord32 Word32+	| VarBoxWord64 Word64+	| VarBoxDouble Double+	| VarBoxString Text+	| VarBoxSignature Signature+	| VarBoxObjectPath ObjectPath+	| VarBoxVariant Variant+	| VarBoxArray Array+	| VarBoxDictionary Dictionary+	| VarBoxStructure Structure+	deriving (Eq)++class Variable a where+	toVariant :: a -> Variant+	fromVariant :: Variant -> Maybe a++#line 175 "src/types.anansi"+instance Show Variant where+	showsPrec d var = showParen (d > 10) full where+		full = s "Variant " . shows code . s " " . valueStr+		code = typeCode $ variantType var+		s = showString+		valueStr = showsPrecVar 11 var++showsPrecVar :: Int -> Variant -> ShowS+showsPrecVar d var = case var of+	(VarBoxBool x) -> showsPrec d x+	(VarBoxWord8 x) -> showsPrec d x+	(VarBoxInt16 x) -> showsPrec d x+	(VarBoxInt32 x) -> showsPrec d x+	(VarBoxInt64 x) -> showsPrec d x+	(VarBoxWord16 x) -> showsPrec d x+	(VarBoxWord32 x) -> showsPrec d x+	(VarBoxWord64 x) -> showsPrec d x+	(VarBoxDouble x) -> showsPrec d x+	(VarBoxString x) -> showsPrec d x+	(VarBoxSignature x) -> showsPrec d x+	(VarBoxObjectPath x) -> showsPrec d x+	(VarBoxVariant x) -> showsPrec d x+	(VarBoxArray x) -> showsPrec d x+	(VarBoxDictionary x) -> showsPrec d x+	(VarBoxStructure x) -> showsPrec d x++#line 207 "src/types.anansi"++#line 43 "src/api-docs.anansi"+-- | Every variant is strongly-typed; that is, the type of its contained+-- value is known at all times. This function retrieves that type, so that+-- the correct cast can be used to retrieve the value.++#line 208 "src/types.anansi"+variantType :: Variant -> Type+variantType var = case var of+	(VarBoxBool _) -> DBusBoolean+	(VarBoxWord8 _) -> DBusByte+	(VarBoxInt16 _) -> DBusInt16+	(VarBoxInt32 _) -> DBusInt32+	(VarBoxInt64 _) -> DBusInt64+	(VarBoxWord16 _) -> DBusWord16+	(VarBoxWord32 _) -> DBusWord32+	(VarBoxWord64 _) -> DBusWord64+	(VarBoxDouble _) -> DBusDouble+	(VarBoxString _) -> DBusString+	(VarBoxSignature _) -> DBusSignature+	(VarBoxObjectPath _) -> DBusObjectPath+	(VarBoxVariant _) -> DBusVariant+	(VarBoxArray x) -> DBusArray (arrayType x)+	(VarBoxDictionary x) -> let+		keyT = dictionaryKeyType x+		valueT = dictionaryValueType x+		in DBusDictionary keyT valueT+	(VarBoxStructure x) -> let+		Structure items = x+		in DBusStructure (map variantType items)++#line 241 "src/types.anansi"+#define INSTANCE_VARIABLE(TYPE) \+	instance Variable TYPE where \+		{ toVariant = VarBox/**/TYPE \+		; fromVariant (VarBox/**/TYPE x) = Just x \+		; fromVariant _ = Nothing \+		}++#line 252 "src/types.anansi"+INSTANCE_VARIABLE(Variant)++#line 316 "src/types.anansi"+INSTANCE_VARIABLE(Bool)+INSTANCE_VARIABLE(Word8)+INSTANCE_VARIABLE(Int16)+INSTANCE_VARIABLE(Int32)+INSTANCE_VARIABLE(Int64)+INSTANCE_VARIABLE(Word16)+INSTANCE_VARIABLE(Word32)+INSTANCE_VARIABLE(Word64)+INSTANCE_VARIABLE(Double)++#line 334 "src/types.anansi"+instance Variable TL.Text where+	toVariant = VarBoxString+	fromVariant (VarBoxString x) = Just x+	fromVariant _ = Nothing++#line 349 "src/types.anansi"+instance Variable T.Text where+	toVariant = toVariant . TL.fromChunks . (:[])+	fromVariant = fmap (T.concat . TL.toChunks) . fromVariant++#line 362 "src/types.anansi"+instance Variable String where+	toVariant = toVariant . TL.pack+	fromVariant = fmap TL.unpack . fromVariant++#line 395 "src/types.anansi"+INSTANCE_VARIABLE(Signature)+data Signature = Signature { signatureTypes :: [Type] }+	deriving (Eq)++instance Show Signature where+	showsPrec d x = showParen (d > 10) $+		showString "Signature " . shows (strSignature x)++#line 408 "src/types.anansi"+strSignature :: Signature -> Text+strSignature (Signature ts) = TL.concat $ map typeCode ts++#line 420 "src/types.anansi"+instance Ord Signature where+	compare = comparing strSignature++#line 482 "src/types.anansi"+mkSignature :: Text -> Maybe Signature+mkSignature text = parsed where++#line 496 "src/types.anansi"+	just t = Just $ Signature [t]+	fast = case TL.head text of+		'b' -> just DBusBoolean+		'y' -> just DBusByte+		'n' -> just DBusInt16+		'i' -> just DBusInt32+		'x' -> just DBusInt64+		'q' -> just DBusWord16+		'u' -> just DBusWord32+		't' -> just DBusWord64+		'd' -> just DBusDouble+		's' -> just DBusString+		'g' -> just DBusSignature+		'o' -> just DBusObjectPath+		'v' -> just DBusVariant+		_   -> Nothing++#line 485 "src/types.anansi"++#line 523 "src/types.anansi"+	slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text+	sigParser = do+		types <- P.many parseType+		P.eof+		return $ Signature types++#line 534 "src/types.anansi"+	parseType = parseAtom <|> parseContainer+	parseContainer =+		    parseArray+		<|> parseStruct+		<|> (P.char 'v' >> return DBusVariant)++#line 542 "src/types.anansi"+	parseArray = do+		P.char 'a'+		parseDict <|> fmap DBusArray parseType+	parseDict = do+		P.char '{'+		keyType <- parseAtom+		valueType <- parseType+		P.char '}'+		return $ DBusDictionary keyType valueType++#line 556 "src/types.anansi"+	parseStruct = do+		P.char '('+		types <- P.many parseType+		P.char ')'+		return $ DBusStructure types++#line 564 "src/types.anansi"+	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)++#line 486 "src/types.anansi"+	parsed = case TL.length text of+		0 -> Just $ Signature []+		1 -> fast+		_ -> slow++#line 589 "src/types.anansi"+mkSignature_ :: Text -> Signature+mkSignature_ = mkUnsafe "signature" mkSignature++instance String.IsString Signature where+	fromString = mkSignature_ . TL.pack++#line 620 "src/types.anansi"+INSTANCE_VARIABLE(ObjectPath)+newtype ObjectPath = ObjectPath+	{ strObjectPath :: Text+	}+	deriving (Eq, Ord)++instance Show ObjectPath where+	showsPrec d (ObjectPath x) = showParen (d > 10) $+		showString "ObjectPath " . shows x++instance String.IsString ObjectPath where+	fromString = mkObjectPath_ . TL.pack++#line 647 "src/types.anansi"+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++#line 696 "src/types.anansi"+INSTANCE_VARIABLE(Array)+data Array+	= VariantArray Type [Variant]+	| ByteArray ByteString+	deriving (Eq)+++#line 49 "src/api-docs.anansi"+-- | This is the type contained within the array, not the type of the array+-- itself.++#line 703 "src/types.anansi"+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++#line 723 "src/types.anansi"+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+			showVar var = showsPrecVar 0 var ""+			valueString = intercalate ", " $ map showVar $ arrayItems array++#line 737 "src/types.anansi"+arrayFromItems :: Type -> [Variant] -> Maybe Array+arrayFromItems DBusByte vs = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs)++arrayFromItems t vs = do+	mkSignature (typeCode t)+	if all (\x -> variantType x == t) vs+		then Just $ VariantArray t vs+		else Nothing++#line 751 "src/types.anansi"+toArray :: Variable a => Type -> [a] -> Maybe Array+toArray t = arrayFromItems t . map toVariant++fromArray :: Variable a => Array -> Maybe [a]+fromArray = mapM fromVariant . arrayItems++#line 768 "src/types.anansi"+arrayToBytes :: Array -> Maybe ByteString+arrayToBytes (ByteArray x) = Just x+arrayToBytes _             = Nothing++arrayFromBytes :: ByteString -> Array+arrayFromBytes = ByteArray++#line 785 "src/types.anansi"+instance Variable ByteString where+	toVariant = toVariant . arrayFromBytes+	fromVariant x = fromVariant x >>= arrayToBytes++#line 795 "src/types.anansi"+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++#line 836 "src/types.anansi"+INSTANCE_VARIABLE(Dictionary)+data Dictionary = Dictionary+	{ dictionaryKeyType   :: Type+	, dictionaryValueType :: Type+	, dictionaryItems     :: [(Variant, Variant)]+	}+	deriving (Eq)++#line 861 "src/types.anansi"+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 (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 v) ""++#line 878 "src/types.anansi"+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++#line 901 "src/types.anansi"+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++#line 912 "src/types.anansi"+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++#line 972 "src/types.anansi"+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]++#line 980 "src/types.anansi"+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++#line 1005 "src/types.anansi"+INSTANCE_VARIABLE(Structure)+data Structure = Structure [Variant]+	deriving (Show, Eq)++#line 1031 "src/types.anansi"+#define NAME_TYPE(TYPE, NAME) \+	newtype TYPE = TYPE {str/**/TYPE :: Text} \+		deriving (Eq, Ord); \+		\+	instance Show TYPE where \+		{ showsPrec d (TYPE x) = showParen (d > 10) $ \+			showString "TYPE " . shows x \+		}; \+		\+	instance String.IsString TYPE where \+		{ fromString = mk/**/TYPE/**/_ . TL.pack }; \+		\+	instance Variable TYPE where \+		{ toVariant = toVariant . str/**/TYPE \+		; fromVariant = (mk/**/TYPE =<<) . fromVariant }; \+		                                                \+	mk/**/TYPE/**/_ :: Text -> TYPE; \+	mk/**/TYPE/**/_ = mkUnsafe NAME mk/**/TYPE++#line 1068 "src/types.anansi"+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')++#line 1123 "src/types.anansi"+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)++#line 1169 "src/types.anansi"+NAME_TYPE(ErrorName, "error name")++mkErrorName :: Text -> Maybe ErrorName+mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName++#line 1201 "src/types.anansi"+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)
− hs/DBus/Types.hs 
@@ -1,593 +0,0 @@-{--  Copyright (C) 2009 John Millikin <jmillikin@gmail.com>-  -  This program is free software: you can redistribute it and/or modify-  it under the terms of the GNU General Public License as published by-  the Free Software Foundation, either version 3 of the License, or-  any later version.-  -  This program is distributed in the hope that it will be useful,-  but WITHOUT ANY WARRANTY; without even the implied warranty of-  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-  GNU General Public License for more details.-  -  You should have received a copy of the GNU General Public License-  along with this program.  If not, see <http://www.gnu.org/licenses/>.--}--{-# LANGUAGE OverloadedStrings #-}--{-# LANGUAGE TypeSynonymInstances #-}--module DBus.Types (  -- * Available types-                     Type (..)-                   , typeCode--                     -- * Variants-                   , Variant-                   , Variable (..)--                   , variantType--                     -- * Signatures-                   , Signature-                   , signatureTypes-                   , strSignature--                   , mkSignature-                   , mkSignature_--                     -- * Object paths-                   , ObjectPath-                   , strObjectPath-                   , mkObjectPath-                   , mkObjectPath_--                     -- * Arrays-                   , Array-                   , arrayType-                   , arrayItems--                   , toArray-                   , fromArray-                   , arrayFromItems--                   , arrayToBytes-                   , arrayFromBytes--                     -- * Dictionaries-                   , Dictionary-                   , dictionaryItems-                   , dictionaryKeyType-                   , dictionaryValueType--                   , toDictionary-                   , fromDictionary-                   , dictionaryFromItems--                   , dictionaryToArray-                   , arrayToDictionary--                     -- * Structures-                   , Structure (..)--                   -- * Names--                     -- ** Bus names-                   , BusName-                   , strBusName-                   , mkBusName-                   , mkBusName_--                     -- ** Interface names-                   , InterfaceName-                   , strInterfaceName-                   , mkInterfaceName-                   , mkInterfaceName_--                     -- ** Error names-                   , ErrorName-                   , strErrorName-                   , mkErrorName-                   , mkErrorName_--                     -- ** Member names-                   , MemberName-                   , strMemberName-                   , mkMemberName-                   , mkMemberName_-) where-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as TL--import Data.Word (Word8, Word16, Word32, Word64)-import Data.Int (Int16, Int32, Int64)--import qualified Data.Text as T--import Data.Ord (comparing)--import Text.Parsec ((<|>))-import qualified Text.Parsec as P-import DBus.Util (checkLength, parseMaybe)--import DBus.Util (mkUnsafe)--import qualified Data.String as String--import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as ByteString--import qualified Data.ByteString as StrictByteString--import Data.List (intercalate)--import Control.Monad (unless)--import Control.Arrow ((***))-import qualified Data.Map as Map--import Control.Monad (forM)---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)---- | \"Atomic\" types are any which can't contain any other types. Only--- atomic types may be used as dictionary keys.--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---- | Every type has an associated type code; a textual representation of--- the type, useful for debugging.--typeCode :: Type -> Text-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"--typeCode (DBusArray t) = TL.cons 'a' $ typeCode t--typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"]--typeCode (DBusStructure ts) = TL.concat $-        ["("] ++ map typeCode ts ++ [")"]----- | 'Variant's may contain any other built-in D-Bus value. Besides--- representing native @VARIANT@ values, they allow type-safe storage and--- deconstruction of heterogeneous collections.--data Variant-        = VarBoxBool Bool-        | VarBoxWord8 Word8-        | VarBoxInt16 Int16-        | VarBoxInt32 Int32-        | VarBoxInt64 Int64-        | VarBoxWord16 Word16-        | VarBoxWord32 Word32-        | VarBoxWord64 Word64-        | VarBoxDouble Double-        | VarBoxString Text-        | VarBoxSignature Signature-        | VarBoxObjectPath ObjectPath-        | VarBoxVariant Variant-        | VarBoxArray Array-        | VarBoxDictionary Dictionary-        | VarBoxStructure Structure-        deriving (Eq)--class Variable a where-        toVariant :: a -> Variant-        fromVariant :: Variant -> Maybe a--instance Show Variant where-        showsPrec d var = showParen (d > 10) full where-                full = s "Variant " . shows code . s " " . valueStr-                code = typeCode $ variantType var-                s = showString-                valueStr = showsPrecVar 11 var--showsPrecVar :: Int -> Variant -> ShowS-showsPrecVar d var = case var of-        (VarBoxBool x) -> showsPrec d x-        (VarBoxWord8 x) -> showsPrec d x-        (VarBoxInt16 x) -> showsPrec d x-        (VarBoxInt32 x) -> showsPrec d x-        (VarBoxInt64 x) -> showsPrec d x-        (VarBoxWord16 x) -> showsPrec d x-        (VarBoxWord32 x) -> showsPrec d x-        (VarBoxWord64 x) -> showsPrec d x-        (VarBoxDouble x) -> showsPrec d x-        (VarBoxString x) -> showsPrec d x-        (VarBoxSignature x) -> showsPrec d x-        (VarBoxObjectPath x) -> showsPrec d x-        (VarBoxVariant x) -> showsPrec d x-        (VarBoxArray x) -> showsPrec d x-        (VarBoxDictionary x) -> showsPrec d x-        (VarBoxStructure x) -> showsPrec d x---- | Every variant is strongly-typed; that is, the type of its contained--- value is known at all times. This function retrieves that type, so that--- the correct cast can be used to retrieve the value.--variantType :: Variant -> Type-variantType var = case var of-        (VarBoxBool _) -> DBusBoolean-        (VarBoxWord8 _) -> DBusByte-        (VarBoxInt16 _) -> DBusInt16-        (VarBoxInt32 _) -> DBusInt32-        (VarBoxInt64 _) -> DBusInt64-        (VarBoxWord16 _) -> DBusWord16-        (VarBoxWord32 _) -> DBusWord32-        (VarBoxWord64 _) -> DBusWord64-        (VarBoxDouble _) -> DBusDouble-        (VarBoxString _) -> DBusString-        (VarBoxSignature _) -> DBusSignature-        (VarBoxObjectPath _) -> DBusObjectPath-        (VarBoxVariant _) -> DBusVariant-        (VarBoxArray x) -> DBusArray (arrayType x)-        (VarBoxDictionary x) -> let-                keyT = dictionaryKeyType x-                valueT = dictionaryValueType x-                in DBusDictionary keyT valueT-        (VarBoxStructure x) -> let-                Structure items = x-                in DBusStructure (map variantType items)---------instance Variable Variant where                 { toVariant = VarBoxVariant                 ; fromVariant (VarBoxVariant x) = Just x                 ; fromVariant _ = Nothing                 }--instance Variable Bool where                 { toVariant = VarBoxBool                 ; fromVariant (VarBoxBool x) = Just x                 ; fromVariant _ = Nothing                 }-instance Variable Word8 where                 { toVariant = VarBoxWord8                 ; fromVariant (VarBoxWord8 x) = Just x                 ; fromVariant _ = Nothing                 }-instance Variable Int16 where                 { toVariant = VarBoxInt16                 ; fromVariant (VarBoxInt16 x) = Just x                 ; fromVariant _ = Nothing                 }-instance Variable Int32 where                 { toVariant = VarBoxInt32                 ; fromVariant (VarBoxInt32 x) = Just x                 ; fromVariant _ = Nothing                 }-instance Variable Int64 where                 { toVariant = VarBoxInt64                 ; fromVariant (VarBoxInt64 x) = Just x                 ; fromVariant _ = Nothing                 }-instance Variable Word16 where                 { toVariant = VarBoxWord16                 ; fromVariant (VarBoxWord16 x) = Just x                 ; fromVariant _ = Nothing                 }-instance Variable Word32 where                 { toVariant = VarBoxWord32                 ; fromVariant (VarBoxWord32 x) = Just x                 ; fromVariant _ = Nothing                 }-instance Variable Word64 where                 { toVariant = VarBoxWord64                 ; fromVariant (VarBoxWord64 x) = Just x                 ; fromVariant _ = Nothing                 }-instance Variable Double where                 { toVariant = VarBoxDouble                 ; fromVariant (VarBoxDouble x) = Just x                 ; fromVariant _ = Nothing                 }--instance Variable TL.Text where-        toVariant = VarBoxString-        fromVariant (VarBoxString x) = Just x-        fromVariant _ = Nothing--instance Variable T.Text where-        toVariant = toVariant . TL.fromChunks . (:[])-        fromVariant = fmap (T.concat . TL.toChunks) . fromVariant--instance Variable String where-        toVariant = toVariant . TL.pack-        fromVariant = fmap TL.unpack . fromVariant--instance Variable Signature where                 { toVariant = VarBoxSignature                 ; fromVariant (VarBoxSignature x) = Just x                 ; fromVariant _ = Nothing                 }-data Signature = Signature { signatureTypes :: [Type] }-        deriving (Eq)--instance Show Signature where-        showsPrec d x = showParen (d > 10) $-                showString "Signature " . shows (strSignature x)--strSignature :: Signature -> Text-strSignature (Signature ts) = TL.concat $ map typeCode ts--instance Ord Signature where-        compare = comparing strSignature--mkSignature :: Text -> Maybe Signature-mkSignature text = parsed where-        just t = Just $ Signature [t]-        fast = case TL.head text of-                'b' -> just DBusBoolean-                'y' -> just DBusByte-                'n' -> just DBusInt16-                'i' -> just DBusInt32-                'x' -> just DBusInt64-                'q' -> just DBusWord16-                'u' -> just DBusWord32-                't' -> just DBusWord64-                'd' -> just DBusDouble-                's' -> just DBusString-                'g' -> just DBusSignature-                'o' -> just DBusObjectPath-                'v' -> just DBusVariant-                _   -> Nothing--        slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text-        sigParser = do-                types <- P.many parseType-                P.eof-                return $ Signature types--        parseType = parseAtom <|> parseContainer-        parseContainer =-                    parseArray-                <|> parseStruct-                <|> (P.char 'v' >> return DBusVariant)--        parseArray = do-                P.char 'a'-                parseDict <|> fmap DBusArray parseType-        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--        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)--        parsed = case TL.length text of-                0 -> Just $ Signature []-                1 -> fast-                _ -> slow--mkSignature_ :: Text -> Signature-mkSignature_ = mkUnsafe "signature" mkSignature--instance String.IsString Signature where-        fromString = mkSignature_ . TL.pack--instance Variable ObjectPath where                 { toVariant = VarBoxObjectPath                 ; fromVariant (VarBoxObjectPath x) = Just x                 ; fromVariant _ = Nothing                 }-newtype ObjectPath = ObjectPath-        { strObjectPath :: Text-        }-        deriving (Eq, Ord)--instance Show ObjectPath where-        showsPrec d (ObjectPath x) = showParen (d > 10) $-                showString "ObjectPath " . shows x--instance String.IsString ObjectPath where-        fromString = mkObjectPath_ . TL.pack--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--instance Variable Array where                 { toVariant = VarBoxArray                 ; fromVariant (VarBoxArray x) = Just x                 ; fromVariant _ = Nothing                 }-data Array-        = VariantArray Type [Variant]-        | ByteArray ByteString-        deriving (Eq)---- | This is the type contained within the array, not the type of the array--- itself.--arrayType :: Array -> Type-arrayType (VariantArray t _) = t-arrayType (ByteArray _) = DBusByte--arrayItems :: Array -> [Variant]-arrayItems (VariantArray _ xs) = xs-arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs--instance Show Array where-        showsPrec d array = showParen (d > 10) $-                s "Array " . showSig . s " [" . s valueString . s "]" where-                        s = showString-                        showSig = shows . typeCode . arrayType $ array-                        showVar var = showsPrecVar 0 var ""-                        valueString = intercalate ", " $ map showVar $ arrayItems array--arrayFromItems :: Type -> [Variant] -> Maybe Array-arrayFromItems DBusByte vs = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs)--arrayFromItems t vs = do-        mkSignature (typeCode t)-        if all (\x -> variantType x == t) vs-                then Just $ VariantArray t vs-                else Nothing--toArray :: Variable a => Type -> [a] -> Maybe Array-toArray t = arrayFromItems t . map toVariant--fromArray :: Variable a => Array -> Maybe [a]-fromArray = mapM fromVariant . arrayItems--arrayToBytes :: Array -> Maybe ByteString-arrayToBytes (ByteArray x) = Just x-arrayToBytes _             = Nothing--arrayFromBytes :: ByteString -> Array-arrayFromBytes = ByteArray--instance Variable ByteString where-        toVariant = toVariant . arrayFromBytes-        fromVariant x = fromVariant x >>= arrayToBytes--instance Variable StrictByteString.ByteString where-        toVariant x = toVariant . arrayFromBytes $ ByteString.fromChunks [x]-        fromVariant x = do-                chunks <- ByteString.toChunks `fmap` fromVariant x-                return $ StrictByteString.concat chunks--instance Variable Dictionary where                 { toVariant = VarBoxDictionary                 ; fromVariant (VarBoxDictionary x) = Just x                 ; fromVariant _ = Nothing                 }-data Dictionary = Dictionary-        { dictionaryKeyType   :: Type-        , dictionaryValueType :: Type-        , dictionaryItems     :: [(Variant, Variant)]-        }-        deriving (Eq)--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 (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 v) ""--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--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--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--dictionaryToArray :: Dictionary -> Array-dictionaryToArray (Dictionary kt vt items) = array where-        Just array = toArray itemType structs-        itemType = DBusStructure [kt, vt]-        structs = [Structure [k, v] | (k, v) <- items]--arrayToDictionary :: Array -> Maybe Dictionary-arrayToDictionary array = do-        let toPair x = do-                struct <- fromVariant x-                case struct of-                        Structure [k, v] -> Just (k, v)-                        _                -> Nothing-        (kt, vt) <- case arrayType array of-                DBusStructure [kt, vt] -> Just (kt, vt)-                _                      -> Nothing-        pairs <- mapM toPair $ arrayItems array-        dictionaryFromItems kt vt pairs--instance Variable Structure where                 { toVariant = VarBoxStructure                 ; fromVariant (VarBoxStructure x) = Just x                 ; fromVariant _ = Nothing                 }-data Structure = Structure [Variant]-        deriving (Show, Eq)---------------------newtype BusName = BusName {strBusName :: Text}                 deriving (Eq, Ord);                         instance Show BusName where                 { showsPrec d (BusName x) = showParen (d > 10) $                         showString "BusName " . shows x                 };                         instance String.IsString BusName where                 { fromString = mkBusName_ . TL.pack };                         instance Variable BusName where                 { toVariant = toVariant . strBusName                 ; fromVariant = (mkBusName =<<) . fromVariant };                                                                         mkBusName_ :: Text -> BusName;         mkBusName_ = mkUnsafe "bus name" mkBusName--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')--newtype InterfaceName = InterfaceName {strInterfaceName :: Text}                 deriving (Eq, Ord);                         instance Show InterfaceName where                 { showsPrec d (InterfaceName x) = showParen (d > 10) $                         showString "InterfaceName " . shows x                 };                         instance String.IsString InterfaceName where                 { fromString = mkInterfaceName_ . TL.pack };                         instance Variable InterfaceName where                 { toVariant = toVariant . strInterfaceName                 ; fromVariant = (mkInterfaceName =<<) . fromVariant };                                                                         mkInterfaceName_ :: Text -> InterfaceName;         mkInterfaceName_ = mkUnsafe "interface name" mkInterfaceName--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)--newtype ErrorName = ErrorName {strErrorName :: Text}                 deriving (Eq, Ord);                         instance Show ErrorName where                 { showsPrec d (ErrorName x) = showParen (d > 10) $                         showString "ErrorName " . shows x                 };                         instance String.IsString ErrorName where                 { fromString = mkErrorName_ . TL.pack };                         instance Variable ErrorName where                 { toVariant = toVariant . strErrorName                 ; fromVariant = (mkErrorName =<<) . fromVariant };                                                                         mkErrorName_ :: Text -> ErrorName;         mkErrorName_ = mkUnsafe "error name" mkErrorName--mkErrorName :: Text -> Maybe ErrorName-mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName--newtype MemberName = MemberName {strMemberName :: Text}                 deriving (Eq, Ord);                         instance Show MemberName where                 { showsPrec d (MemberName x) = showParen (d > 10) $                         showString "MemberName " . shows x                 };                         instance String.IsString MemberName where                 { fromString = mkMemberName_ . TL.pack };                         instance Variable MemberName where                 { toVariant = toVariant . strMemberName                 ; fromVariant = (mkMemberName =<<) . fromVariant };                                                                         mkMemberName_ :: Text -> MemberName;         mkMemberName_ = mkUnsafe "member name" mkMemberName--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)-
hs/DBus/UUID.hs view
@@ -1,50 +1,55 @@-{--  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/>.--} +#line 22 "src/util.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 23 "src/util.anansi" module DBus.UUID-        ( UUID-        , toHex-        , fromHex-        ) where+	( UUID+	, toHex+	, fromHex+	) where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 29 "src/util.anansi"  newtype UUID = UUID Text -- TODO: (Word64, Word64)?-        deriving (Eq)+	deriving (Eq)  instance Show UUID where-        showsPrec d uuid = showParen (d > 10) $-                showString "UUID " . shows (toHex uuid)+	showsPrec d uuid = showParen (d > 10) $+		showString "UUID " . shows (toHex uuid)  toHex :: UUID -> Text toHex (UUID text) = text  fromHex :: Text -> Maybe UUID fromHex text = if validUUID text-        then Just $ UUID text-        else Nothing+	then Just $ UUID text+	else Nothing  validUUID :: Text -> Bool validUUID text = valid where-        valid = and [TL.length text == 32, TL.all validChar text]-        validChar c = or-                [ c >= '0' && c <= '9'-                , c >= 'a' && c <= 'f'-                , c >= 'A' && c <= 'F'-                ]-+	valid = and [TL.length text == 32, TL.all validChar text]+	validChar c = or+		[ c >= '0' && c <= '9'+		, c >= 'a' && c <= 'f'+		, c >= 'A' && c <= 'F'+		]
hs/DBus/Util.hs view
@@ -1,20 +1,23 @@-{--  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/>.--} +#line 58 "src/util.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 59 "src/util.anansi" module DBus.Util where import Text.Parsec (Parsec, parse) import Data.Char (digitToInt)@@ -29,8 +32,8 @@  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+	Just x' -> x'+	Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x  hexToInt :: String -> Int hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt@@ -53,14 +56,13 @@ -- readUntil :: (Monad m, Eq a) => [a] -> m a -> m [a] readUntil guard getx = readUntil' [] where-        guard' = reverse guard-        step xs | isPrefixOf guard' xs = return . reverse $ xs-                | otherwise            = readUntil' xs-        readUntil' xs = do-                x <- getx-                step $ x:xs+	guard' = reverse guard+	step xs | isPrefixOf guard' xs = return . reverse $ xs+	        | otherwise            = readUntil' xs+	readUntil' xs = do+		x <- getx+		step $ x:xs  -- | Drop /n/ items from the end of a list dropEnd :: Int -> [a] -> [a] dropEnd n xs = take (length xs - n) xs-
hs/DBus/Util/MonadError.hs view
@@ -1,57 +1,58 @@-{--  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/>.--} +#line 117 "src/util.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 118 "src/util.anansi" {-# LANGUAGE TypeFamilies #-}-module DBus.Util.MonadError where+module DBus.Util.MonadError+	( ErrorT (..)+	, throwError+	) where import Control.Monad.Trans.Class import Control.Monad.State+import Control.Monad.Error.Class  newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }  instance Functor m => Functor (ErrorT e m) where-        fmap f = ErrorT . fmap (fmap f) . runErrorT+	fmap f = ErrorT . fmap (fmap f) . runErrorT  instance Monad m => Monad (ErrorT e m) where-        return = ErrorT . return . Right-        (>>=) m k = ErrorT $ do-                x <- runErrorT m-                case x of-                        Left l -> return $ Left l-                        Right r -> runErrorT $ k r+	return = ErrorT . return . Right+	(>>=) m k = ErrorT $ do+		x <- runErrorT m+		case x of+			Left l -> return $ Left l+			Right r -> runErrorT $ k r  instance MonadTrans (ErrorT e) where-        lift = ErrorT . liftM Right--class Monad m => MonadError m where-        type ErrorType m-        throwError :: ErrorType m -> m a-        catchError :: m a -> (ErrorType m -> m a) -> m a+	lift = ErrorT . liftM Right  instance Monad m => MonadError (ErrorT e m) where-        type ErrorType (ErrorT e m) = e-        throwError = ErrorT . return . Left-        catchError m h = ErrorT $ do-                x <- runErrorT m-                case x of-                        Left l -> runErrorT $ h l-                        Right r -> return $ Right r+	type ErrorType (ErrorT e m) = e+	throwError = ErrorT . return . Left+	catchError m h = ErrorT $ do+		x <- runErrorT m+		case x of+			Left l -> runErrorT $ h l+			Right r -> return $ Right r  instance MonadState m => MonadState (ErrorT e m) where-        type StateType (ErrorT e m) = StateType m-        get = lift get-        put = lift . put-+	type StateType (ErrorT e m) = StateType m+	get = lift get+	put = lift . put
hs/DBus/Wire.hs view
@@ -1,31 +1,42 @@-{--  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/>.--} -module DBus.Wire (  Endianness (..)+#line 21 "src/wire.anansi" -                  , MarshalError (..)+#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>. -                  , UnmarshalError (..)+#line 22 "src/wire.anansi"+module DBus.Wire ( -                  , marshalMessage+#line 54 "src/wire.anansi"+	  Endianness (..) -                  , unmarshalMessage-) where+#line 207 "src/wire.anansi"+	, MarshalError (..)++#line 379 "src/wire.anansi"+	, UnmarshalError (..)++#line 850 "src/wire.anansi"+	, marshalMessage++#line 919 "src/wire.anansi"+	, unmarshalMessage++#line 24 "src/wire.anansi"+	) where import DBus.Wire.Internal import DBus.Wire.Marshal import DBus.Wire.Unmarshal-
hs/DBus/Wire/Internal.hs view
@@ -1,26 +1,30 @@-{--  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/>.--} +#line 31 "src/wire.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 32 "src/wire.anansi" module DBus.Wire.Internal where import Data.Word (Word8, Word64) import qualified DBus.Types as T +#line 40 "src/wire.anansi" data Endianness = LittleEndian | BigEndian-        deriving (Show, Eq)+	deriving (Show, Eq)  encodeEndianness :: Endianness -> Word8 encodeEndianness LittleEndian = 108@@ -31,7 +35,10 @@ decodeEndianness 66  = Just BigEndian decodeEndianness _   = Nothing +#line 69 "src/wire.anansi" alignment :: T.Type -> Word8++#line 388 "src/wire.anansi" alignment T.DBusByte    = 1 alignment T.DBusWord16  = 2 alignment T.DBusWord32  = 4@@ -41,27 +48,34 @@ alignment T.DBusInt64   = 8 alignment T.DBusDouble  = 8 +#line 472 "src/wire.anansi" alignment T.DBusBoolean = 4 +#line 553 "src/wire.anansi" alignment T.DBusString     = 4 alignment T.DBusObjectPath = 4 +#line 599 "src/wire.anansi" alignment T.DBusSignature  = 1 +#line 615 "src/wire.anansi" alignment (T.DBusArray _) = 4 +#line 697 "src/wire.anansi" alignment (T.DBusDictionary _ _) = 4 +#line 714 "src/wire.anansi" alignment (T.DBusStructure _) = 8 +#line 733 "src/wire.anansi" alignment T.DBusVariant = 1 +#line 71 "src/wire.anansi"  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-+	count' = fromIntegral count+	missing = mod current count'+	required = if missing > 0+		then count' - missing+		else 0
hs/DBus/Wire/Marshal.hs view
@@ -1,44 +1,59 @@-{--  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/>.--} +#line 89 "src/wire.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 90 "src/wire.anansi" {-# LANGUAGE TypeFamilies #-} module DBus.Wire.Marshal where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 93 "src/wire.anansi"++#line 104 "src/wire.anansi" import qualified Control.Monad.State as State import qualified DBus.Util.MonadError as E import qualified Data.ByteString.Lazy as L import qualified Data.Binary.Builder as B +#line 443 "src/wire.anansi" import Data.Binary.Put (runPut) import qualified Data.Binary.IEEE754 as IEEE +#line 523 "src/wire.anansi" import DBus.Wire.Unicode (maybeEncodeUtf8) +#line 575 "src/wire.anansi" import Data.Text.Lazy.Encoding (encodeUtf8) +#line 631 "src/wire.anansi" import qualified DBus.Constants as C +#line 759 "src/wire.anansi" import qualified DBus.Message.Internal as M +#line 774 "src/wire.anansi" import Data.Bits ((.|.)) import qualified Data.Set as Set +#line 94 "src/wire.anansi" import DBus.Wire.Internal import Control.Monad (when) import Data.Maybe (fromJust)@@ -47,162 +62,186 @@  import qualified DBus.Types as T +#line 111 "src/wire.anansi" data MarshalState = MarshalState Endianness B.Builder !Word64 type MarshalM = E.ErrorT MarshalError (State.State MarshalState) type Marshal = MarshalM () +#line 120 "src/wire.anansi" runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString runMarshal m e = case State.runState (E.runErrorT m) initialState of-        (Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder)-        (Left  x, _) -> Left x-        where initialState = MarshalState e B.empty 0+	(Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder)+	(Left  x, _) -> Left x+	where initialState = MarshalState e B.empty 0 +#line 128 "src/wire.anansi" 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-        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)+	x :: T.Variable a => a+	x = fromJust . T.fromVariant $ v+	marshalType :: T.Type -> Marshal -        marshalType T.DBusDouble = do-                pad 8-                (MarshalState e _ _) <- State.get-                let put = case e of-                        BigEndian -> IEEE.putFloat64be-                        LittleEndian -> IEEE.putFloat64le-                let bytes = runPut $ put x-                append bytes+#line 412 "src/wire.anansi"+	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) -        marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0+#line 452 "src/wire.anansi"+	marshalType T.DBusDouble = do+		pad 8+		(MarshalState e _ _) <- State.get+		let put = case e of+			BigEndian -> IEEE.putFloat64be+			LittleEndian -> IEEE.putFloat64le+		let bytes = runPut $ put x+		append bytes -        marshalType T.DBusString = marshalText x-        marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x+#line 476 "src/wire.anansi"+	marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0 -        marshalType T.DBusSignature = marshalSignature x+#line 558 "src/wire.anansi"+	marshalType T.DBusString = marshalText x+	marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x -        marshalType (T.DBusArray _) = marshalArray x+#line 603 "src/wire.anansi"+	marshalType T.DBusSignature = marshalSignature x -        marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x)+#line 619 "src/wire.anansi"+	marshalType (T.DBusArray _) = marshalArray x -        marshalType (T.DBusStructure _) = do-                let T.Structure vs = x-                pad 8-                mapM_ marshal vs+#line 701 "src/wire.anansi"+	marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x) -        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+#line 718 "src/wire.anansi"+	marshalType (T.DBusStructure _) = do+		let T.Structure vs = x+		pad 8+		mapM_ marshal vs +#line 737 "src/wire.anansi"+	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 +#line 139 "src/wire.anansi" append :: L.ByteString -> Marshal append bytes = do-        (MarshalState e builder count) <- State.get-        let builder' = B.append builder $ B.fromLazyByteString bytes-            count' = count + fromIntegral (L.length bytes)-        State.put $ MarshalState e builder' count'+	(MarshalState e builder count) <- State.get+	let builder' = B.append builder $ B.fromLazyByteString bytes+	    count' = count + fromIntegral (L.length bytes)+	State.put $ MarshalState e builder' count' +#line 148 "src/wire.anansi" pad :: Word8 -> Marshal pad count = do-        (MarshalState _ _ existing) <- State.get-        let padding' = fromIntegral $ padding existing count-        append $ L.replicate padding' 0+	(MarshalState _ _ existing) <- State.get+	let padding' = fromIntegral $ padding existing count+	append $ L.replicate padding' 0 +#line 159 "src/wire.anansi" marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal marshalBuilder size be le x = do-        pad size-        (MarshalState e builder count) <- State.get-        let builder' = B.append builder $ case e of-                BigEndian -> be x-                LittleEndian -> le x-        let count' = count + fromIntegral size-        State.put $ MarshalState e builder' count'+	pad size+	(MarshalState e builder count) <- State.get+	let builder' = B.append builder $ case e of+		BigEndian -> be x+		LittleEndian -> le x+	let count' = count + fromIntegral size+	State.put $ MarshalState e builder' count' +#line 185 "src/wire.anansi" data MarshalError-        = MessageTooLong Word64-        | ArrayTooLong Word64-        | InvalidBodySignature Text-        | InvalidVariantSignature Text-        | InvalidText Text-        deriving (Eq)+	= 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]+	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] +#line 402 "src/wire.anansi" marshalWord32 :: Word32 -> Marshal marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le +#line 527 "src/wire.anansi" 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)+	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) +#line 579 "src/wire.anansi" 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)+	let bytes = encodeUtf8 . T.strSignature $ x+	let size = fromIntegral . L.length $ bytes+	append (L.singleton size)+	append bytes+	append (L.singleton 0) +#line 635 "src/wire.anansi" 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+	(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 +#line 647 "src/wire.anansi" getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString) getArrayBytes T.DBusByte x = return (0, bytes) where-        Just bytes = T.arrayToBytes x+	Just bytes = T.arrayToBytes x +#line 653 "src/wire.anansi" getArrayBytes itemType x = do-        let vs = T.arrayItems x-        s <- State.get-        (MarshalState _ _ afterLength) <- marshalWord32 0 >> State.get-        (MarshalState e _ afterPadding) <- pad (alignment itemType) >> State.get-        -        State.put $ MarshalState e B.empty afterPadding-        (MarshalState _ itemBuilder _) <- mapM_ marshal vs >> State.get-        -        let itemBytes = B.toLazyByteString itemBuilder-            paddingSize = fromIntegral $ afterPadding - afterLength-        -        State.put s-        return (paddingSize, itemBytes)+	let vs = T.arrayItems x+	s <- State.get+	(MarshalState _ _ afterLength) <- marshalWord32 0 >> State.get+	(MarshalState e _ afterPadding) <- pad (alignment itemType) >> State.get+	+	State.put $ MarshalState e B.empty afterPadding+	(MarshalState _ itemBuilder _) <- mapM_ marshal vs >> State.get+	+	let itemBytes = B.toLazyByteString itemBuilder+	    paddingSize = fromIntegral $ afterPadding - afterLength+	+	State.put s+	return (paddingSize, itemBytes) +#line 779 "src/wire.anansi" encodeFlags :: Set.Set M.Flag -> Word8 encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where-        flagValue M.NoReplyExpected = 0x1-        flagValue M.NoAutoStart     = 0x2+	flagValue M.NoReplyExpected = 0x1+	flagValue M.NoAutoStart     = 0x2 +#line 797 "src/wire.anansi" encodeField :: M.HeaderField -> T.Structure encodeField (M.Path x)        = encodeField' 1 x encodeField (M.Interface x)   = encodeField' 2 x@@ -215,59 +254,66 @@  encodeField' :: T.Variable a => Word8 -> a -> T.Structure encodeField' code x = T.Structure-        [ T.toVariant code-        , T.toVariant $ T.toVariant x-        ]+	[ T.toVariant code+	, T.toVariant $ T.toVariant x+	] +#line 854 "src/wire.anansi"++#line 163 "src/api-docs.anansi" -- | Convert a 'M.Message' into a 'L.ByteString'. Although unusual, it is -- possible for marshaling to fail -- if this occurs, an appropriate error -- will be returned instead. +#line 855 "src/wire.anansi" 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 <- State.get-                mapM_ marshal body-                (MarshalState _ bodyBytesB _) <- State.get-                State.put empty-                marshalEndianness e-                let bodyBytes = B.toLazyByteString bodyBytesB-                marshalHeader msg serial sig-                        $ fromIntegral . L.length $ bodyBytes-                pad 8-                append bodyBytes-                checkMaximumSize+	body = M.messageBody msg+	marshaler = do+		sig <- checkBodySig body+		empty <- State.get+		mapM_ marshal body+		(MarshalState _ bodyBytesB _) <- State.get+		State.put empty+		marshalEndianness e+		let bodyBytes = B.toLazyByteString bodyBytesB+		marshalHeader msg serial sig+			$ fromIntegral . L.length $ bodyBytes+		pad 8+		append bodyBytes+		checkMaximumSize +#line 875 "src/wire.anansi" 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+	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 +#line 885 "src/wire.anansi" 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+	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 +#line 900 "src/wire.anansi" marshalEndianness :: Endianness -> Marshal marshalEndianness = marshal . T.toVariant . encodeEndianness +#line 905 "src/wire.anansi" checkMaximumSize :: Marshal checkMaximumSize = do-        (MarshalState _ _ messageLength) <- State.get-        when (messageLength > fromIntegral C.messageMaximumLength)-                (E.throwError $ MessageTooLong $ fromIntegral messageLength)-+	(MarshalState _ _ messageLength) <- State.get+	when (messageLength > fromIntegral C.messageMaximumLength)+		(E.throwError $ MessageTooLong $ fromIntegral messageLength)
hs/DBus/Wire/Unicode.hs view
@@ -1,23 +1,26 @@-{--  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/>.--} +#line 498 "src/wire.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 499 "src/wire.anansi" module DBus.Wire.Unicode-        ( maybeEncodeUtf8-        , maybeDecodeUtf8) where+	( maybeEncodeUtf8+	, maybeDecodeUtf8) where import Data.ByteString.Lazy (ByteString) import Data.Text.Lazy (Text) import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)@@ -36,4 +39,3 @@  maybeDecodeUtf8 :: ByteString -> Maybe Text maybeDecodeUtf8 = excToMaybe . decodeUtf8-
hs/DBus/Wire/Unmarshal.hs view
@@ -1,45 +1,63 @@-{--  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/>.--} +#line 215 "src/wire.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 216 "src/wire.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} +#line 217 "src/wire.anansi" {-# LANGUAGE TypeFamilies #-} module DBus.Wire.Unmarshal where++#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 220 "src/wire.anansi"++#line 231 "src/wire.anansi" import qualified Control.Monad.State as State import Control.Monad.Trans.Class (lift) import qualified DBus.Util.MonadError as E import qualified Data.ByteString.Lazy as L +#line 302 "src/wire.anansi" import qualified Data.Binary.Get as G +#line 448 "src/wire.anansi" import qualified Data.Binary.IEEE754 as IEEE +#line 540 "src/wire.anansi" import DBus.Wire.Unicode (maybeDecodeUtf8) +#line 763 "src/wire.anansi" import qualified DBus.Message.Internal as M +#line 769 "src/wire.anansi" import Data.Bits ((.&.)) import qualified Data.Set as Set +#line 915 "src/wire.anansi" import qualified DBus.Constants as C +#line 221 "src/wire.anansi" import Control.Monad (when, unless, liftM) import Data.Maybe (fromJust, listToMaybe, fromMaybe) import Data.Word (Word8, Word32, Word64)@@ -48,337 +66,392 @@ import DBus.Wire.Internal import qualified DBus.Types as T +#line 238 "src/wire.anansi" data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64 type Unmarshal = E.ErrorT UnmarshalError (State.State UnmarshalState) +#line 243 "src/wire.anansi" runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a runUnmarshal m e bytes = State.evalState (E.runErrorT m) state where-        state = UnmarshalState e bytes 0+	state = UnmarshalState e bytes 0 +#line 249 "src/wire.anansi" unmarshal :: T.Signature -> Unmarshal [T.Variant] unmarshal = mapM unmarshalType . T.signatureTypes  unmarshalType :: T.Type -> Unmarshal T.Variant++#line 422 "src/wire.anansi" 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)+	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)+	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)+	x <- unmarshalGet 8 G.getWord64be G.getWord64le+	return . T.toVariant $ (fromIntegral x :: Int64) +#line 463 "src/wire.anansi" unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le +#line 480 "src/wire.anansi" unmarshalType T.DBusBoolean = unmarshalWord32 >>=-        fromMaybeU' "boolean" (\x -> case x of-                0 -> Just False-                1 -> Just True-                _ -> Nothing)+	fromMaybeU' "boolean" (\x -> case x of+		0 -> Just False+		1 -> Just True+		_ -> Nothing) +#line 563 "src/wire.anansi" unmarshalType T.DBusString = fmap T.toVariant unmarshalText  unmarshalType T.DBusObjectPath = unmarshalText >>=-        fromMaybeU' "object path" T.mkObjectPath+	fromMaybeU' "object path" T.mkObjectPath +#line 607 "src/wire.anansi" unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature +#line 623 "src/wire.anansi" unmarshalType (T.DBusArray t) = T.toVariant `fmap` unmarshalArray t +#line 705 "src/wire.anansi" unmarshalType (T.DBusDictionary kt vt) = do-        let pairType = T.DBusStructure [kt, vt]-        array <- unmarshalArray pairType-        fromMaybeU' "dictionary" T.arrayToDictionary array+	let pairType = T.DBusStructure [kt, vt]+	array <- unmarshalArray pairType+	fromMaybeU' "dictionary" T.arrayToDictionary array +#line 725 "src/wire.anansi" unmarshalType (T.DBusStructure ts) = do-        skipPadding 8-        fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts+	skipPadding 8+	fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts +#line 747 "src/wire.anansi" 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-+	let getType sig = case T.signatureTypes sig of+		[t] -> Just t+		_   -> Nothing+	+	t <- fromMaybeU "variant signature" getType =<< unmarshalSignature+	T.toVariant `fmap` unmarshalType t +#line 259 "src/wire.anansi" consume :: Word64 -> Unmarshal L.ByteString consume count = do-        (UnmarshalState e bytes offset) <- State.get-        let (x, bytes') = L.splitAt (fromIntegral count) bytes-        unless (L.length x == fromIntegral count) $-                E.throwError $ UnexpectedEOF offset-        -        State.put $ UnmarshalState e bytes' (offset + count)-        return x+	(UnmarshalState e bytes offset) <- State.get+	let (x, bytes') = L.splitAt (fromIntegral count) bytes+	unless (L.length x == fromIntegral count) $+		E.throwError $ UnexpectedEOF offset+	+	State.put $ UnmarshalState e bytes' (offset + count)+	return x +#line 271 "src/wire.anansi" skipPadding :: Word8 -> Unmarshal () skipPadding count = do-        (UnmarshalState _ _ offset) <- State.get-        bytes <- consume $ padding offset count-        unless (L.all (== 0) bytes) $-                E.throwError $ InvalidPadding offset+	(UnmarshalState _ _ offset) <- State.get+	bytes <- consume $ padding offset count+	unless (L.all (== 0) bytes) $+		E.throwError $ InvalidPadding offset +#line 280 "src/wire.anansi" skipTerminator :: Unmarshal () skipTerminator = do-        (UnmarshalState _ _ offset) <- State.get-        bytes <- consume 1-        unless (L.all (== 0) bytes) $-                E.throwError $ MissingTerminator offset+	(UnmarshalState _ _ offset) <- State.get+	bytes <- consume 1+	unless (L.all (== 0) bytes) $+		E.throwError $ MissingTerminator offset +#line 289 "src/wire.anansi" 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+	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'+	x' <- fromMaybeU label f x+	return $ T.toVariant x' +#line 306 "src/wire.anansi" unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a unmarshalGet count be le = do-        skipPadding count-        (UnmarshalState e _ _) <- State.get-        bs <- consume . fromIntegral $ count-        let get' = case e of-                BigEndian -> be-                LittleEndian -> le-        return $ G.runGet get' bs+	skipPadding count+	(UnmarshalState e _ _) <- State.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 +#line 322 "src/wire.anansi" 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+	done <- test+	if done+		then return []+		else do+			x <- comp+			xs <- untilM test comp+			return $ x:xs +#line 349 "src/wire.anansi" data UnmarshalError-        = UnsupportedProtocolVersion Word8-        | UnexpectedEOF Word64-        | Invalid Text Text-        | MissingHeaderField Text-        | InvalidHeaderField Text T.Variant-        | InvalidPadding Word64-        | MissingTerminator Word64-        | ArraySizeMismatch-        deriving (Eq)+	= 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"+	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" +#line 407 "src/wire.anansi" unmarshalWord32 :: Unmarshal Word32 unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le +#line 544 "src/wire.anansi" unmarshalText :: Unmarshal Text unmarshalText = do-        byteCount <- unmarshalWord32-        bytes <- consume . fromIntegral $ byteCount-        skipTerminator-        fromMaybeU "text" maybeDecodeUtf8 bytes+	byteCount <- unmarshalWord32+	bytes <- consume . fromIntegral $ byteCount+	skipTerminator+	fromMaybeU "text" maybeDecodeUtf8 bytes +#line 589 "src/wire.anansi" 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+	byteCount <- L.head `fmap` consume 1+	bytes <- consume $ fromIntegral byteCount+	sigText <- fromMaybeU "text" maybeDecodeUtf8 bytes+	skipTerminator+	fromMaybeU "signature" T.mkSignature sigText +#line 672 "src/wire.anansi" unmarshalArray :: T.Type -> Unmarshal T.Array unmarshalArray T.DBusByte = do-        byteCount <- unmarshalWord32-        T.arrayFromBytes `fmap` consume (fromIntegral byteCount)+	byteCount <- unmarshalWord32+	T.arrayFromBytes `fmap` consume (fromIntegral byteCount) +#line 679 "src/wire.anansi" unmarshalArray itemType = do-        let getOffset = do-                (UnmarshalState _ _ o) <- State.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+	let getOffset = do+		(UnmarshalState _ _ o) <- State.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 +#line 786 "src/wire.anansi" 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]+	flagSet = [ (0x1, M.NoReplyExpected)+	          , (0x2, M.NoAutoStart)+	          ]+	flags = flagSet >>= \(x, y) -> [y | word .&. x > 0] +#line 815 "src/wire.anansi" 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 []+	(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+	Just x' -> return [f x']+	Nothing -> E.throwError $ InvalidHeaderField label x +#line 836 "src/wire.anansi" 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+	T.Structure [c, v] = struct+	c' = fromJust . T.fromVariant $ c+	v' = fromJust . T.fromVariant $ v +#line 923 "src/wire.anansi"++#line 169 "src/api-docs.anansi" -- | Read bytes from a monad until a complete message has been received. +#line 924 "src/wire.anansi" unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)                  -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do-        let getBytes = lift . getBytes'-        -        let fixedSig = "yyyyuuu"-        fixedBytes <- getBytes 16+	let getBytes = lift . getBytes'+	 -        let messageVersion = L.index fixedBytes 3-        when (messageVersion /= C.protocolVersion) $-                E.throwError $ UnsupportedProtocolVersion messageVersion+#line 939 "src/wire.anansi"+	let fixedSig = "yyyyuuu"+	fixedBytes <- getBytes 16 -        let eByte = L.index fixedBytes 0-        endianness <- case decodeEndianness eByte of-                Just x' -> return x'-                Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte+#line 948 "src/wire.anansi"+	let messageVersion = L.index fixedBytes 3+	when (messageVersion /= C.protocolVersion) $+		E.throwError $ UnsupportedProtocolVersion messageVersion -        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+#line 956 "src/wire.anansi"+	let eByte = L.index fixedBytes 0+	endianness <- case decodeEndianness eByte of+		Just x' -> return x'+		Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte -        let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6+#line 966 "src/wire.anansi"+	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 -        let headerSig  = "yyyyuua(yv)"-        fieldBytes <- getBytes fieldByteCount-        let headerBytes = L.append fixedBytes fieldBytes-        header <- unmarshal' headerSig headerBytes+#line 981 "src/wire.anansi"+	let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6 -        let fieldArray = fromJust . T.fromVariant $ header !! 6-        let fieldStructures = fromJust . T.fromArray $ fieldArray-        fields <- concat `liftM` mapM decodeField fieldStructures+#line 930 "src/wire.anansi" -        let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8-        getBytes . fromIntegral $ bodyPadding+#line 988 "src/wire.anansi"+	let headerSig  = "yyyyuua(yv)"+	fieldBytes <- getBytes fieldByteCount+	let headerBytes = L.append fixedBytes fieldBytes+	header <- unmarshal' headerSig headerBytes -        let bodySig = findBodySignature fields+#line 997 "src/wire.anansi"+	let fieldArray = fromJust . T.fromVariant $ header !! 6+	let fieldStructures = fromJust . T.fromArray $ fieldArray+	fields <- concat `liftM` mapM decodeField fieldStructures -        bodyBytes <- getBytes bodyLength-        body <- unmarshal' bodySig bodyBytes+#line 931 "src/wire.anansi" -        y <- case buildReceivedMessage typeCode fields of-                EitherM (Right x) -> return x-                EitherM (Left x) -> E.throwError $ MissingHeaderField x+#line 1006 "src/wire.anansi"+	let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8+	getBytes . fromIntegral $ bodyPadding -        return $ y serial flags body+#line 1017 "src/wire.anansi"+	let bodySig = findBodySignature fields +#line 1023 "src/wire.anansi"+	bodyBytes <- getBytes bodyLength+	body <- unmarshal' bodySig bodyBytes +#line 932 "src/wire.anansi"++#line 1043 "src/wire.anansi"+	y <- case buildReceivedMessage typeCode fields of+		EitherM (Right x) -> return x+		EitherM (Left x) -> E.throwError $ MissingHeaderField x+	return $ y serial flags body++#line 1011 "src/wire.anansi" findBodySignature :: [M.HeaderField] -> T.Signature findBodySignature fields = fromMaybe "" signature where-        signature = listToMaybe [x | M.Signature x <- fields]+	signature = listToMaybe [x | M.Signature x <- fields] +#line 1034 "src/wire.anansi" newtype EitherM a b = EitherM (Either a b)  instance Monad (EitherM a) where-        return = EitherM . Right-        (EitherM (Left x)) >>= _ = EitherM (Left x)-        (EitherM (Right x)) >>= k = k x+	return = EitherM . Right+	(EitherM (Left x)) >>= _ = EitherM (Left x)+	(EitherM (Right x)) >>= k = k x +#line 1052 "src/wire.anansi" buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text                         (M.Serial -> (Set.Set M.Flag) -> [T.Variant]                          -> M.ReceivedMessage) +#line 1060 "src/wire.anansi" 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+	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 +#line 1074 "src/wire.anansi" 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+	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 +#line 1086 "src/wire.anansi" 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+	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 +#line 1099 "src/wire.anansi" 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+	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 +#line 1113 "src/wire.anansi" 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+	sender = listToMaybe [x | M.Sender x <- fields]+	msg = M.Unknown typeCode flags body+	in M.ReceivedUnknown serial sender msg +#line 1120 "src/wire.anansi" require :: Text -> [a] -> EitherM Text a require _     (x:_) = return x require label _     = EitherM $ Left label-
hs/Tests.hs view
@@ -1,25 +1,32 @@-{--  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/>.--} +#line 64 "src/introduction.anansi"++#line 30 "src/introduction.anansi"+-- Copyright (C) 2009-2010 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/>.++#line 65 "src/introduction.anansi"++#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-}-module Main (tests) where +#line 66 "src/introduction.anansi"+module Main (tests, main) where++#line 163 "src/util.anansi" import Test.QuickCheck-import Test.Framework (Test, testGroup) import qualified Test.Framework as F import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -27,6 +34,7 @@ import Control.Monad (replicateM) import qualified Data.Binary.Get as G import Data.Char (isPrint)+import Data.String import Data.List (intercalate, isInfixOf) import Data.Maybe (fromJust, isJust, isNothing) import qualified Data.Map as Map@@ -44,570 +52,541 @@ import DBus.Wire.Unmarshal import qualified DBus.Introspection as I -tests :: [Test]-tests = [  testGroup "Types"-                 [ testGroup "Atomic types"-                         [-                            testGroup "Bool" $ commonVariantTests (arbitrary :: Gen Bool)-                          , testGroup "Word8"   $ commonVariantTests (arbitrary :: Gen Word8)-                          , testGroup "Word16"  $ commonVariantTests (arbitrary :: Gen Word16)-                          , testGroup "Word32"  $ commonVariantTests (arbitrary :: Gen Word32)-                          , testGroup "Word64"  $ commonVariantTests (arbitrary :: Gen Word64)-                          , testGroup "Int16"   $ commonVariantTests (arbitrary :: Gen Int16)-                          , testGroup "Int32"   $ commonVariantTests (arbitrary :: Gen Int32)-                          , testGroup "Int64"   $ commonVariantTests (arbitrary :: Gen Int64)-                          , testGroup "Double"  $ commonVariantTests (arbitrary :: Gen Double)-                          , testGroup "String"  $ commonVariantTests (arbitrary :: Gen String) ++-                                  [ testProperty "String -> strict Text"-                                          $ \x -> (fromVariant . toVariant) x == (Just $ T.pack x)-                                  , testProperty "String <- strict Text"-                                          $ \x -> (fromVariant . toVariant) x == (Just $ T.unpack x)-                                  , testProperty "String -> lazy Text"-                                          $ \x -> (fromVariant . toVariant) x == (Just $ TL.pack x)-                                  , testProperty "String <- lazy Text"-                                          $ \x -> (fromVariant . toVariant) x == (Just $ TL.unpack x)-                                  , testProperty "Strict Text -> lazy Text"-                                          $ \x -> (fromVariant . toVariant) x == (Just $ TL.pack . T.unpack $ x)-                                  , testProperty "Strict Text <- lazy Text"-                                          $ \x -> (fromVariant . toVariant) x == (Just $ T.pack . TL.unpack $ x)-                                  ]--                          , testGroup "Signature" $ commonVariantTests (arbitrary :: Gen Signature) ++-                                  [ testProperty "Signature identity"-                                          $ \x -> (mkSignature . strSignature) x == Just x-                                  , testProperty "Signature show"-                                          $ \x -> show (strSignature x) `isInfixOf` show x-                                  ]+#line 68 "src/introduction.anansi" -                          , testGroup "ObjectPath" $ commonVariantTests (arbitrary :: Gen ObjectPath) ++-                                  [ testProperty "ObjectPath identity"-                                          $ \x -> (mkObjectPath . strObjectPath) x == Just x-                                  ]+tests :: [F.Test]+tests = [ F.testGroup "dummy" [] -                          , testGroup "BusName" $ commonVariantTests (arbitrary :: Gen BusName) ++-                                  [ testProperty "BusName identity"-                                          $ \x -> (mkBusName . strBusName) x == Just x-                                  ]+#line 370 "src/types.anansi"+	, F.testGroup "String"+		[ testProperty "String -> strict Text"+			$ funEq (fromVariant . toVariant) (Just . T.pack)+		, testProperty "String <- strict Text"+			$ funEq (fromVariant . toVariant) (Just . T.unpack)+		, testProperty "String -> lazy Text"+			$ funEq (fromVariant . toVariant) (Just . TL.pack)+		, testProperty "String <- lazy Text"+			$ funEq (fromVariant . toVariant) (Just . TL.unpack)+		, testProperty "Strict Text -> lazy Text"+			$ funEq (fromVariant . toVariant) (Just . TL.pack . T.unpack)+		, testProperty "Strict Text <- lazy Text"+			$ funEq (fromVariant . toVariant) (Just . T.pack . TL.unpack)+		] -                          , testGroup "InterfaceName" $ commonVariantTests (arbitrary :: Gen InterfaceName) ++-                                  [ testProperty "InterfaceName identity"-                                          $ \x -> (mkInterfaceName . strInterfaceName) x == Just x-                                  ]+#line 611 "src/types.anansi"+	, F.testGroup "Signature"+		[ testProperty "Signature identity"+			$ funEq (mkSignature . strSignature) Just+		] -                          , testGroup "ErrorName" $ commonVariantTests (arbitrary :: Gen ErrorName) ++-                                  [ testProperty "ErrorName identity"-                                          $ \x -> (mkErrorName . strErrorName) x == Just x-                                  ]+#line 675 "src/types.anansi"+	, F.testGroup "ObjectPath"+		[ testProperty "ObjectPath identity"+			$ funEq (mkObjectPath . strObjectPath) Just+		] -                          , testGroup "MemberName" $ commonVariantTests (arbitrary :: Gen MemberName) ++-                                  [ testProperty "MemberName identity"-                                          $ \x -> (mkMemberName . strMemberName) x == Just x-                                  ]+#line 822 "src/types.anansi"+	, F.testGroup "Array"+		[ testProperty "Array identity"+			$ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x)+		, testProperty "Array homogeneity" prop_ArrayHomogeneous+		] -                         ]-                 , testGroup "Container types"-                         [-                            testGroup "Variant" $ commonVariantTests (arbitrary :: Gen Variant)+#line 950 "src/types.anansi"+	, F.testGroup "Dictionary"+		[ testProperty "Dictionary identity"+			$ \x -> Just x == dictionaryFromItems+				(dictionaryKeyType x)+				(dictionaryValueType x)+				(dictionaryItems x)+		, testProperty "Dictionary homogeneity" prop_DictionaryHomogeneous+		, testProperty "Dictionary must have atomic keys" +			$ \vt -> forAll containerType $ \kt ->+				isNothing (dictionaryFromItems kt vt [])+		, testProperty "Dictionary <-> Array conversion"+			$ funEq (arrayToDictionary . dictionaryToArray) Just+		] -                          , testGroup "Array" $ commonVariantTests (arbitrary :: Gen Array) ++-                                  [ testProperty "Array identity"-                                          $ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x)-                                  , testProperty "Array homogeneity" prop_ArrayHomogeneous-                                  ]+#line 1110 "src/types.anansi"+	, F.testGroup "BusName"+		[ testProperty "BusName identity"+			$ funEq (mkBusName . strBusName) Just+		] -                          , testGroup "Dictionary" $ commonVariantTests (arbitrary :: Gen Dictionary) ++-                                  [ testProperty "Dictionary identity"-                                          $ \x -> Just x == dictionaryFromItems-                                                  (dictionaryKeyType x)-                                                  (dictionaryValueType x)-                                                  (dictionaryItems x)-                                  , testProperty "Dictionary homogeneity" prop_DictionaryHomogeneous-                                  , testProperty "Dictionary must have atomic keys" -                                          $ \vt -> forAll containerType $ \kt ->-                                                  isNothing (dictionaryFromItems kt vt [])-                                  , testProperty "Dictionary <-> Array conversion"-                                          $ \x -> arrayToDictionary (dictionaryToArray x) == Just x-                                  ]+#line 1157 "src/types.anansi"+	, F.testGroup "InterfaceName"+		[ testProperty "InterfaceName identity"+			$ funEq (mkInterfaceName . strInterfaceName) Just+		] -                          , testGroup "Structure" $ commonVariantTests (arbitrary :: Gen Structure)+#line 1189 "src/types.anansi"+	, F.testGroup "ErrorName"+		[ testProperty "ErrorName identity"+			$ funEq (mkErrorName . strErrorName) Just+		] -                         ]-                 ]+#line 1232 "src/types.anansi"+	, F.testGroup "MemberName"+		[ testProperty "MemberName identity"+			$ funEq (mkMemberName . strMemberName) Just+		] -         , testGroup "Addresses"-                 [ testProperty "Address identity"-                         $ \x -> mkAddresses (strAddress x) == Just [x]-                 , testProperty "Multiple addresses"-                         $ \x y -> let-                         joined = TL.concat [strAddress x, ";", strAddress y]-                         in mkAddresses joined == Just [x, y]-                 , testProperty "Ignore trailing semicolon"-                         $ \x -> mkAddresses (TL.append (strAddress x) ";") == Just [x]-                 , testProperty "Ignore trailing comma"-                         $ \x -> let-                         hasParams = not . Map.null . addressParameters $ x-                         parsed = mkAddresses (TL.append (strAddress x) ",")-                         in hasParams ==> parsed == Just [x]-                 , testGroup "Valid addresses" $ singleTests-                         [ isJust . mkAddresses $ ":"-                         , isJust . mkAddresses $ "a:"-                         , isJust . mkAddresses $ "a:b=c"-                         , isJust . mkAddresses $ "a:;"-                         , isJust . mkAddresses $ "a:;b:"-                         , isJust . mkAddresses $ "a:b=c,"-                         ]-                 , testGroup "Invalid addresses" $ singleTests-                         [ isNothing . mkAddresses $ ""-                         , isNothing . mkAddresses $ "a"-                         , isNothing . mkAddresses $ "a:b"-                         , isNothing . mkAddresses $ "a:b="-                         , isNothing . mkAddresses $ "a:,"-                         ]-                 ]+#line 1161 "src/wire.anansi"+	, F.testGroup "Wire format"+		[ testProperty "Marshal -> Ummarshal" prop_Unmarshal+		, F.testGroup "Messages"+			[ testProperty "Method calls" prop_WireMethodCall+			, testProperty "Method returns" prop_WireMethodReturn+			, testProperty "Errors" prop_WireError+			, testProperty "Signals" prop_WireSignal+			]+		] -         , testGroup "Wire format"-                 [ testProperty "Marshal -> Ummarshal" prop_Unmarshal-                 , testGroup "Messages"-                         [ testProperty "Method calls" prop_WireMethodCall-                         , testProperty "Method returns" prop_WireMethodReturn-                         , testProperty "Errors" prop_WireError-                         , testProperty "Signals" prop_WireSignal-                         ]-                 ]+#line 177 "src/addresses.anansi"+	, F.testGroup "Addresses"+		[ testProperty "Address identity"+			$ \x -> mkAddresses (strAddress x) == Just [x]+		, testProperty "Multiple addresses"+			$ \x y -> let+			joined = TL.concat [strAddress x, ";", strAddress y]+			in mkAddresses joined == Just [x, y]+		, testProperty "Ignore trailing semicolon"+			$ \x -> mkAddresses (TL.append (strAddress x) ";") == Just [x]+		, testProperty "Ignore trailing comma"+			$ \x -> let+			hasParams = not . Map.null . addressParameters $ x+			parsed = mkAddresses (TL.append (strAddress x) ",")+			in hasParams ==> parsed == Just [x]+		, F.testGroup "Valid addresses"+			[ test "colon" $ isJust . mkAddresses $ ":"+			, test "just scheme" $ isJust . mkAddresses $ "a:"+			, test "param" $ isJust . mkAddresses $ "a:b=c"+			, test "trailing semicolon" $ isJust . mkAddresses $ "a:;"+			, test "two schemes" $ isJust . mkAddresses $ "a:;b:"+			, test "trailing comma" $ isJust . mkAddresses $ "a:b=c,"+			]+		, F.testGroup "Invalid addresses"+			[ test "empty" $ isNothing . mkAddresses $ ""+			, test "no colon" $ isNothing . mkAddresses $ "a"+			, test "no equals" $ isNothing . mkAddresses $ "a:b"+			, test "no param" $ isNothing . mkAddresses $ "a:b="+			, test "no param" $ isNothing . mkAddresses $ "a:,"+			]+		] -         , testGroup "Introspection"-                 [ testProperty "Generate -> Parse"-                         $ \x@(I.Object path _ _) -> let-                         xml = I.toXML x-                         Just xml' = xml-                         parsed = I.fromXML path xml'-                         in isJust xml ==> I.fromXML path xml' == Just x-                 ]+#line 472 "src/introspection.anansi"+	, F.testGroup "Introspection"+		[ testProperty "Generate -> Parse"+			$ \x@(I.Object path _ _) -> let+			xml = I.toXML x+			Just xml' = xml+			parsed = I.fromXML path xml'+			in isJust xml ==> I.fromXML path xml' == Just x+		] -        ]+#line 72 "src/introduction.anansi"+	]  main :: IO () main = F.defaultMain tests +#line 95 "src/types.anansi"+instance Arbitrary Type where+	arbitrary = oneof [atomicType, containerType]+ atomicType :: Gen Type atomicType = elements-        [ DBusBoolean-        , DBusByte-        , DBusWord16-        , DBusWord32-        , DBusWord64-        , DBusInt16-        , DBusInt32-        , DBusInt64-        , DBusDouble-        , DBusString-        , DBusObjectPath-        , DBusSignature-        ]+	[ DBusBoolean+	, DBusByte+	, DBusWord16+	, DBusWord32+	, DBusWord64+	, DBusInt16+	, DBusInt32+	, DBusInt64+	, DBusDouble+	, DBusString+	, DBusObjectPath+	, DBusSignature+	]  containerType :: Gen Type containerType = do-        c <- choose (0,3) :: Gen Int-        case c of-                0 -> fmap DBusArray arbitrary-                1 -> do-                        kt <- atomicType-                        vt <- arbitrary-                        return $ DBusDictionary kt vt-                2 -> fmap DBusStructure $ shrinkingGen arbitrary-                3 -> return DBusVariant--instance Arbitrary Type where-        arbitrary = oneof [atomicType, containerType]--instance Arbitrary Signature where-        arbitrary = clampedSize 255 genSig mkSignature_ where-                genSig = fmap (TL.concat . map typeCode) arbitrary--instance Arbitrary ObjectPath where-        arbitrary = fmap (mkObjectPath_ . TL.pack) path' where-                c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"-                path = fmap (intercalate "/" . ([] :)) genElements-                path' = frequency [(1, return "/"), (9, path)]-                genElements = sized' 1 (sized' 1 (elements c))--instance Arbitrary BusName where-        arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName_ where-                c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"-                c' = c ++ ['0'..'9']-                -                unique = do-                        elems' <- sized' 2 $ elems c'-                        return . TL.pack $ ':' : intercalate "." elems'-                -                wellKnown = do-                        elems' <- sized' 2 $ elems c-                        return . TL.pack $ intercalate "." elems'-                -                elems start = do-                        x <- elements start-                        xs <- sized' 0 (elements c')-                        return (x:xs)--instance Arbitrary InterfaceName where-        arbitrary = clampedSize 255 genName mkInterfaceName_ where-                c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"-                c' = c ++ ['0'..'9']-                -                genName = fmap (TL.pack . intercalate ".") genElements-                genElements = sized' 2 genElement-                genElement = do-                        x <- elements c-                        xs <- sized' 0 (elements c')-                        return (x:xs)--instance Arbitrary ErrorName where-        arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary--instance Arbitrary MemberName where-        arbitrary = clampedSize 255 genName mkMemberName_ where-                c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"-                c' = c ++ ['0'..'9']-                -                genName = do-                        x <- elements c-                        xs <- sized' 0 (elements c')-                        return . TL.pack $ (x:xs)--prop_VariantIdentity gen = testProperty "Variant identity" . forAll gen-        $ \x -> (fromVariant . toVariant) x == Just x--prop_VariantEquality gen = testProperty "Variant equality" . forAll gen-        $ \x y -> (x == y) == (toVariant x == toVariant y)+	c <- choose (0,3) :: Gen Int+	case c of+		0 -> fmap DBusArray arbitrary+		1 -> do+			kt <- atomicType+			vt <- arbitrary+			return $ DBusDictionary kt vt+		2 -> fmap DBusStructure $ halfSized arbitrary+		3 -> return DBusVariant -commonVariantTests gen =-        [ prop_VariantIdentity gen-        , prop_VariantEquality gen-        ]+#line 258 "src/types.anansi"+instance Arbitrary Variant where+	arbitrary = arbitrary >>= genVariant  genVariant :: Type -> Gen Variant-genVariant  DBusBoolean         = fmap toVariant (arbitrary :: Gen Bool)-genVariant  DBusByte            = fmap toVariant (arbitrary :: Gen Word8)-genVariant  DBusWord16          = fmap toVariant (arbitrary :: Gen Word16)-genVariant  DBusWord32          = fmap toVariant (arbitrary :: Gen Word32)-genVariant  DBusWord64          = fmap toVariant (arbitrary :: Gen Word64)-genVariant  DBusInt16           = fmap toVariant (arbitrary :: Gen Int16)-genVariant  DBusInt32           = fmap toVariant (arbitrary :: Gen Int32)-genVariant  DBusInt64           = fmap toVariant (arbitrary :: Gen Int64)-genVariant  DBusDouble          = fmap toVariant (arbitrary :: Gen Double)-genVariant  DBusString          = fmap toVariant (arbitrary :: Gen String)-genVariant  DBusObjectPath      = fmap toVariant (arbitrary :: Gen ObjectPath)-genVariant  DBusSignature       = fmap toVariant (arbitrary :: Gen Signature)-genVariant (DBusArray _)        = fmap toVariant (arbitrary :: Gen Array)-genVariant (DBusDictionary _ _) = fmap toVariant (arbitrary :: Gen Dictionary)-genVariant (DBusStructure _)    = fmap toVariant (arbitrary :: Gen Structure)-genVariant  DBusVariant         = fmap toVariant (arbitrary :: Gen Variant)+genVariant t = case t of+	DBusBoolean          -> fmap toVariant (arbitrary :: Gen Bool)+	DBusByte             -> fmap toVariant (arbitrary :: Gen Word8)+	DBusWord16           -> fmap toVariant (arbitrary :: Gen Word16)+	DBusWord32           -> fmap toVariant (arbitrary :: Gen Word32)+	DBusWord64           -> fmap toVariant (arbitrary :: Gen Word64)+	DBusInt16            -> fmap toVariant (arbitrary :: Gen Int16)+	DBusInt32            -> fmap toVariant (arbitrary :: Gen Int32)+	DBusInt64            -> fmap toVariant (arbitrary :: Gen Int64)+	DBusDouble           -> fmap toVariant (arbitrary :: Gen Double)+	DBusString           -> fmap toVariant (arbitrary :: Gen String)+	DBusObjectPath       -> fmap toVariant (arbitrary :: Gen ObjectPath)+	DBusSignature        -> fmap toVariant (arbitrary :: Gen Signature)+	(DBusArray _)        -> fmap toVariant (arbitrary :: Gen Array)+	(DBusDictionary _ _) -> fmap toVariant (arbitrary :: Gen Dictionary)+	(DBusStructure _)    -> fmap toVariant (arbitrary :: Gen Structure)+	DBusVariant          -> fmap toVariant (arbitrary :: Gen Variant) -instance Arbitrary Variant where-        arbitrary = arbitrary >>= genVariant+#line 606 "src/types.anansi"+instance Arbitrary Signature where+	arbitrary = sizedText 255 $ fmap (TL.concat . map typeCode) arbitrary -genAtom :: Type -> Gen Variant-genAtom DBusBoolean    = fmap toVariant (arbitrary :: Gen Bool)-genAtom DBusByte       = fmap toVariant (arbitrary :: Gen Word8)-genAtom DBusWord16     = fmap toVariant (arbitrary :: Gen Word16)-genAtom DBusWord32     = fmap toVariant (arbitrary :: Gen Word32)-genAtom DBusWord64     = fmap toVariant (arbitrary :: Gen Word64)-genAtom DBusInt16      = fmap toVariant (arbitrary :: Gen Int16)-genAtom DBusInt32      = fmap toVariant (arbitrary :: Gen Int32)-genAtom DBusInt64      = fmap toVariant (arbitrary :: Gen Int64)-genAtom DBusDouble     = fmap toVariant (arbitrary :: Gen Double)-genAtom DBusString     = fmap toVariant (arbitrary :: Gen String)-genAtom DBusObjectPath = fmap toVariant (arbitrary :: Gen ObjectPath)-genAtom DBusSignature  = fmap toVariant (arbitrary :: Gen Signature)+#line 666 "src/types.anansi"+instance Arbitrary ObjectPath where+	arbitrary = fmap (mkObjectPath_ . TL.pack) path' where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"+		path = fmap (intercalate "/" . ([] :)) genElements+		path' = frequency [(1, return "/"), (9, path)]+		genElements = atLeast 1 (atLeast 1 (elements c)) +#line 806 "src/types.anansi" instance Arbitrary Array where-        arbitrary = do-                -- Only generate arrays of atomic values, as generating-                -- containers randomly almost never results in a valid-                -- array.-                t <- atomicType-                xs <- listOf $ genVariant t-                return . fromJust $ arrayFromItems t xs+	arbitrary = do+		t <- atomicType+		xs <- listOf $ genVariant t+		return . fromJust $ arrayFromItems t xs  prop_ArrayHomogeneous vs = isJust array == homogeneousTypes where-        array = arrayFromItems firstType vs-        homogeneousTypes = all (== firstType) types-        types = map variantType vs-        firstType = if null types-                then DBusByte-                else head types+	array = arrayFromItems firstType vs+	homogeneousTypes = all (== firstType) types+	types = map variantType vs+	firstType = if null types+		then DBusByte+		else head types +#line 932 "src/types.anansi" instance Arbitrary Dictionary where-        arbitrary = do-                -- Only generate dictionaries of atomic values, as generating-                -- containers randomly almost never results in a valid-                -- dictionary.-                kt <- atomicType-                vt <- atomicType-                ks <- listOf $ genAtom kt-                vs <- vectorOf (length ks) $ genVariant vt-                -                return . fromJust $ dictionaryFromItems kt vt $ zip ks vs+	arbitrary = do+		kt <- atomicType+		vt <- atomicType+		ks <- listOf $ genVariant kt+		vs <- vectorOf (length ks) $ genVariant vt+		+		return . fromJust $ dictionaryFromItems kt vt $ zip ks vs  prop_DictionaryHomogeneous x = all correctType pairs where-        pairs = dictionaryItems x-        kType = dictionaryKeyType x-        vType = dictionaryValueType x-        correctType (k, v) = variantType k == kType &&-                             variantType v == vType+	pairs = dictionaryItems x+	kType = dictionaryKeyType x+	vType = dictionaryValueType x+	correctType (k, v) = variantType k == kType &&+	                     variantType v == vType +#line 1016 "src/types.anansi" instance Arbitrary Structure where-        arbitrary = sized $ \n ->-                fmap Structure $ shrinkingGen arbitrary+	arbitrary = fmap Structure $ halfSized arbitrary -singleTests :: Testable a => [a] -> [Test]-singleTests ts = singleTests' 1 ts where-        singleTests' _ []     = []-        singleTests' n (t:ts') = plusOptions (testProperty (name n) t)-                                 : singleTests' (n + 1) ts'-        -        total = length ts-        options = F.TestOptions Nothing (Just 1) Nothing Nothing-        plusOptions = F.plusTestOptions options-        name n = "Test " ++ show n ++ "/" ++ show total+#line 1090 "src/types.anansi"+instance Arbitrary BusName where+	arbitrary = sizedText 255 (oneof [unique, wellKnown]) where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"+		c' = c ++ ['0'..'9']+		+		unique = do+			elems' <- atLeast 2 $ elems c'+			return . TL.pack $ ':' : intercalate "." elems'+		+		wellKnown = do+			elems' <- atLeast 2 $ elems c+			return . TL.pack $ intercalate "." elems'+		+		elems start = do+			x <- elements start+			xs <- atLeast 0 (elements c')+			return (x:xs) -instance Arbitrary Address where-        arbitrary = genAddress where-                optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."-                methodChars = filter (flip notElem ":;") ['!'..'~']-                keyChars = filter (flip notElem "=;,") ['!'..'~']-                -                genMethod = sized' 0 $ elements methodChars-                genParam = do-                        key <- genKey-                        value <- genValue-                        return . concat $ [key, "=", value]-                -                genKey = sized' 1 $ elements keyChars-                genValue = oneof [encodedValue, plainValue]-                genHex = elements $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']-                encodedValue = do-                        x1 <- genHex-                        x2 <- genHex-                        return ['%', x1, x2]-                plainValue = sized' 1 $ elements optional-                -                genParams = do-                        params <- sized' 0 genParam-                        let params' = intercalate "," params-                        extraComma <- if null params-                                then return ""-                                else elements ["", ","]-                        return $ concat [params', extraComma]-                -                genAddress = do-                        m <- genMethod-                        params <- genParams-                        extraSemicolon <- elements ["", ";"]-                        let addrStr = concat [m, ":", params, extraSemicolon]-                        let Just [addr] = mkAddresses $ TL.pack addrStr-                        return addr+#line 1143 "src/types.anansi"+instance Arbitrary InterfaceName where+	arbitrary = sizedText 255 genName where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+		c' = c ++ ['0'..'9']+		+		genName = fmap (TL.pack . intercalate ".") genElements+		genElements = atLeast 2 genElement+		genElement = do+			x <- elements c+			xs <- atLeast 0 (elements c')+			return (x:xs) -instance Arbitrary Serial where-        arbitrary = fmap Serial arbitrary+#line 1184 "src/types.anansi"+instance Arbitrary ErrorName where+	arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary +#line 1220 "src/types.anansi"+instance Arbitrary MemberName where+	arbitrary = sizedText 255 genName where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+		c' = c ++ ['0'..'9']+		+		genName = do+			x <- elements c+			xs <- atLeast 0 (elements c')+			return . TL.pack $ (x:xs)++#line 73 "src/messages.anansi" instance Arbitrary Flag where-        arbitrary = elements [NoReplyExpected, NoAutoStart]+	arbitrary = elements [NoReplyExpected, NoAutoStart] +#line 131 "src/messages.anansi"+instance Arbitrary Serial where+	arbitrary = fmap Serial arbitrary++#line 173 "src/messages.anansi" instance Arbitrary MethodCall where-        arbitrary = do-                path   <- arbitrary-                member <- arbitrary-                iface  <- arbitrary-                dest   <- arbitrary-                flags  <- fmap Set.fromList arbitrary-                Structure body <- arbitrary-                return $ MethodCall path member iface dest flags body+	arbitrary = do+		path   <- arbitrary+		member <- arbitrary+		iface  <- arbitrary+		dest   <- arbitrary+		flags  <- fmap Set.fromList arbitrary+		Structure body <- arbitrary+		return $ MethodCall path member iface dest flags body +#line 210 "src/messages.anansi" instance Arbitrary MethodReturn where-        arbitrary = do-                serial <- arbitrary-                dest   <- arbitrary-                Structure body <- arbitrary-                return $ MethodReturn serial dest body+	arbitrary = do+		serial <- arbitrary+		dest   <- arbitrary+		Structure body <- arbitrary+		return $ MethodReturn serial dest body +#line 261 "src/messages.anansi" instance Arbitrary Error where-        arbitrary = do-                name   <- arbitrary-                serial <- arbitrary-                dest   <- arbitrary-                Structure body <- arbitrary-                return $ Error name serial dest body+	arbitrary = do+		name   <- arbitrary+		serial <- arbitrary+		dest   <- arbitrary+		Structure body <- arbitrary+		return $ Error name serial dest body +#line 300 "src/messages.anansi" instance Arbitrary Signal where-        arbitrary = do-                path   <- arbitrary-                member <- arbitrary-                iface  <- arbitrary-                dest   <- arbitrary-                Structure body <- arbitrary-                return $ Signal path member iface dest body+	arbitrary = do+		path   <- arbitrary+		member <- arbitrary+		iface  <- arbitrary+		dest   <- arbitrary+		Structure body <- arbitrary+		return $ Signal path member iface dest body -isRight :: Either a b -> Bool-isRight = either (const False) (const True)+#line 58 "src/wire.anansi"+instance Arbitrary Endianness where+	arbitrary = elements [LittleEndian, BigEndian] +#line 1126 "src/wire.anansi" prop_Unmarshal :: Endianness -> Variant -> Property prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where-        sig = mkSignature . typeCode . variantType $ x-        Just sig' = sig-        -        bytes = runMarshal (marshal x) e-        Right bytes' = bytes-        -        valid = isJust sig && isRight bytes-        unmarshaled = runUnmarshal (unmarshal sig') e bytes'+	sig = mkSignature . typeCode . variantType $ x+	Just sig' = sig+	+	bytes = runMarshal (marshal x) e+	Right bytes' = bytes+	+	valid = isJust sig && isRight bytes+	unmarshaled = runUnmarshal (unmarshal sig') e bytes'  prop_MarshalMessage e serial msg expected = valid ==> correct where-        bytes = marshalMessage e serial msg-        Right bytes' = bytes-        -        getBytes = G.getLazyByteString . fromIntegral-        unmarshaled = G.runGet (unmarshalMessage getBytes) bytes'-        -        valid = isRight bytes-        correct = unmarshaled == Right expected+	bytes = marshalMessage e serial msg+	Right bytes' = bytes+	+	getBytes = G.getLazyByteString . fromIntegral+	unmarshaled = G.runGet (unmarshalMessage getBytes) bytes'+	+	valid = isRight bytes+	correct = unmarshaled == Right expected  prop_WireMethodCall e serial msg = prop_MarshalMessage e serial msg-        $ ReceivedMethodCall serial Nothing msg+	$ ReceivedMethodCall serial Nothing msg  prop_WireMethodReturn e serial msg = prop_MarshalMessage e serial msg-        $ ReceivedMethodReturn serial Nothing msg+	$ ReceivedMethodReturn serial Nothing msg  prop_WireError e serial msg = prop_MarshalMessage e serial msg-        $ ReceivedError serial Nothing msg+	$ ReceivedError serial Nothing msg  prop_WireSignal e serial msg = prop_MarshalMessage e serial msg-        $ ReceivedSignal serial Nothing msg+	$ ReceivedSignal serial Nothing msg -instance Arbitrary Endianness where-        arbitrary = elements [LittleEndian, BigEndian]+#line 138 "src/addresses.anansi"+instance Arbitrary Address where+	arbitrary = genAddress where+		optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."+		methodChars = filter (flip notElem ":;") ['!'..'~']+		keyChars = filter (flip notElem "=;,") ['!'..'~']+		+		genMethod = atLeast 0 $ elements methodChars+		genParam = do+			key <- genKey+			value <- genValue+			return . concat $ [key, "=", value]+		+		genKey = atLeast 1 $ elements keyChars+		genValue = oneof [encodedValue, plainValue]+		genHex = elements $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']+		encodedValue = do+			x1 <- genHex+			x2 <- genHex+			return ['%', x1, x2]+		plainValue = atLeast 1 $ elements optional+		+		genParams = do+			params <- atLeast 0 genParam+			let params' = intercalate "," params+			extraComma <- if null params+				then return ""+				else elements ["", ","]+			return $ concat [params', extraComma]+		+		genAddress = do+			m <- genMethod+			params <- genParams+			extraSemicolon <- elements ["", ";"]+			let addrStr = concat [m, ":", params, extraSemicolon]+			let Just [addr] = mkAddresses $ TL.pack addrStr+			return addr +#line 407 "src/introspection.anansi" subObject :: ObjectPath -> Gen I.Object subObject parentPath = sized $ \n -> resize (min n 4) $ do-        let nonRoot = do-                x <- arbitrary-                case strObjectPath x of-                        "/" -> nonRoot-                        x'  -> return x'-        -        thisPath <- nonRoot-        let path' = case strObjectPath parentPath of-                "/" -> thisPath-                x   -> TL.append x thisPath-        let path = mkObjectPath_ path'-        ifaces <- arbitrary-        children <- shrinkingGen . listOf . subObject $ path-        return $ I.Object path ifaces children+	let nonRoot = do+		x <- arbitrary+		case strObjectPath x of+			"/" -> nonRoot+			x'  -> return x'+	+	thisPath <- nonRoot+	let path' = case strObjectPath parentPath of+		"/" -> thisPath+		x   -> TL.append x thisPath+	let path = mkObjectPath_ path'+	ifaces <- arbitrary+	children <- halfSized . listOf . subObject $ path+	return $ I.Object path ifaces children  instance Arbitrary I.Object where-        arbitrary = arbitrary >>= subObject+	arbitrary = arbitrary >>= subObject  instance Arbitrary I.Interface where-        arbitrary = do-                name <- arbitrary-                methods <- arbitrary-                signals <- arbitrary-                properties <- arbitrary-                return $ I.Interface name methods signals properties+	arbitrary = do+		name <- arbitrary+		methods <- arbitrary+		signals <- arbitrary+		properties <- arbitrary+		return $ I.Interface name methods signals properties  instance Arbitrary I.Method where-        arbitrary = do-                name <- arbitrary-                inParams <- arbitrary-                outParams <- arbitrary-                return $ I.Method name inParams outParams+	arbitrary = do+		name <- arbitrary+		inParams <- arbitrary+		outParams <- arbitrary+		return $ I.Method name inParams outParams  instance Arbitrary I.Signal where-        arbitrary = do-                name <- arbitrary-                params <- arbitrary-                return $ I.Signal name params+	arbitrary = do+		name <- arbitrary+		params <- arbitrary+		return $ I.Signal name params  singleType :: Gen Signature singleType = do-        t <- arbitrary-        case mkSignature $ typeCode t of-                Just x -> return x-                Nothing -> singleType+	t <- arbitrary+	case mkSignature $ typeCode t of+		Just x -> return x+		Nothing -> singleType  instance Arbitrary I.Parameter where-        arbitrary = do-                name <- listOf $ arbitrary `suchThat` isPrint-                sig <- singleType-                return $ I.Parameter (TL.pack name) sig+	arbitrary = do+		name <- listOf $ arbitrary `suchThat` isPrint+		sig <- singleType+		return $ I.Parameter (TL.pack name) sig  instance Arbitrary I.Property where-        arbitrary = do-                name <- listOf $ arbitrary `suchThat` isPrint-                sig <- singleType-                access <- elements-                        [[], [I.Read], [I.Write],-                         [I.Read, I.Write]]-                return $ I.Property (TL.pack name) sig access+	arbitrary = do+		name <- listOf $ arbitrary `suchThat` isPrint+		sig <- singleType+		access <- elements+			[[], [I.Read], [I.Write],+			 [I.Read, I.Write]]+		return $ I.Property (TL.pack name) sig access -iexp :: Integral a => a -> a -> a-iexp x y = floor $ fromIntegral x ** fromIntegral y+#line 191 "src/util.anansi"+halfSized :: Gen a -> Gen a+halfSized gen = sized $ \n -> if n > 0 then+	resize (n `div` 2) gen+	else gen +funEq :: Eq b => (a -> b) -> (a -> b) -> a -> Bool+funEq f g x = f x == g x++sizedText :: (IsString a, Arbitrary a) => Integer -> Gen TL.Text -> Gen a+sizedText maxSize gen = step where+	step = do+		s <- gen+		if toInteger (TL.length s) > maxSize+			then halfSized step+			else return . fromString . TL.unpack $ s++atLeast :: Int -> Gen a -> Gen [a]+atLeast minSize g = sized $ \n -> do+	count <- choose (minSize, max minSize n)+	replicateM count g++isRight :: Either a b -> Bool+isRight = either (const False) (const True)++#line 220 "src/util.anansi"+test :: Testable a => F.TestName -> a -> F.Test+test name prop = F.plusTestOptions options (testProperty name prop) where+	options = F.TestOptions Nothing (Just 1) Nothing Nothing++#line 229 "src/util.anansi" instance Arbitrary Word8 where-        arbitrary = fmap fromIntegral gen where-                gen = choose (0, max') :: Gen Integer-                max' = iexp 2 8 - 1+	arbitrary = arbitraryBoundedIntegral+	shrink    = shrinkIntegral  instance Arbitrary Word16 where-        arbitrary = fmap fromIntegral gen where-                gen = choose (0, max') :: Gen Integer-                max' = iexp 2 16 - 1+	arbitrary = arbitraryBoundedIntegral+	shrink    = shrinkIntegral  instance Arbitrary Word32 where-        arbitrary = fmap fromIntegral gen where-                gen = choose (0, max') :: Gen Integer-                max' = iexp 2 32 - 1+	arbitrary = arbitraryBoundedIntegral+	shrink    = shrinkIntegral  instance Arbitrary Word64 where-        arbitrary = fmap fromIntegral gen where-                gen = choose (0, max') :: Gen Integer-                max' = iexp 2 64 - 1+	arbitrary = arbitraryBoundedIntegral+	shrink    = shrinkIntegral  instance Arbitrary Int16 where-        arbitrary = fmap fromIntegral gen where-                gen = choose (0, max') :: Gen Integer-                max' = iexp 2 16 - 1+	arbitrary = arbitraryBoundedIntegral+	shrink    = shrinkIntegral  instance Arbitrary Int32 where-        arbitrary = fmap fromIntegral gen where-                gen = choose (0, max') :: Gen Integer-                max' = iexp 2 32 - 1+	arbitrary = arbitraryBoundedIntegral+	shrink    = shrinkIntegral  instance Arbitrary Int64 where-        arbitrary = fmap fromIntegral gen where-                gen = choose (0, max') :: Gen Integer-                max' = iexp 2 64 - 1+	arbitrary = arbitraryBoundedIntegral+	shrink    = shrinkIntegral  instance Arbitrary T.Text where-        arbitrary = fmap T.pack arbitrary+	arbitrary = fmap T.pack arbitrary  instance Arbitrary TL.Text where-        arbitrary = fmap TL.pack arbitrary--sized' :: Int -> Gen a -> Gen [a]-sized' atLeast g = sized $ \n -> do-        n' <- choose (atLeast, max atLeast n)-        replicateM n' g--clampedSize :: Arbitrary a => Int64 -> Gen TL.Text -> (TL.Text -> a) -> Gen a-clampedSize maxSize gen f = do-        s <- gen-        if TL.length s > maxSize-                then shrinkingGen arbitrary-                else return . f $ s--shrinkingGen :: Gen a -> Gen a-shrinkingGen gen = sized $ \n -> if n > 0 then-        resize (n `div` 2) gen-        else gen-+	arbitrary = fmap TL.pack arbitrary
+ readme.txt view
@@ -0,0 +1,10 @@+The source code for "dbus-core" is literate. To build the library from scratch,+install the "anansi" application and then run:++    anansi -o hs/ src/dbus-core.anansi++To generate the woven PDF, run:++    anansi -w -l latex-noweb -o dbus-core.tex src/dbus-core.anansi+    xelatex dbus-core.tex+    xelatex dbus-core.tex
+ src/addresses.anansi view
@@ -0,0 +1,207 @@+:# Copyright (C) 2009-2010 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{Addresses}++:f 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.++:f 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.++:f 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.++:f 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.++:f 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)+:++:f Tests.hs+instance Arbitrary Address where+	arbitrary = genAddress where+		optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."+		methodChars = filter (flip notElem ":;") ['!'..'~']+		keyChars = filter (flip notElem "=;,") ['!'..'~']+		+		genMethod = atLeast 0 $ elements methodChars+		genParam = do+			key <- genKey+			value <- genValue+			return . concat $ [key, "=", value]+		+		genKey = atLeast 1 $ elements keyChars+		genValue = oneof [encodedValue, plainValue]+		genHex = elements $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']+		encodedValue = do+			x1 <- genHex+			x2 <- genHex+			return ['%', x1, x2]+		plainValue = atLeast 1 $ elements optional+		+		genParams = do+			params <- atLeast 0 genParam+			let params' = intercalate "," params+			extraComma <- if null params+				then return ""+				else elements ["", ","]+			return $ concat [params', extraComma]+		+		genAddress = do+			m <- genMethod+			params <- genParams+			extraSemicolon <- elements ["", ";"]+			let addrStr = concat [m, ":", params, extraSemicolon]+			let Just [addr] = mkAddresses $ TL.pack addrStr+			return addr+:++:d test cases+, F.testGroup "Addresses"+	[ testProperty "Address identity"+		$ \x -> mkAddresses (strAddress x) == Just [x]+	, testProperty "Multiple addresses"+		$ \x y -> let+		joined = TL.concat [strAddress x, ";", strAddress y]+		in mkAddresses joined == Just [x, y]+	, testProperty "Ignore trailing semicolon"+		$ \x -> mkAddresses (TL.append (strAddress x) ";") == Just [x]+	, testProperty "Ignore trailing comma"+		$ \x -> let+		hasParams = not . Map.null . addressParameters $ x+		parsed = mkAddresses (TL.append (strAddress x) ",")+		in hasParams ==> parsed == Just [x]+	, F.testGroup "Valid addresses"+		[ test "colon" $ isJust . mkAddresses $ ":"+		, test "just scheme" $ isJust . mkAddresses $ "a:"+		, test "param" $ isJust . mkAddresses $ "a:b=c"+		, test "trailing semicolon" $ isJust . mkAddresses $ "a:;"+		, test "two schemes" $ isJust . mkAddresses $ "a:;b:"+		, test "trailing comma" $ isJust . mkAddresses $ "a:b=c,"+		]+	, F.testGroup "Invalid addresses"+		[ test "empty" $ isNothing . mkAddresses $ ""+		, test "no colon" $ isNothing . mkAddresses $ "a"+		, test "no equals" $ isNothing . mkAddresses $ "a:b"+		, test "no param" $ isNothing . mkAddresses $ "a:b="+		, test "no param" $ isNothing . mkAddresses $ "a:,"+		]+	]+:
+ src/api-docs.anansi view
@@ -0,0 +1,170 @@+:# Copyright (C) 2009-2010 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{Haddock API documentation}++The \LaTeX{} documentation is great for somebody reading the source code+or trying to fix an error, but it's not useful for people who just want+to add D-Bus support to their applications. These documentation sections+will be included in Haddock output for public functions.++There's no real order to this section; it exists only because Haddock+can't merge documentation from external files.++:d apidoc isAtomicType+-- | \"Atomic\" types are any which can't contain any other types. Only+-- atomic types may be used as dictionary keys.+:++:d apidoc typeCode+-- | Every type has an associated type code; a textual representation of+-- the type, useful for debugging.+:++:d apidoc Variant+-- | 'Variant's may contain any other built-in D-Bus value. Besides+-- representing native @VARIANT@ values, they allow type-safe storage and+-- deconstruction of heterogeneous collections.+:++:d apidoc variantType+-- | Every variant is strongly-typed; that is, the type of its contained+-- value is known at all times. This function retrieves that type, so that+-- the correct cast can be used to retrieve the value.+:++:d apidoc arrayType+-- | This is the type contained within the array, not the type of the array+-- itself.+:++:d apidoc Connection+-- | A 'Connection' is an opaque handle to an open D-Bus channel, with an+-- internal state for maintaining the current message serial.+:++:d apidoc Transport+-- | A 'Transport' is anything which can send and receive bytestrings,+-- typically via a socket.+:++:d apidoc connect+-- | Open a connection to some address, using a given authentication+-- mechanism. If the connection fails, a 'ConnectionError' will be thrown.+:++:d apidoc connectFirst+-- | Try to open a connection to various addresses, returning the first+-- connection which could be successfully opened.+:++:d apidoc connectionClose+-- | Close an open connection. Once closed, the 'Connection' is no longer+-- valid and must not be used.+:++:d apidoc send+-- | Send a single message, with a generated 'M.Serial'. The second parameter+-- exists to prevent race conditions when registering a reply handler; it+-- receives the serial the message /will/ be sent with, before it's actually+-- sent.+--+-- Only one message may be sent at a time; if multiple threads attempt to+-- send messages in parallel, one will block until after the other has+-- finished.+:++:d apidoc receive+-- | Receive the next message from the connection, blocking until one is+-- available.+--+-- Only one message may be received at a time; if multiple threads attempt+-- to receive messages in parallel, one will block until after the other has+-- finished.+:++:d apidoc getBus+-- | Similar to 'C.connect', but additionally sends @Hello@ messages to the+-- central bus.+:++:d apidoc getFirstBus+-- | Similar to 'C.connectFirst', but additionally sends @Hello@ messages to+-- the central bus.+:++:d apidoc getSystemBus+-- | Connect to the bus specified in the environment variable+-- @DBUS_SYSTEM_BUS_ADDRESS@, or to+-- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@+-- is not set.+:++:d apidoc getSessionBus+-- | Connect to the bus specified in the environment variable+-- @DBUS_SESSION_BUS_ADDRESS@, which must be set.+:++:d apidoc getStarterBus+-- | Connect to the bus specified in the environment variable+-- @DBUS_STARTER_ADDRESS@, which must be set.+:++:d apidoc formatRule+-- | Format a 'MatchRule' as the bus expects to receive in a call to+-- @AddMatch@.+:++:d apidoc addMatch+-- | Build a 'M.MethodCall' for adding a match rule to the bus.+:++:d apidoc matchAll+-- | An empty match rule, which matches everything.+:++:d apidoc matches+-- | Whether a 'M.ReceivedMessage' matches a given rule. This is useful+-- for implementing signal handlers.+:++:d apidoc requestName+-- | Build a 'M.MethodCall' for requesting a registered bus name.+:++:d apidoc releaseName+-- | Build a 'M.MethodCall' for releasing a registered bus name.+:++:d apidoc Serial+-- | A value used to uniquely identify a particular message within a session.+-- 'Serial's are 32-bit unsigned integers, and eventually wrap.+:++:d apidoc ReceivedMessage+-- | Not an actual message type, but a wrapper around messages received from+-- the bus. Each value contains the message's 'Serial' and possibly the+-- origin's 'T.BusName'+:++:d apidoc marshalMessage+-- | Convert a 'M.Message' into a 'L.ByteString'. Although unusual, it is+-- possible for marshaling to fail -- if this occurs, an appropriate error+-- will be returned instead.+:++:d apidoc unmarshalMessage+-- | Read bytes from a monad until a complete message has been received.+:
+ src/authentication.anansi view
@@ -0,0 +1,147 @@+:# Copyright (C) 2009-2010 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/>.++\subsection{Authentication}++Authentication is a bit iffy; currently, there's a one specified+authentication mechanism ({\tt DBUS\_COOKIE\_SHA1}), which I've never seen+in the wild. Everybody seems to use {\tt EXTERNAL}, described below.++To support multiple modes more easily in the future, and for user-defined+authentication handling (eg, in proxy servers), authentication is handled by+a separate module.++:f DBus/Authentication.hs+|copyright|+|text extensions|+{-# LANGUAGE DeriveDataTypeable #-}+module DBus.Authentication+	( Command+	, Mechanism (..)+	, AuthenticationError (..)+	, authenticate+	, realUserID+	) where+|text imports|+|authentication imports|+:++The authentication protocol is based on {\sc ascii} text, initiated by the+client. Commands and mechanisms are represented by a couple data types:++:d authentication imports+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as ByteString+import qualified DBus.UUID as UUID+:++:f DBus/Authentication.hs+type Command = Text+newtype Mechanism = Mechanism+	{ mechanismRun :: (Command -> IO Command) -> IO UUID.UUID+	}+:++If authentication fails, an exception will be raised.++:d authentication imports+import Data.Typeable (Typeable)+import qualified Control.Exception as E+:++:f DBus/Authentication.hs+data AuthenticationError+	= AuthenticationError Text+	deriving (Show, Typeable)++instance E.Exception AuthenticationError+:++The process begins by the client sending a single {\sc nul} byte, followed+by exchanges of {\sc ascii} commands until authentication is complete. Which+commands are sent depends on the selected mechanism.++:d authentication imports+import Data.Word (Word8)+:++:f DBus/Authentication.hs+authenticate :: Mechanism -> (ByteString -> IO ()) -> IO Word8+             -> IO UUID.UUID+authenticate mech put getByte = do+	put $ ByteString.singleton 0+	uuid <- mechanismRun mech (putCommand put getByte)+	put "BEGIN\r\n"+	return uuid+:++TODO: describe {\tt putCommand} here++:d authentication imports+import Control.Monad (liftM)+import Data.Char (chr)+import Data.Text.Lazy.Encoding (encodeUtf8)+import DBus.Util (readUntil, dropEnd)+:++:f DBus/Authentication.hs+putCommand :: Monad m => (ByteString -> m ()) -> m Word8 -> Command -> m Command+putCommand put get cmd = do+	let getC = liftM (chr . fromIntegral) get+	put $ encodeUtf8 cmd+	put "\r\n"+	liftM (TL.pack . dropEnd 2) $ readUntil "\r\n" getC+:++\subsubsection{Support authentication mechanisms}++Currently, the only supported authentication mechanism is sending the local+user's ``real user ID''.++:d authentication imports+import System.Posix.User (getRealUserID)+import Data.Char (ord)+import Text.Printf (printf)+:++:f DBus/Authentication.hs+realUserID :: Mechanism+realUserID = Mechanism $ \sendCmd -> do+	uid <- getRealUserID+	let token = concatMap (printf "%02X" . ord) (show uid)+	let cmd = "AUTH EXTERNAL " ++ token+	eitherUUID <- checkOK `fmap` sendCmd (TL.pack cmd)+	case eitherUUID of+		Right uuid -> return uuid+		Left err -> E.throwIO $ AuthenticationError err+:++If authentication was successful, the server responds with {\tt OK+<server GUID>}.++:d authentication imports+import Data.Maybe (isJust)+:++:f DBus/Authentication.hs+checkOK :: Command -> Either Text UUID.UUID+checkOK cmd = if validUUID then Right uuid else Left errorMsg where+	validUUID = TL.isPrefixOf "OK " cmd && isJust maybeUUID+	maybeUUID = UUID.fromHex $ TL.drop 3 cmd+	Just uuid = maybeUUID+	errorMsg = if TL.isPrefixOf "ERROR " cmd+		then TL.drop 6 cmd+		else TL.pack $ "Unexpected response: " ++ show cmd+:
+ src/bus.anansi view
@@ -0,0 +1,140 @@+:# Copyright (C) 2009-2010 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{The central bus}++:f DBus/Bus.hs+|copyright|+|text extensions|+module DBus.Bus+	( getBus+	, getFirstBus+	, getSystemBus+	, getSessionBus+	, getStarterBus+	) where+|text imports|++import qualified Control.Exception as E+import Control.Monad (when)+import Data.Maybe (fromJust, isNothing)+import qualified Data.Set as Set+import System.Environment (getEnv)++import qualified DBus.Address as A+import qualified DBus.Authentication as Auth+import qualified DBus.Connection as C+import DBus.Constants (dbusName, dbusPath, dbusInterface)+import qualified DBus.Message as M+import qualified DBus.Types as T+import DBus.Util (fromRight)+:++Connecting to a message bus is a bit more involved than just connecting+over an app-to-app connection: the bus must be notified of the new client,+using a "hello message", before it will begin forwarding messages.++:f DBus/Bus.hs+busForConnection :: C.Connection -> IO (C.Connection, T.BusName)+busForConnection c = fmap ((,) c) $ sendHello c++|apidoc getBus|+getBus :: Auth.Mechanism -> A.Address -> IO (C.Connection, T.BusName)+getBus = ((busForConnection =<<) .) . C.connect+:++Optionally, multiple addresses may be provided. The first successful+connection will be used.++:f DBus/Bus.hs+|apidoc getFirstBus|+getFirstBus :: [(Auth.Mechanism, A.Address)] -> IO (C.Connection, T.BusName)+getFirstBus = (busForConnection =<<) . C.connectFirst+:++\subsection{Default connections}++Two default buses are defined, the ``system'' and ``session'' buses. The system+bus is global for the OS, while the session bus runs only for the duration+of the user's session.++:f DBus/Bus.hs+|apidoc getSystemBus|+getSystemBus :: IO (C.Connection, T.BusName)+getSystemBus = getBus' $ fromEnv `E.catch` noEnv where+	defaultAddr = "unix:path=/var/run/dbus/system_bus_socket"+	fromEnv = getEnv "DBUS_SYSTEM_BUS_ADDRESS"+	noEnv (E.SomeException _) = return defaultAddr++|apidoc getSessionBus|+getSessionBus :: IO (C.Connection, T.BusName)+getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS"++|apidoc getStarterBus|+getStarterBus :: IO (C.Connection, T.BusName)+getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS"+:++:f DBus/Bus.hs+getBus' :: IO String -> IO (C.Connection, T.BusName)+getBus' io = do+	addr <- fmap TL.pack io+	case A.mkAddresses addr of+		Just [x] -> getBus Auth.realUserID x+		Just  xs -> getFirstBus [(Auth.realUserID,x) | x <- xs]+		_        -> E.throwIO $ C.InvalidAddress addr+:++\subsection{Sending the ``hello'' message}++:f DBus/Bus.hs+hello :: M.MethodCall+hello = M.MethodCall dbusPath+	"Hello"+	(Just dbusInterface)+	(Just dbusName)+	Set.empty+	[]+:++:f 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+:++:f 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+:
+ src/connections.anansi view
@@ -0,0 +1,392 @@+:# Copyright (C) 2009-2010 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{Connections}++:f 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.++:d connection imports+import qualified Control.Concurrent as C+import qualified DBus.Address as A+import qualified DBus.Message as M+import qualified DBus.UUID as UUID+:++:f DBus/Connection.hs+data Connection = Connection+	{ connectionAddress    :: A.Address+	, connectionTransport  :: Transport+	, connectionSerialMVar :: C.MVar M.Serial+	, connectionReadMVar   :: C.MVar ()+	, connectionUUID       :: UUID.UUID+	}+:++:d connection exports+  Connection+, connectionAddress+, connectionUUID+:++While not particularly useful for other functions, being able to+{\tt show} a {\tt Connection} is useful when debugging.++:f DBus/Connection.hs+instance Show Connection where+	showsPrec d con = showParen (d > 10) strCon where+		addr = A.strAddress $ connectionAddress con+		strCon = s "<Connection " . shows addr . s ">"+		s = showString+:++\subsection{Transports}++A transport is anything which can send and receive bytestrings, typically+via a socket.++:d connection imports+import qualified Data.ByteString.Lazy as L+import Data.Word (Word32)+:++:f DBus/Connection.hs+|apidoc Transport|+data Transport = Transport+	{ transportSend :: L.ByteString -> IO ()+	, transportRecv :: Word32 -> IO L.ByteString+	, transportClose :: IO ()+	}+:++If a method has no known transport, attempting to connect using it will+just result in an exception.++:f 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.++:d connection imports+import qualified Network as N+import qualified Data.Map as Map+:++:f 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.++:d connection imports+import qualified Network.Socket as NS+:++:f 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...++:f DBus/Connection.hs+	hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params+:++:f 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+:++:f 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}.++:d connection imports+import qualified Text.Parsec as P+import Control.Monad (unless)+import Data.Binary.Get (runGet, getWord16host)+import Data.Binary.Put (runPut, putWord16be)+:++:f 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))+:++:f 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.++:f 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.++:f 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.++:d connection imports+import qualified System.IO as I+:++:f 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) (I.hClose h)+:++\subsection{Errors}++If connecting to D-Bus fails, a {\tt ConnectionError} will be thrown.+The constructor describes which exception occurred.++:d connection imports+import qualified Control.Exception as E+import Data.Typeable (Typeable)+:++:f DBus/Connection.hs+data ConnectionError+	= InvalidAddress Text+	| BadParameters A.Address Text+	| UnknownMethod A.Address+	| NoWorkingAddress [A.Address]+	deriving (Show, Typeable)++instance E.Exception ConnectionError+:++:d 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.++:d connection imports+import qualified DBus.Authentication as Auth+:++:f DBus/Connection.hs+|apidoc connect|+connect :: Auth.Mechanism -> A.Address -> IO Connection+connect mechanism a = do+	t <- connectTransport a+	let getByte = L.head `fmap` transportRecv t 1+	uuid <- Auth.authenticate mechanism (transportSend t) getByte+	readLock <- C.newMVar ()+	serialMVar <- C.newMVar M.firstSerial+	return $ Connection a t serialMVar readLock uuid+:++Since addresses usually come in a list, it's sensible to have a variant+of {\tt connect} which tries multiple addresses. The first successfully+opened {\tt Connection} is returned.++:f DBus/Connection.hs+|apidoc connectFirst|+connectFirst :: [(Auth.Mechanism, A.Address)] -> IO Connection+connectFirst orig = connectFirst' orig where+	allAddrs = [a | (_, a) <- orig]+	connectFirst'     [] = E.throwIO $ NoWorkingAddress allAddrs+	connectFirst' ((mech, a):as) = E.catch (connect mech a) $+		\(E.SomeException _) -> connectFirst' as+:++:d connection exports+, connect+, connectFirst+:++\subsection{Closing connections}++:f DBus/Connection.hs+|apidoc connectionClose|+connectionClose :: Connection -> IO ()+connectionClose = transportClose . connectionTransport+:++:d connection exports+, connectionClose+:++:i authentication.anansi++\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.++:d connection imports+import qualified DBus.Wire as W+:++:f DBus/Connection.hs+|apidoc send|+send :: M.Message a => Connection -> (M.Serial -> IO b) -> a+     -> IO (Either W.MarshalError b)+send (Connection _ t mvar _ _) io msg = withSerial mvar $ \serial ->+	case W.marshalMessage W.LittleEndian serial msg of+		Right bytes -> do+			x <- io serial+			transportSend t bytes+			return $ Right x+		Left  err   -> return $ Left err+:++:d connection exports+, send+:++:f 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.++:f DBus/Connection.hs+|apidoc receive|+receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage)+receive (Connection _ t _ lock _) = C.withMVar lock $ \_ ->+	W.unmarshalMessage $ transportRecv t+:++:d connection exports+, receive+:
+ src/constants.anansi view
@@ -0,0 +1,186 @@+:# Copyright (C) 2009-2010 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{Constants}++:f DBus/Constants.hs+|copyright|+{-# LANGUAGE OverloadedStrings #-}+module DBus.Constants where+import qualified DBus.Types as T+import Data.Word (Word8, Word32)++protocolVersion :: Word8+protocolVersion = 1++messageMaximumLength :: Word32+messageMaximumLength = 134217728++arrayMaximumLength :: Word32+arrayMaximumLength = 67108864+:++\subsection{The message bus}++:f DBus/Constants.hs+dbusName :: T.BusName+dbusName = "org.freedesktop.DBus"++dbusPath :: T.ObjectPath+dbusPath = "/org/freedesktop/DBus"++dbusInterface :: T.InterfaceName+dbusInterface = "org.freedesktop.DBus"+:++\subsection{Pre-defined interfaces}++:f DBus/Constants.hs+interfaceIntrospectable :: T.InterfaceName+interfaceIntrospectable = "org.freedesktop.DBus.Introspectable"++interfaceProperties :: T.InterfaceName+interfaceProperties = "org.freedesktop.DBus.Properties"++interfacePeer :: T.InterfaceName+interfacePeer = "org.freedesktop.DBus.Peer"+:++\subsection{Pre-defined error names}++:f DBus/Constants.hs+errorFailed :: T.ErrorName+errorFailed = "org.freedesktop.DBus.Error.Failed"++errorNoMemory :: T.ErrorName+errorNoMemory = "org.freedesktop.DBus.Error.NoMemory"++errorServiceUnknown :: T.ErrorName+errorServiceUnknown = "org.freedesktop.DBus.Error.ServiceUnknown"++errorNameHasNoOwner :: T.ErrorName+errorNameHasNoOwner = "org.freedesktop.DBus.Error.NameHasNoOwner"++errorNoReply :: T.ErrorName+errorNoReply = "org.freedesktop.DBus.Error.NoReply"++errorIOError :: T.ErrorName+errorIOError = "org.freedesktop.DBus.Error.IOError"++errorBadAddress :: T.ErrorName+errorBadAddress = "org.freedesktop.DBus.Error.BadAddress"++errorNotSupported :: T.ErrorName+errorNotSupported = "org.freedesktop.DBus.Error.NotSupported"++errorLimitsExceeded :: T.ErrorName+errorLimitsExceeded = "org.freedesktop.DBus.Error.LimitsExceeded"++errorAccessDenied :: T.ErrorName+errorAccessDenied = "org.freedesktop.DBus.Error.AccessDenied"++errorAuthFailed :: T.ErrorName+errorAuthFailed = "org.freedesktop.DBus.Error.AuthFailed"++errorNoServer :: T.ErrorName+errorNoServer = "org.freedesktop.DBus.Error.NoServer"++errorTimeout :: T.ErrorName+errorTimeout = "org.freedesktop.DBus.Error.Timeout"++errorNoNetwork :: T.ErrorName+errorNoNetwork = "org.freedesktop.DBus.Error.NoNetwork"++errorAddressInUse :: T.ErrorName+errorAddressInUse = "org.freedesktop.DBus.Error.AddressInUse"++errorDisconnected :: T.ErrorName+errorDisconnected = "org.freedesktop.DBus.Error.Disconnected"++errorInvalidArgs :: T.ErrorName+errorInvalidArgs = "org.freedesktop.DBus.Error.InvalidArgs"++errorFileNotFound :: T.ErrorName+errorFileNotFound = "org.freedesktop.DBus.Error.FileNotFound"++errorFileExists :: T.ErrorName+errorFileExists = "org.freedesktop.DBus.Error.FileExists"++errorUnknownMethod :: T.ErrorName+errorUnknownMethod = "org.freedesktop.DBus.Error.UnknownMethod"++errorTimedOut :: T.ErrorName+errorTimedOut = "org.freedesktop.DBus.Error.TimedOut"++errorMatchRuleNotFound :: T.ErrorName+errorMatchRuleNotFound = "org.freedesktop.DBus.Error.MatchRuleNotFound"++errorMatchRuleInvalid :: T.ErrorName+errorMatchRuleInvalid = "org.freedesktop.DBus.Error.MatchRuleInvalid"++errorSpawnExecFailed :: T.ErrorName+errorSpawnExecFailed = "org.freedesktop.DBus.Error.Spawn.ExecFailed"++errorSpawnForkFailed :: T.ErrorName+errorSpawnForkFailed = "org.freedesktop.DBus.Error.Spawn.ForkFailed"++errorSpawnChildExited :: T.ErrorName+errorSpawnChildExited = "org.freedesktop.DBus.Error.Spawn.ChildExited"++errorSpawnChildSignaled :: T.ErrorName+errorSpawnChildSignaled = "org.freedesktop.DBus.Error.Spawn.ChildSignaled"++errorSpawnFailed :: T.ErrorName+errorSpawnFailed = "org.freedesktop.DBus.Error.Spawn.Failed"++errorSpawnFailedToSetup :: T.ErrorName+errorSpawnFailedToSetup = "org.freedesktop.DBus.Error.Spawn.FailedToSetup"++errorSpawnConfigInvalid :: T.ErrorName+errorSpawnConfigInvalid = "org.freedesktop.DBus.Error.Spawn.ConfigInvalid"++errorSpawnServiceNotValid :: T.ErrorName+errorSpawnServiceNotValid = "org.freedesktop.DBus.Error.Spawn.ServiceNotValid"++errorSpawnServiceNotFound :: T.ErrorName+errorSpawnServiceNotFound = "org.freedesktop.DBus.Error.Spawn.ServiceNotFound"++errorSpawnPermissionsInvalid :: T.ErrorName+errorSpawnPermissionsInvalid = "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid"++errorSpawnFileInvalid :: T.ErrorName+errorSpawnFileInvalid = "org.freedesktop.DBus.Error.Spawn.FileInvalid"++errorSpawnNoMemory :: T.ErrorName+errorSpawnNoMemory = "org.freedesktop.DBus.Error.Spawn.NoMemory"++errorUnixProcessIdUnknown :: T.ErrorName+errorUnixProcessIdUnknown = "org.freedesktop.DBus.Error.UnixProcessIdUnknown"++errorInvalidFileContent :: T.ErrorName+errorInvalidFileContent = "org.freedesktop.DBus.Error.InvalidFileContent"++errorSELinuxSecurityContextUnknown :: T.ErrorName+errorSELinuxSecurityContextUnknown = "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown"++errorAdtAuditDataUnknown :: T.ErrorName+errorAdtAuditDataUnknown = "org.freedesktop.DBus.Error.AdtAuditDataUnknown"++errorObjectPathInUse :: T.ErrorName+errorObjectPathInUse = "org.freedesktop.DBus.Error.ObjectPathInUse"++errorInconsistentMessage :: T.ErrorName+errorInconsistentMessage = "org.freedesktop.DBus.Error.InconsistentMessage"+:
+ src/dbus-core.anansi view
@@ -0,0 +1,55 @@+:# Copyright (C) 2009-2010 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++:i introduction.anansi+:i types.anansi+:i messages.anansi+:i wire.anansi+:i addresses.anansi+:i connections.anansi+:i bus.anansi+:i introspection.anansi+:i match-rules.anansi+:i name-reservation.anansi+:i constants.anansi+:i util.anansi+:i api-docs.anansi++\end{document}
+ src/introduction.anansi view
@@ -0,0 +1,76 @@+:# Copyright (C) 2009-2010 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{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.++:d copyright+-- Copyright (C) 2009-2010 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.++:d text extensions+{-# LANGUAGE OverloadedStrings #-}+:++:d text imports+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL+:++Tests are separated into a separate file, which is optionally compiled but+not included in the library.++:f Tests.hs+|copyright|+|text extensions|+module Main (tests, main) where+|test imports|++tests :: [F.Test]+tests = [ F.testGroup "dummy" []+	|test cases|+	]++main :: IO ()+main = F.defaultMain tests+:
+ src/introspection.anansi view
@@ -0,0 +1,480 @@+:# Copyright (C) 2009-2010 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{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}++:f 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.++:d introspection imports+import qualified Text.XML.HaXml as H+:++\subsection{Data types}++:f 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.++:d introspection imports+import Text.XML.HaXml.Parse (xmlParse')+import DBus.Util (eitherToMaybe)+:++:f 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.++:f 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.++:f 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.++:f 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.++:f 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.++:f 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.++:f 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.++:f DBus/Introspection.hs+parseParameter :: H.Element a -> Maybe Parameter+parseParameter e = do+	let name = getAttr' "name" e+	sig <- parseType e+	return $ Parameter name sig+:++:f 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.++:f 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.++:d introspection imports+import Data.Char (chr)+:++:f 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++:d introspection imports+import Data.Maybe (fromMaybe)+:++:f 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++isParam :: [Text] -> H.CFilter a+isParam dirs content = do+	arg@(H.CElem e _) <- H.tag "arg" content+	let direction = getAttr' "direction" e+	[arg | direction `elem` dirs]++children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b]+children f filt (H.Elem _ _ contents) =+	mapM f [x | (H.CElem x _) <- concatMap filt contents]+:++\subsection{Generating XML}++:f 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.++:d 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}.++:f 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.++:f DBus/Introspection.hs+xmlRoot :: Object -> Maybe (H.Element a)+xmlRoot obj@(Object path _ _) = do+	(H.CElem root _) <- xmlObject' (T.strObjectPath path) obj+	return root+:++:f 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+:++:f 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''+			]+:++:f 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+			]+:++:f 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+		]+:++:f 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+:++:f 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+	] []+:++:f 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+	] []+:++:f 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 ""+:++:f 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++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]+:++\subsection{Test support}++:f Tests.hs+subObject :: ObjectPath -> Gen I.Object+subObject parentPath = sized $ \n -> resize (min n 4) $ do+	let nonRoot = do+		x <- arbitrary+		case strObjectPath x of+			"/" -> nonRoot+			x'  -> return x'+	+	thisPath <- nonRoot+	let path' = case strObjectPath parentPath of+		"/" -> thisPath+		x   -> TL.append x thisPath+	let path = mkObjectPath_ path'+	ifaces <- arbitrary+	children <- halfSized . listOf . subObject $ path+	return $ I.Object path ifaces children++instance Arbitrary I.Object where+	arbitrary = arbitrary >>= subObject++instance Arbitrary I.Interface where+	arbitrary = do+		name <- arbitrary+		methods <- arbitrary+		signals <- arbitrary+		properties <- arbitrary+		return $ I.Interface name methods signals properties++instance Arbitrary I.Method where+	arbitrary = do+		name <- arbitrary+		inParams <- arbitrary+		outParams <- arbitrary+		return $ I.Method name inParams outParams++instance Arbitrary I.Signal where+	arbitrary = do+		name <- arbitrary+		params <- arbitrary+		return $ I.Signal name params++singleType :: Gen Signature+singleType = do+	t <- arbitrary+	case mkSignature $ typeCode t of+		Just x -> return x+		Nothing -> singleType++instance Arbitrary I.Parameter where+	arbitrary = do+		name <- listOf $ arbitrary `suchThat` isPrint+		sig <- singleType+		return $ I.Parameter (TL.pack name) sig++instance Arbitrary I.Property where+	arbitrary = do+		name <- listOf $ arbitrary `suchThat` isPrint+		sig <- singleType+		access <- elements+			[[], [I.Read], [I.Write],+			 [I.Read, I.Write]]+		return $ I.Property (TL.pack name) sig access+:++:d test cases+, F.testGroup "Introspection"+	[ testProperty "Generate -> Parse"+		$ \x@(I.Object path _ _) -> let+		xml = I.toXML x+		Just xml' = xml+		parsed = I.fromXML path xml'+		in isJust xml ==> I.fromXML path xml' == Just x+	]+:
+ src/match-rules.anansi view
@@ -0,0 +1,244 @@+:# Copyright (C) 2009-2010 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{Match rules}++Match rules are used to indicate that the client is interested in messages+matching a particular filter. This module provides an interface for building+match rule strings. Eventually, it will support parsing them also.++:f 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 (fromMaybe, mapMaybe)+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)+:++:f DBus/MatchRule.hs+-- | A match rule is a set of filters; most filters may have one possible+-- value assigned, such as a single message type. The exception are parameter+-- filters, which are limited in number only by the server implementation.+-- +data MatchRule = MatchRule+	{ matchType        :: Maybe MessageType+	, matchSender      :: Maybe T.BusName+	, matchInterface   :: Maybe T.InterfaceName+	, matchMember      :: Maybe T.MemberName+	, matchPath        :: Maybe T.ObjectPath+	, matchDestination :: Maybe T.BusName+	, matchParameters  :: [ParameterValue]+	}+	deriving (Show)+:++:f DBus/MatchRule.hs+-- | Parameters may match against two types, strings and object paths. It's+-- probably an error to have two values for the same parameter.+-- +-- The constructor @StringValue 3 \"hello\"@ means that the fourth parameter+-- in the message body must be the string @\"hello\"@. @PathValue@ is the+-- same, but its value must be an object path.+-- +data ParameterValue+	= StringValue Word8 Text+	| PathValue Word8 T.ObjectPath+	deriving (Show, Eq)+:++:f DBus/MatchRule.hs+-- | The set of allowed message types to filter on is separate from the set+-- supported for sending over the wire. This allows the server to support+-- additional types not yet implemented in the library, or vice-versa.+-- +data MessageType+	= MethodCall+	| MethodReturn+	| Signal+	| Error+	deriving (Show, Eq)+:++There's currently only one operation to perform on match rules, and that's+to format them.++:f DBus/MatchRule.hs+|apidoc formatRule|+formatRule :: MatchRule -> Text+formatRule rule = TL.intercalate "," filters where+	filters = structureFilters ++ parameterFilters+	parameterFilters = map formatParameter $ matchParameters rule+	structureFilters = mapMaybe 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+:++:f 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.++:f DBus/MatchRule.hs+formatFilter' :: Text -> Text -> Text+formatFilter' key value = TL.concat [key, "='", value, "'"]++formatType :: MessageType -> Text+formatType MethodCall   = "method_call"+formatType MethodReturn = "method_return"+formatType Signal       = "signal"+formatType Error        = "error"+:++And since the only real reason for formatting a match rule is to send it,+it's useful to have a message-building function pre-defined.++:f DBus/MatchRule.hs+|apidoc addMatch|+addMatch :: MatchRule -> M.MethodCall+addMatch rule = M.MethodCall+	C.dbusPath+	"AddMatch"+	(Just C.dbusInterface)+	(Just C.dbusName)+	Set.empty+	[T.toVariant $ formatRule rule]+:++Most match rules will have only one or two fields filled in, so defining+an empty rule allows clients to set only the fields they care about.++:f DBus/MatchRule.hs+|apidoc matchAll|+matchAll :: MatchRule+matchAll = MatchRule+	{ matchType        = Nothing+	, matchSender      = Nothing+	, matchInterface   = Nothing+	, matchMember      = Nothing+	, matchPath        = Nothing+	, matchDestination = Nothing+	, matchParameters  = []+	}+:++It's useful to match against a rule client-side, eg when listening for+signals.++:f DBus/MatchRule.hs+|apidoc matches|+matches :: MatchRule -> M.ReceivedMessage -> Bool+matches rule msg = and . mapMaybe ($ 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+	]+:++:f 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+:++:f DBus/MatchRule.hs+senderMatches :: M.ReceivedMessage -> T.BusName -> Bool+senderMatches msg name = M.receivedSender msg == Just name+:++:f 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+:++:f 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+:++:f 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+:++:f 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+:++:f 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+:
+ src/messages.anansi view
@@ -0,0 +1,381 @@+:# Copyright (C) 2009-2010 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{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.++:f DBus/Message.hs+|copyright|+module DBus.Message (+	|message exports|+	) where+import DBus.Message.Internal+:++:f 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)+:++:f DBus/Message/Internal.hs+class Message a where+	messageTypeCode     :: a -> Word8+	messageHeaderFields :: a -> [HeaderField]+	messageFlags        :: a -> S.Set Flag+	messageBody         :: a -> [T.Variant]+:++:d 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.++:f DBus/Message/Internal.hs+data Flag+	= NoReplyExpected+	| NoAutoStart+	deriving (Show, Eq, Ord)+:++:d message exports+, Flag (..)+:++:f Tests.hs+instance Arbitrary Flag where+	arbitrary = elements [NoReplyExpected, NoAutoStart]+:++\subsection{Header fields}++:f 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.++:f DBus/Message/Internal.hs+|apidoc Serial|+newtype Serial = Serial { serialValue :: Word32 }+	deriving (Eq, Ord)++instance Show Serial where+	show (Serial x) = show x++instance T.Variable Serial where+	toVariant (Serial x) = T.toVariant x+	fromVariant = fmap Serial . T.fromVariant+:++Additionally, some useful functions exist for incrementing serials.++:f 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.++:d message exports+, Serial+, serialValue+, firstSerial+, nextSerial+:++:f Tests.hs+instance Arbitrary Serial where+	arbitrary = fmap Serial arbitrary+:++\subsection{Message types}++:f DBus/Message/Internal.hs+maybe' :: (a -> b) -> Maybe a -> [b]+maybe' f = maybe [] (\x' -> [f x'])+:++\subsubsection{Method calls}++:f 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+		]+:++:d message exports+, MethodCall (..)+:++:f Tests.hs+instance Arbitrary MethodCall where+	arbitrary = do+		path   <- arbitrary+		member <- arbitrary+		iface  <- arbitrary+		dest   <- arbitrary+		flags  <- fmap Set.fromList arbitrary+		Structure body <- arbitrary+		return $ MethodCall path member iface dest flags body+:++\subsubsection{Method returns}++:f 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+		]+:++:d message exports+, MethodReturn (..)+:++:f Tests.hs+instance Arbitrary MethodReturn where+	arbitrary = do+		serial <- arbitrary+		dest   <- arbitrary+		Structure body <- arbitrary+		return $ MethodReturn serial dest body+:++\subsubsection{Errors}++:f 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.++:f 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+:++:d message exports+, Error (..)+, errorMessage+:++:f Tests.hs+instance Arbitrary Error where+	arbitrary = do+		name   <- arbitrary+		serial <- arbitrary+		dest   <- arbitrary+		Structure body <- arbitrary+		return $ Error name serial dest body+:++\subsubsection{Signals}++:f 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+		]+:++:d message exports+, Signal (..)+:++:f Tests.hs+instance Arbitrary Signal where+	arbitrary = do+		path   <- arbitrary+		member <- arbitrary+		iface  <- arbitrary+		dest   <- arbitrary+		Structure body <- arbitrary+		return $ Signal path member iface dest body+:++\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.++:f DBus/Message/Internal.hs+data Unknown = Unknown+	{ unknownType    :: Word8+	, unknownFlags   :: S.Set Flag+	, unknownBody    :: [T.Variant]+	}+	deriving (Show, Eq)+:++:d 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.++:f DBus/Message/Internal.hs+|apidoc ReceivedMessage|+data ReceivedMessage+	= ReceivedMethodCall   Serial (Maybe T.BusName) MethodCall+	| ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn+	| ReceivedError        Serial (Maybe T.BusName) Error+	| ReceivedSignal       Serial (Maybe T.BusName) Signal+	| ReceivedUnknown      Serial (Maybe T.BusName) Unknown+	deriving (Show, Eq)+:++:f 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+:++:f 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+:++:f 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 (ReceivedUnknown      _ _ x) = unknownBody x+:++:d message exports+, ReceivedMessage (..)+, receivedSerial+, receivedSender+, receivedBody+:
+ src/name-reservation.anansi view
@@ -0,0 +1,137 @@+:# Copyright (C) 2009-2010 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{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.++:f 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)+:++:f DBus/NameReservation.hs+data RequestNameFlag+	= AllowReplacement+	| ReplaceExisting+	| DoNotQueue+	deriving (Show)+:++:f 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}.++:f DBus/NameReservation.hs+|apidoc requestName|+requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall+requestName name flags = M.MethodCall+	{ M.methodCallPath = C.dbusPath+	, M.methodCallInterface = Just C.dbusInterface+	, M.methodCallDestination = Just C.dbusName+	, M.methodCallFlags = Set.empty+	, M.methodCallMember = "RequestName"+	, M.methodCallBody =+		[ T.toVariant name+		, T.toVariant . encodeFlags $ flags]+	}+:++:f DBus/NameReservation.hs+data RequestNameReply+	= PrimaryOwner+	| InQueue+	| Exists+	| AlreadyOwner+	deriving (Show)+:++:f DBus/NameReservation.hs+mkRequestNameReply :: M.MethodReturn -> Maybe RequestNameReply+mkRequestNameReply msg =+	maybeIndex (M.messageBody msg) 0 >>=+	T.fromVariant >>=+	decodeRequestReply+:++:f 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+:++:f DBus/NameReservation.hs+|apidoc releaseName|+releaseName :: T.BusName -> M.MethodCall+releaseName name = M.MethodCall+	{ M.methodCallPath = C.dbusPath+	, M.methodCallInterface = Just C.dbusInterface+	, M.methodCallDestination = Just C.dbusName+	, M.methodCallFlags = Set.empty+	, M.methodCallMember = "ReleaseName"+	, M.methodCallBody = [T.toVariant name]+	}+:++:f DBus/NameReservation.hs+data ReleaseNameReply+	= Released+	| NonExistent+	| NotOwner+	deriving (Show)+:++:f DBus/NameReservation.hs+mkReleaseNameReply :: M.MethodReturn -> Maybe ReleaseNameReply+mkReleaseNameReply msg =+	maybeIndex (M.messageBody msg) 0 >>=+	T.fromVariant >>=+	decodeReleaseReply+:++:f DBus/NameReservation.hs+decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply+decodeReleaseReply 1 = Just Released+decodeReleaseReply 2 = Just NonExistent+decodeReleaseReply 3 = Just NotOwner+decodeReleaseReply _ = Nothing+:
+ src/types.anansi view
@@ -0,0 +1,1236 @@+:# Copyright (C) 2009-2010 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{Types}++The {\tt DBus.Types module} defines interfaces for storing, building, and+deconstructing D-Bus values.++:f DBus/Types.cpphs+|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.++:f DBus/Types.cpphs+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)+:++:f DBus/Types.cpphs+|apidoc isAtomicType|+isAtomicType :: Type -> Bool+isAtomicType DBusBoolean    = True+isAtomicType DBusByte       = True+isAtomicType DBusInt16      = True+isAtomicType DBusInt32      = True+isAtomicType DBusInt64      = True+isAtomicType DBusWord16     = True+isAtomicType DBusWord32     = True+isAtomicType DBusWord64     = True+isAtomicType DBusDouble     = True+isAtomicType DBusString     = True+isAtomicType DBusSignature  = True+isAtomicType DBusObjectPath = True+isAtomicType _              = False+:++Each type can be converted to a textual representation, used in ``type+signatures'' or for debugging.++:f DBus/Types.cpphs+|apidoc typeCode|+typeCode :: Type -> Text+|type codes|+:++:d type exports+  -- * Available types+  Type (..)+, typeCode+:++:f Tests.hs+instance Arbitrary Type where+	arbitrary = oneof [atomicType, containerType]++atomicType :: Gen Type+atomicType = elements+	[ DBusBoolean+	, DBusByte+	, DBusWord16+	, DBusWord32+	, DBusWord64+	, DBusInt16+	, DBusInt32+	, DBusInt64+	, DBusDouble+	, DBusString+	, DBusObjectPath+	, DBusSignature+	]++containerType :: Gen Type+containerType = do+	c <- choose (0,3) :: Gen Int+	case c of+		0 -> fmap DBusArray arbitrary+		1 -> do+			kt <- atomicType+			vt <- arbitrary+			return $ DBusDictionary kt vt+		2 -> fmap DBusStructure $ halfSized arbitrary+		3 -> return DBusVariant+:++\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.++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.++:f DBus/Types.cpphs+|apidoc Variant|+data Variant+	= VarBoxBool Bool+	| VarBoxWord8 Word8+	| VarBoxInt16 Int16+	| VarBoxInt32 Int32+	| VarBoxInt64 Int64+	| VarBoxWord16 Word16+	| VarBoxWord32 Word32+	| VarBoxWord64 Word64+	| VarBoxDouble Double+	| VarBoxString Text+	| VarBoxSignature Signature+	| VarBoxObjectPath ObjectPath+	| VarBoxVariant Variant+	| VarBoxArray Array+	| VarBoxDictionary Dictionary+	| VarBoxStructure Structure+	deriving (Eq)++class Variable a where+	toVariant :: a -> Variant+	fromVariant :: Variant -> Maybe a+:++:d 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.++:f DBus/Types.cpphs+instance Show Variant where+	showsPrec d var = showParen (d > 10) full where+		full = s "Variant " . shows code . s " " . valueStr+		code = typeCode $ variantType var+		s = showString+		valueStr = showsPrecVar 11 var++showsPrecVar :: Int -> Variant -> ShowS+showsPrecVar d var = case var of+	(VarBoxBool x) -> showsPrec d x+	(VarBoxWord8 x) -> showsPrec d x+	(VarBoxInt16 x) -> showsPrec d x+	(VarBoxInt32 x) -> showsPrec d x+	(VarBoxInt64 x) -> showsPrec d x+	(VarBoxWord16 x) -> showsPrec d x+	(VarBoxWord32 x) -> showsPrec d x+	(VarBoxWord64 x) -> showsPrec d x+	(VarBoxDouble x) -> showsPrec d x+	(VarBoxString x) -> showsPrec d x+	(VarBoxSignature x) -> showsPrec d x+	(VarBoxObjectPath x) -> showsPrec d x+	(VarBoxVariant x) -> showsPrec d x+	(VarBoxArray x) -> showsPrec d x+	(VarBoxDictionary x) -> showsPrec d x+	(VarBoxStructure x) -> showsPrec d x+:++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}.++:f DBus/Types.cpphs+|apidoc variantType|+variantType :: Variant -> Type+variantType var = case var of+	(VarBoxBool _) -> DBusBoolean+	(VarBoxWord8 _) -> DBusByte+	(VarBoxInt16 _) -> DBusInt16+	(VarBoxInt32 _) -> DBusInt32+	(VarBoxInt64 _) -> DBusInt64+	(VarBoxWord16 _) -> DBusWord16+	(VarBoxWord32 _) -> DBusWord32+	(VarBoxWord64 _) -> DBusWord64+	(VarBoxDouble _) -> DBusDouble+	(VarBoxString _) -> DBusString+	(VarBoxSignature _) -> DBusSignature+	(VarBoxObjectPath _) -> DBusObjectPath+	(VarBoxVariant _) -> DBusVariant+	(VarBoxArray x) -> DBusArray (arrayType x)+	(VarBoxDictionary x) -> let+		keyT = dictionaryKeyType x+		valueT = dictionaryValueType x+		in DBusDictionary keyT valueT+	(VarBoxStructure x) -> let+		Structure items = x+		in DBusStructure (map variantType items)+:++:d type exports+, variantType+:++A macro is useful for reducing verbosity in simple {\tt Variable}+instances.++:f DBus/Types.cpphs+#define INSTANCE_VARIABLE(TYPE) \+	instance Variable TYPE where \+		{ toVariant = VarBox/**/TYPE \+		; fromVariant (VarBox/**/TYPE x) = Just x \+		; fromVariant _ = Nothing \+		}+:++Since {\tt Variant}s are D-Bus values themselves, they can be stored in variants.++:f DBus/Types.cpphs+INSTANCE_VARIABLE(Variant)+:++For testing, {\tt Variant}s are usually generated by type.++:f Tests.hs+instance Arbitrary Variant where+	arbitrary = arbitrary >>= genVariant++genVariant :: Type -> Gen Variant+genVariant t = case t of+	DBusBoolean          -> fmap toVariant (arbitrary :: Gen Bool)+	DBusByte             -> fmap toVariant (arbitrary :: Gen Word8)+	DBusWord16           -> fmap toVariant (arbitrary :: Gen Word16)+	DBusWord32           -> fmap toVariant (arbitrary :: Gen Word32)+	DBusWord64           -> fmap toVariant (arbitrary :: Gen Word64)+	DBusInt16            -> fmap toVariant (arbitrary :: Gen Int16)+	DBusInt32            -> fmap toVariant (arbitrary :: Gen Int32)+	DBusInt64            -> fmap toVariant (arbitrary :: Gen Int64)+	DBusDouble           -> fmap toVariant (arbitrary :: Gen Double)+	DBusString           -> fmap toVariant (arbitrary :: Gen String)+	DBusObjectPath       -> fmap toVariant (arbitrary :: Gen ObjectPath)+	DBusSignature        -> fmap toVariant (arbitrary :: Gen Signature)+	(DBusArray _)        -> fmap toVariant (arbitrary :: Gen Array)+	(DBusDictionary _ _) -> fmap toVariant (arbitrary :: Gen Dictionary)+	(DBusStructure _)    -> fmap toVariant (arbitrary :: Gen Structure)+	DBusVariant          -> fmap toVariant (arbitrary :: Gen Variant)+:++\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.++:d type imports+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Int (Int16, Int32, Int64)+:++:f DBus/Types.cpphs+INSTANCE_VARIABLE(Bool)+INSTANCE_VARIABLE(Word8)+INSTANCE_VARIABLE(Int16)+INSTANCE_VARIABLE(Int32)+INSTANCE_VARIABLE(Int64)+INSTANCE_VARIABLE(Word16)+INSTANCE_VARIABLE(Word32)+INSTANCE_VARIABLE(Word64)+INSTANCE_VARIABLE(Double)+:++\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.++:f DBus/Types.cpphs+instance Variable TL.Text where+	toVariant = VarBoxString+	fromVariant (VarBoxString x) = Just x+	fromVariant _ = Nothing+:++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.++:d type imports+import qualified Data.Text as T+:++:f DBus/Types.cpphs+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.++:d type extensions+{-# LANGUAGE TypeSynonymInstances #-}+:++:f DBus/Types.cpphs+instance Variable String where+	toVariant = toVariant . TL.pack+	fromVariant = fmap TL.unpack . fromVariant+:++All this is verified using some QuickCheck properties++:d test cases+, F.testGroup "String"+	[ testProperty "String -> strict Text"+		$ funEq (fromVariant . toVariant) (Just . T.pack)+	, testProperty "String <- strict Text"+		$ funEq (fromVariant . toVariant) (Just . T.unpack)+	, testProperty "String -> lazy Text"+		$ funEq (fromVariant . toVariant) (Just . TL.pack)+	, testProperty "String <- lazy Text"+		$ funEq (fromVariant . toVariant) (Just . TL.unpack)+	, testProperty "Strict Text -> lazy Text"+		$ funEq (fromVariant . toVariant) (Just . TL.pack . T.unpack)+	, testProperty "Strict Text <- lazy Text"+		$ funEq (fromVariant . toVariant) (Just . T.pack . TL.unpack)+	]+:++\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}.++:f DBus/Types.cpphs+INSTANCE_VARIABLE(Signature)+data Signature = Signature { signatureTypes :: [Type] }+	deriving (Eq)++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.++:f DBus/Types.cpphs+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}.++:d type imports+import Data.Ord (comparing)+:++:f DBus/Types.cpphs+instance Ord Signature where+	compare = comparing strSignature+:++:d 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.++:d type codes+typeCode DBusBoolean    = "b"+typeCode DBusByte       = "y"+typeCode DBusInt16      = "n"+typeCode DBusInt32      = "i"+typeCode DBusInt64      = "x"+typeCode DBusWord16     = "q"+typeCode DBusWord32     = "u"+typeCode DBusWord64     = "t"+typeCode DBusDouble     = "d"+typeCode DBusString     = "s"+typeCode DBusSignature  = "g"+typeCode DBusObjectPath = "o"+typeCode DBusVariant    = "v"+:++An array's type code is ``a'' followed by the type it contains. For example,+an array of booleans would have the type string ``ab''.++:d type codes+typeCode (DBusArray t) = TL.cons 'a' $ typeCode t+:++A dictionary's type code is ``a\{$key\_type$ $value\_type$\}''. For example,+a dictionary of bytes to booleans would have the type string ``a\{yb\}''.++:d type codes+typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"]+:++A structure's type code is the concatenation of its contained types,+wrapped by ``('' and ``)''. Structures may be empty, in which case their+type code is simply ``()''.++:d type codes+typeCode (DBusStructure ts) = TL.concat $+	["("] ++ map typeCode ts ++ [")"]+:++\subsubsection{Parsing}++When parsing, additional restrictions apply which are not inherent to the+D-Bus type system. {\tt mkSignature} guarantees that any {\tt Signature} is+valid according to D-Bus rules.++:f DBus/Types.cpphs+mkSignature :: Text -> Maybe Signature+mkSignature text = parsed where+	|fast signature parser|+	|slow signature parser|+	parsed = case TL.length text of+		0 -> Just $ Signature []+		1 -> fast+		_ -> slow+:++Since single-type and empty signatures are very common, they are+special-cased for performance.++:d fast signature parser+just t = Just $ Signature [t]+fast = case TL.head text of+	'b' -> just DBusBoolean+	'y' -> just DBusByte+	'n' -> just DBusInt16+	'i' -> just DBusInt32+	'x' -> just DBusInt64+	'q' -> just DBusWord16+	'u' -> just DBusWord32+	't' -> just DBusWord64+	'd' -> just DBusDouble+	's' -> just DBusString+	'g' -> just DBusSignature+	'o' -> just DBusObjectPath+	'v' -> just DBusVariant+	_   -> Nothing+:++Parsec is used to parse more complex signatures.++:d type imports+import Text.Parsec ((<|>))+import qualified Text.Parsec as P+import DBus.Util (checkLength, parseMaybe)+:++:d slow signature parser+slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text+sigParser = do+	types <- P.many parseType+	P.eof+	return $ Signature types+:++Types may be either containers or atoms. Containers can't be dictionary+keys.++:d slow signature parser+parseType = parseAtom <|> parseContainer+parseContainer =+	    parseArray+	<|> parseStruct+	<|> (P.char 'v' >> return DBusVariant)+:++:d slow signature parser+parseArray = do+	P.char 'a'+	parseDict <|> fmap DBusArray parseType+parseDict = do+	P.char '{'+	keyType <- parseAtom+	valueType <- parseType+	P.char '}'+	return $ DBusDictionary keyType valueType+:++Structures can contain any types.++:d slow signature parser+parseStruct = do+	P.char '('+	types <- P.many parseType+	P.char ')'+	return $ DBusStructure types+:++:d slow signature parser+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)+:++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.++:d type imports+import DBus.Util (mkUnsafe)+import qualified Data.String as String+:++:f DBus/Types.cpphs+mkSignature_ :: Text -> Signature+mkSignature_ = mkUnsafe "signature" mkSignature++instance String.IsString Signature where+	fromString = mkSignature_ . TL.pack+:++Most signature-related functions are exposed to clients, except the+{\tt Signature} value constructor. If that were exposed, clients could+construct invalid signatures.++:d type exports+, mkSignature+, mkSignature_+:++:f Tests.hs+instance Arbitrary Signature where+	arbitrary = sizedText 255 $ fmap (TL.concat . map typeCode) arbitrary+:++:d test cases+, F.testGroup "Signature"+	[ testProperty "Signature identity"+		$ funEq (mkSignature . strSignature) Just+	]+:++\subsection{Object paths}++:f DBus/Types.cpphs+INSTANCE_VARIABLE(ObjectPath)+newtype ObjectPath = ObjectPath+	{ strObjectPath :: Text+	}+	deriving (Eq, Ord)++instance Show ObjectPath where+	showsPrec d (ObjectPath x) = showParen (d > 10) $+		showString "ObjectPath " . shows x++instance String.IsString ObjectPath where+	fromString = mkObjectPath_ . TL.pack+:++An object path may be one of++\begin{itemize}+\item The root path, {\tt "/"}.+\item {\tt '/'}, followed by one or more element names. Each element name+      contains characters in the set {\tt [a-zA-Z0-9\_]}, and must have at+      least one character.+\end{itemize}++Element names are separated by {\tt '/'}, and the path may not end in+{\tt '/'} unless it is the root path.++:f DBus/Types.cpphs+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+:++:d type exports+  -- * Object paths+, ObjectPath+, strObjectPath+, mkObjectPath+, mkObjectPath_+:++:f Tests.hs+instance Arbitrary ObjectPath where+	arbitrary = fmap (mkObjectPath_ . TL.pack) path' where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"+		path = fmap (intercalate "/" . ([] :)) genElements+		path' = frequency [(1, return "/"), (9, path)]+		genElements = atLeast 1 (atLeast 1 (elements c))+:++:d test cases+, F.testGroup "ObjectPath"+	[ testProperty "ObjectPath identity"+		$ funEq (mkObjectPath . strObjectPath) Just+	]+:++\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.++:d type imports+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as ByteString+:++:f DBus/Types.cpphs+INSTANCE_VARIABLE(Array)+data Array+	= VariantArray Type [Variant]+	| ByteArray ByteString+	deriving (Eq)++|apidoc arrayType|+arrayType :: Array -> Type+arrayType (VariantArray t _) = t+arrayType (ByteArray _) = DBusByte++arrayItems :: Array -> [Variant]+arrayItems (VariantArray _ xs) = xs+arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs+:++:d type exports+  -- * Arrays+, Array+, arrayType+, arrayItems+:++Like {\tt Variant}, deriving {\tt Show} for {\tt Array} is mostly+just useful for debugging.++:f DBus/Types.cpphs+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+			showVar var = showsPrecVar 0 var ""+			valueString = intercalate ", " $ map showVar $ arrayItems array+:++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.++:f DBus/Types.cpphs+arrayFromItems :: Type -> [Variant] -> Maybe Array+arrayFromItems DBusByte vs = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs)++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.++:f DBus/Types.cpphs+toArray :: Variable a => Type -> [a] -> Maybe Array+toArray t = arrayFromItems t . map toVariant++fromArray :: Variable a => Array -> Maybe [a]+fromArray = mapM fromVariant . arrayItems+:++:d 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}++:f DBus/Types.cpphs+arrayToBytes :: Array -> Maybe ByteString+arrayToBytes (ByteArray x) = Just x+arrayToBytes _             = Nothing++arrayFromBytes :: ByteString -> Array+arrayFromBytes = ByteArray+:++:d 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}.++:f DBus/Types.cpphs+instance Variable ByteString where+	toVariant = toVariant . arrayFromBytes+	fromVariant x = fromVariant x >>= arrayToBytes+:++:d type imports+import qualified Data.ByteString as StrictByteString+:++:f DBus/Types.cpphs+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+:++When generating random arrays for testing, only atomic values are used.+Random containers are almost never homogenous.++:f Tests.hs+instance Arbitrary Array where+	arbitrary = do+		t <- atomicType+		xs <- listOf $ genVariant t+		return . fromJust $ arrayFromItems t xs++prop_ArrayHomogeneous vs = isJust array == homogeneousTypes where+	array = arrayFromItems firstType vs+	homogeneousTypes = all (== firstType) types+	types = map variantType vs+	firstType = if null types+		then DBusByte+		else head types+:++:d test cases+, F.testGroup "Array"+	[ testProperty "Array identity"+		$ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x)+	, testProperty "Array homogeneity" prop_ArrayHomogeneous+	]+:++\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.++:f DBus/Types.cpphs+INSTANCE_VARIABLE(Dictionary)+data Dictionary = Dictionary+	{ dictionaryKeyType   :: Type+	, dictionaryValueType :: Type+	, dictionaryItems     :: [(Variant, Variant)]+	}+	deriving (Eq)+:++:d 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.++:d type imports+import Data.List (intercalate)+:++:f DBus/Types.cpphs+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 (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 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.++:d type imports+import Control.Monad (unless)+:++:f DBus/Types.cpphs+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.++:d type imports+import Control.Arrow ((***))+import qualified Data.Map as Map+:++:f DBus/Types.cpphs+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+:++:d type imports+import Control.Monad (forM)+:++:f DBus/Types.cpphs+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+:++:d type exports+, toDictionary+, fromDictionary+, dictionaryFromItems+:++When generating random dictionaries for testing, only atomic values are used.+Random containers are almost never homogenous.++:f Tests.hs+instance Arbitrary Dictionary where+	arbitrary = do+		kt <- atomicType+		vt <- atomicType+		ks <- listOf $ genVariant kt+		vs <- vectorOf (length ks) $ genVariant vt+		+		return . fromJust $ dictionaryFromItems kt vt $ zip ks vs++prop_DictionaryHomogeneous x = all correctType pairs where+	pairs = dictionaryItems x+	kType = dictionaryKeyType x+	vType = dictionaryValueType x+	correctType (k, v) = variantType k == kType &&+	                     variantType v == vType+:++:d test cases+, F.testGroup "Dictionary"+	[ testProperty "Dictionary identity"+		$ \x -> Just x == dictionaryFromItems+			(dictionaryKeyType x)+			(dictionaryValueType x)+			(dictionaryItems x)+	, testProperty "Dictionary homogeneity" prop_DictionaryHomogeneous+	, testProperty "Dictionary must have atomic keys" +		$ \vt -> forAll containerType $ \kt ->+			isNothing (dictionaryFromItems kt vt [])+	, testProperty "Dictionary <-> Array conversion"+		$ funEq (arrayToDictionary . dictionaryToArray) Just+	]+:++\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.++:f DBus/Types.cpphs+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]+:++:f DBus/Types.cpphs+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+:++:d type exports+, dictionaryToArray+, arrayToDictionary+:++\subsection{Structures}++A heterogeneous, fixed-length container; equivalent in purpose to a Haskell+tuple.++:f DBus/Types.cpphs+INSTANCE_VARIABLE(Structure)+data Structure = Structure [Variant]+	deriving (Show, Eq)+:++:d type exports+  -- * Structures+, Structure (..)+:++:f Tests.hs+instance Arbitrary Structure where+	arbitrary = fmap Structure $ halfSized arbitrary+:++\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.++:f DBus/Types.cpphs+#define NAME_TYPE(TYPE, NAME) \+	newtype TYPE = TYPE {str/**/TYPE :: Text} \+		deriving (Eq, Ord); \+		\+	instance Show TYPE where \+		{ showsPrec d (TYPE x) = showParen (d > 10) $ \+			showString "TYPE " . shows x \+		}; \+		\+	instance String.IsString TYPE where \+		{ fromString = mk/**/TYPE/**/_ . TL.pack }; \+		\+	instance Variable TYPE where \+		{ toVariant = toVariant . str/**/TYPE \+		; fromVariant = (mk/**/TYPE =<<) . fromVariant }; \+		                                                \+	mk/**/TYPE/**/_ :: Text -> TYPE; \+	mk/**/TYPE/**/_ = mkUnsafe NAME mk/**/TYPE+:++:d 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.++:f DBus/Types.cpphs+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')+:++:d type exports+  -- ** Bus names+, BusName+, strBusName+, mkBusName+, mkBusName_+:++:f Tests.hs+instance Arbitrary BusName where+	arbitrary = sizedText 255 (oneof [unique, wellKnown]) where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"+		c' = c ++ ['0'..'9']+		+		unique = do+			elems' <- atLeast 2 $ elems c'+			return . TL.pack $ ':' : intercalate "." elems'+		+		wellKnown = do+			elems' <- atLeast 2 $ elems c+			return . TL.pack $ intercalate "." elems'+		+		elems start = do+			x <- elements start+			xs <- atLeast 0 (elements c')+			return (x:xs)+:++:d test cases+, F.testGroup "BusName"+	[ testProperty "BusName identity"+		$ funEq (mkBusName . strBusName) Just+	]+:++\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.++:f DBus/Types.cpphs+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)+:++:d type exports+  -- ** Interface names+, InterfaceName+, strInterfaceName+, mkInterfaceName+, mkInterfaceName_+:++:f Tests.hs+instance Arbitrary InterfaceName where+	arbitrary = sizedText 255 genName where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+		c' = c ++ ['0'..'9']+		+		genName = fmap (TL.pack . intercalate ".") genElements+		genElements = atLeast 2 genElement+		genElement = do+			x <- elements c+			xs <- atLeast 0 (elements c')+			return (x:xs)+:++:d test cases+, F.testGroup "InterfaceName"+	[ testProperty "InterfaceName identity"+		$ funEq (mkInterfaceName . strInterfaceName) Just+	]+:++\subsubsection{Error names}++Error names have the same format as interface names, so the parser logic+can just be re-purposed.++:f DBus/Types.cpphs+NAME_TYPE(ErrorName, "error name")++mkErrorName :: Text -> Maybe ErrorName+mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName+:++:d type exports+  -- ** Error names+, ErrorName+, strErrorName+, mkErrorName+, mkErrorName_+:++:f Tests.hs+instance Arbitrary ErrorName where+	arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary+:++:d test cases+, F.testGroup "ErrorName"+	[ testProperty "ErrorName identity"+		$ funEq (mkErrorName . strErrorName) Just+	]+:++\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.++:f DBus/Types.cpphs+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)+:++:d type exports+  -- ** Member names+, MemberName+, strMemberName+, mkMemberName+, mkMemberName_+:++:f Tests.hs+instance Arbitrary MemberName where+	arbitrary = sizedText 255 genName where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+		c' = c ++ ['0'..'9']+		+		genName = do+			x <- elements c+			xs <- atLeast 0 (elements c')+			return . TL.pack $ (x:xs)+:++:d test cases+, F.testGroup "MemberName"+	[ testProperty "MemberName identity"+		$ funEq (mkMemberName . strMemberName) Just+	]+:
+ src/util.anansi view
@@ -0,0 +1,262 @@+:# Copyright (C) 2009-2010 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{UUIDs}++D-Bus {\sc uuid}s are 128-bit unique identifiers, used for server instances+and machine {\sc id}s. They are not compatible with {\sc rfc4122}.++:f DBus/UUID.hs+|copyright|+module DBus.UUID+	( UUID+	, toHex+	, fromHex+	) where+|text imports|++newtype UUID = UUID Text -- TODO: (Word64, Word64)?+	deriving (Eq)++instance Show UUID where+	showsPrec d uuid = showParen (d > 10) $+		showString "UUID " . shows (toHex uuid)++toHex :: UUID -> Text+toHex (UUID text) = text++fromHex :: Text -> Maybe UUID+fromHex text = if validUUID text+	then Just $ UUID text+	else Nothing++validUUID :: Text -> Bool+validUUID text = valid where+	valid = and [TL.length text == 32, TL.all validChar text]+	validChar c = or+		[ c >= '0' && c <= '9'+		, c >= 'a' && c <= 'f'+		, c >= 'A' && c <= 'F'+		]+:++\section{Misc. utility functions}++:f DBus/Util.hs+|copyright|+module DBus.Util where+import Text.Parsec (Parsec, parse)+import Data.Char (digitToInt)+import Data.List (isPrefixOf)++checkLength :: Int -> String -> Maybe String+checkLength length' s | length s <= length' = Just s+checkLength _ _ = Nothing++parseMaybe :: Parsec String () a -> String -> Maybe a+parseMaybe p = either (const Nothing) Just . parse p ""++mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b+mkUnsafe label f x = case f x of+	Just x' -> x'+	Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x++hexToInt :: String -> Int+hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt++eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe (Left  _) = Nothing+eitherToMaybe (Right x) = Just x++fromRight :: Either a b -> b+fromRight (Right x) = x+fromRight _ = error "DBus.Util.fromRight: Left"++maybeIndex :: [a] -> Int -> Maybe a+maybeIndex (x:_ ) 0         = Just x+maybeIndex (_:xs) n | n > 0 = maybeIndex xs (n - 1)+maybeIndex _ _ = Nothing++-- | Read values from a monad until a guard value is read; return all+-- values, including the guard.+--+readUntil :: (Monad m, Eq a) => [a] -> m a -> m [a]+readUntil guard getx = readUntil' [] where+	guard' = reverse guard+	step xs | isPrefixOf guard' xs = return . reverse $ xs+	        | otherwise            = readUntil' xs+	readUntil' xs = do+		x <- getx+		step $ x:xs++-- | Drop /n/ items from the end of a list+dropEnd :: Int -> [a] -> [a]+dropEnd n xs = take (length xs - n) xs+:++\subsection{Bundled ErrorT variant}++The default {\tt ErrorT} type in the {\tt transformers} package has an idiotic+dependency on the {\tt Error} class, which is used to implement the obsolete+{\tt fail} function. This module is a variant, which doesn't include this+dependency.++:f DBus/Util/MonadError.hs+|copyright|+{-# LANGUAGE TypeFamilies #-}+module DBus.Util.MonadError+	( ErrorT (..)+	, throwError+	) where+import Control.Monad.Trans.Class+import Control.Monad.State+import Control.Monad.Error.Class++newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }++instance Functor m => Functor (ErrorT e m) where+	fmap f = ErrorT . fmap (fmap f) . runErrorT++instance Monad m => Monad (ErrorT e m) where+	return = ErrorT . return . Right+	(>>=) m k = ErrorT $ do+		x <- runErrorT m+		case x of+			Left l -> return $ Left l+			Right r -> runErrorT $ k r++instance MonadTrans (ErrorT e) where+	lift = ErrorT . liftM Right++instance Monad m => MonadError (ErrorT e m) where+	type ErrorType (ErrorT e m) = e+	throwError = ErrorT . return . Left+	catchError m h = ErrorT $ do+		x <- runErrorT m+		case x of+			Left l -> runErrorT $ h l+			Right r -> return $ Right r++instance MonadState m => MonadState (ErrorT e m) where+	type StateType (ErrorT e m) = StateType m+	get = lift get+	put = lift . put+:++\subsection{Extra test support}++The test suite requires a whole bunch of imports++:d test imports+import Test.QuickCheck+import qualified Test.Framework as F+import Test.Framework.Providers.QuickCheck2 (testProperty)++import Control.Arrow ((&&&))+import Control.Monad (replicateM)+import qualified Data.Binary.Get as G+import Data.Char (isPrint)+import Data.String+import Data.List (intercalate, isInfixOf)+import Data.Maybe (fromJust, isJust, isNothing)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Int (Int16, Int32, Int64)++import DBus.Address+import DBus.Message.Internal+import DBus.Types+import DBus.Wire.Internal+import DBus.Wire.Marshal+import DBus.Wire.Unmarshal+import qualified DBus.Introspection as I+:++:f Tests.hs+halfSized :: Gen a -> Gen a+halfSized gen = sized $ \n -> if n > 0 then+	resize (n `div` 2) gen+	else gen++funEq :: Eq b => (a -> b) -> (a -> b) -> a -> Bool+funEq f g x = f x == g x++sizedText :: (IsString a, Arbitrary a) => Integer -> Gen TL.Text -> Gen a+sizedText maxSize gen = step where+	step = do+		s <- gen+		if toInteger (TL.length s) > maxSize+			then halfSized step+			else return . fromString . TL.unpack $ s++atLeast :: Int -> Gen a -> Gen [a]+atLeast minSize g = sized $ \n -> do+	count <- choose (minSize, max minSize n)+	replicateM count g++isRight :: Either a b -> Bool+isRight = either (const False) (const True)+:++Some tests, such as address parsing, are single-case tests instead of+the more common ``property''. This function lets them be run only once.++:f Tests.hs+test :: Testable a => F.TestName -> a -> F.Test+test name prop = F.plusTestOptions options (testProperty name prop) where+	options = F.TestOptions Nothing (Just 1) Nothing Nothing+:++QuickCheck doesn't define instances for fixed-size integral types or+variants of {\tt Text}, so define them here.++:f Tests.hs+instance Arbitrary Word8 where+	arbitrary = arbitraryBoundedIntegral+	shrink    = shrinkIntegral++instance Arbitrary Word16 where+	arbitrary = arbitraryBoundedIntegral+	shrink    = shrinkIntegral++instance Arbitrary Word32 where+	arbitrary = arbitraryBoundedIntegral+	shrink    = shrinkIntegral++instance Arbitrary Word64 where+	arbitrary = arbitraryBoundedIntegral+	shrink    = shrinkIntegral++instance Arbitrary Int16 where+	arbitrary = arbitraryBoundedIntegral+	shrink    = shrinkIntegral++instance Arbitrary Int32 where+	arbitrary = arbitraryBoundedIntegral+	shrink    = shrinkIntegral++instance Arbitrary Int64 where+	arbitrary = arbitraryBoundedIntegral+	shrink    = shrinkIntegral++instance Arbitrary T.Text where+	arbitrary = fmap T.pack arbitrary++instance Arbitrary TL.Text where+	arbitrary = fmap TL.pack arbitrary+:
+ src/wire.anansi view
@@ -0,0 +1,1170 @@+:# Copyright (C) 2009-2010 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{Wire format}++{\tt DBus.Wire} is also split into an internal and external interface.++:f DBus/Wire.hs+|copyright|+module DBus.Wire (+	|wire exports|+	) where+import DBus.Wire.Internal+import DBus.Wire.Marshal+import DBus.Wire.Unmarshal+:++:f DBus/Wire/Internal.hs+|copyright|+module DBus.Wire.Internal where+import Data.Word (Word8, Word64)+import qualified DBus.Types as T+:++\subsection{Endianness}++:f 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+:++:d wire exports+  Endianness (..)+:++:f Tests.hs+instance Arbitrary Endianness where+	arbitrary = elements [LittleEndian, BigEndian]+:++\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.++:f 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.++:f DBus/Wire/Marshal.hs+|copyright|+{-# LANGUAGE TypeFamilies #-}+module DBus.Wire.Marshal where+|text imports|+|marshal imports|+import DBus.Wire.Internal+import Control.Monad (when)+import Data.Maybe (fromJust)+import Data.Word (Word8, Word32, Word64)+import Data.Int (Int16, Int32, Int64)++import qualified DBus.Types as T+:++:d marshal imports+import qualified Control.Monad.State as State+import qualified DBus.Util.MonadError as E+import qualified Data.ByteString.Lazy as L+import qualified Data.Binary.Builder as B+:++:f DBus/Wire/Marshal.hs+data MarshalState = MarshalState Endianness B.Builder !Word64+type MarshalM = E.ErrorT MarshalError (State.State 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.++:f DBus/Wire/Marshal.hs+runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString+runMarshal m e = case State.runState (E.runErrorT m) initialState of+	(Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder)+	(Left  x, _) -> Left x+	where initialState = MarshalState e B.empty 0+:++:f DBus/Wire/Marshal.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++:f DBus/Wire/Marshal.hs+append :: L.ByteString -> Marshal+append bytes = do+	(MarshalState e builder count) <- State.get+	let builder' = B.append builder $ B.fromLazyByteString bytes+	    count' = count + fromIntegral (L.length bytes)+	State.put $ MarshalState e builder' count'+:++:f DBus/Wire/Marshal.hs+pad :: Word8 -> Marshal+pad count = do+	(MarshalState _ _ existing) <- State.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.++:f DBus/Wire/Marshal.hs+marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal+marshalBuilder size be le x = do+	pad size+	(MarshalState e builder count) <- State.get+	let builder' = B.append builder $ case e of+		BigEndian -> be x+		LittleEndian -> le x+	let count' = count + fromIntegral size+	State.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}++:f DBus/Wire/Marshal.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]+:++:d wire exports+, MarshalError (..)+:++\subsection{Unmarshaling}++Unmarshaling also uses an error transformer and internal state.++:f DBus/Wire/Unmarshal.hs+|copyright|+|text extensions|+{-# LANGUAGE TypeFamilies #-}+module DBus.Wire.Unmarshal where+|text imports|+|unmarshal imports|+import Control.Monad (when, unless, liftM)+import Data.Maybe (fromJust, listToMaybe, fromMaybe)+import Data.Word (Word8, Word32, Word64)+import Data.Int (Int16, Int32, Int64)++import DBus.Wire.Internal+import qualified DBus.Types as T+:++:d unmarshal imports+import qualified Control.Monad.State as State+import Control.Monad.Trans.Class (lift)+import qualified DBus.Util.MonadError as E+import qualified Data.ByteString.Lazy as L+:++:f DBus/Wire/Unmarshal.hs+data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64+type Unmarshal = E.ErrorT UnmarshalError (State.State UnmarshalState)+:++:f DBus/Wire/Unmarshal.hs+runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a+runUnmarshal m e bytes = State.evalState (E.runErrorT m) state where+	state = UnmarshalState e bytes 0+:++:f DBus/Wire/Unmarshal.hs+unmarshal :: T.Signature -> Unmarshal [T.Variant]+unmarshal = mapM unmarshalType . T.signatureTypes++unmarshalType :: T.Type -> Unmarshal T.Variant+|unmarshalers|+:++TODO: describe these functions++:f DBus/Wire/Unmarshal.hs+consume :: Word64 -> Unmarshal L.ByteString+consume count = do+	(UnmarshalState e bytes offset) <- State.get+	let (x, bytes') = L.splitAt (fromIntegral count) bytes+	unless (L.length x == fromIntegral count) $+		E.throwError $ UnexpectedEOF offset+	+	State.put $ UnmarshalState e bytes' (offset + count)+	return x+:++:f DBus/Wire/Unmarshal.hs+skipPadding :: Word8 -> Unmarshal ()+skipPadding count = do+	(UnmarshalState _ _ offset) <- State.get+	bytes <- consume $ padding offset count+	unless (L.all (== 0) bytes) $+		E.throwError $ InvalidPadding offset+:++:f DBus/Wire/Unmarshal.hs+skipTerminator :: Unmarshal ()+skipTerminator = do+	(UnmarshalState _ _ offset) <- State.get+	bytes <- consume 1+	unless (L.all (== 0) bytes) $+		E.throwError $ MissingTerminator offset+:++:f DBus/Wire/Unmarshal.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'+:++:d unmarshal imports+import qualified Data.Binary.Get as G+:++:f DBus/Wire/Unmarshal.hs+unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a+unmarshalGet count be le = do+	skipPadding count+	(UnmarshalState e _ _) <- State.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+:++:f DBus/Wire/Unmarshal.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}++:f DBus/Wire/Unmarshal.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"+:++:d wire exports+, UnmarshalError (..)+:++\subsection{Numerics}++Numeric values are fixed-length, and aligned ``naturally'' -- ie, a 4-byte+integer will have a 4-byte alignment.++:d 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.++:f DBus/Wire/Marshal.hs+marshalWord32 :: Word32 -> Marshal+marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le+:++:f DBus/Wire/Unmarshal.hs+unmarshalWord32 :: Unmarshal Word32+unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le+:++:d 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)+:++:d 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.++:d marshal imports+import Data.Binary.Put (runPut)+import qualified Data.Binary.IEEE754 as IEEE+:++:d unmarshal imports+import qualified Data.Binary.IEEE754 as IEEE+:++:d marshalers+marshalType T.DBusDouble = do+	pad 8+	(MarshalState e _ _) <- State.get+	let put = case e of+		BigEndian -> IEEE.putFloat64be+		LittleEndian -> IEEE.putFloat64le+	let bytes = runPut $ put x+	append bytes+:++:d 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.++:d alignments+alignment T.DBusBoolean = 4+:++:d marshalers+marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0+:++:d 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.++:f DBus/Wire/Unicode.hs+|copyright|+module DBus.Wire.Unicode+	( maybeEncodeUtf8+	, maybeDecodeUtf8) where+import Data.ByteString.Lazy (ByteString)+import Data.Text.Lazy (Text)+import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)+import Data.Text.Encoding.Error (UnicodeException)+import qualified Control.Exception as Exc+import System.IO.Unsafe (unsafePerformIO)++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 ByteString+maybeEncodeUtf8 = excToMaybe . encodeUtf8++maybeDecodeUtf8 :: ByteString -> Maybe Text+maybeDecodeUtf8 = excToMaybe . decodeUtf8+:++:d marshal imports+import DBus.Wire.Unicode (maybeEncodeUtf8)+:++:f DBus/Wire/Marshal.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)+:++:d unmarshal imports+import DBus.Wire.Unicode (maybeDecodeUtf8)+:++:f DBus/Wire/Unmarshal.hs+unmarshalText :: Unmarshal Text+unmarshalText = do+	byteCount <- unmarshalWord32+	bytes <- consume . fromIntegral $ byteCount+	skipTerminator+	fromMaybeU "text" maybeDecodeUtf8 bytes+:++:d alignments+alignment T.DBusString     = 4+alignment T.DBusObjectPath = 4+:++:d marshalers+marshalType T.DBusString = marshalText x+marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x+:++:d 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.++:d marshal imports+import Data.Text.Lazy.Encoding (encodeUtf8)+:++:f DBus/Wire/Marshal.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)+:++:f DBus/Wire/Unmarshal.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+:++:d alignments+alignment T.DBusSignature  = 1+:++:d marshalers+marshalType T.DBusSignature = marshalSignature x+:++:d unmarshalers+unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature+:++\subsection{Containers}++\subsubsection{Arrays}++:d alignments+alignment (T.DBusArray _) = 4+:++:d marshalers+marshalType (T.DBusArray _) = marshalArray x+:++:d 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.++:d marshal imports+import qualified DBus.Constants as C+:++:f DBus/Wire/Marshal.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+:++:f DBus/Wire/Marshal.hs+getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString)+getArrayBytes T.DBusByte x = return (0, bytes) where+	Just bytes = T.arrayToBytes x+:++:f DBus/Wire/Marshal.hs+getArrayBytes itemType x = do+	let vs = T.arrayItems x+	s <- State.get+	(MarshalState _ _ afterLength) <- marshalWord32 0 >> State.get+	(MarshalState e _ afterPadding) <- pad (alignment itemType) >> State.get+	+	State.put $ MarshalState e B.empty afterPadding+	(MarshalState _ itemBuilder _) <- mapM_ marshal vs >> State.get+	+	let itemBytes = B.toLazyByteString itemBuilder+	    paddingSize = fromIntegral $ afterPadding - afterLength+	+	State.put s+	return (paddingSize, itemBytes)+:++Unmarshaling is much easier, especially if it's a byte array.++:f DBus/Wire/Unmarshal.hs+unmarshalArray :: T.Type -> Unmarshal T.Array+unmarshalArray T.DBusByte = do+	byteCount <- unmarshalWord32+	T.arrayFromBytes `fmap` consume (fromIntegral byteCount)+:++:f DBus/Wire/Unmarshal.hs+unmarshalArray itemType = do+	let getOffset = do+		(UnmarshalState _ _ o) <- State.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}++:d alignments+alignment (T.DBusDictionary _ _) = 4+:++:d marshalers+marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x)+:++:d unmarshalers+unmarshalType (T.DBusDictionary kt vt) = do+	let pairType = T.DBusStructure [kt, vt]+	array <- unmarshalArray pairType+	fromMaybeU' "dictionary" T.arrayToDictionary array+:++\subsubsection{Structures}++:d alignments+alignment (T.DBusStructure _) = 8+:++:d marshalers+marshalType (T.DBusStructure _) = do+	let T.Structure vs = x+	pad 8+	mapM_ marshal vs+:++:d unmarshalers+unmarshalType (T.DBusStructure ts) = do+	skipPadding 8+	fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts+:++\subsubsection{Variants}++:d alignments+alignment T.DBusVariant = 1+:++:d 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+:++:d 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}++:d marshal imports+import qualified DBus.Message.Internal as M+:++:d unmarshal imports+import qualified DBus.Message.Internal as M+:++\subsubsection{Flags}++:d unmarshal imports+import Data.Bits ((.&.))+import qualified Data.Set as Set+:++:d marshal imports+import Data.Bits ((.|.))+import qualified Data.Set as Set+:++:f DBus/Wire/Marshal.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+:++:f DBus/Wire/Unmarshal.hs+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}++:f DBus/Wire/Marshal.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+	]+:++:f DBus/Wire/Unmarshal.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+:++:f DBus/Wire/Unmarshal.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}++:d wire exports+, marshalMessage+:++:f DBus/Wire/Marshal.hs+|apidoc marshalMessage|+marshalMessage :: M.Message a => Endianness -> M.Serial -> a+               -> Either MarshalError L.ByteString+marshalMessage e serial msg = runMarshal marshaler e where+	body = M.messageBody msg+	marshaler = do+		sig <- checkBodySig body+		empty <- State.get+		mapM_ marshal body+		(MarshalState _ bodyBytesB _) <- State.get+		State.put empty+		marshalEndianness e+		let bodyBytes = B.toLazyByteString bodyBytesB+		marshalHeader msg serial sig+			$ fromIntegral . L.length $ bodyBytes+		pad 8+		append bodyBytes+		checkMaximumSize+:++:f DBus/Wire/Marshal.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+:++:f DBus/Wire/Marshal.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+:++:f DBus/Wire/Marshal.hs+marshalEndianness :: Endianness -> Marshal+marshalEndianness = marshal . T.toVariant . encodeEndianness+:++:f DBus/Wire/Marshal.hs+checkMaximumSize :: Marshal+checkMaximumSize = do+	(MarshalState _ _ messageLength) <- State.get+	when (messageLength > fromIntegral C.messageMaximumLength)+		(E.throwError $ MessageTooLong $ fromIntegral messageLength)+:++\subsubsection{Unmarshaling}++:d unmarshal imports+import qualified DBus.Constants as C+:++:d wire exports+, unmarshalMessage+:++:f DBus/Wire/Unmarshal.hs+|apidoc unmarshalMessage|+unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)+                 -> m (Either UnmarshalError M.ReceivedMessage)+unmarshalMessage getBytes' = E.runErrorT $ do+	let getBytes = 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.++:d read fixed-length header+let fixedSig = "yyyyuuu"+fixedBytes <- getBytes 16+:++The first field of interest is the protocol version; if the incoming+message's version is different from this library, the message cannot be+parsed.++:d 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.++:d 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++:d 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.++:d 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.++:d read full header+let headerSig  = "yyyyuua(yv)"+fieldBytes <- getBytes fieldByteCount+let headerBytes = L.append fixedBytes fieldBytes+header <- unmarshal' headerSig headerBytes+:++And the header fields can be parsed.++:d read full header+let fieldArray = fromJust . T.fromVariant $ header !! 6+let fieldStructures = fromJust . T.fromArray $ fieldArray+fields <- concat `liftM` mapM decodeField fieldStructures+:++The body is always aligned to 8 bytes, so pull out the padding before+unmarshaling it.++:d read body+let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8+getBytes . fromIntegral $ bodyPadding+:++:f DBus/Wire/Unmarshal.hs+findBodySignature :: [M.HeaderField] -> T.Signature+findBodySignature fields = fromMaybe "" signature where+	signature = listToMaybe [x | M.Signature x <- fields]+:++:d read body+let bodySig = findBodySignature fields+:++Then pull the body bytes, and unmarshal it.++:d read body+bodyBytes <- getBytes bodyLength+body <- unmarshal' bodySig bodyBytes+:++Even if the received message was structurally valid, building the+{\tt ReceivedMessage} can still fail due to missing header fields.++Slightly ugly; to avoid orphan instances of either {\tt Text} or+{\tt Either}, a newtype is used to turn {\tt Either} into a monad.++:f DBus/Wire/Unmarshal.hs+newtype EitherM a b = EitherM (Either a b)++instance Monad (EitherM a) where+	return = EitherM . Right+	(EitherM (Left x)) >>= _ = EitherM (Left x)+	(EitherM (Right x)) >>= k = k x+:++:d build message+y <- case buildReceivedMessage typeCode fields of+	EitherM (Right x) -> return x+	EitherM (Left x) -> E.throwError $ MissingHeaderField x+return $ y serial flags body+:++This really belongs in the Message section...++:f DBus/Wire/Unmarshal.hs+buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text+                        (M.Serial -> (Set.Set M.Flag) -> [T.Variant]+                         -> M.ReceivedMessage)+:++Method calls++:f DBus/Wire/Unmarshal.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++:f DBus/Wire/Unmarshal.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++:f DBus/Wire/Unmarshal.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++:f DBus/Wire/Unmarshal.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++:f DBus/Wire/Unmarshal.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+:++:f DBus/Wire/Unmarshal.hs+require :: Text -> [a] -> EitherM Text a+require _     (x:_) = return x+require label _     = EitherM $ Left label+:++:f Tests.hs+prop_Unmarshal :: Endianness -> Variant -> Property+prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where+	sig = mkSignature . typeCode . variantType $ x+	Just sig' = sig+	+	bytes = runMarshal (marshal x) e+	Right bytes' = bytes+	+	valid = isJust sig && isRight bytes+	unmarshaled = runUnmarshal (unmarshal sig') e bytes'++prop_MarshalMessage e serial msg expected = valid ==> correct where+	bytes = marshalMessage e serial msg+	Right bytes' = bytes+	+	getBytes = G.getLazyByteString . fromIntegral+	unmarshaled = G.runGet (unmarshalMessage getBytes) bytes'+	+	valid = isRight bytes+	correct = unmarshaled == Right expected++prop_WireMethodCall e serial msg = prop_MarshalMessage e serial msg+	$ ReceivedMethodCall serial Nothing msg++prop_WireMethodReturn e serial msg = prop_MarshalMessage e serial msg+	$ ReceivedMethodReturn serial Nothing msg++prop_WireError e serial msg = prop_MarshalMessage e serial msg+	$ ReceivedError serial Nothing msg++prop_WireSignal e serial msg = prop_MarshalMessage e serial msg+	$ ReceivedSignal serial Nothing msg+:++:d test cases+, F.testGroup "Wire format"+	[ testProperty "Marshal -> Ummarshal" prop_Unmarshal+	, F.testGroup "Messages"+		[ testProperty "Method calls" prop_WireMethodCall+		, testProperty "Method returns" prop_WireMethodReturn+		, testProperty "Errors" prop_WireError+		, testProperty "Signals" prop_WireSignal+		]+	]+: