diff --git a/DBus/Bus.lhs b/DBus/Bus.lhs --- a/DBus/Bus.lhs +++ b/DBus/Bus.lhs @@ -15,18 +15,20 @@ \ignore{ \begin{code} -{-# LANGUAGE DeriveDataTypeable #-} module DBus.Bus ( getSystemBus , getSessionBus - , register + , getFirstBus + , getBus ) where -import Data.Typeable (Typeable, cast) -import Data.Maybe (fromJust) +import qualified Control.Exception as E +import Control.Monad (when) + +import Data.Maybe (fromJust, isNothing) import qualified Data.Set as Set + import System.Environment (getEnv) -import qualified Control.Exception as E import qualified DBus.Bus.Address as A import qualified DBus.Bus.Connection as C import qualified DBus.Message as M @@ -34,37 +36,40 @@ \end{code} } +\section{Connecting to a message bus} + +Connecting to a message bus is a bit more involved than just connecting +over an app-to-app connection: the bus must be notified of the new client, +using a "hello message", before it will begin forwarding messages. + \begin{code} getBus :: A.Address -> IO (C.Connection, T.BusName) getBus addr = do - c <- C.connect . C.findTransport $ addr - name <- register c + c <- C.connect addr + name <- sendHello c return (c, name) \end{code} -\begin{code} -findBusName :: M.ReceivedMessage -> Maybe T.BusName -findBusName (M.ReceivedMethodReturn _ _ msg) = name where - name = case M.methodReturnBody msg of - [x] -> T.fromVariant x - _ -> Nothing -findBusName _ = Nothing -\end{code} +Optionally, multiple addresses may be provided. The first successfully +connected bus will be returned. \begin{code} -register :: C.Connection -> IO T.BusName -register c = do - C.send c return hello - reply <- C.recv c >>= \x -> case x of - Right x' -> return x' - Left err -> E.throwIO . E.AssertionFailed $ err - case findBusName reply of - Just x -> return x - Nothing -> E.throwIO . E.AssertionFailed $ "Received inappropriate reply to Hello()." +getFirstBus :: [A.Address] -> IO (C.Connection, T.BusName) +getFirstBus as = getFirstBus' as as + +getFirstBus' :: [A.Address] -> [A.Address] -> IO (C.Connection, T.BusName) +getFirstBus' orig [] = E.throwIO $ C.NoWorkingAddress orig +getFirstBus' orig (a:as) = E.catch (getBus a) onError where + onError :: E.SomeException -> IO (C.Connection, T.BusName) + onError _ = getFirstBus' orig as \end{code} -\section{Default connections} +\subsection{Default connections} +Two default buses are defined, the ``system'' and ``session'' buses. The system +bus is global for the OS, while the session bus runs only for the duration +of the user's session. + \begin{code} getSystemBus :: IO (C.Connection, T.BusName) getSystemBus = getBus addr where @@ -76,19 +81,14 @@ getSessionBus :: IO (C.Connection, T.BusName) getSessionBus = do env <- getEnv "DBUS_SESSION_BUS_ADDRESS" + case A.parseAddresses env of - Just (addr:_) -> getBus addr - _ -> E.throwIO $ BadAddress env + Just [x] -> getBus x + Just x -> getFirstBus x + _ -> E.throwIO $ C.InvalidAddress env \end{code} -\begin{code} -data BadAddress = BadAddress String - deriving (Show, Typeable) - -instance E.Exception BadAddress where - toException = E.SomeException - fromException = cast -\end{code} +\subsection{Sending the ``hello'' message} \begin{code} hello :: M.MethodCall @@ -100,3 +100,32 @@ Set.empty [] \end{code} + +\begin{code} +sendHello :: C.Connection -> IO T.BusName +sendHello c = do + serial <- C.send c return hello + reply <- waitForReply c serial + let name = case M.methodReturnBody reply of + [x] -> T.fromVariant x + _ -> Nothing + + when (isNothing name) + (E.throwIO . C.ProtocolException $ + "Received inappropriate reply to Hello().") + + return . fromJust $ name +\end{code} + +\begin{code} +waitForReply :: C.Connection -> T.Serial -> IO M.MethodReturn +waitForReply c serial = do + msg <- C.receive c + case msg of + (M.ReceivedMethodReturn _ _ reply) -> + if M.methodReturnSerial reply == serial + then return reply + else waitForReply c serial + _ -> waitForReply c serial +\end{code} + diff --git a/DBus/Bus/Connection.lhs b/DBus/Bus/Connection.lhs --- a/DBus/Bus/Connection.lhs +++ b/DBus/Bus/Connection.lhs @@ -17,23 +17,26 @@ \begin{code} {-# LANGUAGE DeriveDataTypeable #-} module DBus.Bus.Connection - ( Transport (..) - , findTransport - , Connection + ( Connection + , ConnectionException (..) + , ProtocolException (..) , connect , send - , recv + , receive ) where import qualified Control.Concurrent as C import qualified Control.Exception as E + import Data.Word (Word32) import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.UTF8 (toString, fromString) import qualified Data.Map as Map -import Data.Typeable (Typeable, cast) +import Data.Typeable (Typeable) + import qualified Network as N import qualified System.IO as I + import qualified DBus.Types as T import DBus.Message (Message, ReceivedMessage, marshal, unmarshal) import qualified DBus.Bus.Address as A @@ -41,77 +44,132 @@ \end{code} } -\section{Transports} +\section{Connections} -A transport is anything which can be used to construct a (send, recv) -computation pair. +A {\tt Connection} is an opaque handle to an open DBus channel, with +an internal state for maintaining the current message serial. \begin{code} -data Transport = Transport - { transportAddress :: A.Address - , transportConnect :: IO - ( L.ByteString -> IO () - , Word32 -> IO L.ByteString - ) - } +data Connection = Connection A.Address Transport (C.MVar T.Serial) \end{code} +While not particularly useful for other functions, being able to {\tt show} +a {\tt Connection} is useful when debugging. + \begin{code} -instance Show Transport where - showsPrec d (Transport a _) = showParen (d > 10) $ - showString' [""] where +instance Show Connection where + showsPrec d (Connection a _ _) = showParen (d > 10) $ + showString' [""] where showString' = foldr (.) id . map showString \end{code} +A connection can be opened to any valid address, though actually connecting +might fail due to external factors. + \begin{code} -findTransport :: A.Address -> Transport -findTransport a = transport' (A.addressMethod a) a where - transport' "unix" = unix - transport' _ = unknownTransport +connect :: A.Address -> IO Connection +connect a = do + t <- connectTransport a + let putS = transportSend t . fromString + let getS = fmap toString . transportRecv t + authenticate putS getS + serialMVar <- C.newMVar T.firstSerial + return $ Connection a t serialMVar \end{code} -\subsection{UNIX} +Sending a message will increment the connection's internal serial state. +The second parameter is present to allow registration of a callback before +the message has actually been sent, which avoids race conditions in +multi-threaded clients. -known parameters: - * path - * abstract - * tmpdir (only for listening) +\begin{code} +send :: Message a => Connection -> (T.Serial -> IO b) -> a -> IO b +send (Connection _ t mvar) io msg = withSerial mvar $ \serial -> do + x <- io serial + transportSend t . marshal T.LittleEndian serial $ msg + return x -If an invalid set of parameters is provided, the transport will still -be built, but will not be able to connect. +withSerial :: C.MVar T.Serial -> (T.Serial -> IO a) -> IO a +withSerial m io = E.block $ do + s <- C.takeMVar m + let s' = T.nextSerial s + x <- E.unblock (io s) `E.onException` C.putMVar m s' + C.putMVar m s' + return x +\end{code} +Messages are received wrapped in a {\tt ReceivedMessage} value. If an error +is encountered while unmarshaling, an exception will be thrown. + \begin{code} -data BadParameters = BadParameters String - deriving (Show, Typeable) +receive :: Connection -> IO ReceivedMessage +receive (Connection _ t _) = do + either' <- unmarshal $ transportRecv t + case either' of + Right x -> return x + Left err -> E.throwIO . ProtocolException $ err +\end{code} -instance E.Exception BadParameters where - toException = E.SomeException - fromException = cast +\section{Transports} -unix :: A.Address -> Transport -unix a = handleTransport a connect' where +A transport is anything which can send and receive bytestrings, typically +over a socket. + +\begin{code} +data Transport = Transport + { transportSend :: L.ByteString -> IO () + , transportRecv :: Word32 -> IO L.ByteString + } +\end{code} + +\begin{code} +connectTransport :: A.Address -> IO Transport +connectTransport a = transport' (A.addressMethod a) a where + transport' "unix" = unix + transport' _ = unknownTransport +\end{code} + +\subsection{UNIX} + +The {\sc unix} transport accepts two parameters: {\tt path}, which is a +simple filesystem path, and {\tt abstract}, which is a path in the +Linux-specific abstract domain. One, and only one, of these parameters must +be specified. + +\begin{code} +unix :: A.Address -> IO Transport +unix a = handleTransport . N.connectTo "localhost" =<< port where params = A.addressParameters a path = Map.lookup "path" params abstract = Map.lookup "abstract" params + + tooMany = "Only one of `path' or `abstract' may be specified for the" + ++ " `unix' method." + tooFew = "One of `path' or `abstract' must be specified for the" + ++ " `unix' transport." + + port = fmap N.UnixSocket path' path' = case (path, abstract) of - (Just _, Just _) -> E.throwIO (BadParameters "got path and abstract") - (Nothing, Nothing) -> E.throwIO (BadParameters "need path or abstract") + (Just _, Just _) -> E.throwIO $ BadParameters a tooMany + (Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew (Just x, Nothing) -> return x (Nothing, Just x) -> return $ '\x00':x - connect' = N.connectTo "localhost" =<< fmap N.UnixSocket path' \end{code} \subsection{TCP} known parameters: - * host (optional, default "localhost") - * port - * family (optional, choices are "ipv4" or "ipv6" +\begin{itemize} +\item {\tt host} (optional, default "{\tt localhost}") +\item {\tt port} +\item {\tt family} (optional, choices are "{\tt ipv4}" or "{\tt ipv6}" +\end{itemize} + TCP support is TODO -\begin{code}% -tcp :: A.Address -> Transport +\begin{otherCode} +tcp :: A.Address -> IO Transport tcp a@(A.Address _ params) = handleTransport a connect' where host = lookup "host" params port = parsePort =<< lookup "post" params @@ -124,76 +182,55 @@ parsePort :: String -> Maybe PortNumber parseFamily :: String -> Maybe Family -\end{code}% +\end{otherCode} \subsection{Generic handle-based transport} -both UNIX and TCP use generic handle-based transport: +Both UNIX and TCP are backed by standard handles, and can therefore use +a shared handle-based transport backend. \begin{code} -handleTransport :: A.Address -> IO I.Handle -> Transport -handleTransport addr io = Transport addr $ do +handleTransport :: IO I.Handle -> IO Transport +handleTransport io = do h <- io I.hSetBuffering h I.NoBuffering I.hSetBinaryMode h True - let get' = L.hGet h .fromIntegral - return (L.hPut h, get') + return $ Transport (L.hPut h) (L.hGet h . fromIntegral) \end{code} \subsection{Unknown transports} +If a method has no known transport, attempting to connect using it will +just result in an exception. + \begin{code} -unknownTransport :: A.Address -> Transport -unknownTransport a = Transport a $ do - let m = A.addressMethod a - let err = "Unknown method " ++ show m ++ - " in address " ++ (show . A.strAddress) a ++ "." - - E.throwIO . E.AssertionFailed $ err +unknownTransport :: A.Address -> IO Transport +unknownTransport = E.throwIO . UnknownMethod \end{code} -\section{Connections} +\subsection{Errors} +If connecting to DBus fails, a {\tt ConnectionException} will be thrown. +The constructor describes which exception occurred. + \begin{code} -data Connection = Connection Transport (C.MVar T.Serial) - (L.ByteString -> IO ()) - (Word32 -> IO L.ByteString) +data ConnectionException = + InvalidAddress String + | BadParameters A.Address String + | UnknownMethod A.Address + | NoWorkingAddress [A.Address] + deriving (Show, Typeable) -instance Show Connection where - showsPrec d (Connection (Transport a _) _ _ _) = showParen (d > 10) $ - showString' [""] where - showString' = foldr (.) id . map showString +instance E.Exception ConnectionException \end{code} -\begin{code} -connect :: Transport -> IO Connection -connect t@(Transport _ connect') = do - (put, get) <- connect' - serialMVar <- C.newMVar T.firstSerial - let c = Connection t serialMVar put get - let put' = put . fromString - let get' = fmap toString . get - authenticate put' get' - return c -\end{code} +If a message cannot be unmarshaled --- for example, due to malformed or +truncated input --- a {\tt ProtocolException} will be thrown. \begin{code} -send :: Message a => Connection -> (T.Serial -> IO b) -> a -> IO b -send (Connection _ mvar put _) io msg = withSerial mvar $ \serial -> do - x <- io serial - put . marshal T.LittleEndian serial $ msg - return x +data ProtocolException = ProtocolException String + deriving (Show, Typeable) -withSerial :: C.MVar T.Serial -> (T.Serial -> IO a) -> IO a -withSerial m io = E.block $ do - s <- C.takeMVar m - let s' = T.nextSerial s - x <- E.unblock (io s) `E.onException` C.putMVar m s' - C.putMVar m s' - return x +instance E.Exception ProtocolException \end{code} -\begin{code} -recv :: Connection -> IO (Either String ReceivedMessage) -recv (Connection _ _ _ get) = unmarshal get -\end{code} diff --git a/DBus/Message.lhs b/DBus/Message.lhs --- a/DBus/Message.lhs +++ b/DBus/Message.lhs @@ -271,7 +271,7 @@ buildHeader :: Message a => T.Endianness -> T.Serial -> a -> Word32 -> MessageHeader buildHeader endianness serial m bodyLen = header where - ts = concatMap (T.signatureTypes . T.variantSignature) $ messageBody m + ts = map T.variantType $ messageBody m bodySig = fromJust . T.mkSignature $ concatMap T.typeString ts fields = Signature bodySig : messageHeaderFields m header = MessageHeader @@ -408,7 +408,7 @@ \begin{code} checkMatchingVersion :: (E.Error e, E.MonadError e m) => T.Variant -> m () -checkMatchingVersion v = unless (messageVersion == protocolVersion) $ do +checkMatchingVersion v = unless (messageVersion == protocolVersion) $ E.throwError . E.strMsg . concat $ [ "Protocol version mismatch: " , show messageVersion diff --git a/DBus/Protocol/Marshal.lhs b/DBus/Protocol/Marshal.lhs --- a/DBus/Protocol/Marshal.lhs +++ b/DBus/Protocol/Marshal.lhs @@ -40,31 +40,31 @@ \begin{code} marshal :: T.Endianness -> [T.Variant] -> L.ByteString -marshal e vs = runMarshal (mapM_ marshal' vs) e +marshal e vs = runMarshal (mapM_ marshalAny vs) e \end{code} \begin{code} -marshal' :: T.Variant -> Marshal -marshal' x = fromJust $ msum marshalers where - m f = fmap f . T.fromVariant - marshalers = map ($ x) - [ m bool - , m word8 - , m word16 - , m word32 - , m word64 - , m int16 - , m int32 - , m int64 - , m double - , m string - , m objectPath - , m signature - , m array - , m dictionary - , m structure - , m variant - ] +marshalAny :: T.Variant -> Marshal +marshalAny x = marshal' (T.variantType x) x where + v :: T.Variable a => T.Variant -> a + v = fromJust . T.fromVariant + + marshal' T.BooleanT = bool . v + marshal' T.ByteT = word8 . v + marshal' T.UInt16T = word16 . v + marshal' T.UInt32T = word32 . v + marshal' T.UInt64T = word64 . v + marshal' T.Int16T = int16 . v + marshal' T.Int32T = int32 . v + marshal' T.Int64T = int64 . v + marshal' T.DoubleT = double . v + marshal' T.StringT = string . v + marshal' T.ObjectPathT = objectPath . v + marshal' T.SignatureT = signature . v + marshal' (T.ArrayT _) = array . v + marshal' (T.DictionaryT _ _) = dictionary . v + marshal' (T.StructureT _) = structure . v + marshal' T.VariantT = variant . v \end{code} \subsection{Atoms} @@ -162,7 +162,7 @@ s <- S.get (MarshalState _ afterLength) <- word32 0 >> S.get (MarshalState _ afterPadding) <- pad (padByType itemType) >> S.get - (MarshalState _ afterItems) <- mapM_ marshal' vs >> S.get + (MarshalState _ afterItems) <- mapM_ marshalAny vs >> S.get let paddingBytes = L.drop (L.length afterLength) afterPadding let itemBytes = L.drop (L.length afterPadding) afterItems @@ -185,14 +185,14 @@ \begin{code} structure :: T.Structure -> Marshal -structure (T.Structure xs) = pad 8 >> mapM_ marshal' xs +structure (T.Structure xs) = pad 8 >> mapM_ marshalAny xs \end{code} \subsubsection{Variants} \begin{code} variant :: T.Variant -> Marshal -variant x = signature (T.variantSignature x) >> marshal' x +variant x = signature (T.variantSignature x) >> marshalAny x \end{code} \subsection{The {\tt Marshal} monad} diff --git a/DBus/Protocol/Padding.lhs b/DBus/Protocol/Padding.lhs --- a/DBus/Protocol/Padding.lhs +++ b/DBus/Protocol/Padding.lhs @@ -40,21 +40,21 @@ \begin{code} padByType :: T.Type -> Word8 -padByType T.BooleanT = 4 -padByType T.ByteT = 1 -padByType T.UInt16T = 2 -padByType T.UInt32T = 4 -padByType T.UInt64T = 8 -padByType T.Int16T = 2 -padByType T.Int32T = 4 -padByType T.Int64T = 8 -padByType T.DoubleT = 8 -padByType T.StringT = 4 -padByType T.ObjectPathT = 4 -padByType T.SignatureT = 1 -padByType T.VariantT = 1 -padByType (T.ArrayT _) = 4 -padByType (T.DictT _ _) = 4 -padByType (T.StructT _) = 8 +padByType T.BooleanT = 4 +padByType T.ByteT = 1 +padByType T.UInt16T = 2 +padByType T.UInt32T = 4 +padByType T.UInt64T = 8 +padByType T.Int16T = 2 +padByType T.Int32T = 4 +padByType T.Int64T = 8 +padByType T.DoubleT = 8 +padByType T.StringT = 4 +padByType T.ObjectPathT = 4 +padByType T.SignatureT = 1 +padByType (T.ArrayT _) = 4 +padByType (T.DictionaryT _ _) = 4 +padByType (T.StructureT _) = 8 +padByType T.VariantT = 1 \end{code} diff --git a/DBus/Protocol/Unmarshal.lhs b/DBus/Protocol/Unmarshal.lhs --- a/DBus/Protocol/Unmarshal.lhs +++ b/DBus/Protocol/Unmarshal.lhs @@ -51,22 +51,22 @@ \begin{code} unmarshal' :: T.Type -> Unmarshal T.Variant -unmarshal' T.BooleanT = fmap T.toVariant bool -unmarshal' T.ByteT = fmap T.toVariant word8 -unmarshal' T.UInt16T = fmap T.toVariant word16 -unmarshal' T.UInt32T = fmap T.toVariant word32 -unmarshal' T.UInt64T = fmap T.toVariant word64 -unmarshal' T.Int16T = fmap T.toVariant int16 -unmarshal' T.Int32T = fmap T.toVariant int32 -unmarshal' T.Int64T = fmap T.toVariant int64 -unmarshal' T.DoubleT = fmap T.toVariant double -unmarshal' T.StringT = fmap T.toVariant string -unmarshal' T.ObjectPathT = fmap T.toVariant objectPath -unmarshal' T.SignatureT = fmap T.toVariant signature -unmarshal' (T.ArrayT t) = fmap T.toVariant $ array t -unmarshal' (T.DictT kt vt) = fmap T.toVariant $ dictionary kt vt -unmarshal' (T.StructT ts) = fmap T.toVariant $ structure ts -unmarshal' T.VariantT = fmap T.toVariant variant +unmarshal' T.BooleanT = fmap T.toVariant bool +unmarshal' T.ByteT = fmap T.toVariant word8 +unmarshal' T.UInt16T = fmap T.toVariant word16 +unmarshal' T.UInt32T = fmap T.toVariant word32 +unmarshal' T.UInt64T = fmap T.toVariant word64 +unmarshal' T.Int16T = fmap T.toVariant int16 +unmarshal' T.Int32T = fmap T.toVariant int32 +unmarshal' T.Int64T = fmap T.toVariant int64 +unmarshal' T.DoubleT = fmap T.toVariant double +unmarshal' T.StringT = fmap T.toVariant string +unmarshal' T.ObjectPathT = fmap T.toVariant objectPath +unmarshal' T.SignatureT = fmap T.toVariant signature +unmarshal' (T.ArrayT t) = fmap T.toVariant $ array t +unmarshal' (T.DictionaryT kt vt) = fmap T.toVariant $ dictionary kt vt +unmarshal' (T.StructureT ts) = fmap T.toVariant $ structure ts +unmarshal' T.VariantT = fmap T.toVariant variant \end{code} \subsection{Atoms} @@ -174,7 +174,7 @@ \begin{code} dictionary :: T.Type -> T.Type -> Unmarshal T.Dictionary dictionary kt vt = do - arr <- array $ T.StructT [kt, vt] + arr <- array $ T.StructureT [kt, vt] structs <- fromMaybe T.fromArray arr "dictionary" pairs <- mapM mkPair structs let kSig = fromJust . T.mkSignature . T.typeString $ kt diff --git a/DBus/Types/Atom.lhs b/DBus/Types/Atom.lhs --- a/DBus/Types/Atom.lhs +++ b/DBus/Types/Atom.lhs @@ -24,6 +24,7 @@ , toAtom , fromAtom , atomSignature + , atomType , atomToVariant , atomFromVariant ) where @@ -80,6 +81,11 @@ \begin{code} atomSignature :: Atom -> S.Signature atomSignature (Atom v) = C.variantSignature v +\end{code} + +\begin{code} +atomType :: Atom -> S.Type +atomType = head . S.signatureTypes . atomSignature \end{code} \subsubsection{Built-in atomic types} diff --git a/DBus/Types/Containers.lhs b/DBus/Types/Containers.lhs --- a/DBus/Types/Containers.lhs +++ b/DBus/Types/Containers.lhs @@ -25,6 +25,7 @@ , fromVariant , defaultSignature , variantSignature + , variantType , Array , toArray @@ -107,6 +108,11 @@ \begin{code} variantSignature :: Variant -> S.Signature variantSignature (Variant s _) = s +\end{code} + +\begin{code} +variantType :: Variant -> S.Type +variantType = head . S.signatureTypes . variantSignature \end{code} \begin{code} diff --git a/DBus/Types/Signature.lhs b/DBus/Types/Signature.lhs --- a/DBus/Types/Signature.lhs +++ b/DBus/Types/Signature.lhs @@ -91,12 +91,12 @@ keyType <- parseAtom valueType <- parseType char '}' - return $ DictT keyType valueType + return $ DictionaryT keyType valueType parseStruct = do char '(' types <- many parseType char ')' - return $ StructT types + return $ StructureT types \end{code} Convert a signature to a string, for marshaling over the bus or display. @@ -125,26 +125,26 @@ | ObjectPathT | SignatureT | ArrayT Type - | DictT Type Type - | StructT [Type] + | DictionaryT Type Type + | StructureT [Type] | VariantT deriving (Show, Eq) typeString :: Type -> String -typeString BooleanT = "b" -typeString ByteT = "y" -typeString Int16T = "n" -typeString UInt16T = "q" -typeString Int32T = "i" -typeString UInt32T = "u" -typeString Int64T = "x" -typeString UInt64T = "t" -typeString DoubleT = "d" -typeString StringT = "s" -typeString ObjectPathT = "o" -typeString SignatureT = "g" -typeString (ArrayT t) = 'a' : typeString t -typeString (DictT kt vt) = "a{" ++ typeString kt ++ typeString vt ++ "}" -typeString (StructT ts) = "(" ++ concatMap typeString ts ++ ")" -typeString VariantT = "v" +typeString BooleanT = "b" +typeString ByteT = "y" +typeString Int16T = "n" +typeString UInt16T = "q" +typeString Int32T = "i" +typeString UInt32T = "u" +typeString Int64T = "x" +typeString UInt64T = "t" +typeString DoubleT = "d" +typeString StringT = "s" +typeString ObjectPathT = "o" +typeString SignatureT = "g" +typeString (ArrayT t) = 'a' : typeString t +typeString (DictionaryT kt vt) = "a{" ++ typeString kt ++ typeString vt ++ "}" +typeString (StructureT ts) = "(" ++ concatMap typeString ts ++ ")" +typeString VariantT = "v" \end{code} diff --git a/Examples/dbus-monitor.hs b/Examples/dbus-monitor.hs --- a/Examples/dbus-monitor.hs +++ b/Examples/dbus-monitor.hs @@ -55,13 +55,10 @@ findBus (o:_) = case o of BusOption Session -> getSessionBus BusOption System -> getSystemBus - AddressOption addr -> do - addr' <- case parseAddresses addr of - Just (x:_) -> return x - _ -> error $ "Invalid address: " ++ show addr - c <- connect . findTransport $ addr' - name <- register c - return (c, name) + AddressOption addr -> case parseAddresses addr of + Just [x] -> getBus x + Just x -> getFirstBus x + _ -> error $ "Invalid address: " ++ show addr addMatchMsg :: String -> MethodCall addMatchMsg match = MethodCall @@ -83,12 +80,8 @@ , "type='error'" ] -onMessage :: Either String ReceivedMessage -> IO () -onMessage (Left err) = do - hPutStrLn stderr err - exitFailure - -onMessage (Right msg) = putStrLn (formatMessage msg ++ "\n") +onMessage :: ReceivedMessage -> IO () +onMessage msg = putStrLn (formatMessage msg ++ "\n") main :: IO () main = do @@ -108,7 +101,7 @@ mapM_ (addMatch bus) filters - forever (recv bus >>= onMessage) + forever (receive bus >>= onMessage) -- Message formatting is verbose and mostly uninteresting, except as an -- excersise in string manipulation. @@ -250,7 +243,7 @@ , Line "]" ] -formatVariant' (DictT _ _) x = MultiLine lines' where +formatVariant' (DictionaryT _ _) x = MultiLine lines' where items = dictionaryItems . fromJust . fromVariant $ x lines' = [ Line "dictionary {" , Children . map formatItem $ items @@ -262,7 +255,7 @@ vHead = head v' vTail = map Line $ tail v' -formatVariant' (StructT _) x = MultiLine lines' where +formatVariant' (StructureT _) x = MultiLine lines' where Structure items = fromJust . fromVariant $ x lines' = [ Line "struct (" diff --git a/Tests/Containers.hs b/Tests/Containers.hs --- a/Tests/Containers.hs +++ b/Tests/Containers.hs @@ -40,7 +40,13 @@ , forAllAtomic prop_AtomDefaultSignature , forAllVariable prop_DefaultSignature , variantSignatureProperties - , [ property prop_VariantSignatureLength ] + + , [ property prop_VariantSignatureLength + , property prop_VariantType + , property prop_AtomType + ] + + , [ property prop_ArrayHomogeneous , property prop_DictHomogeneous0 , property prop_DictHomogeneous1 @@ -82,8 +88,7 @@ -- Test that signatures are set properly sameSig :: Variable a => a -> Type -> Bool -sameSig x t = [t] == t' where - t' = signatureTypes . variantSignature . toVariant $ x +sameSig x t = t == (variantType . toVariant) x sameSig' :: Variable a => (a -> Signature) -> a -> Bool sameSig' f x = f x == (variantSignature . toVariant) x @@ -111,6 +116,15 @@ prop_VariantSignatureLength x = length sig == 1 where sig = signatureTypes . variantSignature $ x +-- variantType is a shortcut for getting the type in a variant's +-- signature. +prop_VariantType x = variantType x == t where + t = head . signatureTypes . variantSignature $ x + +-- Ditto atomType +prop_AtomType x = atomType x == t where + t = head . signatureTypes . atomSignature $ x + -- All items in an array have the same signature. If items do not have -- the same signature, the array can't be constructed prop_ArrayHomogeneous vs = isJust array == homogeneousTypes where @@ -118,7 +132,7 @@ homogeneousTypes = if length vs > 0 then all (== firstType) types else True - types = map (signatureTypes . variantSignature) vs + types = map variantType vs firstType = head types sig = if length vs > 0 then variantSignature (head vs) @@ -140,10 +154,10 @@ keys = [k | (k,_) <- items] values = [v | (_,v) <- items] - kTypes = map (signatureTypes . atomSignature) keys + kTypes = map atomType keys kFirst = head kTypes - vTypes = map (signatureTypes . variantSignature) values + vTypes = map variantType values vFirst = head vTypes homogeneous = all (== kFirst) kTypes && all (== vFirst) vTypes diff --git a/Tests/Instances.hs b/Tests/Instances.hs --- a/Tests/Instances.hs +++ b/Tests/Instances.hs @@ -170,11 +170,11 @@ 1 -> do kt <- atomicType vt <- arbitrary - return $ DictT kt vt + return $ DictionaryT kt vt 2 -> sized structType 3 -> return VariantT -structType n | n >= 0 = fmap StructT $ resize (n `div` 2) arbitrary +structType n | n >= 0 = fmap StructureT $ resize (n `div` 2) arbitrary instance Arbitrary Atom where coarbitrary = undefined @@ -261,22 +261,22 @@ instance Arbitrary Variant where coarbitrary = undefined arbitrary = arbitrary >>= \t -> case t of - BooleanT -> fmap toVariant (arbitrary :: Gen Bool) - ByteT -> fmap toVariant (arbitrary :: Gen Word8) - UInt16T -> fmap toVariant (arbitrary :: Gen Word16) - UInt32T -> fmap toVariant (arbitrary :: Gen Word32) - UInt64T -> fmap toVariant (arbitrary :: Gen Word64) - Int16T -> fmap toVariant (arbitrary :: Gen Int16) - Int32T -> fmap toVariant (arbitrary :: Gen Int32) - Int64T -> fmap toVariant (arbitrary :: Gen Int64) - DoubleT -> fmap toVariant (arbitrary :: Gen Double) - StringT -> fmap toVariant (arbitrary :: Gen String) - ObjectPathT -> fmap toVariant (arbitrary :: Gen ObjectPath) - SignatureT -> fmap toVariant (arbitrary :: Gen Signature) - ArrayT _ -> fmap toVariant (arbitrary :: Gen Array) - DictT _ _ -> fmap toVariant (arbitrary :: Gen Dictionary) - StructT _ -> fmap toVariant (arbitrary :: Gen Structure) - VariantT -> fmap toVariant (arbitrary :: Gen Variant) + BooleanT -> fmap toVariant (arbitrary :: Gen Bool) + ByteT -> fmap toVariant (arbitrary :: Gen Word8) + UInt16T -> fmap toVariant (arbitrary :: Gen Word16) + UInt32T -> fmap toVariant (arbitrary :: Gen Word32) + UInt64T -> fmap toVariant (arbitrary :: Gen Word64) + Int16T -> fmap toVariant (arbitrary :: Gen Int16) + Int32T -> fmap toVariant (arbitrary :: Gen Int32) + Int64T -> fmap toVariant (arbitrary :: Gen Int64) + DoubleT -> fmap toVariant (arbitrary :: Gen Double) + StringT -> fmap toVariant (arbitrary :: Gen String) + ObjectPathT -> fmap toVariant (arbitrary :: Gen ObjectPath) + SignatureT -> fmap toVariant (arbitrary :: Gen Signature) + ArrayT _ -> fmap toVariant (arbitrary :: Gen Array) + DictionaryT _ _ -> fmap toVariant (arbitrary :: Gen Dictionary) + StructureT _ -> fmap toVariant (arbitrary :: Gen Structure) + VariantT -> fmap toVariant (arbitrary :: Gen Variant) instance Arbitrary Endianness where coarbitrary = undefined diff --git a/dbus-core.cabal b/dbus-core.cabal --- a/dbus-core.cabal +++ b/dbus-core.cabal @@ -1,5 +1,5 @@ name: dbus-core -version: 0.2 +version: 0.3 synopsis: Low-level DBus protocol implementation license: GPL license-file: License.txt @@ -7,7 +7,7 @@ maintainer: jmillikin@gmail.com build-type: Simple cabal-version: >=1.6 -category: Data +category: Network, Desktop stability: experimental bug-reports: mailto:jmillikin@gmail.com @@ -20,15 +20,17 @@ source-repository head type: darcs - location: http://patch-tag.com/r/dbus-core/pullrepo + location: http://patch-tag.com/r/jmillikin/dbus-core/pullrepo library + ghc-options: -Wall + build-depends: base >=4 && < 5, - parsec >= 3, + parsec >= 3.0.0, binary, bytestring, - data-binary-ieee754, + data-binary-ieee754 >= 0.3, utf8-string, mtl, containers, diff --git a/dbus-core.tex b/dbus-core.tex --- a/dbus-core.tex +++ b/dbus-core.tex @@ -26,6 +26,17 @@ }} {} +% http://hackage.haskell.org/trac/ghc/ticket/3549 +\lstnewenvironment{otherCode}{ + \lstset + {language=Haskell + ,basicstyle=\footnotesize\tt + ,showstringspaces=false + ,frame=single + ,upquote=true + }} + {} + \long\def\ignore#1{} \makeindex @@ -35,9 +46,9 @@ \addcontentsline{toc}{section}{Contents} \tableofcontents +\input{DBus/Bus.lhs} \input{DBus/Bus/Address.lhs} \input{DBus/Bus/Connection.lhs} -\input{DBus/Bus.lhs} \input{DBus/Types.lhs} \input{DBus/Message.lhs} \input{DBus/Protocol/Marshal.lhs}