packages feed

dbus-core 0.8.5.3 → 0.8.5.4

raw patch · 25 files changed

+564/−17 lines, 25 filesdep ~textPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: text

API changes (from Hackage documentation)

Files

dbus-core.cabal view
@@ -1,5 +1,5 @@ name: dbus-core-version: 0.8.5.3+version: 0.8.5.4 synopsis: Low-level D-Bus protocol implementation license: GPL-3 license-file: License.txt@@ -29,11 +29,7 @@   default: False  library-  if true-    ghc-options: -Wall--  if impl(ghc >= 6.11)-    ghc-options: -fno-warn-unused-do-bind+  ghc-options: -Wall    hs-source-dirs: hs @@ -43,7 +39,7 @@     , binary >= 0.4 && < 0.6     , bytestring >= 0.9 && < 0.10     , data-binary-ieee754 >= 0.3 && < 0.5-    , text >= 0.8 && < 0.11+    , text >= 0.8 && < 0.12     , containers >= 0.1 && < 0.5     , unix >= 2.2 && < 2.5     , network >= 2.2 && < 2.4
hs/DBus/Address.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,7 +14,10 @@ --  -- 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 DBus.Address 	( Address 	, addressMethod@@ -20,17 +25,21 @@ 	, mkAddresses 	, strAddress 	) where+ import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + import Data.Char (ord, chr) import qualified Data.Map as M import Text.Printf (printf) import qualified Text.ParserCombinators.Parsec as P import Text.ParserCombinators.Parsec ((<|>))-import DBus.Util (hexToInt, eitherToMaybe)+import DBus.Util (hexToInt, eitherToMaybe, void)+ optionallyEncoded :: [Char] optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."+ data Address = Address 	{ addressMethod     :: Text 	, addressParameters :: M.Map Text Text@@ -39,17 +48,18 @@ instance Show Address where 	showsPrec d x = showParen (d> 10) $ 		showString "Address " . shows (strAddress x)+ mkAddresses :: Text -> Maybe [Address] mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where 	address = do 		method <- P.many (P.noneOf ":;")-		P.char ':'+		void (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 '='+		void (P.char '=') 		value <- P.many1 (encodedValue <|> unencodedValue) 		return (TL.pack key, TL.pack value) 	@@ -60,9 +70,10 @@ 	 	unencodedValue = P.oneOf optionallyEncoded 	encodedValue = do-		P.char '%'+		void (P.char '%') 		hex <- P.count 2 P.hexDigit 		return . chr . hexToInt $ hex+ strAddress :: Address -> Text strAddress (Address t ps) = TL.concat [t, ":", ps'] where 	ps' = TL.intercalate "," $ do
hs/DBus/Authentication.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,7 +14,10 @@ --  -- 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@@ -21,32 +26,43 @@ 	, 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 Data.ByteString.Lazy.Char8 () 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@@ -54,12 +70,14 @@ 	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@@ -69,6 +87,7 @@ 	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
hs/DBus/Bus.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,7 +14,10 @@ --  -- 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 DBus.Bus 	( getBus 	, getFirstBus@@ -20,9 +25,11 @@ 	, getSessionBus 	, getStarterBus 	) where+ import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL + import qualified Control.Exception as E import Control.Monad (when) import Data.Maybe (fromJust, isNothing)@@ -36,36 +43,50 @@ import qualified DBus.Message as M import qualified DBus.Types as T import DBus.Util (fromRight)+ busForConnection :: C.Connection -> IO (C.Connection, T.BusName) busForConnection c = fmap ((,) c) $ sendHello c + -- | Similar to 'C.connect', but additionally sends @Hello@ messages to the -- central bus.+ 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"+ getBus' :: IO String -> IO (C.Connection, T.BusName) getBus' io = do 	addr <- fmap TL.pack io@@ -73,6 +94,7 @@ 		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 	"Hello"@@ -80,6 +102,7 @@ 	(Just dbusName) 	Set.empty 	[]+ sendHello :: C.Connection -> IO T.BusName sendHello c = do 	serial <- fromRight `fmap` C.send c return hello@@ -92,6 +115,7 @@ 		E.throwIO $ E.AssertionFailed "Invalid response to Hello()" 	 	return . fromJust $ name+ waitForReply :: C.Connection -> M.Serial -> IO M.MethodReturn waitForReply c serial = do 	received <- C.receive c
hs/DBus/Connection.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,39 +14,61 @@ --  -- 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.Connection (+ 	  Connection 	, connectionAddress 	, connectionUUID+ 	, ConnectionError (..)+ 	, connect 	, connectFirst+ 	, connectionClose+ 	, send+ 	, receive+ 	) where+ import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL++ import qualified Control.Concurrent as C import qualified DBus.Address as A import qualified DBus.Message as M import qualified DBus.UUID as UUID+ import qualified Data.ByteString.Lazy as L import Data.Word (Word32)+ import qualified Network as N import qualified Data.Map as Map+ import qualified Network.Socket as NS+ import qualified Text.ParserCombinators.Parsec as P import Control.Monad (unless) import Data.Binary.Get (runGet, getWord16host) import Data.Binary.Put (runPut, putWord16be)+ import qualified System.IO as I+ import qualified Control.Exception as E import Data.Typeable (Typeable)+ import qualified DBus.Authentication as Auth+ import qualified DBus.Wire as W+ data Connection = Connection 	{ connectionAddress    :: A.Address 	, connectionTransport  :: Transport@@ -52,23 +76,29 @@ 	, connectionReadMVar   :: C.MVar () 	, connectionUUID       :: UUID.UUID 	}+ 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++ -- | 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 	, transportClose :: IO () 	}+ connectTransport :: A.Address -> IO Transport connectTransport a = transport' (A.addressMethod a) a where 	transport' "unix" = unix 	transport' "tcp"  = tcp 	transport' _      = E.throwIO . UnknownMethod+ unix :: A.Address -> IO Transport unix a = port >>= N.connectTo "localhost" >>= handleTransport where 	params = A.addressParameters a@@ -86,6 +116,7 @@ 		(Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew 		(Just x, Nothing) -> return $ TL.unpack x 		(Nothing, Just x) -> return $ '\x00' : TL.unpack x+ tcp :: A.Address -> IO Transport tcp a = openHandle >>= handleTransport where 	params = A.addressParameters a@@ -95,13 +126,16 @@ 		addresses <- getAddresses family 		socket <- openSocket port addresses 		NS.socketToHandle socket I.ReadWriteMode+ 	hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params+ 	unknownFamily x = TL.concat ["Unknown socket family for TCP transport: ", x] 	getFamily = case Map.lookup "family" params of 		Just "ipv4" -> return NS.AF_INET 		Just "ipv6" -> return NS.AF_INET6 		Nothing     -> return NS.AF_UNSPEC 		Just x      -> E.throwIO $ BadParameters a $ unknownFamily x+ 	missingPort = "TCP transport requires the ``port'' parameter." 	badPort x = TL.concat ["Invalid socket port for TCP transport: ", x] 	getPort = case Map.lookup "port" params of@@ -109,6 +143,7 @@ 		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@@ -120,6 +155,7 @@ 			fail "bad port" 		let word = fromIntegral value 		return $ runGet getWord16host (runPut (putWord16be word))+ 	getAddresses family = do 		let hints = NS.defaultHints 			{ NS.addrFlags = [NS.AI_ADDRCONFIG]@@ -127,9 +163,11 @@ 			, NS.addrSocketType = NS.Stream 			} 		NS.getAddrInfo (Just hints) (Just hostname) Nothing+ 	setPort port (NS.SockAddrInet  _ x)     = NS.SockAddrInet port x 	setPort port (NS.SockAddrInet6 _ x y z) = NS.SockAddrInet6 port x y z 	setPort _    addr                       = addr+ 	openSocket _ [] = E.throwIO $ NoWorkingAddress [a] 	openSocket port (addr:addrs) = E.catch (openSocket' port addr) $ 		\(E.SomeException _) -> openSocket port addrs@@ -139,11 +177,13 @@ 		                  (NS.addrProtocol addr) 		NS.connect sock . setPort port . NS.addrAddress $ addr 		return sock+ handleTransport :: I.Handle -> IO Transport handleTransport h = do 	I.hSetBuffering h I.NoBuffering 	I.hSetBinaryMode h True 	return $ Transport (L.hPut h) (L.hGet h . fromIntegral) (I.hClose h)+ data ConnectionError 	= InvalidAddress Text 	| BadParameters A.Address Text@@ -152,8 +192,11 @@ 	deriving (Show, Typeable)  instance E.Exception ConnectionError++ -- | 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@@ -162,18 +205,26 @@ 	readLock <- C.newMVar () 	serialMVar <- C.newMVar M.firstSerial 	return $ Connection a t serialMVar readLock uuid++ -- | 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 	allAddrs = [a | (_, a) <- orig] 	connectFirst'     [] = E.throwIO $ NoWorkingAddress allAddrs 	connectFirst' ((mech, a):as) = E.catch (connect mech a) $ 		\(E.SomeException _) -> connectFirst' as++ -- | Close an open connection. Once closed, the 'Connection' is no longer -- valid and must not be used.+ connectionClose :: Connection -> IO () connectionClose = transportClose . connectionTransport++ -- | 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@@ -182,6 +233,7 @@ -- 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 ->@@ -191,6 +243,7 @@ 			transportSend t bytes 			return $ Right x 		Left  err   -> return $ Left err+ withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a withSerial m io = E.block $ do 	s <- C.takeMVar m@@ -198,12 +251,15 @@ 	x <- E.unblock (io s) `E.onException` C.putMVar m s' 	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 $ \_ -> 	W.unmarshalMessage $ transportRecv t
hs/DBus/Constants.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,6 +14,7 @@ --  -- 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 DBus.Constants where import qualified DBus.Types as T@@ -25,6 +28,7 @@  arrayMaximumLength :: Word32 arrayMaximumLength = 67108864+ dbusName :: T.BusName dbusName = "org.freedesktop.DBus" @@ -33,6 +37,7 @@  dbusInterface :: T.InterfaceName dbusInterface = "org.freedesktop.DBus"+ interfaceIntrospectable :: T.InterfaceName interfaceIntrospectable = "org.freedesktop.DBus.Introspectable" @@ -41,6 +46,7 @@  interfacePeer :: T.InterfaceName interfacePeer = "org.freedesktop.DBus.Peer"+ errorFailed :: T.ErrorName errorFailed = "org.freedesktop.DBus.Error.Failed"
hs/DBus/Introspection.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,7 +14,10 @@ --  -- 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 DBus.Introspection 	( Object (..) 	, Interface (..)@@ -24,15 +29,21 @@ 	, toXML 	, fromXML 	) where+ import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL++ import qualified Data.XML.Types as X import qualified Text.XML.LibXML.SAX as SAX import Control.Monad.ST (runST) import qualified Data.STRef as ST+ import Control.Monad ((>=>)) import Data.Maybe (fromMaybe, listToMaybe)+ import qualified DBus.Types as T+ data Object = Object T.ObjectPath [Interface] [Object] 	deriving (Show, Eq) @@ -53,10 +64,12 @@  data PropertyAccess = Read | Write 	deriving (Show, Eq)+ fromXML :: T.ObjectPath -> Text -> Maybe Object fromXML path text = do 	root <- parseElement text 	parseRoot path root+ parseElement :: Text -> Maybe X.Element parseElement text = runST $ do 	stackRef <- ST.newSTRef [([], [])]@@ -82,12 +95,14 @@ 	return $ case stack of 		[] -> Nothing 		(_, children'):_ -> Just $ head children'+ parseRoot :: T.ObjectPath -> X.Element -> Maybe Object parseRoot defaultPath e = do 	path <- case getattrM "name" e of 		Nothing -> Just defaultPath 		Just x  -> T.mkObjectPath x 	parseObject path e+ parseChild :: T.ObjectPath -> X.Element -> Maybe Object parseChild parentPath e = do 	let parentPath' = case T.strObjectPath parentPath of@@ -96,12 +111,14 @@ 	pathSegment <- getattrM "name" e 	path <- T.mkObjectPath $ TL.append parentPath' pathSegment 	parseObject path e+ parseObject :: T.ObjectPath -> X.Element -> Maybe Object parseObject path e | X.elementName e == toName "node" = do 	interfaces <- children parseInterface (named "interface") e 	children' <- children (parseChild path) (named "node") e 	return $ Object path interfaces children' parseObject _ _ = Nothing+ parseInterface :: X.Element -> Maybe Interface parseInterface e = do 	name <- T.mkInterfaceName =<< getattrM "name" e@@ -109,28 +126,33 @@ 	signals <- children parseSignal (named "signal") e 	properties <- children parseProperty (named "property") e 	return $ Interface name methods signals properties+ parseMethod :: X.Element -> Maybe Method parseMethod e = do 	name <- T.mkMemberName =<< getattrM "name" e 	paramsIn <- children parseParameter (isParam ["in", ""]) e 	paramsOut <- children parseParameter (isParam ["out"]) e 	return $ Method name paramsIn paramsOut+ parseSignal :: X.Element -> Maybe Signal parseSignal e = do 	name <- T.mkMemberName =<< getattrM "name" e 	params <- children parseParameter (isParam ["out", ""]) e 	return $ Signal name params+ parseParameter :: X.Element -> Maybe Parameter parseParameter e = do 	let name = getattr "name" e 	sig <- parseType e 	return $ Parameter name sig+ parseType :: X.Element -> Maybe T.Signature parseType e = do 	sig <- T.mkSignature =<< getattrM "type" e 	case T.signatureTypes sig of 		[_] -> Just sig 		_   -> Nothing+ parseProperty :: X.Element -> Maybe Property parseProperty e = do 	let name = getattr "name" e@@ -142,6 +164,7 @@ 		"readwrite" -> Just [Read, Write] 		_           -> Nothing 	return $ Property name sig access+ getattrM :: Text -> X.Element -> Maybe Text getattrM name = fmap attrText . listToMaybe . attrs where 	attrText = textContent . X.attributeContent@@ -163,6 +186,7 @@  toName :: Text -> X.Name toName t = X.Name t Nothing Nothing+ newtype XmlWriter a = XmlWriter { runXmlWriter :: Maybe (a, Text) }  instance Monad XmlWriter where@@ -171,17 +195,21 @@ 		(a, w) <- runXmlWriter m 		(b, w') <- runXmlWriter (f a) 		return (b, TL.append w w')+ tell :: Text -> XmlWriter () tell t = XmlWriter $ Just ((), t)+ toXML :: Object -> Maybe Text toXML obj = do 	(_, text) <- runXmlWriter (writeRoot obj) 	return text+ writeRoot :: Object -> XmlWriter () writeRoot obj@(Object path _ _) = do 	tell "<!DOCTYPE node PUBLIC '-//freedesktop//DTD D-BUS Object Introspection 1.0//EN'" 	tell " 'http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd'>\n" 	writeObject (T.strObjectPath path) obj+ writeChild :: T.ObjectPath -> Object -> XmlWriter () writeChild parentPath obj@(Object path _ _) = write where 	path' = T.strObjectPath path@@ -195,42 +223,50 @@ 	write = case relpathM of 		Just relpath -> writeObject relpath obj 		Nothing -> XmlWriter Nothing+ writeObject :: Text -> Object -> XmlWriter () writeObject path (Object fullPath interfaces children') = writeElement "node" 	[("name", path)] $ do 		mapM_ writeInterface interfaces 		mapM_ (writeChild fullPath) children'+ writeInterface :: Interface -> XmlWriter () writeInterface (Interface name methods signals properties) = writeElement "interface" 	[("name", T.strInterfaceName name)] $ do 		mapM_ writeMethod methods 		mapM_ writeSignal signals 		mapM_ writeProperty properties+ writeMethod :: Method -> XmlWriter () writeMethod (Method name inParams outParams) = writeElement "method" 	[("name", T.strMemberName name)] $ do 		mapM_ (writeParameter "in") inParams 		mapM_ (writeParameter "out") outParams+ writeSignal :: Signal -> XmlWriter () writeSignal (Signal name params) = writeElement "signal" 	[("name", T.strMemberName name)] $ do 		mapM_ (writeParameter "out") params+ writeParameter :: Text -> Parameter -> XmlWriter () writeParameter direction (Parameter name sig) = writeEmptyElement "arg" 	[ ("name", name) 	, ("type", T.strSignature sig) 	, ("direction", direction) 	]+ writeProperty :: Property -> XmlWriter () writeProperty (Property name sig access) = writeEmptyElement "property" 	[ ("name", name) 	, ("type", T.strSignature sig) 	, ("access", strAccess access) 	]+ strAccess :: [PropertyAccess] -> Text strAccess access = TL.append readS writeS where 	readS = if elem Read access then "read" else "" 	writeS = if elem Write access then "write" else ""+ writeElement :: Text -> [(Text, Text)] -> XmlWriter () -> XmlWriter () writeElement name attrs content = do 	tell "<"@@ -241,12 +277,14 @@ 	tell "</" 	tell name 	tell ">"+ writeEmptyElement :: Text -> [(Text, Text)] -> XmlWriter () writeEmptyElement name attrs = do 	tell "<" 	tell name 	mapM_ writeAttribute attrs 	tell "/>"+ writeAttribute :: (Text, Text) -> XmlWriter () writeAttribute (name, content) = do 	tell " "@@ -254,6 +292,7 @@ 	tell "='" 	tell (escape content) 	tell "'"+ escape :: Text -> Text escape = TL.concatMap escapeChar where 	escapeChar c = case c of
hs/DBus/MatchRule.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,7 +14,10 @@ --  -- 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 DBus.MatchRule ( 	  MatchRule (..) 	, MessageType (..)@@ -22,8 +27,10 @@ 	, matchAll 	, matches 	) where+ import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL+ import Data.Word (Word8) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set@@ -31,6 +38,7 @@ import qualified DBus.Message as M import qualified DBus.Constants as C import DBus.Util (maybeIndex)+ -- | A match rule is a set of filters; most filters may have one possible -- value assigned, such as a single message type. The exception are parameter -- filters, which are limited in number only by the server implementation.@@ -45,6 +53,7 @@ 	, 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. -- @@ -56,6 +65,7 @@ 	= 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.@@ -66,8 +76,11 @@ 	| Signal 	| 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@@ -81,12 +94,14 @@ 		, ("destination", fmap T.strBusName . matchDestination) 		] 	unpack (key, mkValue) = formatFilter' key `fmap` mkValue rule+ formatParameter :: ParameterValue -> Text formatParameter (StringValue index x) = formatFilter' key x where 	key = "arg" `TL.append` TL.pack (show index) formatParameter (PathValue index x) = formatFilter' key value where 	key = "arg" `TL.append` TL.pack (show index) `TL.append` "path" 	value = T.strObjectPath x+ formatFilter' :: Text -> Text -> Text formatFilter' key value = TL.concat [key, "='", value, "'"] @@ -95,7 +110,10 @@ formatType MethodReturn = "method_return" 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@@ -104,7 +122,10 @@ 	(Just C.dbusName) 	Set.empty 	[T.toVariant $ formatRule rule]++ -- | An empty match rule, which matches everything.+ matchAll :: MatchRule matchAll = MatchRule 	{ matchType        = Nothing@@ -115,8 +136,11 @@ 	, 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 . mapMaybe ($ rule) $ 	[ fmap      (typeMatches msg) . matchType@@ -127,32 +151,38 @@ 	, fmap      (destMatches msg) . matchDestination 	, Just . parametersMatch msg  . matchParameters 	]+ typeMatches :: M.ReceivedMessage -> MessageType -> Bool typeMatches (M.ReceivedMethodCall   _ _ _) MethodCall   = True typeMatches (M.ReceivedMethodReturn _ _ _) MethodReturn = True typeMatches (M.ReceivedSignal       _ _ _) Signal       = True typeMatches (M.ReceivedError        _ _ _) Error        = True typeMatches _ _ = False+ senderMatches :: M.ReceivedMessage -> T.BusName -> Bool senderMatches msg name = M.receivedSender msg == Just name+ ifaceMatches :: M.ReceivedMessage -> T.InterfaceName -> Bool ifaceMatches (M.ReceivedMethodCall _ _ msg) name = 	Just name == M.methodCallInterface msg ifaceMatches (M.ReceivedSignal _ _ msg) name = 	name == M.signalInterface msg ifaceMatches _ _ = False+ memberMatches :: M.ReceivedMessage -> T.MemberName -> Bool memberMatches (M.ReceivedMethodCall _ _ msg) name = 	name == M.methodCallMember msg memberMatches (M.ReceivedSignal _ _ msg) name = 	name == M.signalMember msg memberMatches _ _ = False+ pathMatches :: M.ReceivedMessage -> T.ObjectPath -> Bool pathMatches (M.ReceivedMethodCall _ _ msg) path = 	path == M.methodCallPath msg pathMatches (M.ReceivedSignal _ _ msg) path = 	path == M.signalPath msg pathMatches _ _ = False+ destMatches :: M.ReceivedMessage -> T.BusName -> Bool destMatches (M.ReceivedMethodCall _ _ msg) name = 	Just name == M.methodCallDestination msg@@ -163,6 +193,7 @@ destMatches (M.ReceivedSignal _ _ msg) name = 	Just name == M.signalDestination msg destMatches _ _ = False+ parametersMatch :: M.ReceivedMessage -> [ParameterValue] -> Bool parametersMatch _ [] = True parametersMatch msg values = all validParam values where
hs/DBus/Message.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,24 +14,35 @@ --  -- 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 	        )+ 	, Flag (..)+ 	, Serial 	, serialValue 	, firstSerial 	, nextSerial+ 	, MethodCall (..)+ 	, MethodReturn (..)+ 	, Error (..) 	, errorMessage+ 	, Signal (..)+ 	, Unknown (..)+ 	, ReceivedMessage (..) 	, receivedSerial 	, receivedSender 	, receivedBody+ 	) where import DBus.Message.Internal
hs/DBus/Message/Internal.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,24 +14,32 @@ --  -- 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 DBus.Message.Internal where+ import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL+ import qualified Data.Set as S import Data.Word (Word8, Word32) import Data.Maybe (fromMaybe) import qualified DBus.Types as T import DBus.Util (maybeIndex)+ class Message a where 	messageTypeCode     :: a -> Word8 	messageHeaderFields :: a -> [HeaderField] 	messageFlags        :: a -> S.Set Flag 	messageBody         :: a -> [T.Variant]+ data Flag 	= NoReplyExpected 	| NoAutoStart 	deriving (Show, Eq, Ord)+ data HeaderField 	= Path        T.ObjectPath 	| Interface   T.InterfaceName@@ -40,8 +50,11 @@ 	| Sender      T.BusName 	| 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) @@ -51,13 +64,16 @@ instance T.Variable Serial where 	toVariant (Serial x) = T.toVariant x 	fromVariant = fmap Serial . T.fromVariant+ firstSerial :: Serial firstSerial = Serial 1  nextSerial :: Serial -> Serial nextSerial (Serial x) = Serial (x + 1)+ maybe' :: (a -> b) -> Maybe a -> [b] maybe' f = maybe [] (\x' -> [f x'])+ data MethodCall = MethodCall 	{ methodCallPath        :: T.ObjectPath 	, methodCallMember      :: T.MemberName@@ -79,6 +95,7 @@ 		, maybe' Interface . methodCallInterface $ m 		, maybe' Destination . methodCallDestination $ m 		]+ data MethodReturn = MethodReturn 	{ methodReturnSerial      :: Serial 	, methodReturnDestination :: Maybe T.BusName@@ -95,6 +112,7 @@ 		  ] 		, maybe' Destination . methodReturnDestination $ m 		]+ data Error = Error 	{ errorName        :: T.ErrorName 	, errorSerial      :: Serial@@ -113,6 +131,7 @@ 		  ] 		, maybe' Destination . errorDestination $ m 		]+ errorMessage :: Error -> Text errorMessage msg = fromMaybe "(no error message)" $ do 	field <- maybeIndex (errorBody msg) 0@@ -120,6 +139,7 @@ 	if TL.null text 		then Nothing 		else return text+ data Signal = Signal 	{ signalPath        :: T.ObjectPath 	, signalMember      :: T.MemberName@@ -140,15 +160,19 @@ 		  ] 		, maybe' Destination . signalDestination $ m 		]+ data Unknown = Unknown 	{ unknownType    :: Word8 	, unknownFlags   :: S.Set Flag 	, 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 	| ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn@@ -156,18 +180,21 @@ 	| ReceivedSignal       Serial (Maybe T.BusName) Signal 	| ReceivedUnknown      Serial (Maybe T.BusName) Unknown 	deriving (Show, Eq)+ receivedSerial :: ReceivedMessage -> Serial receivedSerial (ReceivedMethodCall   s _ _) = s receivedSerial (ReceivedMethodReturn s _ _) = s receivedSerial (ReceivedError        s _ _) = s receivedSerial (ReceivedSignal       s _ _) = s receivedSerial (ReceivedUnknown      s _ _) = s+ receivedSender :: ReceivedMessage -> Maybe T.BusName receivedSender (ReceivedMethodCall   _ s _) = s receivedSender (ReceivedMethodReturn _ s _) = s receivedSender (ReceivedError        _ s _) = s receivedSender (ReceivedSignal       _ s _) = s receivedSender (ReceivedUnknown      _ s _) = s+ receivedBody :: ReceivedMessage -> [T.Variant] receivedBody (ReceivedMethodCall   _ _ x) = messageBody x receivedBody (ReceivedMethodReturn _ _ x) = messageBody x
hs/DBus/NameReservation.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,6 +14,7 @@ --  -- 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 DBus.NameReservation 	( RequestNameFlag (..)@@ -29,17 +32,22 @@ import qualified DBus.Message as M import qualified DBus.Constants as C import DBus.Util (maybeIndex)+ data RequestNameFlag 	= AllowReplacement 	| ReplaceExisting 	| DoNotQueue 	deriving (Show)+ encodeFlags :: [RequestNameFlag] -> Word32 encodeFlags = foldr (.|.) 0 . map flagValue where 	flagValue AllowReplacement = 0x1 	flagValue ReplaceExisting  = 0x2 	flagValue DoNotQueue       = 0x4++ -- | 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@@ -51,24 +59,30 @@ 		[ T.toVariant name 		, T.toVariant . encodeFlags $ flags] 	}+ data RequestNameReply 	= PrimaryOwner 	| InQueue 	| Exists 	| AlreadyOwner 	deriving (Show)+ mkRequestNameReply :: M.MethodReturn -> Maybe RequestNameReply mkRequestNameReply msg = 	maybeIndex (M.messageBody msg) 0 >>= 	T.fromVariant >>= 	decodeRequestReply+ decodeRequestReply :: Word32 -> Maybe RequestNameReply decodeRequestReply 1 = Just PrimaryOwner decodeRequestReply 2 = Just InQueue decodeRequestReply 3 = Just Exists decodeRequestReply 4 = Just AlreadyOwner decodeRequestReply _ = Nothing++ -- | Build a 'M.MethodCall' for releasing a registered bus name.+ releaseName :: T.BusName -> M.MethodCall releaseName name = M.MethodCall 	{ M.methodCallPath = C.dbusPath@@ -78,16 +92,19 @@ 	, M.methodCallMember = "ReleaseName" 	, M.methodCallBody = [T.toVariant name] 	}+ data ReleaseNameReply 	= Released 	| NonExistent 	| NotOwner 	deriving (Show)+ mkReleaseNameReply :: M.MethodReturn -> Maybe ReleaseNameReply mkReleaseNameReply msg = 	maybeIndex (M.messageBody msg) 0 >>= 	T.fromVariant >>= 	decodeReleaseReply+ decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply decodeReleaseReply 1 = Just Released decodeReleaseReply 2 = Just NonExistent
hs/DBus/Types.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,66 +14,86 @@ --  -- 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.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 DBus.Types.Internal
hs/DBus/Types/Internal.cpphs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,34 +14,55 @@ --  -- 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.Internal 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 Data.Text.Encoding (decodeUtf8)+ import qualified Data.ByteString.Unsafe as B import qualified Foreign as F import System.IO.Unsafe (unsafePerformIO)+ import Data.Text.Lazy.Encoding (encodeUtf8)+ import DBus.Util (mkUnsafe) import qualified Data.String as String+ import Text.ParserCombinators.Parsec ((<|>)) import qualified Text.ParserCombinators.Parsec as P import DBus.Util (checkLength, parseMaybe)+ import Data.List (intercalate)+ import Control.Monad (unless)+ import Control.Arrow ((***)) import qualified Data.Map as Map+ import Control.Monad (forM)+ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as BL8+ data Type 	= DBusBoolean 	| DBusByte@@ -58,8 +81,11 @@ 	| 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@@ -74,9 +100,13 @@ 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 t = TL.fromChunks [decodeUtf8 $ typeCodeB t]  typeCodeB :: Type -> B.ByteString@@ -93,13 +123,19 @@ typeCodeB DBusSignature  = "g" typeCodeB DBusObjectPath = "o" typeCodeB DBusVariant    = "v"+ typeCodeB (DBusArray t) = B8.cons 'a' $ typeCodeB t+ typeCodeB (DBusDictionary k v) = B.concat ["a{", typeCodeB k, typeCodeB v, "}"]+ typeCodeB (DBusStructure ts) = B.concat $ 	["("] ++ map typeCodeB 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@@ -122,6 +158,7 @@ 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@@ -147,9 +184,12 @@ 	(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@@ -176,13 +216,16 @@  variantSignature :: Variant -> Maybe Signature variantSignature = mkBytesSignature . typeCodeB . variantType+ #define INSTANCE_VARIABLE(TYPE) \ 	instance Variable TYPE where \ 		{ toVariant = VarBox/**/TYPE \ 		; fromVariant (VarBox/**/TYPE x) = Just x \ 		; fromVariant _ = Nothing \ 		}+ INSTANCE_VARIABLE(Variant)+ INSTANCE_VARIABLE(Bool) INSTANCE_VARIABLE(Word8) INSTANCE_VARIABLE(Int16)@@ -192,16 +235,20 @@ INSTANCE_VARIABLE(Word32) INSTANCE_VARIABLE(Word64) INSTANCE_VARIABLE(Double)+ 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) data Signature = Signature { signatureTypes :: [Type] } 	deriving (Eq)@@ -209,15 +256,19 @@ instance Show Signature where 	showsPrec d x = showParen (d > 10) $ 		showString "Signature " . shows (strSignature x)+ bytesSignature :: Signature -> B.ByteString bytesSignature (Signature ts) = B.concat $ map typeCodeB ts  strSignature :: Signature -> Text strSignature (Signature ts) = TL.concat $ map typeCode ts+ instance Ord Signature where 	compare = comparing strSignature+ mkBytesSignature :: B.ByteString -> Maybe Signature mkBytesSignature = unsafePerformIO . flip B.unsafeUseAsCStringLen io where+ 	parseAtom c yes no = case c of 		0x62 -> yes DBusBoolean 		0x79 -> yes DBusByte@@ -236,6 +287,8 @@ 	fast c = parseAtom c (\t -> Just (Signature [t])) $ case c of 		0x76 -> Just (Signature [DBusVariant]) 		_ -> Nothing++ 	slow :: F.Ptr Word8 -> Int -> IO (Maybe Signature) 	slow buf len = loop [] 0 where 		loop acc ii | ii >= len = return . Just . Signature $ reverse acc@@ -260,6 +313,7 @@ 						Nothing -> return Nothing 				 				_ -> return Nothing+ 	structure :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type)) 	structure buf len = loop [] where 		loop _ ii | ii >= len = return Nothing@@ -287,6 +341,7 @@ 						Nothing -> return Nothing 				 				_ -> return Nothing+ 	array :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type)) 	array _   len ii | ii >= len = return Nothing 	array buf len ii = do@@ -313,6 +368,7 @@ 					Nothing -> return Nothing 			 			_ -> return Nothing+ 	dict :: F.Ptr Word8 -> Int -> Int -> IO (Maybe (Int, Type)) 	dict _   len ii | ii + 1 >= len = return Nothing 	dict buf len ii = do@@ -343,23 +399,28 @@ 						if c3 == 0x7D then Just () else Nothing 						t1 <- mt1 						Just (ii' + 1, DBusDictionary t1 t2)+ 	 	io (cstr, len) = case len of 		0 -> return $ Just $ Signature [] 		1 -> fmap fast $ F.peek cstr 		_ | len <= 255 -> slow (F.castPtr cstr) len 		_ -> return Nothing+ mkSignature :: Text -> Maybe Signature mkSignature = mkBytesSignature . B.concat . BL.toChunks . encodeUtf8+ mkSignature_ :: Text -> Signature mkSignature_ = mkUnsafe "signature" mkSignature  instance String.IsString Signature where 	fromString = mkUnsafe "signature" mkBytesSignature . BL8.pack+ maybeValidType :: Type -> Maybe () maybeValidType t = if B.length (typeCodeB t) > 255 	then Nothing 	else Just ()+ INSTANCE_VARIABLE(ObjectPath) newtype ObjectPath = ObjectPath 	{ strObjectPath :: Text@@ -372,6 +433,7 @@  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'] ++ "_"@@ -380,14 +442,17 @@  mkObjectPath_ :: Text -> ObjectPath mkObjectPath_ = mkUnsafe "object path" mkObjectPath+ INSTANCE_VARIABLE(Array) data Array 	= VariantArray Type [Variant] 	| ByteArray BL.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@@ -395,6 +460,7 @@ arrayItems :: Array -> [Variant] arrayItems (VariantArray _ xs) = xs arrayItems (ByteArray xs) = map toVariant $ BL.unpack xs+ instance Show Array where 	showsPrec d array = showParen (d > 10) $ 		s "Array " . showSig . s " [" . s valueString . s "]" where@@ -402,6 +468,7 @@ 			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 . BL.pack) (mapM fromVariant vs) @@ -410,23 +477,28 @@ 	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 BL.ByteString arrayToBytes (ByteArray x) = Just x arrayToBytes _             = Nothing  arrayFromBytes :: BL.ByteString -> Array arrayFromBytes = ByteArray+ instance Variable BL.ByteString where 	toVariant = toVariant . arrayFromBytes 	fromVariant x = fromVariant x >>= arrayToBytes+ instance Variable B.ByteString where 	toVariant x = toVariant . arrayFromBytes $ BL.fromChunks [x] 	fromVariant = fmap (B.concat . BL.toChunks) . fromVariant+ INSTANCE_VARIABLE(Dictionary)  data Dictionary = Dictionary@@ -435,6 +507,7 @@ 	, 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@@ -442,6 +515,7 @@ 			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@@ -453,10 +527,12 @@ 	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@@ -465,11 +541,13 @@ 		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@@ -482,10 +560,12 @@ 		_                      -> Nothing 	pairs <- mapM toPair $ arrayItems array 	dictionaryFromItems kt vt pairs+ INSTANCE_VARIABLE(Structure)  data Structure = Structure [Variant] 	deriving (Show, Eq)+ #define NAME_TYPE(TYPE, NAME) \ 	newtype TYPE = TYPE {str/**/TYPE :: Text} \ 		deriving (Eq, Ord); \@@ -504,6 +584,7 @@ 		                                                \ 	mk/**/TYPE/**/_ :: Text -> TYPE; \ 	mk/**/TYPE/**/_ = mkUnsafe NAME mk/**/TYPE+ NAME_TYPE(BusName, "bus name")  mkBusName :: Text -> Maybe BusName@@ -515,6 +596,7 @@ 	wellKnown = elems c 	elems start = elem' start >> P.many1 (P.char '.' >> elem' start) 	elem' start = P.oneOf start >> P.many (P.oneOf c')+ NAME_TYPE(InterfaceName, "interface name")  mkInterfaceName :: Text -> Maybe InterfaceName@@ -524,10 +606,12 @@ 	element = P.oneOf c >> P.many (P.oneOf c') 	name = element >> P.many1 (P.char '.' >> element) 	parser = name >> P.eof >> return (InterfaceName s)+ NAME_TYPE(ErrorName, "error name")  mkErrorName :: Text -> Maybe ErrorName mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName+ NAME_TYPE(MemberName, "member name")  mkMemberName :: Text -> Maybe MemberName
hs/DBus/UUID.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,13 +14,16 @@ --  -- 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)
hs/DBus/Util.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,6 +14,7 @@ --  -- 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.Util where import Text.ParserCombinators.Parsec (Parser, parse) import Data.Char (digitToInt)@@ -60,3 +63,6 @@ -- | Drop /n/ items from the end of a list dropEnd :: Int -> [a] -> [a] dropEnd n xs = take (length xs - n) xs++void :: Monad m => m a -> m ()+void m = m >> return ()
hs/DBus/Util/MonadError.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,6 +14,7 @@ --  -- 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.Util.MonadError 	( ErrorM (..) 	, ErrorT (..)
hs/DBus/Wire.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,12 +14,19 @@ --  -- 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 (..)+ 	, MarshalError (..)+ 	, UnmarshalError (..)+ 	, marshalMessage+ 	, unmarshalMessage+ 	) where import DBus.Wire.Internal import DBus.Wire.Marshal
hs/DBus/Wire/Internal.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,9 +14,11 @@ --  -- 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.Internal where import Data.Word (Word8, Word64) import qualified DBus.Types as T+ data Endianness = LittleEndian | BigEndian 	deriving (Show, Eq) @@ -26,7 +30,9 @@ decodeEndianness 108 = Just LittleEndian decodeEndianness 66  = Just BigEndian decodeEndianness _   = Nothing+ alignment :: T.Type -> Word8+ alignment T.DBusByte    = 1 alignment T.DBusWord16  = 2 alignment T.DBusWord32  = 4@@ -35,14 +41,22 @@ alignment T.DBusInt32   = 4 alignment T.DBusInt64   = 8 alignment T.DBusDouble  = 8+ alignment T.DBusBoolean = 4+ alignment T.DBusString     = 4 alignment T.DBusObjectPath = 4+ alignment T.DBusSignature  = 1+ alignment (T.DBusArray _) = 4+ alignment (T.DBusDictionary _ _) = 4+ alignment (T.DBusStructure _) = 8+ alignment T.DBusVariant = 1+  padding :: Word64 -> Word8 -> Word64 padding current count = required where
hs/DBus/Wire/Marshal.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,20 +14,30 @@ --  -- 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 TypeFamilies #-} module DBus.Wire.Marshal where+ import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL++ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L import qualified Data.Binary.Builder as B+ import Data.Binary.Put (runPut) import qualified Data.Binary.IEEE754 as IEEE+ import DBus.Wire.Unicode (maybeEncodeUtf8)+ import qualified DBus.Constants as C+ import qualified DBus.Message.Internal as M+ import Data.Bits ((.|.)) import qualified Data.Set as Set+ import DBus.Wire.Internal import Control.Monad (when) import Data.Maybe (fromJust)@@ -34,6 +46,7 @@  import qualified DBus.Types as T import qualified DBus.Types.Internal as T+ data MarshalState = MarshalState {-# UNPACK #-} !B.Builder {-# UNPACK #-} !Word64  data MarshalR a = MarshalRL MarshalError | MarshalRR a {-# UNPACK #-} !MarshalState@@ -65,12 +78,15 @@ {-# INLINE putState #-} putState :: MarshalState -> MarshalM () putState s = MarshalM $ \_ _ -> MarshalRR () s+ runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString runMarshal m e = case unMarshalM m e (MarshalState B.empty 0) of 	MarshalRL err -> Left err 	MarshalRR _ (MarshalState builder _) -> Right $ B.toLazyByteString builder+ marshal :: T.Variant -> Marshal marshal v = case v of+ 	T.VarBoxWord8  x -> marshalWord8 x 	T.VarBoxWord16 x -> marshalBuilder 2 B.putWord16be B.putWord16le x 	T.VarBoxWord32 x -> marshalWord32 x@@ -78,16 +94,24 @@ 	T.VarBoxInt16  x -> marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral x 	T.VarBoxInt32  x -> marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral x 	T.VarBoxInt64  x -> marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral x+ 	T.VarBoxDouble x -> marshalDouble x+ 	T.VarBoxBool x -> marshalWord32 $ if x then 1 else 0+ 	T.VarBoxString x -> marshalText x 	T.VarBoxObjectPath x -> marshalText . T.strObjectPath $ x+ 	T.VarBoxSignature x -> marshalSignature x+ 	T.VarBoxArray x -> marshalArray x+ 	T.VarBoxDictionary x -> marshalArray (T.dictionaryToArray x)+ 	T.VarBoxStructure (T.Structure vs) -> do 		pad 8 		mapM_ marshal vs+ 	T.VarBoxVariant x -> do 		let textSig = T.typeCode . T.variantType $ x 		sig <- case T.variantSignature x of@@ -95,21 +119,25 @@ 			Nothing -> throwError $ InvalidVariantSignature textSig 		marshalSignature sig 		marshal x+ appendS :: BS.ByteString -> Marshal appendS bytes = MarshalM $ \_ (MarshalState builder count) -> let 	builder' = B.append builder $ B.fromByteString bytes 	count' = count + fromIntegral (BS.length bytes) 	in MarshalRR () (MarshalState builder' count')+ appendL :: L.ByteString -> Marshal appendL bytes = MarshalM $ \_ (MarshalState builder count) -> let 	builder' = B.append builder $ B.fromLazyByteString bytes 	count' = count + fromIntegral (L.length bytes) 	in MarshalRR () (MarshalState builder' count')+ pad :: Word8 -> Marshal pad count = MarshalM $ \e s@(MarshalState _ existing) -> let 	padding' = fromIntegral $ padding existing count 	bytes = BS.replicate padding' 0 	in unMarshalM (appendS bytes) e s+ marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal marshalBuilder size be le x = do 	pad size@@ -119,6 +147,7 @@ 			LittleEndian -> le x 		size' = fromIntegral size 		in MarshalRR () (MarshalState builder' (count + size'))+ data MarshalError 	= MessageTooLong Word64 	| ArrayTooLong Word64@@ -138,13 +167,16 @@ 		["Invalid variant signature: ", show x] 	show (InvalidText x) = concat 		["Text cannot be marshaled: ", show x]+ marshalWord32 :: Word32 -> Marshal marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le+ {-# INLINE marshalWord8 #-} marshalWord8 :: Word8 -> Marshal marshalWord8 x = MarshalM $ \_ (MarshalState builder count) -> let 	builder' = B.append builder $ B.singleton x 	in MarshalRR () (MarshalState builder' (count + 1))+ marshalDouble :: Double -> Marshal marshalDouble x = do 	pad 8@@ -154,6 +186,7 @@ 			LittleEndian -> IEEE.putFloat64le 		bytes = runPut $ put x 		in unMarshalM (appendL bytes) e s+ marshalText :: Text -> Marshal marshalText x = do 	bytes <- case maybeEncodeUtf8 x of@@ -164,6 +197,7 @@ 	marshalWord32 . fromIntegral . L.length $ bytes 	appendL bytes 	marshalWord8 0+ marshalSignature :: T.Signature -> Marshal marshalSignature x = do 	let bytes = T.bytesSignature x@@ -171,6 +205,7 @@ 	marshalWord8 size 	appendS bytes 	marshalWord8 0+ marshalArray :: T.Array -> Marshal marshalArray x = do 	(arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x@@ -180,9 +215,11 @@ 	marshalWord32 $ fromIntegral arrayLen 	appendL $ L.replicate arrayPadding 0 	appendL arrayBytes+ getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString) getArrayBytes T.DBusByte x = return (0, bytes) where 	Just bytes = T.arrayToBytes x+ getArrayBytes itemType x = do 	let vs = T.arrayItems x 	s <- getState@@ -197,10 +234,12 @@ 	 	putState s 	return (paddingSize, itemBytes)+ encodeFlags :: Set.Set M.Flag -> Word8 encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where 	flagValue M.NoReplyExpected = 0x1 	flagValue M.NoAutoStart     = 0x2+ encodeField :: M.HeaderField -> T.Structure encodeField (M.Path x)        = encodeField' 1 x encodeField (M.Interface x)   = encodeField' 2 x@@ -216,9 +255,12 @@ 	[ T.toVariant code 	, T.toVariant $ T.toVariant x 	]++ -- | 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@@ -236,6 +278,7 @@ 		pad 8 		appendL bodyBytes 		checkMaximumSize+ checkBodySig :: [T.Variant] -> MarshalM T.Signature checkBodySig vs = let 	textSig = TL.concat . map (T.typeCode . T.variantType) $ vs@@ -244,6 +287,7 @@ 	in case T.mkBytesSignature bytesSig of 		Just x -> return x 		Nothing -> invalid+ marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32               -> Marshal marshalHeader msg serial bodySig bodyLength = do@@ -256,8 +300,10 @@ 	let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant] 	marshalArray . fromJust . T.toArray fieldType 	        $ map encodeField fields+ marshalEndianness :: Endianness -> Marshal marshalEndianness = marshal . T.toVariant . encodeEndianness+ checkMaximumSize :: Marshal checkMaximumSize = do 	(MarshalState _ messageLength) <- getState
hs/DBus/Wire/Unicode.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,6 +14,7 @@ --  -- 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.Unicode 	( maybeEncodeUtf8 	, maybeDecodeUtf8) where
hs/DBus/Wire/Unmarshal.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,22 +14,35 @@ --  -- 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 TypeFamilies #-} module DBus.Wire.Unmarshal where+ import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL++ import Control.Monad (liftM) import qualified DBus.Util.MonadError as E import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL+ import qualified Data.Binary.Get as G+ import qualified Data.Binary.IEEE754 as IEEE+ import DBus.Wire.Unicode (maybeDecodeUtf8)+ import qualified DBus.Message.Internal as M+ import Data.Bits ((.&.)) import qualified Data.Set as Set+ import qualified DBus.Constants as C+ import Control.Monad (when, unless) import Data.Maybe (fromJust, listToMaybe, fromMaybe) import Data.Word (Word8, Word32, Word64)@@ -35,6 +50,8 @@  import DBus.Wire.Internal import qualified DBus.Types.Internal as T+import DBus.Util (void)+ data UnmarshalState = UnmarshalState BL.ByteString {-# UNPACK #-} !Word64  data UnmarshalR a = UnmarshalRL UnmarshalError | UnmarshalRR a {-# UNPACK #-} !UnmarshalState@@ -65,14 +82,17 @@ {-# INLINE putState #-} putState :: UnmarshalState -> Unmarshal () putState s = Unmarshal $ \_ _ -> UnmarshalRR () s+ runUnmarshal :: Unmarshal a -> Endianness -> BL.ByteString -> Either UnmarshalError a runUnmarshal m e bytes = case unUnmarshal m e (UnmarshalState bytes 0) of 	UnmarshalRL err -> Left err 	UnmarshalRR a _ -> Right a+ unmarshal :: T.Signature -> Unmarshal [T.Variant] unmarshal = mapM unmarshalType . T.signatureTypes  unmarshalType :: T.Type -> Unmarshal T.Variant+ unmarshalType T.DBusByte = liftM (T.toVariant . BL.head) $ consume 1 unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le@@ -89,25 +109,33 @@ unmarshalType T.DBusInt64  = do 	x <- unmarshalGet 8 G.getWord64be G.getWord64le 	return . T.toVariant $ (fromIntegral x :: Int64)+ unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le+ unmarshalType T.DBusBoolean = unmarshalWord32 >>= 	fromMaybeU' "boolean" (\x -> case x of 		0 -> Just False 		1 -> Just True 		_ -> Nothing)+ unmarshalType T.DBusString = liftM T.toVariant unmarshalText  unmarshalType T.DBusObjectPath = unmarshalText >>= 	fromMaybeU' "object path" T.mkObjectPath+ unmarshalType T.DBusSignature = liftM T.toVariant unmarshalSignature+ unmarshalType (T.DBusArray t) = T.toVariant `liftM` unmarshalArray t+ unmarshalType (T.DBusDictionary kt vt) = do 	let pairType = T.DBusStructure [kt, vt] 	array <- unmarshalArray pairType 	fromMaybeU' "dictionary" T.arrayToDictionary array+ unmarshalType (T.DBusStructure ts) = do 	skipPadding 8 	liftM (T.toVariant . T.Structure) $ mapM unmarshalType ts+ unmarshalType T.DBusVariant = do 	let getType sig = case T.signatureTypes sig of 		[t] -> Just t@@ -115,6 +143,7 @@ 	 	t <- fromMaybeU "variant signature" getType =<< unmarshalSignature 	T.toVariant `liftM` unmarshalType t+ {-# INLINE consume #-} consume :: Word64 -> Unmarshal BL.ByteString consume count = Unmarshal $ \_ (UnmarshalState bytes offset) -> let@@ -123,18 +152,21 @@ 	in if BL.length x == count' 		then UnmarshalRR x (UnmarshalState bytes' (offset + count)) 		else UnmarshalRL $ UnexpectedEOF offset+ skipPadding :: Word8 -> Unmarshal () skipPadding count = do 	(UnmarshalState _ offset) <- getState 	bytes <- consume $ padding offset count 	unless (BL.all (== 0) bytes) $ 		throwError $ InvalidPadding offset+ skipTerminator :: Unmarshal () skipTerminator = do 	(UnmarshalState _ offset) <- getState 	bytes <- consume 1 	unless (BL.all (== 0) bytes) $ 		throwError $ MissingTerminator offset+ fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b fromMaybeU label f x = case f x of 	Just x' -> return x'@@ -145,6 +177,7 @@ fromMaybeU' label f x = do 	x' <- fromMaybeU label f x 	return $ T.toVariant x'+ unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a unmarshalGet count be le = do 	skipPadding count@@ -159,6 +192,7 @@ unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a               -> Unmarshal T.Variant unmarshalGet' count be le = T.toVariant `liftM` unmarshalGet count be le+ untilM :: Monad m => m Bool -> m a -> m [a] untilM test comp = do 	done <- test@@ -168,6 +202,7 @@ 			x <- comp 			xs <- untilM test comp 			return $ x:xs+ data UnmarshalError 	= UnsupportedProtocolVersion Word8 	| UnexpectedEOF Word64@@ -195,14 +230,17 @@ 	show (MissingTerminator pos) = concat 		["Missing NUL terminator at position ", show pos] 	show ArraySizeMismatch = "Array size mismatch"+ unmarshalWord32 :: Unmarshal Word32 unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le+ unmarshalText :: Unmarshal Text unmarshalText = do 	byteCount <- unmarshalWord32 	bytes <- consume . fromIntegral $ byteCount 	skipTerminator 	fromMaybeU "text" maybeDecodeUtf8 bytes+ unmarshalSignature :: Unmarshal T.Signature unmarshalSignature = do 	byteCount <- BL.head `liftM` consume 1@@ -210,10 +248,12 @@ 	skipTerminator 	let bytes = B.concat $ BL.toChunks lazy 	fromMaybeU "signature" T.mkBytesSignature bytes+ unmarshalArray :: T.Type -> Unmarshal T.Array unmarshalArray T.DBusByte = do 	byteCount <- unmarshalWord32 	T.arrayFromBytes `liftM` consume (fromIntegral byteCount)+ unmarshalArray itemType = do 	let getOffset = do 		(UnmarshalState _ o) <- getState@@ -227,12 +267,14 @@ 	when (end' > end) $ 		throwError ArraySizeMismatch 	fromMaybeU "array" (T.arrayFromItems itemType) vs+ 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]+ decodeField :: T.Structure             -> E.ErrorM UnmarshalError [M.HeaderField] decodeField struct = case unpackField struct of@@ -251,26 +293,34 @@ decodeField' x f label = case T.fromVariant x of 	Just x' -> return [f x'] 	Nothing -> E.throwErrorM $ InvalidHeaderField label x+ unpackField :: T.Structure -> (Word8, T.Variant) unpackField struct = (c', v') where 	T.Structure [c, v] = struct 	c' = fromJust . T.fromVariant $ c 	v' = fromJust . T.fromVariant $ v++ -- | Read bytes from a monad until a complete message has been received.+ unmarshalMessage :: Monad m => (Word32 -> m BL.ByteString)                  -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do 	let getBytes = E.ErrorT . liftM Right . getBytes' 	+ 	let fixedSig = "yyyyuuu" 	fixedBytes <- getBytes 16+ 	let messageVersion = BL.index fixedBytes 3 	when (messageVersion /= C.protocolVersion) $ 		E.throwErrorT $ UnsupportedProtocolVersion messageVersion+ 	let eByte = BL.index fixedBytes 0 	endianness <- case decodeEndianness eByte of 		Just x' -> return x' 		Nothing -> E.throwErrorT . Invalid "endianness" . TL.pack . show $ eByte+ 	let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of 		Right x' -> return x' 		Left  e  -> E.throwErrorT e@@ -279,31 +329,44 @@ 	let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2 	let bodyLength = fromJust . T.fromVariant $ fixed !! 4 	let serial = fromJust . T.fromVariant $ fixed !! 5+ 	let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6++ 	let headerSig  = "yyyyuua(yv)" 	fieldBytes <- getBytes fieldByteCount 	let headerBytes = BL.append fixedBytes fieldBytes 	header <- unmarshal' headerSig headerBytes+ 	let fieldArray = fromJust . T.fromVariant $ header !! 6 	let fieldStructures = fromJust . T.fromArray $ fieldArray 	fields <- case E.runErrorM $ concat `liftM` mapM decodeField fieldStructures of 		Left err -> E.throwErrorT err 		Right x -> return x++ 	let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8-	getBytes . fromIntegral $ bodyPadding+	void (getBytes (fromIntegral bodyPadding))+ 	let bodySig = findBodySignature fields+ 	bodyBytes <- getBytes bodyLength 	body <- unmarshal' bodySig bodyBytes++ 	y <- case E.runErrorM $ buildReceivedMessage typeCode fields of 		Right x -> return x 		Left err -> E.throwErrorT $ MissingHeaderField err 	return $ y serial flags body+ findBodySignature :: [M.HeaderField] -> T.Signature findBodySignature fields = fromMaybe "" signature where 	signature = listToMaybe [x | M.Signature x <- fields]+ buildReceivedMessage :: Word8 -> [M.HeaderField] -> E.ErrorM Text                         (M.Serial -> (Set.Set M.Flag) -> [T.Variant]                          -> M.ReceivedMessage)+ buildReceivedMessage 1 fields = do 	path <- require "path" [x | M.Path x <- fields] 	member <- require "member name" [x | M.Member x <- fields]@@ -313,6 +376,7 @@ 		sender = listToMaybe [x | M.Sender x <- fields] 		msg = M.MethodCall path member iface dest flags body 		in M.ReceivedMethodCall serial sender msg+ buildReceivedMessage 2 fields = do 	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] 	return $ \serial _ body -> let@@ -320,6 +384,7 @@ 		sender = listToMaybe [x | M.Sender x <- fields] 		msg = M.MethodReturn replySerial dest body 		in M.ReceivedMethodReturn serial sender msg+ buildReceivedMessage 3 fields = do 	name <- require "error name" [x | M.ErrorName x <- fields] 	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]@@ -328,6 +393,7 @@ 		sender = listToMaybe [x | M.Sender x <- fields] 		msg = M.Error name replySerial dest body 		in M.ReceivedError serial sender msg+ buildReceivedMessage 4 fields = do 	path <- require "path" [x | M.Path x <- fields] 	member <- require "member name" [x | M.Member x <- fields]@@ -337,10 +403,12 @@ 		sender = listToMaybe [x | M.Sender x <- fields] 		msg = M.Signal path member iface dest body 		in M.ReceivedSignal serial sender msg+ buildReceivedMessage typeCode fields = return $ \serial flags body -> let 	sender = listToMaybe [x | M.Sender x <- fields] 	msg = M.Unknown typeCode flags body 	in M.ReceivedUnknown serial sender msg+ require :: Text -> [a] -> E.ErrorM Text a require _     (x:_) = return x require label _     = E.throwErrorM label
hs/Tests.hs view
@@ -1,3 +1,5 @@++ -- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com> --  -- This program is free software: you can redistribute it and/or modify@@ -12,8 +14,12 @@ --  -- 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 (tests, main) where+ import Test.QuickCheck import qualified Test.Framework as F import Test.Framework.Providers.QuickCheck2 (testProperty)@@ -40,8 +46,10 @@ import DBus.Wire.Unmarshal import qualified DBus.Introspection as I + tests :: [F.Test] tests = [ F.testGroup "dummy" []+ 	, F.testGroup "String" 		[ testProperty "String -> strict Text" 			$ funEq (fromVariant . toVariant) (Just . T.pack)@@ -56,19 +64,23 @@ 		, testProperty "Strict Text <- lazy Text" 			$ funEq (fromVariant . toVariant) (Just . T.pack . TL.unpack) 		]+ 	, F.testGroup "Signature" 		[ testProperty "Signature identity" 			$ funEq (mkSignature . strSignature) Just 		]+ 	, F.testGroup "ObjectPath" 		[ testProperty "ObjectPath identity" 			$ funEq (mkObjectPath . strObjectPath) Just 		]+ 	, F.testGroup "Array" 		[ testProperty "Array identity" 			$ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x) 		, testProperty "Array homogeneity" prop_ArrayHomogeneous 		]+ 	, F.testGroup "Dictionary" 		[ testProperty "Dictionary identity" 			$ \x -> Just x == dictionaryFromItems@@ -82,22 +94,27 @@ 		, testProperty "Dictionary <-> Array conversion" 			$ funEq (arrayToDictionary . dictionaryToArray) Just 		]+ 	, F.testGroup "BusName" 		[ testProperty "BusName identity" 			$ funEq (mkBusName . strBusName) Just 		]+ 	, F.testGroup "InterfaceName" 		[ testProperty "InterfaceName identity" 			$ funEq (mkInterfaceName . strInterfaceName) Just 		]+ 	, F.testGroup "ErrorName" 		[ testProperty "ErrorName identity" 			$ funEq (mkErrorName . strErrorName) Just 		]+ 	, F.testGroup "MemberName" 		[ testProperty "MemberName identity" 			$ funEq (mkMemberName . strMemberName) Just 		]+ 	, F.testGroup "Wire format" 		[ testProperty "Marshal -> Ummarshal" prop_Unmarshal 		, F.testGroup "Messages"@@ -107,6 +124,7 @@ 			, testProperty "Signals" prop_WireSignal 			] 		]+ 	, F.testGroup "Addresses" 		[ testProperty "Address identity" 			$ \x -> mkAddresses (strAddress x) == Just [x]@@ -137,6 +155,7 @@ 			, test "no param" $ isNothing . mkAddresses $ "a:," 			] 		]+ 	, F.testGroup "Introspection" 		[ testProperty "Generate -> Parse" 			$ \x@(I.Object path _ _) -> let@@ -145,10 +164,12 @@ 			parsed = I.fromXML path xml' 			in isJust xml ==> I.fromXML path xml' == Just x 		]+ 	]  main :: IO () main = F.defaultMain tests+ instance Arbitrary Type where 	arbitrary = oneof [atomicType, containerType] @@ -179,6 +200,7 @@ 			return $ DBusDictionary kt vt 		2 -> fmap DBusStructure $ halfSized arbitrary 		3 -> return DBusVariant+ instance Arbitrary Variant where 	arbitrary = arbitrary >>= genVariant @@ -200,14 +222,17 @@ 	(DBusDictionary _ _) -> fmap toVariant (arbitrary :: Gen Dictionary) 	(DBusStructure _)    -> fmap toVariant (arbitrary :: Gen Structure) 	DBusVariant          -> fmap toVariant (arbitrary :: Gen Variant)+ instance Arbitrary Signature where 	arbitrary = sizedText 255 $ 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 = atLeast 1 (atLeast 1 (elements c))+ instance Arbitrary Array where 	arbitrary = do 		t <- atomicType@@ -221,6 +246,7 @@ 	firstType = if null types 		then DBusByte 		else head types+ instance Arbitrary Dictionary where 	arbitrary = do 		kt <- atomicType@@ -236,8 +262,10 @@ 	vType = dictionaryValueType x 	correctType (k, v) = variantType k == kType && 	                     variantType v == vType+ instance Arbitrary Structure where 	arbitrary = fmap Structure $ halfSized arbitrary+ instance Arbitrary BusName where 	arbitrary = sizedText 255 (oneof [unique, wellKnown]) where 		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"@@ -255,6 +283,7 @@ 			x <- elements start 			xs <- atLeast 0 (elements c') 			return (x:xs)+ instance Arbitrary InterfaceName where 	arbitrary = sizedText 255 genName where 		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"@@ -266,8 +295,10 @@ 			x <- elements c 			xs <- atLeast 0 (elements c') 			return (x:xs)+ instance Arbitrary ErrorName where 	arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary+ instance Arbitrary MemberName where 	arbitrary = sizedText 255 genName where 		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"@@ -277,10 +308,13 @@ 			x <- elements c 			xs <- atLeast 0 (elements c') 			return . TL.pack $ (x:xs)+ instance Arbitrary Flag where 	arbitrary = elements [NoReplyExpected, NoAutoStart]+ instance Arbitrary Serial where 	arbitrary = fmap Serial arbitrary+ instance Arbitrary MethodCall where 	arbitrary = do 		path   <- arbitrary@@ -290,12 +324,14 @@ 		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@@ -303,6 +339,7 @@ 		dest   <- arbitrary 		Structure body <- arbitrary 		return $ Error name serial dest body+ instance Arbitrary Signal where 	arbitrary = do 		path   <- arbitrary@@ -311,8 +348,10 @@ 		dest   <- arbitrary 		Structure body <- arbitrary 		return $ Signal path member iface dest body+ instance Arbitrary Endianness where 	arbitrary = elements [LittleEndian, BigEndian]+ prop_Unmarshal :: Endianness -> Variant -> Property prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where 	sig = mkSignature . typeCode . variantType $ x@@ -345,6 +384,7 @@  prop_WireSignal e serial msg = prop_MarshalMessage e serial msg 	$ ReceivedSignal serial Nothing msg+ instance Arbitrary Address where 	arbitrary = genAddress where 		optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."@@ -381,6 +421,7 @@ 			let addrStr = concat [m, ":", params, extraSemicolon] 			let Just [addr] = mkAddresses $ TL.pack addrStr 			return addr+ subObject :: ObjectPath -> Gen I.Object subObject parentPath = sized $ \n -> resize (min n 4) $ do 	let nonRoot = do@@ -443,6 +484,7 @@ 			[[], [I.Read], [I.Write], 			 [I.Read, I.Write]] 		return $ I.Property (TL.pack name) sig access+ halfSized :: Gen a -> Gen a halfSized gen = sized $ \n -> if n > 0 then 	resize (n `div` 2) gen@@ -466,9 +508,11 @@  isRight :: Either a b -> Bool isRight = either (const False) (const True)+ 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+ instance Arbitrary T.Text where 	arbitrary = fmap T.pack arbitrary
src/addresses.anansi view
@@ -32,7 +32,7 @@ import Text.Printf (printf) import qualified Text.ParserCombinators.Parsec as P import Text.ParserCombinators.Parsec ((<|>))-import DBus.Util (hexToInt, eitherToMaybe)+import DBus.Util (hexToInt, eitherToMaybe, void) :  \subsection{Address syntax}@@ -98,13 +98,13 @@ mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where 	address = do 		method <- P.many (P.noneOf ":;")-		P.char ':'+		void (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 '='+		void (P.char '=') 		value <- P.many1 (encodedValue <|> unencodedValue) 		return (TL.pack key, TL.pack value) 	@@ -115,7 +115,7 @@ 	 	unencodedValue = P.oneOf optionallyEncoded 	encodedValue = do-		P.char '%'+		void (P.char '%') 		hex <- P.count 2 P.hexDigit 		return . chr . hexToInt $ hex :
src/util.anansi view
@@ -104,6 +104,9 @@ -- | Drop /n/ items from the end of a list dropEnd :: Int -> [a] -> [a] dropEnd n xs = take (length xs - n) xs++void :: Monad m => m a -> m ()+void m = m >> return () :  \subsection{Bundled ErrorT variant}
src/wire.anansi view
@@ -256,6 +256,7 @@  import DBus.Wire.Internal import qualified DBus.Types.Internal as T+import DBus.Util (void) :  :d unmarshal imports@@ -1078,7 +1079,7 @@  :d read body let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8-getBytes . fromIntegral $ bodyPadding+void (getBytes (fromIntegral bodyPadding)) :  :f DBus/Wire/Unmarshal.hs