diff --git a/DBus/Protocol/Authentication.lhs b/DBus/Protocol/Authentication.lhs new file mode 100644 --- /dev/null +++ b/DBus/Protocol/Authentication.lhs @@ -0,0 +1,71 @@ +% Copyright (C) 2009 John Millikin +% +% This program is free software: you can redistribute it and/or modify +% it under the terms of the GNU General Public License as published by +% the Free Software Foundation, either version 3 of the License, or +% any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program. If not, see . + +\ignore{ +\begin{code} +{-# OPTIONS_HADDOCK hide #-} +module DBus.Protocol.Authentication (authenticate) where + +import Data.Char (ord) +import Data.Word (Word32) +import Data.List (isPrefixOf) +import System.Posix.User (getRealUserID) +import Text.Printf (printf) +\end{code} +} + +\section{Authentication} + +\begin{code} +authenticate :: (String -> IO ()) -> (Word32 -> IO String) + -> IO () +authenticate put get = do + put "\x00" +\end{code} + +{\tt EXTERNAL} authentication is performed using the process's real user +ID, converted to a string, and then hex-encoded. + +\begin{code} + uid <- getRealUserID + let authToken = concatMap (printf "%02X" . ord) (show uid) + put $ "AUTH EXTERNAL " ++ authToken ++ "\r\n" +\end{code} + +If authentication was successful, the server responds with {\tt OK +}. The GUID is intended to enable connection sharing, which +is currently unimplemented, so it's ignored. + +\begin{code} + response <- readUntil '\n' get + if "OK" `isPrefixOf` response + then put "BEGIN\r\n" + else do + putStrLn $ "response = " ++ show response + error "Server rejected authentication token." +\end{code} + +\begin{code} +readUntil :: Monad m => Char -> (Word32 -> m String) -> m String +readUntil = readUntil' "" + +readUntil' :: Monad m => String -> Char -> (Word32 -> m String) -> m String +readUntil' xs c f = do + [x] <- f 1 + let xs' = xs ++ [x] + if x == c + then return xs' + else readUntil' xs' c f +\end{code} diff --git a/DBus/Protocol/Marshal.lhs b/DBus/Protocol/Marshal.lhs new file mode 100644 --- /dev/null +++ b/DBus/Protocol/Marshal.lhs @@ -0,0 +1,243 @@ +% Copyright (C) 2009 John Millikin +% +% This program is free software: you can redistribute it and/or modify +% it under the terms of the GNU General Public License as published by +% the Free Software Foundation, either version 3 of the License, or +% any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program. If not, see . + +\ignore{ +\begin{code} +{-# OPTIONS_HADDOCK hide #-} +module DBus.Protocol.Marshal (marshal) where + +import Control.Arrow (first) +import Control.Monad (msum) +import qualified Control.Monad.State as S +import Data.Maybe (fromJust) +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int16, Int32, Int64) +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.UTF8 (fromString) +import qualified Data.Binary.Put as P +import qualified Data.Binary.IEEE754 as IEEE + +import DBus.Protocol.Padding (padding, padByType) +import qualified DBus.Types as T +\end{code} +} + +\clearpage +\section{Marshaling} +\subsection{\tt marshal} + +\begin{code} +marshal :: T.Endianness -> [T.Variant] -> L.ByteString +marshal e vs = runMarshal (mapM_ marshal' 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 + ] +\end{code} + +\subsection{Atoms} + +\begin{code} +bool :: Bool -> Marshal +bool x = word32 (if x then 1 else 0) +\end{code} + +\begin{code} +word8 :: Word8 -> Marshal +word8 x = append (L.pack [x]) +\end{code} + +\begin{code} +word16 :: Word16 -> Marshal +word16 = appendPut P.putWord16be +\end{code} + +\begin{code} +word32 :: Word32 -> Marshal +word32 = appendPut P.putWord32be +\end{code} + +\begin{code} +word64 :: Word64 -> Marshal +word64 = appendPut P.putWord64be +\end{code} + +\begin{code} +int16 :: Int16 -> Marshal +int16 = appendPut P.putWord16be . fromIntegral +\end{code} + +\begin{code} +int32 :: Int32 -> Marshal +int32 = appendPut P.putWord32be . fromIntegral +\end{code} + +\begin{code} +int64 :: Int64 -> Marshal +int64 = appendPut P.putWord64be . fromIntegral +\end{code} + +\begin{code} +double :: Double -> Marshal +double = appendPut IEEE.putFloat64be +\end{code} + +\begin{code} +string :: String -> Marshal +string x = do + let bytes = fromString x + word32 . fromIntegral . L.length $ bytes + append bytes + append (L.pack [0]) +\end{code} + +\begin{code} +objectPath :: T.ObjectPath -> Marshal +objectPath = string . T.strObjectPath +\end{code} + +\begin{code} +signature :: T.Signature -> Marshal +signature x = do + let bytes = fromString . T.strSignature $ x + word8 . fromIntegral . L.length $ bytes + append bytes + append (L.pack [0]) +\end{code} + +\subsection{Containers} + +\subsubsection{Arrays} + +Marshaling arrays is complicated, because the array body must be marshaled +\emph{first} to calculate the array length. This requires building a +temporary marshaler, to get the padding right. + +\begin{code} +array :: T.Array -> Marshal +array x = do + (arrayPadding, arrayBytes) <- getArrayBytes x + word32 . fromIntegral . L.length $ arrayBytes + append arrayPadding + append arrayBytes +\end{code} + +\begin{code} +getArrayBytes :: T.Array -> MarshalM (L.ByteString, L.ByteString) +getArrayBytes x = do + let vs = T.arrayItems x + let [T.ArrayT itemType] = T.signatureTypes . T.arraySignature $ x + s <- S.get + (MarshalState _ afterLength) <- word32 0 >> S.get + (MarshalState _ afterPadding) <- pad (padByType itemType) >> S.get + (MarshalState _ afterItems) <- mapM_ marshal' vs >> S.get + + let paddingBytes = L.drop (L.length afterLength) afterPadding + let itemBytes = L.drop (L.length afterPadding) afterItems + + S.put s + return (paddingBytes, itemBytes) +\end{code} + +\subsubsection{Dictionaries} + +\begin{code} +dictionary :: T.Dictionary -> Marshal +dictionary x = array x' where + pairs = map (first T.atomToVariant) (T.dictionaryItems x) + structs = [T.Structure [k,v] | (k,v) <- pairs] + x' = fromJust . T.toArray $ structs +\end{code} + +\subsubsection{Structures} + +\begin{code} +structure :: T.Structure -> Marshal +structure (T.Structure xs) = pad 8 >> mapM_ marshal' xs +\end{code} + +\subsubsection{Variants} + +\begin{code} +variant :: T.Variant -> Marshal +variant x = signature (T.variantSignature x) >> marshal' x +\end{code} + +\subsection{The {\tt Marshal} monad} + +{\tt Marshal} implements stateful marshaling, which is required for padding +to be calculated properly. + +\begin{code} +data MarshalState = MarshalState T.Endianness L.ByteString +type MarshalM = S.State MarshalState +type Marshal = MarshalM () +\end{code} + +\begin{code} +runMarshal :: Marshal -> T.Endianness -> L.ByteString +runMarshal m e = bytes where + initialState = MarshalState e L.empty + (MarshalState _ bytes) = S.execState m initialState +\end{code} + +\begin{code} +append :: L.ByteString -> Marshal +append bs = do + (MarshalState e bs') <- S.get + S.put $ MarshalState e (L.append bs' bs) +\end{code} + +Add padding to the end of the marshaled bytes, until the length is a +multiple of {\tt count}. + +\begin{code} +pad :: Word8 -> Marshal +pad count = do + (MarshalState _ bytes) <- S.get + let padding' = padding (fromIntegral . L.length $ bytes) count + append $ L.replicate (fromIntegral padding') 0 +\end{code} + +\begin{code} +appendPut :: (a -> P.Put) -> a -> Marshal +appendPut put x = do + let bytes = P.runPut $ put x + (MarshalState e _) <- S.get + pad . fromIntegral . L.length $ bytes + append $ case e of + T.BigEndian -> bytes + T.LittleEndian -> L.reverse bytes +\end{code} diff --git a/DBus/Protocol/Padding.lhs b/DBus/Protocol/Padding.lhs new file mode 100644 --- /dev/null +++ b/DBus/Protocol/Padding.lhs @@ -0,0 +1,60 @@ +% Copyright (C) 2009 John Millikin +% +% This program is free software: you can redistribute it and/or modify +% it under the terms of the GNU General Public License as published by +% the Free Software Foundation, either version 3 of the License, or +% any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program. If not, see . + +\ignore{ +\begin{code} +{-# OPTIONS_HADDOCK hide #-} +module DBus.Protocol.Padding + ( padding + , padByType + ) where + +import Data.Word (Word8, Word64) +import qualified DBus.Types as T +\end{code} +} + +\section{Value padding} + +\begin{code} +padding :: Word64 -> Word8 -> Word64 +padding current count = required where + count' = fromIntegral count + missing = mod current count' + required = if missing > 0 + then count' - missing + else 0 +\end{code} + +\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 +\end{code} + diff --git a/DBus/Protocol/Unmarshal.lhs b/DBus/Protocol/Unmarshal.lhs new file mode 100644 --- /dev/null +++ b/DBus/Protocol/Unmarshal.lhs @@ -0,0 +1,313 @@ +% Copyright (C) 2009 John Millikin +% +% This program is free software: you can redistribute it and/or modify +% it under the terms of the GNU General Public License as published by +% the Free Software Foundation, either version 3 of the License, or +% any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program. If not, see . + +\ignore{ +\begin{code} +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE ExistentialQuantification #-} +module DBus.Protocol.Unmarshal (unmarshal) where + +import Data.Maybe (fromJust) +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int16, Int32, Int64) +import qualified Control.Monad.State as S +import qualified Control.Monad.Error as E +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.UTF8 (toString) +import qualified Data.Binary.Get as G +import qualified Data.Binary.IEEE754 as IEEE + +import DBus.Protocol.Padding (padding, padByType) +import qualified DBus.Types as T +\end{code} +} + +\clearpage +\section{Unmarshaling} +\subsection{\tt unmarshal} + +\begin{code} +unmarshal :: (E.Error e, E.MonadError e m) + => T.Endianness -> T.Signature -> L.ByteString + -> m [T.Variant] +unmarshal e sig bytes = either' where + either' = case runUnmarshal x e bytes of + Left y -> E.throwError . E.strMsg . show $ y + Right y -> return y + x = mapM unmarshal' $ T.signatureTypes sig +\end{code} + +\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 +\end{code} + +\subsection{Atoms} + +\begin{code} +bool :: Unmarshal Bool +bool = word32 >>= \x -> case x of + 0 -> return False + 1 -> return True + _ -> E.throwError $ Invalid "boolean" x +\end{code} + +\begin{code} +word8 :: Unmarshal Word8 +word8 = do + bs <- consume 1 + let [b] = L.unpack bs + return b +\end{code} + +\begin{code} +word16 :: Unmarshal Word16 +word16 = eitherEndian 2 G.getWord16be G.getWord16le +\end{code} + +\begin{code} +word32 :: Unmarshal Word32 +word32 = eitherEndian 4 G.getWord32be G.getWord32le +\end{code} + +\begin{code} +word64 :: Unmarshal Word64 +word64 = eitherEndian 8 G.getWord64be G.getWord64le +\end{code} + +\begin{code} +int16 :: Unmarshal Int16 +int16 = fmap fromIntegral $ eitherEndian 2 G.getWord16be G.getWord16le +\end{code} + +\begin{code} +int32 :: Unmarshal Int32 +int32 = fmap fromIntegral $ eitherEndian 4 G.getWord32be G.getWord32le +\end{code} + +\begin{code} +int64 :: Unmarshal Int64 +int64 = fmap fromIntegral $ eitherEndian 8 G.getWord64be G.getWord64le +\end{code} + +\begin{code} +double :: Unmarshal Double +double = eitherEndian 8 IEEE.getFloat64be IEEE.getFloat64le +\end{code} + +\begin{code} +string :: Unmarshal String +string = do + byteCount <- word32 + bytes <- consume . fromIntegral $ byteCount + skipNulls 1 + return . toString $ bytes +\end{code} + +\begin{code} +objectPath :: Unmarshal T.ObjectPath +objectPath = do + s <- string + fromMaybe T.mkObjectPath s "object path" +\end{code} + +\begin{code} +signature :: Unmarshal T.Signature +signature = do + byteCount <- word8 + bytes <- consume . fromIntegral $ byteCount + skipNulls 1 + fromMaybe T.mkSignature (toString bytes) "signature" +\end{code} + +\subsection{Containers} + +\subsubsection{Arrays} + +\begin{code} +array :: T.Type -> Unmarshal T.Array +array t = do + let getOffset = do + (UnmarshalState _ _ o) <- get + return o + let sig = fromJust . T.mkSignature . T.typeString $ t + + byteCount <- word32 + skipPadding (padByType t) + start <- getOffset + let end = start + fromIntegral byteCount + vs <- untilM (fmap (>= end) getOffset) (unmarshal' t) + end' <- getOffset + assert (end == end') "Array contained fewer bytes than expected." + fromMaybe (T.arrayFromItems sig) vs "array" +\end{code} + +\subsubsection{Dictionaries} + +\begin{code} +dictionary :: T.Type -> T.Type -> Unmarshal T.Dictionary +dictionary kt vt = do + arr <- array $ T.StructT [kt, vt] + structs <- fromMaybe T.fromArray arr "dictionary" + pairs <- mapM mkPair structs + let kSig = fromJust . T.mkSignature . T.typeString $ kt + let vSig = fromJust . T.mkSignature . T.typeString $ vt + fromMaybe (T.dictionaryFromItems kSig vSig) pairs "dictionary" + +mkPair :: T.Structure -> Unmarshal (T.Atom, T.Variant) +mkPair (T.Structure [k, v]) = do + k' <- fromMaybe T.atomFromVariant k "dictionary key" + return (k', v) +mkPair s = E.throwError $ Invalid "dictionary item" s +\end{code} + +\subsubsection{Structures} + +\begin{code} +structure :: [T.Type] -> Unmarshal T.Structure +structure ts = do + skipPadding 8 + fmap T.Structure $ mapM unmarshal' ts +\end{code} + +\subsubsection{Variants} + +\begin{code} +variant :: Unmarshal T.Variant +variant = do + sig <- signature + t <- case T.signatureTypes sig of + [t'] -> return t' + _ -> E.throwError $ Invalid "variant signature" + $ T.strSignature sig + unmarshal' t +\end{code} + +\subsection{The {\tt Unmarshal} monad} + +\begin{code} +data UnmarshalState = UnmarshalState T.Endianness L.ByteString Word64 +type Unmarshal = E.ErrorT UnmarshalError (S.State UnmarshalState) +\end{code} + +\begin{code} +runUnmarshal :: Unmarshal a -> T.Endianness -> L.ByteString + -> Either UnmarshalError a +runUnmarshal x e bytes = S.evalState (E.runErrorT x) state where + state = UnmarshalState e bytes 0 +\end{code} + +\begin{code} +get :: Unmarshal UnmarshalState +get = E.lift S.get + +put :: UnmarshalState -> Unmarshal () +put = E.lift . S.put +\end{code} + +\begin{code} +consume :: Word64 -> Unmarshal L.ByteString +consume count = do + (UnmarshalState e bytes offset) <- get + let bytes' = L.drop (fromIntegral offset) bytes + let x = L.take (fromIntegral count) bytes' + if L.length x == fromIntegral count + then do + let offset' = offset + count + put $ UnmarshalState e bytes offset' + return x + else E.throwError $ UnexpectedEOF offset +\end{code} + +\begin{code} +skipPadding :: Word8 -> Unmarshal () +skipPadding count = do + (UnmarshalState _ _ offset) <- get + bytes <- consume $ padding offset count + assert (L.all (== 0) bytes) "Non-zero bytes in padding." +\end{code} + +\begin{code} +skipNulls :: Word8 -> Unmarshal () +skipNulls count = do + bytes <- consume $ fromIntegral count + assert (L.all (== 0) bytes) "Non-zero bytes in padding." +\end{code} + +\begin{code} +eitherEndian :: Word8 -> G.Get a -> G.Get a -> Unmarshal a +eitherEndian count be le = do + skipPadding count + (UnmarshalState e _ _) <- get + bs <- consume . fromIntegral $ count + let get' = case e of + T.BigEndian -> be + T.LittleEndian -> le + return $ G.runGet get' bs +\end{code} + +\begin{code} +untilM :: Monad m => m Bool -> m a -> m [a] +untilM test comp = do + done <- test + if done + then return [] + else do + x <- comp + xs <- untilM test comp + return $ x:xs +\end{code} + +\subsection{Errors} + +\begin{code} +data UnmarshalError = UnexpectedEOF Word64 + | forall a. (Show a) => Invalid String a + | GenericError String + +instance E.Error UnmarshalError where + strMsg = GenericError + +instance Show UnmarshalError where + show (UnexpectedEOF pos) = "Unexpected EOF at position " ++ show pos + show (Invalid label x) = "Invalid " ++ label ++ ": " ++ show x + show (GenericError msg) = "Error unmarshaling: " ++ msg +\end{code} + +\begin{code} +assert :: Bool -> String -> Unmarshal () +assert True _ = return () +assert False msg = E.throwError $ E.strMsg msg +\end{code} + +\begin{code} +fromMaybe :: Show a => (a -> Maybe b) -> a -> String -> Unmarshal b +fromMaybe f x s = maybe (E.throwError $ Invalid s x) return $ f x +\end{code} diff --git a/DBus/Types/Containers.lhs-boot b/DBus/Types/Containers.lhs-boot new file mode 100644 --- /dev/null +++ b/DBus/Types/Containers.lhs-boot @@ -0,0 +1,51 @@ +% Copyright (C) 2009 John Millikin +% +% This program is free software: you can redistribute it and/or modify +% it under the terms of the GNU General Public License as published by +% the Free Software Foundation, either version 3 of the License, or +% any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program. If not, see . + +This is just a stub file so {\tt Atom} can implement {\tt Variable}. + +\begin{code} +{-# LANGUAGE TypeSynonymInstances #-} +module DBus.Types.Containers where + +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int16, Int32, Int64) +import DBus.Types.Signature (Signature) +import DBus.Types.ObjectPath (ObjectPath) + +class Variable a where + defaultSignature :: a -> Signature + toVariant :: a -> Variant + fromVariant :: Variant -> Maybe a + +data Variant + +instance Show Variant +instance Eq Variant + +instance Variable Bool +instance Variable Word8 +instance Variable Word16 +instance Variable Word32 +instance Variable Word64 +instance Variable Int16 +instance Variable Int32 +instance Variable Int64 +instance Variable Double +instance Variable String +instance Variable ObjectPath +instance Variable Signature + +variantSignature :: Variant -> Signature +\end{code} diff --git a/DBus/Types/Util.lhs b/DBus/Types/Util.lhs new file mode 100644 --- /dev/null +++ b/DBus/Types/Util.lhs @@ -0,0 +1,40 @@ +% Copyright (C) 2009 John Millikin +% +% This program is free software: you can redistribute it and/or modify +% it under the terms of the GNU General Public License as published by +% the Free Software Foundation, either version 3 of the License, or +% any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program. If not, see . + +\clearpage +\section{Misc. utility functions} + +\ignore{ +\begin{code} +{-# OPTIONS_HADDOCK hide #-} +module DBus.Types.Util + ( checkLength + , parseMaybe + ) where + +import Text.Parsec (Parsec, parse) +\end{code} +} + +\begin{code} +checkLength :: Int -> String -> Maybe String +checkLength length' s | length s <= length' = Just s +checkLength _ _ = Nothing +\end{code} + +\begin{code} +parseMaybe :: Parsec String () a -> String -> Maybe a +parseMaybe p = either (const Nothing) Just . parse p "" +\end{code} diff --git a/Examples/dbus-monitor.hs b/Examples/dbus-monitor.hs new file mode 100644 --- /dev/null +++ b/Examples/dbus-monitor.hs @@ -0,0 +1,273 @@ +{- + Copyright (C) 2009 John Millikin + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} + +import DBus.Bus +import DBus.Bus.Address +import DBus.Bus.Connection +import DBus.Message +import DBus.Types + +import Control.Monad +import qualified Data.Set as Set +import Data.List +import Data.Maybe +import Data.Int +import Data.Word +import System +import System.IO +import System.Console.GetOpt + +data Bus = Session | System + deriving (Show) + +data Option = BusOption Bus | AddressOption String + deriving (Show) + +optionInfo :: [OptDescr Option] +optionInfo = [ + Option [] ["session"] (NoArg (BusOption Session)) + "Monitor the session message bus. (default)" + , Option [] ["system"] (NoArg (BusOption System)) + "Monitor the system message bus." + , Option [] ["address"] (ReqArg AddressOption "ADDRESS") + "Connect to a particular bus address." + ] + +usage :: String -> String +usage name = "Usage: " ++ name ++ " [OPTION...]" + +findBus :: [Option] -> IO (Connection, BusName) +findBus [] = getSessionBus +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) + +addMatchMsg :: String -> MethodCall +addMatchMsg match = MethodCall + (fromJust . mkObjectPath $ "/org/freedesktop/DBus") + (fromJust . mkMemberName $ "AddMatch") + (mkInterfaceName "org.freedesktop.DBus") + (mkBusName "org.freedesktop.DBus") + Set.empty + [toVariant match] + +addMatch :: Connection -> String -> IO () +addMatch c s = send c return (addMatchMsg s) >> return () + +defaultFilters :: [String] +defaultFilters = + [ "type='signal'" + , "type='method_call'" + , "type='method_return'" + , "type='error'" + ] + +onMessage :: Either String ReceivedMessage -> IO () +onMessage (Left err) = do + hPutStrLn stderr err + exitFailure + +onMessage (Right msg) = putStrLn (formatMessage msg ++ "\n") + +main :: IO () +main = do + args <- getArgs + let (options, userFilters, errors) = getOpt Permute optionInfo args + unless (null errors) $ do + name <- getProgName + hPutStrLn stderr $ concat errors + hPutStrLn stderr $ usageInfo (usage name) optionInfo + exitFailure + + (bus, _) <- findBus options + + let filters = if null userFilters + then defaultFilters + else userFilters + + mapM_ (addMatch bus) filters + + forever (recv bus >>= onMessage) + +-- Message formatting is verbose and mostly uninteresting, except as an +-- excersise in string manipulation. + +formatMessage :: ReceivedMessage -> String + +-- Method call +formatMessage (ReceivedMethodCall serial sender msg) = concat + [ "method call" + , " sender=" + , fromMaybe "(null)" . fmap strBusName $ sender + , " -> dest=" + , fromMaybe "(null)" . fmap strBusName . methodCallDestination $ msg + , " serial=" + , show serial + , " path=" + , strObjectPath . methodCallPath $ msg + , "; interface=" + , fromMaybe "(null)" . fmap strInterfaceName . methodCallInterface $ msg + , "; member=" + , strMemberName . methodCallMember $ msg + , formatBody msg + ] + +-- Method return +formatMessage (ReceivedMethodReturn _ sender msg) = concat + [ "method return" + , " sender=" + , fromMaybe "(null)" . fmap strBusName $ sender + , " -> dest=" + , fromMaybe "(null)" . fmap strBusName . methodReturnDestination $ msg + , " reply_serial=" + , show . methodReturnSerial $ msg + , formatBody msg + ] + +-- Error +formatMessage (ReceivedError _ sender msg) = concat + [ "error" + , " sender=" + , fromMaybe "(null)" . fmap strBusName $ sender + , " -> dest=" + , fromMaybe "(null)" . fmap strBusName . errorDestination $ msg + , " error_name=" + , strErrorName . errorName $ msg + , " reply_serial=" + , show . errorSerial $ msg + , formatBody msg + ] + +-- Signal +formatMessage (ReceivedSignal serial sender msg) = concat + [ "signal" + , " sender=" + , fromMaybe "(null)" . fmap strBusName $ sender + , " serial=" + , show serial + , " path=" + , strObjectPath . signalPath $ msg + , "; interface=" + , strInterfaceName . signalInterface $ msg + , "; member=" + , strMemberName . signalMember $ msg + , formatBody msg + ] + +formatMessage (ReceivedUnknown serial sender) = concat + [ "unknown" + , " sender=" + , fromMaybe "(null)" . fmap strBusName $ sender + , " serial=" + , show serial + ] + +formatBody :: Message a => a -> String +formatBody msg = formatted where + tree = Children $ map formatVariant body + body = messageBody msg + formatted = intercalate "\n" ([] : collapseTree 1 tree) + +-- A string tree allows easy indentation of nested structures +data StringTree = Line String | MultiLine [StringTree] | Children [StringTree] + deriving (Show) + +collapseTree :: Int -> StringTree -> [String] +collapseTree d (Line x) = [concat (replicate d " ") ++ x] +collapseTree d (MultiLine xs) = concatMap (collapseTree d) xs +collapseTree d (Children xs) = concatMap (collapseTree (d + 1)) xs + +-- Formatting for various kinds of variants, keyed to their signature type. +formatVariant :: Variant -> StringTree +formatVariant v = formatVariant' type' v where + [type'] = signatureTypes . variantSignature $ v + +formatVariant' :: Type -> Variant -> StringTree + +formatVariant' BooleanT x = Line $ "boolean " ++ strX where + x' = fromJust . fromVariant $ x :: Bool + strX = if x' then "true" else "false" + +formatVariant' ByteT x = Line $ "byte " ++ show x' where + x' = fromJust . fromVariant $ x :: Word8 + +formatVariant' Int16T x = Line $ "int16 " ++ show x' where + x' = fromJust . fromVariant $ x :: Int16 + +formatVariant' Int32T x = Line $ "int32 " ++ show x' where + x' = fromJust . fromVariant $ x :: Int32 + +formatVariant' Int64T x = Line $ "int64 " ++ show x' where + x' = fromJust . fromVariant $ x :: Int64 + +formatVariant' UInt16T x = Line $ "uint16 " ++ show x' where + x' = fromJust . fromVariant $ x :: Word16 + +formatVariant' UInt32T x = Line $ "uint32 " ++ show x' where + x' = fromJust . fromVariant $ x :: Word32 + +formatVariant' UInt64T x = Line $ "uint64 " ++ show x' where + x' = fromJust . fromVariant $ x :: Word64 + +formatVariant' DoubleT x = Line $ "double " ++ show x' where + x' = fromJust . fromVariant $ x :: Double + +formatVariant' StringT x = Line $ "string " ++ show x' where + x' = fromJust . fromVariant $ x :: String + +formatVariant' ObjectPathT x = Line $ "object path " ++ show x' where + x' = strObjectPath . fromJust . fromVariant $ x + +formatVariant' SignatureT x = Line $ "signature " ++ show x' where + x' = strSignature . fromJust . fromVariant $ x + +formatVariant' (ArrayT _) x = MultiLine lines' where + items = arrayItems . fromJust . fromVariant $ x + lines' = + [ Line "array [" + , Children . map formatVariant $ items + , Line "]" + ] + +formatVariant' (DictT _ _) x = MultiLine lines' where + items = dictionaryItems . fromJust . fromVariant $ x + lines' = [ Line "dictionary {" + , Children . map formatItem $ items + , Line "}" + ] + formatItem (k, v) = MultiLine $ [Line $ k' ++ " -> " ++ vHead] ++ vTail where + Line k' = formatVariant (atomToVariant k) + v' = collapseTree 0 (formatVariant v) + vHead = head v' + vTail = map Line $ tail v' + +formatVariant' (StructT _) x = MultiLine lines' where + Structure items = fromJust . fromVariant $ x + lines' = + [ Line "struct (" + , Children . map formatVariant $ items + , Line ")" + ] + +formatVariant' VariantT x = formatVariant . fromJust . fromVariant $ x diff --git a/Tests.hs b/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests.hs @@ -0,0 +1,40 @@ +{- + Copyright (C) 2009 John Millikin + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} + +import Test.QuickCheck.Batch +import Tests.Address (addressProperties) +import Tests.Signature (signatureProperties) +import Tests.Containers (containerProperties) +import Tests.Marshal (marshalProperties) +import Tests.Messages (messageProperties) +import Tests.MiscTypes (miscTypeProperties) + +options = TestOptions + { no_of_tests = 100 + , length_of_tests = 1 + , debug_tests = False + } + +main = do + runTests "simple" options . map run . concat $ + [ addressProperties + , containerProperties + , marshalProperties + , messageProperties + , miscTypeProperties + , signatureProperties + ] diff --git a/Tests/Address.hs b/Tests/Address.hs new file mode 100644 --- /dev/null +++ b/Tests/Address.hs @@ -0,0 +1,107 @@ +{- + Copyright (C) 2009 John Millikin + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} + +module Tests.Address (addressProperties) where + +import Control.Monad (replicateM) +import Data.List (intercalate) +import Data.Map (toList) +import Data.Maybe (isJust, isNothing) +import Test.QuickCheck +import Tests.Instances (sized') +import DBus.Bus.Address + +addressProperties = concat + [ prop_Valid + , prop_Invalid + , [ property prop_Identity + , property prop_MultipleAddresses + , property prop_IgnoreTrailingSemicolon + , property prop_IgnoreTrailingComma + ] + ] + +-- Addresses can be converted to strings and back safely +prop_Identity x = parseAddresses (strAddress x) == Just [x] + +-- Multiple addresses may be parsed +prop_MultipleAddresses x y = parseAddresses joined == Just [x, y] where + joined = concat [strAddress x, ";", strAddress y] + +-- Trailing semicolons are ignored +prop_IgnoreTrailingSemicolon x = parseAddresses appended == Just [x] where + appended = strAddress x ++ ";" + +-- Trailing commas are ignored +prop_IgnoreTrailingComma x = hasParams ==> ignoresComma where + hasParams = not . null $ params + ignoresComma = parseAddresses (strAddress x ++ ",") == Just [x] + params = toList . addressParameters $ x + +prop_Valid = let valid = property . isJust . parseAddresses in + [ valid ":" + , valid "a:" + , valid "a:b=c" + , valid "a:;" + , valid "a:;b:" + ] + +prop_Invalid = let invalid = property . isNothing . parseAddresses in + [ invalid "" + , invalid "a" + , invalid "a:b" + , invalid "a:b=" + ] + +instance Arbitrary Address where + coarbitrary = undefined + arbitrary = genAddress where + optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." + methodChars = filter (flip notElem ":;") ['!'..'~'] + keyChars = filter (flip notElem "=;,") ['!'..'~'] + + genMethod = sized' 0 $ elements methodChars + genParam = do + key <- genKey + value <- genValue + return . concat $ [key, "=", value] + + genKey = sized' 1 $ elements keyChars + genValue = oneof [encodedValue, plainValue] + genHex = elements $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F'] + encodedValue = do + x1 <- genHex + x2 <- genHex + return ['%', x1, x2] + plainValue = sized' 1 $ elements optional + + genParams = do + params <- sized' 0 genParam + let params' = intercalate "," params + extraComma <- if null params + then return "" + else elements ["", ","] + return $ concat [params', extraComma] + + genAddress = do + m <- genMethod + params <- genParams + extraSemicolon <- elements ["", ";"] + let addrStr = concat [m, ":", params, extraSemicolon] + let Just [addr] = parseAddresses addrStr + return addr + diff --git a/Tests/Containers.hs b/Tests/Containers.hs new file mode 100644 --- /dev/null +++ b/Tests/Containers.hs @@ -0,0 +1,209 @@ +{- + Copyright (C) 2009 John Millikin + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} + +{-# LANGUAGE RankNTypes #-} +module Tests.Containers (containerProperties) where + +import Control.Arrow ((&&&)) +import Data.Maybe (isJust, fromJust) +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int16, Int32, Int64) +import Test.QuickCheck + +import Tests.Instances () + +import DBus.Types + +containerProperties = concat + [ forAllAtomic prop_AtomEquality + , forAllVariable prop_VariantEquality + + , forAllAtomic prop_AtomWrapping0 + , forAllAtomic prop_AtomWrapping1 + , forAllVariable prop_VariantWrapping + + , forAllAtomic prop_AtomSignature + , forAllAtomic prop_AtomDefaultSignature + , forAllVariable prop_DefaultSignature + , variantSignatureProperties + , [ property prop_VariantSignatureLength ] + , [ property prop_ArrayHomogeneous + , property prop_DictHomogeneous0 + , property prop_DictHomogeneous1 + ] + , props_EmptyArraySignature + , props_EmptyDictionarySignature + ] + +-- Basic equality + +prop_AtomEquality gen = forAll gen $ \x y -> + (x == y) == (toAtom x == toAtom y) + +prop_VariantEquality gen = forAll gen $ \x y -> + (x == y) == (toVariant x == toVariant y) + +-- Conversion to/from/between Atom and Variant + +prop_AtomWrapping0 gen = forAll gen $ \x -> + fromAtom (toAtom x) == Just x + +prop_AtomWrapping1 gen = forAll gen $ \x -> + atomToVariant (toAtom x) == toVariant x + +prop_VariantWrapping gen = forAll gen $ \x -> + fromVariant (toVariant x) == Just x + +prop_AtomSignature gen = forAll gen $ \x -> + atomSignature (toAtom x) == variantSignature (toVariant x) + +prop_AtomDefaultSignature gen = forAll gen $ \x -> + variantSignature (toVariant x) == defaultSignature x + +prop_DefaultSignature gen = forAll gen $ \x -> let + sig = strSignature . defaultSignature $ y + y = head [y, x] + in not . null $ sig + + +-- Test that signatures are set properly +sameSig :: Variable a => a -> Type -> Bool +sameSig x t = [t] == t' where + t' = signatureTypes . variantSignature . toVariant $ x + +sameSig' :: Variable a => (a -> Signature) -> a -> Bool +sameSig' f x = f x == (variantSignature . toVariant) x + +variantSignatureProperties = + [ property $ \x -> sameSig (x :: Bool) BooleanT + , property $ \x -> sameSig (x :: Word8) ByteT + , property $ \x -> sameSig (x :: Word16) UInt16T + , property $ \x -> sameSig (x :: Word32) UInt32T + , property $ \x -> sameSig (x :: Word64) UInt64T + , property $ \x -> sameSig (x :: Int16) Int16T + , property $ \x -> sameSig (x :: Int32) Int32T + , property $ \x -> sameSig (x :: Int64) Int64T + , property $ \x -> sameSig (x :: Double) DoubleT + , property $ \x -> sameSig (x :: String) StringT + , property $ \x -> sameSig (x :: ObjectPath) ObjectPathT + , property $ \x -> sameSig (x :: Signature) SignatureT + , property $ sameSig' arraySignature + , property $ sameSig' dictionarySignature + , property $ sameSig' structureSignature + , property $ \x -> sameSig (x :: Variant) VariantT + ] + +-- All variant signatures have one entry +prop_VariantSignatureLength x = length sig == 1 where + sig = signatureTypes . variantSignature $ 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 + array = arrayFromItems sig vs + homogeneousTypes = if length vs > 0 + then all (== firstType) types + else True + types = map (signatureTypes . variantSignature) vs + firstType = head types + sig = if length vs > 0 + then variantSignature (head vs) + else fromJust . mkSignature $ "y" + +-- A dictionary must have homogeneous key and value types +prop_DictHomogeneous0 = homogeneousDict + +prop_DictHomogeneous1 ks = forAll (vector (length ks)) $ \vs -> let + dict = dictionaryFromItems kSig vSig (zip ks vs) + (kSig, vSig) = if null ks + then (id &&& id) . fromJust . mkSignature $ "y" + else (atomSignature (head ks), variantSignature (head vs)) + in isJust dict ==> homogeneousDict (fromJust dict) + +homogeneousDict :: Dictionary -> Property +homogeneousDict x = length items > 0 ==> homogeneous where + items = dictionaryItems x + keys = [k | (k,_) <- items] + values = [v | (_,v) <- items] + + kTypes = map (signatureTypes . atomSignature) keys + kFirst = head kTypes + + vTypes = map (signatureTypes . variantSignature) values + vFirst = head vTypes + + homogeneous = all (== kFirst) kTypes && all (== vFirst) vTypes + +props_EmptyArraySignature = + [ check ([] :: [Word8]) "ay" + , check ([] :: [Bool]) "ab" + , check ([] :: [Array]) "aay" + , check ([] :: [Dictionary]) "aa{yy}" + , check ([] :: [Structure]) "a()" + , check ([] :: [Variant]) "av" + ] + where check xs sig = forAll (return sig) $ checkEmptyArray xs + +checkEmptyArray xs sig = arraySignature a == sig' where + sig' = fromJust . mkSignature $ sig + a = fromJust . toArray $ xs + +props_EmptyDictionarySignature = + [ check ([] :: [(Word8, Word8)]) "a{yy}" + , check ([] :: [(Bool, Word8)]) "a{by}" + , check ([] :: [(Bool, Array)]) "a{bay}" + , check ([] :: [(Bool, Dictionary)]) "a{ba{yy}}" + , check ([] :: [(Bool, Structure)]) "a{b()}" + , check ([] :: [(Bool, Variant)]) "a{bv}" + ] + where check xs sig = forAll (return sig) $ checkEmptyDict xs + +checkEmptyDict xs sig = dictionarySignature a == sig' where + sig' = fromJust . mkSignature $ sig + a = fromJust . toDictionary $ xs + +-- TODO Conversion to/from array and dictionary + +-- TODO: container signatures + +-- Helper functions + +forAllAtomic :: (forall a. (Show a, Arbitrary a, Atomic a, Eq a) => + (Gen a -> Property)) -> [Property] +forAllAtomic t = + [ t (arbitrary :: Gen Bool) + , t (arbitrary :: Gen Word8) + , t (arbitrary :: Gen Word16) + , t (arbitrary :: Gen Word32) + , t (arbitrary :: Gen Word64) + , t (arbitrary :: Gen Int16) + , t (arbitrary :: Gen Int32) + , t (arbitrary :: Gen Int64) + , t (arbitrary :: Gen Double) + , t (arbitrary :: Gen String) + , t (arbitrary :: Gen ObjectPath) + , t (arbitrary :: Gen Signature) + ] + +forAllVariable :: (forall a. (Show a, Arbitrary a, Variable a, Eq a) => + (Gen a -> Property)) -> [Property] +forAllVariable t = forAllAtomic t ++ + [ t (arbitrary :: Gen Array) + , t (arbitrary :: Gen Dictionary) + , t (arbitrary :: Gen Structure) + , t (arbitrary :: Gen Variant) + ] diff --git a/Tests/Instances.hs b/Tests/Instances.hs new file mode 100644 --- /dev/null +++ b/Tests/Instances.hs @@ -0,0 +1,290 @@ +{- + Copyright (C) 2009 John Millikin + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} + +module Tests.Instances (sized') where + +import Control.Monad (replicateM) +import Data.List (intercalate) +import Data.Maybe (fromJust) +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int16, Int32, Int64) +import Test.QuickCheck +import DBus.Types + +instance Arbitrary Char where + coarbitrary = undefined + arbitrary = choose ('!', '~') -- TODO: unicode? + +instance Arbitrary Word8 where + coarbitrary = undefined + arbitrary = gen where + gen = fmap fromIntegral (choose (0, max') :: Gen Integer) + max' = iexp 2 8 - 1 + +instance Arbitrary Word16 where + coarbitrary = undefined + arbitrary = gen where + gen = fmap fromIntegral (choose (0, max') :: Gen Integer) + max' = iexp 2 16 - 1 + +instance Arbitrary Word32 where + coarbitrary = undefined + arbitrary = gen where + gen = fmap fromIntegral (choose (0, max') :: Gen Integer) + max' = iexp 2 32 - 1 + +instance Arbitrary Word64 where + coarbitrary = undefined + arbitrary = gen where + gen = fmap fromIntegral (choose (0, max') :: Gen Integer) + max' = iexp 2 64 - 1 + +instance Arbitrary Int16 where + coarbitrary = undefined + arbitrary = gen where + gen = fmap fromIntegral (choose (0, max') :: Gen Integer) + max' = iexp 2 16 - 1 + +instance Arbitrary Int32 where + coarbitrary = undefined + arbitrary = gen where + gen = fmap fromIntegral (choose (0, max') :: Gen Integer) + max' = iexp 2 32 - 1 + +instance Arbitrary Int64 where + coarbitrary = undefined + arbitrary = gen where + gen = fmap fromIntegral (choose (0, max') :: Gen Integer) + max' = iexp 2 64 - 1 + +sized' :: Int -> Gen a -> Gen [a] +sized' atLeast g = sized $ \n -> do + n' <- choose (atLeast, max atLeast n) + replicateM n' g + +clampedSize :: Arbitrary a => Int -> Gen String -> (String -> Maybe a) -> Gen a +clampedSize maxSize gen f = do + s <- gen + if length s > maxSize + then sized (\n -> resize (n `div` 2) arbitrary) + else return . fromJust . f $ s + +instance Arbitrary ObjectPath where + coarbitrary = undefined + arbitrary = fmap (fromJust . mkObjectPath) path' where + c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" + path = fmap (intercalate "/" . ([] :)) genElements + path' = frequency [(1, return "/"), (9, path)] + genElements = sized' 1 (sized' 1 (elements c)) + +instance Arbitrary InterfaceName where + coarbitrary = undefined + arbitrary = clampedSize 255 genName mkInterfaceName where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + + genName = fmap (intercalate ".") genElements + genElements = sized' 2 genElement + genElement = do + x <- elements c + xs <- sized' 0 (elements c') + return (x:xs) + + +instance Arbitrary BusName where + coarbitrary = undefined + arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" + c' = c ++ ['0'..'9'] + + unique = do + elems' <- sized' 2 $ elems c' + return $ ':' : intercalate "." elems' + + wellKnown = do + elems' <- sized' 2 $ elems c + return $ intercalate "." elems' + + elems start = do + x <- elements start + xs <- sized' 0 (elements c') + return (x:xs) + +instance Arbitrary MemberName where + coarbitrary = undefined + arbitrary = clampedSize 255 genName mkMemberName where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + + genName = do + x <- elements c + xs <- sized' 0 (elements c') + return (x:xs) + +instance Arbitrary ErrorName where + coarbitrary = undefined + arbitrary = fmap (fromJust . mkErrorName . strInterfaceName) arbitrary + +instance Arbitrary Type where + coarbitrary = undefined + arbitrary = oneof [atomicType, containerType] + +instance Arbitrary Signature where + coarbitrary = undefined + arbitrary = clampedSize 255 genSig mkSignature where + genSig = fmap (concatMap typeString) arbitrary + +atomicType = elements + [ BooleanT + , ByteT + , UInt16T + , UInt32T + , UInt64T + , Int16T + , Int32T + , Int64T + , DoubleT + , StringT + , ObjectPathT + , SignatureT + ] + +containerType = do + c <- choose (0,3) :: Gen Int + case c of + 0 -> fmap ArrayT arbitrary + 1 -> do + kt <- atomicType + vt <- arbitrary + return $ DictT kt vt + 2 -> sized structType + 3 -> return VariantT + +structType n | n >= 0 = fmap StructT $ resize (n `div` 2) arbitrary + +instance Arbitrary Atom where + coarbitrary = undefined + arbitrary = atomicType >>= \t -> case t of + BooleanT -> fmap toAtom (arbitrary :: Gen Bool) + ByteT -> fmap toAtom (arbitrary :: Gen Word8) + UInt16T -> fmap toAtom (arbitrary :: Gen Word16) + UInt32T -> fmap toAtom (arbitrary :: Gen Word32) + UInt64T -> fmap toAtom (arbitrary :: Gen Word64) + Int16T -> fmap toAtom (arbitrary :: Gen Int16) + Int32T -> fmap toAtom (arbitrary :: Gen Int32) + Int64T -> fmap toAtom (arbitrary :: Gen Int64) + DoubleT -> fmap toAtom (arbitrary :: Gen Double) + StringT -> fmap toAtom (arbitrary :: Gen String) + ObjectPathT -> fmap toAtom (arbitrary :: Gen ObjectPath) + SignatureT -> fmap toAtom (arbitrary :: Gen Signature) + +instance Arbitrary Array where + coarbitrary = undefined + arbitrary = do + -- Only generate arrays of atomic values, as generating + -- containers randomly almost never results in a valid + -- array. + x <- atomicType >>= \t -> case t of + BooleanT -> fmap toArray (arbitrary :: Gen [Bool]) + ByteT -> fmap toArray (arbitrary :: Gen [Word8]) + UInt16T -> fmap toArray (arbitrary :: Gen [Word16]) + UInt32T -> fmap toArray (arbitrary :: Gen [Word32]) + UInt64T -> fmap toArray (arbitrary :: Gen [Word64]) + Int16T -> fmap toArray (arbitrary :: Gen [Int16]) + Int32T -> fmap toArray (arbitrary :: Gen [Int32]) + Int64T -> fmap toArray (arbitrary :: Gen [Int64]) + DoubleT -> fmap toArray (arbitrary :: Gen [Double]) + StringT -> fmap toArray (arbitrary :: Gen [String]) + ObjectPathT -> fmap toArray (arbitrary :: Gen [ObjectPath]) + SignatureT -> fmap toArray (arbitrary :: Gen [Signature]) + + maybe arbitrary return x + +instance Arbitrary Dictionary where + coarbitrary = undefined + arbitrary = do + -- Only generate dictionaries of atomic values, as generating + -- containers randomly almost never results in a valid + -- array. + kt <- atomicType + vt <- atomicType + ks <- case kt of + BooleanT -> fmap (map toAtom) (arbitrary :: Gen [Bool]) + ByteT -> fmap (map toAtom) (arbitrary :: Gen [Word8]) + UInt16T -> fmap (map toAtom) (arbitrary :: Gen [Word16]) + UInt32T -> fmap (map toAtom) (arbitrary :: Gen [Word32]) + UInt64T -> fmap (map toAtom) (arbitrary :: Gen [Word64]) + Int16T -> fmap (map toAtom) (arbitrary :: Gen [Int16]) + Int32T -> fmap (map toAtom) (arbitrary :: Gen [Int32]) + Int64T -> fmap (map toAtom) (arbitrary :: Gen [Int64]) + DoubleT -> fmap (map toAtom) (arbitrary :: Gen [Double]) + StringT -> fmap (map toAtom) (arbitrary :: Gen [String]) + ObjectPathT -> fmap (map toAtom) (arbitrary :: Gen [ObjectPath]) + SignatureT -> fmap (map toAtom) (arbitrary :: Gen [Signature]) + vs <- case vt of + BooleanT -> fmap (map toVariant) (arbitrary :: Gen [Bool]) + ByteT -> fmap (map toVariant) (arbitrary :: Gen [Word8]) + UInt16T -> fmap (map toVariant) (arbitrary :: Gen [Word16]) + UInt32T -> fmap (map toVariant) (arbitrary :: Gen [Word32]) + UInt64T -> fmap (map toVariant) (arbitrary :: Gen [Word64]) + Int16T -> fmap (map toVariant) (arbitrary :: Gen [Int16]) + Int32T -> fmap (map toVariant) (arbitrary :: Gen [Int32]) + Int64T -> fmap (map toVariant) (arbitrary :: Gen [Int64]) + DoubleT -> fmap (map toVariant) (arbitrary :: Gen [Double]) + StringT -> fmap (map toVariant) (arbitrary :: Gen [String]) + ObjectPathT -> fmap (map toVariant) (arbitrary :: Gen [ObjectPath]) + SignatureT -> fmap (map toVariant) (arbitrary :: Gen [Signature]) + + let kSig = fromJust . mkSignature . typeString $ kt + let vSig = fromJust . mkSignature . typeString $ vt + maybe arbitrary return (dictionaryFromItems kSig vSig (zip ks vs)) + +instance Arbitrary Structure where + coarbitrary = undefined + arbitrary = sized $ \n -> + fmap Structure $ resize (n `div` 2) arbitrary + +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) + +instance Arbitrary Endianness where + coarbitrary = undefined + arbitrary = elements [LittleEndian, BigEndian] + +instance Arbitrary Serial where + coarbitrary = undefined + arbitrary = fmap Serial arbitrary + +iexp :: Integral a => a -> a -> a +iexp x y = floor $ fromIntegral x ** fromIntegral y diff --git a/Tests/Marshal.hs b/Tests/Marshal.hs new file mode 100644 --- /dev/null +++ b/Tests/Marshal.hs @@ -0,0 +1,61 @@ +{- + Copyright (C) 2009 John Millikin + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} + +module Tests.Marshal (marshalProperties) where + +import qualified Control.Exception as E +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.ByteString.Lazy as L +import Data.Word +import Data.Maybe (fromJust) + +import Test.QuickCheck +import Tests.Instances () +import DBus.Types +import DBus.Protocol.Marshal +import DBus.Protocol.Unmarshal + +marshalProperties :: [Property] +marshalProperties = + [ property prop_MarshalAnyVariant + , property prop_MarshalAtom + , property prop_Unmarshal + ] + +-- Check that any variant can be marshaled successfully. +prop_MarshalAnyVariant e x = noError $ marshal e [x] + +-- Any atomic value should marshal to *something* +prop_MarshalAtom e x = not . L.null . marshal e $ [atomToVariant x] + +-- TODO: test bytes of marshaled atoms + +-- TODO: test bytes of marshaled containers + +-- Any value, when marshaled, can be unmarshaled to the same value +prop_Unmarshal e x = unmarshaled == Right [x] where + bytes = marshal e [x] + unmarshaled :: Either String [Variant] + unmarshaled = unmarshal e (variantSignature x) bytes + +-- Helper to determine whether the given pure function raised an exception. +-- No exceptions should be raised during the normal process of marshaling. +noError :: a -> Bool +noError x = unsafePerformIO $ E.catch io onError where + onError :: E.SomeException -> IO Bool + onError = const (return False) + io = E.evaluate x >> return True diff --git a/Tests/Messages.hs b/Tests/Messages.hs new file mode 100644 --- /dev/null +++ b/Tests/Messages.hs @@ -0,0 +1,131 @@ +{- + Copyright (C) 2009 John Millikin + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} + +{-# LANGUAGE RankNTypes #-} +module Tests.Messages (messageProperties) where + +import Data.Set (fromList) +import Test.QuickCheck +import Tests.Instances () +import qualified Data.ByteString.Lazy as L +import DBus.Message +import DBus.Types + +import qualified Data.Binary.Get as G + +messageProperties = concat + [ headerFieldProperties + , forAllMessages prop_Marshal + , [ property prop_Unmarshal0 + , property prop_Unmarshal1 + , property prop_Unmarshal2 + , property prop_Unmarshal3 + ] + ] + +headerFieldProperties = + [ property prop_HeaderFieldVariable + ] + +prop_HeaderFieldVariable x = fromVariant (toVariant x) == Just x + where types = [x :: HeaderField] + +prop_Marshal gen = forAll arbitrary (\e s -> forAll gen (not . L.null . marshal e s)) + +prop_Unmarshal0 e s msg = checkUnmarshal expected e s msg where + expected = ReceivedMethodCall s Nothing msg + +prop_Unmarshal1 e s msg = checkUnmarshal expected e s msg where + expected = ReceivedMethodReturn s Nothing msg + +prop_Unmarshal2 e s msg = checkUnmarshal expected e s msg where + expected = ReceivedError s Nothing msg + +prop_Unmarshal3 e s msg = checkUnmarshal expected e s msg where + expected = ReceivedSignal s Nothing msg + +checkUnmarshal expected e s msg = unmarshaled == Right expected where + bytes = marshal e s msg + getBytes = G.getLazyByteString . fromIntegral + unmarshaled = G.runGet (unmarshal getBytes) bytes + +forAllMessages :: (forall a. (Show a, Arbitrary a, Message a, Eq a) => + (Gen a -> Property)) -> [Property] +forAllMessages t = + [ t (arbitrary :: Gen MethodCall) + , t (arbitrary :: Gen MethodReturn) + , t (arbitrary :: Gen Error) + , t (arbitrary :: Gen Signal) + ] + +instance Arbitrary Flag where + coarbitrary = undefined + arbitrary = elements [NoReplyExpected, NoAutoStart] + +instance Arbitrary HeaderField where + coarbitrary = undefined + arbitrary = do + x <- choose (1, 8) + case (x :: Int) of + 1 -> fmap Path arbitrary + 2 -> fmap Interface arbitrary + 3 -> fmap Member arbitrary + 4 -> fmap ErrorName arbitrary + 5 -> fmap ReplySerial arbitrary + 6 -> fmap Destination arbitrary + 7 -> fmap Sender arbitrary + 8 -> fmap Signature arbitrary + +instance Arbitrary MethodCall where + coarbitrary = undefined + arbitrary = do + path <- arbitrary + member <- arbitrary + iface <- arbitrary + dest <- arbitrary + flags <- fmap fromList arbitrary + body <- sized (\n -> resize (n `div` 2) arbitrary) + return $ MethodCall path member iface dest flags body + +instance Arbitrary MethodReturn where + coarbitrary = undefined + arbitrary = do + serial <- arbitrary + dest <- arbitrary + flags <- fmap fromList arbitrary + body <- sized (\n -> resize (n `div` 2) arbitrary) + return $ MethodReturn serial dest flags body + +instance Arbitrary Error where + coarbitrary = undefined + arbitrary = do + name <- arbitrary + serial <- arbitrary + dest <- arbitrary + flags <- fmap fromList arbitrary + body <- sized (\n -> resize (n `div` 2) arbitrary) + return $ Error name serial dest flags body + +instance Arbitrary Signal where + coarbitrary = undefined + arbitrary = do + path <- arbitrary + member <- arbitrary + iface <- arbitrary + flags <- fmap fromList arbitrary + body <- sized (\n -> resize (n `div` 2) arbitrary) + return $ Signal path member iface flags body diff --git a/Tests/MiscTypes.hs b/Tests/MiscTypes.hs new file mode 100644 --- /dev/null +++ b/Tests/MiscTypes.hs @@ -0,0 +1,168 @@ +{- + Copyright (C) 2009 John Millikin + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} + +module Tests.MiscTypes (miscTypeProperties) where + +import Data.Maybe (isNothing) +import Data.Word (Word8) +import Test.QuickCheck +import Tests.Instances () +import DBus.Types + +miscTypeProperties = concat + [ objectPathProperties + , interfaceNameProperties + , busNameProperties + , memberNameProperties + , errorNameProperties + , endiannessProperties + , serialProperties + ] + +prop_Equality x = x == x + +prop_IsVariable x = fromVariant (toVariant x) == Just x + +prop_IsAtomic x = fromAtom (toAtom x) == Just x + +-- Object paths + +objectPathProperties = + [ property (prop_Equality :: ObjectPath -> Bool) + , property (prop_IsVariable :: ObjectPath -> Bool) + , property (prop_IsAtomic :: ObjectPath -> Bool) + , property prop_ObjectPathIdentity + ] ++ map property prop_ObjectPathInvalid + +prop_ObjectPathIdentity x = mkObjectPath (strObjectPath x) == Just x + +prop_ObjectPathInvalid = let invalid = isNothing . mkObjectPath in + [ invalid "" + , invalid "a" + , invalid "/a/" + , invalid "/a/-" + ] + +-- Endianness + +endiannessProperties = + [ property (prop_Equality :: Endianness -> Bool) + , property prop_EndianToVariant + , property prop_EndianFromVariant + ] + +prop_EndianToVariant x@(LittleEndian) = toVariant x == toVariant (0x6C :: Word8) +prop_EndianToVariant x@(BigEndian) = toVariant x == toVariant (0x42 :: Word8) + +endianWords :: Gen Word8 +endianWords = oneof [ return 0x6C , return 0x42 , arbitrary] + +prop_EndianFromVariant = forAll endianWords $ \x -> let + v = fromVariant (toVariant x) in case x of + 0x6C -> v == Just LittleEndian + 0x42 -> v == Just BigEndian + _ -> isNothing v + +-- Interface names + +interfaceNameProperties = + [ property (prop_Equality :: InterfaceName -> Bool) + , property (prop_IsVariable :: InterfaceName -> Bool) + , property (prop_IsAtomic :: InterfaceName -> Bool) + , property prop_InterfaceNameIdentity + ] ++ map property prop_InterfaceNameInvalid + +prop_InterfaceNameIdentity x = mkInterfaceName (strInterfaceName x) == Just x + +prop_InterfaceNameInvalid = let invalid = isNothing . mkInterfaceName in + [ invalid "" + , invalid "0" + , invalid "a" + , invalid "a." + , invalid "a.1" + , invalid $ "a." ++ replicate 255 'b' + ] + +-- Bus names + +busNameProperties = + [ property (prop_Equality :: BusName -> Bool) + , property (prop_IsVariable :: BusName -> Bool) + , property (prop_IsAtomic :: BusName -> Bool) + , property prop_BusNameIdentity + ] ++ map property prop_BusNameInvalid + +prop_BusNameIdentity x = mkBusName (strBusName x) == Just x + +prop_BusNameInvalid = let invalid = isNothing . mkBusName in + [ invalid "" + , invalid ":" + , invalid ":0" + , invalid ":a" + , invalid "0" + , invalid "a" + , invalid "a." + , invalid "a.1" + , invalid $ "a." ++ replicate 255 'b' + ] + +-- Member names + +memberNameProperties = + [ property (prop_Equality :: MemberName -> Bool) + , property (prop_IsVariable :: MemberName -> Bool) + , property (prop_IsAtomic :: MemberName -> Bool) + , property prop_MemberNameIdentity + ] ++ map property prop_MemberNameInvalid + +prop_MemberNameIdentity x = mkMemberName (strMemberName x) == Just x + +prop_MemberNameInvalid = let invalid = isNothing . mkMemberName in + [ invalid "" + , invalid "0" + , invalid $ replicate 256 'a' + ] + +-- Error names + +errorNameProperties = + [ property (prop_Equality :: ErrorName -> Bool) + , property (prop_IsVariable :: ErrorName -> Bool) + , property (prop_IsAtomic :: ErrorName -> Bool) + , property prop_ErrorNameIdentity + ] ++ map property prop_ErrorNameInvalid + +prop_ErrorNameIdentity x = mkErrorName (strErrorName x) == Just x + +prop_ErrorNameInvalid = let invalid = isNothing . mkErrorName in + [ invalid "" + , invalid "0" + , invalid "a" + , invalid "a." + , invalid "a.1" + , invalid $ "a." ++ replicate 255 'b' + ] + +-- Serials + +serialProperties = + [ property (prop_IsVariable :: Serial -> Bool) + , property (prop_IsAtomic :: Serial -> Bool) + , property prop_SerialIncremented + ] + +prop_SerialIncremented x = nextSerial x > x diff --git a/Tests/Signature.hs b/Tests/Signature.hs new file mode 100644 --- /dev/null +++ b/Tests/Signature.hs @@ -0,0 +1,64 @@ +{- + Copyright (C) 2009 John Millikin + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} + +module Tests.Signature (signatureProperties) where + +import Data.Maybe (isJust, isNothing) +import Test.QuickCheck +import Tests.Instances () +import DBus.Types + +signatureProperties = + [ property (prop_Equality :: Signature -> Bool) + , property (prop_Equality :: Type -> Bool) + , property prop_TypeToSig + , property prop_Ident + , property prop_Length0 + , property prop_Length254 + , property prop_Length255 + , property prop_Length256 + , property prop_Invalid0 + , property prop_Invalid1 + , property prop_Invalid2 + , property prop_show0 + , property prop_show1 + ] + +-- Signatures and type equality +prop_Equality x = x == x + +-- Types can be converted to signatures via mkSignature +prop_TypeToSig x = typeString x == strSignature sig where + Just sig = mkSignature (typeString x) + +-- Signatures can be safely converted to strings and back +prop_Ident x = mkSignature (strSignature x) == Just x + +-- Signatures may be no more than 255 characters long +prop_Length0 = isJust . mkSignature $ "" +prop_Length254 = isJust . mkSignature . replicate 254 $ 'y' +prop_Length255 = isJust . mkSignature . replicate 255 $ 'y' +prop_Length256 = isNothing . mkSignature . replicate 256 $ 'y' + +-- Invalid signatures are not parsed +prop_Invalid0 = isNothing . mkSignature $ "a" +prop_Invalid1 = isNothing . mkSignature $ "0" +prop_Invalid2 = isNothing . mkSignature $ "a{vy}" + +-- Show is useful +prop_show0 x = showsPrec 10 x "" == "Signature \"" ++ strSignature x ++ "\"" +prop_show1 x = showsPrec 11 x "" == "(Signature \"" ++ strSignature x ++ "\")" diff --git a/dbus-core.cabal b/dbus-core.cabal --- a/dbus-core.cabal +++ b/dbus-core.cabal @@ -1,6 +1,6 @@ name: dbus-core -version: 0.1 -synopsis: DBus protocol +version: 0.2 +synopsis: Low-level DBus protocol implementation license: GPL license-file: License.txt author: John Millikin @@ -11,10 +11,30 @@ stability: experimental bug-reports: mailto:jmillikin@gmail.com +extra-source-files: + dbus-core.tex + Examples/*.hs + Tests/*.hs + Tests.hs + DBus/Types/Containers.lhs-boot + +source-repository head + type: darcs + location: http://patch-tag.com/r/dbus-core/pullrepo + library - build-depends: base >=4 && < 5, parsec >= 3, bytestring, - data-binary-ieee754, binary, utf8-string, mtl, - containers, unix, network + build-depends: + base >=4 && < 5, + parsec >= 3, + binary, + bytestring, + data-binary-ieee754, + utf8-string, + mtl, + containers, + unix, + network + exposed-modules: DBus.Bus DBus.Bus.Address @@ -28,3 +48,10 @@ DBus.Types.ObjectPath DBus.Types.Serial DBus.Types.Signature + + other-modules: + DBus.Protocol.Authentication + DBus.Protocol.Marshal + DBus.Protocol.Unmarshal + DBus.Protocol.Padding + DBus.Types.Util diff --git a/dbus-core.tex b/dbus-core.tex new file mode 100644 --- /dev/null +++ b/dbus-core.tex @@ -0,0 +1,47 @@ +\documentclass[12pt]{article} + +\usepackage{color} +\usepackage{hyperref} +\usepackage{textcomp} +\usepackage{booktabs} +\usepackage{multirow} + +% Smaller margins +\usepackage[left=1.5cm,top=2cm,right=1.5cm,nohead,nofoot]{geometry} + +% Remove boxes from hyperlinks +\hypersetup{ + colorlinks, + linkcolor=blue, +} + +\usepackage{listings} +\lstnewenvironment{code}{ + \lstset + {language=Haskell + ,basicstyle=\footnotesize\tt + ,showstringspaces=false + ,frame=single + ,upquote=true + }} + {} + +\long\def\ignore#1{} + +\makeindex + +\begin{document} + +\addcontentsline{toc}{section}{Contents} +\tableofcontents + +\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} +\input{DBus/Protocol/Unmarshal.lhs} +\input{DBus/Protocol/Padding.lhs} + +\end{document}