dbus-core 0.2 → 0.3
raw patch · 14 files changed
+351/−253 lines, 14 filesdep ~data-binary-ieee754dep ~parsec
Dependency ranges changed: data-binary-ieee754, parsec
Files
- DBus/Bus.lhs +64/−35
- DBus/Bus/Connection.lhs +129/−92
- DBus/Message.lhs +2/−2
- DBus/Protocol/Marshal.lhs +25/−25
- DBus/Protocol/Padding.lhs +16/−16
- DBus/Protocol/Unmarshal.lhs +17/−17
- DBus/Types/Atom.lhs +6/−0
- DBus/Types/Containers.lhs +6/−0
- DBus/Types/Signature.lhs +20/−20
- Examples/dbus-monitor.hs +9/−16
- Tests/Containers.hs +20/−6
- Tests/Instances.hs +18/−18
- dbus-core.cabal +7/−5
- dbus-core.tex +12/−1
DBus/Bus.lhs view
@@ -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}+
DBus/Bus/Connection.lhs view
@@ -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' ["<transport \"", A.strAddress a, "\">"] where+instance Show Connection where+ showsPrec d (Connection a _ _) = showParen (d > 10) $+ showString' ["<connection \"", A.strAddress a, "\">"] 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' ["<connection \"", A.strAddress a, "\">"] 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}
DBus/Message.lhs view
@@ -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
DBus/Protocol/Marshal.lhs view
@@ -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}
DBus/Protocol/Padding.lhs view
@@ -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}
DBus/Protocol/Unmarshal.lhs view
@@ -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
DBus/Types/Atom.lhs view
@@ -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}
DBus/Types/Containers.lhs view
@@ -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}
DBus/Types/Signature.lhs view
@@ -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}
Examples/dbus-monitor.hs view
@@ -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 ("
Tests/Containers.hs view
@@ -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
Tests/Instances.hs view
@@ -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
dbus-core.cabal view
@@ -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,
dbus-core.tex view
@@ -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}