dbus-core 0.7 → 0.8

raw patch · 18 files changed

+1017/−338 lines, 18 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Examples/dbus-monitor.hs +11/−8
• Examples/simple.hs +64/−0
• Makefile +2/−0
• Tests.nw +7/−7
• dbus-core.cabal +19/−15
• dbus-core.nw +488/−156
• hs/DBus/Authentication.hs +100/−0
• hs/DBus/Bus.hs +24/−6
• hs/DBus/Connection.hs +51/−47
• hs/DBus/Constants.hs +47/−47
• hs/DBus/MatchRule.hs +28/−1
• hs/DBus/Message.hs +2/−0
• hs/DBus/Message/Internal.hs +7/−0
• hs/DBus/NameReservation.hs +6/−2
• hs/DBus/Types.hs +73/−36
• hs/DBus/UUID.hs +50/−0
• hs/DBus/Util.hs +17/−0
• hs/DBus/Wire/Internal.hs +21/−13

@@ -18,11 +18,13 @@ {-# LANGUAGE OverloadedStrings #-}  import DBus.Address+import DBus.Authentication import DBus.Bus import DBus.Connection import DBus.Constants import DBus.Message import DBus.Types+import DBus.Wire  import Control.Monad import qualified Data.Set as Set@@ -61,18 +63,19 @@ 	BusOption Session -> getSessionBus 	BusOption System  -> getSystemBus 	AddressOption addr -> case mkAddresses (TL.pack addr) of-			Just [x] -> getBus x-			Just  x  -> getFirstBus x+			Just [x] -> getBus realUserID x+			Just  xs -> getFirstBus [(realUserID, addr) | addr <- xs] 			_        -> error $ "Invalid address: " ++ show addr  addMatchMsg :: String -> MethodCall addMatchMsg match = MethodCall-	dbusPath-	(mkMemberName' "AddMatch")-	(Just dbusInterface)-	(Just dbusName)-	Set.empty-	[toVariant match]+	{ methodCallPath = dbusPath+	, methodCallMember = "AddMatch"+	, methodCallInterface = Just dbusInterface+	, methodCallDestination = Just dbusName+	, methodCallFlags = Set.empty+	, methodCallBody = [toVariant match]+	}  addMatch :: Connection -> String -> IO () addMatch c s = send c return (addMatchMsg s) >> return ()

@@ -0,0 +1,64 @@+-- Copyright (C) 2009 John Millikin <jmillikin@gmail.com>+-- +-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- any later version.+-- +-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import DBus.Bus+import DBus.Connection+import DBus.Message+import DBus.Types+import qualified Data.Set as Set+import Data.List (sort)++main :: IO ()+main = do+	-- Connect to the bus, and print which name was assigned to this+	-- connection.+	(bus, name) <- getSessionBus+	putStrLn $ "Connected as: " ++ show name+	+	-- Request a list of connected clients from the bus+	Right serial <- send bus return $ MethodCall+		{ methodCallPath = "/org/freedesktop/DBus"+		, methodCallMember = "ListNames"+		, methodCallInterface = Just "org.freedesktop.DBus"+		, methodCallDestination = Just "org.freedesktop.DBus"+		, methodCallFlags = Set.empty+		, methodCallBody = []+		}+	+	-- Wait for the reply+	reply <- waitForReply bus serial+	+	-- Pull out the body, and convert it to [String]+	let Just names = fromArray =<< fromVariant (messageBody reply !! 0)+	+	-- Print each name on a line, sorted so reserved names are below+	-- temporary names.+	mapM_ putStrLn $ sort names++waitForReply :: Connection -> Serial -> IO MethodReturn+waitForReply bus serial = wait where+	wait = do+		received <- receive bus+		case received of+			Right (ReceivedMethodReturn _ _ ret) ->+				if methodReturnSerial ret == serial+					then return ret+					else wait+			Right _ -> wait+			Left err -> error $ show err+

@@ -1,5 +1,6 @@ HS_SOURCES=\ 	hs/DBus/Address.hs \+	hs/DBus/Authentication.hs \ 	hs/DBus/Bus.hs \ 	hs/DBus/Connection.hs \ 	hs/DBus/Constants.hs \@@ -10,6 +11,7 @@ 	hs/DBus/NameReservation.hs \ 	hs/DBus/Types.hs \ 	hs/DBus/Util.hs \+	hs/DBus/UUID.hs \ 	hs/DBus/Wire.hs \ 	hs/DBus/Wire/Internal.hs \ 	hs/Tests.hs

@@ -128,7 +128,7 @@ 	arbitrary = oneof [atomicType, containerType]  instance Arbitrary Signature where-	arbitrary = clampedSize 255 genSig mkSignature' where+	arbitrary = clampedSize 255 genSig mkSignature_ where 		genSig = fmap (TL.concat . map typeCode) arbitrary  <<atom tests>>=@@ -141,7 +141,7 @@  <<Tests.hs>>= instance Arbitrary ObjectPath where-	arbitrary = fmap (mkObjectPath' . TL.pack) path' 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)]@@ -155,7 +155,7 @@  <<Tests.hs>>= instance Arbitrary BusName where-	arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName' where+	arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName_ where 		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" 		c' = c ++ ['0'..'9'] 		@@ -180,7 +180,7 @@  <<Tests.hs>>= instance Arbitrary InterfaceName where-	arbitrary = clampedSize 255 genName mkInterfaceName' where+	arbitrary = clampedSize 255 genName mkInterfaceName_ where 		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" 		c' = c ++ ['0'..'9'] 		@@ -199,7 +199,7 @@  <<Tests.hs>>= instance Arbitrary ErrorName where-	arbitrary = fmap (mkErrorName' . strInterfaceName) arbitrary+	arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary  <<atom tests>>= , testGroup "ErrorName" $ commonVariantTests (arbitrary :: Gen ErrorName) ++@@ -209,7 +209,7 @@  <<Tests.hs>>= instance Arbitrary MemberName where-	arbitrary = clampedSize 255 genName mkMemberName' where+	arbitrary = clampedSize 255 genName mkMemberName_ where 		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" 		c' = c ++ ['0'..'9'] 		@@ -562,7 +562,7 @@ 	let path' = case strObjectPath parentPath of 		"/" -> thisPath 		x   -> TL.append x thisPath-	let path = mkObjectPath' path'+	let path = mkObjectPath_ path' 	ifaces <- arbitrary 	children <- shrinkingGen . listOf . subObject $ path 	return $ I.Object path ifaces children

@@ -1,7 +1,7 @@ name: dbus-core-version: 0.7+version: 0.8 synopsis: Low-level D-Bus protocol implementation-license: GPL+license: GPL-3 license-file: License.txt author: John Millikin maintainer: jmillikin@gmail.com@@ -10,6 +10,8 @@ category: Network, Desktop stability: experimental bug-reports: mailto:jmillikin@gmail.com+homepage: http://ianen.org/haskell/dbus/+tested-with: GHC==6.10.4  extra-source-files:   dbus-core.nw@@ -19,7 +21,7 @@  source-repository head   type: darcs-  location: http://patch-tag.com/r/jmillikin/dbus-core/pullrepo+  location: http://ianen.org/haskell/dbus/core/  flag test   default: False@@ -32,21 +34,22 @@   hs-source-dirs: hs    build-depends:-    base >=4 && < 5,-    parsec >= 3.0.0,-    binary,-    bytestring,-    data-binary-ieee754 >= 0.3,-    HaXml >= 1.19.7,-    pretty,-    text,-    mtl,-    containers,-    unix,-    network+      base >=4 && < 5+    , parsec >= 3.0.0+    , binary+    , bytestring+    , data-binary-ieee754 >= 0.3+    , HaXml >= 1.19.7+    , pretty+    , text+    , mtl+    , containers+    , unix+    , network    exposed-modules:     DBus.Address+    DBus.Authentication     DBus.Bus     DBus.Connection     DBus.Constants@@ -55,6 +58,7 @@     DBus.Message     DBus.NameReservation     DBus.Types+    DBus.UUID     DBus.Wire    other-modules:

@@ -127,6 +127,7 @@ 	deriving (Show, Eq)  <<DBus/Types.hs>>=+<<apidoc isAtomicType>> isAtomicType :: Type -> Bool isAtomicType DBusBoolean    = True isAtomicType DBusByte       = True@@ -146,7 +147,9 @@ signatures'' or for debugging.  <<DBus/Types.hs>>=+<<apidoc typeCode>> typeCode :: Type -> Text+<<type codes>>  <<type exports>>=   -- * Available types@@ -182,6 +185,7 @@ pre-defined types.  <<DBus/Types.hs>>=+<<apidoc Variant>> data Variant = forall a. (Variable a, Builtin a, Typeable a) => Variant a 	deriving (Typeable) @@ -217,6 +221,7 @@ a {\tt Variant}.  <<DBus/Types.hs>>=+<<apidoc variantType>> variantType :: Variant -> Type variantType (Variant x) = builtinDBusType x @@ -362,7 +367,7 @@ @ For atomic types, the type code is a single letter. Arrays, structures, and dictionary types are multiple characters. -<<DBus/Types.hs>>=+<<type codes>>= typeCode DBusBoolean    = "b" typeCode DBusByte       = "y" typeCode DBusInt16      = "n"@@ -380,20 +385,20 @@ @ An array's type code is ``a'' followed by the type it contains. For example, an array of booleans would have the type string ``ab''. -<<DBus/Types.hs>>=+<<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\}''. -<<DBus/Types.hs>>=+<<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 ``()''. -<<DBus/Types.hs>>=+<<type codes>>= typeCode (DBusStructure ts) = TL.concat $ 	["("] ++ map typeCode ts ++ [")"] @@ -463,16 +468,23 @@ import DBus.Util (mkUnsafe)  <<DBus/Types.hs>>=-mkSignature' :: Text -> Signature-mkSignature' = mkUnsafe "signature" mkSignature+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'+, mkSignature_  @ \subsection{Object paths} @@ -481,8 +493,15 @@ newtype ObjectPath = ObjectPath 	{ strObjectPath :: Text 	}-	deriving (Show, Eq, Ord, Typeable)+	deriving (Eq, Ord, Typeable) +instance Show ObjectPath where+	showsPrec d (ObjectPath x) = showParen (d > 10) $+		showString "ObjectPath " . shows x++instance String.IsString ObjectPath where+	fromString = mkObjectPath_ . TL.pack+ @ An object path may be one of  \begin{itemize}@@ -502,15 +521,15 @@ 	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+mkObjectPath_ :: Text -> ObjectPath+mkObjectPath_ = mkUnsafe "object path" mkObjectPath  <<type exports>>=   -- * Object paths , ObjectPath , strObjectPath , mkObjectPath-, mkObjectPath'+, mkObjectPath_  @ \subsection{Arrays} @@ -535,6 +554,7 @@ instance Builtin Array where 	builtinDBusType = DBusArray . arrayType +<<apidoc arrayType>> arrayType :: Array -> Type arrayType (VariantArray t _) = t arrayType (ByteArray _) = DBusByte@@ -778,14 +798,22 @@ <<DBus/Types.hs>>= #define NAME_TYPE(TYPE, NAME) \ 	newtype TYPE = TYPE {str##TYPE :: Text} \-		deriving (Show, Eq, Ord); \-		                          \+		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+	mk##TYPE##_ :: Text -> TYPE; \+	mk##TYPE##_ = mkUnsafe NAME mk##TYPE  <<type exports>>= -- * Names@@ -820,7 +848,7 @@ , BusName , strBusName , mkBusName-, mkBusName'+, mkBusName_  @ \subsubsection{Interface names} @@ -844,7 +872,7 @@ , InterfaceName , strInterfaceName , mkInterfaceName-, mkInterfaceName'+, mkInterfaceName_  @ \subsubsection{Error names} @@ -862,7 +890,7 @@ , ErrorName , strErrorName , mkErrorName-, mkErrorName'+, mkErrorName_  @ \subsubsection{Member names} @@ -884,7 +912,7 @@ , MemberName , strMemberName , mkMemberName-, mkMemberName'+, mkMemberName_  @ \section{Messages}@@ -957,6 +985,7 @@ added type-safety.  <<DBus/Message/Internal.hs>>=+<<apidoc Serial>> newtype Serial = Serial { serialValue :: Word32 } 	deriving (Eq, Ord) @@ -982,6 +1011,8 @@ <<message exports>>= , Serial , serialValue+, firstSerial+, nextSerial  @ \subsection{Message types} @@ -1133,6 +1164,7 @@ 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@@ -1875,6 +1907,7 @@ , marshalMessage  <<DBus/Wire/Internal.hs>>=+<<apidoc marshalMessage>> marshalMessage :: M.Message a => Endianness -> M.Serial -> a                -> Either MarshalError L.ByteString marshalMessage e serial msg = runMarshal marshaler e where@@ -1933,6 +1966,7 @@ , unmarshalMessage  <<DBus/Wire/Internal.hs>>=+<<apidoc unmarshalMessage>> unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)                  -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do@@ -1947,7 +1981,7 @@ retrieved without any size calculations.  <<read fixed-length header>>=-let fixedSig = T.mkSignature' "yyyyuuu"+let fixedSig = "yyyyuuu" fixedBytes <- getBytes 16  @ The first field of interest is the protocol version; if the incoming@@ -1991,7 +2025,7 @@ pulled out of the monad.  <<read full header>>=-let headerSig  = T.mkSignature' "yyyyuua(yv)"+let headerSig  = "yyyyuua(yv)" fieldBytes <- getBytes fieldByteCount let headerBytes = L.append fixedBytes fieldBytes header <- unmarshal' headerSig headerBytes@@ -2012,8 +2046,7 @@  <<DBus/Wire/Internal.hs>>= findBodySignature :: [M.HeaderField] -> T.Signature-findBodySignature fields = fromMaybe empty signature where-	empty = T.mkSignature' ""+findBodySignature fields = fromMaybe "" signature where 	signature = listToMaybe [x | M.Signature x <- fields]  <<read body>>=@@ -2028,10 +2061,21 @@ @ Even if the received message was structurally valid, building the {\tt ReceivedMessage} can still fail due to missing header fields. +Slightly ugly; to avoid orphan instances of either {\tt Text} or+{\tt Either}, a newtype is used to turn {\tt Either} into a monad.++<<DBus/Wire/Internal.hs>>=+newtype EitherM a b = EitherM (Either a b)++instance Monad (EitherM a) where+	return = EitherM . Right+	(EitherM (Left x)) >>= _ = EitherM (Left x)+	(EitherM (Right x)) >>= k = k x+ <<build message>>= y <- case buildReceivedMessage typeCode fields of-	Right x -> return x-	Left x -> E.throwError $ MissingHeaderField x+	EitherM (Right x) -> return x+	EitherM (Left x) -> E.throwError $ MissingHeaderField x  <<build message>>= return $ y serial flags body@@ -2039,7 +2083,7 @@ @ This really belongs in the Message section...  <<DBus/Wire/Internal.hs>>=-buildReceivedMessage :: Word8 -> [M.HeaderField] -> Either Text +buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text                         (M.Serial -> (Set.Set M.Flag) -> [T.Variant]                          -> M.ReceivedMessage) @@ -2101,15 +2145,9 @@ 	in M.ReceivedUnknown serial sender msg  <<DBus/Wire/Internal.hs>>=-require :: Text -> [a] -> Either Text a-require _     (x:_) = Right x-require label _     = Left label--@ This is just needed for the Monad instance of {\tt Either Text}--<<DBus/Wire/Internal.hs>>=-instance E.Error Text where-	strMsg = TL.pack+require :: Text -> [a] -> EitherM Text a+require _     (x:_) = return x+require label _     = EitherM $ Left label  @ \section{Addresses}@@ -2253,33 +2291,44 @@ <<connection imports>>= import qualified Control.Concurrent as C import qualified DBus.Address as A-import qualified DBus.Message.Internal as M+import qualified DBus.Message as M+import qualified DBus.UUID as UUID  <<DBus/Connection.hs>>=-data Connection = Connection A.Address Transport (C.MVar M.Serial) (C.MVar ())+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 (Connection a _ _ _) = showParen (d > 10) $-		showString' ["<connection ", show $ A.strAddress a, ">"] where-		showString' = foldr (.) id . map showString+	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-over a socket.+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@@ -2473,28 +2522,30 @@ might fail due to external factors.  <<connection imports>>=-import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)+import qualified DBus.Authentication as Auth  <<DBus/Connection.hs>>=-connect :: A.Address -> IO Connection-connect a = do+<<apidoc connect>>+connect :: Auth.Mechanism -> A.Address -> IO Connection+connect mechanism a = do 	t <- connectTransport a-	let putS = transportSend t . encodeUtf8 . TL.pack-	let getS = fmap (TL.unpack . decodeUtf8) . transportRecv t-	authenticate putS getS+	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+	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>>=-connectFirst :: [A.Address] -> IO Connection+<<apidoc connectFirst>>+connectFirst :: [(Auth.Mechanism, A.Address)] -> IO Connection connectFirst orig = connectFirst' orig where-	connectFirst'     [] = E.throwIO $ NoWorkingAddress orig-	connectFirst' (a:as) = E.catch (connect a) $+	allAddrs = [a | (_, a) <- orig]+	connectFirst'     [] = E.throwIO $ NoWorkingAddress allAddrs+	connectFirst' ((mech, a):as) = E.catch (connect mech a) $ 		\(E.SomeException _) -> connectFirst' as  <<connection exports>>=@@ -2503,49 +2554,132 @@  @ \subsection{Authentication} -<<DBus/Connection.hs>>=-authenticate :: (String -> IO ()) -> (Word32 -> IO String)-                -> IO ()-authenticate put get = do-	put "\x00"+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. -@ {\sc external} authentication is performed using the process's real user-ID, converted to a string, and then hex-encoded.+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. -<<connection imports>>=+<<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/Connection.hs>>=+<<DBus/Authentication.hs>>=+realUserID :: Mechanism+realUserID = Mechanism $ \sendCmd -> do 	uid <- getRealUserID-	let authToken = concatMap (printf "%02X" . ord) (show uid)-	put $ "AUTH EXTERNAL " ++ authToken ++ "\r\n"+	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>}.  The GUID is intended to enable connection sharing, which-is currently unimplemented, so it's ignored.--<<connection imports>>=-import Data.List (isPrefixOf)+<server GUID>}. -<<DBus/Connection.hs>>=-	response <- readUntil '\n' get-	if "OK" `isPrefixOf` response-		then put "BEGIN\r\n"-		else do-			putStrLn $ "response = " ++ show response-			error "Server rejected authentication token."+<<authentication imports>>=+import Data.Maybe (isJust) -<<DBus/Connection.hs>>=-readUntil :: Monad m => Char -> (Word32 -> m String) -> m String-readUntil = readUntil' "" where-	readUntil' xs c f = do-		[x] <- f 1-		let xs' = xs ++ [x]-		if x == c-			then return xs'-			else readUntil' xs' c f+<<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} @@ -2558,9 +2692,10 @@ 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 ->+send (Connection _ t mvar _ _) io msg = withSerial mvar $ \serial -> 	case W.marshalMessage W.LittleEndian serial msg of 		Right bytes -> do 			x <- io serial@@ -2584,8 +2719,9 @@ 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 $ \_ ->+receive (Connection _ t _ lock _) = C.withMVar lock $ \_ -> 	W.unmarshalMessage $ transportRecv t  <<connection exports>>=@@ -2613,6 +2749,7 @@ 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@@ -2628,14 +2765,16 @@ busForConnection c = sendHello c >>= return . (,) c  <<DBus/Bus.hs>>=-getBus :: A.Address -> IO (C.Connection, T.BusName)-getBus = (busForConnection =<<) . C.connect+<<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>>=-getFirstBus :: [A.Address] -> IO (C.Connection, T.BusName)+<<apidoc getFirstBus>>+getFirstBus :: [(Auth.Mechanism, A.Address)] -> IO (C.Connection, T.BusName) getFirstBus = (busForConnection =<<) . C.connectFirst  @ \subsection{Default connections}@@ -2645,6 +2784,7 @@ 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"@@ -2652,10 +2792,12 @@ 	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" @@ -2664,8 +2806,8 @@ getBus' io = do 	addr <- fmap TL.pack io 	case A.mkAddresses addr of-		Just [x] -> getBus x-		Just  x  -> getFirstBus x+		Just [x] -> getBus Auth.realUserID x+		Just  xs -> getFirstBus [(Auth.realUserID,x) | x <- xs] 		_        -> E.throwIO $ C.InvalidAddress addr  @ \subsection{Sending the ``hello'' message}@@ -2673,7 +2815,7 @@ <<DBus/Bus.hs>>= hello :: M.MethodCall hello = M.MethodCall dbusPath-	(T.mkMemberName' "Hello")+	"Hello" 	(Just dbusInterface) 	(Just dbusName) 	Set.empty@@ -3071,7 +3213,7 @@ @ \section{Match rules} -Match rules are used indicate that the client is interested in messages+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. @@ -3096,11 +3238,12 @@ import qualified DBus.Constants as C import DBus.Util (maybeIndex) -@ A match rule is a set of filters; most filters may have one possible-value assigned, such as a single message type. The exception are parameter-filters, which are limited in number only by the server implementation.  <<DBus/MatchRule.hs>>=+-- | 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@@ -3110,25 +3253,26 @@ 	, matchDestination :: Maybe T.BusName 	, matchParameters  :: [ParameterValue] 	}--@ Parameters may match against two types, strings and object paths. It's-probably an error to have two values for the same parameter.--The constructor {\tt StringValue 3 "hello"} means that the fourth parameter-in the message body must be the string ``hello''. {\tt PathValue} is the-same, but its value must be an object path.+	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) -@ The set of allowed message types to filter on is separate from the set-supported for sending over the wire. This allows the server to support-additional types not yet implemented in the library, or vice-versa.- <<DBus/MatchRule.hs>>=+-- | 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@@ -3140,6 +3284,7 @@ to format them.  <<DBus/MatchRule.hs>>=+<<apidoc formatRule>> formatRule :: MatchRule -> Text formatRule rule = TL.intercalate "," filters where 	filters = structureFilters ++ parameterFilters@@ -3180,10 +3325,11 @@ 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-	(T.mkMemberName' "AddMatch")+	"AddMatch" 	(Just C.dbusInterface) 	(Just C.dbusName) 	Set.empty@@ -3193,6 +3339,7 @@ an empty rule allows clients to set only the fields they care about.  <<DBus/MatchRule.hs>>=+<<apidoc matchAll>> matchAll :: MatchRule matchAll = MatchRule 	{ matchType        = Nothing@@ -3208,6 +3355,7 @@ signals.  <<DBus/MatchRule.hs>>=+<<apidoc matches>> matches :: MatchRule -> M.ReceivedMessage -> Bool matches rule msg = and . catMaybes . map ($ rule) $ 	[ fmap      (typeMatches msg) . matchType@@ -3323,13 +3471,14 @@ {\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 = T.mkMemberName' "RequestName"+	, M.methodCallMember = "RequestName" 	, M.methodCallBody = 		[ T.toVariant name 		, T.toVariant . encodeFlags $ flags]@@ -3359,13 +3508,14 @@ 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 = T.mkMemberName' "ReleaseName"+	, M.methodCallMember = "ReleaseName" 	, M.methodCallBody = [T.toVariant name] 	} @@ -3414,153 +3564,192 @@  <<DBus/Constants.hs>>= dbusName :: T.BusName-dbusName = T.mkBusName' "org.freedesktop.DBus"+dbusName = "org.freedesktop.DBus"  dbusPath :: T.ObjectPath-dbusPath = T.mkObjectPath' "/org/freedesktop/DBus"+dbusPath = "/org/freedesktop/DBus"  dbusInterface :: T.InterfaceName-dbusInterface = T.mkInterfaceName' "org.freedesktop.DBus"+dbusInterface = "org.freedesktop.DBus"  @ \subsection{Pre-defined interfaces}  <<DBus/Constants.hs>>= interfaceIntrospectable :: T.InterfaceName-interfaceIntrospectable = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable"+interfaceIntrospectable = "org.freedesktop.DBus.Introspectable"  interfaceProperties :: T.InterfaceName-interfaceProperties = T.mkInterfaceName' "org.freedesktop.DBus.Properties"+interfaceProperties = "org.freedesktop.DBus.Properties"  interfacePeer :: T.InterfaceName-interfacePeer = T.mkInterfaceName' "org.freedesktop.DBus.Peer"+interfacePeer = "org.freedesktop.DBus.Peer"  @ \subsection{Pre-defined error names}  <<DBus/Constants.hs>>= errorFailed :: T.ErrorName-errorFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Failed"+errorFailed = "org.freedesktop.DBus.Error.Failed"  errorNoMemory :: T.ErrorName-errorNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.NoMemory"+errorNoMemory = "org.freedesktop.DBus.Error.NoMemory"  errorServiceUnknown :: T.ErrorName-errorServiceUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.ServiceUnknown"+errorServiceUnknown = "org.freedesktop.DBus.Error.ServiceUnknown"  errorNameHasNoOwner :: T.ErrorName-errorNameHasNoOwner = T.mkErrorName' "org.freedesktop.DBus.Error.NameHasNoOwner"+errorNameHasNoOwner = "org.freedesktop.DBus.Error.NameHasNoOwner"  errorNoReply :: T.ErrorName-errorNoReply = T.mkErrorName' "org.freedesktop.DBus.Error.NoReply"+errorNoReply = "org.freedesktop.DBus.Error.NoReply"  errorIOError :: T.ErrorName-errorIOError = T.mkErrorName' "org.freedesktop.DBus.Error.IOError"+errorIOError = "org.freedesktop.DBus.Error.IOError"  errorBadAddress :: T.ErrorName-errorBadAddress = T.mkErrorName' "org.freedesktop.DBus.Error.BadAddress"+errorBadAddress = "org.freedesktop.DBus.Error.BadAddress"  errorNotSupported :: T.ErrorName-errorNotSupported = T.mkErrorName' "org.freedesktop.DBus.Error.NotSupported"+errorNotSupported = "org.freedesktop.DBus.Error.NotSupported"  errorLimitsExceeded :: T.ErrorName-errorLimitsExceeded = T.mkErrorName' "org.freedesktop.DBus.Error.LimitsExceeded"+errorLimitsExceeded = "org.freedesktop.DBus.Error.LimitsExceeded"  errorAccessDenied :: T.ErrorName-errorAccessDenied = T.mkErrorName' "org.freedesktop.DBus.Error.AccessDenied"+errorAccessDenied = "org.freedesktop.DBus.Error.AccessDenied"  errorAuthFailed :: T.ErrorName-errorAuthFailed = T.mkErrorName' "org.freedesktop.DBus.Error.AuthFailed"+errorAuthFailed = "org.freedesktop.DBus.Error.AuthFailed"  errorNoServer :: T.ErrorName-errorNoServer = T.mkErrorName' "org.freedesktop.DBus.Error.NoServer"+errorNoServer = "org.freedesktop.DBus.Error.NoServer"  errorTimeout :: T.ErrorName-errorTimeout = T.mkErrorName' "org.freedesktop.DBus.Error.Timeout"+errorTimeout = "org.freedesktop.DBus.Error.Timeout"  errorNoNetwork :: T.ErrorName-errorNoNetwork = T.mkErrorName' "org.freedesktop.DBus.Error.NoNetwork"+errorNoNetwork = "org.freedesktop.DBus.Error.NoNetwork"  errorAddressInUse :: T.ErrorName-errorAddressInUse = T.mkErrorName' "org.freedesktop.DBus.Error.AddressInUse"+errorAddressInUse = "org.freedesktop.DBus.Error.AddressInUse"  errorDisconnected :: T.ErrorName-errorDisconnected = T.mkErrorName' "org.freedesktop.DBus.Error.Disconnected"+errorDisconnected = "org.freedesktop.DBus.Error.Disconnected"  errorInvalidArgs :: T.ErrorName-errorInvalidArgs = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidArgs"+errorInvalidArgs = "org.freedesktop.DBus.Error.InvalidArgs"  errorFileNotFound :: T.ErrorName-errorFileNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.FileNotFound"+errorFileNotFound = "org.freedesktop.DBus.Error.FileNotFound"  errorFileExists :: T.ErrorName-errorFileExists = T.mkErrorName' "org.freedesktop.DBus.Error.FileExists"+errorFileExists = "org.freedesktop.DBus.Error.FileExists"  errorUnknownMethod :: T.ErrorName-errorUnknownMethod = T.mkErrorName' "org.freedesktop.DBus.Error.UnknownMethod"+errorUnknownMethod = "org.freedesktop.DBus.Error.UnknownMethod"  errorTimedOut :: T.ErrorName-errorTimedOut = T.mkErrorName' "org.freedesktop.DBus.Error.TimedOut"+errorTimedOut = "org.freedesktop.DBus.Error.TimedOut"  errorMatchRuleNotFound :: T.ErrorName-errorMatchRuleNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleNotFound"+errorMatchRuleNotFound = "org.freedesktop.DBus.Error.MatchRuleNotFound"  errorMatchRuleInvalid :: T.ErrorName-errorMatchRuleInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleInvalid"+errorMatchRuleInvalid = "org.freedesktop.DBus.Error.MatchRuleInvalid"  errorSpawnExecFailed :: T.ErrorName-errorSpawnExecFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ExecFailed"+errorSpawnExecFailed = "org.freedesktop.DBus.Error.Spawn.ExecFailed"  errorSpawnForkFailed :: T.ErrorName-errorSpawnForkFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ForkFailed"+errorSpawnForkFailed = "org.freedesktop.DBus.Error.Spawn.ForkFailed"  errorSpawnChildExited :: T.ErrorName-errorSpawnChildExited = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildExited"+errorSpawnChildExited = "org.freedesktop.DBus.Error.Spawn.ChildExited"  errorSpawnChildSignaled :: T.ErrorName-errorSpawnChildSignaled = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildSignaled"+errorSpawnChildSignaled = "org.freedesktop.DBus.Error.Spawn.ChildSignaled"  errorSpawnFailed :: T.ErrorName-errorSpawnFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.Failed"+errorSpawnFailed = "org.freedesktop.DBus.Error.Spawn.Failed"  errorSpawnFailedToSetup :: T.ErrorName-errorSpawnFailedToSetup = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FailedToSetup"+errorSpawnFailedToSetup = "org.freedesktop.DBus.Error.Spawn.FailedToSetup"  errorSpawnConfigInvalid :: T.ErrorName-errorSpawnConfigInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ConfigInvalid"+errorSpawnConfigInvalid = "org.freedesktop.DBus.Error.Spawn.ConfigInvalid"  errorSpawnServiceNotValid :: T.ErrorName-errorSpawnServiceNotValid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotValid"+errorSpawnServiceNotValid = "org.freedesktop.DBus.Error.Spawn.ServiceNotValid"  errorSpawnServiceNotFound :: T.ErrorName-errorSpawnServiceNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotFound"+errorSpawnServiceNotFound = "org.freedesktop.DBus.Error.Spawn.ServiceNotFound"  errorSpawnPermissionsInvalid :: T.ErrorName-errorSpawnPermissionsInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid"+errorSpawnPermissionsInvalid = "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid"  errorSpawnFileInvalid :: T.ErrorName-errorSpawnFileInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FileInvalid"+errorSpawnFileInvalid = "org.freedesktop.DBus.Error.Spawn.FileInvalid"  errorSpawnNoMemory :: T.ErrorName-errorSpawnNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.NoMemory"+errorSpawnNoMemory = "org.freedesktop.DBus.Error.Spawn.NoMemory"  errorUnixProcessIdUnknown :: T.ErrorName-errorUnixProcessIdUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.UnixProcessIdUnknown"+errorUnixProcessIdUnknown = "org.freedesktop.DBus.Error.UnixProcessIdUnknown"  errorInvalidFileContent :: T.ErrorName-errorInvalidFileContent = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidFileContent"+errorInvalidFileContent = "org.freedesktop.DBus.Error.InvalidFileContent"  errorSELinuxSecurityContextUnknown :: T.ErrorName-errorSELinuxSecurityContextUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown"+errorSELinuxSecurityContextUnknown = "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown"  errorAdtAuditDataUnknown :: T.ErrorName-errorAdtAuditDataUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.AdtAuditDataUnknown"+errorAdtAuditDataUnknown = "org.freedesktop.DBus.Error.AdtAuditDataUnknown"  errorObjectPathInUse :: T.ErrorName-errorObjectPathInUse = T.mkErrorName' "org.freedesktop.DBus.Error.ObjectPathInUse"+errorObjectPathInUse = "org.freedesktop.DBus.Error.ObjectPathInUse"  errorInconsistentMessage :: T.ErrorName-errorInconsistentMessage = T.mkErrorName' "org.freedesktop.DBus.Error.InconsistentMessage"+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>>=@@ -3568,6 +3757,7 @@ 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@@ -3596,5 +3786,147 @@ maybeIndex (x:_ ) 0         = Just x maybeIndex (_:xs) n | n > 0 = maybeIndex xs (n - 1) maybeIndex _ _ = Nothing++-- | Read values from a monad until a guard value is read; return all+-- values, including the guard.+--+readUntil :: (Monad m, Eq a) => [a] -> m a -> m [a]+readUntil guard getx = readUntil' [] where+	guard' = reverse guard+	step xs | isPrefixOf guard' xs = return . reverse $ xs+	        | otherwise            = readUntil' xs+	readUntil' xs = do+		x <- getx+		step $ x:xs++-- | Drop /n/ items from the end of a list+dropEnd :: Int -> [a] -> [a]+dropEnd n xs = take (length xs - n) xs++@+\section{Haddock API documentation}++The \LaTeX{} documentation is great for somebody reading the source code+or trying to fix an error, but it's not useful for people who just want+to add D-Bus support to their applications. These documentation sections+will be included in Haddock output for public functions.++There's no real order to this section; it exists only because Haddock+can't merge documentation from external files.++<<apidoc isAtomicType>>=+-- | \"Atomic\" types are any which can't contain any other types. Only+-- atomic types may be used as dictionary keys.++<<apidoc typeCode>>=+-- | Every type has an associated type code; a textual representation of+-- the type, useful for debugging.++<<apidoc Variant>>=+-- | 'Variant's may contain any other built-in D-Bus value. Besides+-- representing native @VARIANT@ values, they allow type-safe storage and+-- deconstruction of heterogeneous collections.++<<apidoc variantType>>=+-- | Every variant is strongly-typed; that is, the type of its contained+-- value is known at all times. This function retrieves that type, so that+-- the correct cast can be used to retrieve the value.++<<apidoc arrayType>>=+-- | This is the type contained within the array, not the type of the array+-- itself.++<<apidoc Connection>>=+-- | A 'Connection' is an opaque handle to an open D-Bus channel, with an+-- internal state for maintaining the current message serial.++<<apidoc Transport>>=+-- | A 'Transport' is anything which can send and receive bytestrings,+-- typically via a socket.++<<apidoc connect>>=+-- | Open a connection to some address, using a given authentication+-- mechanism. If the connection fails, a 'ConnectionError' will be thrown.++<<apidoc connectFirst>>=+-- | Try to open a connection to various addresses, returning the first+-- connection which could be successfully opened.++<<apidoc send>>=+-- | Send a single message, with a generated 'M.Serial'. The second parameter+-- exists to prevent race conditions when registering a reply handler; it+-- receives the serial the message /will/ be sent with, before it's actually+-- sent.+--+-- Only one message may be sent at a time; if multiple threads attempt to+-- send messages in parallel, one will block until after the other has+-- finished.++<<apidoc receive>>=+-- | Receive the next message from the connection, blocking until one is+-- available.+--+-- Only one message may be received at a time; if multiple threads attempt+-- to receive messages in parallel, one will block until after the other has+-- finished.++<<apidoc getBus>>=+-- | Similar to 'C.connect', but additionally sends @Hello@ messages to the+-- central bus.++<<apidoc getFirstBus>>=+-- | Similar to 'C.connectFirst', but additionally sends @Hello@ messages to+-- the central bus.++<<apidoc getSystemBus>>=+-- | Connect to the bus specified in the environment variable+-- @DBUS_SYSTEM_BUS_ADDRESS@, or to+-- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@+-- is not set.++<<apidoc getSessionBus>>=+-- | Connect to the bus specified in the environment variable+-- @DBUS_SESSION_BUS_ADDRESS@, which must be set.++<<apidoc getStarterBus>>=+-- | Connect to the bus specified in the environment variable+-- @DBUS_STARTER_ADDRESS@, which must be set.++<<apidoc formatRule>>=+-- | Format a 'MatchRule' as the bus expects to receive in a call to+-- @AddMatch@.++<<apidoc addMatch>>=+-- | Build a 'M.MethodCall' for adding a match rule to the bus.++<<apidoc matchAll>>=+-- | An empty match rule, which matches everything.++<<apidoc matches>>=+-- | Whether a 'M.ReceivedMessage' matches a given rule. This is useful+-- for implementing signal handlers.++<<apidoc requestName>>=+-- | Build a 'M.MethodCall' for requesting a registered bus name.++<<apidoc releaseName>>=+-- | Build a 'M.MethodCall' for releasing a registered bus name.++<<apidoc Serial>>=+-- | A value used to uniquely identify a particular message within a session.+-- 'Serial's are 32-bit unsigned integers, and eventually wrap.++<<apidoc ReceivedMessage>>=+-- | Not an actual message type, but a wrapper around messages received from+-- the bus. Each value contains the message's 'Serial' and possibly the+-- origin's 'T.BusName'++<<apidoc marshalMessage>>=+-- | Convert a 'M.Message' into a 'L.ByteString'. Although unusual, it is+-- possible for marshaling to fail -- if this occurs, an appropriate error+-- will be returned instead.++<<apidoc unmarshalMessage>>=+-- | Read bytes from a monad until a complete message has been received.  @ \end{document}

@@ -0,0 +1,100 @@+{-+  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 DeriveDataTypeable #-}+module DBus.Authentication+        (   Command+          , Mechanism (..)++          , AuthenticationError (..)++          , authenticate++          , realUserID++        ) where+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL++import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as ByteString+import qualified DBus.UUID as UUID++import Data.Typeable (Typeable)+import qualified Control.Exception as E++import Data.Word (Word8)++import Control.Monad (liftM)+import Data.Char (chr)+import Data.Text.Lazy.Encoding (encodeUtf8)+import DBus.Util (readUntil, dropEnd)++import System.Posix.User (getRealUserID)+import Data.Char (ord)+import Text.Printf (printf)++import Data.Maybe (isJust)+++type Command = Text+newtype Mechanism = Mechanism+        { mechanismRun :: (Command -> IO Command) -> IO UUID.UUID+        }++data AuthenticationError+        = AuthenticationError Text+        deriving (Show, Typeable)++instance E.Exception AuthenticationError++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++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++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++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+

@@ -35,6 +35,7 @@ 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@@ -44,21 +45,38 @@ busForConnection :: C.Connection -> IO (C.Connection, T.BusName) busForConnection c = sendHello c >>= return . (,) c -getBus :: A.Address -> IO (C.Connection, T.BusName)-getBus = (busForConnection =<<) . C.connect+-- | Similar to 'C.connect', but additionally sends @Hello@ messages to the+-- central bus. -getFirstBus :: [A.Address] -> IO (C.Connection, T.BusName)+getBus :: Auth.Mechanism -> A.Address -> IO (C.Connection, T.BusName)+getBus = ((busForConnection =<<) .) . C.connect++-- | Similar to 'C.connectFirst', but additionally sends @Hello@ messages to+-- the central bus.++getFirstBus :: [(Auth.Mechanism, A.Address)] -> IO (C.Connection, T.BusName) getFirstBus = (busForConnection =<<) . C.connectFirst +-- | 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.+ 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 +-- | Connect to the bus specified in the environment variable+-- @DBUS_SESSION_BUS_ADDRESS@, which must be set.+ getSessionBus :: IO (C.Connection, T.BusName) getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS" +-- | Connect to the bus specified in the environment variable+-- @DBUS_STARTER_ADDRESS@, which must be set.+ getStarterBus :: IO (C.Connection, T.BusName) getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS" @@ -66,13 +84,13 @@ getBus' io = do         addr <- fmap TL.pack io         case A.mkAddresses addr of-                Just [x] -> getBus x-                Just  x  -> getFirstBus x+                Just [x] -> getBus Auth.realUserID x+                Just  xs -> getFirstBus [(Auth.realUserID,x) | x <- xs]                 _        -> E.throwIO $ C.InvalidAddress addr  hello :: M.MethodCall hello = M.MethodCall dbusPath-        (T.mkMemberName' "Hello")+        "Hello"         (Just dbusInterface)         (Just dbusName)         Set.empty

@@ -20,6 +20,8 @@ {-# LANGUAGE DeriveDataTypeable #-} module DBus.Connection         (   Connection+          , connectionAddress+          , connectionUUID            , ConnectionError (..) @@ -36,7 +38,8 @@  import qualified Control.Concurrent as C import qualified DBus.Address as A-import qualified DBus.Message.Internal as M+import qualified DBus.Message as M+import qualified DBus.UUID as UUID  import qualified Data.ByteString.Lazy as L import Data.Word (Word32)@@ -56,24 +59,28 @@ import qualified Control.Exception as E import Data.Typeable (Typeable) -import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)--import System.Posix.User (getRealUserID)-import Data.Char (ord)-import Text.Printf (printf)--import Data.List (isPrefixOf)+import qualified DBus.Authentication as Auth  import qualified DBus.Wire as W  -data Connection = Connection A.Address Transport (C.MVar M.Serial) (C.MVar ())+data Connection = Connection+        { connectionAddress    :: A.Address+        , connectionTransport  :: Transport+        , connectionSerialMVar :: C.MVar M.Serial+        , connectionReadMVar   :: C.MVar ()+        , connectionUUID       :: UUID.UUID+        }  instance Show Connection where-        showsPrec d (Connection a _ _ _) = showParen (d > 10) $-                showString' ["<connection ", show $ A.strAddress a, ">"] where-                showString' = foldr (.) id . map showString+        showsPrec d con = showParen (d > 10) strCon where+                addr = A.strAddress $ connectionAddress con+                strCon = s "<Connection " . shows addr . s ">"+                s = showString +-- | A 'Transport' is anything which can send and receive bytestrings,+-- typically via a socket.+ data Transport = Transport         { transportSend :: L.ByteString -> IO ()         , transportRecv :: Word32 -> IO L.ByteString@@ -176,50 +183,40 @@  instance E.Exception ConnectionError -connect :: A.Address -> IO Connection-connect a = do+-- | Open a connection to some address, using a given authentication+-- mechanism. If the connection fails, a 'ConnectionError' will be thrown.++connect :: Auth.Mechanism -> A.Address -> IO Connection+connect mechanism a = do         t <- connectTransport a-        let putS = transportSend t . encodeUtf8 . TL.pack-        let getS = fmap (TL.unpack . decodeUtf8) . transportRecv t-        authenticate putS getS+        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+        return $ Connection a t serialMVar readLock uuid -connectFirst :: [A.Address] -> IO Connection+-- | Try to open a connection to various addresses, returning the first+-- connection which could be successfully opened.++connectFirst :: [(Auth.Mechanism, A.Address)] -> IO Connection connectFirst orig = connectFirst' orig where-        connectFirst'     [] = E.throwIO $ NoWorkingAddress orig-        connectFirst' (a:as) = E.catch (connect a) $+        allAddrs = [a | (_, a) <- orig]+        connectFirst'     [] = E.throwIO $ NoWorkingAddress allAddrs+        connectFirst' ((mech, a):as) = E.catch (connect mech a) $                 \(E.SomeException _) -> connectFirst' as -authenticate :: (String -> IO ()) -> (Word32 -> IO String)-                -> IO ()-authenticate put get = do-        put "\x00"--        uid <- getRealUserID-        let authToken = concatMap (printf "%02X" . ord) (show uid)-        put $ "AUTH EXTERNAL " ++ authToken ++ "\r\n"--        response <- readUntil '\n' get-        if "OK" `isPrefixOf` response-                then put "BEGIN\r\n"-                else do-                        putStrLn $ "response = " ++ show response-                        error "Server rejected authentication token."--readUntil :: Monad m => Char -> (Word32 -> m String) -> m String-readUntil = readUntil' "" where-        readUntil' xs c f = do-                [x] <- f 1-                let xs' = xs ++ [x]-                if x == c-                        then return xs'-                        else readUntil' xs' c f+-- | 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.  send :: M.Message a => Connection -> (M.Serial -> IO b) -> a      -> IO (Either W.MarshalError b)-send (Connection _ t mvar _) io msg = withSerial mvar $ \serial ->+send (Connection _ t mvar _ _) io msg = withSerial mvar $ \serial ->         case W.marshalMessage W.LittleEndian serial msg of                 Right bytes -> do                         x <- io serial@@ -235,7 +232,14 @@         C.putMVar m s'         return x +-- | 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.+ receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage)-receive (Connection _ t _ lock) = C.withMVar lock $ \_ ->+receive (Connection _ t _ lock _) = C.withMVar lock $ \_ ->         W.unmarshalMessage $ transportRecv t 

@@ -30,143 +30,143 @@ arrayMaximumLength = 67108864  dbusName :: T.BusName-dbusName = T.mkBusName' "org.freedesktop.DBus"+dbusName = "org.freedesktop.DBus"  dbusPath :: T.ObjectPath-dbusPath = T.mkObjectPath' "/org/freedesktop/DBus"+dbusPath = "/org/freedesktop/DBus"  dbusInterface :: T.InterfaceName-dbusInterface = T.mkInterfaceName' "org.freedesktop.DBus"+dbusInterface = "org.freedesktop.DBus"  interfaceIntrospectable :: T.InterfaceName-interfaceIntrospectable = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable"+interfaceIntrospectable = "org.freedesktop.DBus.Introspectable"  interfaceProperties :: T.InterfaceName-interfaceProperties = T.mkInterfaceName' "org.freedesktop.DBus.Properties"+interfaceProperties = "org.freedesktop.DBus.Properties"  interfacePeer :: T.InterfaceName-interfacePeer = T.mkInterfaceName' "org.freedesktop.DBus.Peer"+interfacePeer = "org.freedesktop.DBus.Peer"  errorFailed :: T.ErrorName-errorFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Failed"+errorFailed = "org.freedesktop.DBus.Error.Failed"  errorNoMemory :: T.ErrorName-errorNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.NoMemory"+errorNoMemory = "org.freedesktop.DBus.Error.NoMemory"  errorServiceUnknown :: T.ErrorName-errorServiceUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.ServiceUnknown"+errorServiceUnknown = "org.freedesktop.DBus.Error.ServiceUnknown"  errorNameHasNoOwner :: T.ErrorName-errorNameHasNoOwner = T.mkErrorName' "org.freedesktop.DBus.Error.NameHasNoOwner"+errorNameHasNoOwner = "org.freedesktop.DBus.Error.NameHasNoOwner"  errorNoReply :: T.ErrorName-errorNoReply = T.mkErrorName' "org.freedesktop.DBus.Error.NoReply"+errorNoReply = "org.freedesktop.DBus.Error.NoReply"  errorIOError :: T.ErrorName-errorIOError = T.mkErrorName' "org.freedesktop.DBus.Error.IOError"+errorIOError = "org.freedesktop.DBus.Error.IOError"  errorBadAddress :: T.ErrorName-errorBadAddress = T.mkErrorName' "org.freedesktop.DBus.Error.BadAddress"+errorBadAddress = "org.freedesktop.DBus.Error.BadAddress"  errorNotSupported :: T.ErrorName-errorNotSupported = T.mkErrorName' "org.freedesktop.DBus.Error.NotSupported"+errorNotSupported = "org.freedesktop.DBus.Error.NotSupported"  errorLimitsExceeded :: T.ErrorName-errorLimitsExceeded = T.mkErrorName' "org.freedesktop.DBus.Error.LimitsExceeded"+errorLimitsExceeded = "org.freedesktop.DBus.Error.LimitsExceeded"  errorAccessDenied :: T.ErrorName-errorAccessDenied = T.mkErrorName' "org.freedesktop.DBus.Error.AccessDenied"+errorAccessDenied = "org.freedesktop.DBus.Error.AccessDenied"  errorAuthFailed :: T.ErrorName-errorAuthFailed = T.mkErrorName' "org.freedesktop.DBus.Error.AuthFailed"+errorAuthFailed = "org.freedesktop.DBus.Error.AuthFailed"  errorNoServer :: T.ErrorName-errorNoServer = T.mkErrorName' "org.freedesktop.DBus.Error.NoServer"+errorNoServer = "org.freedesktop.DBus.Error.NoServer"  errorTimeout :: T.ErrorName-errorTimeout = T.mkErrorName' "org.freedesktop.DBus.Error.Timeout"+errorTimeout = "org.freedesktop.DBus.Error.Timeout"  errorNoNetwork :: T.ErrorName-errorNoNetwork = T.mkErrorName' "org.freedesktop.DBus.Error.NoNetwork"+errorNoNetwork = "org.freedesktop.DBus.Error.NoNetwork"  errorAddressInUse :: T.ErrorName-errorAddressInUse = T.mkErrorName' "org.freedesktop.DBus.Error.AddressInUse"+errorAddressInUse = "org.freedesktop.DBus.Error.AddressInUse"  errorDisconnected :: T.ErrorName-errorDisconnected = T.mkErrorName' "org.freedesktop.DBus.Error.Disconnected"+errorDisconnected = "org.freedesktop.DBus.Error.Disconnected"  errorInvalidArgs :: T.ErrorName-errorInvalidArgs = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidArgs"+errorInvalidArgs = "org.freedesktop.DBus.Error.InvalidArgs"  errorFileNotFound :: T.ErrorName-errorFileNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.FileNotFound"+errorFileNotFound = "org.freedesktop.DBus.Error.FileNotFound"  errorFileExists :: T.ErrorName-errorFileExists = T.mkErrorName' "org.freedesktop.DBus.Error.FileExists"+errorFileExists = "org.freedesktop.DBus.Error.FileExists"  errorUnknownMethod :: T.ErrorName-errorUnknownMethod = T.mkErrorName' "org.freedesktop.DBus.Error.UnknownMethod"+errorUnknownMethod = "org.freedesktop.DBus.Error.UnknownMethod"  errorTimedOut :: T.ErrorName-errorTimedOut = T.mkErrorName' "org.freedesktop.DBus.Error.TimedOut"+errorTimedOut = "org.freedesktop.DBus.Error.TimedOut"  errorMatchRuleNotFound :: T.ErrorName-errorMatchRuleNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleNotFound"+errorMatchRuleNotFound = "org.freedesktop.DBus.Error.MatchRuleNotFound"  errorMatchRuleInvalid :: T.ErrorName-errorMatchRuleInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleInvalid"+errorMatchRuleInvalid = "org.freedesktop.DBus.Error.MatchRuleInvalid"  errorSpawnExecFailed :: T.ErrorName-errorSpawnExecFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ExecFailed"+errorSpawnExecFailed = "org.freedesktop.DBus.Error.Spawn.ExecFailed"  errorSpawnForkFailed :: T.ErrorName-errorSpawnForkFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ForkFailed"+errorSpawnForkFailed = "org.freedesktop.DBus.Error.Spawn.ForkFailed"  errorSpawnChildExited :: T.ErrorName-errorSpawnChildExited = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildExited"+errorSpawnChildExited = "org.freedesktop.DBus.Error.Spawn.ChildExited"  errorSpawnChildSignaled :: T.ErrorName-errorSpawnChildSignaled = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildSignaled"+errorSpawnChildSignaled = "org.freedesktop.DBus.Error.Spawn.ChildSignaled"  errorSpawnFailed :: T.ErrorName-errorSpawnFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.Failed"+errorSpawnFailed = "org.freedesktop.DBus.Error.Spawn.Failed"  errorSpawnFailedToSetup :: T.ErrorName-errorSpawnFailedToSetup = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FailedToSetup"+errorSpawnFailedToSetup = "org.freedesktop.DBus.Error.Spawn.FailedToSetup"  errorSpawnConfigInvalid :: T.ErrorName-errorSpawnConfigInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ConfigInvalid"+errorSpawnConfigInvalid = "org.freedesktop.DBus.Error.Spawn.ConfigInvalid"  errorSpawnServiceNotValid :: T.ErrorName-errorSpawnServiceNotValid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotValid"+errorSpawnServiceNotValid = "org.freedesktop.DBus.Error.Spawn.ServiceNotValid"  errorSpawnServiceNotFound :: T.ErrorName-errorSpawnServiceNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotFound"+errorSpawnServiceNotFound = "org.freedesktop.DBus.Error.Spawn.ServiceNotFound"  errorSpawnPermissionsInvalid :: T.ErrorName-errorSpawnPermissionsInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid"+errorSpawnPermissionsInvalid = "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid"  errorSpawnFileInvalid :: T.ErrorName-errorSpawnFileInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FileInvalid"+errorSpawnFileInvalid = "org.freedesktop.DBus.Error.Spawn.FileInvalid"  errorSpawnNoMemory :: T.ErrorName-errorSpawnNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.NoMemory"+errorSpawnNoMemory = "org.freedesktop.DBus.Error.Spawn.NoMemory"  errorUnixProcessIdUnknown :: T.ErrorName-errorUnixProcessIdUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.UnixProcessIdUnknown"+errorUnixProcessIdUnknown = "org.freedesktop.DBus.Error.UnixProcessIdUnknown"  errorInvalidFileContent :: T.ErrorName-errorInvalidFileContent = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidFileContent"+errorInvalidFileContent = "org.freedesktop.DBus.Error.InvalidFileContent"  errorSELinuxSecurityContextUnknown :: T.ErrorName-errorSELinuxSecurityContextUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown"+errorSELinuxSecurityContextUnknown = "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown"  errorAdtAuditDataUnknown :: T.ErrorName-errorAdtAuditDataUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.AdtAuditDataUnknown"+errorAdtAuditDataUnknown = "org.freedesktop.DBus.Error.AdtAuditDataUnknown"  errorObjectPathInUse :: T.ErrorName-errorObjectPathInUse = T.mkErrorName' "org.freedesktop.DBus.Error.ObjectPathInUse"+errorObjectPathInUse = "org.freedesktop.DBus.Error.ObjectPathInUse"  errorInconsistentMessage :: T.ErrorName-errorInconsistentMessage = T.mkErrorName' "org.freedesktop.DBus.Error.InconsistentMessage"+errorInconsistentMessage = "org.freedesktop.DBus.Error.InconsistentMessage" 

@@ -37,6 +37,11 @@ import qualified DBus.Constants as C import DBus.Util (maybeIndex) ++-- | A match rule is a set of filters; most filters may have one possible+-- value assigned, such as a single message type. The exception are parameter+-- filters, which are limited in number only by the server implementation.+--  data MatchRule = MatchRule         { matchType        :: Maybe MessageType         , matchSender      :: Maybe T.BusName@@ -46,12 +51,24 @@         , matchDestination :: Maybe T.BusName         , matchParameters  :: [ParameterValue]         }+        deriving (Show) +-- | 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) +-- | 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@@ -59,6 +76,9 @@         | Error         deriving (Show, Eq) +-- | Format a 'MatchRule' as the bus expects to receive in a call to+-- @AddMatch@.+ formatRule :: MatchRule -> Text formatRule rule = TL.intercalate "," filters where         filters = structureFilters ++ parameterFilters@@ -89,15 +109,19 @@ formatType Signal       = "signal" formatType Error        = "error" +-- | Build a 'M.MethodCall' for adding a match rule to the bus.+ addMatch :: MatchRule -> M.MethodCall addMatch rule = M.MethodCall         C.dbusPath-        (T.mkMemberName' "AddMatch")+        "AddMatch"         (Just C.dbusInterface)         (Just C.dbusName)         Set.empty         [T.toVariant $ formatRule rule] +-- | An empty match rule, which matches everything.+ matchAll :: MatchRule matchAll = MatchRule         { matchType        = Nothing@@ -108,6 +132,9 @@         , matchDestination = Nothing         , matchParameters  = []         }++-- | Whether a 'M.ReceivedMessage' matches a given rule. This is useful+-- for implementing signal handlers.  matches :: MatchRule -> M.ReceivedMessage -> Bool matches rule msg = and . catMaybes . map ($ rule) $

@@ -24,6 +24,8 @@           , Serial          , serialValue+         , firstSerial+         , nextSerial           , MethodCall (..) 

@@ -49,6 +49,9 @@         | Signature   T.Signature         deriving (Show, Eq) +-- | A value used to uniquely identify a particular message within a session.+-- 'Serial's are 32-bit unsigned integers, and eventually wrap.+ newtype Serial = Serial { serialValue :: Word32 }         deriving (Eq, Ord) @@ -161,6 +164,10 @@         , unknownBody    :: [T.Variant]         }         deriving (Show, Eq)++-- | 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'  data ReceivedMessage         = ReceivedMethodCall   Serial (Maybe T.BusName) MethodCall

@@ -45,13 +45,15 @@         flagValue ReplaceExisting  = 0x2         flagValue DoNotQueue       = 0x4 +-- | Build a 'M.MethodCall' for requesting a registered bus name.+ requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall requestName name flags = M.MethodCall         { M.methodCallPath = C.dbusPath         , M.methodCallInterface = Just C.dbusInterface         , M.methodCallDestination = Just C.dbusName         , M.methodCallFlags = Set.empty-        , M.methodCallMember = T.mkMemberName' "RequestName"+        , M.methodCallMember = "RequestName"         , M.methodCallBody =                 [ T.toVariant name                 , T.toVariant . encodeFlags $ flags]@@ -77,13 +79,15 @@ decodeRequestReply 4 = Just AlreadyOwner decodeRequestReply _ = Nothing +-- | Build a 'M.MethodCall' for releasing a registered bus name.+ releaseName :: T.BusName -> M.MethodCall releaseName name = M.MethodCall         { M.methodCallPath = C.dbusPath         , M.methodCallInterface = Just C.dbusInterface         , M.methodCallDestination = Just C.dbusName         , M.methodCallFlags = Set.empty-        , M.methodCallMember = T.mkMemberName' "ReleaseName"+        , M.methodCallMember = "ReleaseName"         , M.methodCallBody = [T.toVariant name]         } 

@@ -38,13 +38,13 @@                    , strSignature                     , mkSignature-                   , mkSignature'+                   , mkSignature_                       -- * Object paths                    , ObjectPath                    , strObjectPath                    , mkObjectPath-                   , mkObjectPath'+                   , mkObjectPath_                       -- * Arrays                    , Array@@ -80,25 +80,25 @@                    , BusName                    , strBusName                    , mkBusName-                   , mkBusName'+                   , mkBusName_                       -- ** Interface names                    , InterfaceName                    , strInterfaceName                    , mkInterfaceName-                   , mkInterfaceName'+                   , mkInterfaceName_                       -- ** Error names                    , ErrorName                    , strErrorName                    , mkErrorName-                   , mkErrorName'+                   , mkErrorName_                       -- ** Member names                    , MemberName                    , strMemberName                    , mkMemberName-                   , mkMemberName'+                   , mkMemberName_ ) where import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL@@ -116,6 +116,8 @@  import DBus.Util (mkUnsafe) +import qualified Data.String as String+ import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as ByteString @@ -150,6 +152,9 @@         | 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@@ -165,11 +170,39 @@ 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 ++ [")"]++ class (Show a, Eq a) => Builtin a where         builtinDBusType :: a -> Type +-- | '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 = forall a. (Variable a, Builtin a, Typeable a) => Variant a         deriving (Typeable) @@ -186,6 +219,10 @@ instance Eq Variant where         (Variant x) == (Variant y) = cast x == Just y +-- | 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 (Variant x) = builtinDBusType x @@ -238,27 +275,6 @@ instance Ord Signature where         compare x y = compare (strSignature x) (strSignature y) -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 ++ [")"]- mkSignature :: Text -> Maybe Signature mkSignature = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack where         sigParser = do@@ -300,23 +316,33 @@                 P.char ')'                 return $ DBusStructure types -mkSignature' :: Text -> Signature-mkSignature' = mkUnsafe "signature" mkSignature+mkSignature_ :: Text -> Signature+mkSignature_ = mkUnsafe "signature" mkSignature +instance String.IsString Signature where+        fromString = mkSignature_ . TL.pack+ instance Builtin ObjectPath where                 { builtinDBusType _ = DBusObjectPath };         instance Variable ObjectPath where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x }; newtype ObjectPath = ObjectPath         { strObjectPath :: Text         }-        deriving (Show, Eq, Ord, Typeable)+        deriving (Eq, Ord, Typeable) +instance Show ObjectPath where+        showsPrec d (ObjectPath x) = showParen (d > 10) $+                showString "ObjectPath " . shows x++instance String.IsString ObjectPath where+        fromString = mkObjectPath_ . TL.pack+ 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+mkObjectPath_ :: Text -> ObjectPath+mkObjectPath_ = mkUnsafe "object path" mkObjectPath  instance Variable Array where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x }; data Array@@ -327,6 +353,9 @@ instance Builtin Array where         builtinDBusType = DBusArray . arrayType +-- | 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@@ -460,8 +489,16 @@   -newtype BusName = BusName {strBusName :: Text}                 deriving (Show, Eq, Ord);                                                   instance Variable BusName where                 { toVariant = toVariant . strBusName                 ; fromVariant = (mkBusName =<<) . fromVariant };                                                                         mkBusName' :: Text -> BusName;         mkBusName' = mkUnsafe "bus name" mkBusName ++++++++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'] ++ "_-"@@ -472,7 +509,7 @@         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 (Show, Eq, Ord);                                                   instance Variable InterfaceName where                 { toVariant = toVariant . strInterfaceName                 ; fromVariant = (mkInterfaceName =<<) . fromVariant };                                                                         mkInterfaceName' :: Text -> InterfaceName;         mkInterfaceName' = mkUnsafe "interface name" mkInterfaceName+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@@ -482,12 +519,12 @@         name = element >> P.many1 (P.char '.' >> element)         parser = name >> P.eof >> return (InterfaceName s) -newtype ErrorName = ErrorName {strErrorName :: Text}                 deriving (Show, Eq, Ord);                                                   instance Variable ErrorName where                 { toVariant = toVariant . strErrorName                 ; fromVariant = (mkErrorName =<<) . fromVariant };                                                                         mkErrorName' :: Text -> ErrorName;         mkErrorName' = mkUnsafe "error name" mkErrorName+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 (Show, Eq, Ord);                                                   instance Variable MemberName where                 { toVariant = toVariant . strMemberName                 ; fromVariant = (mkMemberName =<<) . fromVariant };                                                                         mkMemberName' :: Text -> MemberName;         mkMemberName' = mkUnsafe "member name" mkMemberName+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

@@ -0,0 +1,50 @@+{-+  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.UUID+        ( UUID+        , toHex+        , fromHex+        ) where+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL+++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'+                ]+

@@ -18,6 +18,7 @@ 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@@ -46,4 +47,20 @@ 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 

@@ -508,6 +508,10 @@         c' = fromJust . T.fromVariant $ c         v' = fromJust . T.fromVariant $ v +-- | 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.+ marshalMessage :: M.Message a => Endianness -> M.Serial -> a                -> Either MarshalError L.ByteString marshalMessage e serial msg = runMarshal marshaler e where@@ -556,12 +560,13 @@         when (messageLength > fromIntegral C.messageMaximumLength)                 (E.throwError $ MessageTooLong $ fromIntegral messageLength) +-- | Read bytes from a monad until a complete message has been received. unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)                  -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do         let getBytes = E.lift . getBytes'         -        let fixedSig = T.mkSignature' "yyyyuuu"+        let fixedSig = "yyyyuuu"         fixedBytes <- getBytes 16          let messageVersion = L.index fixedBytes 3@@ -584,7 +589,7 @@          let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6 -        let headerSig  = T.mkSignature' "yyyyuua(yv)"+        let headerSig  = "yyyyuua(yv)"         fieldBytes <- getBytes fieldByteCount         let headerBytes = L.append fixedBytes fieldBytes         header <- unmarshal' headerSig headerBytes@@ -602,18 +607,24 @@         body <- unmarshal' bodySig bodyBytes          y <- case buildReceivedMessage typeCode fields of-                Right x -> return x-                Left x -> E.throwError $ MissingHeaderField x+                EitherM (Right x) -> return x+                EitherM (Left x) -> E.throwError $ MissingHeaderField x          return $ y serial flags body   findBodySignature :: [M.HeaderField] -> T.Signature-findBodySignature fields = fromMaybe empty signature where-        empty = T.mkSignature' ""+findBodySignature fields = fromMaybe "" signature where         signature = listToMaybe [x | M.Signature x <- fields] -buildReceivedMessage :: Word8 -> [M.HeaderField] -> Either Text +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++buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text                         (M.Serial -> (Set.Set M.Flag) -> [T.Variant]                          -> M.ReceivedMessage) @@ -659,10 +670,7 @@         msg = M.Unknown typeCode flags body         in M.ReceivedUnknown serial sender msg -require :: Text -> [a] -> Either Text a-require _     (x:_) = Right x-require label _     = Left label--instance E.Error Text where-        strMsg = TL.pack+require :: Text -> [a] -> EitherM Text a+require _     (x:_) = return x+require label _     = EitherM $ Left label