diff --git a/Makefile b/Makefile deleted file mode 100644 --- a/Makefile +++ /dev/null @@ -1,53 +0,0 @@ -HS_SOURCES=\ - hs/DBus/Address.hs \ - hs/DBus/Authentication.hs \ - hs/DBus/Bus.hs \ - hs/DBus/Connection.hs \ - hs/DBus/Constants.hs \ - hs/DBus/Introspection.hs \ - hs/DBus/MatchRule.hs \ - hs/DBus/Message.hs \ - hs/DBus/Message/Internal.hs \ - hs/DBus/NameReservation.hs \ - hs/DBus/Types.hs \ - hs/DBus/Util.hs \ - hs/DBus/Util/MonadError.hs \ - hs/DBus/UUID.hs \ - hs/DBus/Wire.hs \ - hs/DBus/Wire/Internal.hs \ - hs/DBus/Wire/Marshal.hs \ - hs/DBus/Wire/Unmarshal.hs \ - hs/DBus/Wire/Unicode.hs \ - hs/Tests.hs - -all: $(HS_SOURCES) - -%.tex: %.nw - noweave -delay "$<" | cpif "$@" - -hs/%.hs: dbus-core.nw hs/DBus/Message hs/DBus/Wire hs/DBus/Util - notangle -R"$*.hs" "$<" | cpphs --hashes --noline | cpif "$@" - -hs/Tests.hs: Tests.nw hs - notangle -R"Tests.hs" "$<" dbus-core.nw | cpphs --hashes --noline | cpif "$@" - -hs: - mkdir -p hs - -hs/DBus: - mkdir -p hs/DBus - -hs/DBus/Message: - mkdir -p hs/DBus/Message - -hs/DBus/Wire: - mkdir -p hs/DBus/Wire - -hs/DBus/Util: - mkdir -p hs/DBus/Util - -%.pdf: %.tex - xelatex "$<" - xelatex "$<" - -pdfs: dbus-core.pdf manual.pdf diff --git a/Tests.nw b/Tests.nw deleted file mode 100644 --- a/Tests.nw +++ /dev/null @@ -1,681 +0,0 @@ -% 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 OverloadedStrings #-} -module Main (tests) where - -import Test.QuickCheck -import Test.Framework (Test, testGroup) -import qualified Test.Framework as F -import Test.Framework.Providers.QuickCheck2 (testProperty) - -import Control.Arrow ((&&&)) -import Control.Monad (replicateM) -import qualified Data.Binary.Get as G -import Data.Char (isPrint) -import Data.List (intercalate, isInfixOf) -import Data.Maybe (fromJust, isJust, isNothing) -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import Data.Word (Word8, Word16, Word32, Word64) -import Data.Int (Int16, Int32, Int64) - -import DBus.Address -import DBus.Message.Internal -import DBus.Types -import DBus.Wire.Internal -import DBus.Wire.Marshal -import DBus.Wire.Unmarshal -import qualified DBus.Introspection as I - -@ \section{Tests} - -<>= -tests :: [Test] -tests = [<> - ] - -main :: IO () -main = F.defaultMain tests - -@ \subsection{Types} - -<>= - testGroup "Types" - [ testGroup "Atomic types" - [<> - ] - , testGroup "Container types" - [<> - ] - ] - -<>= - -<>= - -@ \subsubsection{Atoms} - -<>= - testGroup "Bool" $ commonVariantTests (arbitrary :: Gen Bool) -, testGroup "Word8" $ commonVariantTests (arbitrary :: Gen Word8) -, testGroup "Word16" $ commonVariantTests (arbitrary :: Gen Word16) -, testGroup "Word32" $ commonVariantTests (arbitrary :: Gen Word32) -, testGroup "Word64" $ commonVariantTests (arbitrary :: Gen Word64) -, testGroup "Int16" $ commonVariantTests (arbitrary :: Gen Int16) -, testGroup "Int32" $ commonVariantTests (arbitrary :: Gen Int32) -, testGroup "Int64" $ commonVariantTests (arbitrary :: Gen Int64) -, testGroup "Double" $ commonVariantTests (arbitrary :: Gen Double) -, testGroup "String" $ commonVariantTests (arbitrary :: Gen String) ++ - [ testProperty "String -> strict Text" - $ \x -> (fromVariant . toVariant) x == (Just $ T.pack x) - , testProperty "String <- strict Text" - $ \x -> (fromVariant . toVariant) x == (Just $ T.unpack x) - , testProperty "String -> lazy Text" - $ \x -> (fromVariant . toVariant) x == (Just $ TL.pack x) - , testProperty "String <- lazy Text" - $ \x -> (fromVariant . toVariant) x == (Just $ TL.unpack x) - , testProperty "Strict Text -> lazy Text" - $ \x -> (fromVariant . toVariant) x == (Just $ TL.pack . T.unpack $ x) - , testProperty "Strict Text <- lazy Text" - $ \x -> (fromVariant . toVariant) x == (Just $ T.pack . TL.unpack $ x) - ] - -<>= -atomicType :: Gen Type -atomicType = elements - [ DBusBoolean - , DBusByte - , DBusWord16 - , DBusWord32 - , DBusWord64 - , DBusInt16 - , DBusInt32 - , DBusInt64 - , DBusDouble - , DBusString - , DBusObjectPath - , DBusSignature - ] - -containerType :: Gen Type -containerType = do - c <- choose (0,3) :: Gen Int - case c of - 0 -> fmap DBusArray arbitrary - 1 -> do - kt <- atomicType - vt <- arbitrary - return $ DBusDictionary kt vt - 2 -> fmap DBusStructure $ shrinkingGen arbitrary - 3 -> return DBusVariant - -instance Arbitrary Type where - arbitrary = oneof [atomicType, containerType] - -instance Arbitrary Signature where - arbitrary = clampedSize 255 genSig mkSignature_ where - genSig = fmap (TL.concat . map typeCode) arbitrary - -<>= -, testGroup "Signature" $ commonVariantTests (arbitrary :: Gen Signature) ++ - [ testProperty "Signature identity" - $ \x -> (mkSignature . strSignature) x == Just x - , testProperty "Signature show" - $ \x -> show (strSignature x) `isInfixOf` show x - ] - -<>= -instance Arbitrary ObjectPath where - arbitrary = fmap (mkObjectPath_ . TL.pack) path' where - c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" - path = fmap (intercalate "/" . ([] :)) genElements - path' = frequency [(1, return "/"), (9, path)] - genElements = sized' 1 (sized' 1 (elements c)) - -<>= -, testGroup "ObjectPath" $ commonVariantTests (arbitrary :: Gen ObjectPath) ++ - [ testProperty "ObjectPath identity" - $ \x -> (mkObjectPath . strObjectPath) x == Just x - ] - -<>= -instance Arbitrary BusName where - 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 . TL.pack $ ':' : intercalate "." elems' - - wellKnown = do - elems' <- sized' 2 $ elems c - return . TL.pack $ intercalate "." elems' - - elems start = do - x <- elements start - xs <- sized' 0 (elements c') - return (x:xs) - -<>= -, testGroup "BusName" $ commonVariantTests (arbitrary :: Gen BusName) ++ - [ testProperty "BusName identity" - $ \x -> (mkBusName . strBusName) x == Just x - ] - -<>= -instance Arbitrary InterfaceName where - arbitrary = clampedSize 255 genName mkInterfaceName_ where - c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" - c' = c ++ ['0'..'9'] - - genName = fmap (TL.pack . intercalate ".") genElements - genElements = sized' 2 genElement - genElement = do - x <- elements c - xs <- sized' 0 (elements c') - return (x:xs) - -<>= -, testGroup "InterfaceName" $ commonVariantTests (arbitrary :: Gen InterfaceName) ++ - [ testProperty "InterfaceName identity" - $ \x -> (mkInterfaceName . strInterfaceName) x == Just x - ] - -<>= -instance Arbitrary ErrorName where - arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary - -<>= -, testGroup "ErrorName" $ commonVariantTests (arbitrary :: Gen ErrorName) ++ - [ testProperty "ErrorName identity" - $ \x -> (mkErrorName . strErrorName) x == Just x - ] - -<>= -instance Arbitrary MemberName where - 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 . TL.pack $ (x:xs) - -<>= -, testGroup "MemberName" $ commonVariantTests (arbitrary :: Gen MemberName) ++ - [ testProperty "MemberName identity" - $ \x -> (mkMemberName . strMemberName) x == Just x - ] - -@ \subsubsection{Containers} - -@ All variable types must obey these properties. - -<>= -prop_VariantIdentity gen = testProperty "Variant identity" . forAll gen - $ \x -> (fromVariant . toVariant) x == Just x - -prop_VariantEquality gen = testProperty "Variant equality" . forAll gen - $ \x y -> (x == y) == (toVariant x == toVariant y) - -@ Since all atomic types are also variable, the Variant properties are -added to the set of common Atom tests. - -<>= -, prop_VariantIdentity gen -, prop_VariantEquality gen - -<>= -commonVariantTests gen = - [ prop_VariantIdentity gen - , prop_VariantEquality gen - ] - -<>= -genVariant :: Type -> Gen Variant -genVariant DBusBoolean = fmap toVariant (arbitrary :: Gen Bool) -genVariant DBusByte = fmap toVariant (arbitrary :: Gen Word8) -genVariant DBusWord16 = fmap toVariant (arbitrary :: Gen Word16) -genVariant DBusWord32 = fmap toVariant (arbitrary :: Gen Word32) -genVariant DBusWord64 = fmap toVariant (arbitrary :: Gen Word64) -genVariant DBusInt16 = fmap toVariant (arbitrary :: Gen Int16) -genVariant DBusInt32 = fmap toVariant (arbitrary :: Gen Int32) -genVariant DBusInt64 = fmap toVariant (arbitrary :: Gen Int64) -genVariant DBusDouble = fmap toVariant (arbitrary :: Gen Double) -genVariant DBusString = fmap toVariant (arbitrary :: Gen String) -genVariant DBusObjectPath = fmap toVariant (arbitrary :: Gen ObjectPath) -genVariant DBusSignature = fmap toVariant (arbitrary :: Gen Signature) -genVariant (DBusArray _) = fmap toVariant (arbitrary :: Gen Array) -genVariant (DBusDictionary _ _) = fmap toVariant (arbitrary :: Gen Dictionary) -genVariant (DBusStructure _) = fmap toVariant (arbitrary :: Gen Structure) -genVariant DBusVariant = fmap toVariant (arbitrary :: Gen Variant) - -instance Arbitrary Variant where - arbitrary = arbitrary >>= genVariant - -<>= -genAtom :: Type -> Gen Variant -genAtom DBusBoolean = fmap toVariant (arbitrary :: Gen Bool) -genAtom DBusByte = fmap toVariant (arbitrary :: Gen Word8) -genAtom DBusWord16 = fmap toVariant (arbitrary :: Gen Word16) -genAtom DBusWord32 = fmap toVariant (arbitrary :: Gen Word32) -genAtom DBusWord64 = fmap toVariant (arbitrary :: Gen Word64) -genAtom DBusInt16 = fmap toVariant (arbitrary :: Gen Int16) -genAtom DBusInt32 = fmap toVariant (arbitrary :: Gen Int32) -genAtom DBusInt64 = fmap toVariant (arbitrary :: Gen Int64) -genAtom DBusDouble = fmap toVariant (arbitrary :: Gen Double) -genAtom DBusString = fmap toVariant (arbitrary :: Gen String) -genAtom DBusObjectPath = fmap toVariant (arbitrary :: Gen ObjectPath) -genAtom DBusSignature = fmap toVariant (arbitrary :: Gen Signature) - -<>= - testGroup "Variant" $ commonVariantTests (arbitrary :: Gen Variant) - -<>= -instance Arbitrary Array where - arbitrary = do - -- Only generate arrays of atomic values, as generating - -- containers randomly almost never results in a valid - -- array. - t <- atomicType - xs <- listOf $ genVariant t - return . fromJust $ arrayFromItems t xs - -prop_ArrayHomogeneous vs = isJust array == homogeneousTypes where - array = arrayFromItems firstType vs - homogeneousTypes = all (== firstType) types - types = map variantType vs - firstType = if null types - then DBusByte - else head types - -<>= -, testGroup "Array" $ commonVariantTests (arbitrary :: Gen Array) ++ - [ testProperty "Array identity" - $ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x) - , testProperty "Array homogeneity" prop_ArrayHomogeneous - ] - -<>= -instance Arbitrary Dictionary where - arbitrary = do - -- Only generate dictionaries of atomic values, as generating - -- containers randomly almost never results in a valid - -- dictionary. - kt <- atomicType - vt <- atomicType - ks <- listOf $ genAtom kt - vs <- vectorOf (length ks) $ genVariant vt - - return . fromJust $ dictionaryFromItems kt vt $ zip ks vs - -prop_DictionaryHomogeneous x = all correctType pairs where - pairs = dictionaryItems x - kType = dictionaryKeyType x - vType = dictionaryValueType x - correctType (k, v) = variantType k == kType && - variantType v == vType - -<>= -, testGroup "Dictionary" $ commonVariantTests (arbitrary :: Gen Dictionary) ++ - [ testProperty "Dictionary identity" - $ \x -> Just x == dictionaryFromItems - (dictionaryKeyType x) - (dictionaryValueType x) - (dictionaryItems x) - , testProperty "Dictionary homogeneity" prop_DictionaryHomogeneous - , testProperty "Dictionary must have atomic keys" - $ \vt -> forAll containerType $ \kt -> - isNothing (dictionaryFromItems kt vt []) - , testProperty "Dictionary <-> Array conversion" - $ \x -> arrayToDictionary (dictionaryToArray x) == Just x - ] - -<>= -instance Arbitrary Structure where - arbitrary = sized $ \n -> - fmap Structure $ shrinkingGen arbitrary - -<>= -, testGroup "Structure" $ commonVariantTests (arbitrary :: Gen Structure) - -@ \subsection{Addresses} - -<>= -singleTests :: Testable a => [a] -> [Test] -singleTests ts = singleTests' 1 ts where - singleTests' _ [] = [] - singleTests' n (t:ts') = plusOptions (testProperty (name n) t) - : singleTests' (n + 1) ts' - - total = length ts - options = F.TestOptions Nothing (Just 1) Nothing Nothing - plusOptions = F.plusTestOptions options - name n = "Test " ++ show n ++ "/" ++ show total - -<>= -, testGroup "Addresses" - [ testProperty "Address identity" - $ \x -> mkAddresses (strAddress x) == Just [x] - , testProperty "Multiple addresses" - $ \x y -> let - joined = TL.concat [strAddress x, ";", strAddress y] - in mkAddresses joined == Just [x, y] - , testProperty "Ignore trailing semicolon" - $ \x -> mkAddresses (TL.append (strAddress x) ";") == Just [x] - , testProperty "Ignore trailing comma" - $ \x -> let - hasParams = not . Map.null . addressParameters $ x - parsed = mkAddresses (TL.append (strAddress x) ",") - in hasParams ==> parsed == Just [x] - , testGroup "Valid addresses" $ singleTests - [ isJust . mkAddresses $ ":" - , isJust . mkAddresses $ "a:" - , isJust . mkAddresses $ "a:b=c" - , isJust . mkAddresses $ "a:;" - , isJust . mkAddresses $ "a:;b:" - , isJust . mkAddresses $ "a:b=c," - ] - , testGroup "Invalid addresses" $ singleTests - [ isNothing . mkAddresses $ "" - , isNothing . mkAddresses $ "a" - , isNothing . mkAddresses $ "a:b" - , isNothing . mkAddresses $ "a:b=" - , isNothing . mkAddresses $ "a:," - ] - ] - -<>= -instance Arbitrary Address where - 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] = mkAddresses $ TL.pack addrStr - return addr - -@ \subsection{Messages} - -<>= -instance Arbitrary Serial where - arbitrary = fmap Serial arbitrary - -instance Arbitrary Flag where - arbitrary = elements [NoReplyExpected, NoAutoStart] - -instance Arbitrary MethodCall where - arbitrary = do - path <- arbitrary - member <- arbitrary - iface <- arbitrary - dest <- arbitrary - flags <- fmap Set.fromList arbitrary - Structure body <- arbitrary - return $ MethodCall path member iface dest flags body - -instance Arbitrary MethodReturn where - arbitrary = do - serial <- arbitrary - dest <- arbitrary - Structure body <- arbitrary - return $ MethodReturn serial dest body - -instance Arbitrary Error where - arbitrary = do - name <- arbitrary - serial <- arbitrary - dest <- arbitrary - Structure body <- arbitrary - return $ Error name serial dest body - -instance Arbitrary Signal where - arbitrary = do - path <- arbitrary - member <- arbitrary - iface <- arbitrary - dest <- arbitrary - Structure body <- arbitrary - return $ Signal path member iface dest body - -@ \subsection{Wire format} - -<>= -isRight :: Either a b -> Bool -isRight = either (const False) (const True) - -prop_Unmarshal :: Endianness -> Variant -> Property -prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where - sig = mkSignature . typeCode . variantType $ x - Just sig' = sig - - bytes = runMarshal (marshal x) e - Right bytes' = bytes - - valid = isJust sig && isRight bytes - unmarshaled = runUnmarshal (unmarshal sig') e bytes' - -prop_MarshalMessage e serial msg expected = valid ==> correct where - bytes = marshalMessage e serial msg - Right bytes' = bytes - - getBytes = G.getLazyByteString . fromIntegral - unmarshaled = G.runGet (unmarshalMessage getBytes) bytes' - - valid = isRight bytes - correct = unmarshaled == Right expected - -prop_WireMethodCall e serial msg = prop_MarshalMessage e serial msg - $ ReceivedMethodCall serial Nothing msg - -prop_WireMethodReturn e serial msg = prop_MarshalMessage e serial msg - $ ReceivedMethodReturn serial Nothing msg - -prop_WireError e serial msg = prop_MarshalMessage e serial msg - $ ReceivedError serial Nothing msg - -prop_WireSignal e serial msg = prop_MarshalMessage e serial msg - $ ReceivedSignal serial Nothing msg - -<>= -, testGroup "Wire format" - [ testProperty "Marshal -> Ummarshal" prop_Unmarshal - , testGroup "Messages" - [ testProperty "Method calls" prop_WireMethodCall - , testProperty "Method returns" prop_WireMethodReturn - , testProperty "Errors" prop_WireError - , testProperty "Signals" prop_WireSignal - ] - ] - -<>= -instance Arbitrary Endianness where - arbitrary = elements [LittleEndian, BigEndian] - -@ \subsection{Introspection} - -<>= -, testGroup "Introspection" - [ testProperty "Generate -> Parse" - $ \x@(I.Object path _ _) -> let - xml = I.toXML x - Just xml' = xml - parsed = I.fromXML path xml' - in isJust xml ==> I.fromXML path xml' == Just x - ] - -<>= -subObject :: ObjectPath -> Gen I.Object -subObject parentPath = sized $ \n -> resize (min n 4) $ do - let nonRoot = do - x <- arbitrary - case strObjectPath x of - "/" -> nonRoot - x' -> return x' - - thisPath <- nonRoot - let path' = case strObjectPath parentPath of - "/" -> thisPath - x -> TL.append x thisPath - let path = mkObjectPath_ path' - ifaces <- arbitrary - children <- shrinkingGen . listOf . subObject $ path - return $ I.Object path ifaces children - -instance Arbitrary I.Object where - arbitrary = arbitrary >>= subObject - -instance Arbitrary I.Interface where - arbitrary = do - name <- arbitrary - methods <- arbitrary - signals <- arbitrary - properties <- arbitrary - return $ I.Interface name methods signals properties - -instance Arbitrary I.Method where - arbitrary = do - name <- arbitrary - inParams <- arbitrary - outParams <- arbitrary - return $ I.Method name inParams outParams - -instance Arbitrary I.Signal where - arbitrary = do - name <- arbitrary - params <- arbitrary - return $ I.Signal name params - -singleType :: Gen Signature -singleType = do - t <- arbitrary - case mkSignature $ typeCode t of - Just x -> return x - Nothing -> singleType - -instance Arbitrary I.Parameter where - arbitrary = do - name <- listOf $ arbitrary `suchThat` isPrint - sig <- singleType - return $ I.Parameter (TL.pack name) sig - -instance Arbitrary I.Property where - arbitrary = do - name <- listOf $ arbitrary `suchThat` isPrint - sig <- singleType - access <- elements - [[], [I.Read], [I.Write], - [I.Read, I.Write]] - return $ I.Property (TL.pack name) sig access - -@ \subsection{Other instances} - -<>= -iexp :: Integral a => a -> a -> a -iexp x y = floor $ fromIntegral x ** fromIntegral y - -instance Arbitrary Word8 where - arbitrary = fmap fromIntegral gen where - gen = choose (0, max') :: Gen Integer - max' = iexp 2 8 - 1 - -instance Arbitrary Word16 where - arbitrary = fmap fromIntegral gen where - gen = choose (0, max') :: Gen Integer - max' = iexp 2 16 - 1 - -instance Arbitrary Word32 where - arbitrary = fmap fromIntegral gen where - gen = choose (0, max') :: Gen Integer - max' = iexp 2 32 - 1 - -instance Arbitrary Word64 where - arbitrary = fmap fromIntegral gen where - gen = choose (0, max') :: Gen Integer - max' = iexp 2 64 - 1 - -instance Arbitrary Int16 where - arbitrary = fmap fromIntegral gen where - gen = choose (0, max') :: Gen Integer - max' = iexp 2 16 - 1 - -instance Arbitrary Int32 where - arbitrary = fmap fromIntegral gen where - gen = choose (0, max') :: Gen Integer - max' = iexp 2 32 - 1 - -instance Arbitrary Int64 where - arbitrary = fmap fromIntegral gen where - gen = choose (0, max') :: Gen Integer - max' = iexp 2 64 - 1 - -instance Arbitrary T.Text where - arbitrary = fmap T.pack arbitrary - -instance Arbitrary TL.Text where - arbitrary = fmap TL.pack arbitrary - -sized' :: Int -> Gen a -> Gen [a] -sized' atLeast g = sized $ \n -> do - n' <- choose (atLeast, max atLeast n) - replicateM n' g - -clampedSize :: Arbitrary a => Int64 -> Gen TL.Text -> (TL.Text -> a) -> Gen a -clampedSize maxSize gen f = do - s <- gen - if TL.length s > maxSize - then shrinkingGen arbitrary - else return . f $ s - -shrinkingGen :: Gen a -> Gen a -shrinkingGen gen = sized $ \n -> if n > 0 then - resize (n `div` 2) gen - else gen - diff --git a/dbus-core.cabal b/dbus-core.cabal --- a/dbus-core.cabal +++ b/dbus-core.cabal @@ -1,5 +1,5 @@ name: dbus-core -version: 0.8.2 +version: 0.8.3 synopsis: Low-level D-Bus protocol implementation license: GPL-3 license-file: License.txt @@ -11,13 +11,12 @@ stability: experimental bug-reports: mailto:jmillikin@gmail.com homepage: http://ianen.org/haskell/dbus/ -tested-with: GHC==6.10.4, GHC==6.12.1 +tested-with: GHC==6.12.1 extra-source-files: - dbus-core.nw + src/*.anansi Examples/*.hs - Makefile - Tests.nw + readme.txt source-repository head type: darcs @@ -78,7 +77,7 @@ if flag(test) build-depends: QuickCheck >= 2.1 && < 2.2 - , test-framework >= 0.2 && < 0.3 + , test-framework >= 0.2 && < 0.4 , test-framework-quickcheck2 >= 0.2 && < 0.3 else buildable: False diff --git a/dbus-core.nw b/dbus-core.nw deleted file mode 100644 --- a/dbus-core.nw +++ /dev/null @@ -1,4105 +0,0 @@ - -% 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 . - -\documentclass[12pt]{article} - -\usepackage{color} -\usepackage{hyperref} -\usepackage{booktabs} -\usepackage{multirow} -\usepackage{noweb} -\usepackage{url} - -% Smaller margins -\usepackage[left=1.5cm,top=2cm,right=1.5cm,nohead,nofoot]{geometry} - -% Remove boxes from hyperlinks -\hypersetup{ - colorlinks, - linkcolor=blue, -} - -\makeindex - -\begin{document} - -\addcontentsline{toc}{section}{Contents} -\tableofcontents - -@ -\section{Introduction} - -D-Bus is a low-latency, asynchronous IPC protocol. It is primarily used on -Linux, BSD, and other free UNIX-like systems. More information is available -at \url{http://dbus.freedesktop.org/}. - -This package is an implementation of the D-Bus protocol. It is intended -for use in either a client or server, though currently only the client -portion of connection establishment is implemented. Additionally, it -implements the introspection file format. - -All source code is licensed under the terms of the GNU GPL v3 or later. - -<>= -{- - 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 . --} - -@ -\section{Text values} - -Most of the functions in this library use the types and functions defined -in {\tt Data.Text}, in preference to the {\tt String} type. - -<>= -{-# LANGUAGE OverloadedStrings #-} - -<>= -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as TL - -@ -\section{Types} - -The {\tt DBus.Types module} defines interfaces for storing, building, and -deconstructing D-Bus values. - -<>= -<> -<> -<> -module DBus.Types (<>) where -<> -<> - -@ D-Bus types are divided into two categories, ``atomic'' and ``container'' -types. Atoms are actual values -- strings, numbers, etc. Containers store -atoms and other containers. The most interesting difference between the two -is that atoms may be used as the keys in associative mappings -(``dictionaries''). - -Internally, types are represented using an enumeration. - -<>= -data Type - = DBusBoolean - | DBusByte - | DBusInt16 - | DBusInt32 - | DBusInt64 - | DBusWord16 - | DBusWord32 - | DBusWord64 - | DBusDouble - | DBusString - | DBusSignature - | DBusObjectPath - | DBusVariant - | DBusArray Type - | DBusDictionary Type Type - | DBusStructure [Type] - deriving (Show, Eq) - -<>= -<> -isAtomicType :: Type -> Bool -isAtomicType DBusBoolean = True -isAtomicType DBusByte = True -isAtomicType DBusInt16 = True -isAtomicType DBusInt32 = True -isAtomicType DBusInt64 = True -isAtomicType DBusWord16 = True -isAtomicType DBusWord32 = True -isAtomicType DBusWord64 = True -isAtomicType DBusDouble = True -isAtomicType DBusString = True -isAtomicType DBusSignature = True -isAtomicType DBusObjectPath = True -isAtomicType _ = False - -@ Each type can be converted to a textual representation, used in ``type -signatures'' or for debugging. - -<>= -<> -typeCode :: Type -> Text -<> - -<>= - -- * Available types - Type (..) -, typeCode - -@ \subsection{Variants} - -A wrapper type is needed for safely storing generic D-Bus values in Haskell. -The D-Bus ``variant'' type is perfect for this, because variants may store -any D-Bus value. - -@ Any type which is an instance of {\tt Variable} is considered a valid -D-Bus value, because it can be used to construct {\tt Variant}s. However, -outside of this module, {\tt Variant}s can only be constructed from -pre-defined types. - -<>= -<> -data Variant - = VarBoxBool Bool - | VarBoxWord8 Word8 - | VarBoxInt16 Int16 - | VarBoxInt32 Int32 - | VarBoxInt64 Int64 - | VarBoxWord16 Word16 - | VarBoxWord32 Word32 - | VarBoxWord64 Word64 - | VarBoxDouble Double - | VarBoxString Text - | VarBoxSignature Signature - | VarBoxObjectPath ObjectPath - | VarBoxVariant Variant - | VarBoxArray Array - | VarBoxDictionary Dictionary - | VarBoxStructure Structure - deriving (Eq) - -class Variable a where - toVariant :: a -> Variant - fromVariant :: Variant -> Maybe a - -<>= - -- * Variants -, Variant -, Variable (..) - -@ Variants can be printed, for debugging purposes -- this instance shouldn't -be parsed or inspected or anything like that, since the output format might -change drastically. - -<>= -instance Show Variant where - showsPrec d var = showParen (d > 10) full where - full = s "Variant " . shows code . s " " . valueStr - code = typeCode $ variantType var - s = showString - valueStr = showsPrecVar 11 var - -showsPrecVar :: Int -> Variant -> ShowS -showsPrecVar d var = case var of - (VarBoxBool x) -> showsPrec d x - (VarBoxWord8 x) -> showsPrec d x - (VarBoxInt16 x) -> showsPrec d x - (VarBoxInt32 x) -> showsPrec d x - (VarBoxInt64 x) -> showsPrec d x - (VarBoxWord16 x) -> showsPrec d x - (VarBoxWord32 x) -> showsPrec d x - (VarBoxWord64 x) -> showsPrec d x - (VarBoxDouble x) -> showsPrec d x - (VarBoxString x) -> showsPrec d x - (VarBoxSignature x) -> showsPrec d x - (VarBoxObjectPath x) -> showsPrec d x - (VarBoxVariant x) -> showsPrec d x - (VarBoxArray x) -> showsPrec d x - (VarBoxDictionary x) -> showsPrec d x - (VarBoxStructure x) -> showsPrec d x - -@ Since many operations on D-Bus values depend on having the correct type, -{\tt variantType} is used to retrieve which type is actually stored within -a {\tt Variant}. - -<>= -<> -variantType :: Variant -> Type -variantType var = case var of - (VarBoxBool _) -> DBusBoolean - (VarBoxWord8 _) -> DBusByte - (VarBoxInt16 _) -> DBusInt16 - (VarBoxInt32 _) -> DBusInt32 - (VarBoxInt64 _) -> DBusInt64 - (VarBoxWord16 _) -> DBusWord16 - (VarBoxWord32 _) -> DBusWord32 - (VarBoxWord64 _) -> DBusWord64 - (VarBoxDouble _) -> DBusDouble - (VarBoxString _) -> DBusString - (VarBoxSignature _) -> DBusSignature - (VarBoxObjectPath _) -> DBusObjectPath - (VarBoxVariant _) -> DBusVariant - (VarBoxArray x) -> DBusArray (arrayType x) - (VarBoxDictionary x) -> let - keyT = dictionaryKeyType x - valueT = dictionaryValueType x - in DBusDictionary keyT valueT - (VarBoxStructure x) -> let - Structure items = x - in DBusStructure (map variantType items) - -<>= -, variantType - -@ A macro is useful for reducing verbosity in simple {\tt Variable} -instances. - -<>= -#define INSTANCE_VARIABLE(TYPE) \ - instance Variable TYPE where \ - { toVariant = VarBox##TYPE \ - ; fromVariant (VarBox##TYPE x) = Just x \ - ; fromVariant _ = Nothing \ - } - -@ Since {\tt Variant}s are D-Bus values themselves, they can be stored in variants. - -<>= -INSTANCE_VARIABLE(Variant) - -@ \subsection{Numerics} - -D-Bus supports most common numeric types: - -\begin{table}[h] -\caption{D-Bus Numeric types} -\begin{center} -\begin{tabular}{ll} -\toprule -Type & Description \\ -\midrule -Boolean & Either {\tt True} or {\tt False} \\ -Byte & 8-bit unsigned integer \\ -Int16 & 16-bit signed integer \\ -Int32 & 32-bit signed integer \\ -Int64 & 64-bit signed integer \\ -Word16 & 16-bit unsigned integer \\ -Word32 & 32-bit unsigned integer \\ -Word64 & 64-bit unsigned integer \\ -Double & 64-bit IEEE754 floating-point \\ -\bottomrule -\end{tabular} -\end{center} -\end{table} - -All D-Bus numeric types are fixed-length, so the {\tt Int} and {\tt Integer} -types can't be used. Instead, instances for the fixed-length integer types -are defined and any others will have to be converted. - -<>= -import Data.Word (Word8, Word16, Word32, Word64) -import Data.Int (Int16, Int32, Int64) - -<>= -INSTANCE_VARIABLE(Bool) -INSTANCE_VARIABLE(Word8) -INSTANCE_VARIABLE(Int16) -INSTANCE_VARIABLE(Int32) -INSTANCE_VARIABLE(Int64) -INSTANCE_VARIABLE(Word16) -INSTANCE_VARIABLE(Word32) -INSTANCE_VARIABLE(Word64) -INSTANCE_VARIABLE(Double) - -@ \subsection{Strings} - -Strings are a weird case; the built-in type, {\tt String}, is horribly -inefficent. To provide better performance for large strings, packed Unicode -strings defined in {\tt Data.Text} are used internally. - -<>= -instance Variable TL.Text where - toVariant = VarBoxString - fromVariant (VarBoxString x) = Just x - fromVariant _ = Nothing - -@ There's two different {\tt Text} types, strict and lazy. It'd be a pain -to store both and have to convert later, so instead, all strict {\tt Text} -values are converted to lazy values. - -<>= -import qualified Data.Text as T - -<>= -instance Variable T.Text where - toVariant = toVariant . TL.fromChunks . (:[]) - fromVariant = fmap (T.concat . TL.toChunks) . fromVariant - -@ Built-in {\tt String}s can still be stored, of course, but it requires -a language extension. - -<>= -{-# LANGUAGE TypeSynonymInstances #-} - -<>= -instance Variable String where - toVariant = toVariant . TL.pack - fromVariant = fmap TL.unpack . fromVariant - -@ \subsection{Signatures} - -@ Valid D-Bus types must obey certain rules, such as ``dict keys must be -atomic'', which are difficult to express in the Haskell type system. A -{\tt Signature} is guaranteed to be valid according to these rules. Creating -one requires using the {\tt mkSignature} function, which will convert a valid -D-Bus signature string into a {\tt Signature}. - -<>= -INSTANCE_VARIABLE(Signature) -data Signature = Signature { signatureTypes :: [Type] } - deriving (Eq) - -instance Show Signature where - showsPrec d x = showParen (d > 10) $ - showString "Signature " . shows (strSignature x) - -@ Signatures can also be converted back into text, by concatenating the -type codes of their contained types. - -<>= -strSignature :: Signature -> Text -strSignature (Signature ts) = TL.concat $ map typeCode ts - -@ It doesn't make much sense to sort signatures, but since they can be used -as dictionary keys, it's useful to have them as an instance of {\tt Ord}. - -<>= -import Data.Ord (comparing) - -<>= -instance Ord Signature where - compare = comparing strSignature - -<>= - -- * Signatures -, Signature -, signatureTypes -, strSignature - -@ \subsubsection{Type codes} - -@ For atomic types, the type code is a single letter. Arrays, structures, -and dictionary types are multiple characters. - -<>= -typeCode DBusBoolean = "b" -typeCode DBusByte = "y" -typeCode DBusInt16 = "n" -typeCode DBusInt32 = "i" -typeCode DBusInt64 = "x" -typeCode DBusWord16 = "q" -typeCode DBusWord32 = "u" -typeCode DBusWord64 = "t" -typeCode DBusDouble = "d" -typeCode DBusString = "s" -typeCode DBusSignature = "g" -typeCode DBusObjectPath = "o" -typeCode DBusVariant = "v" - -@ An array's type code is ``a'' followed by the type it contains. For example, -an array of booleans would have the type string ``ab''. - -<>= -typeCode (DBusArray t) = TL.cons 'a' $ typeCode t - -@ A dictionary's type code is ``a\{$key\_type$ $value\_type$\}''. For example, -a dictionary of bytes to booleans would have the type string ``a\{yb\}''. - -<>= -typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"] - -@ A structure's type code is the concatenation of its contained types, -wrapped by ``('' and ``)''. Structures may be empty, in which case their -type code is simply ``()''. - -<>= -typeCode (DBusStructure ts) = TL.concat $ - ["("] ++ map typeCode ts ++ [")"] - -@ \subsubsection{Parsing} - -When parsing, additional restrictions apply which are not inherent to the -D-Bus type system. {\tt mkSignature} guarantees that any {\tt Signature} is -valid according to D-Bus rules. - -<>= -mkSignature :: Text -> Maybe Signature -mkSignature text = parsed where - <> - <> - parsed = case TL.length text of - 0 -> Just $ Signature [] - 1 -> fast - _ -> slow - -@ Since single-type and empty signatures are very common, they are -special-cased for performance. - -<>= -just t = Just $ Signature [t] -fast = case TL.head text of - 'b' -> just DBusBoolean - 'y' -> just DBusByte - 'n' -> just DBusInt16 - 'i' -> just DBusInt32 - 'x' -> just DBusInt64 - 'q' -> just DBusWord16 - 'u' -> just DBusWord32 - 't' -> just DBusWord64 - 'd' -> just DBusDouble - 's' -> just DBusString - 'g' -> just DBusSignature - 'o' -> just DBusObjectPath - 'v' -> just DBusVariant - _ -> Nothing - -@ Parsec is used to parse more complex signatures. - -<>= -import Text.Parsec ((<|>)) -import qualified Text.Parsec as P -import DBus.Util (checkLength, parseMaybe) - -<>= -slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text -sigParser = do - types <- P.many parseType - P.eof - return $ Signature types - -@ Types may be either containers or atoms. Containers can't be dictionary -keys. - -<>= -parseType = parseAtom <|> parseContainer -parseContainer = - parseArray - <|> parseStruct - <|> (P.char 'v' >> return DBusVariant) - -<>= -parseArray = do - P.char 'a' - parseDict <|> fmap DBusArray parseType -parseDict = do - P.char '{' - keyType <- parseAtom - valueType <- parseType - P.char '}' - return $ DBusDictionary keyType valueType - -@ Structures can contain any types. - -<>= -parseStruct = do - P.char '(' - types <- P.many parseType - P.char ')' - return $ DBusStructure types - -<>= -parseAtom = - (P.char 'b' >> return DBusBoolean) - <|> (P.char 'y' >> return DBusByte) - <|> (P.char 'n' >> return DBusInt16) - <|> (P.char 'i' >> return DBusInt32) - <|> (P.char 'x' >> return DBusInt64) - <|> (P.char 'q' >> return DBusWord16) - <|> (P.char 'u' >> return DBusWord32) - <|> (P.char 't' >> return DBusWord64) - <|> (P.char 'd' >> return DBusDouble) - <|> (P.char 's' >> return DBusString) - <|> (P.char 'g' >> return DBusSignature) - <|> (P.char 'o' >> return DBusObjectPath) - -@ Since many signatures are defined as string literals, it's useful to -have a helper function to construct a signature directly from a string. -If the input string is invalid, {\tt error} will be called. - -<>= -import DBus.Util (mkUnsafe) - -<>= -mkSignature_ :: Text -> Signature -mkSignature_ = mkUnsafe "signature" mkSignature - -<>= -import qualified Data.String as String - -<>= -instance String.IsString Signature where - fromString = mkSignature_ . TL.pack - -@ Most signature-related functions are exposed to clients, except the -{\tt Signature} value constructor. If that were exposed, clients could -construct invalid signatures. - -<>= -, mkSignature -, mkSignature_ - -@ \subsection{Object paths} - -<>= -INSTANCE_VARIABLE(ObjectPath) -newtype ObjectPath = ObjectPath - { strObjectPath :: Text - } - deriving (Eq, Ord) - -instance Show ObjectPath where - showsPrec d (ObjectPath x) = showParen (d > 10) $ - showString "ObjectPath " . shows x - -instance String.IsString ObjectPath where - fromString = mkObjectPath_ . TL.pack - -@ An object path may be one of - -\begin{itemize} -\item The root path, {\tt "/"}. -\item {\tt '/'}, followed by one or more element names. Each element name - contains characters in the set {\tt [a-zA-Z0-9\_]}, and must have at - least one character. -\end{itemize} - -Element names are separated by {\tt '/'}, and the path may not end in -{\tt '/'} unless it is the root path. - -<>= -mkObjectPath :: Text -> Maybe ObjectPath -mkObjectPath s = parseMaybe path' (TL.unpack s) where - c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" - path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char - path' = path >> P.eof >> return (ObjectPath s) - -mkObjectPath_ :: Text -> ObjectPath -mkObjectPath_ = mkUnsafe "object path" mkObjectPath - -<>= - -- * Object paths -, ObjectPath -, strObjectPath -, mkObjectPath -, mkObjectPath_ - -@ \subsection{Arrays} - -Arrays are homogenous sequences of any valid D-Bus type. Arrays might be -empty, so the type they contain is stored instead of being calculated from -their contents (as in {\tt variantType}). - -Many D-Bus APIs represent binary data using an array of bytes; therefore, -there is a special constructor for {\tt ByteString}-based arrays. - -<>= -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as ByteString - -<>= -INSTANCE_VARIABLE(Array) -data Array - = VariantArray Type [Variant] - | ByteArray ByteString - deriving (Eq) - -<> -arrayType :: Array -> Type -arrayType (VariantArray t _) = t -arrayType (ByteArray _) = DBusByte - -arrayItems :: Array -> [Variant] -arrayItems (VariantArray _ xs) = xs -arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs - -<>= - -- * Arrays -, Array -, arrayType -, arrayItems - -@ Like {\tt Variant}, deriving {\tt Show} for {\tt Array} is mostly -just useful for debugging. - -<>= -instance Show Array where - showsPrec d array = showParen (d > 10) $ - s "Array " . showSig . s " [" . s valueString . s "]" where - s = showString - showSig = shows . typeCode . arrayType $ array - showVar var = showsPrecVar 0 var "" - valueString = intercalate ", " $ map showVar $ arrayItems array - -@ Clients constructing an array must provide the expected item type, which -will be checked for validity. Every item in the array will be checked against -the item type, to ensure the array is homogenous. - -<>= -arrayFromItems :: Type -> [Variant] -> Maybe Array -arrayFromItems DBusByte vs = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs) - -arrayFromItems t vs = do - mkSignature (typeCode t) - if all (\x -> variantType x == t) vs - then Just $ VariantArray t vs - else Nothing - -@ Additionally, for ease of use, an {\tt Array} can be converted directly -to/from lists of {\tt Variable} values. - -<>= -toArray :: Variable a => Type -> [a] -> Maybe Array -toArray t = arrayFromItems t . map toVariant - -fromArray :: Variable a => Array -> Maybe [a] -fromArray = mapM fromVariant . arrayItems - -<>= -, toArray -, fromArray -, arrayFromItems - -@ To provide a more efficient interface for byte array literals, these -functions bypass the conversions in {\tt toArray} and {\tt fromArray} - -<>= -arrayToBytes :: Array -> Maybe ByteString -arrayToBytes (ByteArray x) = Just x -arrayToBytes _ = Nothing - -arrayFromBytes :: ByteString -> Array -arrayFromBytes = ByteArray - -<>= -, arrayToBytes -, arrayFromBytes - -@ And to simplify inclusion of {\tt ByteString}s in message, instances of -{\tt Variable} exist for both strict and lazy {\tt ByteString}. - -<>= -instance Variable ByteString where - toVariant = toVariant . arrayFromBytes - fromVariant x = fromVariant x >>= arrayToBytes - -<>= -import qualified Data.ByteString as StrictByteString - -<>= -instance Variable StrictByteString.ByteString where - toVariant x = toVariant . arrayFromBytes $ ByteString.fromChunks [x] - fromVariant x = do - chunks <- ByteString.toChunks `fmap` fromVariant x - return $ StrictByteString.concat chunks - -@ \subsection{Dictionaries} - -Dictionaries are a homogenous (key $\rightarrow$ value) mapping, where the -key type must be atomic. Values may be of any valid D-Bus type. Like -{\tt Array}, {\tt Dictionary} stores its contained types. - -<>= -INSTANCE_VARIABLE(Dictionary) -data Dictionary = Dictionary - { dictionaryKeyType :: Type - , dictionaryValueType :: Type - , dictionaryItems :: [(Variant, Variant)] - } - deriving (Eq) - -<>= - -- * Dictionaries -, Dictionary -, dictionaryItems -, dictionaryKeyType -, dictionaryValueType - -@ {\tt show}ing a {\tt Dictionary} displays the mapping in a more readable -format than a list of pairs. - -<>= -import Data.List (intercalate) - -<>= -instance Show Dictionary where - showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $ - s "Dictionary " . showSig . s " {" . s valueString . s "}" where - s = showString - showSig = shows $ TL.append (typeCode kt) (typeCode vt) - valueString = intercalate ", " $ map showPair pairs - showPair (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 v) "" - -@ Constructing a {\tt Dictionary} works like constructing an {\tt Array}, -except that there are two types to check, and the key type must be atomic. - -<>= -import Control.Monad (unless) - -<>= -dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary -dictionaryFromItems kt vt pairs = do - unless (isAtomicType kt) Nothing - mkSignature (typeCode kt) - mkSignature (typeCode vt) - - let sameType (k, v) = variantType k == kt && - variantType v == vt - if all sameType pairs - then Just $ Dictionary kt vt pairs - else Nothing - -@ The closest match for dictionary semantics in Haskell is the -{\tt Data.Map.Map} type. Therefore, the utility conversion functions work -with {\tt Map}s instead of pair lists. - -<>= -import Control.Arrow ((***)) -import qualified Data.Map as Map - -<>= -toDictionary :: (Variable a, Variable b) => Type -> Type -> Map.Map a b - -> Maybe Dictionary -toDictionary kt vt = dictionaryFromItems kt vt . pairs where - pairs = map (toVariant *** toVariant) . Map.toList - -<>= -import Control.Monad (forM) - -<>= -fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary - -> Maybe (Map.Map a b) -fromDictionary (Dictionary _ _ vs) = do - pairs <- forM vs $ \(k, v) -> do - k' <- fromVariant k - v' <- fromVariant v - return (k', v') - return $ Map.fromList pairs - -<>= -, toDictionary -, fromDictionary -, dictionaryFromItems - -@ \subsubsection{Converting between {\tt Array} and {\tt Dictionary}} - -Converting between {\tt Array} and {\tt Dictionary} is useful when -(un)marshaling -- dictionaries can be thought of as arrays of two-element -structures, much as a {\tt Map} is a list of pairs. - -<>= -dictionaryToArray :: Dictionary -> Array -dictionaryToArray (Dictionary kt vt items) = array where - Just array = toArray itemType structs - itemType = DBusStructure [kt, vt] - structs = [Structure [k, v] | (k, v) <- items] - -<>= -arrayToDictionary :: Array -> Maybe Dictionary -arrayToDictionary array = do - let toPair x = do - struct <- fromVariant x - case struct of - Structure [k, v] -> Just (k, v) - _ -> Nothing - (kt, vt) <- case arrayType array of - DBusStructure [kt, vt] -> Just (kt, vt) - _ -> Nothing - pairs <- mapM toPair $ arrayItems array - dictionaryFromItems kt vt pairs - -<>= -, dictionaryToArray -, arrayToDictionary - -@ \subsection{Structures} - -A heterogeneous, fixed-length container; equivalent in purpose to a Haskell -tuple. - -<>= -INSTANCE_VARIABLE(Structure) -data Structure = Structure [Variant] - deriving (Show, Eq) - -<>= - -- * Structures -, Structure (..) - -@ \subsection{Names} - -Various aspects of D-Bus require the use of specially-formatted strings, -called ``names''. All names are limited to 255 characters, and use subsets -of ASCII. - -Since all names have basically the same structure (a {\tt newtype} -declaration and some helper functions), I define a macro to automate -the definitions. - -<>= -#define NAME_TYPE(TYPE, NAME) \ - newtype TYPE = TYPE {str##TYPE :: Text} \ - deriving (Eq, Ord); \ - \ - instance Show TYPE where \ - { showsPrec d (TYPE x) = showParen (d > 10) $ \ - showString "TYPE " . shows x \ - }; \ - \ - instance String.IsString TYPE where \ - { fromString = mk##TYPE##_ . TL.pack }; \ - \ - instance Variable TYPE where \ - { toVariant = toVariant . str##TYPE \ - ; fromVariant = (mk##TYPE =<<) . fromVariant }; \ - \ - mk##TYPE##_ :: Text -> TYPE; \ - mk##TYPE##_ = mkUnsafe NAME mk##TYPE - -<>= --- * Names - -@ \subsubsection{Bus names} - -There are two forms of bus names, ``unique'' and ``well-known''. - -Unique names begin with {\tt `:'} and contain two or more elements, separated -by {\tt `.'}. Each element consists of characters from the set -{\tt [a-zA-Z0-9\_-]}. - -Well-known names contain two or more elements, separated by {\tt `.'}. Each -element consists of characters from the set {\tt [a-zA-Z0-9\_-]}, and must -not start with a digit. - -<>= -NAME_TYPE(BusName, "bus name") - -mkBusName :: Text -> Maybe BusName -mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where - c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" - c' = c ++ ['0'..'9'] - parser = (unique <|> wellKnown) >> P.eof >> return (BusName s) - unique = P.char ':' >> elems c' - wellKnown = elems c - elems start = elem' start >> P.many1 (P.char '.' >> elem' start) - elem' start = P.oneOf start >> P.many (P.oneOf c') - -<>= - -- ** Bus names -, BusName -, strBusName -, mkBusName -, mkBusName_ - -@ \subsubsection{Interface names} - -An interface name consists of two or more {\tt '.'}-separated elements. Each -element constists of characters from the set {\tt [a-zA-Z0-9\_]}, may not -start with a digit, and must have at least one character. - -<>= -NAME_TYPE(InterfaceName, "interface name") - -mkInterfaceName :: Text -> Maybe InterfaceName -mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where - c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" - c' = c ++ ['0'..'9'] - element = P.oneOf c >> P.many (P.oneOf c') - name = element >> P.many1 (P.char '.' >> element) - parser = name >> P.eof >> return (InterfaceName s) - -<>= - -- ** Interface names -, InterfaceName -, strInterfaceName -, mkInterfaceName -, mkInterfaceName_ - -@ \subsubsection{Error names} - -Error names have the same format as interface names, so the parser logic -can just be re-purposed. - -<>= -NAME_TYPE(ErrorName, "error name") - -mkErrorName :: Text -> Maybe ErrorName -mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName - -<>= - -- ** Error names -, ErrorName -, strErrorName -, mkErrorName -, mkErrorName_ - -@ \subsubsection{Member names} - -Member names must contain only characters from the set {\tt [a-zA-Z0-9\_]}, -may not begin with a digit, and must be at least one character long. - -<>= -NAME_TYPE(MemberName, "member name") - -mkMemberName :: Text -> Maybe MemberName -mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where - c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" - c' = c ++ ['0'..'9'] - name = P.oneOf c >> P.many (P.oneOf c') - parser = name >> P.eof >> return (MemberName s) - -<>= - -- ** Member names -, MemberName -, strMemberName -, mkMemberName -, mkMemberName_ - -@ -\section{Messages} - -@ To prevent internal details of messages from leaking out to clients, -declarations are contained in an internal module and then re-exported -in the public module. - -<>= -<> -module DBus.Message - (<> - ) where -import DBus.Message.Internal - -<>= -<> -<> -module DBus.Message.Internal where -<> -import qualified Data.Set as S -import Data.Word (Word8, Word32) -import Data.Maybe (fromMaybe) -import qualified DBus.Types as T -import DBus.Util (maybeIndex) - -<>= -class Message a where - messageTypeCode :: a -> Word8 - messageHeaderFields :: a -> [HeaderField] - messageFlags :: a -> S.Set Flag - messageBody :: a -> [T.Variant] - -<>= -Message ( messageFlags - , messageBody - ) - -@ \subsection{Flags} - -The instance of {\tt Ord} only exists for storing flags in a set. Flags have -no inherent ordering. - -<>= -data Flag - = NoReplyExpected - | NoAutoStart - deriving (Show, Eq, Ord) - -<>= -, Flag (..) - -@ \subsection{Header fields} - -<>= -data HeaderField - = Path T.ObjectPath - | Interface T.InterfaceName - | Member T.MemberName - | ErrorName T.ErrorName - | ReplySerial Serial - | Destination T.BusName - | Sender T.BusName - | Signature T.Signature - deriving (Show, Eq) - -@ \subsection{Serials} - -{\tt Serial} is just a wrapper around {\tt Word32}, to provide a bit of -added type-safety. - -<>= -<> -newtype Serial = Serial { serialValue :: Word32 } - deriving (Eq, Ord) - -instance Show Serial where - show (Serial x) = show x - -instance T.Variable Serial where - toVariant (Serial x) = T.toVariant x - fromVariant = fmap Serial . T.fromVariant - -@ Additionally, some useful functions exist for incrementing serials. - -<>= -firstSerial :: Serial -firstSerial = Serial 1 - -nextSerial :: Serial -> Serial -nextSerial (Serial x) = Serial (x + 1) - -@ The {\tt Serial} constructor isn't useful to clients, because building -arbitrary serials doesn't make any sense. - -<>= -, Serial -, serialValue -, firstSerial -, nextSerial - -@ \subsection{Message types} - -<>= -maybe' :: (a -> b) -> Maybe a -> [b] -maybe' f = maybe [] (\x' -> [f x']) - -@ \subsubsection{Method calls} - -<>= -data MethodCall = MethodCall - { methodCallPath :: T.ObjectPath - , methodCallMember :: T.MemberName - , methodCallInterface :: Maybe T.InterfaceName - , methodCallDestination :: Maybe T.BusName - , methodCallFlags :: S.Set Flag - , methodCallBody :: [T.Variant] - } - deriving (Show, Eq) - -instance Message MethodCall where - messageTypeCode _ = 1 - messageFlags = methodCallFlags - messageBody = methodCallBody - messageHeaderFields m = concat - [ [ Path $ methodCallPath m - , Member $ methodCallMember m - ] - , maybe' Interface . methodCallInterface $ m - , maybe' Destination . methodCallDestination $ m - ] - -<>= -, MethodCall (..) - -@ \subsubsection{Method returns} - -<>= -data MethodReturn = MethodReturn - { methodReturnSerial :: Serial - , methodReturnDestination :: Maybe T.BusName - , methodReturnBody :: [T.Variant] - } - deriving (Show, Eq) - -instance Message MethodReturn where - messageTypeCode _ = 2 - messageFlags _ = S.fromList [NoReplyExpected, NoAutoStart] - messageBody = methodReturnBody - messageHeaderFields m = concat - [ [ ReplySerial $ methodReturnSerial m - ] - , maybe' Destination . methodReturnDestination $ m - ] - -<>= -, MethodReturn (..) - -@ \subsubsection{Errors} - -<>= -data Error = Error - { errorName :: T.ErrorName - , errorSerial :: Serial - , errorDestination :: Maybe T.BusName - , errorBody :: [T.Variant] - } - deriving (Show, Eq) - -instance Message Error where - messageTypeCode _ = 3 - messageFlags _ = S.fromList [NoReplyExpected, NoAutoStart] - messageBody = errorBody - messageHeaderFields m = concat - [ [ ErrorName $ errorName m - , ReplySerial $ errorSerial m - ] - , maybe' Destination . errorDestination $ m - ] - -@ Errors usually contain a human-readable message in their first body field. -This function lets it be retrieved easily, with a fallback if no valid -message was found. - -<>= -errorMessage :: Error -> Text -errorMessage msg = fromMaybe "(no error message)" $ do - field <- maybeIndex (errorBody msg) 0 - text <- T.fromVariant field - if TL.null text - then Nothing - else return text - -<>= -, Error (..) -, errorMessage - -@ \subsubsection{Signals} - -<>= -data Signal = Signal - { signalPath :: T.ObjectPath - , signalMember :: T.MemberName - , signalInterface :: T.InterfaceName - , signalDestination :: Maybe T.BusName - , signalBody :: [T.Variant] - } - deriving (Show, Eq) - -instance Message Signal where - messageTypeCode _ = 4 - messageFlags _ = S.fromList [NoReplyExpected, NoAutoStart] - messageBody = signalBody - messageHeaderFields m = concat - [ [ Path $ signalPath m - , Member $ signalMember m - , Interface $ signalInterface m - ] - , maybe' Destination . signalDestination $ m - ] - -<>= -, Signal (..) - -@ \subsubsection{Unknown messages} - -Unknown messages are used for storing information about messages without -a recognised type code. They are not instances of {\tt Message}, because -if they were, then clients could accidentally send invalid messages over -the bus. - -<>= -data Unknown = Unknown - { unknownType :: Word8 - , unknownFlags :: S.Set Flag - , unknownBody :: [T.Variant] - } - deriving (Show, Eq) - -<>= -, Unknown (..) - -@ \subsection{Received messages} - -Messages received from a bus have additional fields which do not make sense -when sending. - -If a message has an unknown type, its serial and origin are still useful -for sending an error reply. - -<>= -<> -data ReceivedMessage - = ReceivedMethodCall Serial (Maybe T.BusName) MethodCall - | ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn - | ReceivedError Serial (Maybe T.BusName) Error - | ReceivedSignal Serial (Maybe T.BusName) Signal - | ReceivedUnknown Serial (Maybe T.BusName) Unknown - deriving (Show, Eq) - -<>= -receivedSerial :: ReceivedMessage -> Serial -receivedSerial (ReceivedMethodCall s _ _) = s -receivedSerial (ReceivedMethodReturn s _ _) = s -receivedSerial (ReceivedError s _ _) = s -receivedSerial (ReceivedSignal s _ _) = s -receivedSerial (ReceivedUnknown s _ _) = s - -<>= -receivedSender :: ReceivedMessage -> Maybe T.BusName -receivedSender (ReceivedMethodCall _ s _) = s -receivedSender (ReceivedMethodReturn _ s _) = s -receivedSender (ReceivedError _ s _) = s -receivedSender (ReceivedSignal _ s _) = s -receivedSender (ReceivedUnknown _ s _) = s - -<>= -receivedBody :: ReceivedMessage -> [T.Variant] -receivedBody (ReceivedMethodCall _ _ x) = messageBody x -receivedBody (ReceivedMethodReturn _ _ x) = messageBody x -receivedBody (ReceivedError _ _ x) = messageBody x -receivedBody (ReceivedSignal _ _ x) = messageBody x -receivedBody (ReceivedUnknown _ _ x) = unknownBody x - -<>= -, ReceivedMessage (..) -, receivedSerial -, receivedSender -, receivedBody - -@ -\section{Wire format} - -{\tt DBus.Wire} is also split into an internal and external interface. - -<>= -<> -module DBus.Wire (<>) where -import DBus.Wire.Internal -import DBus.Wire.Marshal -import DBus.Wire.Unmarshal - -<>= -<> -module DBus.Wire.Internal where -import Data.Word (Word8, Word64) -import qualified DBus.Types as T - -@ \subsection{Endianness} - -<>= -data Endianness = LittleEndian | BigEndian - deriving (Show, Eq) - -encodeEndianness :: Endianness -> Word8 -encodeEndianness LittleEndian = 108 -encodeEndianness BigEndian = 66 - -decodeEndianness :: Word8 -> Maybe Endianness -decodeEndianness 108 = Just LittleEndian -decodeEndianness 66 = Just BigEndian -decodeEndianness _ = Nothing - -<>= - Endianness (..) - -@ \subsection{Alignment} - -Every built-in type has an associated alignment. If a value of the given -type is marshaled, it must have {\sc nul} bytes inserted until it starts -on a byte index divisible by its alignment. - -<>= -alignment :: T.Type -> Word8 -<> - -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 - -@ \subsection{Marshaling} - -Marshaling is implemented using an error transformer over an internal -state. The {\tt Builder} type is used for efficient construction of lazy -byte strings, but it doesn't provide any way to retrieve the length of its -internal buffer, so the byte count is tracked separately. - -<>= -<> -{-# LANGUAGE TypeFamilies #-} -module DBus.Wire.Marshal where -<> -<> -import DBus.Wire.Internal -import Control.Monad (when) -import Data.Maybe (fromJust) -import Data.Word (Word8, Word32, Word64) -import Data.Int (Int16, Int32, Int64) - -import qualified DBus.Types as T - -<>= -import qualified Control.Monad.State as State -import qualified DBus.Util.MonadError as E -import qualified Data.ByteString.Lazy as L -import qualified Data.Binary.Builder as B - -<>= -data MarshalState = MarshalState Endianness B.Builder !Word64 -type MarshalM = E.ErrorT MarshalError (State.State MarshalState) -type Marshal = MarshalM () - -@ Clients can perform marshaling via {\tt marshal} and {\tt runMarshal}, -which will generate a {\tt ByteString} with the fully marshaled data. - -<>= -runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString -runMarshal m e = case State.runState (E.runErrorT m) initialState of - (Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder) - (Left x, _) -> Left x - where initialState = MarshalState e B.empty 0 - -<>= -marshal :: T.Variant -> Marshal -marshal v = marshalType (T.variantType v) where - x :: T.Variable a => a - x = fromJust . T.fromVariant $ v - marshalType :: T.Type -> Marshal - <> - -@ TODO: describe these functions - -<>= -append :: L.ByteString -> Marshal -append bytes = do - (MarshalState e builder count) <- State.get - let builder' = B.append builder $ B.fromLazyByteString bytes - count' = count + fromIntegral (L.length bytes) - State.put $ MarshalState e builder' count' - -<>= -pad :: Word8 -> Marshal -pad count = do - (MarshalState _ _ existing) <- State.get - let padding' = fromIntegral $ padding existing count - append $ L.replicate padding' 0 - -@ Most numeric values already have marshalers implemented in the -{\tt Data.Binary.Builder} module; this function lets them be re-used easily. - -<>= -marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal -marshalBuilder size be le x = do - pad size - (MarshalState e builder count) <- State.get - let builder' = B.append builder $ case e of - BigEndian -> be x - LittleEndian -> le x - let count' = count + fromIntegral size - State.put $ MarshalState e builder' count' - -@ \subsubsection{Errors} - -Marshaling can fail for four reasons: - -\begin{itemize} -\item The message exceeds the maximum message size of $2^{27}$ bytes. -\item An array in the message exceeds the maximum array size of $2^{26}$ bytes. -\item The body's signature is not valid (for example, more than 255 fields). -\item A variant's signature is not valid -- same causes as an invalid body - signature. -\item Some text is invalid -- for example, it contains {\sc nul} - ({\tt '\textbackslash{}0'}) or invalid Unicode. -\end{itemize} - -<>= -data MarshalError - = MessageTooLong Word64 - | ArrayTooLong Word64 - | InvalidBodySignature Text - | InvalidVariantSignature Text - | InvalidText Text - deriving (Eq) - -instance Show MarshalError where - show (MessageTooLong x) = concat - ["Message too long (", show x, " bytes)."] - show (ArrayTooLong x) = concat - ["Array too long (", show x, " bytes)."] - show (InvalidBodySignature x) = concat - ["Invalid body signature: ", show x] - show (InvalidVariantSignature x) = concat - ["Invalid variant signature: ", show x] - show (InvalidText x) = concat - ["Text cannot be marshaled: ", show x] - -<>= -, MarshalError (..) - -@ \subsection{Unmarshaling} - -Unmarshaling also uses an error transformer and internal state. - -<>= -<> -<> -{-# LANGUAGE TypeFamilies #-} -module DBus.Wire.Unmarshal where -<> -<> -import Control.Monad (when, unless, liftM) -import Data.Maybe (fromJust, listToMaybe, fromMaybe) -import Data.Word (Word8, Word32, Word64) -import Data.Int (Int16, Int32, Int64) - -import DBus.Wire.Internal -import qualified DBus.Types as T - -<>= -import qualified Control.Monad.State as State -import Control.Monad.Trans.Class (lift) -import qualified DBus.Util.MonadError as E -import qualified Data.ByteString.Lazy as L - -<>= -data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64 -type Unmarshal = E.ErrorT UnmarshalError (State.State UnmarshalState) - -<>= -runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a -runUnmarshal m e bytes = State.evalState (E.runErrorT m) state where - state = UnmarshalState e bytes 0 - -<>= -unmarshal :: T.Signature -> Unmarshal [T.Variant] -unmarshal = mapM unmarshalType . T.signatureTypes - -unmarshalType :: T.Type -> Unmarshal T.Variant -<> - -@ TODO: describe these functions - -<>= -consume :: Word64 -> Unmarshal L.ByteString -consume count = do - (UnmarshalState e bytes offset) <- State.get - let (x, bytes') = L.splitAt (fromIntegral count) bytes - unless (L.length x == fromIntegral count) $ - E.throwError $ UnexpectedEOF offset - - State.put $ UnmarshalState e bytes' (offset + count) - return x - -<>= -skipPadding :: Word8 -> Unmarshal () -skipPadding count = do - (UnmarshalState _ _ offset) <- State.get - bytes <- consume $ padding offset count - unless (L.all (== 0) bytes) $ - E.throwError $ InvalidPadding offset - -<>= -skipTerminator :: Unmarshal () -skipTerminator = do - (UnmarshalState _ _ offset) <- State.get - bytes <- consume 1 - unless (L.all (== 0) bytes) $ - E.throwError $ MissingTerminator offset - -<>= -fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b -fromMaybeU label f x = case f x of - Just x' -> return x' - Nothing -> E.throwError . Invalid label . TL.pack . show $ x - -fromMaybeU' :: (Show a, T.Variable b) => Text -> (a -> Maybe b) -> a - -> Unmarshal T.Variant -fromMaybeU' label f x = do - x' <- fromMaybeU label f x - return $ T.toVariant x' - -<>= -import qualified Data.Binary.Get as G - -<>= -unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a -unmarshalGet count be le = do - skipPadding count - (UnmarshalState e _ _) <- State.get - bs <- consume . fromIntegral $ count - let get' = case e of - BigEndian -> be - LittleEndian -> le - return $ G.runGet get' bs - -unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a - -> Unmarshal T.Variant -unmarshalGet' count be le = T.toVariant `fmap` unmarshalGet count be le - -<>= -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 - -@ \subsubsection{Errors} - -Unmarshaling can fail for four reasons: - -\begin{itemize} -\item The message's declared protocol version is unsupported. -\item Unexpected {\sc eof}, when there are less bytes remaining than are - required. -\item An invalid byte sequence for a given value type. -\item Missing required header fields for the declared message type. -\item Non-zero bytes were found where padding was expected. -\item A string, signature, or object path was not {\sc null}-terminated. -\item An array's size didn't match the number of elements -\end{itemize} - -<>= -data UnmarshalError - = UnsupportedProtocolVersion Word8 - | UnexpectedEOF Word64 - | Invalid Text Text - | MissingHeaderField Text - | InvalidHeaderField Text T.Variant - | InvalidPadding Word64 - | MissingTerminator Word64 - | ArraySizeMismatch - deriving (Eq) - -instance Show UnmarshalError where - show (UnsupportedProtocolVersion x) = concat - ["Unsupported protocol version: ", show x] - show (UnexpectedEOF pos) = concat - ["Unexpected EOF at position ", show pos] - show (Invalid label x) = TL.unpack $ TL.concat - ["Invalid ", label, ": ", x] - show (MissingHeaderField x) = concat - ["Required field " , show x , " is missing."] - show (InvalidHeaderField x got) = concat - [ "Invalid header field ", show x, ": ", show got] - show (InvalidPadding pos) = concat - ["Invalid padding at position ", show pos] - show (MissingTerminator pos) = concat - ["Missing NUL terminator at position ", show pos] - show ArraySizeMismatch = "Array size mismatch" - -<>= -, UnmarshalError (..) - -@ \subsection{Numerics} - -Numeric values are fixed-length, and aligned ``naturally'' -- ie, a 4-byte -integer will have a 4-byte alignment. - -<>= -alignment T.DBusByte = 1 -alignment T.DBusWord16 = 2 -alignment T.DBusWord32 = 4 -alignment T.DBusWord64 = 8 -alignment T.DBusInt16 = 2 -alignment T.DBusInt32 = 4 -alignment T.DBusInt64 = 8 -alignment T.DBusDouble = 8 - -@ Because {\tt Word32}s are often used for other types, there's -separate functions for handling them. - -<>= -marshalWord32 :: Word32 -> Marshal -marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le - -<>= -unmarshalWord32 :: Unmarshal Word32 -unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le - -<>= -marshalType T.DBusByte = append $ L.singleton x -marshalType T.DBusWord16 = marshalBuilder 2 B.putWord16be B.putWord16le x -marshalType T.DBusWord32 = marshalBuilder 4 B.putWord32be B.putWord32le x -marshalType T.DBusWord64 = marshalBuilder 8 B.putWord64be B.putWord64le x -marshalType T.DBusInt16 = marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral (x :: Int16) -marshalType T.DBusInt32 = marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral (x :: Int32) -marshalType T.DBusInt64 = marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral (x :: Int64) - -<>= -unmarshalType T.DBusByte = fmap (T.toVariant . L.head) $ consume 1 -unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le -unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le -unmarshalType T.DBusWord64 = unmarshalGet' 8 G.getWord64be G.getWord64le - -unmarshalType T.DBusInt16 = do - x <- unmarshalGet 2 G.getWord16be G.getWord16le - return . T.toVariant $ (fromIntegral x :: Int16) - -unmarshalType T.DBusInt32 = do - x <- unmarshalGet 4 G.getWord32be G.getWord32le - return . T.toVariant $ (fromIntegral x :: Int32) - -unmarshalType T.DBusInt64 = do - x <- unmarshalGet 8 G.getWord64be G.getWord64le - return . T.toVariant $ (fromIntegral x :: Int64) - -@ {\tt Double}s are marshaled as in-bit IEEE-754 floating-point format. - -<>= -import Data.Binary.Put (runPut) -import qualified Data.Binary.IEEE754 as IEEE - -<>= -import qualified Data.Binary.IEEE754 as IEEE - -<>= -marshalType T.DBusDouble = do - pad 8 - (MarshalState e _ _) <- State.get - let put = case e of - BigEndian -> IEEE.putFloat64be - LittleEndian -> IEEE.putFloat64le - let bytes = runPut $ put x - append bytes - -<>= -unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le - -@ \subsection{Booleans} - -Booleans are marshaled as 4-byte unsigned integers containing either of -the values 0 or 1. Yes, really. - -<>= -alignment T.DBusBoolean = 4 - -<>= -marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0 - -<>= -unmarshalType T.DBusBoolean = unmarshalWord32 >>= - fromMaybeU' "boolean" (\x -> case x of - 0 -> Just False - 1 -> Just True - _ -> Nothing) - -@ \subsection{Strings and object paths} - -Strings are encoded in {\sc utf-8}, terminated with {\tt NUL}, and prefixed -with their length as an unsigned 32-bit integer. Their alignment is that of -their length. Object paths are marshaled just like strings, though additional -checks are required when unmarshaling. - -Because the encoding functions from {\tt Data.Text} raise exceptions on -error, checking their return value requires some ugly workarounds. - -<>= -<> -module DBus.Wire.Unicode - ( maybeEncodeUtf8 - , maybeDecodeUtf8) where -import Data.ByteString.Lazy (ByteString) -import Data.Text.Lazy (Text) -import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) -import Data.Text.Encoding.Error (UnicodeException) -import qualified Control.Exception as Exc -import System.IO.Unsafe (unsafePerformIO) - -excToMaybe :: a -> Maybe a -excToMaybe x = unsafePerformIO $ fmap Just (Exc.evaluate x) `Exc.catch` unicodeError - -unicodeError :: UnicodeException -> IO (Maybe a) -unicodeError = const $ return Nothing - -maybeEncodeUtf8 :: Text -> Maybe ByteString -maybeEncodeUtf8 = excToMaybe . encodeUtf8 - -maybeDecodeUtf8 :: ByteString -> Maybe Text -maybeDecodeUtf8 = excToMaybe . decodeUtf8 - -<>= -import DBus.Wire.Unicode (maybeEncodeUtf8) - -<>= -marshalText :: Text -> Marshal -marshalText x = do - bytes <- case maybeEncodeUtf8 x of - Just x' -> return x' - Nothing -> E.throwError $ InvalidText x - when (L.any (== 0) bytes) $ - E.throwError $ InvalidText x - marshalWord32 . fromIntegral . L.length $ bytes - append bytes - append (L.singleton 0) - -<>= -import DBus.Wire.Unicode (maybeDecodeUtf8) - -<>= -unmarshalText :: Unmarshal Text -unmarshalText = do - byteCount <- unmarshalWord32 - bytes <- consume . fromIntegral $ byteCount - skipTerminator - fromMaybeU "text" maybeDecodeUtf8 bytes - -<>= -alignment T.DBusString = 4 -alignment T.DBusObjectPath = 4 - -<>= -marshalType T.DBusString = marshalText x -marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x - -<>= -unmarshalType T.DBusString = fmap T.toVariant unmarshalText - -unmarshalType T.DBusObjectPath = unmarshalText >>= - fromMaybeU' "object path" T.mkObjectPath - -@ \subsection{Signatures} - -Signatures are similar to strings, except their length is limited to 255 -characters and is therefore stored as a single byte. - -<>= -import Data.Text.Lazy.Encoding (encodeUtf8) - -<>= -marshalSignature :: T.Signature -> Marshal -marshalSignature x = do - let bytes = encodeUtf8 . T.strSignature $ x - let size = fromIntegral . L.length $ bytes - append (L.singleton size) - append bytes - append (L.singleton 0) - -<>= -unmarshalSignature :: Unmarshal T.Signature -unmarshalSignature = do - byteCount <- L.head `fmap` consume 1 - bytes <- consume $ fromIntegral byteCount - sigText <- fromMaybeU "text" maybeDecodeUtf8 bytes - skipTerminator - fromMaybeU "signature" T.mkSignature sigText - -<>= -alignment T.DBusSignature = 1 - -<>= -marshalType T.DBusSignature = marshalSignature x - -<>= -unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature - -@ \subsection{Containers} - -@ \subsubsection{Arrays} - -<>= -alignment (T.DBusArray _) = 4 - -<>= -marshalType (T.DBusArray _) = marshalArray x - -<>= -unmarshalType (T.DBusArray t) = T.toVariant `fmap` unmarshalArray t - -@ 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. - -<>= -import qualified DBus.Constants as C - -<>= -marshalArray :: T.Array -> Marshal -marshalArray x = do - (arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x - let arrayLen = L.length arrayBytes - when (arrayLen > fromIntegral C.arrayMaximumLength) - (E.throwError $ ArrayTooLong $ fromIntegral arrayLen) - marshalWord32 $ fromIntegral arrayLen - append $ L.replicate arrayPadding 0 - append arrayBytes - -<>= -getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString) -getArrayBytes T.DBusByte x = return (0, bytes) where - Just bytes = T.arrayToBytes x - -<>= -getArrayBytes itemType x = do - let vs = T.arrayItems x - s <- State.get - (MarshalState _ _ afterLength) <- marshalWord32 0 >> State.get - (MarshalState e _ afterPadding) <- pad (alignment itemType) >> State.get - - State.put $ MarshalState e B.empty afterPadding - (MarshalState _ itemBuilder _) <- mapM_ marshal vs >> State.get - - let itemBytes = B.toLazyByteString itemBuilder - paddingSize = fromIntegral $ afterPadding - afterLength - - State.put s - return (paddingSize, itemBytes) - -@ Unmarshaling is much easier, especially if it's a byte array. - -<>= -unmarshalArray :: T.Type -> Unmarshal T.Array -unmarshalArray T.DBusByte = do - byteCount <- unmarshalWord32 - T.arrayFromBytes `fmap` consume (fromIntegral byteCount) - -<>= -unmarshalArray itemType = do - let getOffset = do - (UnmarshalState _ _ o) <- State.get - return o - byteCount <- unmarshalWord32 - skipPadding (alignment itemType) - start <- getOffset - let end = start + fromIntegral byteCount - vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType) - end' <- getOffset - when (end' > end) $ - E.throwError ArraySizeMismatch - fromMaybeU "array" (T.arrayFromItems itemType) vs - -@ \subsubsection{Dictionaries} - -<>= -alignment (T.DBusDictionary _ _) = 4 - -<>= -marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x) - -<>= -unmarshalType (T.DBusDictionary kt vt) = do - let pairType = T.DBusStructure [kt, vt] - array <- unmarshalArray pairType - fromMaybeU' "dictionary" T.arrayToDictionary array - -@ \subsubsection{Structures} - -<>= -alignment (T.DBusStructure _) = 8 - -<>= -marshalType (T.DBusStructure _) = do - let T.Structure vs = x - pad 8 - mapM_ marshal vs - -<>= -unmarshalType (T.DBusStructure ts) = do - skipPadding 8 - fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts - -@ \subsubsection{Variants} - -<>= -alignment T.DBusVariant = 1 - -<>= -marshalType T.DBusVariant = do - let rawSig = T.typeCode . T.variantType $ x - sig <- case T.mkSignature rawSig of - Just x' -> return x' - Nothing -> E.throwError $ InvalidVariantSignature rawSig - marshalSignature sig - marshal x - -<>= -unmarshalType T.DBusVariant = do - let getType sig = case T.signatureTypes sig of - [t] -> Just t - _ -> Nothing - - t <- fromMaybeU "variant signature" getType =<< unmarshalSignature - T.toVariant `fmap` unmarshalType t - -@ \subsection{Messages} - -<>= -import qualified DBus.Message.Internal as M - -<>= -import qualified DBus.Message.Internal as M - -@ \subsubsection{Flags} - -<>= -import Data.Bits ((.&.)) -import qualified Data.Set as Set - -<>= -import Data.Bits ((.|.)) -import qualified Data.Set as Set - -<>= -encodeFlags :: Set.Set M.Flag -> Word8 -encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where - flagValue M.NoReplyExpected = 0x1 - flagValue M.NoAutoStart = 0x2 - -<>= -decodeFlags :: Word8 -> Set.Set M.Flag -decodeFlags word = Set.fromList flags where - flagSet = [ (0x1, M.NoReplyExpected) - , (0x2, M.NoAutoStart) - ] - flags = flagSet >>= \(x, y) -> [y | word .&. x > 0] - -@ \subsubsection{Header fields} - -<>= -encodeField :: M.HeaderField -> T.Structure -encodeField (M.Path x) = encodeField' 1 x -encodeField (M.Interface x) = encodeField' 2 x -encodeField (M.Member x) = encodeField' 3 x -encodeField (M.ErrorName x) = encodeField' 4 x -encodeField (M.ReplySerial x) = encodeField' 5 x -encodeField (M.Destination x) = encodeField' 6 x -encodeField (M.Sender x) = encodeField' 7 x -encodeField (M.Signature x) = encodeField' 8 x - -encodeField' :: T.Variable a => Word8 -> a -> T.Structure -encodeField' code x = T.Structure - [ T.toVariant code - , T.toVariant $ T.toVariant x - ] - -<>= -decodeField :: Monad m => T.Structure - -> E.ErrorT UnmarshalError m [M.HeaderField] -decodeField struct = case unpackField struct of - (1, x) -> decodeField' x M.Path "path" - (2, x) -> decodeField' x M.Interface "interface" - (3, x) -> decodeField' x M.Member "member" - (4, x) -> decodeField' x M.ErrorName "error name" - (5, x) -> decodeField' x M.ReplySerial "reply serial" - (6, x) -> decodeField' x M.Destination "destination" - (7, x) -> decodeField' x M.Sender "sender" - (8, x) -> decodeField' x M.Signature "signature" - _ -> return [] - -decodeField' :: (Monad m, T.Variable a) => T.Variant -> (a -> b) -> Text - -> E.ErrorT UnmarshalError m [b] -decodeField' x f label = case T.fromVariant x of - Just x' -> return [f x'] - Nothing -> E.throwError $ InvalidHeaderField label x - -<>= -unpackField :: T.Structure -> (Word8, T.Variant) -unpackField struct = (c', v') where - T.Structure [c, v] = struct - c' = fromJust . T.fromVariant $ c - v' = fromJust . T.fromVariant $ v - -@ \subsubsection{Header layout} - -TODO: describe header layout here - -@ \subsubsection{Marshaling} - -<>= -, marshalMessage - -<>= -<> -marshalMessage :: M.Message a => Endianness -> M.Serial -> a - -> Either MarshalError L.ByteString -marshalMessage e serial msg = runMarshal marshaler e where - body = M.messageBody msg - marshaler = do - sig <- checkBodySig body - empty <- State.get - mapM_ marshal body - (MarshalState _ bodyBytesB _) <- State.get - State.put empty - marshalEndianness e - let bodyBytes = B.toLazyByteString bodyBytesB - marshalHeader msg serial sig - $ fromIntegral . L.length $ bodyBytes - pad 8 - append bodyBytes - checkMaximumSize - -<>= -checkBodySig :: [T.Variant] -> MarshalM T.Signature -checkBodySig vs = let - sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs - invalid = E.throwError $ InvalidBodySignature sigStr - in case T.mkSignature sigStr of - Just x -> return x - Nothing -> invalid - -<>= -marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32 - -> Marshal -marshalHeader msg serial bodySig bodyLength = do - let fields = M.Signature bodySig : M.messageHeaderFields msg - marshal . T.toVariant . M.messageTypeCode $ msg - marshal . T.toVariant . encodeFlags . M.messageFlags $ msg - marshal . T.toVariant $ C.protocolVersion - marshalWord32 bodyLength - marshal . T.toVariant $ serial - let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant] - marshal . T.toVariant . fromJust . T.toArray fieldType - $ map encodeField fields - -<>= -marshalEndianness :: Endianness -> Marshal -marshalEndianness = marshal . T.toVariant . encodeEndianness - -<>= -checkMaximumSize :: Marshal -checkMaximumSize = do - (MarshalState _ _ messageLength) <- State.get - when (messageLength > fromIntegral C.messageMaximumLength) - (E.throwError $ MessageTooLong $ fromIntegral messageLength) - -@ \subsubsection{Unmarshaling} - -<>= -import qualified DBus.Constants as C - -<>= -, unmarshalMessage - -<>= -<> -unmarshalMessage :: Monad m => (Word32 -> m L.ByteString) - -> m (Either UnmarshalError M.ReceivedMessage) -unmarshalMessage getBytes' = E.runErrorT $ do - let getBytes = lift . getBytes' - - <> - <> - <> - <> - -@ The first part of the header has a fixed size of 16 bytes, so it can be -retrieved without any size calculations. - -<>= -let fixedSig = "yyyyuuu" -fixedBytes <- getBytes 16 - -@ The first field of interest is the protocol version; if the incoming -message's version is different from this library, the message cannot be -parsed. - -<>= -let messageVersion = L.index fixedBytes 3 -when (messageVersion /= C.protocolVersion) $ - E.throwError $ UnsupportedProtocolVersion messageVersion - -@ Next is the endianness, used for parsing pretty much every other field. - -<>= -let eByte = L.index fixedBytes 0 -endianness <- case decodeEndianness eByte of - Just x' -> return x' - Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte - -@ With the endianness out of the way, the rest of the fixed header -can be decoded - -<>= -let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of - Right x' -> return x' - Left e -> E.throwError e -fixed <- unmarshal' fixedSig fixedBytes -let typeCode = fromJust . T.fromVariant $ fixed !! 1 -let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2 -let bodyLength = fromJust . T.fromVariant $ fixed !! 4 -let serial = fromJust . T.fromVariant $ fixed !! 5 - -@ The last field of the fixed header is actually part of the field array, -but is treated as a single {\tt Word32} so it'll be known how many bytes -to retrieve. - -<>= -let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6 - -@ With the field byte count, the remainder of the header bytes can be -pulled out of the monad. - -<>= -let headerSig = "yyyyuua(yv)" -fieldBytes <- getBytes fieldByteCount -let headerBytes = L.append fixedBytes fieldBytes -header <- unmarshal' headerSig headerBytes - -@ And the header fields can be parsed. - -<>= -let fieldArray = fromJust . T.fromVariant $ header !! 6 -let fieldStructures = fromJust . T.fromArray $ fieldArray -fields <- concat `liftM` mapM decodeField fieldStructures - -@ The body is always aligned to 8 bytes, so pull out the padding before -unmarshaling it. - -<>= -let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 -getBytes . fromIntegral $ bodyPadding - -<>= -findBodySignature :: [M.HeaderField] -> T.Signature -findBodySignature fields = fromMaybe "" signature where - signature = listToMaybe [x | M.Signature x <- fields] - -<>= -let bodySig = findBodySignature fields - -@ Then pull the body bytes, and unmarshal it. - -<>= -bodyBytes <- getBytes bodyLength -body <- unmarshal' bodySig bodyBytes - -@ Even if the received message was structurally valid, building the -{\tt ReceivedMessage} can still fail due to missing header fields. - -Slightly ugly; to avoid orphan instances of either {\tt Text} or -{\tt Either}, a newtype is used to turn {\tt Either} into a monad. - -<>= -newtype EitherM a b = EitherM (Either a b) - -instance Monad (EitherM a) where - return = EitherM . Right - (EitherM (Left x)) >>= _ = EitherM (Left x) - (EitherM (Right x)) >>= k = k x - -<>= -y <- case buildReceivedMessage typeCode fields of - EitherM (Right x) -> return x - EitherM (Left x) -> E.throwError $ MissingHeaderField x - -<>= -return $ y serial flags body - -@ This really belongs in the Message section... - -<>= -buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text - (M.Serial -> (Set.Set M.Flag) -> [T.Variant] - -> M.ReceivedMessage) - -@ Method calls - -<>= -buildReceivedMessage 1 fields = do - path <- require "path" [x | M.Path x <- fields] - member <- require "member name" [x | M.Member x <- fields] - return $ \serial flags body -> let - iface = listToMaybe [x | M.Interface x <- fields] - dest = listToMaybe [x | M.Destination x <- fields] - sender = listToMaybe [x | M.Sender x <- fields] - msg = M.MethodCall path member iface dest flags body - in M.ReceivedMethodCall serial sender msg - -@ Method returns - -<>= -buildReceivedMessage 2 fields = do - replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] - return $ \serial _ body -> let - dest = listToMaybe [x | M.Destination x <- fields] - sender = listToMaybe [x | M.Sender x <- fields] - msg = M.MethodReturn replySerial dest body - in M.ReceivedMethodReturn serial sender msg - -@ Errors - -<>= -buildReceivedMessage 3 fields = do - name <- require "error name" [x | M.ErrorName x <- fields] - replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] - return $ \serial _ body -> let - dest = listToMaybe [x | M.Destination x <- fields] - sender = listToMaybe [x | M.Sender x <- fields] - msg = M.Error name replySerial dest body - in M.ReceivedError serial sender msg - -@ Signals - -<>= -buildReceivedMessage 4 fields = do - path <- require "path" [x | M.Path x <- fields] - member <- require "member name" [x | M.Member x <- fields] - iface <- require "interface" [x | M.Interface x <- fields] - return $ \serial _ body -> let - dest = listToMaybe [x | M.Destination x <- fields] - sender = listToMaybe [x | M.Sender x <- fields] - msg = M.Signal path member iface dest body - in M.ReceivedSignal serial sender msg - -@ Unknown - -<>= -buildReceivedMessage typeCode fields = return $ \serial flags body -> let - sender = listToMaybe [x | M.Sender x <- fields] - msg = M.Unknown typeCode flags body - in M.ReceivedUnknown serial sender msg - -<>= -require :: Text -> [a] -> EitherM Text a -require _ (x:_) = return x -require label _ = EitherM $ Left label - -@ -\section{Addresses} - -<>= -<> -<> -module DBus.Address - ( Address - , addressMethod - , addressParameters - , mkAddresses - , strAddress - ) where -<> - -import Data.Char (ord, chr) -import qualified Data.Map as M -import Text.Printf (printf) -import qualified Text.Parsec as P -import Text.Parsec ((<|>)) -import DBus.Util (hexToInt, eitherToMaybe) - -@ \subsection{Address syntax} - -A bus address is in the format {\tt $method$:$key$=$value$,$key$=$value$...} -where the method may be empty and parameters are optional. An address's -parameter list, if present, may end with a comma. Addresses in environment -variables are separated by semicolons, and the full address list may end -in a semicolon. Multiple parameters may have the same key; in this case, -only the first parameter for each key will be stored. - -The bytes allowed in each component of the address are given by the following -chart, where each character is understood to be its ASCII value: - -\begin{table}[h] -\begin{center} -\begin{tabular}{ll} -\toprule -Component & Allowed Characters \\ -\midrule -Method & Any except {\tt `;'} and {\tt `:'} \\ -Param key & Any except {\tt `;'}, {\tt `,'}, and {\tt `='} \\ -Param value & {\tt `0'} to {\tt `9'} \\ - & {\tt `a'} to {\tt `z'} \\ - & {\tt `A'} to {\tt `Z'} \\ - & Any of: {\tt - \textunderscore{} / \textbackslash{} * . \%} \\ -\bottomrule -\end{tabular} -\end{center} -\end{table} - -In parameter values, any byte may be encoded by prepending the \% character -to its value in hexadecimal. \% is not allowed to appear unless it is -followed by two hexadecimal digits. Every other allowed byte is termed -an ``optionally encoded'' byte, and may appear unescaped in parameter -values. - -<>= -optionallyEncoded :: [Char] -optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." - -@ -The address simply stores its method and parameter map, with a custom -{\tt Show} instance to provide easier debugging. - -<>= -data Address = Address - { addressMethod :: Text - , addressParameters :: M.Map Text Text - } deriving (Eq) - -instance Show Address where - showsPrec d x = showParen (d> 10) $ - showString "Address " . shows (strAddress x) - -@ -Parsing is straightforward; the input string is divided into addresses by -semicolons, then further by colons and commas. Parsing will fail if any -of the addresses in the input failed to parse. - -<>= -mkAddresses :: Text -> Maybe [Address] -mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where - address = do - method <- P.many (P.noneOf ":;") - P.char ':' - params <- P.sepEndBy param (P.char ',') - return $ Address (TL.pack method) (M.fromList params) - - param = do - key <- P.many1 (P.noneOf "=;,") - P.char '=' - value <- P.many1 (encodedValue <|> unencodedValue) - return (TL.pack key, TL.pack value) - - parser = do - as <- P.sepEndBy1 address (P.char ';') - P.eof - return as - - unencodedValue = P.oneOf optionallyEncoded - encodedValue = do - P.char '%' - hex <- P.count 2 P.hexDigit - return . chr . hexToInt $ hex - -@ -Converting an {\tt Address} back to a {\tt String} is just the reverse -operation. Note that because the original parameter order is not preserved, -the string produced might differ from the original input. - -<>= -strAddress :: Address -> Text -strAddress (Address t ps) = TL.concat [t, ":", ps'] where - ps' = TL.intercalate "," $ do - (k, v) <- M.toList ps - return $ TL.concat [k, "=", TL.concatMap encode v] - encode c | elem c optionallyEncoded = TL.singleton c - | otherwise = TL.pack $ printf "%%%02X" (ord c) - -@ -\section{Connections} - -<>= -<> -<> -{-# LANGUAGE DeriveDataTypeable #-} -module DBus.Connection - ( <> - ) where -<> -<> - -@ A {\tt Connection} is an opaque handle to an open D-Bus channel, with -an internal state for maintaining the current message serial. - -The second {\tt MVar} doesn't really store a value, it's just used to -prevent two separate threads from reading from the transport at once. - -<>= -import qualified Control.Concurrent as C -import qualified DBus.Address as A -import qualified DBus.Message as M -import qualified DBus.UUID as UUID - -<>= -data Connection = Connection - { connectionAddress :: A.Address - , connectionTransport :: Transport - , connectionSerialMVar :: C.MVar M.Serial - , connectionReadMVar :: C.MVar () - , connectionUUID :: UUID.UUID - } - -<>= - Connection -, connectionAddress -, connectionUUID - -@ While not particularly useful for other functions, being able to -{\tt show} a {\tt Connection} is useful when debugging. - -<>= -instance Show Connection where - showsPrec d con = showParen (d > 10) strCon where - addr = A.strAddress $ connectionAddress con - strCon = s "" - s = showString - -@ \subsection{Transports} - -A transport is anything which can send and receive bytestrings, typically -via a socket. - -<>= -import qualified Data.ByteString.Lazy as L -import Data.Word (Word32) - -<>= -<> -data Transport = Transport - { transportSend :: L.ByteString -> IO () - , transportRecv :: Word32 -> IO L.ByteString - , transportClose :: IO () - } - -@ If a method has no known transport, attempting to connect using it will -just result in an exception. - -<>= -connectTransport :: A.Address -> IO Transport -connectTransport a = transport' (A.addressMethod a) a where - transport' "unix" = unix - transport' "tcp" = tcp - transport' _ = E.throwIO . UnknownMethod - -@ \subsubsection{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. - -<>= -import qualified Network as N -import qualified Data.Map as Map - -<>= -unix :: A.Address -> IO Transport -unix a = port >>= N.connectTo "localhost" >>= handleTransport 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' transport." - 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 a tooMany - (Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew - (Just x, Nothing) -> return $ TL.unpack x - (Nothing, Just x) -> return $ '\x00' : TL.unpack x - -@ \subsubsection{TCP} - -The {\sc tcp} transport has three parameters: - -\begin{itemize} -\item {\tt host} -- optional, defaults to {\tt "localhost"} -\item {\tt port} -- unsigned 16-bit integer -\item {\tt family} -- optional, defaults to {\sc unspec}, choices are - {\tt "ipv4"} or {\tt "ipv6"} -\end{itemize} - -The high-level {\tt Network} module doesn't provide enough control over -socket construction for this transport, so {\tt Network.Socket} must be -imported. - -<>= -import qualified Network.Socket as NS - -<>= -tcp :: A.Address -> IO Transport -tcp a = openHandle >>= handleTransport where - params = A.addressParameters a - openHandle = do - port <- getPort - family <- getFamily - addresses <- getAddresses family - socket <- openSocket port addresses - NS.socketToHandle socket I.ReadWriteMode - -@ Parameter parsing... - -<>= - hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params - -<>= - unknownFamily x = TL.concat ["Unknown socket family for TCP transport: ", x] - getFamily = case Map.lookup "family" params of - Just "ipv4" -> return NS.AF_INET - Just "ipv6" -> return NS.AF_INET6 - Nothing -> return NS.AF_UNSPEC - Just x -> E.throwIO $ BadParameters a $ unknownFamily x - -<>= - missingPort = "TCP transport requires the ``port'' parameter." - badPort x = TL.concat ["Invalid socket port for TCP transport: ", x] - getPort = case Map.lookup "port" params of - Nothing -> E.throwIO $ BadParameters a missingPort - Just x -> case P.parse parseWord16 "" (TL.unpack x) of - Right x' -> return $ NS.PortNum x' - Left _ -> E.throwIO $ BadParameters a $ badPort x - -@ Parsing the port is a bit complicated; assuming every character is an ASCII -digit, the port is converted to an {\tt Integer} and confirmed valid. -{\tt PortNumber} is expected to be in big-endian byte order, so the parsed -value must be converted from host order using {\tt Data.Binary}. - -<>= -import qualified Text.Parsec as P -import Control.Monad (unless) -import Data.Binary.Get (runGet, getWord16host) -import Data.Binary.Put (runPut, putWord16be) - -<>= - parseWord16 = do - chars <- P.many1 P.digit - P.eof - let value = read chars :: Integer - unless (value > 0 && value <= 65535) $ - P.parserFail "bad port" >> return () - let word = fromIntegral value - return $ runGet getWord16host (runPut (putWord16be word)) - -<>= - getAddresses family = do - let hints = NS.defaultHints - { NS.addrFlags = [NS.AI_ADDRCONFIG] - , NS.addrFamily = family - , NS.addrSocketType = NS.Stream - } - NS.getAddrInfo (Just hints) (Just hostname) Nothing - -@ The {\tt SockAddr} values returned from {\tt getAddrInfo} don't have any -port set, so it must be manually changed to whatever was in the {\tt port} -option. - -<>= - setPort port (NS.SockAddrInet _ x) = NS.SockAddrInet port x - setPort port (NS.SockAddrInet6 _ x y z) = NS.SockAddrInet6 port x y z - setPort _ addr = addr - -@ {\tt getAddrInfo} returns multiple addresses; each one is tried in turn, -until a valid address is found. If none are found, or are usable, an -exception will be thrown. - -<>= - openSocket _ [] = E.throwIO $ NoWorkingAddress [a] - openSocket port (addr:addrs) = E.catch (openSocket' port addr) $ - \(E.SomeException _) -> openSocket port addrs - openSocket' port addr = do - sock <- NS.socket (NS.addrFamily addr) - (NS.addrSocketType addr) - (NS.addrProtocol addr) - NS.connect sock . setPort port . NS.addrAddress $ addr - return sock - -@ \subsubsection{Generic handle-based transport} - -Both UNIX and TCP are backed by standard handles, and can therefore use -a shared handle-based transport backend. - -<>= -import qualified System.IO as I - -<>= -handleTransport :: I.Handle -> IO Transport -handleTransport h = do - I.hSetBuffering h I.NoBuffering - I.hSetBinaryMode h True - return $ Transport (L.hPut h) (L.hGet h . fromIntegral) (I.hClose h) - -@ \subsection{Errors} - -If connecting to D-Bus fails, a {\tt ConnectionError} will be thrown. -The constructor describes which exception occurred. - -<>= -import qualified Control.Exception as E -import Data.Typeable (Typeable) - -<>= -data ConnectionError - = InvalidAddress Text - | BadParameters A.Address Text - | UnknownMethod A.Address - | NoWorkingAddress [A.Address] - deriving (Show, Typeable) - -instance E.Exception ConnectionError - -<>= -, ConnectionError (..) - -@ \subsection{Establishing a connection} - -A connection can be opened to any valid address, though actually connecting -might fail due to external factors. - -<>= -import qualified DBus.Authentication as Auth - -<>= -<> -connect :: Auth.Mechanism -> A.Address -> IO Connection -connect mechanism a = do - t <- connectTransport a - let getByte = L.head `fmap` transportRecv t 1 - uuid <- Auth.authenticate mechanism (transportSend t) getByte - readLock <- C.newMVar () - serialMVar <- C.newMVar M.firstSerial - return $ Connection a t serialMVar readLock uuid - -@ Since addresses usually come in a list, it's sensible to have a variant -of {\tt connect} which tries multiple addresses. The first successfully -opened {\tt Connection} is returned. - -<>= -<> -connectFirst :: [(Auth.Mechanism, A.Address)] -> IO Connection -connectFirst orig = connectFirst' orig where - allAddrs = [a | (_, a) <- orig] - connectFirst' [] = E.throwIO $ NoWorkingAddress allAddrs - connectFirst' ((mech, a):as) = E.catch (connect mech a) $ - \(E.SomeException _) -> connectFirst' as - -<>= -, connect -, connectFirst - -@ \subsection{Closing connections} - -<>= -<> -connectionClose :: Connection -> IO () -connectionClose = transportClose . connectionTransport - -<>= -, connectionClose - -@ \subsection{Authentication} - -Authentication is a bit iffy; currently, there's a one specified -authentication mechanism ({\tt DBUS\_COOKIE\_SHA1}), which I've never seen -in the wild. Everybody seems to use {\tt EXTERNAL}, described below. - -To support multiple modes more easily in the future, and for user-defined -authentication handling (eg, in proxy servers), authentication is handled by -a separate module. - -<>= -<> -<> -{-# LANGUAGE DeriveDataTypeable #-} -module DBus.Authentication - ( <> - ) where -<> -<> - -@ The authentication protocol is based on {\sc ascii} text, initiated by the -client. Commands and mechanisms are represented by a couple data types: - -<>= -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as ByteString -import qualified DBus.UUID as UUID - -<>= -type Command = Text -newtype Mechanism = Mechanism - { mechanismRun :: (Command -> IO Command) -> IO UUID.UUID - } - -<>= - Command -, Mechanism (..) - -@ If authentication fails, an exception will be raised. - -<>= -import Data.Typeable (Typeable) -import qualified Control.Exception as E - -<>= -data AuthenticationError - = AuthenticationError Text - deriving (Show, Typeable) - -instance E.Exception AuthenticationError - -<>= -, AuthenticationError (..) - -@ The process begins by the client sending a single {\sc nul} byte, followed -by exchanges of {\sc ascii} commands until authentication is complete. Which -commands are sent depends on the selected mechanism. - -<>= -import Data.Word (Word8) - -<>= -authenticate :: Mechanism -> (ByteString -> IO ()) -> IO Word8 - -> IO UUID.UUID -authenticate mech put getByte = do - put $ ByteString.singleton 0 - uuid <- mechanismRun mech (putCommand put getByte) - put "BEGIN\r\n" - return uuid - -<>= -, authenticate - -@ TODO: describe {\tt putCommand} here - -<>= -import Control.Monad (liftM) -import Data.Char (chr) -import Data.Text.Lazy.Encoding (encodeUtf8) -import DBus.Util (readUntil, dropEnd) - -<>= -putCommand :: Monad m => (ByteString -> m ()) -> m Word8 -> Command -> m Command -putCommand put get cmd = do - let getC = liftM (chr . fromIntegral) get - put $ encodeUtf8 cmd - put "\r\n" - liftM (TL.pack . dropEnd 2) $ readUntil "\r\n" getC - -@ \subsubsection{Support authentication mechanisms} - -Currently, the only supported authentication mechanism is sending the local -user's ``real user ID''. - -<>= -, realUserID - -<>= -import System.Posix.User (getRealUserID) -import Data.Char (ord) -import Text.Printf (printf) - -<>= -realUserID :: Mechanism -realUserID = Mechanism $ \sendCmd -> do - uid <- getRealUserID - let token = concatMap (printf "%02X" . ord) (show uid) - let cmd = "AUTH EXTERNAL " ++ token - eitherUUID <- checkOK `fmap` sendCmd (TL.pack cmd) - case eitherUUID of - Right uuid -> return uuid - Left err -> E.throwIO $ AuthenticationError err - -@ If authentication was successful, the server responds with {\tt OK -}. - -<>= -import Data.Maybe (isJust) - -<>= -checkOK :: Command -> Either Text UUID.UUID -checkOK cmd = if validUUID then Right uuid else Left errorMsg where - validUUID = TL.isPrefixOf "OK " cmd && isJust maybeUUID - maybeUUID = UUID.fromHex $ TL.drop 3 cmd - Just uuid = maybeUUID - errorMsg = if TL.isPrefixOf "ERROR " cmd - then TL.drop 6 cmd - else TL.pack $ "Unexpected response: " ++ show cmd - -@ \subsection{Sending and receiving messages} - -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. - -<>= -import qualified DBus.Wire as W - -<>= -<> -send :: M.Message a => Connection -> (M.Serial -> IO b) -> a - -> IO (Either W.MarshalError b) -send (Connection _ t mvar _ _) io msg = withSerial mvar $ \serial -> - case W.marshalMessage W.LittleEndian serial msg of - Right bytes -> do - x <- io serial - transportSend t bytes - return $ Right x - Left err -> return $ Left err - -<>= -, send - -<>= -withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a -withSerial m io = E.block $ do - s <- C.takeMVar m - let s' = M.nextSerial s - x <- E.unblock (io s) `E.onException` C.putMVar m s' - C.putMVar m s' - return x - -@ Messages are received wrapped in a {\tt ReceivedMessage} value. If an -error is encountered while unmarshaling, an exception will be thrown. - -<>= -<> -receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage) -receive (Connection _ t _ lock _) = C.withMVar lock $ \_ -> - W.unmarshalMessage $ transportRecv t - -<>= -, receive - -@ -\section{The central bus} - -<>= -<> -<> -module DBus.Bus - ( getBus - , getFirstBus - , getSystemBus - , getSessionBus - , getStarterBus - ) where -<> - -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 DBus.Address as A -import qualified DBus.Authentication as Auth -import qualified DBus.Connection as C -import DBus.Constants (dbusName, dbusPath, dbusInterface) -import qualified DBus.Message as M -import qualified DBus.Types as T -import DBus.Util (fromRight) - -@ 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. - -<>= -busForConnection :: C.Connection -> IO (C.Connection, T.BusName) -busForConnection c = fmap ((,) c) $ sendHello c - -<>= -<> -getBus :: Auth.Mechanism -> A.Address -> IO (C.Connection, T.BusName) -getBus = ((busForConnection =<<) .) . C.connect - -@ Optionally, multiple addresses may be provided. The first successful -connection will be used. - -<>= -<> -getFirstBus :: [(Auth.Mechanism, A.Address)] -> IO (C.Connection, T.BusName) -getFirstBus = (busForConnection =<<) . C.connectFirst - -@ \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. - -<>= -<> -getSystemBus :: IO (C.Connection, T.BusName) -getSystemBus = getBus' $ fromEnv `E.catch` noEnv where - defaultAddr = "unix:path=/var/run/dbus/system_bus_socket" - fromEnv = getEnv "DBUS_SYSTEM_BUS_ADDRESS" - noEnv (E.SomeException _) = return defaultAddr - -<>= -<> -getSessionBus :: IO (C.Connection, T.BusName) -getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS" - -<>= -<> -getStarterBus :: IO (C.Connection, T.BusName) -getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS" - -<>= -getBus' :: IO String -> IO (C.Connection, T.BusName) -getBus' io = do - addr <- fmap TL.pack io - case A.mkAddresses addr of - Just [x] -> getBus Auth.realUserID x - Just xs -> getFirstBus [(Auth.realUserID,x) | x <- xs] - _ -> E.throwIO $ C.InvalidAddress addr - -@ \subsection{Sending the ``hello'' message} - -<>= -hello :: M.MethodCall -hello = M.MethodCall dbusPath - "Hello" - (Just dbusInterface) - (Just dbusName) - Set.empty - [] - -<>= -sendHello :: C.Connection -> IO T.BusName -sendHello c = do - serial <- fromRight `fmap` 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 $ E.AssertionFailed "Invalid response to Hello()" - - return . fromJust $ name - -<>= -waitForReply :: C.Connection -> M.Serial -> IO M.MethodReturn -waitForReply c serial = do - received <- C.receive c - msg <- case received of - Right x -> return x - Left _ -> E.throwIO $ E.AssertionFailed "Invalid response to Hello()" - case msg of - (M.ReceivedMethodReturn _ _ reply) -> - if M.methodReturnSerial reply == serial - then return reply - else waitForReply c serial - _ -> waitForReply c serial - -@ -\section{Introspection} - -@ D-Bus objects may be ``introspected'' to determine which methods, signals, -etc they support. Intospection data is sent over the bus in {\sc xml}, in -a mostly standardised but undocumented format. - -An XML introspection document looks like this: - -\begin{verbatim} - - - - - - - - - - - - - - - -\end{verbatim} - -<>= -<> -<> -module DBus.Introspection - ( Object (..) - , Interface (..) - , Method (..) - , Signal (..) - , Parameter (..) - , Property (..) - , PropertyAccess (..) - , toXML - , fromXML - ) where -<> -<> -import qualified DBus.Types as T - -@ HaXml is used to do the heavy lifting of XML parsing because HXT cannot -be combined with Parsec 3. - -<>= -import qualified Text.XML.HaXml as H - -@ \subsection{Data types} - -<>= -data Object = Object T.ObjectPath [Interface] [Object] - deriving (Show, Eq) - -data Interface = Interface T.InterfaceName [Method] [Signal] [Property] - deriving (Show, Eq) - -data Method = Method T.MemberName [Parameter] [Parameter] - deriving (Show, Eq) - -data Signal = Signal T.MemberName [Parameter] - deriving (Show, Eq) - -data Parameter = Parameter Text T.Signature - deriving (Show, Eq) - -data Property = Property Text T.Signature [PropertyAccess] - deriving (Show, Eq) - -data PropertyAccess = Read | Write - deriving (Show, Eq) - -@ \subsection{Parsing XML} - -The root {\tt node} is special, in that it's the only {\tt node} which is -not required to have a {\tt name} attribute. If the root has no {\tt name}, -its path will default to the path of the introspected object. - -If parsing fails, {\tt fromXML} will return {\tt Nothing}. Aside from the -elements directly accessed by the parser, no effort is made to check the -document's validity because there is no DTD as of yet. - -<>= -import Text.XML.HaXml.Parse (xmlParse') -import DBus.Util (eitherToMaybe) - -<>= -fromXML :: T.ObjectPath -> Text -> Maybe Object -fromXML path text = do - doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text - let (H.Document _ _ root _) = doc - parseRoot path root - -@ Even though the root object's {\tt name} is optional, if present, it must -still be a valid object path. - -<>= -parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object -parseRoot defaultPath e = do - path <- case getAttr "name" e of - Nothing -> Just defaultPath - Just x -> T.mkObjectPath x - parseObject' path e - -@ Child {\tt nodes} have ``relative'' paths -- that is, their {\tt name} -attribute is not a valid object path, but should be valid when appended to -the root object's path. - -<>= -parseChild :: T.ObjectPath -> H.Element a -> Maybe Object -parseChild parentPath e = do - let parentPath' = case T.strObjectPath parentPath of - "/" -> "/" - x -> TL.append x "/" - pathSegment <- getAttr "name" e - path <- T.mkObjectPath $ TL.append parentPath' pathSegment - parseObject' path e - -@ Other than the name, both root and non-root {\tt nodes} have identical -contents. They may contain interface definitions, and child {\tt node}s. - -<>= -parseObject' :: T.ObjectPath -> H.Element a -> Maybe Object -parseObject' path e@(H.Elem "node" _ _) = do - interfaces <- children parseInterface (H.tag "interface") e - children' <- children (parseChild path) (H.tag "node") e - return $ Object path interfaces children' -parseObject' _ _ = Nothing - -@ Interfaces may contain methods, signals, and properties. - -<>= -parseInterface :: H.Element a -> Maybe Interface -parseInterface e = do - name <- T.mkInterfaceName =<< getAttr "name" e - methods <- children parseMethod (H.tag "method") e - signals <- children parseSignal (H.tag "signal") e - properties <- children parseProperty (H.tag "property") e - return $ Interface name methods signals properties - -@ Methods contain a list of parameters, which default to ``in'' parameters -if no direction is specified. - -<>= -parseMethod :: H.Element a -> Maybe Method -parseMethod e = do - name <- T.mkMemberName =<< getAttr "name" e - paramsIn <- children parseParameter (isParam ["in", ""]) e - paramsOut <- children parseParameter (isParam ["out"]) e - return $ Method name paramsIn paramsOut - -@ Signals are similar to methods, except they have no ``in'' parameters. - -<>= -parseSignal :: H.Element a -> Maybe Signal -parseSignal e = do - name <- T.mkMemberName =<< getAttr "name" e - params <- children parseParameter (isParam ["out", ""]) e - return $ Signal name params - -@ A parameter has a free-form name, and a single valid type. - -<>= -parseParameter :: H.Element a -> Maybe Parameter -parseParameter e = do - let name = getAttr' "name" e - sig <- parseType e - return $ Parameter name sig - -<>= -parseType :: H.Element a -> Maybe T.Signature -parseType e = do - sig <- T.mkSignature =<< getAttr "type" e - case T.signatureTypes sig of - [_] -> Just sig - _ -> Nothing - -@ Properties are used by the {\tt org.freedesktop.DBus.Properties} interface. -Each property may be read, written, or both, and has an associated type. - -<>= -parseProperty :: H.Element a -> Maybe Property -parseProperty e = do - let name = getAttr' "name" e - sig <- parseType e - access <- case getAttr' "access" e of - "" -> Just [] - "read" -> Just [Read] - "write" -> Just [Write] - "readwrite" -> Just [Read, Write] - _ -> Nothing - return $ Property name sig access - -@ HaXml doesn't seem to have any way to retrieve the ``real'' value of an -attribute, so {\tt attrValue} implements this. - -<>= -import Data.Char (chr) - -<>= -attrValue :: H.AttValue -> Maybe Text -attrValue attr = fmap (TL.pack . concat) $ mapM unescape parts where - (H.AttValue parts) = attr - - unescape (Left x) = Just x - unescape (Right (H.RefEntity x)) = lookup x namedRefs - unescape (Right (H.RefChar x)) = Just [chr x] - - namedRefs = - [ ("lt", "<") - , ("gt", ">") - , ("amp", "&") - , ("apos", "'") - , ("quot", "\"") - ] - -@ Some helper functions for dealing with HaXml filters - -<>= -import Data.Maybe (fromMaybe) - -<>= -getAttr :: String -> H.Element a -> Maybe Text -getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue - -getAttr' :: String -> H.Element a -> Text -getAttr' = (fromMaybe "" .) . getAttr - -<>= -isParam :: [Text] -> H.CFilter a -isParam dirs content = do - arg@(H.CElem e _) <- H.tag "arg" content - let direction = getAttr' "direction" e - [arg | direction `elem` dirs] - -<>= -children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b] -children f filt (H.Elem _ _ contents) = - mapM f [x | (H.CElem x _) <- concatMap filt contents] - -@ \subsection{Generating XML} - -<>= -dtdPublicID, dtdSystemID :: String -dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN" -dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd" - -@ HaXml punts to the {\tt pretty} package for serialising XML. - -<>= -import Text.XML.HaXml.Pretty (document) -import Text.PrettyPrint.HughesPJ (render) - -@ Generating XML can fail; if a child object's path is not a sub-path of the -parent, {\tt toXML} will return {\tt Nothing}. - -<>= -toXML :: Object -> Maybe Text -toXML obj = fmap (TL.pack . render . document) doc where - prolog = H.Prolog Nothing [] (Just doctype) [] - doctype = H.DTD "node" (Just (H.PUBLIC - (H.PubidLiteral dtdPublicID) - (H.SystemLiteral dtdSystemID))) [] - doc = do - root <- xmlRoot obj - return $ H.Document prolog H.emptyST root [] - -@ When writing objects to {\tt node}s, the root object must have an absolute -path, and children must have paths relative to their parent. - -<>= -xmlRoot :: Object -> Maybe (H.Element a) -xmlRoot obj@(Object path _ _) = do - (H.CElem root _) <- xmlObject' (T.strObjectPath path) obj - return root - -<>= -xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a) -xmlObject parentPath obj@(Object path _ _) = do - let path' = T.strObjectPath path - parent' = T.strObjectPath parentPath - relpath <- if TL.isPrefixOf parent' path' - then Just $ if parent' == "/" - then TL.drop 1 path' - else TL.drop (TL.length parent' + 1) path' - else Nothing - xmlObject' relpath obj - -<>= -xmlObject' :: Text -> Object -> Maybe (H.Content a) -xmlObject' path (Object fullPath interfaces children') = do - children'' <- mapM (xmlObject fullPath) children' - return $ mkElement "node" - [mkAttr "name" $ TL.unpack path] - $ concat - [ map xmlInterface interfaces - , children'' - ] - -<>= -xmlInterface :: Interface -> H.Content a -xmlInterface (Interface name methods signals properties) = - mkElement "interface" - [mkAttr "name" . TL.unpack . T.strInterfaceName $ name] - $ concat - [ map xmlMethod methods - , map xmlSignal signals - , map xmlProperty properties - ] - -<>= -xmlMethod :: Method -> H.Content a -xmlMethod (Method name inParams outParams) = mkElement "method" - [mkAttr "name" . TL.unpack . T.strMemberName $ name] - $ concat - [ map (xmlParameter "in") inParams - , map (xmlParameter "out") outParams - ] - -<>= -xmlSignal :: Signal -> H.Content a -xmlSignal (Signal name params) = mkElement "signal" - [mkAttr "name" . TL.unpack . T.strMemberName $ name] - $ map (xmlParameter "out") params - -<>= -xmlParameter :: String -> Parameter -> H.Content a -xmlParameter direction (Parameter name sig) = mkElement "arg" - [ mkAttr "name" . TL.unpack $ name - , mkAttr "type" . TL.unpack . T.strSignature $ sig - , mkAttr "direction" direction - ] [] - -<>= -xmlProperty :: Property -> H.Content a -xmlProperty (Property name sig access) = mkElement "property" - [ mkAttr "name" . TL.unpack $ name - , mkAttr "type" . TL.unpack . T.strSignature $ sig - , mkAttr "access" $ xmlAccess access - ] [] - -<>= -xmlAccess :: [PropertyAccess] -> String -xmlAccess access = readS ++ writeS where - readS = if elem Read access then "read" else "" - writeS = if elem Write access then "write" else "" - -<>= -mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a -mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined - -<>= -mkAttr :: String -> String -> H.Attribute -mkAttr name value = (name, H.AttValue [Left escaped]) where - raw = H.CString True value () - escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw] - -@ -\section{Match rules} - -Match rules are used to indicate that the client is interested in messages -matching a particular filter. This module provides an interface for building -match rule strings. Eventually, it will support parsing them also. - -<>= -<> -<> -module DBus.MatchRule ( - MatchRule (..) - , MessageType (..) - , ParameterValue (..) - , formatRule - , addMatch - , matchAll - , matches - ) where -<> -import Data.Word (Word8) -import Data.Maybe (fromMaybe, mapMaybe) -import qualified Data.Set as Set -import qualified DBus.Types as T -import qualified DBus.Message as M -import qualified DBus.Constants as C -import DBus.Util (maybeIndex) - - -<>= --- | A match rule is a set of filters; most filters may have one possible --- value assigned, such as a single message type. The exception are parameter --- filters, which are limited in number only by the server implementation. --- -data MatchRule = MatchRule - { matchType :: Maybe MessageType - , matchSender :: Maybe T.BusName - , matchInterface :: Maybe T.InterfaceName - , matchMember :: Maybe T.MemberName - , matchPath :: Maybe T.ObjectPath - , matchDestination :: Maybe T.BusName - , matchParameters :: [ParameterValue] - } - deriving (Show) - -<>= --- | Parameters may match against two types, strings and object paths. It's --- probably an error to have two values for the same parameter. --- --- The constructor @StringValue 3 \"hello\"@ means that the fourth parameter --- in the message body must be the string @\"hello\"@. @PathValue@ is the --- same, but its value must be an object path. --- -data ParameterValue - = StringValue Word8 Text - | PathValue Word8 T.ObjectPath - deriving (Show, Eq) - -<>= --- | The set of allowed message types to filter on is separate from the set --- supported for sending over the wire. This allows the server to support --- additional types not yet implemented in the library, or vice-versa. --- -data MessageType - = MethodCall - | MethodReturn - | Signal - | Error - deriving (Show, Eq) - -@ There's currently only one operation to perform on match rules, and that's -to format them. - -<>= -<> -formatRule :: MatchRule -> Text -formatRule rule = TL.intercalate "," filters where - filters = structureFilters ++ parameterFilters - parameterFilters = map formatParameter $ matchParameters rule - structureFilters = mapMaybe unpack - [ ("type", fmap formatType . matchType) - , ("sender", fmap T.strBusName . matchSender) - , ("interface", fmap T.strInterfaceName . matchInterface) - , ("member", fmap T.strMemberName . matchMember) - , ("path", fmap T.strObjectPath . matchPath) - , ("destination", fmap T.strBusName . matchDestination) - ] - unpack (key, mkValue) = formatFilter' key `fmap` mkValue rule - -<>= -formatParameter :: ParameterValue -> Text -formatParameter (StringValue index x) = formatFilter' key x where - key = "arg" `TL.append` TL.pack (show index) -formatParameter (PathValue index x) = formatFilter' key value where - key = "arg" `TL.append` TL.pack (show index) `TL.append` "path" - value = T.strObjectPath x - -@ FIXME: what are the escaping rules for match rules? Other bindings don't -seem to perform any escaping at all. - -<>= -formatFilter' :: Text -> Text -> Text -formatFilter' key value = TL.concat [key, "='", value, "'"] - -<>= -formatType :: MessageType -> Text -formatType MethodCall = "method_call" -formatType MethodReturn = "method_return" -formatType Signal = "signal" -formatType Error = "error" - -@ And since the only real reason for formatting a match rule is to send it, -it's useful to have a message-building function pre-defined. - -<>= -<> -addMatch :: MatchRule -> M.MethodCall -addMatch rule = M.MethodCall - C.dbusPath - "AddMatch" - (Just C.dbusInterface) - (Just C.dbusName) - Set.empty - [T.toVariant $ formatRule rule] - -@ Most match rules will have only one or two fields filled in, so defining -an empty rule allows clients to set only the fields they care about. - -<>= -<> -matchAll :: MatchRule -matchAll = MatchRule - { matchType = Nothing - , matchSender = Nothing - , matchInterface = Nothing - , matchMember = Nothing - , matchPath = Nothing - , matchDestination = Nothing - , matchParameters = [] - } - -@ It's useful to match against a rule client-side, eg when listening for -signals. - -<>= -<> -matches :: MatchRule -> M.ReceivedMessage -> Bool -matches rule msg = and . mapMaybe ($ rule) $ - [ fmap (typeMatches msg) . matchType - , fmap (senderMatches msg) . matchSender - , fmap (ifaceMatches msg) . matchInterface - , fmap (memberMatches msg) . matchMember - , fmap (pathMatches msg) . matchPath - , fmap (destMatches msg) . matchDestination - , Just . parametersMatch msg . matchParameters - ] - -<>= -typeMatches :: M.ReceivedMessage -> MessageType -> Bool -typeMatches (M.ReceivedMethodCall _ _ _) MethodCall = True -typeMatches (M.ReceivedMethodReturn _ _ _) MethodReturn = True -typeMatches (M.ReceivedSignal _ _ _) Signal = True -typeMatches (M.ReceivedError _ _ _) Error = True -typeMatches _ _ = False - - -<>= -senderMatches :: M.ReceivedMessage -> T.BusName -> Bool -senderMatches msg name = M.receivedSender msg == Just name - -<>= -ifaceMatches :: M.ReceivedMessage -> T.InterfaceName -> Bool -ifaceMatches (M.ReceivedMethodCall _ _ msg) name = - Just name == M.methodCallInterface msg -ifaceMatches (M.ReceivedSignal _ _ msg) name = - name == M.signalInterface msg -ifaceMatches _ _ = False - -<>= -memberMatches :: M.ReceivedMessage -> T.MemberName -> Bool -memberMatches (M.ReceivedMethodCall _ _ msg) name = - name == M.methodCallMember msg -memberMatches (M.ReceivedSignal _ _ msg) name = - name == M.signalMember msg -memberMatches _ _ = False - -<>= -pathMatches :: M.ReceivedMessage -> T.ObjectPath -> Bool -pathMatches (M.ReceivedMethodCall _ _ msg) path = - path == M.methodCallPath msg -pathMatches (M.ReceivedSignal _ _ msg) path = - path == M.signalPath msg -pathMatches _ _ = False - -<>= -destMatches :: M.ReceivedMessage -> T.BusName -> Bool -destMatches (M.ReceivedMethodCall _ _ msg) name = - Just name == M.methodCallDestination msg -destMatches (M.ReceivedMethodReturn _ _ msg) name = - Just name == M.methodReturnDestination msg -destMatches (M.ReceivedError _ _ msg) name = - Just name == M.errorDestination msg -destMatches (M.ReceivedSignal _ _ msg) name = - Just name == M.signalDestination msg -destMatches _ _ = False - -<>= -parametersMatch :: M.ReceivedMessage -> [ParameterValue] -> Bool -parametersMatch _ [] = True -parametersMatch msg values = all validParam values where - body = M.receivedBody msg - validParam (StringValue idx x) = validParam' idx x - validParam (PathValue idx x) = validParam' idx x - validParam' idx x = fromMaybe False $ do - var <- maybeIndex body $ fromIntegral idx - fmap (== x) $ T.fromVariant var - -@ -\section{Name reservation} - -The central bus allows clients to register a well-known bus name, which -enables other clients to connect with or start a particular application. - -<>= -<> -{-# LANGUAGE OverloadedStrings #-} -module DBus.NameReservation - ( RequestNameFlag (..) - , RequestNameReply (..) - , ReleaseNameReply (..) - , requestName - , releaseName - , mkRequestNameReply - , mkReleaseNameReply - ) where -import Data.Word (Word32) -import Data.Bits ((.|.)) -import qualified Data.Set as Set -import qualified DBus.Types as T -import qualified DBus.Message as M -import qualified DBus.Constants as C -import DBus.Util (maybeIndex) - -<>= -data RequestNameFlag - = AllowReplacement - | ReplaceExisting - | DoNotQueue - deriving (Show) - -<>= -encodeFlags :: [RequestNameFlag] -> Word32 -encodeFlags = foldr (.|.) 0 . map flagValue where - flagValue AllowReplacement = 0x1 - flagValue ReplaceExisting = 0x2 - flagValue DoNotQueue = 0x4 - -@ There are only two methods of interest here, {\tt RequestName} and -{\tt ReleaseName}. - -<>= -<> -requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall -requestName name flags = M.MethodCall - { M.methodCallPath = C.dbusPath - , M.methodCallInterface = Just C.dbusInterface - , M.methodCallDestination = Just C.dbusName - , M.methodCallFlags = Set.empty - , M.methodCallMember = "RequestName" - , M.methodCallBody = - [ T.toVariant name - , T.toVariant . encodeFlags $ flags] - } - -<>= -data RequestNameReply - = PrimaryOwner - | InQueue - | Exists - | AlreadyOwner - deriving (Show) - -<>= -mkRequestNameReply :: M.MethodReturn -> Maybe RequestNameReply -mkRequestNameReply msg = - maybeIndex (M.messageBody msg) 0 >>= - T.fromVariant >>= - decodeRequestReply - -<>= -decodeRequestReply :: Word32 -> Maybe RequestNameReply -decodeRequestReply 1 = Just PrimaryOwner -decodeRequestReply 2 = Just InQueue -decodeRequestReply 3 = Just Exists -decodeRequestReply 4 = Just AlreadyOwner -decodeRequestReply _ = Nothing - -<>= -<> -releaseName :: T.BusName -> M.MethodCall -releaseName name = M.MethodCall - { M.methodCallPath = C.dbusPath - , M.methodCallInterface = Just C.dbusInterface - , M.methodCallDestination = Just C.dbusName - , M.methodCallFlags = Set.empty - , M.methodCallMember = "ReleaseName" - , M.methodCallBody = [T.toVariant name] - } - -<>= -data ReleaseNameReply - = Released - | NonExistent - | NotOwner - deriving (Show) - -<>= -mkReleaseNameReply :: M.MethodReturn -> Maybe ReleaseNameReply -mkReleaseNameReply msg = - maybeIndex (M.messageBody msg) 0 >>= - T.fromVariant >>= - decodeReleaseReply - -<>= -decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply -decodeReleaseReply 1 = Just Released -decodeReleaseReply 2 = Just NonExistent -decodeReleaseReply 3 = Just NotOwner -decodeReleaseReply _ = Nothing - -@ -\section{Constants} - -<>= -<> -{-# LANGUAGE OverloadedStrings #-} -module DBus.Constants where -import qualified DBus.Types as T -import Data.Word (Word8, Word32) - -<>= -protocolVersion :: Word8 -protocolVersion = 1 - -messageMaximumLength :: Word32 -messageMaximumLength = 134217728 - -arrayMaximumLength :: Word32 -arrayMaximumLength = 67108864 - -@ \subsection{The message bus} - -<>= -dbusName :: T.BusName -dbusName = "org.freedesktop.DBus" - -dbusPath :: T.ObjectPath -dbusPath = "/org/freedesktop/DBus" - -dbusInterface :: T.InterfaceName -dbusInterface = "org.freedesktop.DBus" - -@ \subsection{Pre-defined interfaces} - -<>= -interfaceIntrospectable :: T.InterfaceName -interfaceIntrospectable = "org.freedesktop.DBus.Introspectable" - -interfaceProperties :: T.InterfaceName -interfaceProperties = "org.freedesktop.DBus.Properties" - -interfacePeer :: T.InterfaceName -interfacePeer = "org.freedesktop.DBus.Peer" - -@ \subsection{Pre-defined error names} - -<>= -errorFailed :: T.ErrorName -errorFailed = "org.freedesktop.DBus.Error.Failed" - -errorNoMemory :: T.ErrorName -errorNoMemory = "org.freedesktop.DBus.Error.NoMemory" - -errorServiceUnknown :: T.ErrorName -errorServiceUnknown = "org.freedesktop.DBus.Error.ServiceUnknown" - -errorNameHasNoOwner :: T.ErrorName -errorNameHasNoOwner = "org.freedesktop.DBus.Error.NameHasNoOwner" - -errorNoReply :: T.ErrorName -errorNoReply = "org.freedesktop.DBus.Error.NoReply" - -errorIOError :: T.ErrorName -errorIOError = "org.freedesktop.DBus.Error.IOError" - -errorBadAddress :: T.ErrorName -errorBadAddress = "org.freedesktop.DBus.Error.BadAddress" - -errorNotSupported :: T.ErrorName -errorNotSupported = "org.freedesktop.DBus.Error.NotSupported" - -errorLimitsExceeded :: T.ErrorName -errorLimitsExceeded = "org.freedesktop.DBus.Error.LimitsExceeded" - -errorAccessDenied :: T.ErrorName -errorAccessDenied = "org.freedesktop.DBus.Error.AccessDenied" - -errorAuthFailed :: T.ErrorName -errorAuthFailed = "org.freedesktop.DBus.Error.AuthFailed" - -errorNoServer :: T.ErrorName -errorNoServer = "org.freedesktop.DBus.Error.NoServer" - -errorTimeout :: T.ErrorName -errorTimeout = "org.freedesktop.DBus.Error.Timeout" - -errorNoNetwork :: T.ErrorName -errorNoNetwork = "org.freedesktop.DBus.Error.NoNetwork" - -errorAddressInUse :: T.ErrorName -errorAddressInUse = "org.freedesktop.DBus.Error.AddressInUse" - -errorDisconnected :: T.ErrorName -errorDisconnected = "org.freedesktop.DBus.Error.Disconnected" - -errorInvalidArgs :: T.ErrorName -errorInvalidArgs = "org.freedesktop.DBus.Error.InvalidArgs" - -errorFileNotFound :: T.ErrorName -errorFileNotFound = "org.freedesktop.DBus.Error.FileNotFound" - -errorFileExists :: T.ErrorName -errorFileExists = "org.freedesktop.DBus.Error.FileExists" - -errorUnknownMethod :: T.ErrorName -errorUnknownMethod = "org.freedesktop.DBus.Error.UnknownMethod" - -errorTimedOut :: T.ErrorName -errorTimedOut = "org.freedesktop.DBus.Error.TimedOut" - -errorMatchRuleNotFound :: T.ErrorName -errorMatchRuleNotFound = "org.freedesktop.DBus.Error.MatchRuleNotFound" - -errorMatchRuleInvalid :: T.ErrorName -errorMatchRuleInvalid = "org.freedesktop.DBus.Error.MatchRuleInvalid" - -errorSpawnExecFailed :: T.ErrorName -errorSpawnExecFailed = "org.freedesktop.DBus.Error.Spawn.ExecFailed" - -errorSpawnForkFailed :: T.ErrorName -errorSpawnForkFailed = "org.freedesktop.DBus.Error.Spawn.ForkFailed" - -errorSpawnChildExited :: T.ErrorName -errorSpawnChildExited = "org.freedesktop.DBus.Error.Spawn.ChildExited" - -errorSpawnChildSignaled :: T.ErrorName -errorSpawnChildSignaled = "org.freedesktop.DBus.Error.Spawn.ChildSignaled" - -errorSpawnFailed :: T.ErrorName -errorSpawnFailed = "org.freedesktop.DBus.Error.Spawn.Failed" - -errorSpawnFailedToSetup :: T.ErrorName -errorSpawnFailedToSetup = "org.freedesktop.DBus.Error.Spawn.FailedToSetup" - -errorSpawnConfigInvalid :: T.ErrorName -errorSpawnConfigInvalid = "org.freedesktop.DBus.Error.Spawn.ConfigInvalid" - -errorSpawnServiceNotValid :: T.ErrorName -errorSpawnServiceNotValid = "org.freedesktop.DBus.Error.Spawn.ServiceNotValid" - -errorSpawnServiceNotFound :: T.ErrorName -errorSpawnServiceNotFound = "org.freedesktop.DBus.Error.Spawn.ServiceNotFound" - -errorSpawnPermissionsInvalid :: T.ErrorName -errorSpawnPermissionsInvalid = "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid" - -errorSpawnFileInvalid :: T.ErrorName -errorSpawnFileInvalid = "org.freedesktop.DBus.Error.Spawn.FileInvalid" - -errorSpawnNoMemory :: T.ErrorName -errorSpawnNoMemory = "org.freedesktop.DBus.Error.Spawn.NoMemory" - -errorUnixProcessIdUnknown :: T.ErrorName -errorUnixProcessIdUnknown = "org.freedesktop.DBus.Error.UnixProcessIdUnknown" - -errorInvalidFileContent :: T.ErrorName -errorInvalidFileContent = "org.freedesktop.DBus.Error.InvalidFileContent" - -errorSELinuxSecurityContextUnknown :: T.ErrorName -errorSELinuxSecurityContextUnknown = "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown" - -errorAdtAuditDataUnknown :: T.ErrorName -errorAdtAuditDataUnknown = "org.freedesktop.DBus.Error.AdtAuditDataUnknown" - -errorObjectPathInUse :: T.ErrorName -errorObjectPathInUse = "org.freedesktop.DBus.Error.ObjectPathInUse" - -errorInconsistentMessage :: T.ErrorName -errorInconsistentMessage = "org.freedesktop.DBus.Error.InconsistentMessage" - -@ -\section{UUIDs} - -D-Bus {\sc uuid}s are 128-bit unique identifiers, used for server instances -and machine {\sc id}s. They are not compatible with {\sc rfc4122}. - -<>= -<> -module DBus.UUID - ( UUID - , toHex - , fromHex - ) where -<> - -newtype UUID = UUID Text -- TODO: (Word64, Word64)? - deriving (Eq) - -instance Show UUID where - showsPrec d uuid = showParen (d > 10) $ - showString "UUID " . shows (toHex uuid) - -toHex :: UUID -> Text -toHex (UUID text) = text - -fromHex :: Text -> Maybe UUID -fromHex text = if validUUID text - then Just $ UUID text - else Nothing - -validUUID :: Text -> Bool -validUUID text = valid where - valid = and [TL.length text == 32, TL.all validChar text] - validChar c = or - [ c >= '0' && c <= '9' - , c >= 'a' && c <= 'f' - , c >= 'A' && c <= 'F' - ] - -@ -\section{Misc. utility functions} - -<>= -<> -module DBus.Util where -import Text.Parsec (Parsec, parse) -import Data.Char (digitToInt) -import Data.List (isPrefixOf) - -checkLength :: Int -> String -> Maybe String -checkLength length' s | length s <= length' = Just s -checkLength _ _ = Nothing - -parseMaybe :: Parsec String () a -> String -> Maybe a -parseMaybe p = either (const Nothing) Just . parse p "" - -mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b -mkUnsafe label f x = case f x of - Just x' -> x' - Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x - -hexToInt :: String -> Int -hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt - -eitherToMaybe :: Either a b -> Maybe b -eitherToMaybe (Left _) = Nothing -eitherToMaybe (Right x) = Just x - -fromRight :: Either a b -> b -fromRight (Right x) = x -fromRight _ = error "DBus.Util.fromRight: Left" - -maybeIndex :: [a] -> Int -> Maybe a -maybeIndex (x:_ ) 0 = Just x -maybeIndex (_:xs) n | n > 0 = maybeIndex xs (n - 1) -maybeIndex _ _ = Nothing - --- | Read values from a monad until a guard value is read; return all --- values, including the guard. --- -readUntil :: (Monad m, Eq a) => [a] -> m a -> m [a] -readUntil guard getx = readUntil' [] where - guard' = reverse guard - step xs | isPrefixOf guard' xs = return . reverse $ xs - | otherwise = readUntil' xs - readUntil' xs = do - x <- getx - step $ x:xs - --- | Drop /n/ items from the end of a list -dropEnd :: Int -> [a] -> [a] -dropEnd n xs = take (length xs - n) xs - -@ -\section{Bundled MonadError variant} - -The default {\tt ErrorT} and {\tt MonadError} classes in the -{\tt transformers} package have an idiotic dependency on the {\tt Error} -class, which is used to implement the obsolete {\tt fail} function. This -module is a variant, which doesn't include this dependency. - -<>= -<> -{-# LANGUAGE TypeFamilies #-} -module DBus.Util.MonadError where -import Control.Monad.Trans.Class -import Control.Monad.State - -newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } - -instance Functor m => Functor (ErrorT e m) where - fmap f = ErrorT . fmap (fmap f) . runErrorT - -instance Monad m => Monad (ErrorT e m) where - return = ErrorT . return . Right - (>>=) m k = ErrorT $ do - x <- runErrorT m - case x of - Left l -> return $ Left l - Right r -> runErrorT $ k r - -instance MonadTrans (ErrorT e) where - lift = ErrorT . liftM Right - -class Monad m => MonadError m where - type ErrorType m - throwError :: ErrorType m -> m a - catchError :: m a -> (ErrorType m -> m a) -> m a - -instance Monad m => MonadError (ErrorT e m) where - type ErrorType (ErrorT e m) = e - throwError = ErrorT . return . Left - catchError m h = ErrorT $ do - x <- runErrorT m - case x of - Left l -> runErrorT $ h l - Right r -> return $ Right r - -instance MonadState m => MonadState (ErrorT e m) where - type StateType (ErrorT e m) = StateType m - get = lift get - put = lift . put - -@ -\section{Haddock API documentation} - -The \LaTeX{} documentation is great for somebody reading the source code -or trying to fix an error, but it's not useful for people who just want -to add D-Bus support to their applications. These documentation sections -will be included in Haddock output for public functions. - -There's no real order to this section; it exists only because Haddock -can't merge documentation from external files. - -<>= --- | \"Atomic\" types are any which can't contain any other types. Only --- atomic types may be used as dictionary keys. - -<>= --- | Every type has an associated type code; a textual representation of --- the type, useful for debugging. - -<>= --- | 'Variant's may contain any other built-in D-Bus value. Besides --- representing native @VARIANT@ values, they allow type-safe storage and --- deconstruction of heterogeneous collections. - -<>= --- | Every variant is strongly-typed; that is, the type of its contained --- value is known at all times. This function retrieves that type, so that --- the correct cast can be used to retrieve the value. - -<>= --- | This is the type contained within the array, not the type of the array --- itself. - -<>= --- | A 'Connection' is an opaque handle to an open D-Bus channel, with an --- internal state for maintaining the current message serial. - -<>= --- | A 'Transport' is anything which can send and receive bytestrings, --- typically via a socket. - -<>= --- | Open a connection to some address, using a given authentication --- mechanism. If the connection fails, a 'ConnectionError' will be thrown. - -<>= --- | Try to open a connection to various addresses, returning the first --- connection which could be successfully opened. - -<>= --- | Close an open connection. Once closed, the 'Connection' is no longer --- valid and must not be used. - -<>= --- | Send a single message, with a generated 'M.Serial'. The second parameter --- exists to prevent race conditions when registering a reply handler; it --- receives the serial the message /will/ be sent with, before it's actually --- sent. --- --- Only one message may be sent at a time; if multiple threads attempt to --- send messages in parallel, one will block until after the other has --- finished. - -<>= --- | Receive the next message from the connection, blocking until one is --- available. --- --- Only one message may be received at a time; if multiple threads attempt --- to receive messages in parallel, one will block until after the other has --- finished. - -<>= --- | Similar to 'C.connect', but additionally sends @Hello@ messages to the --- central bus. - -<>= --- | Similar to 'C.connectFirst', but additionally sends @Hello@ messages to --- the central bus. - -<>= --- | Connect to the bus specified in the environment variable --- @DBUS_SYSTEM_BUS_ADDRESS@, or to --- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@ --- is not set. - -<>= --- | Connect to the bus specified in the environment variable --- @DBUS_SESSION_BUS_ADDRESS@, which must be set. - -<>= --- | Connect to the bus specified in the environment variable --- @DBUS_STARTER_ADDRESS@, which must be set. - -<>= --- | Format a 'MatchRule' as the bus expects to receive in a call to --- @AddMatch@. - -<>= --- | Build a 'M.MethodCall' for adding a match rule to the bus. - -<>= --- | An empty match rule, which matches everything. - -<>= --- | Whether a 'M.ReceivedMessage' matches a given rule. This is useful --- for implementing signal handlers. - -<>= --- | Build a 'M.MethodCall' for requesting a registered bus name. - -<>= --- | Build a 'M.MethodCall' for releasing a registered bus name. - -<>= --- | A value used to uniquely identify a particular message within a session. --- 'Serial's are 32-bit unsigned integers, and eventually wrap. - -<>= --- | Not an actual message type, but a wrapper around messages received from --- the bus. Each value contains the message's 'Serial' and possibly the --- origin's 'T.BusName' - -<>= --- | Convert a 'M.Message' into a 'L.ByteString'. Although unusual, it is --- possible for marshaling to fail -- if this occurs, an appropriate error --- will be returned instead. - -<>= --- | Read bytes from a monad until a complete message has been received. - -@ \end{document} diff --git a/hs/DBus/Address.hs b/hs/DBus/Address.hs --- a/hs/DBus/Address.hs +++ b/hs/DBus/Address.hs @@ -1,32 +1,41 @@ -{- - 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 . --} +#line 19 "src/addresses.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 20 "src/addresses.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} +#line 21 "src/addresses.anansi" module DBus.Address - ( Address - , addressMethod - , addressParameters - , mkAddresses - , strAddress - ) where + ( Address + , addressMethod + , addressParameters + , mkAddresses + , strAddress + ) where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 29 "src/addresses.anansi" import Data.Char (ord, chr) import qualified Data.Map as M @@ -35,48 +44,51 @@ import Text.Parsec ((<|>)) import DBus.Util (hexToInt, eitherToMaybe) +#line 74 "src/addresses.anansi" optionallyEncoded :: [Char] optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." +#line 82 "src/addresses.anansi" data Address = Address - { addressMethod :: Text - , addressParameters :: M.Map Text Text - } deriving (Eq) + { addressMethod :: Text + , addressParameters :: M.Map Text Text + } deriving (Eq) instance Show Address where - showsPrec d x = showParen (d> 10) $ - showString "Address " . shows (strAddress x) + showsPrec d x = showParen (d> 10) $ + showString "Address " . shows (strAddress x) +#line 97 "src/addresses.anansi" mkAddresses :: Text -> Maybe [Address] mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where - address = do - method <- P.many (P.noneOf ":;") - P.char ':' - params <- P.sepEndBy param (P.char ',') - return $ Address (TL.pack method) (M.fromList params) - - param = do - key <- P.many1 (P.noneOf "=;,") - P.char '=' - value <- P.many1 (encodedValue <|> unencodedValue) - return (TL.pack key, TL.pack value) - - parser = do - as <- P.sepEndBy1 address (P.char ';') - P.eof - return as - - unencodedValue = P.oneOf optionallyEncoded - encodedValue = do - P.char '%' - hex <- P.count 2 P.hexDigit - return . chr . hexToInt $ hex + address = do + method <- P.many (P.noneOf ":;") + P.char ':' + params <- P.sepEndBy param (P.char ',') + return $ Address (TL.pack method) (M.fromList params) + + param = do + key <- P.many1 (P.noneOf "=;,") + P.char '=' + value <- P.many1 (encodedValue <|> unencodedValue) + return (TL.pack key, TL.pack value) + + parser = do + as <- P.sepEndBy1 address (P.char ';') + P.eof + return as + + unencodedValue = P.oneOf optionallyEncoded + encodedValue = do + P.char '%' + hex <- P.count 2 P.hexDigit + return . chr . hexToInt $ hex +#line 128 "src/addresses.anansi" strAddress :: Address -> Text strAddress (Address t ps) = TL.concat [t, ":", ps'] where - ps' = TL.intercalate "," $ do - (k, v) <- M.toList ps - return $ TL.concat [k, "=", TL.concatMap encode v] - encode c | elem c optionallyEncoded = TL.singleton c - | otherwise = TL.pack $ printf "%%%02X" (ord c) - + ps' = TL.intercalate "," $ do + (k, v) <- M.toList ps + return $ TL.concat [k, "=", TL.concatMap encode v] + encode c | elem c optionallyEncoded = TL.singleton c + | otherwise = TL.pack $ printf "%%%02X" (ord c) diff --git a/hs/DBus/Authentication.hs b/hs/DBus/Authentication.hs --- a/hs/DBus/Authentication.hs +++ b/hs/DBus/Authentication.hs @@ -1,100 +1,116 @@ -{- - 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 OverloadedStrings #-} +#line 27 "src/authentication.anansi" -{-# LANGUAGE DeriveDataTypeable #-} -module DBus.Authentication - ( Command - , Mechanism (..) +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . - , AuthenticationError (..) +#line 28 "src/authentication.anansi" - , authenticate +#line 52 "src/introduction.anansi" +{-# LANGUAGE OverloadedStrings #-} - , realUserID +#line 29 "src/authentication.anansi" +{-# LANGUAGE DeriveDataTypeable #-} +module DBus.Authentication + ( Command + , Mechanism (..) + , AuthenticationError (..) + , authenticate + , realUserID + ) where - ) where +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 38 "src/authentication.anansi" + +#line 45 "src/authentication.anansi" import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as ByteString import qualified DBus.UUID as UUID +#line 60 "src/authentication.anansi" import Data.Typeable (Typeable) import qualified Control.Exception as E +#line 77 "src/authentication.anansi" import Data.Word (Word8) +#line 93 "src/authentication.anansi" import Control.Monad (liftM) import Data.Char (chr) import Data.Text.Lazy.Encoding (encodeUtf8) import DBus.Util (readUntil, dropEnd) +#line 114 "src/authentication.anansi" import System.Posix.User (getRealUserID) import Data.Char (ord) import Text.Printf (printf) +#line 135 "src/authentication.anansi" import Data.Maybe (isJust) - +#line 51 "src/authentication.anansi" type Command = Text newtype Mechanism = Mechanism - { mechanismRun :: (Command -> IO Command) -> IO UUID.UUID - } + { mechanismRun :: (Command -> IO Command) -> IO UUID.UUID + } +#line 65 "src/authentication.anansi" data AuthenticationError - = AuthenticationError Text - deriving (Show, Typeable) + = AuthenticationError Text + deriving (Show, Typeable) instance E.Exception AuthenticationError +#line 81 "src/authentication.anansi" authenticate :: Mechanism -> (ByteString -> IO ()) -> IO Word8 -> IO UUID.UUID authenticate mech put getByte = do - put $ ByteString.singleton 0 - uuid <- mechanismRun mech (putCommand put getByte) - put "BEGIN\r\n" - return uuid + put $ ByteString.singleton 0 + uuid <- mechanismRun mech (putCommand put getByte) + put "BEGIN\r\n" + return uuid +#line 100 "src/authentication.anansi" putCommand :: Monad m => (ByteString -> m ()) -> m Word8 -> Command -> m Command putCommand put get cmd = do - let getC = liftM (chr . fromIntegral) get - put $ encodeUtf8 cmd - put "\r\n" - liftM (TL.pack . dropEnd 2) $ readUntil "\r\n" getC + let getC = liftM (chr . fromIntegral) get + put $ encodeUtf8 cmd + put "\r\n" + liftM (TL.pack . dropEnd 2) $ readUntil "\r\n" getC +#line 120 "src/authentication.anansi" realUserID :: Mechanism realUserID = Mechanism $ \sendCmd -> do - uid <- getRealUserID - let token = concatMap (printf "%02X" . ord) (show uid) - let cmd = "AUTH EXTERNAL " ++ token - eitherUUID <- checkOK `fmap` sendCmd (TL.pack cmd) - case eitherUUID of - Right uuid -> return uuid - Left err -> E.throwIO $ AuthenticationError err + uid <- getRealUserID + let token = concatMap (printf "%02X" . ord) (show uid) + let cmd = "AUTH EXTERNAL " ++ token + eitherUUID <- checkOK `fmap` sendCmd (TL.pack cmd) + case eitherUUID of + Right uuid -> return uuid + Left err -> E.throwIO $ AuthenticationError err +#line 139 "src/authentication.anansi" checkOK :: Command -> Either Text UUID.UUID checkOK cmd = if validUUID then Right uuid else Left errorMsg where - validUUID = TL.isPrefixOf "OK " cmd && isJust maybeUUID - maybeUUID = UUID.fromHex $ TL.drop 3 cmd - Just uuid = maybeUUID - errorMsg = if TL.isPrefixOf "ERROR " cmd - then TL.drop 6 cmd - else TL.pack $ "Unexpected response: " ++ show cmd - + validUUID = TL.isPrefixOf "OK " cmd && isJust maybeUUID + maybeUUID = UUID.fromHex $ TL.drop 3 cmd + Just uuid = maybeUUID + errorMsg = if TL.isPrefixOf "ERROR " cmd + then TL.drop 6 cmd + else TL.pack $ "Unexpected response: " ++ show cmd diff --git a/hs/DBus/Bus.hs b/hs/DBus/Bus.hs --- a/hs/DBus/Bus.hs +++ b/hs/DBus/Bus.hs @@ -1,32 +1,41 @@ -{- - 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 . --} +#line 19 "src/bus.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 20 "src/bus.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} +#line 21 "src/bus.anansi" module DBus.Bus - ( getBus - , getFirstBus - , getSystemBus - , getSessionBus - , getStarterBus - ) where + ( getBus + , getFirstBus + , getSystemBus + , getSessionBus + , getStarterBus + ) where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 29 "src/bus.anansi" import qualified Control.Exception as E import Control.Monad (when) @@ -42,83 +51,104 @@ import qualified DBus.Types as T import DBus.Util (fromRight) +#line 50 "src/bus.anansi" busForConnection :: C.Connection -> IO (C.Connection, T.BusName) busForConnection c = fmap ((,) c) $ sendHello c + +#line 99 "src/api-docs.anansi" -- | Similar to 'C.connect', but additionally sends @Hello@ messages to the -- central bus. +#line 54 "src/bus.anansi" getBus :: Auth.Mechanism -> A.Address -> IO (C.Connection, T.BusName) getBus = ((busForConnection =<<) .) . C.connect +#line 62 "src/bus.anansi" + +#line 104 "src/api-docs.anansi" -- | Similar to 'C.connectFirst', but additionally sends @Hello@ messages to -- the central bus. +#line 63 "src/bus.anansi" getFirstBus :: [(Auth.Mechanism, A.Address)] -> IO (C.Connection, T.BusName) getFirstBus = (busForConnection =<<) . C.connectFirst +#line 74 "src/bus.anansi" + +#line 109 "src/api-docs.anansi" -- | Connect to the bus specified in the environment variable -- @DBUS_SYSTEM_BUS_ADDRESS@, or to -- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@ -- is not set. +#line 75 "src/bus.anansi" getSystemBus :: IO (C.Connection, T.BusName) getSystemBus = getBus' $ fromEnv `E.catch` noEnv where - defaultAddr = "unix:path=/var/run/dbus/system_bus_socket" - fromEnv = getEnv "DBUS_SYSTEM_BUS_ADDRESS" - noEnv (E.SomeException _) = return defaultAddr + defaultAddr = "unix:path=/var/run/dbus/system_bus_socket" + fromEnv = getEnv "DBUS_SYSTEM_BUS_ADDRESS" + noEnv (E.SomeException _) = return defaultAddr + +#line 116 "src/api-docs.anansi" -- | Connect to the bus specified in the environment variable -- @DBUS_SESSION_BUS_ADDRESS@, which must be set. +#line 82 "src/bus.anansi" getSessionBus :: IO (C.Connection, T.BusName) getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS" + +#line 121 "src/api-docs.anansi" -- | Connect to the bus specified in the environment variable -- @DBUS_STARTER_ADDRESS@, which must be set. +#line 86 "src/bus.anansi" getStarterBus :: IO (C.Connection, T.BusName) getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS" +#line 91 "src/bus.anansi" getBus' :: IO String -> IO (C.Connection, T.BusName) getBus' io = do - addr <- fmap TL.pack io - case A.mkAddresses addr of - Just [x] -> getBus Auth.realUserID x - Just xs -> getFirstBus [(Auth.realUserID,x) | x <- xs] - _ -> E.throwIO $ C.InvalidAddress addr + addr <- fmap TL.pack io + case A.mkAddresses addr of + Just [x] -> getBus Auth.realUserID x + Just xs -> getFirstBus [(Auth.realUserID,x) | x <- xs] + _ -> E.throwIO $ C.InvalidAddress addr +#line 103 "src/bus.anansi" hello :: M.MethodCall hello = M.MethodCall dbusPath - "Hello" - (Just dbusInterface) - (Just dbusName) - Set.empty - [] + "Hello" + (Just dbusInterface) + (Just dbusName) + Set.empty + [] +#line 113 "src/bus.anansi" sendHello :: C.Connection -> IO T.BusName sendHello c = do - serial <- fromRight `fmap` 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 $ E.AssertionFailed "Invalid response to Hello()" - - return . fromJust $ name + serial <- fromRight `fmap` 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 $ E.AssertionFailed "Invalid response to Hello()" + + return . fromJust $ name +#line 128 "src/bus.anansi" waitForReply :: C.Connection -> M.Serial -> IO M.MethodReturn waitForReply c serial = do - received <- C.receive c - msg <- case received of - Right x -> return x - Left _ -> E.throwIO $ E.AssertionFailed "Invalid response to Hello()" - case msg of - (M.ReceivedMethodReturn _ _ reply) -> - if M.methodReturnSerial reply == serial - then return reply - else waitForReply c serial - _ -> waitForReply c serial - + received <- C.receive c + msg <- case received of + Right x -> return x + Left _ -> E.throwIO $ E.AssertionFailed "Invalid response to Hello()" + case msg of + (M.ReceivedMethodReturn _ _ reply) -> + if M.methodReturnSerial reply == serial + then return reply + else waitForReply c serial + _ -> waitForReply c serial diff --git a/hs/DBus/Connection.hs b/hs/DBus/Connection.hs --- a/hs/DBus/Connection.hs +++ b/hs/DBus/Connection.hs @@ -1,219 +1,278 @@ -{- - 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 . --} +#line 19 "src/connections.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 20 "src/connections.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} +#line 21 "src/connections.anansi" {-# LANGUAGE DeriveDataTypeable #-} -module DBus.Connection - ( Connection - , connectionAddress - , connectionUUID +module DBus.Connection ( - , ConnectionError (..) +#line 53 "src/connections.anansi" + Connection + , connectionAddress + , connectionUUID - , connect - , connectFirst +#line 285 "src/connections.anansi" + , ConnectionError (..) - , connectionClose +#line 324 "src/connections.anansi" + , connect + , connectFirst - , send +#line 337 "src/connections.anansi" + , connectionClose - , receive +#line 367 "src/connections.anansi" + , send - ) where +#line 391 "src/connections.anansi" + , receive + +#line 24 "src/connections.anansi" + ) where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 26 "src/connections.anansi" + +#line 36 "src/connections.anansi" import qualified Control.Concurrent as C import qualified DBus.Address as A import qualified DBus.Message as M import qualified DBus.UUID as UUID +#line 75 "src/connections.anansi" import qualified Data.ByteString.Lazy as L import Data.Word (Word32) +#line 107 "src/connections.anansi" import qualified Network as N import qualified Data.Map as Map +#line 147 "src/connections.anansi" import qualified Network.Socket as NS +#line 193 "src/connections.anansi" import qualified Text.Parsec as P import Control.Monad (unless) import Data.Binary.Get (runGet, getWord16host) import Data.Binary.Put (runPut, putWord16be) +#line 252 "src/connections.anansi" import qualified System.IO as I +#line 269 "src/connections.anansi" import qualified Control.Exception as E import Data.Typeable (Typeable) +#line 294 "src/connections.anansi" import qualified DBus.Authentication as Auth +#line 350 "src/connections.anansi" import qualified DBus.Wire as W - +#line 43 "src/connections.anansi" data Connection = Connection - { connectionAddress :: A.Address - , connectionTransport :: Transport - , connectionSerialMVar :: C.MVar M.Serial - , connectionReadMVar :: C.MVar () - , connectionUUID :: UUID.UUID - } + { connectionAddress :: A.Address + , connectionTransport :: Transport + , connectionSerialMVar :: C.MVar M.Serial + , connectionReadMVar :: C.MVar () + , connectionUUID :: UUID.UUID + } +#line 62 "src/connections.anansi" instance Show Connection where - showsPrec d con = showParen (d > 10) strCon where - addr = A.strAddress $ connectionAddress con - strCon = s "" - s = showString + showsPrec d con = showParen (d > 10) strCon where + addr = A.strAddress $ connectionAddress con + strCon = s "" + s = showString +#line 80 "src/connections.anansi" + +#line 59 "src/api-docs.anansi" -- | A 'Transport' is anything which can send and receive bytestrings, -- typically via a socket. +#line 81 "src/connections.anansi" data Transport = Transport - { transportSend :: L.ByteString -> IO () - , transportRecv :: Word32 -> IO L.ByteString - , transportClose :: IO () - } + { transportSend :: L.ByteString -> IO () + , transportRecv :: Word32 -> IO L.ByteString + , transportClose :: IO () + } +#line 92 "src/connections.anansi" connectTransport :: A.Address -> IO Transport connectTransport a = transport' (A.addressMethod a) a where - transport' "unix" = unix - transport' "tcp" = tcp - transport' _ = E.throwIO . UnknownMethod + transport' "unix" = unix + transport' "tcp" = tcp + transport' _ = E.throwIO . UnknownMethod +#line 112 "src/connections.anansi" unix :: A.Address -> IO Transport unix a = port >>= N.connectTo "localhost" >>= handleTransport 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' transport." - 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 a tooMany - (Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew - (Just x, Nothing) -> return $ TL.unpack x - (Nothing, Just x) -> return $ '\x00' : TL.unpack x + 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' transport." + 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 a tooMany + (Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew + (Just x, Nothing) -> return $ TL.unpack x + (Nothing, Just x) -> return $ '\x00' : TL.unpack x +#line 151 "src/connections.anansi" tcp :: A.Address -> IO Transport tcp a = openHandle >>= handleTransport where - params = A.addressParameters a - openHandle = do - port <- getPort - family <- getFamily - addresses <- getAddresses family - socket <- openSocket port addresses - NS.socketToHandle socket I.ReadWriteMode + params = A.addressParameters a + openHandle = do + port <- getPort + family <- getFamily + addresses <- getAddresses family + socket <- openSocket port addresses + NS.socketToHandle socket I.ReadWriteMode - hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params +#line 165 "src/connections.anansi" + hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params - unknownFamily x = TL.concat ["Unknown socket family for TCP transport: ", x] - getFamily = case Map.lookup "family" params of - Just "ipv4" -> return NS.AF_INET - Just "ipv6" -> return NS.AF_INET6 - Nothing -> return NS.AF_UNSPEC - Just x -> E.throwIO $ BadParameters a $ unknownFamily x +#line 169 "src/connections.anansi" + unknownFamily x = TL.concat ["Unknown socket family for TCP transport: ", x] + getFamily = case Map.lookup "family" params of + Just "ipv4" -> return NS.AF_INET + Just "ipv6" -> return NS.AF_INET6 + Nothing -> return NS.AF_UNSPEC + Just x -> E.throwIO $ BadParameters a $ unknownFamily x - missingPort = "TCP transport requires the ``port'' parameter." - badPort x = TL.concat ["Invalid socket port for TCP transport: ", x] - getPort = case Map.lookup "port" params of - Nothing -> E.throwIO $ BadParameters a missingPort - Just x -> case P.parse parseWord16 "" (TL.unpack x) of - Right x' -> return $ NS.PortNum x' - Left _ -> E.throwIO $ BadParameters a $ badPort x +#line 178 "src/connections.anansi" + missingPort = "TCP transport requires the ``port'' parameter." + badPort x = TL.concat ["Invalid socket port for TCP transport: ", x] + getPort = case Map.lookup "port" params of + Nothing -> E.throwIO $ BadParameters a missingPort + Just x -> case P.parse parseWord16 "" (TL.unpack x) of + Right x' -> return $ NS.PortNum x' + Left _ -> E.throwIO $ BadParameters a $ badPort x - parseWord16 = do - chars <- P.many1 P.digit - P.eof - let value = read chars :: Integer - unless (value > 0 && value <= 65535) $ - P.parserFail "bad port" >> return () - let word = fromIntegral value - return $ runGet getWord16host (runPut (putWord16be word)) +#line 200 "src/connections.anansi" + parseWord16 = do + chars <- P.many1 P.digit + P.eof + let value = read chars :: Integer + unless (value > 0 && value <= 65535) $ + P.parserFail "bad port" >> return () + let word = fromIntegral value + return $ runGet getWord16host (runPut (putWord16be word)) - getAddresses family = do - let hints = NS.defaultHints - { NS.addrFlags = [NS.AI_ADDRCONFIG] - , NS.addrFamily = family - , NS.addrSocketType = NS.Stream - } - NS.getAddrInfo (Just hints) (Just hostname) Nothing +#line 211 "src/connections.anansi" + getAddresses family = do + let hints = NS.defaultHints + { NS.addrFlags = [NS.AI_ADDRCONFIG] + , NS.addrFamily = family + , NS.addrSocketType = NS.Stream + } + NS.getAddrInfo (Just hints) (Just hostname) Nothing - setPort port (NS.SockAddrInet _ x) = NS.SockAddrInet port x - setPort port (NS.SockAddrInet6 _ x y z) = NS.SockAddrInet6 port x y z - setPort _ addr = addr +#line 225 "src/connections.anansi" + setPort port (NS.SockAddrInet _ x) = NS.SockAddrInet port x + setPort port (NS.SockAddrInet6 _ x y z) = NS.SockAddrInet6 port x y z + setPort _ addr = addr - openSocket _ [] = E.throwIO $ NoWorkingAddress [a] - openSocket port (addr:addrs) = E.catch (openSocket' port addr) $ - \(E.SomeException _) -> openSocket port addrs - openSocket' port addr = do - sock <- NS.socket (NS.addrFamily addr) - (NS.addrSocketType addr) - (NS.addrProtocol addr) - NS.connect sock . setPort port . NS.addrAddress $ addr - return sock +#line 235 "src/connections.anansi" + openSocket _ [] = E.throwIO $ NoWorkingAddress [a] + openSocket port (addr:addrs) = E.catch (openSocket' port addr) $ + \(E.SomeException _) -> openSocket port addrs + openSocket' port addr = do + sock <- NS.socket (NS.addrFamily addr) + (NS.addrSocketType addr) + (NS.addrProtocol addr) + NS.connect sock . setPort port . NS.addrAddress $ addr + return sock +#line 256 "src/connections.anansi" handleTransport :: I.Handle -> IO Transport handleTransport h = do - I.hSetBuffering h I.NoBuffering - I.hSetBinaryMode h True - return $ Transport (L.hPut h) (L.hGet h . fromIntegral) (I.hClose h) + I.hSetBuffering h I.NoBuffering + I.hSetBinaryMode h True + return $ Transport (L.hPut h) (L.hGet h . fromIntegral) (I.hClose h) +#line 274 "src/connections.anansi" data ConnectionError - = InvalidAddress Text - | BadParameters A.Address Text - | UnknownMethod A.Address - | NoWorkingAddress [A.Address] - deriving (Show, Typeable) + = InvalidAddress Text + | BadParameters A.Address Text + | UnknownMethod A.Address + | NoWorkingAddress [A.Address] + deriving (Show, Typeable) instance E.Exception ConnectionError +#line 298 "src/connections.anansi" + +#line 64 "src/api-docs.anansi" -- | Open a connection to some address, using a given authentication -- mechanism. If the connection fails, a 'ConnectionError' will be thrown. +#line 299 "src/connections.anansi" connect :: Auth.Mechanism -> A.Address -> IO Connection connect mechanism a = do - t <- connectTransport a - let getByte = L.head `fmap` transportRecv t 1 - uuid <- Auth.authenticate mechanism (transportSend t) getByte - readLock <- C.newMVar () - serialMVar <- C.newMVar M.firstSerial - return $ Connection a t serialMVar readLock uuid + t <- connectTransport a + let getByte = L.head `fmap` transportRecv t 1 + uuid <- Auth.authenticate mechanism (transportSend t) getByte + readLock <- C.newMVar () + serialMVar <- C.newMVar M.firstSerial + return $ Connection a t serialMVar readLock uuid +#line 314 "src/connections.anansi" + +#line 69 "src/api-docs.anansi" -- | Try to open a connection to various addresses, returning the first -- connection which could be successfully opened. +#line 315 "src/connections.anansi" connectFirst :: [(Auth.Mechanism, A.Address)] -> IO Connection connectFirst orig = connectFirst' orig where - allAddrs = [a | (_, a) <- orig] - connectFirst' [] = E.throwIO $ NoWorkingAddress allAddrs - connectFirst' ((mech, a):as) = E.catch (connect mech a) $ - \(E.SomeException _) -> connectFirst' as + allAddrs = [a | (_, a) <- orig] + connectFirst' [] = E.throwIO $ NoWorkingAddress allAddrs + connectFirst' ((mech, a):as) = E.catch (connect mech a) $ + \(E.SomeException _) -> connectFirst' as +#line 331 "src/connections.anansi" + +#line 74 "src/api-docs.anansi" -- | Close an open connection. Once closed, the 'Connection' is no longer -- valid and must not be used. +#line 332 "src/connections.anansi" connectionClose :: Connection -> IO () connectionClose = transportClose . connectionTransport +#line 354 "src/connections.anansi" + +#line 79 "src/api-docs.anansi" -- | Send a single message, with a generated 'M.Serial'. The second parameter -- exists to prevent race conditions when registering a reply handler; it -- receives the serial the message /will/ be sent with, before it's actually @@ -223,24 +282,29 @@ -- send messages in parallel, one will block until after the other has -- finished. +#line 355 "src/connections.anansi" send :: M.Message a => Connection -> (M.Serial -> IO b) -> a -> IO (Either W.MarshalError b) send (Connection _ t mvar _ _) io msg = withSerial mvar $ \serial -> - case W.marshalMessage W.LittleEndian serial msg of - Right bytes -> do - x <- io serial - transportSend t bytes - return $ Right x - Left err -> return $ Left err + case W.marshalMessage W.LittleEndian serial msg of + Right bytes -> do + x <- io serial + transportSend t bytes + return $ Right x + Left err -> return $ Left err +#line 371 "src/connections.anansi" withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a withSerial m io = E.block $ do - s <- C.takeMVar m - let s' = M.nextSerial s - x <- E.unblock (io s) `E.onException` C.putMVar m s' - C.putMVar m s' - return x + s <- C.takeMVar m + let s' = M.nextSerial s + x <- E.unblock (io s) `E.onException` C.putMVar m s' + C.putMVar m s' + return x +#line 384 "src/connections.anansi" + +#line 90 "src/api-docs.anansi" -- | Receive the next message from the connection, blocking until one is -- available. -- @@ -248,7 +312,7 @@ -- to receive messages in parallel, one will block until after the other has -- finished. +#line 385 "src/connections.anansi" receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage) receive (Connection _ t _ lock _) = C.withMVar lock $ \_ -> - W.unmarshalMessage $ transportRecv t - + W.unmarshalMessage $ transportRecv t diff --git a/hs/DBus/Constants.hs b/hs/DBus/Constants.hs --- a/hs/DBus/Constants.hs +++ b/hs/DBus/Constants.hs @@ -1,20 +1,23 @@ -{- - 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 . --} +#line 19 "src/constants.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 20 "src/constants.anansi" {-# LANGUAGE OverloadedStrings #-} module DBus.Constants where import qualified DBus.Types as T @@ -29,6 +32,7 @@ arrayMaximumLength :: Word32 arrayMaximumLength = 67108864 +#line 38 "src/constants.anansi" dbusName :: T.BusName dbusName = "org.freedesktop.DBus" @@ -38,6 +42,7 @@ dbusInterface :: T.InterfaceName dbusInterface = "org.freedesktop.DBus" +#line 51 "src/constants.anansi" interfaceIntrospectable :: T.InterfaceName interfaceIntrospectable = "org.freedesktop.DBus.Introspectable" @@ -47,6 +52,7 @@ interfacePeer :: T.InterfaceName interfacePeer = "org.freedesktop.DBus.Peer" +#line 64 "src/constants.anansi" errorFailed :: T.ErrorName errorFailed = "org.freedesktop.DBus.Error.Failed" @@ -169,4 +175,3 @@ errorInconsistentMessage :: T.ErrorName errorInconsistentMessage = "org.freedesktop.DBus.Error.InconsistentMessage" - diff --git a/hs/DBus/Introspection.hs b/hs/DBus/Introspection.hs --- a/hs/DBus/Introspection.hs +++ b/hs/DBus/Introspection.hs @@ -1,162 +1,191 @@ -{- - 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 . --} +#line 44 "src/introspection.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 45 "src/introspection.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} +#line 46 "src/introspection.anansi" module DBus.Introspection - ( Object (..) - , Interface (..) - , Method (..) - , Signal (..) - , Parameter (..) - , Property (..) - , PropertyAccess (..) - , toXML - , fromXML - ) where + ( Object (..) + , Interface (..) + , Method (..) + , Signal (..) + , Parameter (..) + , Property (..) + , PropertyAccess (..) + , toXML + , fromXML + ) where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 58 "src/introspection.anansi" + +#line 66 "src/introspection.anansi" import qualified Text.XML.HaXml as H +#line 105 "src/introspection.anansi" import Text.XML.HaXml.Parse (xmlParse') import DBus.Util (eitherToMaybe) +#line 230 "src/introspection.anansi" import Data.Char (chr) +#line 254 "src/introspection.anansi" import Data.Maybe (fromMaybe) +#line 286 "src/introspection.anansi" import Text.XML.HaXml.Pretty (document) import Text.PrettyPrint.HughesPJ (render) +#line 59 "src/introspection.anansi" import qualified DBus.Types as T +#line 72 "src/introspection.anansi" data Object = Object T.ObjectPath [Interface] [Object] - deriving (Show, Eq) + deriving (Show, Eq) data Interface = Interface T.InterfaceName [Method] [Signal] [Property] - deriving (Show, Eq) + deriving (Show, Eq) data Method = Method T.MemberName [Parameter] [Parameter] - deriving (Show, Eq) + deriving (Show, Eq) data Signal = Signal T.MemberName [Parameter] - deriving (Show, Eq) + deriving (Show, Eq) data Parameter = Parameter Text T.Signature - deriving (Show, Eq) + deriving (Show, Eq) data Property = Property Text T.Signature [PropertyAccess] - deriving (Show, Eq) + deriving (Show, Eq) data PropertyAccess = Read | Write - deriving (Show, Eq) + deriving (Show, Eq) +#line 110 "src/introspection.anansi" fromXML :: T.ObjectPath -> Text -> Maybe Object fromXML path text = do - doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text - let (H.Document _ _ root _) = doc - parseRoot path root + doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text + let (H.Document _ _ root _) = doc + parseRoot path root +#line 121 "src/introspection.anansi" parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object parseRoot defaultPath e = do - path <- case getAttr "name" e of - Nothing -> Just defaultPath - Just x -> T.mkObjectPath x - parseObject' path e + path <- case getAttr "name" e of + Nothing -> Just defaultPath + Just x -> T.mkObjectPath x + parseObject' path e +#line 134 "src/introspection.anansi" parseChild :: T.ObjectPath -> H.Element a -> Maybe Object parseChild parentPath e = do - let parentPath' = case T.strObjectPath parentPath of - "/" -> "/" - x -> TL.append x "/" - pathSegment <- getAttr "name" e - path <- T.mkObjectPath $ TL.append parentPath' pathSegment - parseObject' path e + let parentPath' = case T.strObjectPath parentPath of + "/" -> "/" + x -> TL.append x "/" + pathSegment <- getAttr "name" e + path <- T.mkObjectPath $ TL.append parentPath' pathSegment + parseObject' path e +#line 148 "src/introspection.anansi" parseObject' :: T.ObjectPath -> H.Element a -> Maybe Object parseObject' path e@(H.Elem "node" _ _) = do - interfaces <- children parseInterface (H.tag "interface") e - children' <- children (parseChild path) (H.tag "node") e - return $ Object path interfaces children' + interfaces <- children parseInterface (H.tag "interface") e + children' <- children (parseChild path) (H.tag "node") e + return $ Object path interfaces children' parseObject' _ _ = Nothing +#line 159 "src/introspection.anansi" parseInterface :: H.Element a -> Maybe Interface parseInterface e = do - name <- T.mkInterfaceName =<< getAttr "name" e - methods <- children parseMethod (H.tag "method") e - signals <- children parseSignal (H.tag "signal") e - properties <- children parseProperty (H.tag "property") e - return $ Interface name methods signals properties + name <- T.mkInterfaceName =<< getAttr "name" e + methods <- children parseMethod (H.tag "method") e + signals <- children parseSignal (H.tag "signal") e + properties <- children parseProperty (H.tag "property") e + return $ Interface name methods signals properties +#line 172 "src/introspection.anansi" parseMethod :: H.Element a -> Maybe Method parseMethod e = do - name <- T.mkMemberName =<< getAttr "name" e - paramsIn <- children parseParameter (isParam ["in", ""]) e - paramsOut <- children parseParameter (isParam ["out"]) e - return $ Method name paramsIn paramsOut + name <- T.mkMemberName =<< getAttr "name" e + paramsIn <- children parseParameter (isParam ["in", ""]) e + paramsOut <- children parseParameter (isParam ["out"]) e + return $ Method name paramsIn paramsOut +#line 183 "src/introspection.anansi" parseSignal :: H.Element a -> Maybe Signal parseSignal e = do - name <- T.mkMemberName =<< getAttr "name" e - params <- children parseParameter (isParam ["out", ""]) e - return $ Signal name params + name <- T.mkMemberName =<< getAttr "name" e + params <- children parseParameter (isParam ["out", ""]) e + return $ Signal name params +#line 193 "src/introspection.anansi" parseParameter :: H.Element a -> Maybe Parameter parseParameter e = do - let name = getAttr' "name" e - sig <- parseType e - return $ Parameter name sig + let name = getAttr' "name" e + sig <- parseType e + return $ Parameter name sig +#line 201 "src/introspection.anansi" parseType :: H.Element a -> Maybe T.Signature parseType e = do - sig <- T.mkSignature =<< getAttr "type" e - case T.signatureTypes sig of - [_] -> Just sig - _ -> Nothing + sig <- T.mkSignature =<< getAttr "type" e + case T.signatureTypes sig of + [_] -> Just sig + _ -> Nothing +#line 213 "src/introspection.anansi" parseProperty :: H.Element a -> Maybe Property parseProperty e = do - let name = getAttr' "name" e - sig <- parseType e - access <- case getAttr' "access" e of - "" -> Just [] - "read" -> Just [Read] - "write" -> Just [Write] - "readwrite" -> Just [Read, Write] - _ -> Nothing - return $ Property name sig access + let name = getAttr' "name" e + sig <- parseType e + access <- case getAttr' "access" e of + "" -> Just [] + "read" -> Just [Read] + "write" -> Just [Write] + "readwrite" -> Just [Read, Write] + _ -> Nothing + return $ Property name sig access +#line 234 "src/introspection.anansi" attrValue :: H.AttValue -> Maybe Text attrValue attr = fmap (TL.pack . concat) $ mapM unescape parts where - (H.AttValue parts) = attr - - unescape (Left x) = Just x - unescape (Right (H.RefEntity x)) = lookup x namedRefs - unescape (Right (H.RefChar x)) = Just [chr x] - - namedRefs = - [ ("lt", "<") - , ("gt", ">") - , ("amp", "&") - , ("apos", "'") - , ("quot", "\"") - ] + (H.AttValue parts) = attr + + unescape (Left x) = Just x + unescape (Right (H.RefEntity x)) = lookup x namedRefs + unescape (Right (H.RefChar x)) = Just [chr x] + + namedRefs = + [ ("lt", "<") + , ("gt", ">") + , ("amp", "&") + , ("apos", "'") + , ("quot", "\"") + ] +#line 258 "src/introspection.anansi" getAttr :: String -> H.Element a -> Maybe Text getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue @@ -165,101 +194,112 @@ isParam :: [Text] -> H.CFilter a isParam dirs content = do - arg@(H.CElem e _) <- H.tag "arg" content - let direction = getAttr' "direction" e - [arg | direction `elem` dirs] + arg@(H.CElem e _) <- H.tag "arg" content + let direction = getAttr' "direction" e + [arg | direction `elem` dirs] children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b] children f filt (H.Elem _ _ contents) = - mapM f [x | (H.CElem x _) <- concatMap filt contents] + mapM f [x | (H.CElem x _) <- concatMap filt contents] +#line 278 "src/introspection.anansi" dtdPublicID, dtdSystemID :: String dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN" dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd" +#line 294 "src/introspection.anansi" toXML :: Object -> Maybe Text toXML obj = fmap (TL.pack . render . document) doc where - prolog = H.Prolog Nothing [] (Just doctype) [] - doctype = H.DTD "node" (Just (H.PUBLIC - (H.PubidLiteral dtdPublicID) - (H.SystemLiteral dtdSystemID))) [] - doc = do - root <- xmlRoot obj - return $ H.Document prolog H.emptyST root [] + prolog = H.Prolog Nothing [] (Just doctype) [] + doctype = H.DTD "node" (Just (H.PUBLIC + (H.PubidLiteral dtdPublicID) + (H.SystemLiteral dtdSystemID))) [] + doc = do + root <- xmlRoot obj + return $ H.Document prolog H.emptyST root [] +#line 309 "src/introspection.anansi" xmlRoot :: Object -> Maybe (H.Element a) xmlRoot obj@(Object path _ _) = do - (H.CElem root _) <- xmlObject' (T.strObjectPath path) obj - return root + (H.CElem root _) <- xmlObject' (T.strObjectPath path) obj + return root +#line 316 "src/introspection.anansi" xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a) xmlObject parentPath obj@(Object path _ _) = do - let path' = T.strObjectPath path - parent' = T.strObjectPath parentPath - relpath <- if TL.isPrefixOf parent' path' - then Just $ if parent' == "/" - then TL.drop 1 path' - else TL.drop (TL.length parent' + 1) path' - else Nothing - xmlObject' relpath obj + let path' = T.strObjectPath path + parent' = T.strObjectPath parentPath + relpath <- if TL.isPrefixOf parent' path' + then Just $ if parent' == "/" + then TL.drop 1 path' + else TL.drop (TL.length parent' + 1) path' + else Nothing + xmlObject' relpath obj +#line 329 "src/introspection.anansi" xmlObject' :: Text -> Object -> Maybe (H.Content a) xmlObject' path (Object fullPath interfaces children') = do - children'' <- mapM (xmlObject fullPath) children' - return $ mkElement "node" - [mkAttr "name" $ TL.unpack path] - $ concat - [ map xmlInterface interfaces - , children'' - ] + children'' <- mapM (xmlObject fullPath) children' + return $ mkElement "node" + [mkAttr "name" $ TL.unpack path] + $ concat + [ map xmlInterface interfaces + , children'' + ] +#line 341 "src/introspection.anansi" xmlInterface :: Interface -> H.Content a xmlInterface (Interface name methods signals properties) = - mkElement "interface" - [mkAttr "name" . TL.unpack . T.strInterfaceName $ name] - $ concat - [ map xmlMethod methods - , map xmlSignal signals - , map xmlProperty properties - ] + mkElement "interface" + [mkAttr "name" . TL.unpack . T.strInterfaceName $ name] + $ concat + [ map xmlMethod methods + , map xmlSignal signals + , map xmlProperty properties + ] +#line 353 "src/introspection.anansi" xmlMethod :: Method -> H.Content a xmlMethod (Method name inParams outParams) = mkElement "method" - [mkAttr "name" . TL.unpack . T.strMemberName $ name] - $ concat - [ map (xmlParameter "in") inParams - , map (xmlParameter "out") outParams - ] + [mkAttr "name" . TL.unpack . T.strMemberName $ name] + $ concat + [ map (xmlParameter "in") inParams + , map (xmlParameter "out") outParams + ] +#line 363 "src/introspection.anansi" xmlSignal :: Signal -> H.Content a xmlSignal (Signal name params) = mkElement "signal" - [mkAttr "name" . TL.unpack . T.strMemberName $ name] - $ map (xmlParameter "out") params + [mkAttr "name" . TL.unpack . T.strMemberName $ name] + $ map (xmlParameter "out") params +#line 370 "src/introspection.anansi" xmlParameter :: String -> Parameter -> H.Content a xmlParameter direction (Parameter name sig) = mkElement "arg" - [ mkAttr "name" . TL.unpack $ name - , mkAttr "type" . TL.unpack . T.strSignature $ sig - , mkAttr "direction" direction - ] [] + [ mkAttr "name" . TL.unpack $ name + , mkAttr "type" . TL.unpack . T.strSignature $ sig + , mkAttr "direction" direction + ] [] +#line 379 "src/introspection.anansi" xmlProperty :: Property -> H.Content a xmlProperty (Property name sig access) = mkElement "property" - [ mkAttr "name" . TL.unpack $ name - , mkAttr "type" . TL.unpack . T.strSignature $ sig - , mkAttr "access" $ xmlAccess access - ] [] + [ mkAttr "name" . TL.unpack $ name + , mkAttr "type" . TL.unpack . T.strSignature $ sig + , mkAttr "access" $ xmlAccess access + ] [] +#line 388 "src/introspection.anansi" xmlAccess :: [PropertyAccess] -> String xmlAccess access = readS ++ writeS where - readS = if elem Read access then "read" else "" - writeS = if elem Write access then "write" else "" + readS = if elem Read access then "read" else "" + writeS = if elem Write access then "write" else "" +#line 395 "src/introspection.anansi" mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined mkAttr :: String -> String -> H.Attribute mkAttr name value = (name, H.AttValue [Left escaped]) where - raw = H.CString True value () - escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw] - + raw = H.CString True value () + escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw] diff --git a/hs/DBus/MatchRule.hs b/hs/DBus/MatchRule.hs --- a/hs/DBus/MatchRule.hs +++ b/hs/DBus/MatchRule.hs @@ -1,34 +1,43 @@ -{- - 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 . --} +#line 23 "src/match-rules.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 24 "src/match-rules.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} +#line 25 "src/match-rules.anansi" module DBus.MatchRule ( - MatchRule (..) - , MessageType (..) - , ParameterValue (..) - , formatRule - , addMatch - , matchAll - , matches - ) where + MatchRule (..) + , MessageType (..) + , ParameterValue (..) + , formatRule + , addMatch + , matchAll + , matches + ) where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 35 "src/match-rules.anansi" import Data.Word (Word8) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set @@ -37,22 +46,23 @@ import qualified DBus.Constants as C import DBus.Util (maybeIndex) - +#line 45 "src/match-rules.anansi" -- | A match rule is a set of filters; most filters may have one possible -- value assigned, such as a single message type. The exception are parameter -- filters, which are limited in number only by the server implementation. -- data MatchRule = MatchRule - { matchType :: Maybe MessageType - , matchSender :: Maybe T.BusName - , matchInterface :: Maybe T.InterfaceName - , matchMember :: Maybe T.MemberName - , matchPath :: Maybe T.ObjectPath - , matchDestination :: Maybe T.BusName - , matchParameters :: [ParameterValue] - } - deriving (Show) + { matchType :: Maybe MessageType + , matchSender :: Maybe T.BusName + , matchInterface :: Maybe T.InterfaceName + , matchMember :: Maybe T.MemberName + , matchPath :: Maybe T.ObjectPath + , matchDestination :: Maybe T.BusName + , matchParameters :: [ParameterValue] + } + deriving (Show) +#line 62 "src/match-rules.anansi" -- | Parameters may match against two types, strings and object paths. It's -- probably an error to have two values for the same parameter. -- @@ -61,45 +71,52 @@ -- same, but its value must be an object path. -- data ParameterValue - = StringValue Word8 Text - | PathValue Word8 T.ObjectPath - deriving (Show, Eq) + = StringValue Word8 Text + | PathValue Word8 T.ObjectPath + deriving (Show, Eq) +#line 76 "src/match-rules.anansi" -- | The set of allowed message types to filter on is separate from the set -- supported for sending over the wire. This allows the server to support -- additional types not yet implemented in the library, or vice-versa. -- data MessageType - = MethodCall - | MethodReturn - | Signal - | Error - deriving (Show, Eq) + = MethodCall + | MethodReturn + | Signal + | Error + deriving (Show, Eq) +#line 92 "src/match-rules.anansi" + +#line 126 "src/api-docs.anansi" -- | Format a 'MatchRule' as the bus expects to receive in a call to -- @AddMatch@. +#line 93 "src/match-rules.anansi" formatRule :: MatchRule -> Text formatRule rule = TL.intercalate "," filters where - filters = structureFilters ++ parameterFilters - parameterFilters = map formatParameter $ matchParameters rule - structureFilters = mapMaybe unpack - [ ("type", fmap formatType . matchType) - , ("sender", fmap T.strBusName . matchSender) - , ("interface", fmap T.strInterfaceName . matchInterface) - , ("member", fmap T.strMemberName . matchMember) - , ("path", fmap T.strObjectPath . matchPath) - , ("destination", fmap T.strBusName . matchDestination) - ] - unpack (key, mkValue) = formatFilter' key `fmap` mkValue rule + filters = structureFilters ++ parameterFilters + parameterFilters = map formatParameter $ matchParameters rule + structureFilters = mapMaybe unpack + [ ("type", fmap formatType . matchType) + , ("sender", fmap T.strBusName . matchSender) + , ("interface", fmap T.strInterfaceName . matchInterface) + , ("member", fmap T.strMemberName . matchMember) + , ("path", fmap T.strObjectPath . matchPath) + , ("destination", fmap T.strBusName . matchDestination) + ] + unpack (key, mkValue) = formatFilter' key `fmap` mkValue rule +#line 109 "src/match-rules.anansi" formatParameter :: ParameterValue -> Text formatParameter (StringValue index x) = formatFilter' key x where - key = "arg" `TL.append` TL.pack (show index) + key = "arg" `TL.append` TL.pack (show index) formatParameter (PathValue index x) = formatFilter' key value where - key = "arg" `TL.append` TL.pack (show index) `TL.append` "path" - value = T.strObjectPath x + key = "arg" `TL.append` TL.pack (show index) `TL.append` "path" + value = T.strObjectPath x +#line 121 "src/match-rules.anansi" formatFilter' :: Text -> Text -> Text formatFilter' key value = TL.concat [key, "='", value, "'"] @@ -109,44 +126,57 @@ formatType Signal = "signal" formatType Error = "error" +#line 135 "src/match-rules.anansi" + +#line 131 "src/api-docs.anansi" -- | Build a 'M.MethodCall' for adding a match rule to the bus. +#line 136 "src/match-rules.anansi" addMatch :: MatchRule -> M.MethodCall addMatch rule = M.MethodCall - C.dbusPath - "AddMatch" - (Just C.dbusInterface) - (Just C.dbusName) - Set.empty - [T.toVariant $ formatRule rule] + C.dbusPath + "AddMatch" + (Just C.dbusInterface) + (Just C.dbusName) + Set.empty + [T.toVariant $ formatRule rule] +#line 150 "src/match-rules.anansi" + +#line 135 "src/api-docs.anansi" -- | An empty match rule, which matches everything. +#line 151 "src/match-rules.anansi" matchAll :: MatchRule matchAll = MatchRule - { matchType = Nothing - , matchSender = Nothing - , matchInterface = Nothing - , matchMember = Nothing - , matchPath = Nothing - , matchDestination = Nothing - , matchParameters = [] - } + { matchType = Nothing + , matchSender = Nothing + , matchInterface = Nothing + , matchMember = Nothing + , matchPath = Nothing + , matchDestination = Nothing + , matchParameters = [] + } +#line 167 "src/match-rules.anansi" + +#line 139 "src/api-docs.anansi" -- | Whether a 'M.ReceivedMessage' matches a given rule. This is useful -- for implementing signal handlers. +#line 168 "src/match-rules.anansi" matches :: MatchRule -> M.ReceivedMessage -> Bool matches rule msg = and . mapMaybe ($ rule) $ - [ fmap (typeMatches msg) . matchType - , fmap (senderMatches msg) . matchSender - , fmap (ifaceMatches msg) . matchInterface - , fmap (memberMatches msg) . matchMember - , fmap (pathMatches msg) . matchPath - , fmap (destMatches msg) . matchDestination - , Just . parametersMatch msg . matchParameters - ] + [ fmap (typeMatches msg) . matchType + , fmap (senderMatches msg) . matchSender + , fmap (ifaceMatches msg) . matchInterface + , fmap (memberMatches msg) . matchMember + , fmap (pathMatches msg) . matchPath + , fmap (destMatches msg) . matchDestination + , Just . parametersMatch msg . matchParameters + ] +#line 181 "src/match-rules.anansi" typeMatches :: M.ReceivedMessage -> MessageType -> Bool typeMatches (M.ReceivedMethodCall _ _ _) MethodCall = True typeMatches (M.ReceivedMethodReturn _ _ _) MethodReturn = True @@ -154,49 +184,53 @@ typeMatches (M.ReceivedError _ _ _) Error = True typeMatches _ _ = False - +#line 190 "src/match-rules.anansi" senderMatches :: M.ReceivedMessage -> T.BusName -> Bool senderMatches msg name = M.receivedSender msg == Just name +#line 195 "src/match-rules.anansi" ifaceMatches :: M.ReceivedMessage -> T.InterfaceName -> Bool ifaceMatches (M.ReceivedMethodCall _ _ msg) name = - Just name == M.methodCallInterface msg + Just name == M.methodCallInterface msg ifaceMatches (M.ReceivedSignal _ _ msg) name = - name == M.signalInterface msg + name == M.signalInterface msg ifaceMatches _ _ = False +#line 204 "src/match-rules.anansi" memberMatches :: M.ReceivedMessage -> T.MemberName -> Bool memberMatches (M.ReceivedMethodCall _ _ msg) name = - name == M.methodCallMember msg + name == M.methodCallMember msg memberMatches (M.ReceivedSignal _ _ msg) name = - name == M.signalMember msg + name == M.signalMember msg memberMatches _ _ = False +#line 213 "src/match-rules.anansi" pathMatches :: M.ReceivedMessage -> T.ObjectPath -> Bool pathMatches (M.ReceivedMethodCall _ _ msg) path = - path == M.methodCallPath msg + path == M.methodCallPath msg pathMatches (M.ReceivedSignal _ _ msg) path = - path == M.signalPath msg + path == M.signalPath msg pathMatches _ _ = False +#line 222 "src/match-rules.anansi" destMatches :: M.ReceivedMessage -> T.BusName -> Bool destMatches (M.ReceivedMethodCall _ _ msg) name = - Just name == M.methodCallDestination msg + Just name == M.methodCallDestination msg destMatches (M.ReceivedMethodReturn _ _ msg) name = - Just name == M.methodReturnDestination msg + Just name == M.methodReturnDestination msg destMatches (M.ReceivedError _ _ msg) name = - Just name == M.errorDestination msg + Just name == M.errorDestination msg destMatches (M.ReceivedSignal _ _ msg) name = - Just name == M.signalDestination msg + Just name == M.signalDestination msg destMatches _ _ = False +#line 235 "src/match-rules.anansi" parametersMatch :: M.ReceivedMessage -> [ParameterValue] -> Bool parametersMatch _ [] = True parametersMatch msg values = all validParam values where - body = M.receivedBody msg - validParam (StringValue idx x) = validParam' idx x - validParam (PathValue idx x) = validParam' idx x - validParam' idx x = fromMaybe False $ do - var <- maybeIndex body $ fromIntegral idx - fmap (== x) $ T.fromVariant var - + body = M.receivedBody msg + validParam (StringValue idx x) = validParam' idx x + validParam (PathValue idx x) = validParam' idx x + validParam' idx x = fromMaybe False $ do + var <- maybeIndex body $ fromIntegral idx + fmap (== x) $ T.fromVariant var diff --git a/hs/DBus/Message.hs b/hs/DBus/Message.hs --- a/hs/DBus/Message.hs +++ b/hs/DBus/Message.hs @@ -1,48 +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 DBus.Message - (Message ( messageFlags - , messageBody - ) +#line 23 "src/messages.anansi" - , Flag (..) +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . - , Serial - , serialValue - , firstSerial - , nextSerial +#line 24 "src/messages.anansi" +module DBus.Message ( - , MethodCall (..) +#line 51 "src/messages.anansi" + Message ( messageFlags + , messageBody + ) - , MethodReturn (..) +#line 69 "src/messages.anansi" + , Flag (..) - , Error (..) - , errorMessage +#line 124 "src/messages.anansi" + , Serial + , serialValue + , firstSerial + , nextSerial - , Signal (..) +#line 169 "src/messages.anansi" + , MethodCall (..) - , Unknown (..) +#line 206 "src/messages.anansi" + , MethodReturn (..) - , ReceivedMessage (..) - , receivedSerial - , receivedSender - , receivedBody +#line 256 "src/messages.anansi" + , Error (..) + , errorMessage - ) where -import DBus.Message.Internal +#line 296 "src/messages.anansi" + , Signal (..) +#line 327 "src/messages.anansi" + , Unknown (..) + +#line 377 "src/messages.anansi" + , ReceivedMessage (..) + , receivedSerial + , receivedSender + , receivedBody + +#line 26 "src/messages.anansi" + ) where +import DBus.Message.Internal diff --git a/hs/DBus/Message/Internal.hs b/hs/DBus/Message/Internal.hs --- a/hs/DBus/Message/Internal.hs +++ b/hs/DBus/Message/Internal.hs @@ -1,182 +1,211 @@ -{- - 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 . --} +#line 31 "src/messages.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 32 "src/messages.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} +#line 33 "src/messages.anansi" module DBus.Message.Internal where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 35 "src/messages.anansi" import qualified Data.Set as S import Data.Word (Word8, Word32) import Data.Maybe (fromMaybe) import qualified DBus.Types as T import DBus.Util (maybeIndex) +#line 43 "src/messages.anansi" class Message a where - messageTypeCode :: a -> Word8 - messageHeaderFields :: a -> [HeaderField] - messageFlags :: a -> S.Set Flag - messageBody :: a -> [T.Variant] + messageTypeCode :: a -> Word8 + messageHeaderFields :: a -> [HeaderField] + messageFlags :: a -> S.Set Flag + messageBody :: a -> [T.Variant] +#line 62 "src/messages.anansi" data Flag - = NoReplyExpected - | NoAutoStart - deriving (Show, Eq, Ord) + = NoReplyExpected + | NoAutoStart + deriving (Show, Eq, Ord) +#line 80 "src/messages.anansi" data HeaderField - = Path T.ObjectPath - | Interface T.InterfaceName - | Member T.MemberName - | ErrorName T.ErrorName - | ReplySerial Serial - | Destination T.BusName - | Sender T.BusName - | Signature T.Signature - deriving (Show, Eq) + = Path T.ObjectPath + | Interface T.InterfaceName + | Member T.MemberName + | ErrorName T.ErrorName + | ReplySerial Serial + | Destination T.BusName + | Sender T.BusName + | Signature T.Signature + deriving (Show, Eq) +#line 98 "src/messages.anansi" + +#line 152 "src/api-docs.anansi" -- | A value used to uniquely identify a particular message within a session. -- 'Serial's are 32-bit unsigned integers, and eventually wrap. +#line 99 "src/messages.anansi" newtype Serial = Serial { serialValue :: Word32 } - deriving (Eq, Ord) + deriving (Eq, Ord) instance Show Serial where - show (Serial x) = show x + show (Serial x) = show x instance T.Variable Serial where - toVariant (Serial x) = T.toVariant x - fromVariant = fmap Serial . T.fromVariant + toVariant (Serial x) = T.toVariant x + fromVariant = fmap Serial . T.fromVariant +#line 113 "src/messages.anansi" firstSerial :: Serial firstSerial = Serial 1 nextSerial :: Serial -> Serial nextSerial (Serial x) = Serial (x + 1) +#line 138 "src/messages.anansi" maybe' :: (a -> b) -> Maybe a -> [b] maybe' f = maybe [] (\x' -> [f x']) +#line 145 "src/messages.anansi" data MethodCall = MethodCall - { methodCallPath :: T.ObjectPath - , methodCallMember :: T.MemberName - , methodCallInterface :: Maybe T.InterfaceName - , methodCallDestination :: Maybe T.BusName - , methodCallFlags :: S.Set Flag - , methodCallBody :: [T.Variant] - } - deriving (Show, Eq) + { methodCallPath :: T.ObjectPath + , methodCallMember :: T.MemberName + , methodCallInterface :: Maybe T.InterfaceName + , methodCallDestination :: Maybe T.BusName + , methodCallFlags :: S.Set Flag + , methodCallBody :: [T.Variant] + } + deriving (Show, Eq) instance Message MethodCall where - messageTypeCode _ = 1 - messageFlags = methodCallFlags - messageBody = methodCallBody - messageHeaderFields m = concat - [ [ Path $ methodCallPath m - , Member $ methodCallMember m - ] - , maybe' Interface . methodCallInterface $ m - , maybe' Destination . methodCallDestination $ m - ] + messageTypeCode _ = 1 + messageFlags = methodCallFlags + messageBody = methodCallBody + messageHeaderFields m = concat + [ [ Path $ methodCallPath m + , Member $ methodCallMember m + ] + , maybe' Interface . methodCallInterface $ m + , maybe' Destination . methodCallDestination $ m + ] +#line 187 "src/messages.anansi" data MethodReturn = MethodReturn - { methodReturnSerial :: Serial - , methodReturnDestination :: Maybe T.BusName - , methodReturnBody :: [T.Variant] - } - deriving (Show, Eq) + { methodReturnSerial :: Serial + , methodReturnDestination :: Maybe T.BusName + , methodReturnBody :: [T.Variant] + } + deriving (Show, Eq) instance Message MethodReturn where - messageTypeCode _ = 2 - messageFlags _ = S.fromList [NoReplyExpected, NoAutoStart] - messageBody = methodReturnBody - messageHeaderFields m = concat - [ [ ReplySerial $ methodReturnSerial m - ] - , maybe' Destination . methodReturnDestination $ m - ] + messageTypeCode _ = 2 + messageFlags _ = S.fromList [NoReplyExpected, NoAutoStart] + messageBody = methodReturnBody + messageHeaderFields m = concat + [ [ ReplySerial $ methodReturnSerial m + ] + , maybe' Destination . methodReturnDestination $ m + ] +#line 221 "src/messages.anansi" data Error = Error - { errorName :: T.ErrorName - , errorSerial :: Serial - , errorDestination :: Maybe T.BusName - , errorBody :: [T.Variant] - } - deriving (Show, Eq) + { errorName :: T.ErrorName + , errorSerial :: Serial + , errorDestination :: Maybe T.BusName + , errorBody :: [T.Variant] + } + deriving (Show, Eq) instance Message Error where - messageTypeCode _ = 3 - messageFlags _ = S.fromList [NoReplyExpected, NoAutoStart] - messageBody = errorBody - messageHeaderFields m = concat - [ [ ErrorName $ errorName m - , ReplySerial $ errorSerial m - ] - , maybe' Destination . errorDestination $ m - ] + messageTypeCode _ = 3 + messageFlags _ = S.fromList [NoReplyExpected, NoAutoStart] + messageBody = errorBody + messageHeaderFields m = concat + [ [ ErrorName $ errorName m + , ReplySerial $ errorSerial m + ] + , maybe' Destination . errorDestination $ m + ] +#line 246 "src/messages.anansi" errorMessage :: Error -> Text errorMessage msg = fromMaybe "(no error message)" $ do - field <- maybeIndex (errorBody msg) 0 - text <- T.fromVariant field - if TL.null text - then Nothing - else return text + field <- maybeIndex (errorBody msg) 0 + text <- T.fromVariant field + if TL.null text + then Nothing + else return text +#line 273 "src/messages.anansi" data Signal = Signal - { signalPath :: T.ObjectPath - , signalMember :: T.MemberName - , signalInterface :: T.InterfaceName - , signalDestination :: Maybe T.BusName - , signalBody :: [T.Variant] - } - deriving (Show, Eq) + { signalPath :: T.ObjectPath + , signalMember :: T.MemberName + , signalInterface :: T.InterfaceName + , signalDestination :: Maybe T.BusName + , signalBody :: [T.Variant] + } + deriving (Show, Eq) instance Message Signal where - messageTypeCode _ = 4 - messageFlags _ = S.fromList [NoReplyExpected, NoAutoStart] - messageBody = signalBody - messageHeaderFields m = concat - [ [ Path $ signalPath m - , Member $ signalMember m - , Interface $ signalInterface m - ] - , maybe' Destination . signalDestination $ m - ] + messageTypeCode _ = 4 + messageFlags _ = S.fromList [NoReplyExpected, NoAutoStart] + messageBody = signalBody + messageHeaderFields m = concat + [ [ Path $ signalPath m + , Member $ signalMember m + , Interface $ signalInterface m + ] + , maybe' Destination . signalDestination $ m + ] +#line 318 "src/messages.anansi" data Unknown = Unknown - { unknownType :: Word8 - , unknownFlags :: S.Set Flag - , unknownBody :: [T.Variant] - } - deriving (Show, Eq) + { unknownType :: Word8 + , unknownFlags :: S.Set Flag + , unknownBody :: [T.Variant] + } + deriving (Show, Eq) +#line 339 "src/messages.anansi" + +#line 157 "src/api-docs.anansi" -- | Not an actual message type, but a wrapper around messages received from -- the bus. Each value contains the message's 'Serial' and possibly the -- origin's 'T.BusName' +#line 340 "src/messages.anansi" data ReceivedMessage - = ReceivedMethodCall Serial (Maybe T.BusName) MethodCall - | ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn - | ReceivedError Serial (Maybe T.BusName) Error - | ReceivedSignal Serial (Maybe T.BusName) Signal - | ReceivedUnknown Serial (Maybe T.BusName) Unknown - deriving (Show, Eq) + = ReceivedMethodCall Serial (Maybe T.BusName) MethodCall + | ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn + | ReceivedError Serial (Maybe T.BusName) Error + | ReceivedSignal Serial (Maybe T.BusName) Signal + | ReceivedUnknown Serial (Maybe T.BusName) Unknown + deriving (Show, Eq) +#line 350 "src/messages.anansi" receivedSerial :: ReceivedMessage -> Serial receivedSerial (ReceivedMethodCall s _ _) = s receivedSerial (ReceivedMethodReturn s _ _) = s @@ -184,6 +213,7 @@ receivedSerial (ReceivedSignal s _ _) = s receivedSerial (ReceivedUnknown s _ _) = s +#line 359 "src/messages.anansi" receivedSender :: ReceivedMessage -> Maybe T.BusName receivedSender (ReceivedMethodCall _ s _) = s receivedSender (ReceivedMethodReturn _ s _) = s @@ -191,10 +221,10 @@ receivedSender (ReceivedSignal _ s _) = s receivedSender (ReceivedUnknown _ s _) = s +#line 368 "src/messages.anansi" receivedBody :: ReceivedMessage -> [T.Variant] receivedBody (ReceivedMethodCall _ _ x) = messageBody x receivedBody (ReceivedMethodReturn _ _ x) = messageBody x receivedBody (ReceivedError _ _ x) = messageBody x receivedBody (ReceivedSignal _ _ x) = messageBody x receivedBody (ReceivedUnknown _ _ x) = unknownBody x - diff --git a/hs/DBus/NameReservation.hs b/hs/DBus/NameReservation.hs --- a/hs/DBus/NameReservation.hs +++ b/hs/DBus/NameReservation.hs @@ -1,30 +1,33 @@ -{- - 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 . --} +#line 22 "src/name-reservation.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 23 "src/name-reservation.anansi" {-# LANGUAGE OverloadedStrings #-} module DBus.NameReservation - ( RequestNameFlag (..) - , RequestNameReply (..) - , ReleaseNameReply (..) - , requestName - , releaseName - , mkRequestNameReply - , mkReleaseNameReply - ) where + ( RequestNameFlag (..) + , RequestNameReply (..) + , ReleaseNameReply (..) + , requestName + , releaseName + , mkRequestNameReply + , mkReleaseNameReply + ) where import Data.Word (Word32) import Data.Bits ((.|.)) import qualified Data.Set as Set @@ -33,45 +36,54 @@ import qualified DBus.Constants as C import DBus.Util (maybeIndex) +#line 43 "src/name-reservation.anansi" data RequestNameFlag - = AllowReplacement - | ReplaceExisting - | DoNotQueue - deriving (Show) + = AllowReplacement + | ReplaceExisting + | DoNotQueue + deriving (Show) +#line 51 "src/name-reservation.anansi" encodeFlags :: [RequestNameFlag] -> Word32 encodeFlags = foldr (.|.) 0 . map flagValue where - flagValue AllowReplacement = 0x1 - flagValue ReplaceExisting = 0x2 - flagValue DoNotQueue = 0x4 + flagValue AllowReplacement = 0x1 + flagValue ReplaceExisting = 0x2 + flagValue DoNotQueue = 0x4 +#line 62 "src/name-reservation.anansi" + +#line 144 "src/api-docs.anansi" -- | Build a 'M.MethodCall' for requesting a registered bus name. +#line 63 "src/name-reservation.anansi" requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall requestName name flags = M.MethodCall - { M.methodCallPath = C.dbusPath - , M.methodCallInterface = Just C.dbusInterface - , M.methodCallDestination = Just C.dbusName - , M.methodCallFlags = Set.empty - , M.methodCallMember = "RequestName" - , M.methodCallBody = - [ T.toVariant name - , T.toVariant . encodeFlags $ flags] - } + { M.methodCallPath = C.dbusPath + , M.methodCallInterface = Just C.dbusInterface + , M.methodCallDestination = Just C.dbusName + , M.methodCallFlags = Set.empty + , M.methodCallMember = "RequestName" + , M.methodCallBody = + [ T.toVariant name + , T.toVariant . encodeFlags $ flags] + } +#line 77 "src/name-reservation.anansi" data RequestNameReply - = PrimaryOwner - | InQueue - | Exists - | AlreadyOwner - deriving (Show) + = PrimaryOwner + | InQueue + | Exists + | AlreadyOwner + deriving (Show) +#line 86 "src/name-reservation.anansi" mkRequestNameReply :: M.MethodReturn -> Maybe RequestNameReply mkRequestNameReply msg = - maybeIndex (M.messageBody msg) 0 >>= - T.fromVariant >>= - decodeRequestReply + maybeIndex (M.messageBody msg) 0 >>= + T.fromVariant >>= + decodeRequestReply +#line 94 "src/name-reservation.anansi" decodeRequestReply :: Word32 -> Maybe RequestNameReply decodeRequestReply 1 = Just PrimaryOwner decodeRequestReply 2 = Just InQueue @@ -79,33 +91,39 @@ decodeRequestReply 4 = Just AlreadyOwner decodeRequestReply _ = Nothing +#line 103 "src/name-reservation.anansi" + +#line 148 "src/api-docs.anansi" -- | Build a 'M.MethodCall' for releasing a registered bus name. +#line 104 "src/name-reservation.anansi" releaseName :: T.BusName -> M.MethodCall releaseName name = M.MethodCall - { M.methodCallPath = C.dbusPath - , M.methodCallInterface = Just C.dbusInterface - , M.methodCallDestination = Just C.dbusName - , M.methodCallFlags = Set.empty - , M.methodCallMember = "ReleaseName" - , M.methodCallBody = [T.toVariant name] - } + { M.methodCallPath = C.dbusPath + , M.methodCallInterface = Just C.dbusInterface + , M.methodCallDestination = Just C.dbusName + , M.methodCallFlags = Set.empty + , M.methodCallMember = "ReleaseName" + , M.methodCallBody = [T.toVariant name] + } +#line 116 "src/name-reservation.anansi" data ReleaseNameReply - = Released - | NonExistent - | NotOwner - deriving (Show) + = Released + | NonExistent + | NotOwner + deriving (Show) +#line 124 "src/name-reservation.anansi" mkReleaseNameReply :: M.MethodReturn -> Maybe ReleaseNameReply mkReleaseNameReply msg = - maybeIndex (M.messageBody msg) 0 >>= - T.fromVariant >>= - decodeReleaseReply + maybeIndex (M.messageBody msg) 0 >>= + T.fromVariant >>= + decodeReleaseReply +#line 132 "src/name-reservation.anansi" decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply decodeReleaseReply 1 = Just Released decodeReleaseReply 2 = Just NonExistent decodeReleaseReply 3 = Just NotOwner decodeReleaseReply _ = Nothing - diff --git a/hs/DBus/Types.cpphs b/hs/DBus/Types.cpphs new file mode 100644 --- /dev/null +++ b/hs/DBus/Types.cpphs @@ -0,0 +1,704 @@ + +#line 22 "src/types.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 23 "src/types.anansi" + +#line 52 "src/introduction.anansi" +{-# LANGUAGE OverloadedStrings #-} + +#line 24 "src/types.anansi" + +#line 358 "src/types.anansi" +{-# LANGUAGE TypeSynonymInstances #-} + +#line 25 "src/types.anansi" +module DBus.Types ( + +#line 89 "src/types.anansi" + -- * Available types + Type (..) + , typeCode + +#line 165 "src/types.anansi" + -- * Variants + , Variant + , Variable (..) + +#line 234 "src/types.anansi" + , variantType + +#line 425 "src/types.anansi" + -- * Signatures + , Signature + , signatureTypes + , strSignature + +#line 601 "src/types.anansi" + , mkSignature + , mkSignature_ + +#line 658 "src/types.anansi" + -- * Object paths + , ObjectPath + , strObjectPath + , mkObjectPath + , mkObjectPath_ + +#line 713 "src/types.anansi" + -- * Arrays + , Array + , arrayType + , arrayItems + +#line 759 "src/types.anansi" + , toArray + , fromArray + , arrayFromItems + +#line 777 "src/types.anansi" + , arrayToBytes + , arrayFromBytes + +#line 846 "src/types.anansi" + -- * Dictionaries + , Dictionary + , dictionaryItems + , dictionaryKeyType + , dictionaryValueType + +#line 923 "src/types.anansi" + , toDictionary + , fromDictionary + , dictionaryFromItems + +#line 995 "src/types.anansi" + , dictionaryToArray + , arrayToDictionary + +#line 1011 "src/types.anansi" + -- * Structures + , Structure (..) + +#line 1052 "src/types.anansi" + -- * Names + +#line 1082 "src/types.anansi" + -- ** Bus names + , BusName + , strBusName + , mkBusName + , mkBusName_ + +#line 1135 "src/types.anansi" + -- ** Interface names + , InterfaceName + , strInterfaceName + , mkInterfaceName + , mkInterfaceName_ + +#line 1176 "src/types.anansi" + -- ** Error names + , ErrorName + , strErrorName + , mkErrorName + , mkErrorName_ + +#line 1212 "src/types.anansi" + -- ** Member names + , MemberName + , strMemberName + , mkMemberName + , mkMemberName_ + +#line 27 "src/types.anansi" + ) where + +#line 56 "src/introduction.anansi" +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL + +#line 29 "src/types.anansi" + +#line 311 "src/types.anansi" +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int16, Int32, Int64) + +#line 345 "src/types.anansi" +import qualified Data.Text as T + +#line 416 "src/types.anansi" +import Data.Ord (comparing) + +#line 517 "src/types.anansi" +import Text.Parsec ((<|>)) +import qualified Text.Parsec as P +import DBus.Util (checkLength, parseMaybe) + +#line 584 "src/types.anansi" +import DBus.Util (mkUnsafe) +import qualified Data.String as String + +#line 691 "src/types.anansi" +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as ByteString + +#line 791 "src/types.anansi" +import qualified Data.ByteString as StrictByteString + +#line 857 "src/types.anansi" +import Data.List (intercalate) + +#line 874 "src/types.anansi" +import Control.Monad (unless) + +#line 896 "src/types.anansi" +import Control.Arrow ((***)) +import qualified Data.Map as Map + +#line 908 "src/types.anansi" +import Control.Monad (forM) + +#line 41 "src/types.anansi" +data Type + = DBusBoolean + | DBusByte + | DBusInt16 + | DBusInt32 + | DBusInt64 + | DBusWord16 + | DBusWord32 + | DBusWord64 + | DBusDouble + | DBusString + | DBusSignature + | DBusObjectPath + | DBusVariant + | DBusArray Type + | DBusDictionary Type Type + | DBusStructure [Type] + deriving (Show, Eq) + +#line 62 "src/types.anansi" + +#line 27 "src/api-docs.anansi" +-- | \"Atomic\" types are any which can't contain any other types. Only +-- atomic types may be used as dictionary keys. + +#line 63 "src/types.anansi" +isAtomicType :: Type -> Bool +isAtomicType DBusBoolean = True +isAtomicType DBusByte = True +isAtomicType DBusInt16 = True +isAtomicType DBusInt32 = True +isAtomicType DBusInt64 = True +isAtomicType DBusWord16 = True +isAtomicType DBusWord32 = True +isAtomicType DBusWord64 = True +isAtomicType DBusDouble = True +isAtomicType DBusString = True +isAtomicType DBusSignature = True +isAtomicType DBusObjectPath = True +isAtomicType _ = False + +#line 83 "src/types.anansi" + +#line 32 "src/api-docs.anansi" +-- | Every type has an associated type code; a textual representation of +-- the type, useful for debugging. + +#line 84 "src/types.anansi" +typeCode :: Type -> Text + +#line 437 "src/types.anansi" +typeCode DBusBoolean = "b" +typeCode DBusByte = "y" +typeCode DBusInt16 = "n" +typeCode DBusInt32 = "i" +typeCode DBusInt64 = "x" +typeCode DBusWord16 = "q" +typeCode DBusWord32 = "u" +typeCode DBusWord64 = "t" +typeCode DBusDouble = "d" +typeCode DBusString = "s" +typeCode DBusSignature = "g" +typeCode DBusObjectPath = "o" +typeCode DBusVariant = "v" + +#line 456 "src/types.anansi" +typeCode (DBusArray t) = TL.cons 'a' $ typeCode t + +#line 463 "src/types.anansi" +typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"] + +#line 471 "src/types.anansi" +typeCode (DBusStructure ts) = TL.concat $ + ["("] ++ map typeCode ts ++ [")"] + +#line 139 "src/types.anansi" + +#line 37 "src/api-docs.anansi" +-- | 'Variant's may contain any other built-in D-Bus value. Besides +-- representing native @VARIANT@ values, they allow type-safe storage and +-- deconstruction of heterogeneous collections. + +#line 140 "src/types.anansi" +data Variant + = VarBoxBool Bool + | VarBoxWord8 Word8 + | VarBoxInt16 Int16 + | VarBoxInt32 Int32 + | VarBoxInt64 Int64 + | VarBoxWord16 Word16 + | VarBoxWord32 Word32 + | VarBoxWord64 Word64 + | VarBoxDouble Double + | VarBoxString Text + | VarBoxSignature Signature + | VarBoxObjectPath ObjectPath + | VarBoxVariant Variant + | VarBoxArray Array + | VarBoxDictionary Dictionary + | VarBoxStructure Structure + deriving (Eq) + +class Variable a where + toVariant :: a -> Variant + fromVariant :: Variant -> Maybe a + +#line 175 "src/types.anansi" +instance Show Variant where + showsPrec d var = showParen (d > 10) full where + full = s "Variant " . shows code . s " " . valueStr + code = typeCode $ variantType var + s = showString + valueStr = showsPrecVar 11 var + +showsPrecVar :: Int -> Variant -> ShowS +showsPrecVar d var = case var of + (VarBoxBool x) -> showsPrec d x + (VarBoxWord8 x) -> showsPrec d x + (VarBoxInt16 x) -> showsPrec d x + (VarBoxInt32 x) -> showsPrec d x + (VarBoxInt64 x) -> showsPrec d x + (VarBoxWord16 x) -> showsPrec d x + (VarBoxWord32 x) -> showsPrec d x + (VarBoxWord64 x) -> showsPrec d x + (VarBoxDouble x) -> showsPrec d x + (VarBoxString x) -> showsPrec d x + (VarBoxSignature x) -> showsPrec d x + (VarBoxObjectPath x) -> showsPrec d x + (VarBoxVariant x) -> showsPrec d x + (VarBoxArray x) -> showsPrec d x + (VarBoxDictionary x) -> showsPrec d x + (VarBoxStructure x) -> showsPrec d x + +#line 207 "src/types.anansi" + +#line 43 "src/api-docs.anansi" +-- | Every variant is strongly-typed; that is, the type of its contained +-- value is known at all times. This function retrieves that type, so that +-- the correct cast can be used to retrieve the value. + +#line 208 "src/types.anansi" +variantType :: Variant -> Type +variantType var = case var of + (VarBoxBool _) -> DBusBoolean + (VarBoxWord8 _) -> DBusByte + (VarBoxInt16 _) -> DBusInt16 + (VarBoxInt32 _) -> DBusInt32 + (VarBoxInt64 _) -> DBusInt64 + (VarBoxWord16 _) -> DBusWord16 + (VarBoxWord32 _) -> DBusWord32 + (VarBoxWord64 _) -> DBusWord64 + (VarBoxDouble _) -> DBusDouble + (VarBoxString _) -> DBusString + (VarBoxSignature _) -> DBusSignature + (VarBoxObjectPath _) -> DBusObjectPath + (VarBoxVariant _) -> DBusVariant + (VarBoxArray x) -> DBusArray (arrayType x) + (VarBoxDictionary x) -> let + keyT = dictionaryKeyType x + valueT = dictionaryValueType x + in DBusDictionary keyT valueT + (VarBoxStructure x) -> let + Structure items = x + in DBusStructure (map variantType items) + +#line 241 "src/types.anansi" +#define INSTANCE_VARIABLE(TYPE) \ + instance Variable TYPE where \ + { toVariant = VarBox/**/TYPE \ + ; fromVariant (VarBox/**/TYPE x) = Just x \ + ; fromVariant _ = Nothing \ + } + +#line 252 "src/types.anansi" +INSTANCE_VARIABLE(Variant) + +#line 316 "src/types.anansi" +INSTANCE_VARIABLE(Bool) +INSTANCE_VARIABLE(Word8) +INSTANCE_VARIABLE(Int16) +INSTANCE_VARIABLE(Int32) +INSTANCE_VARIABLE(Int64) +INSTANCE_VARIABLE(Word16) +INSTANCE_VARIABLE(Word32) +INSTANCE_VARIABLE(Word64) +INSTANCE_VARIABLE(Double) + +#line 334 "src/types.anansi" +instance Variable TL.Text where + toVariant = VarBoxString + fromVariant (VarBoxString x) = Just x + fromVariant _ = Nothing + +#line 349 "src/types.anansi" +instance Variable T.Text where + toVariant = toVariant . TL.fromChunks . (:[]) + fromVariant = fmap (T.concat . TL.toChunks) . fromVariant + +#line 362 "src/types.anansi" +instance Variable String where + toVariant = toVariant . TL.pack + fromVariant = fmap TL.unpack . fromVariant + +#line 395 "src/types.anansi" +INSTANCE_VARIABLE(Signature) +data Signature = Signature { signatureTypes :: [Type] } + deriving (Eq) + +instance Show Signature where + showsPrec d x = showParen (d > 10) $ + showString "Signature " . shows (strSignature x) + +#line 408 "src/types.anansi" +strSignature :: Signature -> Text +strSignature (Signature ts) = TL.concat $ map typeCode ts + +#line 420 "src/types.anansi" +instance Ord Signature where + compare = comparing strSignature + +#line 482 "src/types.anansi" +mkSignature :: Text -> Maybe Signature +mkSignature text = parsed where + +#line 496 "src/types.anansi" + just t = Just $ Signature [t] + fast = case TL.head text of + 'b' -> just DBusBoolean + 'y' -> just DBusByte + 'n' -> just DBusInt16 + 'i' -> just DBusInt32 + 'x' -> just DBusInt64 + 'q' -> just DBusWord16 + 'u' -> just DBusWord32 + 't' -> just DBusWord64 + 'd' -> just DBusDouble + 's' -> just DBusString + 'g' -> just DBusSignature + 'o' -> just DBusObjectPath + 'v' -> just DBusVariant + _ -> Nothing + +#line 485 "src/types.anansi" + +#line 523 "src/types.anansi" + slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text + sigParser = do + types <- P.many parseType + P.eof + return $ Signature types + +#line 534 "src/types.anansi" + parseType = parseAtom <|> parseContainer + parseContainer = + parseArray + <|> parseStruct + <|> (P.char 'v' >> return DBusVariant) + +#line 542 "src/types.anansi" + parseArray = do + P.char 'a' + parseDict <|> fmap DBusArray parseType + parseDict = do + P.char '{' + keyType <- parseAtom + valueType <- parseType + P.char '}' + return $ DBusDictionary keyType valueType + +#line 556 "src/types.anansi" + parseStruct = do + P.char '(' + types <- P.many parseType + P.char ')' + return $ DBusStructure types + +#line 564 "src/types.anansi" + parseAtom = + (P.char 'b' >> return DBusBoolean) + <|> (P.char 'y' >> return DBusByte) + <|> (P.char 'n' >> return DBusInt16) + <|> (P.char 'i' >> return DBusInt32) + <|> (P.char 'x' >> return DBusInt64) + <|> (P.char 'q' >> return DBusWord16) + <|> (P.char 'u' >> return DBusWord32) + <|> (P.char 't' >> return DBusWord64) + <|> (P.char 'd' >> return DBusDouble) + <|> (P.char 's' >> return DBusString) + <|> (P.char 'g' >> return DBusSignature) + <|> (P.char 'o' >> return DBusObjectPath) + +#line 486 "src/types.anansi" + parsed = case TL.length text of + 0 -> Just $ Signature [] + 1 -> fast + _ -> slow + +#line 589 "src/types.anansi" +mkSignature_ :: Text -> Signature +mkSignature_ = mkUnsafe "signature" mkSignature + +instance String.IsString Signature where + fromString = mkSignature_ . TL.pack + +#line 620 "src/types.anansi" +INSTANCE_VARIABLE(ObjectPath) +newtype ObjectPath = ObjectPath + { strObjectPath :: Text + } + deriving (Eq, Ord) + +instance Show ObjectPath where + showsPrec d (ObjectPath x) = showParen (d > 10) $ + showString "ObjectPath " . shows x + +instance String.IsString ObjectPath where + fromString = mkObjectPath_ . TL.pack + +#line 647 "src/types.anansi" +mkObjectPath :: Text -> Maybe ObjectPath +mkObjectPath s = parseMaybe path' (TL.unpack s) where + c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" + path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char + path' = path >> P.eof >> return (ObjectPath s) + +mkObjectPath_ :: Text -> ObjectPath +mkObjectPath_ = mkUnsafe "object path" mkObjectPath + +#line 696 "src/types.anansi" +INSTANCE_VARIABLE(Array) +data Array + = VariantArray Type [Variant] + | ByteArray ByteString + deriving (Eq) + + +#line 49 "src/api-docs.anansi" +-- | This is the type contained within the array, not the type of the array +-- itself. + +#line 703 "src/types.anansi" +arrayType :: Array -> Type +arrayType (VariantArray t _) = t +arrayType (ByteArray _) = DBusByte + +arrayItems :: Array -> [Variant] +arrayItems (VariantArray _ xs) = xs +arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs + +#line 723 "src/types.anansi" +instance Show Array where + showsPrec d array = showParen (d > 10) $ + s "Array " . showSig . s " [" . s valueString . s "]" where + s = showString + showSig = shows . typeCode . arrayType $ array + showVar var = showsPrecVar 0 var "" + valueString = intercalate ", " $ map showVar $ arrayItems array + +#line 737 "src/types.anansi" +arrayFromItems :: Type -> [Variant] -> Maybe Array +arrayFromItems DBusByte vs = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs) + +arrayFromItems t vs = do + mkSignature (typeCode t) + if all (\x -> variantType x == t) vs + then Just $ VariantArray t vs + else Nothing + +#line 751 "src/types.anansi" +toArray :: Variable a => Type -> [a] -> Maybe Array +toArray t = arrayFromItems t . map toVariant + +fromArray :: Variable a => Array -> Maybe [a] +fromArray = mapM fromVariant . arrayItems + +#line 768 "src/types.anansi" +arrayToBytes :: Array -> Maybe ByteString +arrayToBytes (ByteArray x) = Just x +arrayToBytes _ = Nothing + +arrayFromBytes :: ByteString -> Array +arrayFromBytes = ByteArray + +#line 785 "src/types.anansi" +instance Variable ByteString where + toVariant = toVariant . arrayFromBytes + fromVariant x = fromVariant x >>= arrayToBytes + +#line 795 "src/types.anansi" +instance Variable StrictByteString.ByteString where + toVariant x = toVariant . arrayFromBytes $ ByteString.fromChunks [x] + fromVariant x = do + chunks <- ByteString.toChunks `fmap` fromVariant x + return $ StrictByteString.concat chunks + +#line 836 "src/types.anansi" +INSTANCE_VARIABLE(Dictionary) +data Dictionary = Dictionary + { dictionaryKeyType :: Type + , dictionaryValueType :: Type + , dictionaryItems :: [(Variant, Variant)] + } + deriving (Eq) + +#line 861 "src/types.anansi" +instance Show Dictionary where + showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $ + s "Dictionary " . showSig . s " {" . s valueString . s "}" where + s = showString + showSig = shows $ TL.append (typeCode kt) (typeCode vt) + valueString = intercalate ", " $ map showPair pairs + showPair (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 v) "" + +#line 878 "src/types.anansi" +dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary +dictionaryFromItems kt vt pairs = do + unless (isAtomicType kt) Nothing + mkSignature (typeCode kt) + mkSignature (typeCode vt) + + let sameType (k, v) = variantType k == kt && + variantType v == vt + if all sameType pairs + then Just $ Dictionary kt vt pairs + else Nothing + +#line 901 "src/types.anansi" +toDictionary :: (Variable a, Variable b) => Type -> Type -> Map.Map a b + -> Maybe Dictionary +toDictionary kt vt = dictionaryFromItems kt vt . pairs where + pairs = map (toVariant *** toVariant) . Map.toList + +#line 912 "src/types.anansi" +fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary + -> Maybe (Map.Map a b) +fromDictionary (Dictionary _ _ vs) = do + pairs <- forM vs $ \(k, v) -> do + k' <- fromVariant k + v' <- fromVariant v + return (k', v') + return $ Map.fromList pairs + +#line 972 "src/types.anansi" +dictionaryToArray :: Dictionary -> Array +dictionaryToArray (Dictionary kt vt items) = array where + Just array = toArray itemType structs + itemType = DBusStructure [kt, vt] + structs = [Structure [k, v] | (k, v) <- items] + +#line 980 "src/types.anansi" +arrayToDictionary :: Array -> Maybe Dictionary +arrayToDictionary array = do + let toPair x = do + struct <- fromVariant x + case struct of + Structure [k, v] -> Just (k, v) + _ -> Nothing + (kt, vt) <- case arrayType array of + DBusStructure [kt, vt] -> Just (kt, vt) + _ -> Nothing + pairs <- mapM toPair $ arrayItems array + dictionaryFromItems kt vt pairs + +#line 1005 "src/types.anansi" +INSTANCE_VARIABLE(Structure) +data Structure = Structure [Variant] + deriving (Show, Eq) + +#line 1031 "src/types.anansi" +#define NAME_TYPE(TYPE, NAME) \ + newtype TYPE = TYPE {str/**/TYPE :: Text} \ + deriving (Eq, Ord); \ + \ + instance Show TYPE where \ + { showsPrec d (TYPE x) = showParen (d > 10) $ \ + showString "TYPE " . shows x \ + }; \ + \ + instance String.IsString TYPE where \ + { fromString = mk/**/TYPE/**/_ . TL.pack }; \ + \ + instance Variable TYPE where \ + { toVariant = toVariant . str/**/TYPE \ + ; fromVariant = (mk/**/TYPE =<<) . fromVariant }; \ + \ + mk/**/TYPE/**/_ :: Text -> TYPE; \ + mk/**/TYPE/**/_ = mkUnsafe NAME mk/**/TYPE + +#line 1068 "src/types.anansi" +NAME_TYPE(BusName, "bus name") + +mkBusName :: Text -> Maybe BusName +mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" + c' = c ++ ['0'..'9'] + parser = (unique <|> wellKnown) >> P.eof >> return (BusName s) + unique = P.char ':' >> elems c' + wellKnown = elems c + elems start = elem' start >> P.many1 (P.char '.' >> elem' start) + elem' start = P.oneOf start >> P.many (P.oneOf c') + +#line 1123 "src/types.anansi" +NAME_TYPE(InterfaceName, "interface name") + +mkInterfaceName :: Text -> Maybe InterfaceName +mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + element = P.oneOf c >> P.many (P.oneOf c') + name = element >> P.many1 (P.char '.' >> element) + parser = name >> P.eof >> return (InterfaceName s) + +#line 1169 "src/types.anansi" +NAME_TYPE(ErrorName, "error name") + +mkErrorName :: Text -> Maybe ErrorName +mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName + +#line 1201 "src/types.anansi" +NAME_TYPE(MemberName, "member name") + +mkMemberName :: Text -> Maybe MemberName +mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + name = P.oneOf c >> P.many (P.oneOf c') + parser = name >> P.eof >> return (MemberName s) diff --git a/hs/DBus/Types.hs b/hs/DBus/Types.hs deleted file mode 100644 --- a/hs/DBus/Types.hs +++ /dev/null @@ -1,593 +0,0 @@ -{- - 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 OverloadedStrings #-} - -{-# LANGUAGE TypeSynonymInstances #-} - -module DBus.Types ( -- * Available types - Type (..) - , typeCode - - -- * Variants - , Variant - , Variable (..) - - , variantType - - -- * Signatures - , Signature - , signatureTypes - , strSignature - - , mkSignature - , mkSignature_ - - -- * Object paths - , ObjectPath - , strObjectPath - , mkObjectPath - , mkObjectPath_ - - -- * Arrays - , Array - , arrayType - , arrayItems - - , toArray - , fromArray - , arrayFromItems - - , arrayToBytes - , arrayFromBytes - - -- * Dictionaries - , Dictionary - , dictionaryItems - , dictionaryKeyType - , dictionaryValueType - - , toDictionary - , fromDictionary - , dictionaryFromItems - - , dictionaryToArray - , arrayToDictionary - - -- * Structures - , Structure (..) - - -- * Names - - -- ** Bus names - , BusName - , strBusName - , mkBusName - , mkBusName_ - - -- ** Interface names - , InterfaceName - , strInterfaceName - , mkInterfaceName - , mkInterfaceName_ - - -- ** Error names - , ErrorName - , strErrorName - , mkErrorName - , mkErrorName_ - - -- ** Member names - , MemberName - , strMemberName - , mkMemberName - , mkMemberName_ -) where -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as TL - -import Data.Word (Word8, Word16, Word32, Word64) -import Data.Int (Int16, Int32, Int64) - -import qualified Data.Text as T - -import Data.Ord (comparing) - -import Text.Parsec ((<|>)) -import qualified Text.Parsec as P -import DBus.Util (checkLength, parseMaybe) - -import DBus.Util (mkUnsafe) - -import qualified Data.String as String - -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as ByteString - -import qualified Data.ByteString as StrictByteString - -import Data.List (intercalate) - -import Control.Monad (unless) - -import Control.Arrow ((***)) -import qualified Data.Map as Map - -import Control.Monad (forM) - - -data Type - = DBusBoolean - | DBusByte - | DBusInt16 - | DBusInt32 - | DBusInt64 - | DBusWord16 - | DBusWord32 - | DBusWord64 - | DBusDouble - | DBusString - | DBusSignature - | DBusObjectPath - | DBusVariant - | DBusArray Type - | DBusDictionary Type Type - | DBusStructure [Type] - deriving (Show, Eq) - --- | \"Atomic\" types are any which can't contain any other types. Only --- atomic types may be used as dictionary keys. - -isAtomicType :: Type -> Bool -isAtomicType DBusBoolean = True -isAtomicType DBusByte = True -isAtomicType DBusInt16 = True -isAtomicType DBusInt32 = True -isAtomicType DBusInt64 = True -isAtomicType DBusWord16 = True -isAtomicType DBusWord32 = True -isAtomicType DBusWord64 = True -isAtomicType DBusDouble = True -isAtomicType DBusString = True -isAtomicType DBusSignature = True -isAtomicType DBusObjectPath = True -isAtomicType _ = False - --- | Every type has an associated type code; a textual representation of --- the type, useful for debugging. - -typeCode :: Type -> Text -typeCode DBusBoolean = "b" -typeCode DBusByte = "y" -typeCode DBusInt16 = "n" -typeCode DBusInt32 = "i" -typeCode DBusInt64 = "x" -typeCode DBusWord16 = "q" -typeCode DBusWord32 = "u" -typeCode DBusWord64 = "t" -typeCode DBusDouble = "d" -typeCode DBusString = "s" -typeCode DBusSignature = "g" -typeCode DBusObjectPath = "o" -typeCode DBusVariant = "v" - -typeCode (DBusArray t) = TL.cons 'a' $ typeCode t - -typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"] - -typeCode (DBusStructure ts) = TL.concat $ - ["("] ++ map typeCode ts ++ [")"] - - --- | 'Variant's may contain any other built-in D-Bus value. Besides --- representing native @VARIANT@ values, they allow type-safe storage and --- deconstruction of heterogeneous collections. - -data Variant - = VarBoxBool Bool - | VarBoxWord8 Word8 - | VarBoxInt16 Int16 - | VarBoxInt32 Int32 - | VarBoxInt64 Int64 - | VarBoxWord16 Word16 - | VarBoxWord32 Word32 - | VarBoxWord64 Word64 - | VarBoxDouble Double - | VarBoxString Text - | VarBoxSignature Signature - | VarBoxObjectPath ObjectPath - | VarBoxVariant Variant - | VarBoxArray Array - | VarBoxDictionary Dictionary - | VarBoxStructure Structure - deriving (Eq) - -class Variable a where - toVariant :: a -> Variant - fromVariant :: Variant -> Maybe a - -instance Show Variant where - showsPrec d var = showParen (d > 10) full where - full = s "Variant " . shows code . s " " . valueStr - code = typeCode $ variantType var - s = showString - valueStr = showsPrecVar 11 var - -showsPrecVar :: Int -> Variant -> ShowS -showsPrecVar d var = case var of - (VarBoxBool x) -> showsPrec d x - (VarBoxWord8 x) -> showsPrec d x - (VarBoxInt16 x) -> showsPrec d x - (VarBoxInt32 x) -> showsPrec d x - (VarBoxInt64 x) -> showsPrec d x - (VarBoxWord16 x) -> showsPrec d x - (VarBoxWord32 x) -> showsPrec d x - (VarBoxWord64 x) -> showsPrec d x - (VarBoxDouble x) -> showsPrec d x - (VarBoxString x) -> showsPrec d x - (VarBoxSignature x) -> showsPrec d x - (VarBoxObjectPath x) -> showsPrec d x - (VarBoxVariant x) -> showsPrec d x - (VarBoxArray x) -> showsPrec d x - (VarBoxDictionary x) -> showsPrec d x - (VarBoxStructure x) -> showsPrec d x - --- | Every variant is strongly-typed; that is, the type of its contained --- value is known at all times. This function retrieves that type, so that --- the correct cast can be used to retrieve the value. - -variantType :: Variant -> Type -variantType var = case var of - (VarBoxBool _) -> DBusBoolean - (VarBoxWord8 _) -> DBusByte - (VarBoxInt16 _) -> DBusInt16 - (VarBoxInt32 _) -> DBusInt32 - (VarBoxInt64 _) -> DBusInt64 - (VarBoxWord16 _) -> DBusWord16 - (VarBoxWord32 _) -> DBusWord32 - (VarBoxWord64 _) -> DBusWord64 - (VarBoxDouble _) -> DBusDouble - (VarBoxString _) -> DBusString - (VarBoxSignature _) -> DBusSignature - (VarBoxObjectPath _) -> DBusObjectPath - (VarBoxVariant _) -> DBusVariant - (VarBoxArray x) -> DBusArray (arrayType x) - (VarBoxDictionary x) -> let - keyT = dictionaryKeyType x - valueT = dictionaryValueType x - in DBusDictionary keyT valueT - (VarBoxStructure x) -> let - Structure items = x - in DBusStructure (map variantType items) - - - - - - - - -instance Variable Variant where { toVariant = VarBoxVariant ; fromVariant (VarBoxVariant x) = Just x ; fromVariant _ = Nothing } - -instance Variable Bool where { toVariant = VarBoxBool ; fromVariant (VarBoxBool x) = Just x ; fromVariant _ = Nothing } -instance Variable Word8 where { toVariant = VarBoxWord8 ; fromVariant (VarBoxWord8 x) = Just x ; fromVariant _ = Nothing } -instance Variable Int16 where { toVariant = VarBoxInt16 ; fromVariant (VarBoxInt16 x) = Just x ; fromVariant _ = Nothing } -instance Variable Int32 where { toVariant = VarBoxInt32 ; fromVariant (VarBoxInt32 x) = Just x ; fromVariant _ = Nothing } -instance Variable Int64 where { toVariant = VarBoxInt64 ; fromVariant (VarBoxInt64 x) = Just x ; fromVariant _ = Nothing } -instance Variable Word16 where { toVariant = VarBoxWord16 ; fromVariant (VarBoxWord16 x) = Just x ; fromVariant _ = Nothing } -instance Variable Word32 where { toVariant = VarBoxWord32 ; fromVariant (VarBoxWord32 x) = Just x ; fromVariant _ = Nothing } -instance Variable Word64 where { toVariant = VarBoxWord64 ; fromVariant (VarBoxWord64 x) = Just x ; fromVariant _ = Nothing } -instance Variable Double where { toVariant = VarBoxDouble ; fromVariant (VarBoxDouble x) = Just x ; fromVariant _ = Nothing } - -instance Variable TL.Text where - toVariant = VarBoxString - fromVariant (VarBoxString x) = Just x - fromVariant _ = Nothing - -instance Variable T.Text where - toVariant = toVariant . TL.fromChunks . (:[]) - fromVariant = fmap (T.concat . TL.toChunks) . fromVariant - -instance Variable String where - toVariant = toVariant . TL.pack - fromVariant = fmap TL.unpack . fromVariant - -instance Variable Signature where { toVariant = VarBoxSignature ; fromVariant (VarBoxSignature x) = Just x ; fromVariant _ = Nothing } -data Signature = Signature { signatureTypes :: [Type] } - deriving (Eq) - -instance Show Signature where - showsPrec d x = showParen (d > 10) $ - showString "Signature " . shows (strSignature x) - -strSignature :: Signature -> Text -strSignature (Signature ts) = TL.concat $ map typeCode ts - -instance Ord Signature where - compare = comparing strSignature - -mkSignature :: Text -> Maybe Signature -mkSignature text = parsed where - just t = Just $ Signature [t] - fast = case TL.head text of - 'b' -> just DBusBoolean - 'y' -> just DBusByte - 'n' -> just DBusInt16 - 'i' -> just DBusInt32 - 'x' -> just DBusInt64 - 'q' -> just DBusWord16 - 'u' -> just DBusWord32 - 't' -> just DBusWord64 - 'd' -> just DBusDouble - 's' -> just DBusString - 'g' -> just DBusSignature - 'o' -> just DBusObjectPath - 'v' -> just DBusVariant - _ -> Nothing - - slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text - sigParser = do - types <- P.many parseType - P.eof - return $ Signature types - - parseType = parseAtom <|> parseContainer - parseContainer = - parseArray - <|> parseStruct - <|> (P.char 'v' >> return DBusVariant) - - parseArray = do - P.char 'a' - parseDict <|> fmap DBusArray parseType - parseDict = do - P.char '{' - keyType <- parseAtom - valueType <- parseType - P.char '}' - return $ DBusDictionary keyType valueType - - parseStruct = do - P.char '(' - types <- P.many parseType - P.char ')' - return $ DBusStructure types - - parseAtom = - (P.char 'b' >> return DBusBoolean) - <|> (P.char 'y' >> return DBusByte) - <|> (P.char 'n' >> return DBusInt16) - <|> (P.char 'i' >> return DBusInt32) - <|> (P.char 'x' >> return DBusInt64) - <|> (P.char 'q' >> return DBusWord16) - <|> (P.char 'u' >> return DBusWord32) - <|> (P.char 't' >> return DBusWord64) - <|> (P.char 'd' >> return DBusDouble) - <|> (P.char 's' >> return DBusString) - <|> (P.char 'g' >> return DBusSignature) - <|> (P.char 'o' >> return DBusObjectPath) - - parsed = case TL.length text of - 0 -> Just $ Signature [] - 1 -> fast - _ -> slow - -mkSignature_ :: Text -> Signature -mkSignature_ = mkUnsafe "signature" mkSignature - -instance String.IsString Signature where - fromString = mkSignature_ . TL.pack - -instance Variable ObjectPath where { toVariant = VarBoxObjectPath ; fromVariant (VarBoxObjectPath x) = Just x ; fromVariant _ = Nothing } -newtype ObjectPath = ObjectPath - { strObjectPath :: Text - } - deriving (Eq, Ord) - -instance Show ObjectPath where - showsPrec d (ObjectPath x) = showParen (d > 10) $ - showString "ObjectPath " . shows x - -instance String.IsString ObjectPath where - fromString = mkObjectPath_ . TL.pack - -mkObjectPath :: Text -> Maybe ObjectPath -mkObjectPath s = parseMaybe path' (TL.unpack s) where - c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" - path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char - path' = path >> P.eof >> return (ObjectPath s) - -mkObjectPath_ :: Text -> ObjectPath -mkObjectPath_ = mkUnsafe "object path" mkObjectPath - -instance Variable Array where { toVariant = VarBoxArray ; fromVariant (VarBoxArray x) = Just x ; fromVariant _ = Nothing } -data Array - = VariantArray Type [Variant] - | ByteArray ByteString - deriving (Eq) - --- | This is the type contained within the array, not the type of the array --- itself. - -arrayType :: Array -> Type -arrayType (VariantArray t _) = t -arrayType (ByteArray _) = DBusByte - -arrayItems :: Array -> [Variant] -arrayItems (VariantArray _ xs) = xs -arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs - -instance Show Array where - showsPrec d array = showParen (d > 10) $ - s "Array " . showSig . s " [" . s valueString . s "]" where - s = showString - showSig = shows . typeCode . arrayType $ array - showVar var = showsPrecVar 0 var "" - valueString = intercalate ", " $ map showVar $ arrayItems array - -arrayFromItems :: Type -> [Variant] -> Maybe Array -arrayFromItems DBusByte vs = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs) - -arrayFromItems t vs = do - mkSignature (typeCode t) - if all (\x -> variantType x == t) vs - then Just $ VariantArray t vs - else Nothing - -toArray :: Variable a => Type -> [a] -> Maybe Array -toArray t = arrayFromItems t . map toVariant - -fromArray :: Variable a => Array -> Maybe [a] -fromArray = mapM fromVariant . arrayItems - -arrayToBytes :: Array -> Maybe ByteString -arrayToBytes (ByteArray x) = Just x -arrayToBytes _ = Nothing - -arrayFromBytes :: ByteString -> Array -arrayFromBytes = ByteArray - -instance Variable ByteString where - toVariant = toVariant . arrayFromBytes - fromVariant x = fromVariant x >>= arrayToBytes - -instance Variable StrictByteString.ByteString where - toVariant x = toVariant . arrayFromBytes $ ByteString.fromChunks [x] - fromVariant x = do - chunks <- ByteString.toChunks `fmap` fromVariant x - return $ StrictByteString.concat chunks - -instance Variable Dictionary where { toVariant = VarBoxDictionary ; fromVariant (VarBoxDictionary x) = Just x ; fromVariant _ = Nothing } -data Dictionary = Dictionary - { dictionaryKeyType :: Type - , dictionaryValueType :: Type - , dictionaryItems :: [(Variant, Variant)] - } - deriving (Eq) - -instance Show Dictionary where - showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $ - s "Dictionary " . showSig . s " {" . s valueString . s "}" where - s = showString - showSig = shows $ TL.append (typeCode kt) (typeCode vt) - valueString = intercalate ", " $ map showPair pairs - showPair (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 v) "" - -dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary -dictionaryFromItems kt vt pairs = do - unless (isAtomicType kt) Nothing - mkSignature (typeCode kt) - mkSignature (typeCode vt) - - let sameType (k, v) = variantType k == kt && - variantType v == vt - if all sameType pairs - then Just $ Dictionary kt vt pairs - else Nothing - -toDictionary :: (Variable a, Variable b) => Type -> Type -> Map.Map a b - -> Maybe Dictionary -toDictionary kt vt = dictionaryFromItems kt vt . pairs where - pairs = map (toVariant *** toVariant) . Map.toList - -fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary - -> Maybe (Map.Map a b) -fromDictionary (Dictionary _ _ vs) = do - pairs <- forM vs $ \(k, v) -> do - k' <- fromVariant k - v' <- fromVariant v - return (k', v') - return $ Map.fromList pairs - -dictionaryToArray :: Dictionary -> Array -dictionaryToArray (Dictionary kt vt items) = array where - Just array = toArray itemType structs - itemType = DBusStructure [kt, vt] - structs = [Structure [k, v] | (k, v) <- items] - -arrayToDictionary :: Array -> Maybe Dictionary -arrayToDictionary array = do - let toPair x = do - struct <- fromVariant x - case struct of - Structure [k, v] -> Just (k, v) - _ -> Nothing - (kt, vt) <- case arrayType array of - DBusStructure [kt, vt] -> Just (kt, vt) - _ -> Nothing - pairs <- mapM toPair $ arrayItems array - dictionaryFromItems kt vt pairs - -instance Variable Structure where { toVariant = VarBoxStructure ; fromVariant (VarBoxStructure x) = Just x ; fromVariant _ = Nothing } -data Structure = Structure [Variant] - deriving (Show, Eq) - - - - - - - - - - - - - - - - - - - - -newtype BusName = BusName {strBusName :: Text} deriving (Eq, Ord); instance Show BusName where { showsPrec d (BusName x) = showParen (d > 10) $ showString "BusName " . shows x }; instance String.IsString BusName where { fromString = mkBusName_ . TL.pack }; instance Variable BusName where { toVariant = toVariant . strBusName ; fromVariant = (mkBusName =<<) . fromVariant }; mkBusName_ :: Text -> BusName; mkBusName_ = mkUnsafe "bus name" mkBusName - -mkBusName :: Text -> Maybe BusName -mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where - c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" - c' = c ++ ['0'..'9'] - parser = (unique <|> wellKnown) >> P.eof >> return (BusName s) - unique = P.char ':' >> elems c' - wellKnown = elems c - elems start = elem' start >> P.many1 (P.char '.' >> elem' start) - elem' start = P.oneOf start >> P.many (P.oneOf c') - -newtype InterfaceName = InterfaceName {strInterfaceName :: Text} deriving (Eq, Ord); instance Show InterfaceName where { showsPrec d (InterfaceName x) = showParen (d > 10) $ showString "InterfaceName " . shows x }; instance String.IsString InterfaceName where { fromString = mkInterfaceName_ . TL.pack }; instance Variable InterfaceName where { toVariant = toVariant . strInterfaceName ; fromVariant = (mkInterfaceName =<<) . fromVariant }; mkInterfaceName_ :: Text -> InterfaceName; mkInterfaceName_ = mkUnsafe "interface name" mkInterfaceName - -mkInterfaceName :: Text -> Maybe InterfaceName -mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where - c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" - c' = c ++ ['0'..'9'] - element = P.oneOf c >> P.many (P.oneOf c') - name = element >> P.many1 (P.char '.' >> element) - parser = name >> P.eof >> return (InterfaceName s) - -newtype ErrorName = ErrorName {strErrorName :: Text} deriving (Eq, Ord); instance Show ErrorName where { showsPrec d (ErrorName x) = showParen (d > 10) $ showString "ErrorName " . shows x }; instance String.IsString ErrorName where { fromString = mkErrorName_ . TL.pack }; instance Variable ErrorName where { toVariant = toVariant . strErrorName ; fromVariant = (mkErrorName =<<) . fromVariant }; mkErrorName_ :: Text -> ErrorName; mkErrorName_ = mkUnsafe "error name" mkErrorName - -mkErrorName :: Text -> Maybe ErrorName -mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName - -newtype MemberName = MemberName {strMemberName :: Text} deriving (Eq, Ord); instance Show MemberName where { showsPrec d (MemberName x) = showParen (d > 10) $ showString "MemberName " . shows x }; instance String.IsString MemberName where { fromString = mkMemberName_ . TL.pack }; instance Variable MemberName where { toVariant = toVariant . strMemberName ; fromVariant = (mkMemberName =<<) . fromVariant }; mkMemberName_ :: Text -> MemberName; mkMemberName_ = mkUnsafe "member name" mkMemberName - -mkMemberName :: Text -> Maybe MemberName -mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where - c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" - c' = c ++ ['0'..'9'] - name = P.oneOf c >> P.many (P.oneOf c') - parser = name >> P.eof >> return (MemberName s) - diff --git a/hs/DBus/UUID.hs b/hs/DBus/UUID.hs --- a/hs/DBus/UUID.hs +++ b/hs/DBus/UUID.hs @@ -1,50 +1,55 @@ -{- - 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 . --} +#line 22 "src/util.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 23 "src/util.anansi" module DBus.UUID - ( UUID - , toHex - , fromHex - ) where + ( UUID + , toHex + , fromHex + ) where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 29 "src/util.anansi" newtype UUID = UUID Text -- TODO: (Word64, Word64)? - deriving (Eq) + deriving (Eq) instance Show UUID where - showsPrec d uuid = showParen (d > 10) $ - showString "UUID " . shows (toHex uuid) + showsPrec d uuid = showParen (d > 10) $ + showString "UUID " . shows (toHex uuid) toHex :: UUID -> Text toHex (UUID text) = text fromHex :: Text -> Maybe UUID fromHex text = if validUUID text - then Just $ UUID text - else Nothing + then Just $ UUID text + else Nothing validUUID :: Text -> Bool validUUID text = valid where - valid = and [TL.length text == 32, TL.all validChar text] - validChar c = or - [ c >= '0' && c <= '9' - , c >= 'a' && c <= 'f' - , c >= 'A' && c <= 'F' - ] - + valid = and [TL.length text == 32, TL.all validChar text] + validChar c = or + [ c >= '0' && c <= '9' + , c >= 'a' && c <= 'f' + , c >= 'A' && c <= 'F' + ] diff --git a/hs/DBus/Util.hs b/hs/DBus/Util.hs --- a/hs/DBus/Util.hs +++ b/hs/DBus/Util.hs @@ -1,20 +1,23 @@ -{- - 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 . --} +#line 58 "src/util.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 59 "src/util.anansi" module DBus.Util where import Text.Parsec (Parsec, parse) import Data.Char (digitToInt) @@ -29,8 +32,8 @@ mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b mkUnsafe label f x = case f x of - Just x' -> x' - Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x + Just x' -> x' + Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x hexToInt :: String -> Int hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt @@ -53,14 +56,13 @@ -- readUntil :: (Monad m, Eq a) => [a] -> m a -> m [a] readUntil guard getx = readUntil' [] where - guard' = reverse guard - step xs | isPrefixOf guard' xs = return . reverse $ xs - | otherwise = readUntil' xs - readUntil' xs = do - x <- getx - step $ x:xs + guard' = reverse guard + step xs | isPrefixOf guard' xs = return . reverse $ xs + | otherwise = readUntil' xs + readUntil' xs = do + x <- getx + step $ x:xs -- | Drop /n/ items from the end of a list dropEnd :: Int -> [a] -> [a] dropEnd n xs = take (length xs - n) xs - diff --git a/hs/DBus/Util/MonadError.hs b/hs/DBus/Util/MonadError.hs --- a/hs/DBus/Util/MonadError.hs +++ b/hs/DBus/Util/MonadError.hs @@ -1,57 +1,58 @@ -{- - 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 . --} +#line 117 "src/util.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 118 "src/util.anansi" {-# LANGUAGE TypeFamilies #-} -module DBus.Util.MonadError where +module DBus.Util.MonadError + ( ErrorT (..) + , throwError + ) where import Control.Monad.Trans.Class import Control.Monad.State +import Control.Monad.Error.Class newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } instance Functor m => Functor (ErrorT e m) where - fmap f = ErrorT . fmap (fmap f) . runErrorT + fmap f = ErrorT . fmap (fmap f) . runErrorT instance Monad m => Monad (ErrorT e m) where - return = ErrorT . return . Right - (>>=) m k = ErrorT $ do - x <- runErrorT m - case x of - Left l -> return $ Left l - Right r -> runErrorT $ k r + return = ErrorT . return . Right + (>>=) m k = ErrorT $ do + x <- runErrorT m + case x of + Left l -> return $ Left l + Right r -> runErrorT $ k r instance MonadTrans (ErrorT e) where - lift = ErrorT . liftM Right - -class Monad m => MonadError m where - type ErrorType m - throwError :: ErrorType m -> m a - catchError :: m a -> (ErrorType m -> m a) -> m a + lift = ErrorT . liftM Right instance Monad m => MonadError (ErrorT e m) where - type ErrorType (ErrorT e m) = e - throwError = ErrorT . return . Left - catchError m h = ErrorT $ do - x <- runErrorT m - case x of - Left l -> runErrorT $ h l - Right r -> return $ Right r + type ErrorType (ErrorT e m) = e + throwError = ErrorT . return . Left + catchError m h = ErrorT $ do + x <- runErrorT m + case x of + Left l -> runErrorT $ h l + Right r -> return $ Right r instance MonadState m => MonadState (ErrorT e m) where - type StateType (ErrorT e m) = StateType m - get = lift get - put = lift . put - + type StateType (ErrorT e m) = StateType m + get = lift get + put = lift . put diff --git a/hs/DBus/Wire.hs b/hs/DBus/Wire.hs --- a/hs/DBus/Wire.hs +++ b/hs/DBus/Wire.hs @@ -1,31 +1,42 @@ -{- - 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 DBus.Wire ( Endianness (..) +#line 21 "src/wire.anansi" - , MarshalError (..) +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . - , UnmarshalError (..) +#line 22 "src/wire.anansi" +module DBus.Wire ( - , marshalMessage +#line 54 "src/wire.anansi" + Endianness (..) - , unmarshalMessage -) where +#line 207 "src/wire.anansi" + , MarshalError (..) + +#line 379 "src/wire.anansi" + , UnmarshalError (..) + +#line 850 "src/wire.anansi" + , marshalMessage + +#line 919 "src/wire.anansi" + , unmarshalMessage + +#line 24 "src/wire.anansi" + ) where import DBus.Wire.Internal import DBus.Wire.Marshal import DBus.Wire.Unmarshal - diff --git a/hs/DBus/Wire/Internal.hs b/hs/DBus/Wire/Internal.hs --- a/hs/DBus/Wire/Internal.hs +++ b/hs/DBus/Wire/Internal.hs @@ -1,26 +1,30 @@ -{- - 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 . --} +#line 31 "src/wire.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 32 "src/wire.anansi" module DBus.Wire.Internal where import Data.Word (Word8, Word64) import qualified DBus.Types as T +#line 40 "src/wire.anansi" data Endianness = LittleEndian | BigEndian - deriving (Show, Eq) + deriving (Show, Eq) encodeEndianness :: Endianness -> Word8 encodeEndianness LittleEndian = 108 @@ -31,7 +35,10 @@ decodeEndianness 66 = Just BigEndian decodeEndianness _ = Nothing +#line 69 "src/wire.anansi" alignment :: T.Type -> Word8 + +#line 388 "src/wire.anansi" alignment T.DBusByte = 1 alignment T.DBusWord16 = 2 alignment T.DBusWord32 = 4 @@ -41,27 +48,34 @@ alignment T.DBusInt64 = 8 alignment T.DBusDouble = 8 +#line 472 "src/wire.anansi" alignment T.DBusBoolean = 4 +#line 553 "src/wire.anansi" alignment T.DBusString = 4 alignment T.DBusObjectPath = 4 +#line 599 "src/wire.anansi" alignment T.DBusSignature = 1 +#line 615 "src/wire.anansi" alignment (T.DBusArray _) = 4 +#line 697 "src/wire.anansi" alignment (T.DBusDictionary _ _) = 4 +#line 714 "src/wire.anansi" alignment (T.DBusStructure _) = 8 +#line 733 "src/wire.anansi" alignment T.DBusVariant = 1 +#line 71 "src/wire.anansi" 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 - + count' = fromIntegral count + missing = mod current count' + required = if missing > 0 + then count' - missing + else 0 diff --git a/hs/DBus/Wire/Marshal.hs b/hs/DBus/Wire/Marshal.hs --- a/hs/DBus/Wire/Marshal.hs +++ b/hs/DBus/Wire/Marshal.hs @@ -1,44 +1,59 @@ -{- - 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 . --} +#line 89 "src/wire.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 90 "src/wire.anansi" {-# LANGUAGE TypeFamilies #-} module DBus.Wire.Marshal where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 93 "src/wire.anansi" + +#line 104 "src/wire.anansi" import qualified Control.Monad.State as State import qualified DBus.Util.MonadError as E import qualified Data.ByteString.Lazy as L import qualified Data.Binary.Builder as B +#line 443 "src/wire.anansi" import Data.Binary.Put (runPut) import qualified Data.Binary.IEEE754 as IEEE +#line 523 "src/wire.anansi" import DBus.Wire.Unicode (maybeEncodeUtf8) +#line 575 "src/wire.anansi" import Data.Text.Lazy.Encoding (encodeUtf8) +#line 631 "src/wire.anansi" import qualified DBus.Constants as C +#line 759 "src/wire.anansi" import qualified DBus.Message.Internal as M +#line 774 "src/wire.anansi" import Data.Bits ((.|.)) import qualified Data.Set as Set +#line 94 "src/wire.anansi" import DBus.Wire.Internal import Control.Monad (when) import Data.Maybe (fromJust) @@ -47,162 +62,186 @@ import qualified DBus.Types as T +#line 111 "src/wire.anansi" data MarshalState = MarshalState Endianness B.Builder !Word64 type MarshalM = E.ErrorT MarshalError (State.State MarshalState) type Marshal = MarshalM () +#line 120 "src/wire.anansi" runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString runMarshal m e = case State.runState (E.runErrorT m) initialState of - (Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder) - (Left x, _) -> Left x - where initialState = MarshalState e B.empty 0 + (Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder) + (Left x, _) -> Left x + where initialState = MarshalState e B.empty 0 +#line 128 "src/wire.anansi" marshal :: T.Variant -> Marshal marshal v = marshalType (T.variantType v) where - x :: T.Variable a => a - x = fromJust . T.fromVariant $ v - marshalType :: T.Type -> Marshal - marshalType T.DBusByte = append $ L.singleton x - marshalType T.DBusWord16 = marshalBuilder 2 B.putWord16be B.putWord16le x - marshalType T.DBusWord32 = marshalBuilder 4 B.putWord32be B.putWord32le x - marshalType T.DBusWord64 = marshalBuilder 8 B.putWord64be B.putWord64le x - marshalType T.DBusInt16 = marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral (x :: Int16) - marshalType T.DBusInt32 = marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral (x :: Int32) - marshalType T.DBusInt64 = marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral (x :: Int64) + x :: T.Variable a => a + x = fromJust . T.fromVariant $ v + marshalType :: T.Type -> Marshal - marshalType T.DBusDouble = do - pad 8 - (MarshalState e _ _) <- State.get - let put = case e of - BigEndian -> IEEE.putFloat64be - LittleEndian -> IEEE.putFloat64le - let bytes = runPut $ put x - append bytes +#line 412 "src/wire.anansi" + marshalType T.DBusByte = append $ L.singleton x + marshalType T.DBusWord16 = marshalBuilder 2 B.putWord16be B.putWord16le x + marshalType T.DBusWord32 = marshalBuilder 4 B.putWord32be B.putWord32le x + marshalType T.DBusWord64 = marshalBuilder 8 B.putWord64be B.putWord64le x + marshalType T.DBusInt16 = marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral (x :: Int16) + marshalType T.DBusInt32 = marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral (x :: Int32) + marshalType T.DBusInt64 = marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral (x :: Int64) - marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0 +#line 452 "src/wire.anansi" + marshalType T.DBusDouble = do + pad 8 + (MarshalState e _ _) <- State.get + let put = case e of + BigEndian -> IEEE.putFloat64be + LittleEndian -> IEEE.putFloat64le + let bytes = runPut $ put x + append bytes - marshalType T.DBusString = marshalText x - marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x +#line 476 "src/wire.anansi" + marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0 - marshalType T.DBusSignature = marshalSignature x +#line 558 "src/wire.anansi" + marshalType T.DBusString = marshalText x + marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x - marshalType (T.DBusArray _) = marshalArray x +#line 603 "src/wire.anansi" + marshalType T.DBusSignature = marshalSignature x - marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x) +#line 619 "src/wire.anansi" + marshalType (T.DBusArray _) = marshalArray x - marshalType (T.DBusStructure _) = do - let T.Structure vs = x - pad 8 - mapM_ marshal vs +#line 701 "src/wire.anansi" + marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x) - marshalType T.DBusVariant = do - let rawSig = T.typeCode . T.variantType $ x - sig <- case T.mkSignature rawSig of - Just x' -> return x' - Nothing -> E.throwError $ InvalidVariantSignature rawSig - marshalSignature sig - marshal x +#line 718 "src/wire.anansi" + marshalType (T.DBusStructure _) = do + let T.Structure vs = x + pad 8 + mapM_ marshal vs +#line 737 "src/wire.anansi" + marshalType T.DBusVariant = do + let rawSig = T.typeCode . T.variantType $ x + sig <- case T.mkSignature rawSig of + Just x' -> return x' + Nothing -> E.throwError $ InvalidVariantSignature rawSig + marshalSignature sig + marshal x +#line 139 "src/wire.anansi" append :: L.ByteString -> Marshal append bytes = do - (MarshalState e builder count) <- State.get - let builder' = B.append builder $ B.fromLazyByteString bytes - count' = count + fromIntegral (L.length bytes) - State.put $ MarshalState e builder' count' + (MarshalState e builder count) <- State.get + let builder' = B.append builder $ B.fromLazyByteString bytes + count' = count + fromIntegral (L.length bytes) + State.put $ MarshalState e builder' count' +#line 148 "src/wire.anansi" pad :: Word8 -> Marshal pad count = do - (MarshalState _ _ existing) <- State.get - let padding' = fromIntegral $ padding existing count - append $ L.replicate padding' 0 + (MarshalState _ _ existing) <- State.get + let padding' = fromIntegral $ padding existing count + append $ L.replicate padding' 0 +#line 159 "src/wire.anansi" marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal marshalBuilder size be le x = do - pad size - (MarshalState e builder count) <- State.get - let builder' = B.append builder $ case e of - BigEndian -> be x - LittleEndian -> le x - let count' = count + fromIntegral size - State.put $ MarshalState e builder' count' + pad size + (MarshalState e builder count) <- State.get + let builder' = B.append builder $ case e of + BigEndian -> be x + LittleEndian -> le x + let count' = count + fromIntegral size + State.put $ MarshalState e builder' count' +#line 185 "src/wire.anansi" data MarshalError - = MessageTooLong Word64 - | ArrayTooLong Word64 - | InvalidBodySignature Text - | InvalidVariantSignature Text - | InvalidText Text - deriving (Eq) + = MessageTooLong Word64 + | ArrayTooLong Word64 + | InvalidBodySignature Text + | InvalidVariantSignature Text + | InvalidText Text + deriving (Eq) instance Show MarshalError where - show (MessageTooLong x) = concat - ["Message too long (", show x, " bytes)."] - show (ArrayTooLong x) = concat - ["Array too long (", show x, " bytes)."] - show (InvalidBodySignature x) = concat - ["Invalid body signature: ", show x] - show (InvalidVariantSignature x) = concat - ["Invalid variant signature: ", show x] - show (InvalidText x) = concat - ["Text cannot be marshaled: ", show x] + show (MessageTooLong x) = concat + ["Message too long (", show x, " bytes)."] + show (ArrayTooLong x) = concat + ["Array too long (", show x, " bytes)."] + show (InvalidBodySignature x) = concat + ["Invalid body signature: ", show x] + show (InvalidVariantSignature x) = concat + ["Invalid variant signature: ", show x] + show (InvalidText x) = concat + ["Text cannot be marshaled: ", show x] +#line 402 "src/wire.anansi" marshalWord32 :: Word32 -> Marshal marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le +#line 527 "src/wire.anansi" marshalText :: Text -> Marshal marshalText x = do - bytes <- case maybeEncodeUtf8 x of - Just x' -> return x' - Nothing -> E.throwError $ InvalidText x - when (L.any (== 0) bytes) $ - E.throwError $ InvalidText x - marshalWord32 . fromIntegral . L.length $ bytes - append bytes - append (L.singleton 0) + bytes <- case maybeEncodeUtf8 x of + Just x' -> return x' + Nothing -> E.throwError $ InvalidText x + when (L.any (== 0) bytes) $ + E.throwError $ InvalidText x + marshalWord32 . fromIntegral . L.length $ bytes + append bytes + append (L.singleton 0) +#line 579 "src/wire.anansi" marshalSignature :: T.Signature -> Marshal marshalSignature x = do - let bytes = encodeUtf8 . T.strSignature $ x - let size = fromIntegral . L.length $ bytes - append (L.singleton size) - append bytes - append (L.singleton 0) + let bytes = encodeUtf8 . T.strSignature $ x + let size = fromIntegral . L.length $ bytes + append (L.singleton size) + append bytes + append (L.singleton 0) +#line 635 "src/wire.anansi" marshalArray :: T.Array -> Marshal marshalArray x = do - (arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x - let arrayLen = L.length arrayBytes - when (arrayLen > fromIntegral C.arrayMaximumLength) - (E.throwError $ ArrayTooLong $ fromIntegral arrayLen) - marshalWord32 $ fromIntegral arrayLen - append $ L.replicate arrayPadding 0 - append arrayBytes + (arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x + let arrayLen = L.length arrayBytes + when (arrayLen > fromIntegral C.arrayMaximumLength) + (E.throwError $ ArrayTooLong $ fromIntegral arrayLen) + marshalWord32 $ fromIntegral arrayLen + append $ L.replicate arrayPadding 0 + append arrayBytes +#line 647 "src/wire.anansi" getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString) getArrayBytes T.DBusByte x = return (0, bytes) where - Just bytes = T.arrayToBytes x + Just bytes = T.arrayToBytes x +#line 653 "src/wire.anansi" getArrayBytes itemType x = do - let vs = T.arrayItems x - s <- State.get - (MarshalState _ _ afterLength) <- marshalWord32 0 >> State.get - (MarshalState e _ afterPadding) <- pad (alignment itemType) >> State.get - - State.put $ MarshalState e B.empty afterPadding - (MarshalState _ itemBuilder _) <- mapM_ marshal vs >> State.get - - let itemBytes = B.toLazyByteString itemBuilder - paddingSize = fromIntegral $ afterPadding - afterLength - - State.put s - return (paddingSize, itemBytes) + let vs = T.arrayItems x + s <- State.get + (MarshalState _ _ afterLength) <- marshalWord32 0 >> State.get + (MarshalState e _ afterPadding) <- pad (alignment itemType) >> State.get + + State.put $ MarshalState e B.empty afterPadding + (MarshalState _ itemBuilder _) <- mapM_ marshal vs >> State.get + + let itemBytes = B.toLazyByteString itemBuilder + paddingSize = fromIntegral $ afterPadding - afterLength + + State.put s + return (paddingSize, itemBytes) +#line 779 "src/wire.anansi" encodeFlags :: Set.Set M.Flag -> Word8 encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where - flagValue M.NoReplyExpected = 0x1 - flagValue M.NoAutoStart = 0x2 + flagValue M.NoReplyExpected = 0x1 + flagValue M.NoAutoStart = 0x2 +#line 797 "src/wire.anansi" encodeField :: M.HeaderField -> T.Structure encodeField (M.Path x) = encodeField' 1 x encodeField (M.Interface x) = encodeField' 2 x @@ -215,59 +254,66 @@ encodeField' :: T.Variable a => Word8 -> a -> T.Structure encodeField' code x = T.Structure - [ T.toVariant code - , T.toVariant $ T.toVariant x - ] + [ T.toVariant code + , T.toVariant $ T.toVariant x + ] +#line 854 "src/wire.anansi" + +#line 163 "src/api-docs.anansi" -- | Convert a 'M.Message' into a 'L.ByteString'. Although unusual, it is -- possible for marshaling to fail -- if this occurs, an appropriate error -- will be returned instead. +#line 855 "src/wire.anansi" marshalMessage :: M.Message a => Endianness -> M.Serial -> a -> Either MarshalError L.ByteString marshalMessage e serial msg = runMarshal marshaler e where - body = M.messageBody msg - marshaler = do - sig <- checkBodySig body - empty <- State.get - mapM_ marshal body - (MarshalState _ bodyBytesB _) <- State.get - State.put empty - marshalEndianness e - let bodyBytes = B.toLazyByteString bodyBytesB - marshalHeader msg serial sig - $ fromIntegral . L.length $ bodyBytes - pad 8 - append bodyBytes - checkMaximumSize + body = M.messageBody msg + marshaler = do + sig <- checkBodySig body + empty <- State.get + mapM_ marshal body + (MarshalState _ bodyBytesB _) <- State.get + State.put empty + marshalEndianness e + let bodyBytes = B.toLazyByteString bodyBytesB + marshalHeader msg serial sig + $ fromIntegral . L.length $ bodyBytes + pad 8 + append bodyBytes + checkMaximumSize +#line 875 "src/wire.anansi" checkBodySig :: [T.Variant] -> MarshalM T.Signature checkBodySig vs = let - sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs - invalid = E.throwError $ InvalidBodySignature sigStr - in case T.mkSignature sigStr of - Just x -> return x - Nothing -> invalid + sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs + invalid = E.throwError $ InvalidBodySignature sigStr + in case T.mkSignature sigStr of + Just x -> return x + Nothing -> invalid +#line 885 "src/wire.anansi" marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32 -> Marshal marshalHeader msg serial bodySig bodyLength = do - let fields = M.Signature bodySig : M.messageHeaderFields msg - marshal . T.toVariant . M.messageTypeCode $ msg - marshal . T.toVariant . encodeFlags . M.messageFlags $ msg - marshal . T.toVariant $ C.protocolVersion - marshalWord32 bodyLength - marshal . T.toVariant $ serial - let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant] - marshal . T.toVariant . fromJust . T.toArray fieldType - $ map encodeField fields + let fields = M.Signature bodySig : M.messageHeaderFields msg + marshal . T.toVariant . M.messageTypeCode $ msg + marshal . T.toVariant . encodeFlags . M.messageFlags $ msg + marshal . T.toVariant $ C.protocolVersion + marshalWord32 bodyLength + marshal . T.toVariant $ serial + let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant] + marshal . T.toVariant . fromJust . T.toArray fieldType + $ map encodeField fields +#line 900 "src/wire.anansi" marshalEndianness :: Endianness -> Marshal marshalEndianness = marshal . T.toVariant . encodeEndianness +#line 905 "src/wire.anansi" checkMaximumSize :: Marshal checkMaximumSize = do - (MarshalState _ _ messageLength) <- State.get - when (messageLength > fromIntegral C.messageMaximumLength) - (E.throwError $ MessageTooLong $ fromIntegral messageLength) - + (MarshalState _ _ messageLength) <- State.get + when (messageLength > fromIntegral C.messageMaximumLength) + (E.throwError $ MessageTooLong $ fromIntegral messageLength) diff --git a/hs/DBus/Wire/Unicode.hs b/hs/DBus/Wire/Unicode.hs --- a/hs/DBus/Wire/Unicode.hs +++ b/hs/DBus/Wire/Unicode.hs @@ -1,23 +1,26 @@ -{- - 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 . --} +#line 498 "src/wire.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 499 "src/wire.anansi" module DBus.Wire.Unicode - ( maybeEncodeUtf8 - , maybeDecodeUtf8) where + ( maybeEncodeUtf8 + , maybeDecodeUtf8) where import Data.ByteString.Lazy (ByteString) import Data.Text.Lazy (Text) import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) @@ -36,4 +39,3 @@ maybeDecodeUtf8 :: ByteString -> Maybe Text maybeDecodeUtf8 = excToMaybe . decodeUtf8 - diff --git a/hs/DBus/Wire/Unmarshal.hs b/hs/DBus/Wire/Unmarshal.hs --- a/hs/DBus/Wire/Unmarshal.hs +++ b/hs/DBus/Wire/Unmarshal.hs @@ -1,45 +1,63 @@ -{- - 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 . --} +#line 215 "src/wire.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 216 "src/wire.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} +#line 217 "src/wire.anansi" {-# LANGUAGE TypeFamilies #-} module DBus.Wire.Unmarshal where + +#line 56 "src/introduction.anansi" import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +#line 220 "src/wire.anansi" + +#line 231 "src/wire.anansi" import qualified Control.Monad.State as State import Control.Monad.Trans.Class (lift) import qualified DBus.Util.MonadError as E import qualified Data.ByteString.Lazy as L +#line 302 "src/wire.anansi" import qualified Data.Binary.Get as G +#line 448 "src/wire.anansi" import qualified Data.Binary.IEEE754 as IEEE +#line 540 "src/wire.anansi" import DBus.Wire.Unicode (maybeDecodeUtf8) +#line 763 "src/wire.anansi" import qualified DBus.Message.Internal as M +#line 769 "src/wire.anansi" import Data.Bits ((.&.)) import qualified Data.Set as Set +#line 915 "src/wire.anansi" import qualified DBus.Constants as C +#line 221 "src/wire.anansi" import Control.Monad (when, unless, liftM) import Data.Maybe (fromJust, listToMaybe, fromMaybe) import Data.Word (Word8, Word32, Word64) @@ -48,337 +66,392 @@ import DBus.Wire.Internal import qualified DBus.Types as T +#line 238 "src/wire.anansi" data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64 type Unmarshal = E.ErrorT UnmarshalError (State.State UnmarshalState) +#line 243 "src/wire.anansi" runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a runUnmarshal m e bytes = State.evalState (E.runErrorT m) state where - state = UnmarshalState e bytes 0 + state = UnmarshalState e bytes 0 +#line 249 "src/wire.anansi" unmarshal :: T.Signature -> Unmarshal [T.Variant] unmarshal = mapM unmarshalType . T.signatureTypes unmarshalType :: T.Type -> Unmarshal T.Variant + +#line 422 "src/wire.anansi" unmarshalType T.DBusByte = fmap (T.toVariant . L.head) $ consume 1 unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le unmarshalType T.DBusWord64 = unmarshalGet' 8 G.getWord64be G.getWord64le unmarshalType T.DBusInt16 = do - x <- unmarshalGet 2 G.getWord16be G.getWord16le - return . T.toVariant $ (fromIntegral x :: Int16) + x <- unmarshalGet 2 G.getWord16be G.getWord16le + return . T.toVariant $ (fromIntegral x :: Int16) unmarshalType T.DBusInt32 = do - x <- unmarshalGet 4 G.getWord32be G.getWord32le - return . T.toVariant $ (fromIntegral x :: Int32) + x <- unmarshalGet 4 G.getWord32be G.getWord32le + return . T.toVariant $ (fromIntegral x :: Int32) unmarshalType T.DBusInt64 = do - x <- unmarshalGet 8 G.getWord64be G.getWord64le - return . T.toVariant $ (fromIntegral x :: Int64) + x <- unmarshalGet 8 G.getWord64be G.getWord64le + return . T.toVariant $ (fromIntegral x :: Int64) +#line 463 "src/wire.anansi" unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le +#line 480 "src/wire.anansi" unmarshalType T.DBusBoolean = unmarshalWord32 >>= - fromMaybeU' "boolean" (\x -> case x of - 0 -> Just False - 1 -> Just True - _ -> Nothing) + fromMaybeU' "boolean" (\x -> case x of + 0 -> Just False + 1 -> Just True + _ -> Nothing) +#line 563 "src/wire.anansi" unmarshalType T.DBusString = fmap T.toVariant unmarshalText unmarshalType T.DBusObjectPath = unmarshalText >>= - fromMaybeU' "object path" T.mkObjectPath + fromMaybeU' "object path" T.mkObjectPath +#line 607 "src/wire.anansi" unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature +#line 623 "src/wire.anansi" unmarshalType (T.DBusArray t) = T.toVariant `fmap` unmarshalArray t +#line 705 "src/wire.anansi" unmarshalType (T.DBusDictionary kt vt) = do - let pairType = T.DBusStructure [kt, vt] - array <- unmarshalArray pairType - fromMaybeU' "dictionary" T.arrayToDictionary array + let pairType = T.DBusStructure [kt, vt] + array <- unmarshalArray pairType + fromMaybeU' "dictionary" T.arrayToDictionary array +#line 725 "src/wire.anansi" unmarshalType (T.DBusStructure ts) = do - skipPadding 8 - fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts + skipPadding 8 + fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts +#line 747 "src/wire.anansi" unmarshalType T.DBusVariant = do - let getType sig = case T.signatureTypes sig of - [t] -> Just t - _ -> Nothing - - t <- fromMaybeU "variant signature" getType =<< unmarshalSignature - T.toVariant `fmap` unmarshalType t - + let getType sig = case T.signatureTypes sig of + [t] -> Just t + _ -> Nothing + + t <- fromMaybeU "variant signature" getType =<< unmarshalSignature + T.toVariant `fmap` unmarshalType t +#line 259 "src/wire.anansi" consume :: Word64 -> Unmarshal L.ByteString consume count = do - (UnmarshalState e bytes offset) <- State.get - let (x, bytes') = L.splitAt (fromIntegral count) bytes - unless (L.length x == fromIntegral count) $ - E.throwError $ UnexpectedEOF offset - - State.put $ UnmarshalState e bytes' (offset + count) - return x + (UnmarshalState e bytes offset) <- State.get + let (x, bytes') = L.splitAt (fromIntegral count) bytes + unless (L.length x == fromIntegral count) $ + E.throwError $ UnexpectedEOF offset + + State.put $ UnmarshalState e bytes' (offset + count) + return x +#line 271 "src/wire.anansi" skipPadding :: Word8 -> Unmarshal () skipPadding count = do - (UnmarshalState _ _ offset) <- State.get - bytes <- consume $ padding offset count - unless (L.all (== 0) bytes) $ - E.throwError $ InvalidPadding offset + (UnmarshalState _ _ offset) <- State.get + bytes <- consume $ padding offset count + unless (L.all (== 0) bytes) $ + E.throwError $ InvalidPadding offset +#line 280 "src/wire.anansi" skipTerminator :: Unmarshal () skipTerminator = do - (UnmarshalState _ _ offset) <- State.get - bytes <- consume 1 - unless (L.all (== 0) bytes) $ - E.throwError $ MissingTerminator offset + (UnmarshalState _ _ offset) <- State.get + bytes <- consume 1 + unless (L.all (== 0) bytes) $ + E.throwError $ MissingTerminator offset +#line 289 "src/wire.anansi" fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b fromMaybeU label f x = case f x of - Just x' -> return x' - Nothing -> E.throwError . Invalid label . TL.pack . show $ x + Just x' -> return x' + Nothing -> E.throwError . Invalid label . TL.pack . show $ x fromMaybeU' :: (Show a, T.Variable b) => Text -> (a -> Maybe b) -> a -> Unmarshal T.Variant fromMaybeU' label f x = do - x' <- fromMaybeU label f x - return $ T.toVariant x' + x' <- fromMaybeU label f x + return $ T.toVariant x' +#line 306 "src/wire.anansi" unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a unmarshalGet count be le = do - skipPadding count - (UnmarshalState e _ _) <- State.get - bs <- consume . fromIntegral $ count - let get' = case e of - BigEndian -> be - LittleEndian -> le - return $ G.runGet get' bs + skipPadding count + (UnmarshalState e _ _) <- State.get + bs <- consume . fromIntegral $ count + let get' = case e of + BigEndian -> be + LittleEndian -> le + return $ G.runGet get' bs unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a -> Unmarshal T.Variant unmarshalGet' count be le = T.toVariant `fmap` unmarshalGet count be le +#line 322 "src/wire.anansi" 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 + done <- test + if done + then return [] + else do + x <- comp + xs <- untilM test comp + return $ x:xs +#line 349 "src/wire.anansi" data UnmarshalError - = UnsupportedProtocolVersion Word8 - | UnexpectedEOF Word64 - | Invalid Text Text - | MissingHeaderField Text - | InvalidHeaderField Text T.Variant - | InvalidPadding Word64 - | MissingTerminator Word64 - | ArraySizeMismatch - deriving (Eq) + = UnsupportedProtocolVersion Word8 + | UnexpectedEOF Word64 + | Invalid Text Text + | MissingHeaderField Text + | InvalidHeaderField Text T.Variant + | InvalidPadding Word64 + | MissingTerminator Word64 + | ArraySizeMismatch + deriving (Eq) instance Show UnmarshalError where - show (UnsupportedProtocolVersion x) = concat - ["Unsupported protocol version: ", show x] - show (UnexpectedEOF pos) = concat - ["Unexpected EOF at position ", show pos] - show (Invalid label x) = TL.unpack $ TL.concat - ["Invalid ", label, ": ", x] - show (MissingHeaderField x) = concat - ["Required field " , show x , " is missing."] - show (InvalidHeaderField x got) = concat - [ "Invalid header field ", show x, ": ", show got] - show (InvalidPadding pos) = concat - ["Invalid padding at position ", show pos] - show (MissingTerminator pos) = concat - ["Missing NUL terminator at position ", show pos] - show ArraySizeMismatch = "Array size mismatch" + show (UnsupportedProtocolVersion x) = concat + ["Unsupported protocol version: ", show x] + show (UnexpectedEOF pos) = concat + ["Unexpected EOF at position ", show pos] + show (Invalid label x) = TL.unpack $ TL.concat + ["Invalid ", label, ": ", x] + show (MissingHeaderField x) = concat + ["Required field " , show x , " is missing."] + show (InvalidHeaderField x got) = concat + [ "Invalid header field ", show x, ": ", show got] + show (InvalidPadding pos) = concat + ["Invalid padding at position ", show pos] + show (MissingTerminator pos) = concat + ["Missing NUL terminator at position ", show pos] + show ArraySizeMismatch = "Array size mismatch" +#line 407 "src/wire.anansi" unmarshalWord32 :: Unmarshal Word32 unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le +#line 544 "src/wire.anansi" unmarshalText :: Unmarshal Text unmarshalText = do - byteCount <- unmarshalWord32 - bytes <- consume . fromIntegral $ byteCount - skipTerminator - fromMaybeU "text" maybeDecodeUtf8 bytes + byteCount <- unmarshalWord32 + bytes <- consume . fromIntegral $ byteCount + skipTerminator + fromMaybeU "text" maybeDecodeUtf8 bytes +#line 589 "src/wire.anansi" unmarshalSignature :: Unmarshal T.Signature unmarshalSignature = do - byteCount <- L.head `fmap` consume 1 - bytes <- consume $ fromIntegral byteCount - sigText <- fromMaybeU "text" maybeDecodeUtf8 bytes - skipTerminator - fromMaybeU "signature" T.mkSignature sigText + byteCount <- L.head `fmap` consume 1 + bytes <- consume $ fromIntegral byteCount + sigText <- fromMaybeU "text" maybeDecodeUtf8 bytes + skipTerminator + fromMaybeU "signature" T.mkSignature sigText +#line 672 "src/wire.anansi" unmarshalArray :: T.Type -> Unmarshal T.Array unmarshalArray T.DBusByte = do - byteCount <- unmarshalWord32 - T.arrayFromBytes `fmap` consume (fromIntegral byteCount) + byteCount <- unmarshalWord32 + T.arrayFromBytes `fmap` consume (fromIntegral byteCount) +#line 679 "src/wire.anansi" unmarshalArray itemType = do - let getOffset = do - (UnmarshalState _ _ o) <- State.get - return o - byteCount <- unmarshalWord32 - skipPadding (alignment itemType) - start <- getOffset - let end = start + fromIntegral byteCount - vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType) - end' <- getOffset - when (end' > end) $ - E.throwError ArraySizeMismatch - fromMaybeU "array" (T.arrayFromItems itemType) vs + let getOffset = do + (UnmarshalState _ _ o) <- State.get + return o + byteCount <- unmarshalWord32 + skipPadding (alignment itemType) + start <- getOffset + let end = start + fromIntegral byteCount + vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType) + end' <- getOffset + when (end' > end) $ + E.throwError ArraySizeMismatch + fromMaybeU "array" (T.arrayFromItems itemType) vs +#line 786 "src/wire.anansi" decodeFlags :: Word8 -> Set.Set M.Flag decodeFlags word = Set.fromList flags where - flagSet = [ (0x1, M.NoReplyExpected) - , (0x2, M.NoAutoStart) - ] - flags = flagSet >>= \(x, y) -> [y | word .&. x > 0] + flagSet = [ (0x1, M.NoReplyExpected) + , (0x2, M.NoAutoStart) + ] + flags = flagSet >>= \(x, y) -> [y | word .&. x > 0] +#line 815 "src/wire.anansi" decodeField :: Monad m => T.Structure -> E.ErrorT UnmarshalError m [M.HeaderField] decodeField struct = case unpackField struct of - (1, x) -> decodeField' x M.Path "path" - (2, x) -> decodeField' x M.Interface "interface" - (3, x) -> decodeField' x M.Member "member" - (4, x) -> decodeField' x M.ErrorName "error name" - (5, x) -> decodeField' x M.ReplySerial "reply serial" - (6, x) -> decodeField' x M.Destination "destination" - (7, x) -> decodeField' x M.Sender "sender" - (8, x) -> decodeField' x M.Signature "signature" - _ -> return [] + (1, x) -> decodeField' x M.Path "path" + (2, x) -> decodeField' x M.Interface "interface" + (3, x) -> decodeField' x M.Member "member" + (4, x) -> decodeField' x M.ErrorName "error name" + (5, x) -> decodeField' x M.ReplySerial "reply serial" + (6, x) -> decodeField' x M.Destination "destination" + (7, x) -> decodeField' x M.Sender "sender" + (8, x) -> decodeField' x M.Signature "signature" + _ -> return [] decodeField' :: (Monad m, T.Variable a) => T.Variant -> (a -> b) -> Text -> E.ErrorT UnmarshalError m [b] decodeField' x f label = case T.fromVariant x of - Just x' -> return [f x'] - Nothing -> E.throwError $ InvalidHeaderField label x + Just x' -> return [f x'] + Nothing -> E.throwError $ InvalidHeaderField label x +#line 836 "src/wire.anansi" unpackField :: T.Structure -> (Word8, T.Variant) unpackField struct = (c', v') where - T.Structure [c, v] = struct - c' = fromJust . T.fromVariant $ c - v' = fromJust . T.fromVariant $ v + T.Structure [c, v] = struct + c' = fromJust . T.fromVariant $ c + v' = fromJust . T.fromVariant $ v +#line 923 "src/wire.anansi" + +#line 169 "src/api-docs.anansi" -- | Read bytes from a monad until a complete message has been received. +#line 924 "src/wire.anansi" unmarshalMessage :: Monad m => (Word32 -> m L.ByteString) -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do - let getBytes = lift . getBytes' - - let fixedSig = "yyyyuuu" - fixedBytes <- getBytes 16 + let getBytes = lift . getBytes' + - let messageVersion = L.index fixedBytes 3 - when (messageVersion /= C.protocolVersion) $ - E.throwError $ UnsupportedProtocolVersion messageVersion +#line 939 "src/wire.anansi" + let fixedSig = "yyyyuuu" + fixedBytes <- getBytes 16 - let eByte = L.index fixedBytes 0 - endianness <- case decodeEndianness eByte of - Just x' -> return x' - Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte +#line 948 "src/wire.anansi" + let messageVersion = L.index fixedBytes 3 + when (messageVersion /= C.protocolVersion) $ + E.throwError $ UnsupportedProtocolVersion messageVersion - let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of - Right x' -> return x' - Left e -> E.throwError e - fixed <- unmarshal' fixedSig fixedBytes - let typeCode = fromJust . T.fromVariant $ fixed !! 1 - let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2 - let bodyLength = fromJust . T.fromVariant $ fixed !! 4 - let serial = fromJust . T.fromVariant $ fixed !! 5 +#line 956 "src/wire.anansi" + let eByte = L.index fixedBytes 0 + endianness <- case decodeEndianness eByte of + Just x' -> return x' + Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte - let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6 +#line 966 "src/wire.anansi" + let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of + Right x' -> return x' + Left e -> E.throwError e + fixed <- unmarshal' fixedSig fixedBytes + let typeCode = fromJust . T.fromVariant $ fixed !! 1 + let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2 + let bodyLength = fromJust . T.fromVariant $ fixed !! 4 + let serial = fromJust . T.fromVariant $ fixed !! 5 - let headerSig = "yyyyuua(yv)" - fieldBytes <- getBytes fieldByteCount - let headerBytes = L.append fixedBytes fieldBytes - header <- unmarshal' headerSig headerBytes +#line 981 "src/wire.anansi" + let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6 - let fieldArray = fromJust . T.fromVariant $ header !! 6 - let fieldStructures = fromJust . T.fromArray $ fieldArray - fields <- concat `liftM` mapM decodeField fieldStructures +#line 930 "src/wire.anansi" - let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 - getBytes . fromIntegral $ bodyPadding +#line 988 "src/wire.anansi" + let headerSig = "yyyyuua(yv)" + fieldBytes <- getBytes fieldByteCount + let headerBytes = L.append fixedBytes fieldBytes + header <- unmarshal' headerSig headerBytes - let bodySig = findBodySignature fields +#line 997 "src/wire.anansi" + let fieldArray = fromJust . T.fromVariant $ header !! 6 + let fieldStructures = fromJust . T.fromArray $ fieldArray + fields <- concat `liftM` mapM decodeField fieldStructures - bodyBytes <- getBytes bodyLength - body <- unmarshal' bodySig bodyBytes +#line 931 "src/wire.anansi" - y <- case buildReceivedMessage typeCode fields of - EitherM (Right x) -> return x - EitherM (Left x) -> E.throwError $ MissingHeaderField x +#line 1006 "src/wire.anansi" + let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 + getBytes . fromIntegral $ bodyPadding - return $ y serial flags body +#line 1017 "src/wire.anansi" + let bodySig = findBodySignature fields +#line 1023 "src/wire.anansi" + bodyBytes <- getBytes bodyLength + body <- unmarshal' bodySig bodyBytes +#line 932 "src/wire.anansi" + +#line 1043 "src/wire.anansi" + y <- case buildReceivedMessage typeCode fields of + EitherM (Right x) -> return x + EitherM (Left x) -> E.throwError $ MissingHeaderField x + return $ y serial flags body + +#line 1011 "src/wire.anansi" findBodySignature :: [M.HeaderField] -> T.Signature findBodySignature fields = fromMaybe "" signature where - signature = listToMaybe [x | M.Signature x <- fields] + signature = listToMaybe [x | M.Signature x <- fields] +#line 1034 "src/wire.anansi" newtype EitherM a b = EitherM (Either a b) instance Monad (EitherM a) where - return = EitherM . Right - (EitherM (Left x)) >>= _ = EitherM (Left x) - (EitherM (Right x)) >>= k = k x + return = EitherM . Right + (EitherM (Left x)) >>= _ = EitherM (Left x) + (EitherM (Right x)) >>= k = k x +#line 1052 "src/wire.anansi" buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text (M.Serial -> (Set.Set M.Flag) -> [T.Variant] -> M.ReceivedMessage) +#line 1060 "src/wire.anansi" buildReceivedMessage 1 fields = do - path <- require "path" [x | M.Path x <- fields] - member <- require "member name" [x | M.Member x <- fields] - return $ \serial flags body -> let - iface = listToMaybe [x | M.Interface x <- fields] - dest = listToMaybe [x | M.Destination x <- fields] - sender = listToMaybe [x | M.Sender x <- fields] - msg = M.MethodCall path member iface dest flags body - in M.ReceivedMethodCall serial sender msg + path <- require "path" [x | M.Path x <- fields] + member <- require "member name" [x | M.Member x <- fields] + return $ \serial flags body -> let + iface = listToMaybe [x | M.Interface x <- fields] + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.MethodCall path member iface dest flags body + in M.ReceivedMethodCall serial sender msg +#line 1074 "src/wire.anansi" buildReceivedMessage 2 fields = do - replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] - return $ \serial _ body -> let - dest = listToMaybe [x | M.Destination x <- fields] - sender = listToMaybe [x | M.Sender x <- fields] - msg = M.MethodReturn replySerial dest body - in M.ReceivedMethodReturn serial sender msg + replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] + return $ \serial _ body -> let + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.MethodReturn replySerial dest body + in M.ReceivedMethodReturn serial sender msg +#line 1086 "src/wire.anansi" buildReceivedMessage 3 fields = do - name <- require "error name" [x | M.ErrorName x <- fields] - replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] - return $ \serial _ body -> let - dest = listToMaybe [x | M.Destination x <- fields] - sender = listToMaybe [x | M.Sender x <- fields] - msg = M.Error name replySerial dest body - in M.ReceivedError serial sender msg + name <- require "error name" [x | M.ErrorName x <- fields] + replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] + return $ \serial _ body -> let + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.Error name replySerial dest body + in M.ReceivedError serial sender msg +#line 1099 "src/wire.anansi" buildReceivedMessage 4 fields = do - path <- require "path" [x | M.Path x <- fields] - member <- require "member name" [x | M.Member x <- fields] - iface <- require "interface" [x | M.Interface x <- fields] - return $ \serial _ body -> let - dest = listToMaybe [x | M.Destination x <- fields] - sender = listToMaybe [x | M.Sender x <- fields] - msg = M.Signal path member iface dest body - in M.ReceivedSignal serial sender msg + path <- require "path" [x | M.Path x <- fields] + member <- require "member name" [x | M.Member x <- fields] + iface <- require "interface" [x | M.Interface x <- fields] + return $ \serial _ body -> let + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.Signal path member iface dest body + in M.ReceivedSignal serial sender msg +#line 1113 "src/wire.anansi" buildReceivedMessage typeCode fields = return $ \serial flags body -> let - sender = listToMaybe [x | M.Sender x <- fields] - msg = M.Unknown typeCode flags body - in M.ReceivedUnknown serial sender msg + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.Unknown typeCode flags body + in M.ReceivedUnknown serial sender msg +#line 1120 "src/wire.anansi" require :: Text -> [a] -> EitherM Text a require _ (x:_) = return x require label _ = EitherM $ Left label - diff --git a/hs/Tests.hs b/hs/Tests.hs --- a/hs/Tests.hs +++ b/hs/Tests.hs @@ -1,25 +1,32 @@ -{- - 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 . --} +#line 64 "src/introduction.anansi" + +#line 30 "src/introduction.anansi" +-- Copyright (C) 2009-2010 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 . + +#line 65 "src/introduction.anansi" + +#line 52 "src/introduction.anansi" {-# LANGUAGE OverloadedStrings #-} -module Main (tests) where +#line 66 "src/introduction.anansi" +module Main (tests, main) where + +#line 163 "src/util.anansi" import Test.QuickCheck -import Test.Framework (Test, testGroup) import qualified Test.Framework as F import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -27,6 +34,7 @@ import Control.Monad (replicateM) import qualified Data.Binary.Get as G import Data.Char (isPrint) +import Data.String import Data.List (intercalate, isInfixOf) import Data.Maybe (fromJust, isJust, isNothing) import qualified Data.Map as Map @@ -44,570 +52,541 @@ import DBus.Wire.Unmarshal import qualified DBus.Introspection as I -tests :: [Test] -tests = [ testGroup "Types" - [ testGroup "Atomic types" - [ - testGroup "Bool" $ commonVariantTests (arbitrary :: Gen Bool) - , testGroup "Word8" $ commonVariantTests (arbitrary :: Gen Word8) - , testGroup "Word16" $ commonVariantTests (arbitrary :: Gen Word16) - , testGroup "Word32" $ commonVariantTests (arbitrary :: Gen Word32) - , testGroup "Word64" $ commonVariantTests (arbitrary :: Gen Word64) - , testGroup "Int16" $ commonVariantTests (arbitrary :: Gen Int16) - , testGroup "Int32" $ commonVariantTests (arbitrary :: Gen Int32) - , testGroup "Int64" $ commonVariantTests (arbitrary :: Gen Int64) - , testGroup "Double" $ commonVariantTests (arbitrary :: Gen Double) - , testGroup "String" $ commonVariantTests (arbitrary :: Gen String) ++ - [ testProperty "String -> strict Text" - $ \x -> (fromVariant . toVariant) x == (Just $ T.pack x) - , testProperty "String <- strict Text" - $ \x -> (fromVariant . toVariant) x == (Just $ T.unpack x) - , testProperty "String -> lazy Text" - $ \x -> (fromVariant . toVariant) x == (Just $ TL.pack x) - , testProperty "String <- lazy Text" - $ \x -> (fromVariant . toVariant) x == (Just $ TL.unpack x) - , testProperty "Strict Text -> lazy Text" - $ \x -> (fromVariant . toVariant) x == (Just $ TL.pack . T.unpack $ x) - , testProperty "Strict Text <- lazy Text" - $ \x -> (fromVariant . toVariant) x == (Just $ T.pack . TL.unpack $ x) - ] - - , testGroup "Signature" $ commonVariantTests (arbitrary :: Gen Signature) ++ - [ testProperty "Signature identity" - $ \x -> (mkSignature . strSignature) x == Just x - , testProperty "Signature show" - $ \x -> show (strSignature x) `isInfixOf` show x - ] +#line 68 "src/introduction.anansi" - , testGroup "ObjectPath" $ commonVariantTests (arbitrary :: Gen ObjectPath) ++ - [ testProperty "ObjectPath identity" - $ \x -> (mkObjectPath . strObjectPath) x == Just x - ] +tests :: [F.Test] +tests = [ F.testGroup "dummy" [] - , testGroup "BusName" $ commonVariantTests (arbitrary :: Gen BusName) ++ - [ testProperty "BusName identity" - $ \x -> (mkBusName . strBusName) x == Just x - ] +#line 370 "src/types.anansi" + , F.testGroup "String" + [ testProperty "String -> strict Text" + $ funEq (fromVariant . toVariant) (Just . T.pack) + , testProperty "String <- strict Text" + $ funEq (fromVariant . toVariant) (Just . T.unpack) + , testProperty "String -> lazy Text" + $ funEq (fromVariant . toVariant) (Just . TL.pack) + , testProperty "String <- lazy Text" + $ funEq (fromVariant . toVariant) (Just . TL.unpack) + , testProperty "Strict Text -> lazy Text" + $ funEq (fromVariant . toVariant) (Just . TL.pack . T.unpack) + , testProperty "Strict Text <- lazy Text" + $ funEq (fromVariant . toVariant) (Just . T.pack . TL.unpack) + ] - , testGroup "InterfaceName" $ commonVariantTests (arbitrary :: Gen InterfaceName) ++ - [ testProperty "InterfaceName identity" - $ \x -> (mkInterfaceName . strInterfaceName) x == Just x - ] +#line 611 "src/types.anansi" + , F.testGroup "Signature" + [ testProperty "Signature identity" + $ funEq (mkSignature . strSignature) Just + ] - , testGroup "ErrorName" $ commonVariantTests (arbitrary :: Gen ErrorName) ++ - [ testProperty "ErrorName identity" - $ \x -> (mkErrorName . strErrorName) x == Just x - ] +#line 675 "src/types.anansi" + , F.testGroup "ObjectPath" + [ testProperty "ObjectPath identity" + $ funEq (mkObjectPath . strObjectPath) Just + ] - , testGroup "MemberName" $ commonVariantTests (arbitrary :: Gen MemberName) ++ - [ testProperty "MemberName identity" - $ \x -> (mkMemberName . strMemberName) x == Just x - ] +#line 822 "src/types.anansi" + , F.testGroup "Array" + [ testProperty "Array identity" + $ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x) + , testProperty "Array homogeneity" prop_ArrayHomogeneous + ] - ] - , testGroup "Container types" - [ - testGroup "Variant" $ commonVariantTests (arbitrary :: Gen Variant) +#line 950 "src/types.anansi" + , F.testGroup "Dictionary" + [ testProperty "Dictionary identity" + $ \x -> Just x == dictionaryFromItems + (dictionaryKeyType x) + (dictionaryValueType x) + (dictionaryItems x) + , testProperty "Dictionary homogeneity" prop_DictionaryHomogeneous + , testProperty "Dictionary must have atomic keys" + $ \vt -> forAll containerType $ \kt -> + isNothing (dictionaryFromItems kt vt []) + , testProperty "Dictionary <-> Array conversion" + $ funEq (arrayToDictionary . dictionaryToArray) Just + ] - , testGroup "Array" $ commonVariantTests (arbitrary :: Gen Array) ++ - [ testProperty "Array identity" - $ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x) - , testProperty "Array homogeneity" prop_ArrayHomogeneous - ] +#line 1110 "src/types.anansi" + , F.testGroup "BusName" + [ testProperty "BusName identity" + $ funEq (mkBusName . strBusName) Just + ] - , testGroup "Dictionary" $ commonVariantTests (arbitrary :: Gen Dictionary) ++ - [ testProperty "Dictionary identity" - $ \x -> Just x == dictionaryFromItems - (dictionaryKeyType x) - (dictionaryValueType x) - (dictionaryItems x) - , testProperty "Dictionary homogeneity" prop_DictionaryHomogeneous - , testProperty "Dictionary must have atomic keys" - $ \vt -> forAll containerType $ \kt -> - isNothing (dictionaryFromItems kt vt []) - , testProperty "Dictionary <-> Array conversion" - $ \x -> arrayToDictionary (dictionaryToArray x) == Just x - ] +#line 1157 "src/types.anansi" + , F.testGroup "InterfaceName" + [ testProperty "InterfaceName identity" + $ funEq (mkInterfaceName . strInterfaceName) Just + ] - , testGroup "Structure" $ commonVariantTests (arbitrary :: Gen Structure) +#line 1189 "src/types.anansi" + , F.testGroup "ErrorName" + [ testProperty "ErrorName identity" + $ funEq (mkErrorName . strErrorName) Just + ] - ] - ] +#line 1232 "src/types.anansi" + , F.testGroup "MemberName" + [ testProperty "MemberName identity" + $ funEq (mkMemberName . strMemberName) Just + ] - , testGroup "Addresses" - [ testProperty "Address identity" - $ \x -> mkAddresses (strAddress x) == Just [x] - , testProperty "Multiple addresses" - $ \x y -> let - joined = TL.concat [strAddress x, ";", strAddress y] - in mkAddresses joined == Just [x, y] - , testProperty "Ignore trailing semicolon" - $ \x -> mkAddresses (TL.append (strAddress x) ";") == Just [x] - , testProperty "Ignore trailing comma" - $ \x -> let - hasParams = not . Map.null . addressParameters $ x - parsed = mkAddresses (TL.append (strAddress x) ",") - in hasParams ==> parsed == Just [x] - , testGroup "Valid addresses" $ singleTests - [ isJust . mkAddresses $ ":" - , isJust . mkAddresses $ "a:" - , isJust . mkAddresses $ "a:b=c" - , isJust . mkAddresses $ "a:;" - , isJust . mkAddresses $ "a:;b:" - , isJust . mkAddresses $ "a:b=c," - ] - , testGroup "Invalid addresses" $ singleTests - [ isNothing . mkAddresses $ "" - , isNothing . mkAddresses $ "a" - , isNothing . mkAddresses $ "a:b" - , isNothing . mkAddresses $ "a:b=" - , isNothing . mkAddresses $ "a:," - ] - ] +#line 1161 "src/wire.anansi" + , F.testGroup "Wire format" + [ testProperty "Marshal -> Ummarshal" prop_Unmarshal + , F.testGroup "Messages" + [ testProperty "Method calls" prop_WireMethodCall + , testProperty "Method returns" prop_WireMethodReturn + , testProperty "Errors" prop_WireError + , testProperty "Signals" prop_WireSignal + ] + ] - , testGroup "Wire format" - [ testProperty "Marshal -> Ummarshal" prop_Unmarshal - , testGroup "Messages" - [ testProperty "Method calls" prop_WireMethodCall - , testProperty "Method returns" prop_WireMethodReturn - , testProperty "Errors" prop_WireError - , testProperty "Signals" prop_WireSignal - ] - ] +#line 177 "src/addresses.anansi" + , F.testGroup "Addresses" + [ testProperty "Address identity" + $ \x -> mkAddresses (strAddress x) == Just [x] + , testProperty "Multiple addresses" + $ \x y -> let + joined = TL.concat [strAddress x, ";", strAddress y] + in mkAddresses joined == Just [x, y] + , testProperty "Ignore trailing semicolon" + $ \x -> mkAddresses (TL.append (strAddress x) ";") == Just [x] + , testProperty "Ignore trailing comma" + $ \x -> let + hasParams = not . Map.null . addressParameters $ x + parsed = mkAddresses (TL.append (strAddress x) ",") + in hasParams ==> parsed == Just [x] + , F.testGroup "Valid addresses" + [ test "colon" $ isJust . mkAddresses $ ":" + , test "just scheme" $ isJust . mkAddresses $ "a:" + , test "param" $ isJust . mkAddresses $ "a:b=c" + , test "trailing semicolon" $ isJust . mkAddresses $ "a:;" + , test "two schemes" $ isJust . mkAddresses $ "a:;b:" + , test "trailing comma" $ isJust . mkAddresses $ "a:b=c," + ] + , F.testGroup "Invalid addresses" + [ test "empty" $ isNothing . mkAddresses $ "" + , test "no colon" $ isNothing . mkAddresses $ "a" + , test "no equals" $ isNothing . mkAddresses $ "a:b" + , test "no param" $ isNothing . mkAddresses $ "a:b=" + , test "no param" $ isNothing . mkAddresses $ "a:," + ] + ] - , testGroup "Introspection" - [ testProperty "Generate -> Parse" - $ \x@(I.Object path _ _) -> let - xml = I.toXML x - Just xml' = xml - parsed = I.fromXML path xml' - in isJust xml ==> I.fromXML path xml' == Just x - ] +#line 472 "src/introspection.anansi" + , F.testGroup "Introspection" + [ testProperty "Generate -> Parse" + $ \x@(I.Object path _ _) -> let + xml = I.toXML x + Just xml' = xml + parsed = I.fromXML path xml' + in isJust xml ==> I.fromXML path xml' == Just x + ] - ] +#line 72 "src/introduction.anansi" + ] main :: IO () main = F.defaultMain tests +#line 95 "src/types.anansi" +instance Arbitrary Type where + arbitrary = oneof [atomicType, containerType] + atomicType :: Gen Type atomicType = elements - [ DBusBoolean - , DBusByte - , DBusWord16 - , DBusWord32 - , DBusWord64 - , DBusInt16 - , DBusInt32 - , DBusInt64 - , DBusDouble - , DBusString - , DBusObjectPath - , DBusSignature - ] + [ DBusBoolean + , DBusByte + , DBusWord16 + , DBusWord32 + , DBusWord64 + , DBusInt16 + , DBusInt32 + , DBusInt64 + , DBusDouble + , DBusString + , DBusObjectPath + , DBusSignature + ] containerType :: Gen Type containerType = do - c <- choose (0,3) :: Gen Int - case c of - 0 -> fmap DBusArray arbitrary - 1 -> do - kt <- atomicType - vt <- arbitrary - return $ DBusDictionary kt vt - 2 -> fmap DBusStructure $ shrinkingGen arbitrary - 3 -> return DBusVariant - -instance Arbitrary Type where - arbitrary = oneof [atomicType, containerType] - -instance Arbitrary Signature where - arbitrary = clampedSize 255 genSig mkSignature_ where - genSig = fmap (TL.concat . map typeCode) arbitrary - -instance Arbitrary ObjectPath where - arbitrary = fmap (mkObjectPath_ . TL.pack) path' where - c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" - path = fmap (intercalate "/" . ([] :)) genElements - path' = frequency [(1, return "/"), (9, path)] - genElements = sized' 1 (sized' 1 (elements c)) - -instance Arbitrary BusName where - 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 . TL.pack $ ':' : intercalate "." elems' - - wellKnown = do - elems' <- sized' 2 $ elems c - return . TL.pack $ intercalate "." elems' - - elems start = do - x <- elements start - xs <- sized' 0 (elements c') - return (x:xs) - -instance Arbitrary InterfaceName where - arbitrary = clampedSize 255 genName mkInterfaceName_ where - c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" - c' = c ++ ['0'..'9'] - - genName = fmap (TL.pack . intercalate ".") genElements - genElements = sized' 2 genElement - genElement = do - x <- elements c - xs <- sized' 0 (elements c') - return (x:xs) - -instance Arbitrary ErrorName where - arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary - -instance Arbitrary MemberName where - 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 . TL.pack $ (x:xs) - -prop_VariantIdentity gen = testProperty "Variant identity" . forAll gen - $ \x -> (fromVariant . toVariant) x == Just x - -prop_VariantEquality gen = testProperty "Variant equality" . forAll gen - $ \x y -> (x == y) == (toVariant x == toVariant y) + c <- choose (0,3) :: Gen Int + case c of + 0 -> fmap DBusArray arbitrary + 1 -> do + kt <- atomicType + vt <- arbitrary + return $ DBusDictionary kt vt + 2 -> fmap DBusStructure $ halfSized arbitrary + 3 -> return DBusVariant -commonVariantTests gen = - [ prop_VariantIdentity gen - , prop_VariantEquality gen - ] +#line 258 "src/types.anansi" +instance Arbitrary Variant where + arbitrary = arbitrary >>= genVariant genVariant :: Type -> Gen Variant -genVariant DBusBoolean = fmap toVariant (arbitrary :: Gen Bool) -genVariant DBusByte = fmap toVariant (arbitrary :: Gen Word8) -genVariant DBusWord16 = fmap toVariant (arbitrary :: Gen Word16) -genVariant DBusWord32 = fmap toVariant (arbitrary :: Gen Word32) -genVariant DBusWord64 = fmap toVariant (arbitrary :: Gen Word64) -genVariant DBusInt16 = fmap toVariant (arbitrary :: Gen Int16) -genVariant DBusInt32 = fmap toVariant (arbitrary :: Gen Int32) -genVariant DBusInt64 = fmap toVariant (arbitrary :: Gen Int64) -genVariant DBusDouble = fmap toVariant (arbitrary :: Gen Double) -genVariant DBusString = fmap toVariant (arbitrary :: Gen String) -genVariant DBusObjectPath = fmap toVariant (arbitrary :: Gen ObjectPath) -genVariant DBusSignature = fmap toVariant (arbitrary :: Gen Signature) -genVariant (DBusArray _) = fmap toVariant (arbitrary :: Gen Array) -genVariant (DBusDictionary _ _) = fmap toVariant (arbitrary :: Gen Dictionary) -genVariant (DBusStructure _) = fmap toVariant (arbitrary :: Gen Structure) -genVariant DBusVariant = fmap toVariant (arbitrary :: Gen Variant) +genVariant t = case t of + DBusBoolean -> fmap toVariant (arbitrary :: Gen Bool) + DBusByte -> fmap toVariant (arbitrary :: Gen Word8) + DBusWord16 -> fmap toVariant (arbitrary :: Gen Word16) + DBusWord32 -> fmap toVariant (arbitrary :: Gen Word32) + DBusWord64 -> fmap toVariant (arbitrary :: Gen Word64) + DBusInt16 -> fmap toVariant (arbitrary :: Gen Int16) + DBusInt32 -> fmap toVariant (arbitrary :: Gen Int32) + DBusInt64 -> fmap toVariant (arbitrary :: Gen Int64) + DBusDouble -> fmap toVariant (arbitrary :: Gen Double) + DBusString -> fmap toVariant (arbitrary :: Gen String) + DBusObjectPath -> fmap toVariant (arbitrary :: Gen ObjectPath) + DBusSignature -> fmap toVariant (arbitrary :: Gen Signature) + (DBusArray _) -> fmap toVariant (arbitrary :: Gen Array) + (DBusDictionary _ _) -> fmap toVariant (arbitrary :: Gen Dictionary) + (DBusStructure _) -> fmap toVariant (arbitrary :: Gen Structure) + DBusVariant -> fmap toVariant (arbitrary :: Gen Variant) -instance Arbitrary Variant where - arbitrary = arbitrary >>= genVariant +#line 606 "src/types.anansi" +instance Arbitrary Signature where + arbitrary = sizedText 255 $ fmap (TL.concat . map typeCode) arbitrary -genAtom :: Type -> Gen Variant -genAtom DBusBoolean = fmap toVariant (arbitrary :: Gen Bool) -genAtom DBusByte = fmap toVariant (arbitrary :: Gen Word8) -genAtom DBusWord16 = fmap toVariant (arbitrary :: Gen Word16) -genAtom DBusWord32 = fmap toVariant (arbitrary :: Gen Word32) -genAtom DBusWord64 = fmap toVariant (arbitrary :: Gen Word64) -genAtom DBusInt16 = fmap toVariant (arbitrary :: Gen Int16) -genAtom DBusInt32 = fmap toVariant (arbitrary :: Gen Int32) -genAtom DBusInt64 = fmap toVariant (arbitrary :: Gen Int64) -genAtom DBusDouble = fmap toVariant (arbitrary :: Gen Double) -genAtom DBusString = fmap toVariant (arbitrary :: Gen String) -genAtom DBusObjectPath = fmap toVariant (arbitrary :: Gen ObjectPath) -genAtom DBusSignature = fmap toVariant (arbitrary :: Gen Signature) +#line 666 "src/types.anansi" +instance Arbitrary ObjectPath where + arbitrary = fmap (mkObjectPath_ . TL.pack) path' where + c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" + path = fmap (intercalate "/" . ([] :)) genElements + path' = frequency [(1, return "/"), (9, path)] + genElements = atLeast 1 (atLeast 1 (elements c)) +#line 806 "src/types.anansi" instance Arbitrary Array where - arbitrary = do - -- Only generate arrays of atomic values, as generating - -- containers randomly almost never results in a valid - -- array. - t <- atomicType - xs <- listOf $ genVariant t - return . fromJust $ arrayFromItems t xs + arbitrary = do + t <- atomicType + xs <- listOf $ genVariant t + return . fromJust $ arrayFromItems t xs prop_ArrayHomogeneous vs = isJust array == homogeneousTypes where - array = arrayFromItems firstType vs - homogeneousTypes = all (== firstType) types - types = map variantType vs - firstType = if null types - then DBusByte - else head types + array = arrayFromItems firstType vs + homogeneousTypes = all (== firstType) types + types = map variantType vs + firstType = if null types + then DBusByte + else head types +#line 932 "src/types.anansi" instance Arbitrary Dictionary where - arbitrary = do - -- Only generate dictionaries of atomic values, as generating - -- containers randomly almost never results in a valid - -- dictionary. - kt <- atomicType - vt <- atomicType - ks <- listOf $ genAtom kt - vs <- vectorOf (length ks) $ genVariant vt - - return . fromJust $ dictionaryFromItems kt vt $ zip ks vs + arbitrary = do + kt <- atomicType + vt <- atomicType + ks <- listOf $ genVariant kt + vs <- vectorOf (length ks) $ genVariant vt + + return . fromJust $ dictionaryFromItems kt vt $ zip ks vs prop_DictionaryHomogeneous x = all correctType pairs where - pairs = dictionaryItems x - kType = dictionaryKeyType x - vType = dictionaryValueType x - correctType (k, v) = variantType k == kType && - variantType v == vType + pairs = dictionaryItems x + kType = dictionaryKeyType x + vType = dictionaryValueType x + correctType (k, v) = variantType k == kType && + variantType v == vType +#line 1016 "src/types.anansi" instance Arbitrary Structure where - arbitrary = sized $ \n -> - fmap Structure $ shrinkingGen arbitrary + arbitrary = fmap Structure $ halfSized arbitrary -singleTests :: Testable a => [a] -> [Test] -singleTests ts = singleTests' 1 ts where - singleTests' _ [] = [] - singleTests' n (t:ts') = plusOptions (testProperty (name n) t) - : singleTests' (n + 1) ts' - - total = length ts - options = F.TestOptions Nothing (Just 1) Nothing Nothing - plusOptions = F.plusTestOptions options - name n = "Test " ++ show n ++ "/" ++ show total +#line 1090 "src/types.anansi" +instance Arbitrary BusName where + arbitrary = sizedText 255 (oneof [unique, wellKnown]) where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" + c' = c ++ ['0'..'9'] + + unique = do + elems' <- atLeast 2 $ elems c' + return . TL.pack $ ':' : intercalate "." elems' + + wellKnown = do + elems' <- atLeast 2 $ elems c + return . TL.pack $ intercalate "." elems' + + elems start = do + x <- elements start + xs <- atLeast 0 (elements c') + return (x:xs) -instance Arbitrary Address where - 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] = mkAddresses $ TL.pack addrStr - return addr +#line 1143 "src/types.anansi" +instance Arbitrary InterfaceName where + arbitrary = sizedText 255 genName where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + + genName = fmap (TL.pack . intercalate ".") genElements + genElements = atLeast 2 genElement + genElement = do + x <- elements c + xs <- atLeast 0 (elements c') + return (x:xs) -instance Arbitrary Serial where - arbitrary = fmap Serial arbitrary +#line 1184 "src/types.anansi" +instance Arbitrary ErrorName where + arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary +#line 1220 "src/types.anansi" +instance Arbitrary MemberName where + arbitrary = sizedText 255 genName where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + + genName = do + x <- elements c + xs <- atLeast 0 (elements c') + return . TL.pack $ (x:xs) + +#line 73 "src/messages.anansi" instance Arbitrary Flag where - arbitrary = elements [NoReplyExpected, NoAutoStart] + arbitrary = elements [NoReplyExpected, NoAutoStart] +#line 131 "src/messages.anansi" +instance Arbitrary Serial where + arbitrary = fmap Serial arbitrary + +#line 173 "src/messages.anansi" instance Arbitrary MethodCall where - arbitrary = do - path <- arbitrary - member <- arbitrary - iface <- arbitrary - dest <- arbitrary - flags <- fmap Set.fromList arbitrary - Structure body <- arbitrary - return $ MethodCall path member iface dest flags body + arbitrary = do + path <- arbitrary + member <- arbitrary + iface <- arbitrary + dest <- arbitrary + flags <- fmap Set.fromList arbitrary + Structure body <- arbitrary + return $ MethodCall path member iface dest flags body +#line 210 "src/messages.anansi" instance Arbitrary MethodReturn where - arbitrary = do - serial <- arbitrary - dest <- arbitrary - Structure body <- arbitrary - return $ MethodReturn serial dest body + arbitrary = do + serial <- arbitrary + dest <- arbitrary + Structure body <- arbitrary + return $ MethodReturn serial dest body +#line 261 "src/messages.anansi" instance Arbitrary Error where - arbitrary = do - name <- arbitrary - serial <- arbitrary - dest <- arbitrary - Structure body <- arbitrary - return $ Error name serial dest body + arbitrary = do + name <- arbitrary + serial <- arbitrary + dest <- arbitrary + Structure body <- arbitrary + return $ Error name serial dest body +#line 300 "src/messages.anansi" instance Arbitrary Signal where - arbitrary = do - path <- arbitrary - member <- arbitrary - iface <- arbitrary - dest <- arbitrary - Structure body <- arbitrary - return $ Signal path member iface dest body + arbitrary = do + path <- arbitrary + member <- arbitrary + iface <- arbitrary + dest <- arbitrary + Structure body <- arbitrary + return $ Signal path member iface dest body -isRight :: Either a b -> Bool -isRight = either (const False) (const True) +#line 58 "src/wire.anansi" +instance Arbitrary Endianness where + arbitrary = elements [LittleEndian, BigEndian] +#line 1126 "src/wire.anansi" prop_Unmarshal :: Endianness -> Variant -> Property prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where - sig = mkSignature . typeCode . variantType $ x - Just sig' = sig - - bytes = runMarshal (marshal x) e - Right bytes' = bytes - - valid = isJust sig && isRight bytes - unmarshaled = runUnmarshal (unmarshal sig') e bytes' + sig = mkSignature . typeCode . variantType $ x + Just sig' = sig + + bytes = runMarshal (marshal x) e + Right bytes' = bytes + + valid = isJust sig && isRight bytes + unmarshaled = runUnmarshal (unmarshal sig') e bytes' prop_MarshalMessage e serial msg expected = valid ==> correct where - bytes = marshalMessage e serial msg - Right bytes' = bytes - - getBytes = G.getLazyByteString . fromIntegral - unmarshaled = G.runGet (unmarshalMessage getBytes) bytes' - - valid = isRight bytes - correct = unmarshaled == Right expected + bytes = marshalMessage e serial msg + Right bytes' = bytes + + getBytes = G.getLazyByteString . fromIntegral + unmarshaled = G.runGet (unmarshalMessage getBytes) bytes' + + valid = isRight bytes + correct = unmarshaled == Right expected prop_WireMethodCall e serial msg = prop_MarshalMessage e serial msg - $ ReceivedMethodCall serial Nothing msg + $ ReceivedMethodCall serial Nothing msg prop_WireMethodReturn e serial msg = prop_MarshalMessage e serial msg - $ ReceivedMethodReturn serial Nothing msg + $ ReceivedMethodReturn serial Nothing msg prop_WireError e serial msg = prop_MarshalMessage e serial msg - $ ReceivedError serial Nothing msg + $ ReceivedError serial Nothing msg prop_WireSignal e serial msg = prop_MarshalMessage e serial msg - $ ReceivedSignal serial Nothing msg + $ ReceivedSignal serial Nothing msg -instance Arbitrary Endianness where - arbitrary = elements [LittleEndian, BigEndian] +#line 138 "src/addresses.anansi" +instance Arbitrary Address where + arbitrary = genAddress where + optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." + methodChars = filter (flip notElem ":;") ['!'..'~'] + keyChars = filter (flip notElem "=;,") ['!'..'~'] + + genMethod = atLeast 0 $ elements methodChars + genParam = do + key <- genKey + value <- genValue + return . concat $ [key, "=", value] + + genKey = atLeast 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 = atLeast 1 $ elements optional + + genParams = do + params <- atLeast 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] = mkAddresses $ TL.pack addrStr + return addr +#line 407 "src/introspection.anansi" subObject :: ObjectPath -> Gen I.Object subObject parentPath = sized $ \n -> resize (min n 4) $ do - let nonRoot = do - x <- arbitrary - case strObjectPath x of - "/" -> nonRoot - x' -> return x' - - thisPath <- nonRoot - let path' = case strObjectPath parentPath of - "/" -> thisPath - x -> TL.append x thisPath - let path = mkObjectPath_ path' - ifaces <- arbitrary - children <- shrinkingGen . listOf . subObject $ path - return $ I.Object path ifaces children + let nonRoot = do + x <- arbitrary + case strObjectPath x of + "/" -> nonRoot + x' -> return x' + + thisPath <- nonRoot + let path' = case strObjectPath parentPath of + "/" -> thisPath + x -> TL.append x thisPath + let path = mkObjectPath_ path' + ifaces <- arbitrary + children <- halfSized . listOf . subObject $ path + return $ I.Object path ifaces children instance Arbitrary I.Object where - arbitrary = arbitrary >>= subObject + arbitrary = arbitrary >>= subObject instance Arbitrary I.Interface where - arbitrary = do - name <- arbitrary - methods <- arbitrary - signals <- arbitrary - properties <- arbitrary - return $ I.Interface name methods signals properties + arbitrary = do + name <- arbitrary + methods <- arbitrary + signals <- arbitrary + properties <- arbitrary + return $ I.Interface name methods signals properties instance Arbitrary I.Method where - arbitrary = do - name <- arbitrary - inParams <- arbitrary - outParams <- arbitrary - return $ I.Method name inParams outParams + arbitrary = do + name <- arbitrary + inParams <- arbitrary + outParams <- arbitrary + return $ I.Method name inParams outParams instance Arbitrary I.Signal where - arbitrary = do - name <- arbitrary - params <- arbitrary - return $ I.Signal name params + arbitrary = do + name <- arbitrary + params <- arbitrary + return $ I.Signal name params singleType :: Gen Signature singleType = do - t <- arbitrary - case mkSignature $ typeCode t of - Just x -> return x - Nothing -> singleType + t <- arbitrary + case mkSignature $ typeCode t of + Just x -> return x + Nothing -> singleType instance Arbitrary I.Parameter where - arbitrary = do - name <- listOf $ arbitrary `suchThat` isPrint - sig <- singleType - return $ I.Parameter (TL.pack name) sig + arbitrary = do + name <- listOf $ arbitrary `suchThat` isPrint + sig <- singleType + return $ I.Parameter (TL.pack name) sig instance Arbitrary I.Property where - arbitrary = do - name <- listOf $ arbitrary `suchThat` isPrint - sig <- singleType - access <- elements - [[], [I.Read], [I.Write], - [I.Read, I.Write]] - return $ I.Property (TL.pack name) sig access + arbitrary = do + name <- listOf $ arbitrary `suchThat` isPrint + sig <- singleType + access <- elements + [[], [I.Read], [I.Write], + [I.Read, I.Write]] + return $ I.Property (TL.pack name) sig access -iexp :: Integral a => a -> a -> a -iexp x y = floor $ fromIntegral x ** fromIntegral y +#line 191 "src/util.anansi" +halfSized :: Gen a -> Gen a +halfSized gen = sized $ \n -> if n > 0 then + resize (n `div` 2) gen + else gen +funEq :: Eq b => (a -> b) -> (a -> b) -> a -> Bool +funEq f g x = f x == g x + +sizedText :: (IsString a, Arbitrary a) => Integer -> Gen TL.Text -> Gen a +sizedText maxSize gen = step where + step = do + s <- gen + if toInteger (TL.length s) > maxSize + then halfSized step + else return . fromString . TL.unpack $ s + +atLeast :: Int -> Gen a -> Gen [a] +atLeast minSize g = sized $ \n -> do + count <- choose (minSize, max minSize n) + replicateM count g + +isRight :: Either a b -> Bool +isRight = either (const False) (const True) + +#line 220 "src/util.anansi" +test :: Testable a => F.TestName -> a -> F.Test +test name prop = F.plusTestOptions options (testProperty name prop) where + options = F.TestOptions Nothing (Just 1) Nothing Nothing + +#line 229 "src/util.anansi" instance Arbitrary Word8 where - arbitrary = fmap fromIntegral gen where - gen = choose (0, max') :: Gen Integer - max' = iexp 2 8 - 1 + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral instance Arbitrary Word16 where - arbitrary = fmap fromIntegral gen where - gen = choose (0, max') :: Gen Integer - max' = iexp 2 16 - 1 + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral instance Arbitrary Word32 where - arbitrary = fmap fromIntegral gen where - gen = choose (0, max') :: Gen Integer - max' = iexp 2 32 - 1 + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral instance Arbitrary Word64 where - arbitrary = fmap fromIntegral gen where - gen = choose (0, max') :: Gen Integer - max' = iexp 2 64 - 1 + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral instance Arbitrary Int16 where - arbitrary = fmap fromIntegral gen where - gen = choose (0, max') :: Gen Integer - max' = iexp 2 16 - 1 + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral instance Arbitrary Int32 where - arbitrary = fmap fromIntegral gen where - gen = choose (0, max') :: Gen Integer - max' = iexp 2 32 - 1 + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral instance Arbitrary Int64 where - arbitrary = fmap fromIntegral gen where - gen = choose (0, max') :: Gen Integer - max' = iexp 2 64 - 1 + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral instance Arbitrary T.Text where - arbitrary = fmap T.pack arbitrary + arbitrary = fmap T.pack arbitrary instance Arbitrary TL.Text where - arbitrary = fmap TL.pack arbitrary - -sized' :: Int -> Gen a -> Gen [a] -sized' atLeast g = sized $ \n -> do - n' <- choose (atLeast, max atLeast n) - replicateM n' g - -clampedSize :: Arbitrary a => Int64 -> Gen TL.Text -> (TL.Text -> a) -> Gen a -clampedSize maxSize gen f = do - s <- gen - if TL.length s > maxSize - then shrinkingGen arbitrary - else return . f $ s - -shrinkingGen :: Gen a -> Gen a -shrinkingGen gen = sized $ \n -> if n > 0 then - resize (n `div` 2) gen - else gen - + arbitrary = fmap TL.pack arbitrary diff --git a/readme.txt b/readme.txt new file mode 100644 --- /dev/null +++ b/readme.txt @@ -0,0 +1,10 @@ +The source code for "dbus-core" is literate. To build the library from scratch, +install the "anansi" application and then run: + + anansi -o hs/ src/dbus-core.anansi + +To generate the woven PDF, run: + + anansi -w -l latex-noweb -o dbus-core.tex src/dbus-core.anansi + xelatex dbus-core.tex + xelatex dbus-core.tex diff --git a/src/addresses.anansi b/src/addresses.anansi new file mode 100644 --- /dev/null +++ b/src/addresses.anansi @@ -0,0 +1,207 @@ +:# Copyright (C) 2009-2010 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 . + +\section{Addresses} + +:f DBus/Address.hs +|copyright| +|text extensions| +module DBus.Address + ( Address + , addressMethod + , addressParameters + , mkAddresses + , strAddress + ) where +|text imports| + +import Data.Char (ord, chr) +import qualified Data.Map as M +import Text.Printf (printf) +import qualified Text.Parsec as P +import Text.Parsec ((<|>)) +import DBus.Util (hexToInt, eitherToMaybe) +: + +\subsection{Address syntax} + +A bus address is in the format {\tt $method$:$key$=$value$,$key$=$value$...} +where the method may be empty and parameters are optional. An address's +parameter list, if present, may end with a comma. Addresses in environment +variables are separated by semicolons, and the full address list may end +in a semicolon. Multiple parameters may have the same key; in this case, +only the first parameter for each key will be stored. + +The bytes allowed in each component of the address are given by the following +chart, where each character is understood to be its ASCII value: + +\begin{table}[h] +\begin{center} +\begin{tabular}{ll} +\toprule +Component & Allowed Characters \\ +\midrule +Method & Any except {\tt `;'} and {\tt `:'} \\ +Param key & Any except {\tt `;'}, {\tt `,'}, and {\tt `='} \\ +Param value & {\tt `0'} to {\tt `9'} \\ + & {\tt `a'} to {\tt `z'} \\ + & {\tt `A'} to {\tt `Z'} \\ + & Any of: {\tt - \textunderscore{} / \textbackslash{} * . \%} \\ +\bottomrule +\end{tabular} +\end{center} +\end{table} + +In parameter values, any byte may be encoded by prepending the \% character +to its value in hexadecimal. \% is not allowed to appear unless it is +followed by two hexadecimal digits. Every other allowed byte is termed +an ``optionally encoded'' byte, and may appear unescaped in parameter +values. + +:f DBus/Address.hs +optionallyEncoded :: [Char] +optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." +: + +The address simply stores its method and parameter map, with a custom +{\tt Show} instance to provide easier debugging. + +:f DBus/Address.hs +data Address = Address + { addressMethod :: Text + , addressParameters :: M.Map Text Text + } deriving (Eq) + +instance Show Address where + showsPrec d x = showParen (d> 10) $ + showString "Address " . shows (strAddress x) +: + +Parsing is straightforward; the input string is divided into addresses by +semicolons, then further by colons and commas. Parsing will fail if any +of the addresses in the input failed to parse. + +:f DBus/Address.hs +mkAddresses :: Text -> Maybe [Address] +mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where + address = do + method <- P.many (P.noneOf ":;") + P.char ':' + params <- P.sepEndBy param (P.char ',') + return $ Address (TL.pack method) (M.fromList params) + + param = do + key <- P.many1 (P.noneOf "=;,") + P.char '=' + value <- P.many1 (encodedValue <|> unencodedValue) + return (TL.pack key, TL.pack value) + + parser = do + as <- P.sepEndBy1 address (P.char ';') + P.eof + return as + + unencodedValue = P.oneOf optionallyEncoded + encodedValue = do + P.char '%' + hex <- P.count 2 P.hexDigit + return . chr . hexToInt $ hex +: + +Converting an {\tt Address} back to a {\tt String} is just the reverse +operation. Note that because the original parameter order is not preserved, +the string produced might differ from the original input. + +:f DBus/Address.hs +strAddress :: Address -> Text +strAddress (Address t ps) = TL.concat [t, ":", ps'] where + ps' = TL.intercalate "," $ do + (k, v) <- M.toList ps + return $ TL.concat [k, "=", TL.concatMap encode v] + encode c | elem c optionallyEncoded = TL.singleton c + | otherwise = TL.pack $ printf "%%%02X" (ord c) +: + +:f Tests.hs +instance Arbitrary Address where + arbitrary = genAddress where + optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*." + methodChars = filter (flip notElem ":;") ['!'..'~'] + keyChars = filter (flip notElem "=;,") ['!'..'~'] + + genMethod = atLeast 0 $ elements methodChars + genParam = do + key <- genKey + value <- genValue + return . concat $ [key, "=", value] + + genKey = atLeast 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 = atLeast 1 $ elements optional + + genParams = do + params <- atLeast 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] = mkAddresses $ TL.pack addrStr + return addr +: + +:d test cases +, F.testGroup "Addresses" + [ testProperty "Address identity" + $ \x -> mkAddresses (strAddress x) == Just [x] + , testProperty "Multiple addresses" + $ \x y -> let + joined = TL.concat [strAddress x, ";", strAddress y] + in mkAddresses joined == Just [x, y] + , testProperty "Ignore trailing semicolon" + $ \x -> mkAddresses (TL.append (strAddress x) ";") == Just [x] + , testProperty "Ignore trailing comma" + $ \x -> let + hasParams = not . Map.null . addressParameters $ x + parsed = mkAddresses (TL.append (strAddress x) ",") + in hasParams ==> parsed == Just [x] + , F.testGroup "Valid addresses" + [ test "colon" $ isJust . mkAddresses $ ":" + , test "just scheme" $ isJust . mkAddresses $ "a:" + , test "param" $ isJust . mkAddresses $ "a:b=c" + , test "trailing semicolon" $ isJust . mkAddresses $ "a:;" + , test "two schemes" $ isJust . mkAddresses $ "a:;b:" + , test "trailing comma" $ isJust . mkAddresses $ "a:b=c," + ] + , F.testGroup "Invalid addresses" + [ test "empty" $ isNothing . mkAddresses $ "" + , test "no colon" $ isNothing . mkAddresses $ "a" + , test "no equals" $ isNothing . mkAddresses $ "a:b" + , test "no param" $ isNothing . mkAddresses $ "a:b=" + , test "no param" $ isNothing . mkAddresses $ "a:," + ] + ] +: diff --git a/src/api-docs.anansi b/src/api-docs.anansi new file mode 100644 --- /dev/null +++ b/src/api-docs.anansi @@ -0,0 +1,170 @@ +:# Copyright (C) 2009-2010 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 . + +\section{Haddock API documentation} + +The \LaTeX{} documentation is great for somebody reading the source code +or trying to fix an error, but it's not useful for people who just want +to add D-Bus support to their applications. These documentation sections +will be included in Haddock output for public functions. + +There's no real order to this section; it exists only because Haddock +can't merge documentation from external files. + +:d apidoc isAtomicType +-- | \"Atomic\" types are any which can't contain any other types. Only +-- atomic types may be used as dictionary keys. +: + +:d apidoc typeCode +-- | Every type has an associated type code; a textual representation of +-- the type, useful for debugging. +: + +:d apidoc Variant +-- | 'Variant's may contain any other built-in D-Bus value. Besides +-- representing native @VARIANT@ values, they allow type-safe storage and +-- deconstruction of heterogeneous collections. +: + +:d apidoc variantType +-- | Every variant is strongly-typed; that is, the type of its contained +-- value is known at all times. This function retrieves that type, so that +-- the correct cast can be used to retrieve the value. +: + +:d apidoc arrayType +-- | This is the type contained within the array, not the type of the array +-- itself. +: + +:d apidoc Connection +-- | A 'Connection' is an opaque handle to an open D-Bus channel, with an +-- internal state for maintaining the current message serial. +: + +:d apidoc Transport +-- | A 'Transport' is anything which can send and receive bytestrings, +-- typically via a socket. +: + +:d apidoc connect +-- | Open a connection to some address, using a given authentication +-- mechanism. If the connection fails, a 'ConnectionError' will be thrown. +: + +:d apidoc connectFirst +-- | Try to open a connection to various addresses, returning the first +-- connection which could be successfully opened. +: + +:d apidoc connectionClose +-- | Close an open connection. Once closed, the 'Connection' is no longer +-- valid and must not be used. +: + +:d apidoc send +-- | Send a single message, with a generated 'M.Serial'. The second parameter +-- exists to prevent race conditions when registering a reply handler; it +-- receives the serial the message /will/ be sent with, before it's actually +-- sent. +-- +-- Only one message may be sent at a time; if multiple threads attempt to +-- send messages in parallel, one will block until after the other has +-- finished. +: + +:d apidoc receive +-- | Receive the next message from the connection, blocking until one is +-- available. +-- +-- Only one message may be received at a time; if multiple threads attempt +-- to receive messages in parallel, one will block until after the other has +-- finished. +: + +:d apidoc getBus +-- | Similar to 'C.connect', but additionally sends @Hello@ messages to the +-- central bus. +: + +:d apidoc getFirstBus +-- | Similar to 'C.connectFirst', but additionally sends @Hello@ messages to +-- the central bus. +: + +:d apidoc getSystemBus +-- | Connect to the bus specified in the environment variable +-- @DBUS_SYSTEM_BUS_ADDRESS@, or to +-- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@ +-- is not set. +: + +:d apidoc getSessionBus +-- | Connect to the bus specified in the environment variable +-- @DBUS_SESSION_BUS_ADDRESS@, which must be set. +: + +:d apidoc getStarterBus +-- | Connect to the bus specified in the environment variable +-- @DBUS_STARTER_ADDRESS@, which must be set. +: + +:d apidoc formatRule +-- | Format a 'MatchRule' as the bus expects to receive in a call to +-- @AddMatch@. +: + +:d apidoc addMatch +-- | Build a 'M.MethodCall' for adding a match rule to the bus. +: + +:d apidoc matchAll +-- | An empty match rule, which matches everything. +: + +:d apidoc matches +-- | Whether a 'M.ReceivedMessage' matches a given rule. This is useful +-- for implementing signal handlers. +: + +:d apidoc requestName +-- | Build a 'M.MethodCall' for requesting a registered bus name. +: + +:d apidoc releaseName +-- | Build a 'M.MethodCall' for releasing a registered bus name. +: + +:d apidoc Serial +-- | A value used to uniquely identify a particular message within a session. +-- 'Serial's are 32-bit unsigned integers, and eventually wrap. +: + +:d apidoc ReceivedMessage +-- | Not an actual message type, but a wrapper around messages received from +-- the bus. Each value contains the message's 'Serial' and possibly the +-- origin's 'T.BusName' +: + +:d apidoc marshalMessage +-- | Convert a 'M.Message' into a 'L.ByteString'. Although unusual, it is +-- possible for marshaling to fail -- if this occurs, an appropriate error +-- will be returned instead. +: + +:d apidoc unmarshalMessage +-- | Read bytes from a monad until a complete message has been received. +: diff --git a/src/authentication.anansi b/src/authentication.anansi new file mode 100644 --- /dev/null +++ b/src/authentication.anansi @@ -0,0 +1,147 @@ +:# Copyright (C) 2009-2010 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 . + +\subsection{Authentication} + +Authentication is a bit iffy; currently, there's a one specified +authentication mechanism ({\tt DBUS\_COOKIE\_SHA1}), which I've never seen +in the wild. Everybody seems to use {\tt EXTERNAL}, described below. + +To support multiple modes more easily in the future, and for user-defined +authentication handling (eg, in proxy servers), authentication is handled by +a separate module. + +:f DBus/Authentication.hs +|copyright| +|text extensions| +{-# LANGUAGE DeriveDataTypeable #-} +module DBus.Authentication + ( Command + , Mechanism (..) + , AuthenticationError (..) + , authenticate + , realUserID + ) where +|text imports| +|authentication imports| +: + +The authentication protocol is based on {\sc ascii} text, initiated by the +client. Commands and mechanisms are represented by a couple data types: + +:d authentication imports +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as ByteString +import qualified DBus.UUID as UUID +: + +:f DBus/Authentication.hs +type Command = Text +newtype Mechanism = Mechanism + { mechanismRun :: (Command -> IO Command) -> IO UUID.UUID + } +: + +If authentication fails, an exception will be raised. + +:d authentication imports +import Data.Typeable (Typeable) +import qualified Control.Exception as E +: + +:f DBus/Authentication.hs +data AuthenticationError + = AuthenticationError Text + deriving (Show, Typeable) + +instance E.Exception AuthenticationError +: + +The process begins by the client sending a single {\sc nul} byte, followed +by exchanges of {\sc ascii} commands until authentication is complete. Which +commands are sent depends on the selected mechanism. + +:d authentication imports +import Data.Word (Word8) +: + +:f DBus/Authentication.hs +authenticate :: Mechanism -> (ByteString -> IO ()) -> IO Word8 + -> IO UUID.UUID +authenticate mech put getByte = do + put $ ByteString.singleton 0 + uuid <- mechanismRun mech (putCommand put getByte) + put "BEGIN\r\n" + return uuid +: + +TODO: describe {\tt putCommand} here + +:d authentication imports +import Control.Monad (liftM) +import Data.Char (chr) +import Data.Text.Lazy.Encoding (encodeUtf8) +import DBus.Util (readUntil, dropEnd) +: + +:f DBus/Authentication.hs +putCommand :: Monad m => (ByteString -> m ()) -> m Word8 -> Command -> m Command +putCommand put get cmd = do + let getC = liftM (chr . fromIntegral) get + put $ encodeUtf8 cmd + put "\r\n" + liftM (TL.pack . dropEnd 2) $ readUntil "\r\n" getC +: + +\subsubsection{Support authentication mechanisms} + +Currently, the only supported authentication mechanism is sending the local +user's ``real user ID''. + +:d authentication imports +import System.Posix.User (getRealUserID) +import Data.Char (ord) +import Text.Printf (printf) +: + +:f DBus/Authentication.hs +realUserID :: Mechanism +realUserID = Mechanism $ \sendCmd -> do + uid <- getRealUserID + let token = concatMap (printf "%02X" . ord) (show uid) + let cmd = "AUTH EXTERNAL " ++ token + eitherUUID <- checkOK `fmap` sendCmd (TL.pack cmd) + case eitherUUID of + Right uuid -> return uuid + Left err -> E.throwIO $ AuthenticationError err +: + +If authentication was successful, the server responds with {\tt OK +}. + +:d authentication imports +import Data.Maybe (isJust) +: + +:f DBus/Authentication.hs +checkOK :: Command -> Either Text UUID.UUID +checkOK cmd = if validUUID then Right uuid else Left errorMsg where + validUUID = TL.isPrefixOf "OK " cmd && isJust maybeUUID + maybeUUID = UUID.fromHex $ TL.drop 3 cmd + Just uuid = maybeUUID + errorMsg = if TL.isPrefixOf "ERROR " cmd + then TL.drop 6 cmd + else TL.pack $ "Unexpected response: " ++ show cmd +: diff --git a/src/bus.anansi b/src/bus.anansi new file mode 100644 --- /dev/null +++ b/src/bus.anansi @@ -0,0 +1,140 @@ +:# Copyright (C) 2009-2010 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 . + +\section{The central bus} + +:f DBus/Bus.hs +|copyright| +|text extensions| +module DBus.Bus + ( getBus + , getFirstBus + , getSystemBus + , getSessionBus + , getStarterBus + ) where +|text imports| + +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 DBus.Address as A +import qualified DBus.Authentication as Auth +import qualified DBus.Connection as C +import DBus.Constants (dbusName, dbusPath, dbusInterface) +import qualified DBus.Message as M +import qualified DBus.Types as T +import DBus.Util (fromRight) +: + +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. + +:f DBus/Bus.hs +busForConnection :: C.Connection -> IO (C.Connection, T.BusName) +busForConnection c = fmap ((,) c) $ sendHello c + +|apidoc getBus| +getBus :: Auth.Mechanism -> A.Address -> IO (C.Connection, T.BusName) +getBus = ((busForConnection =<<) .) . C.connect +: + +Optionally, multiple addresses may be provided. The first successful +connection will be used. + +:f DBus/Bus.hs +|apidoc getFirstBus| +getFirstBus :: [(Auth.Mechanism, A.Address)] -> IO (C.Connection, T.BusName) +getFirstBus = (busForConnection =<<) . C.connectFirst +: + +\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. + +:f DBus/Bus.hs +|apidoc getSystemBus| +getSystemBus :: IO (C.Connection, T.BusName) +getSystemBus = getBus' $ fromEnv `E.catch` noEnv where + defaultAddr = "unix:path=/var/run/dbus/system_bus_socket" + fromEnv = getEnv "DBUS_SYSTEM_BUS_ADDRESS" + noEnv (E.SomeException _) = return defaultAddr + +|apidoc getSessionBus| +getSessionBus :: IO (C.Connection, T.BusName) +getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS" + +|apidoc getStarterBus| +getStarterBus :: IO (C.Connection, T.BusName) +getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS" +: + +:f DBus/Bus.hs +getBus' :: IO String -> IO (C.Connection, T.BusName) +getBus' io = do + addr <- fmap TL.pack io + case A.mkAddresses addr of + Just [x] -> getBus Auth.realUserID x + Just xs -> getFirstBus [(Auth.realUserID,x) | x <- xs] + _ -> E.throwIO $ C.InvalidAddress addr +: + +\subsection{Sending the ``hello'' message} + +:f DBus/Bus.hs +hello :: M.MethodCall +hello = M.MethodCall dbusPath + "Hello" + (Just dbusInterface) + (Just dbusName) + Set.empty + [] +: + +:f DBus/Bus.hs +sendHello :: C.Connection -> IO T.BusName +sendHello c = do + serial <- fromRight `fmap` 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 $ E.AssertionFailed "Invalid response to Hello()" + + return . fromJust $ name +: + +:f DBus/Bus.hs +waitForReply :: C.Connection -> M.Serial -> IO M.MethodReturn +waitForReply c serial = do + received <- C.receive c + msg <- case received of + Right x -> return x + Left _ -> E.throwIO $ E.AssertionFailed "Invalid response to Hello()" + case msg of + (M.ReceivedMethodReturn _ _ reply) -> + if M.methodReturnSerial reply == serial + then return reply + else waitForReply c serial + _ -> waitForReply c serial +: diff --git a/src/connections.anansi b/src/connections.anansi new file mode 100644 --- /dev/null +++ b/src/connections.anansi @@ -0,0 +1,392 @@ +:# Copyright (C) 2009-2010 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 . + +\section{Connections} + +:f DBus/Connection.hs +|copyright| +|text extensions| +{-# LANGUAGE DeriveDataTypeable #-} +module DBus.Connection ( + |connection exports| + ) where +|text imports| +|connection imports| +: + +A {\tt Connection} is an opaque handle to an open D-Bus channel, with +an internal state for maintaining the current message serial. + +The second {\tt MVar} doesn't really store a value, it's just used to +prevent two separate threads from reading from the transport at once. + +:d connection imports +import qualified Control.Concurrent as C +import qualified DBus.Address as A +import qualified DBus.Message as M +import qualified DBus.UUID as UUID +: + +:f DBus/Connection.hs +data Connection = Connection + { connectionAddress :: A.Address + , connectionTransport :: Transport + , connectionSerialMVar :: C.MVar M.Serial + , connectionReadMVar :: C.MVar () + , connectionUUID :: UUID.UUID + } +: + +:d connection exports + Connection +, connectionAddress +, connectionUUID +: + +While not particularly useful for other functions, being able to +{\tt show} a {\tt Connection} is useful when debugging. + +:f DBus/Connection.hs +instance Show Connection where + showsPrec d con = showParen (d > 10) strCon where + addr = A.strAddress $ connectionAddress con + strCon = s "" + s = showString +: + +\subsection{Transports} + +A transport is anything which can send and receive bytestrings, typically +via a socket. + +:d connection imports +import qualified Data.ByteString.Lazy as L +import Data.Word (Word32) +: + +:f DBus/Connection.hs +|apidoc Transport| +data Transport = Transport + { transportSend :: L.ByteString -> IO () + , transportRecv :: Word32 -> IO L.ByteString + , transportClose :: IO () + } +: + +If a method has no known transport, attempting to connect using it will +just result in an exception. + +:f DBus/Connection.hs +connectTransport :: A.Address -> IO Transport +connectTransport a = transport' (A.addressMethod a) a where + transport' "unix" = unix + transport' "tcp" = tcp + transport' _ = E.throwIO . UnknownMethod +: + +\subsubsection{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. + +:d connection imports +import qualified Network as N +import qualified Data.Map as Map +: + +:f DBus/Connection.hs +unix :: A.Address -> IO Transport +unix a = port >>= N.connectTo "localhost" >>= handleTransport 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' transport." + 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 a tooMany + (Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew + (Just x, Nothing) -> return $ TL.unpack x + (Nothing, Just x) -> return $ '\x00' : TL.unpack x +: + +\subsubsection{TCP} + +The {\sc tcp} transport has three parameters: + +\begin{itemize} +\item {\tt host} -- optional, defaults to {\tt "localhost"} +\item {\tt port} -- unsigned 16-bit integer +\item {\tt family} -- optional, defaults to {\sc unspec}, choices are + {\tt "ipv4"} or {\tt "ipv6"} +\end{itemize} + +The high-level {\tt Network} module doesn't provide enough control over +socket construction for this transport, so {\tt Network.Socket} must be +imported. + +:d connection imports +import qualified Network.Socket as NS +: + +:f DBus/Connection.hs +tcp :: A.Address -> IO Transport +tcp a = openHandle >>= handleTransport where + params = A.addressParameters a + openHandle = do + port <- getPort + family <- getFamily + addresses <- getAddresses family + socket <- openSocket port addresses + NS.socketToHandle socket I.ReadWriteMode +: + +Parameter parsing... + +:f DBus/Connection.hs + hostname = maybe "localhost" TL.unpack $ Map.lookup "host" params +: + +:f DBus/Connection.hs + unknownFamily x = TL.concat ["Unknown socket family for TCP transport: ", x] + getFamily = case Map.lookup "family" params of + Just "ipv4" -> return NS.AF_INET + Just "ipv6" -> return NS.AF_INET6 + Nothing -> return NS.AF_UNSPEC + Just x -> E.throwIO $ BadParameters a $ unknownFamily x +: + +:f DBus/Connection.hs + missingPort = "TCP transport requires the ``port'' parameter." + badPort x = TL.concat ["Invalid socket port for TCP transport: ", x] + getPort = case Map.lookup "port" params of + Nothing -> E.throwIO $ BadParameters a missingPort + Just x -> case P.parse parseWord16 "" (TL.unpack x) of + Right x' -> return $ NS.PortNum x' + Left _ -> E.throwIO $ BadParameters a $ badPort x +: + +Parsing the port is a bit complicated; assuming every character is an ASCII +digit, the port is converted to an {\tt Integer} and confirmed valid. +{\tt PortNumber} is expected to be in big-endian byte order, so the parsed +value must be converted from host order using {\tt Data.Binary}. + +:d connection imports +import qualified Text.Parsec as P +import Control.Monad (unless) +import Data.Binary.Get (runGet, getWord16host) +import Data.Binary.Put (runPut, putWord16be) +: + +:f DBus/Connection.hs + parseWord16 = do + chars <- P.many1 P.digit + P.eof + let value = read chars :: Integer + unless (value > 0 && value <= 65535) $ + P.parserFail "bad port" >> return () + let word = fromIntegral value + return $ runGet getWord16host (runPut (putWord16be word)) +: + +:f DBus/Connection.hs + getAddresses family = do + let hints = NS.defaultHints + { NS.addrFlags = [NS.AI_ADDRCONFIG] + , NS.addrFamily = family + , NS.addrSocketType = NS.Stream + } + NS.getAddrInfo (Just hints) (Just hostname) Nothing +: + +The {\tt SockAddr} values returned from {\tt getAddrInfo} don't have any +port set, so it must be manually changed to whatever was in the {\tt port} +option. + +:f DBus/Connection.hs + setPort port (NS.SockAddrInet _ x) = NS.SockAddrInet port x + setPort port (NS.SockAddrInet6 _ x y z) = NS.SockAddrInet6 port x y z + setPort _ addr = addr +: + +{\tt getAddrInfo} returns multiple addresses; each one is tried in turn, +until a valid address is found. If none are found, or are usable, an +exception will be thrown. + +:f DBus/Connection.hs + openSocket _ [] = E.throwIO $ NoWorkingAddress [a] + openSocket port (addr:addrs) = E.catch (openSocket' port addr) $ + \(E.SomeException _) -> openSocket port addrs + openSocket' port addr = do + sock <- NS.socket (NS.addrFamily addr) + (NS.addrSocketType addr) + (NS.addrProtocol addr) + NS.connect sock . setPort port . NS.addrAddress $ addr + return sock +: + +\subsubsection{Generic handle-based transport} + +Both UNIX and TCP are backed by standard handles, and can therefore use +a shared handle-based transport backend. + +:d connection imports +import qualified System.IO as I +: + +:f DBus/Connection.hs +handleTransport :: I.Handle -> IO Transport +handleTransport h = do + I.hSetBuffering h I.NoBuffering + I.hSetBinaryMode h True + return $ Transport (L.hPut h) (L.hGet h . fromIntegral) (I.hClose h) +: + +\subsection{Errors} + +If connecting to D-Bus fails, a {\tt ConnectionError} will be thrown. +The constructor describes which exception occurred. + +:d connection imports +import qualified Control.Exception as E +import Data.Typeable (Typeable) +: + +:f DBus/Connection.hs +data ConnectionError + = InvalidAddress Text + | BadParameters A.Address Text + | UnknownMethod A.Address + | NoWorkingAddress [A.Address] + deriving (Show, Typeable) + +instance E.Exception ConnectionError +: + +:d connection exports +, ConnectionError (..) +: + +\subsection{Establishing a connection} + +A connection can be opened to any valid address, though actually connecting +might fail due to external factors. + +:d connection imports +import qualified DBus.Authentication as Auth +: + +:f DBus/Connection.hs +|apidoc connect| +connect :: Auth.Mechanism -> A.Address -> IO Connection +connect mechanism a = do + t <- connectTransport a + let getByte = L.head `fmap` transportRecv t 1 + uuid <- Auth.authenticate mechanism (transportSend t) getByte + readLock <- C.newMVar () + serialMVar <- C.newMVar M.firstSerial + return $ Connection a t serialMVar readLock uuid +: + +Since addresses usually come in a list, it's sensible to have a variant +of {\tt connect} which tries multiple addresses. The first successfully +opened {\tt Connection} is returned. + +:f DBus/Connection.hs +|apidoc connectFirst| +connectFirst :: [(Auth.Mechanism, A.Address)] -> IO Connection +connectFirst orig = connectFirst' orig where + allAddrs = [a | (_, a) <- orig] + connectFirst' [] = E.throwIO $ NoWorkingAddress allAddrs + connectFirst' ((mech, a):as) = E.catch (connect mech a) $ + \(E.SomeException _) -> connectFirst' as +: + +:d connection exports +, connect +, connectFirst +: + +\subsection{Closing connections} + +:f DBus/Connection.hs +|apidoc connectionClose| +connectionClose :: Connection -> IO () +connectionClose = transportClose . connectionTransport +: + +:d connection exports +, connectionClose +: + +:i authentication.anansi + +\subsection{Sending and receiving messages} + +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. + +:d connection imports +import qualified DBus.Wire as W +: + +:f DBus/Connection.hs +|apidoc send| +send :: M.Message a => Connection -> (M.Serial -> IO b) -> a + -> IO (Either W.MarshalError b) +send (Connection _ t mvar _ _) io msg = withSerial mvar $ \serial -> + case W.marshalMessage W.LittleEndian serial msg of + Right bytes -> do + x <- io serial + transportSend t bytes + return $ Right x + Left err -> return $ Left err +: + +:d connection exports +, send +: + +:f DBus/Connection.hs +withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a +withSerial m io = E.block $ do + s <- C.takeMVar m + let s' = M.nextSerial s + x <- E.unblock (io s) `E.onException` C.putMVar m s' + C.putMVar m s' + return x +: + +Messages are received wrapped in a {\tt ReceivedMessage} value. If an +error is encountered while unmarshaling, an exception will be thrown. + +:f DBus/Connection.hs +|apidoc receive| +receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage) +receive (Connection _ t _ lock _) = C.withMVar lock $ \_ -> + W.unmarshalMessage $ transportRecv t +: + +:d connection exports +, receive +: diff --git a/src/constants.anansi b/src/constants.anansi new file mode 100644 --- /dev/null +++ b/src/constants.anansi @@ -0,0 +1,186 @@ +:# Copyright (C) 2009-2010 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 . + +\section{Constants} + +:f DBus/Constants.hs +|copyright| +{-# LANGUAGE OverloadedStrings #-} +module DBus.Constants where +import qualified DBus.Types as T +import Data.Word (Word8, Word32) + +protocolVersion :: Word8 +protocolVersion = 1 + +messageMaximumLength :: Word32 +messageMaximumLength = 134217728 + +arrayMaximumLength :: Word32 +arrayMaximumLength = 67108864 +: + +\subsection{The message bus} + +:f DBus/Constants.hs +dbusName :: T.BusName +dbusName = "org.freedesktop.DBus" + +dbusPath :: T.ObjectPath +dbusPath = "/org/freedesktop/DBus" + +dbusInterface :: T.InterfaceName +dbusInterface = "org.freedesktop.DBus" +: + +\subsection{Pre-defined interfaces} + +:f DBus/Constants.hs +interfaceIntrospectable :: T.InterfaceName +interfaceIntrospectable = "org.freedesktop.DBus.Introspectable" + +interfaceProperties :: T.InterfaceName +interfaceProperties = "org.freedesktop.DBus.Properties" + +interfacePeer :: T.InterfaceName +interfacePeer = "org.freedesktop.DBus.Peer" +: + +\subsection{Pre-defined error names} + +:f DBus/Constants.hs +errorFailed :: T.ErrorName +errorFailed = "org.freedesktop.DBus.Error.Failed" + +errorNoMemory :: T.ErrorName +errorNoMemory = "org.freedesktop.DBus.Error.NoMemory" + +errorServiceUnknown :: T.ErrorName +errorServiceUnknown = "org.freedesktop.DBus.Error.ServiceUnknown" + +errorNameHasNoOwner :: T.ErrorName +errorNameHasNoOwner = "org.freedesktop.DBus.Error.NameHasNoOwner" + +errorNoReply :: T.ErrorName +errorNoReply = "org.freedesktop.DBus.Error.NoReply" + +errorIOError :: T.ErrorName +errorIOError = "org.freedesktop.DBus.Error.IOError" + +errorBadAddress :: T.ErrorName +errorBadAddress = "org.freedesktop.DBus.Error.BadAddress" + +errorNotSupported :: T.ErrorName +errorNotSupported = "org.freedesktop.DBus.Error.NotSupported" + +errorLimitsExceeded :: T.ErrorName +errorLimitsExceeded = "org.freedesktop.DBus.Error.LimitsExceeded" + +errorAccessDenied :: T.ErrorName +errorAccessDenied = "org.freedesktop.DBus.Error.AccessDenied" + +errorAuthFailed :: T.ErrorName +errorAuthFailed = "org.freedesktop.DBus.Error.AuthFailed" + +errorNoServer :: T.ErrorName +errorNoServer = "org.freedesktop.DBus.Error.NoServer" + +errorTimeout :: T.ErrorName +errorTimeout = "org.freedesktop.DBus.Error.Timeout" + +errorNoNetwork :: T.ErrorName +errorNoNetwork = "org.freedesktop.DBus.Error.NoNetwork" + +errorAddressInUse :: T.ErrorName +errorAddressInUse = "org.freedesktop.DBus.Error.AddressInUse" + +errorDisconnected :: T.ErrorName +errorDisconnected = "org.freedesktop.DBus.Error.Disconnected" + +errorInvalidArgs :: T.ErrorName +errorInvalidArgs = "org.freedesktop.DBus.Error.InvalidArgs" + +errorFileNotFound :: T.ErrorName +errorFileNotFound = "org.freedesktop.DBus.Error.FileNotFound" + +errorFileExists :: T.ErrorName +errorFileExists = "org.freedesktop.DBus.Error.FileExists" + +errorUnknownMethod :: T.ErrorName +errorUnknownMethod = "org.freedesktop.DBus.Error.UnknownMethod" + +errorTimedOut :: T.ErrorName +errorTimedOut = "org.freedesktop.DBus.Error.TimedOut" + +errorMatchRuleNotFound :: T.ErrorName +errorMatchRuleNotFound = "org.freedesktop.DBus.Error.MatchRuleNotFound" + +errorMatchRuleInvalid :: T.ErrorName +errorMatchRuleInvalid = "org.freedesktop.DBus.Error.MatchRuleInvalid" + +errorSpawnExecFailed :: T.ErrorName +errorSpawnExecFailed = "org.freedesktop.DBus.Error.Spawn.ExecFailed" + +errorSpawnForkFailed :: T.ErrorName +errorSpawnForkFailed = "org.freedesktop.DBus.Error.Spawn.ForkFailed" + +errorSpawnChildExited :: T.ErrorName +errorSpawnChildExited = "org.freedesktop.DBus.Error.Spawn.ChildExited" + +errorSpawnChildSignaled :: T.ErrorName +errorSpawnChildSignaled = "org.freedesktop.DBus.Error.Spawn.ChildSignaled" + +errorSpawnFailed :: T.ErrorName +errorSpawnFailed = "org.freedesktop.DBus.Error.Spawn.Failed" + +errorSpawnFailedToSetup :: T.ErrorName +errorSpawnFailedToSetup = "org.freedesktop.DBus.Error.Spawn.FailedToSetup" + +errorSpawnConfigInvalid :: T.ErrorName +errorSpawnConfigInvalid = "org.freedesktop.DBus.Error.Spawn.ConfigInvalid" + +errorSpawnServiceNotValid :: T.ErrorName +errorSpawnServiceNotValid = "org.freedesktop.DBus.Error.Spawn.ServiceNotValid" + +errorSpawnServiceNotFound :: T.ErrorName +errorSpawnServiceNotFound = "org.freedesktop.DBus.Error.Spawn.ServiceNotFound" + +errorSpawnPermissionsInvalid :: T.ErrorName +errorSpawnPermissionsInvalid = "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid" + +errorSpawnFileInvalid :: T.ErrorName +errorSpawnFileInvalid = "org.freedesktop.DBus.Error.Spawn.FileInvalid" + +errorSpawnNoMemory :: T.ErrorName +errorSpawnNoMemory = "org.freedesktop.DBus.Error.Spawn.NoMemory" + +errorUnixProcessIdUnknown :: T.ErrorName +errorUnixProcessIdUnknown = "org.freedesktop.DBus.Error.UnixProcessIdUnknown" + +errorInvalidFileContent :: T.ErrorName +errorInvalidFileContent = "org.freedesktop.DBus.Error.InvalidFileContent" + +errorSELinuxSecurityContextUnknown :: T.ErrorName +errorSELinuxSecurityContextUnknown = "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown" + +errorAdtAuditDataUnknown :: T.ErrorName +errorAdtAuditDataUnknown = "org.freedesktop.DBus.Error.AdtAuditDataUnknown" + +errorObjectPathInUse :: T.ErrorName +errorObjectPathInUse = "org.freedesktop.DBus.Error.ObjectPathInUse" + +errorInconsistentMessage :: T.ErrorName +errorInconsistentMessage = "org.freedesktop.DBus.Error.InconsistentMessage" +: diff --git a/src/dbus-core.anansi b/src/dbus-core.anansi new file mode 100644 --- /dev/null +++ b/src/dbus-core.anansi @@ -0,0 +1,55 @@ +:# Copyright (C) 2009-2010 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 . + +\documentclass[12pt]{article} + +\usepackage{color} +\usepackage{hyperref} +\usepackage{booktabs} +\usepackage{multirow} +\usepackage{noweb} +\usepackage{url} + +:# Smaller margins +\usepackage[left=1.5cm,top=2cm,right=1.5cm,nohead,nofoot]{geometry} + +:# Remove boxes from hyperlinks +\hypersetup{ + colorlinks, + linkcolor=blue, +} + +\makeindex + +\begin{document} + +\addcontentsline{toc}{section}{Contents} +\tableofcontents + +:i introduction.anansi +:i types.anansi +:i messages.anansi +:i wire.anansi +:i addresses.anansi +:i connections.anansi +:i bus.anansi +:i introspection.anansi +:i match-rules.anansi +:i name-reservation.anansi +:i constants.anansi +:i util.anansi +:i api-docs.anansi + +\end{document} diff --git a/src/introduction.anansi b/src/introduction.anansi new file mode 100644 --- /dev/null +++ b/src/introduction.anansi @@ -0,0 +1,76 @@ +:# Copyright (C) 2009-2010 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 . + +\section{Introduction} + +D-Bus is a low-latency, asynchronous IPC protocol. It is primarily used on +Linux, BSD, and other free UNIX-like systems. More information is available +at \url{http://dbus.freedesktop.org/}. + +This package is an implementation of the D-Bus protocol. It is intended +for use in either a client or server, though currently only the client +portion of connection establishment is implemented. Additionally, it +implements the introspection file format. + +All source code is licensed under the terms of the GNU GPL v3 or later. + +:d copyright +-- Copyright (C) 2009-2010 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 . +: + +\section{Text values} + +Most of the functions in this library use the types and functions defined +in {\tt Data.Text}, in preference to the {\tt String} type. + +:d text extensions +{-# LANGUAGE OverloadedStrings #-} +: + +:d text imports +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL +: + +Tests are separated into a separate file, which is optionally compiled but +not included in the library. + +:f Tests.hs +|copyright| +|text extensions| +module Main (tests, main) where +|test imports| + +tests :: [F.Test] +tests = [ F.testGroup "dummy" [] + |test cases| + ] + +main :: IO () +main = F.defaultMain tests +: diff --git a/src/introspection.anansi b/src/introspection.anansi new file mode 100644 --- /dev/null +++ b/src/introspection.anansi @@ -0,0 +1,480 @@ +:# Copyright (C) 2009-2010 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 . + +\section{Introspection} + +D-Bus objects may be ``introspected'' to determine which methods, signals, +etc they support. Intospection data is sent over the bus in {\sc xml}, in +a mostly standardised but undocumented format. + +An XML introspection document looks like this: + +\begin{verbatim} + + + + + + + + + + + + + + + +\end{verbatim} + +:f DBus/Introspection.hs +|copyright| +|text extensions| +module DBus.Introspection + ( Object (..) + , Interface (..) + , Method (..) + , Signal (..) + , Parameter (..) + , Property (..) + , PropertyAccess (..) + , toXML + , fromXML + ) where +|text imports| +|introspection imports| +import qualified DBus.Types as T +: + +HaXml is used to do the heavy lifting of XML parsing because HXT cannot +be combined with Parsec 3. + +:d introspection imports +import qualified Text.XML.HaXml as H +: + +\subsection{Data types} + +:f DBus/Introspection.hs +data Object = Object T.ObjectPath [Interface] [Object] + deriving (Show, Eq) + +data Interface = Interface T.InterfaceName [Method] [Signal] [Property] + deriving (Show, Eq) + +data Method = Method T.MemberName [Parameter] [Parameter] + deriving (Show, Eq) + +data Signal = Signal T.MemberName [Parameter] + deriving (Show, Eq) + +data Parameter = Parameter Text T.Signature + deriving (Show, Eq) + +data Property = Property Text T.Signature [PropertyAccess] + deriving (Show, Eq) + +data PropertyAccess = Read | Write + deriving (Show, Eq) +: + +\subsection{Parsing XML} + +The root {\tt node} is special, in that it's the only {\tt node} which is +not required to have a {\tt name} attribute. If the root has no {\tt name}, +its path will default to the path of the introspected object. + +If parsing fails, {\tt fromXML} will return {\tt Nothing}. Aside from the +elements directly accessed by the parser, no effort is made to check the +document's validity because there is no DTD as of yet. + +:d introspection imports +import Text.XML.HaXml.Parse (xmlParse') +import DBus.Util (eitherToMaybe) +: + +:f DBus/Introspection.hs +fromXML :: T.ObjectPath -> Text -> Maybe Object +fromXML path text = do + doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text + let (H.Document _ _ root _) = doc + parseRoot path root +: + +Even though the root object's {\tt name} is optional, if present, it must +still be a valid object path. + +:f DBus/Introspection.hs +parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object +parseRoot defaultPath e = do + path <- case getAttr "name" e of + Nothing -> Just defaultPath + Just x -> T.mkObjectPath x + parseObject' path e +: + +Child {\tt nodes} have ``relative'' paths -- that is, their {\tt name} +attribute is not a valid object path, but should be valid when appended to +the root object's path. + +:f DBus/Introspection.hs +parseChild :: T.ObjectPath -> H.Element a -> Maybe Object +parseChild parentPath e = do + let parentPath' = case T.strObjectPath parentPath of + "/" -> "/" + x -> TL.append x "/" + pathSegment <- getAttr "name" e + path <- T.mkObjectPath $ TL.append parentPath' pathSegment + parseObject' path e +: + +Other than the name, both root and non-root {\tt nodes} have identical +contents. They may contain interface definitions, and child {\tt node}s. + +:f DBus/Introspection.hs +parseObject' :: T.ObjectPath -> H.Element a -> Maybe Object +parseObject' path e@(H.Elem "node" _ _) = do + interfaces <- children parseInterface (H.tag "interface") e + children' <- children (parseChild path) (H.tag "node") e + return $ Object path interfaces children' +parseObject' _ _ = Nothing +: + +Interfaces may contain methods, signals, and properties. + +:f DBus/Introspection.hs +parseInterface :: H.Element a -> Maybe Interface +parseInterface e = do + name <- T.mkInterfaceName =<< getAttr "name" e + methods <- children parseMethod (H.tag "method") e + signals <- children parseSignal (H.tag "signal") e + properties <- children parseProperty (H.tag "property") e + return $ Interface name methods signals properties +: + +Methods contain a list of parameters, which default to ``in'' parameters +if no direction is specified. + +:f DBus/Introspection.hs +parseMethod :: H.Element a -> Maybe Method +parseMethod e = do + name <- T.mkMemberName =<< getAttr "name" e + paramsIn <- children parseParameter (isParam ["in", ""]) e + paramsOut <- children parseParameter (isParam ["out"]) e + return $ Method name paramsIn paramsOut +: + +Signals are similar to methods, except they have no ``in'' parameters. + +:f DBus/Introspection.hs +parseSignal :: H.Element a -> Maybe Signal +parseSignal e = do + name <- T.mkMemberName =<< getAttr "name" e + params <- children parseParameter (isParam ["out", ""]) e + return $ Signal name params +: + +A parameter has a free-form name, and a single valid type. + +:f DBus/Introspection.hs +parseParameter :: H.Element a -> Maybe Parameter +parseParameter e = do + let name = getAttr' "name" e + sig <- parseType e + return $ Parameter name sig +: + +:f DBus/Introspection.hs +parseType :: H.Element a -> Maybe T.Signature +parseType e = do + sig <- T.mkSignature =<< getAttr "type" e + case T.signatureTypes sig of + [_] -> Just sig + _ -> Nothing +: + +Properties are used by the {\tt org.freedesktop.DBus.Properties} interface. +Each property may be read, written, or both, and has an associated type. + +:f DBus/Introspection.hs +parseProperty :: H.Element a -> Maybe Property +parseProperty e = do + let name = getAttr' "name" e + sig <- parseType e + access <- case getAttr' "access" e of + "" -> Just [] + "read" -> Just [Read] + "write" -> Just [Write] + "readwrite" -> Just [Read, Write] + _ -> Nothing + return $ Property name sig access +: + +HaXml doesn't seem to have any way to retrieve the ``real'' value of an +attribute, so {\tt attrValue} implements this. + +:d introspection imports +import Data.Char (chr) +: + +:f DBus/Introspection.hs +attrValue :: H.AttValue -> Maybe Text +attrValue attr = fmap (TL.pack . concat) $ mapM unescape parts where + (H.AttValue parts) = attr + + unescape (Left x) = Just x + unescape (Right (H.RefEntity x)) = lookup x namedRefs + unescape (Right (H.RefChar x)) = Just [chr x] + + namedRefs = + [ ("lt", "<") + , ("gt", ">") + , ("amp", "&") + , ("apos", "'") + , ("quot", "\"") + ] +: + +Some helper functions for dealing with HaXml filters + +:d introspection imports +import Data.Maybe (fromMaybe) +: + +:f DBus/Introspection.hs +getAttr :: String -> H.Element a -> Maybe Text +getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue + +getAttr' :: String -> H.Element a -> Text +getAttr' = (fromMaybe "" .) . getAttr + +isParam :: [Text] -> H.CFilter a +isParam dirs content = do + arg@(H.CElem e _) <- H.tag "arg" content + let direction = getAttr' "direction" e + [arg | direction `elem` dirs] + +children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b] +children f filt (H.Elem _ _ contents) = + mapM f [x | (H.CElem x _) <- concatMap filt contents] +: + +\subsection{Generating XML} + +:f DBus/Introspection.hs +dtdPublicID, dtdSystemID :: String +dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN" +dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd" +: + +HaXml punts to the {\tt pretty} package for serialising XML. + +:d introspection imports +import Text.XML.HaXml.Pretty (document) +import Text.PrettyPrint.HughesPJ (render) +: + +Generating XML can fail; if a child object's path is not a sub-path of the +parent, {\tt toXML} will return {\tt Nothing}. + +:f DBus/Introspection.hs +toXML :: Object -> Maybe Text +toXML obj = fmap (TL.pack . render . document) doc where + prolog = H.Prolog Nothing [] (Just doctype) [] + doctype = H.DTD "node" (Just (H.PUBLIC + (H.PubidLiteral dtdPublicID) + (H.SystemLiteral dtdSystemID))) [] + doc = do + root <- xmlRoot obj + return $ H.Document prolog H.emptyST root [] +: + +When writing objects to {\tt node}s, the root object must have an absolute +path, and children must have paths relative to their parent. + +:f DBus/Introspection.hs +xmlRoot :: Object -> Maybe (H.Element a) +xmlRoot obj@(Object path _ _) = do + (H.CElem root _) <- xmlObject' (T.strObjectPath path) obj + return root +: + +:f DBus/Introspection.hs +xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a) +xmlObject parentPath obj@(Object path _ _) = do + let path' = T.strObjectPath path + parent' = T.strObjectPath parentPath + relpath <- if TL.isPrefixOf parent' path' + then Just $ if parent' == "/" + then TL.drop 1 path' + else TL.drop (TL.length parent' + 1) path' + else Nothing + xmlObject' relpath obj +: + +:f DBus/Introspection.hs +xmlObject' :: Text -> Object -> Maybe (H.Content a) +xmlObject' path (Object fullPath interfaces children') = do + children'' <- mapM (xmlObject fullPath) children' + return $ mkElement "node" + [mkAttr "name" $ TL.unpack path] + $ concat + [ map xmlInterface interfaces + , children'' + ] +: + +:f DBus/Introspection.hs +xmlInterface :: Interface -> H.Content a +xmlInterface (Interface name methods signals properties) = + mkElement "interface" + [mkAttr "name" . TL.unpack . T.strInterfaceName $ name] + $ concat + [ map xmlMethod methods + , map xmlSignal signals + , map xmlProperty properties + ] +: + +:f DBus/Introspection.hs +xmlMethod :: Method -> H.Content a +xmlMethod (Method name inParams outParams) = mkElement "method" + [mkAttr "name" . TL.unpack . T.strMemberName $ name] + $ concat + [ map (xmlParameter "in") inParams + , map (xmlParameter "out") outParams + ] +: + +:f DBus/Introspection.hs +xmlSignal :: Signal -> H.Content a +xmlSignal (Signal name params) = mkElement "signal" + [mkAttr "name" . TL.unpack . T.strMemberName $ name] + $ map (xmlParameter "out") params +: + +:f DBus/Introspection.hs +xmlParameter :: String -> Parameter -> H.Content a +xmlParameter direction (Parameter name sig) = mkElement "arg" + [ mkAttr "name" . TL.unpack $ name + , mkAttr "type" . TL.unpack . T.strSignature $ sig + , mkAttr "direction" direction + ] [] +: + +:f DBus/Introspection.hs +xmlProperty :: Property -> H.Content a +xmlProperty (Property name sig access) = mkElement "property" + [ mkAttr "name" . TL.unpack $ name + , mkAttr "type" . TL.unpack . T.strSignature $ sig + , mkAttr "access" $ xmlAccess access + ] [] +: + +:f DBus/Introspection.hs +xmlAccess :: [PropertyAccess] -> String +xmlAccess access = readS ++ writeS where + readS = if elem Read access then "read" else "" + writeS = if elem Write access then "write" else "" +: + +:f DBus/Introspection.hs +mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a +mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined + +mkAttr :: String -> String -> H.Attribute +mkAttr name value = (name, H.AttValue [Left escaped]) where + raw = H.CString True value () + escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw] +: + +\subsection{Test support} + +:f Tests.hs +subObject :: ObjectPath -> Gen I.Object +subObject parentPath = sized $ \n -> resize (min n 4) $ do + let nonRoot = do + x <- arbitrary + case strObjectPath x of + "/" -> nonRoot + x' -> return x' + + thisPath <- nonRoot + let path' = case strObjectPath parentPath of + "/" -> thisPath + x -> TL.append x thisPath + let path = mkObjectPath_ path' + ifaces <- arbitrary + children <- halfSized . listOf . subObject $ path + return $ I.Object path ifaces children + +instance Arbitrary I.Object where + arbitrary = arbitrary >>= subObject + +instance Arbitrary I.Interface where + arbitrary = do + name <- arbitrary + methods <- arbitrary + signals <- arbitrary + properties <- arbitrary + return $ I.Interface name methods signals properties + +instance Arbitrary I.Method where + arbitrary = do + name <- arbitrary + inParams <- arbitrary + outParams <- arbitrary + return $ I.Method name inParams outParams + +instance Arbitrary I.Signal where + arbitrary = do + name <- arbitrary + params <- arbitrary + return $ I.Signal name params + +singleType :: Gen Signature +singleType = do + t <- arbitrary + case mkSignature $ typeCode t of + Just x -> return x + Nothing -> singleType + +instance Arbitrary I.Parameter where + arbitrary = do + name <- listOf $ arbitrary `suchThat` isPrint + sig <- singleType + return $ I.Parameter (TL.pack name) sig + +instance Arbitrary I.Property where + arbitrary = do + name <- listOf $ arbitrary `suchThat` isPrint + sig <- singleType + access <- elements + [[], [I.Read], [I.Write], + [I.Read, I.Write]] + return $ I.Property (TL.pack name) sig access +: + +:d test cases +, F.testGroup "Introspection" + [ testProperty "Generate -> Parse" + $ \x@(I.Object path _ _) -> let + xml = I.toXML x + Just xml' = xml + parsed = I.fromXML path xml' + in isJust xml ==> I.fromXML path xml' == Just x + ] +: diff --git a/src/match-rules.anansi b/src/match-rules.anansi new file mode 100644 --- /dev/null +++ b/src/match-rules.anansi @@ -0,0 +1,244 @@ +:# Copyright (C) 2009-2010 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 . + +\section{Match rules} + +Match rules are used to indicate that the client is interested in messages +matching a particular filter. This module provides an interface for building +match rule strings. Eventually, it will support parsing them also. + +:f DBus/MatchRule.hs +|copyright| +|text extensions| +module DBus.MatchRule ( + MatchRule (..) + , MessageType (..) + , ParameterValue (..) + , formatRule + , addMatch + , matchAll + , matches + ) where +|text imports| +import Data.Word (Word8) +import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.Set as Set +import qualified DBus.Types as T +import qualified DBus.Message as M +import qualified DBus.Constants as C +import DBus.Util (maybeIndex) +: + +:f DBus/MatchRule.hs +-- | A match rule is a set of filters; most filters may have one possible +-- value assigned, such as a single message type. The exception are parameter +-- filters, which are limited in number only by the server implementation. +-- +data MatchRule = MatchRule + { matchType :: Maybe MessageType + , matchSender :: Maybe T.BusName + , matchInterface :: Maybe T.InterfaceName + , matchMember :: Maybe T.MemberName + , matchPath :: Maybe T.ObjectPath + , matchDestination :: Maybe T.BusName + , matchParameters :: [ParameterValue] + } + deriving (Show) +: + +:f DBus/MatchRule.hs +-- | Parameters may match against two types, strings and object paths. It's +-- probably an error to have two values for the same parameter. +-- +-- The constructor @StringValue 3 \"hello\"@ means that the fourth parameter +-- in the message body must be the string @\"hello\"@. @PathValue@ is the +-- same, but its value must be an object path. +-- +data ParameterValue + = StringValue Word8 Text + | PathValue Word8 T.ObjectPath + deriving (Show, Eq) +: + +:f DBus/MatchRule.hs +-- | The set of allowed message types to filter on is separate from the set +-- supported for sending over the wire. This allows the server to support +-- additional types not yet implemented in the library, or vice-versa. +-- +data MessageType + = MethodCall + | MethodReturn + | Signal + | Error + deriving (Show, Eq) +: + +There's currently only one operation to perform on match rules, and that's +to format them. + +:f DBus/MatchRule.hs +|apidoc formatRule| +formatRule :: MatchRule -> Text +formatRule rule = TL.intercalate "," filters where + filters = structureFilters ++ parameterFilters + parameterFilters = map formatParameter $ matchParameters rule + structureFilters = mapMaybe unpack + [ ("type", fmap formatType . matchType) + , ("sender", fmap T.strBusName . matchSender) + , ("interface", fmap T.strInterfaceName . matchInterface) + , ("member", fmap T.strMemberName . matchMember) + , ("path", fmap T.strObjectPath . matchPath) + , ("destination", fmap T.strBusName . matchDestination) + ] + unpack (key, mkValue) = formatFilter' key `fmap` mkValue rule +: + +:f DBus/MatchRule.hs +formatParameter :: ParameterValue -> Text +formatParameter (StringValue index x) = formatFilter' key x where + key = "arg" `TL.append` TL.pack (show index) +formatParameter (PathValue index x) = formatFilter' key value where + key = "arg" `TL.append` TL.pack (show index) `TL.append` "path" + value = T.strObjectPath x +: + +FIXME: what are the escaping rules for match rules? Other bindings don't +seem to perform any escaping at all. + +:f DBus/MatchRule.hs +formatFilter' :: Text -> Text -> Text +formatFilter' key value = TL.concat [key, "='", value, "'"] + +formatType :: MessageType -> Text +formatType MethodCall = "method_call" +formatType MethodReturn = "method_return" +formatType Signal = "signal" +formatType Error = "error" +: + +And since the only real reason for formatting a match rule is to send it, +it's useful to have a message-building function pre-defined. + +:f DBus/MatchRule.hs +|apidoc addMatch| +addMatch :: MatchRule -> M.MethodCall +addMatch rule = M.MethodCall + C.dbusPath + "AddMatch" + (Just C.dbusInterface) + (Just C.dbusName) + Set.empty + [T.toVariant $ formatRule rule] +: + +Most match rules will have only one or two fields filled in, so defining +an empty rule allows clients to set only the fields they care about. + +:f DBus/MatchRule.hs +|apidoc matchAll| +matchAll :: MatchRule +matchAll = MatchRule + { matchType = Nothing + , matchSender = Nothing + , matchInterface = Nothing + , matchMember = Nothing + , matchPath = Nothing + , matchDestination = Nothing + , matchParameters = [] + } +: + +It's useful to match against a rule client-side, eg when listening for +signals. + +:f DBus/MatchRule.hs +|apidoc matches| +matches :: MatchRule -> M.ReceivedMessage -> Bool +matches rule msg = and . mapMaybe ($ rule) $ + [ fmap (typeMatches msg) . matchType + , fmap (senderMatches msg) . matchSender + , fmap (ifaceMatches msg) . matchInterface + , fmap (memberMatches msg) . matchMember + , fmap (pathMatches msg) . matchPath + , fmap (destMatches msg) . matchDestination + , Just . parametersMatch msg . matchParameters + ] +: + +:f DBus/MatchRule.hs +typeMatches :: M.ReceivedMessage -> MessageType -> Bool +typeMatches (M.ReceivedMethodCall _ _ _) MethodCall = True +typeMatches (M.ReceivedMethodReturn _ _ _) MethodReturn = True +typeMatches (M.ReceivedSignal _ _ _) Signal = True +typeMatches (M.ReceivedError _ _ _) Error = True +typeMatches _ _ = False +: + +:f DBus/MatchRule.hs +senderMatches :: M.ReceivedMessage -> T.BusName -> Bool +senderMatches msg name = M.receivedSender msg == Just name +: + +:f DBus/MatchRule.hs +ifaceMatches :: M.ReceivedMessage -> T.InterfaceName -> Bool +ifaceMatches (M.ReceivedMethodCall _ _ msg) name = + Just name == M.methodCallInterface msg +ifaceMatches (M.ReceivedSignal _ _ msg) name = + name == M.signalInterface msg +ifaceMatches _ _ = False +: + +:f DBus/MatchRule.hs +memberMatches :: M.ReceivedMessage -> T.MemberName -> Bool +memberMatches (M.ReceivedMethodCall _ _ msg) name = + name == M.methodCallMember msg +memberMatches (M.ReceivedSignal _ _ msg) name = + name == M.signalMember msg +memberMatches _ _ = False +: + +:f DBus/MatchRule.hs +pathMatches :: M.ReceivedMessage -> T.ObjectPath -> Bool +pathMatches (M.ReceivedMethodCall _ _ msg) path = + path == M.methodCallPath msg +pathMatches (M.ReceivedSignal _ _ msg) path = + path == M.signalPath msg +pathMatches _ _ = False +: + +:f DBus/MatchRule.hs +destMatches :: M.ReceivedMessage -> T.BusName -> Bool +destMatches (M.ReceivedMethodCall _ _ msg) name = + Just name == M.methodCallDestination msg +destMatches (M.ReceivedMethodReturn _ _ msg) name = + Just name == M.methodReturnDestination msg +destMatches (M.ReceivedError _ _ msg) name = + Just name == M.errorDestination msg +destMatches (M.ReceivedSignal _ _ msg) name = + Just name == M.signalDestination msg +destMatches _ _ = False +: + +:f DBus/MatchRule.hs +parametersMatch :: M.ReceivedMessage -> [ParameterValue] -> Bool +parametersMatch _ [] = True +parametersMatch msg values = all validParam values where + body = M.receivedBody msg + validParam (StringValue idx x) = validParam' idx x + validParam (PathValue idx x) = validParam' idx x + validParam' idx x = fromMaybe False $ do + var <- maybeIndex body $ fromIntegral idx + fmap (== x) $ T.fromVariant var +: diff --git a/src/messages.anansi b/src/messages.anansi new file mode 100644 --- /dev/null +++ b/src/messages.anansi @@ -0,0 +1,381 @@ +:# Copyright (C) 2009-2010 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 . + +\section{Messages} + +To prevent internal details of messages from leaking out to clients, +declarations are contained in an internal module and then re-exported +in the public module. + +:f DBus/Message.hs +|copyright| +module DBus.Message ( + |message exports| + ) where +import DBus.Message.Internal +: + +:f DBus/Message/Internal.hs +|copyright| +|text extensions| +module DBus.Message.Internal where +|text imports| +import qualified Data.Set as S +import Data.Word (Word8, Word32) +import Data.Maybe (fromMaybe) +import qualified DBus.Types as T +import DBus.Util (maybeIndex) +: + +:f DBus/Message/Internal.hs +class Message a where + messageTypeCode :: a -> Word8 + messageHeaderFields :: a -> [HeaderField] + messageFlags :: a -> S.Set Flag + messageBody :: a -> [T.Variant] +: + +:d message exports +Message ( messageFlags + , messageBody + ) +: + +\subsection{Flags} + +The instance of {\tt Ord} only exists for storing flags in a set. Flags have +no inherent ordering. + +:f DBus/Message/Internal.hs +data Flag + = NoReplyExpected + | NoAutoStart + deriving (Show, Eq, Ord) +: + +:d message exports +, Flag (..) +: + +:f Tests.hs +instance Arbitrary Flag where + arbitrary = elements [NoReplyExpected, NoAutoStart] +: + +\subsection{Header fields} + +:f DBus/Message/Internal.hs +data HeaderField + = Path T.ObjectPath + | Interface T.InterfaceName + | Member T.MemberName + | ErrorName T.ErrorName + | ReplySerial Serial + | Destination T.BusName + | Sender T.BusName + | Signature T.Signature + deriving (Show, Eq) +: + +\subsection{Serials} + +{\tt Serial} is just a wrapper around {\tt Word32}, to provide a bit of +added type-safety. + +:f DBus/Message/Internal.hs +|apidoc Serial| +newtype Serial = Serial { serialValue :: Word32 } + deriving (Eq, Ord) + +instance Show Serial where + show (Serial x) = show x + +instance T.Variable Serial where + toVariant (Serial x) = T.toVariant x + fromVariant = fmap Serial . T.fromVariant +: + +Additionally, some useful functions exist for incrementing serials. + +:f DBus/Message/Internal.hs +firstSerial :: Serial +firstSerial = Serial 1 + +nextSerial :: Serial -> Serial +nextSerial (Serial x) = Serial (x + 1) +: + +The {\tt Serial} constructor isn't useful to clients, because building +arbitrary serials doesn't make any sense. + +:d message exports +, Serial +, serialValue +, firstSerial +, nextSerial +: + +:f Tests.hs +instance Arbitrary Serial where + arbitrary = fmap Serial arbitrary +: + +\subsection{Message types} + +:f DBus/Message/Internal.hs +maybe' :: (a -> b) -> Maybe a -> [b] +maybe' f = maybe [] (\x' -> [f x']) +: + +\subsubsection{Method calls} + +:f DBus/Message/Internal.hs +data MethodCall = MethodCall + { methodCallPath :: T.ObjectPath + , methodCallMember :: T.MemberName + , methodCallInterface :: Maybe T.InterfaceName + , methodCallDestination :: Maybe T.BusName + , methodCallFlags :: S.Set Flag + , methodCallBody :: [T.Variant] + } + deriving (Show, Eq) + +instance Message MethodCall where + messageTypeCode _ = 1 + messageFlags = methodCallFlags + messageBody = methodCallBody + messageHeaderFields m = concat + [ [ Path $ methodCallPath m + , Member $ methodCallMember m + ] + , maybe' Interface . methodCallInterface $ m + , maybe' Destination . methodCallDestination $ m + ] +: + +:d message exports +, MethodCall (..) +: + +:f Tests.hs +instance Arbitrary MethodCall where + arbitrary = do + path <- arbitrary + member <- arbitrary + iface <- arbitrary + dest <- arbitrary + flags <- fmap Set.fromList arbitrary + Structure body <- arbitrary + return $ MethodCall path member iface dest flags body +: + +\subsubsection{Method returns} + +:f DBus/Message/Internal.hs +data MethodReturn = MethodReturn + { methodReturnSerial :: Serial + , methodReturnDestination :: Maybe T.BusName + , methodReturnBody :: [T.Variant] + } + deriving (Show, Eq) + +instance Message MethodReturn where + messageTypeCode _ = 2 + messageFlags _ = S.fromList [NoReplyExpected, NoAutoStart] + messageBody = methodReturnBody + messageHeaderFields m = concat + [ [ ReplySerial $ methodReturnSerial m + ] + , maybe' Destination . methodReturnDestination $ m + ] +: + +:d message exports +, MethodReturn (..) +: + +:f Tests.hs +instance Arbitrary MethodReturn where + arbitrary = do + serial <- arbitrary + dest <- arbitrary + Structure body <- arbitrary + return $ MethodReturn serial dest body +: + +\subsubsection{Errors} + +:f DBus/Message/Internal.hs +data Error = Error + { errorName :: T.ErrorName + , errorSerial :: Serial + , errorDestination :: Maybe T.BusName + , errorBody :: [T.Variant] + } + deriving (Show, Eq) + +instance Message Error where + messageTypeCode _ = 3 + messageFlags _ = S.fromList [NoReplyExpected, NoAutoStart] + messageBody = errorBody + messageHeaderFields m = concat + [ [ ErrorName $ errorName m + , ReplySerial $ errorSerial m + ] + , maybe' Destination . errorDestination $ m + ] +: + +Errors usually contain a human-readable message in their first body field. +This function lets it be retrieved easily, with a fallback if no valid +message was found. + +:f DBus/Message/Internal.hs +errorMessage :: Error -> Text +errorMessage msg = fromMaybe "(no error message)" $ do + field <- maybeIndex (errorBody msg) 0 + text <- T.fromVariant field + if TL.null text + then Nothing + else return text +: + +:d message exports +, Error (..) +, errorMessage +: + +:f Tests.hs +instance Arbitrary Error where + arbitrary = do + name <- arbitrary + serial <- arbitrary + dest <- arbitrary + Structure body <- arbitrary + return $ Error name serial dest body +: + +\subsubsection{Signals} + +:f DBus/Message/Internal.hs +data Signal = Signal + { signalPath :: T.ObjectPath + , signalMember :: T.MemberName + , signalInterface :: T.InterfaceName + , signalDestination :: Maybe T.BusName + , signalBody :: [T.Variant] + } + deriving (Show, Eq) + +instance Message Signal where + messageTypeCode _ = 4 + messageFlags _ = S.fromList [NoReplyExpected, NoAutoStart] + messageBody = signalBody + messageHeaderFields m = concat + [ [ Path $ signalPath m + , Member $ signalMember m + , Interface $ signalInterface m + ] + , maybe' Destination . signalDestination $ m + ] +: + +:d message exports +, Signal (..) +: + +:f Tests.hs +instance Arbitrary Signal where + arbitrary = do + path <- arbitrary + member <- arbitrary + iface <- arbitrary + dest <- arbitrary + Structure body <- arbitrary + return $ Signal path member iface dest body +: + +\subsubsection{Unknown messages} + +Unknown messages are used for storing information about messages without +a recognised type code. They are not instances of {\tt Message}, because +if they were, then clients could accidentally send invalid messages over +the bus. + +:f DBus/Message/Internal.hs +data Unknown = Unknown + { unknownType :: Word8 + , unknownFlags :: S.Set Flag + , unknownBody :: [T.Variant] + } + deriving (Show, Eq) +: + +:d message exports +, Unknown (..) +: + +\subsection{Received messages} + +Messages received from a bus have additional fields which do not make sense +when sending. + +If a message has an unknown type, its serial and origin are still useful +for sending an error reply. + +:f DBus/Message/Internal.hs +|apidoc ReceivedMessage| +data ReceivedMessage + = ReceivedMethodCall Serial (Maybe T.BusName) MethodCall + | ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn + | ReceivedError Serial (Maybe T.BusName) Error + | ReceivedSignal Serial (Maybe T.BusName) Signal + | ReceivedUnknown Serial (Maybe T.BusName) Unknown + deriving (Show, Eq) +: + +:f DBus/Message/Internal.hs +receivedSerial :: ReceivedMessage -> Serial +receivedSerial (ReceivedMethodCall s _ _) = s +receivedSerial (ReceivedMethodReturn s _ _) = s +receivedSerial (ReceivedError s _ _) = s +receivedSerial (ReceivedSignal s _ _) = s +receivedSerial (ReceivedUnknown s _ _) = s +: + +:f DBus/Message/Internal.hs +receivedSender :: ReceivedMessage -> Maybe T.BusName +receivedSender (ReceivedMethodCall _ s _) = s +receivedSender (ReceivedMethodReturn _ s _) = s +receivedSender (ReceivedError _ s _) = s +receivedSender (ReceivedSignal _ s _) = s +receivedSender (ReceivedUnknown _ s _) = s +: + +:f DBus/Message/Internal.hs +receivedBody :: ReceivedMessage -> [T.Variant] +receivedBody (ReceivedMethodCall _ _ x) = messageBody x +receivedBody (ReceivedMethodReturn _ _ x) = messageBody x +receivedBody (ReceivedError _ _ x) = messageBody x +receivedBody (ReceivedSignal _ _ x) = messageBody x +receivedBody (ReceivedUnknown _ _ x) = unknownBody x +: + +:d message exports +, ReceivedMessage (..) +, receivedSerial +, receivedSender +, receivedBody +: diff --git a/src/name-reservation.anansi b/src/name-reservation.anansi new file mode 100644 --- /dev/null +++ b/src/name-reservation.anansi @@ -0,0 +1,137 @@ +:# Copyright (C) 2009-2010 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 . + +\section{Name reservation} + +The central bus allows clients to register a well-known bus name, which +enables other clients to connect with or start a particular application. + +:f DBus/NameReservation.hs +|copyright| +{-# LANGUAGE OverloadedStrings #-} +module DBus.NameReservation + ( RequestNameFlag (..) + , RequestNameReply (..) + , ReleaseNameReply (..) + , requestName + , releaseName + , mkRequestNameReply + , mkReleaseNameReply + ) where +import Data.Word (Word32) +import Data.Bits ((.|.)) +import qualified Data.Set as Set +import qualified DBus.Types as T +import qualified DBus.Message as M +import qualified DBus.Constants as C +import DBus.Util (maybeIndex) +: + +:f DBus/NameReservation.hs +data RequestNameFlag + = AllowReplacement + | ReplaceExisting + | DoNotQueue + deriving (Show) +: + +:f DBus/NameReservation.hs +encodeFlags :: [RequestNameFlag] -> Word32 +encodeFlags = foldr (.|.) 0 . map flagValue where + flagValue AllowReplacement = 0x1 + flagValue ReplaceExisting = 0x2 + flagValue DoNotQueue = 0x4 +: + +There are only two methods of interest here, {\tt RequestName} and +{\tt ReleaseName}. + +:f DBus/NameReservation.hs +|apidoc requestName| +requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall +requestName name flags = M.MethodCall + { M.methodCallPath = C.dbusPath + , M.methodCallInterface = Just C.dbusInterface + , M.methodCallDestination = Just C.dbusName + , M.methodCallFlags = Set.empty + , M.methodCallMember = "RequestName" + , M.methodCallBody = + [ T.toVariant name + , T.toVariant . encodeFlags $ flags] + } +: + +:f DBus/NameReservation.hs +data RequestNameReply + = PrimaryOwner + | InQueue + | Exists + | AlreadyOwner + deriving (Show) +: + +:f DBus/NameReservation.hs +mkRequestNameReply :: M.MethodReturn -> Maybe RequestNameReply +mkRequestNameReply msg = + maybeIndex (M.messageBody msg) 0 >>= + T.fromVariant >>= + decodeRequestReply +: + +:f DBus/NameReservation.hs +decodeRequestReply :: Word32 -> Maybe RequestNameReply +decodeRequestReply 1 = Just PrimaryOwner +decodeRequestReply 2 = Just InQueue +decodeRequestReply 3 = Just Exists +decodeRequestReply 4 = Just AlreadyOwner +decodeRequestReply _ = Nothing +: + +:f DBus/NameReservation.hs +|apidoc releaseName| +releaseName :: T.BusName -> M.MethodCall +releaseName name = M.MethodCall + { M.methodCallPath = C.dbusPath + , M.methodCallInterface = Just C.dbusInterface + , M.methodCallDestination = Just C.dbusName + , M.methodCallFlags = Set.empty + , M.methodCallMember = "ReleaseName" + , M.methodCallBody = [T.toVariant name] + } +: + +:f DBus/NameReservation.hs +data ReleaseNameReply + = Released + | NonExistent + | NotOwner + deriving (Show) +: + +:f DBus/NameReservation.hs +mkReleaseNameReply :: M.MethodReturn -> Maybe ReleaseNameReply +mkReleaseNameReply msg = + maybeIndex (M.messageBody msg) 0 >>= + T.fromVariant >>= + decodeReleaseReply +: + +:f DBus/NameReservation.hs +decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply +decodeReleaseReply 1 = Just Released +decodeReleaseReply 2 = Just NonExistent +decodeReleaseReply 3 = Just NotOwner +decodeReleaseReply _ = Nothing +: diff --git a/src/types.anansi b/src/types.anansi new file mode 100644 --- /dev/null +++ b/src/types.anansi @@ -0,0 +1,1236 @@ +:# Copyright (C) 2009-2010 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 . + +\section{Types} + +The {\tt DBus.Types module} defines interfaces for storing, building, and +deconstructing D-Bus values. + +:f DBus/Types.cpphs +|copyright| +|text extensions| +|type extensions| +module DBus.Types ( + |type exports| + ) where +|text imports| +|type imports| +: + +D-Bus types are divided into two categories, ``atomic'' and ``container'' +types. Atoms are actual values -- strings, numbers, etc. Containers store +atoms and other containers. The most interesting difference between the two +is that atoms may be used as the keys in associative mappings +(``dictionaries''). + +Internally, types are represented using an enumeration. + +:f DBus/Types.cpphs +data Type + = DBusBoolean + | DBusByte + | DBusInt16 + | DBusInt32 + | DBusInt64 + | DBusWord16 + | DBusWord32 + | DBusWord64 + | DBusDouble + | DBusString + | DBusSignature + | DBusObjectPath + | DBusVariant + | DBusArray Type + | DBusDictionary Type Type + | DBusStructure [Type] + deriving (Show, Eq) +: + +:f DBus/Types.cpphs +|apidoc isAtomicType| +isAtomicType :: Type -> Bool +isAtomicType DBusBoolean = True +isAtomicType DBusByte = True +isAtomicType DBusInt16 = True +isAtomicType DBusInt32 = True +isAtomicType DBusInt64 = True +isAtomicType DBusWord16 = True +isAtomicType DBusWord32 = True +isAtomicType DBusWord64 = True +isAtomicType DBusDouble = True +isAtomicType DBusString = True +isAtomicType DBusSignature = True +isAtomicType DBusObjectPath = True +isAtomicType _ = False +: + +Each type can be converted to a textual representation, used in ``type +signatures'' or for debugging. + +:f DBus/Types.cpphs +|apidoc typeCode| +typeCode :: Type -> Text +|type codes| +: + +:d type exports + -- * Available types + Type (..) +, typeCode +: + +:f Tests.hs +instance Arbitrary Type where + arbitrary = oneof [atomicType, containerType] + +atomicType :: Gen Type +atomicType = elements + [ DBusBoolean + , DBusByte + , DBusWord16 + , DBusWord32 + , DBusWord64 + , DBusInt16 + , DBusInt32 + , DBusInt64 + , DBusDouble + , DBusString + , DBusObjectPath + , DBusSignature + ] + +containerType :: Gen Type +containerType = do + c <- choose (0,3) :: Gen Int + case c of + 0 -> fmap DBusArray arbitrary + 1 -> do + kt <- atomicType + vt <- arbitrary + return $ DBusDictionary kt vt + 2 -> fmap DBusStructure $ halfSized arbitrary + 3 -> return DBusVariant +: + +\subsection{Variants} + +A wrapper type is needed for safely storing generic D-Bus values in Haskell. +The D-Bus ``variant'' type is perfect for this, because variants may store +any D-Bus value. + +Any type which is an instance of {\tt Variable} is considered a valid +D-Bus value, because it can be used to construct {\tt Variant}s. However, +outside of this module, {\tt Variant}s can only be constructed from +pre-defined types. + +:f DBus/Types.cpphs +|apidoc Variant| +data Variant + = VarBoxBool Bool + | VarBoxWord8 Word8 + | VarBoxInt16 Int16 + | VarBoxInt32 Int32 + | VarBoxInt64 Int64 + | VarBoxWord16 Word16 + | VarBoxWord32 Word32 + | VarBoxWord64 Word64 + | VarBoxDouble Double + | VarBoxString Text + | VarBoxSignature Signature + | VarBoxObjectPath ObjectPath + | VarBoxVariant Variant + | VarBoxArray Array + | VarBoxDictionary Dictionary + | VarBoxStructure Structure + deriving (Eq) + +class Variable a where + toVariant :: a -> Variant + fromVariant :: Variant -> Maybe a +: + +:d type exports + -- * Variants +, Variant +, Variable (..) +: + +Variants can be printed, for debugging purposes -- this instance shouldn't +be parsed or inspected or anything like that, since the output format might +change drastically. + +:f DBus/Types.cpphs +instance Show Variant where + showsPrec d var = showParen (d > 10) full where + full = s "Variant " . shows code . s " " . valueStr + code = typeCode $ variantType var + s = showString + valueStr = showsPrecVar 11 var + +showsPrecVar :: Int -> Variant -> ShowS +showsPrecVar d var = case var of + (VarBoxBool x) -> showsPrec d x + (VarBoxWord8 x) -> showsPrec d x + (VarBoxInt16 x) -> showsPrec d x + (VarBoxInt32 x) -> showsPrec d x + (VarBoxInt64 x) -> showsPrec d x + (VarBoxWord16 x) -> showsPrec d x + (VarBoxWord32 x) -> showsPrec d x + (VarBoxWord64 x) -> showsPrec d x + (VarBoxDouble x) -> showsPrec d x + (VarBoxString x) -> showsPrec d x + (VarBoxSignature x) -> showsPrec d x + (VarBoxObjectPath x) -> showsPrec d x + (VarBoxVariant x) -> showsPrec d x + (VarBoxArray x) -> showsPrec d x + (VarBoxDictionary x) -> showsPrec d x + (VarBoxStructure x) -> showsPrec d x +: + +Since many operations on D-Bus values depend on having the correct type, +{\tt variantType} is used to retrieve which type is actually stored within +a {\tt Variant}. + +:f DBus/Types.cpphs +|apidoc variantType| +variantType :: Variant -> Type +variantType var = case var of + (VarBoxBool _) -> DBusBoolean + (VarBoxWord8 _) -> DBusByte + (VarBoxInt16 _) -> DBusInt16 + (VarBoxInt32 _) -> DBusInt32 + (VarBoxInt64 _) -> DBusInt64 + (VarBoxWord16 _) -> DBusWord16 + (VarBoxWord32 _) -> DBusWord32 + (VarBoxWord64 _) -> DBusWord64 + (VarBoxDouble _) -> DBusDouble + (VarBoxString _) -> DBusString + (VarBoxSignature _) -> DBusSignature + (VarBoxObjectPath _) -> DBusObjectPath + (VarBoxVariant _) -> DBusVariant + (VarBoxArray x) -> DBusArray (arrayType x) + (VarBoxDictionary x) -> let + keyT = dictionaryKeyType x + valueT = dictionaryValueType x + in DBusDictionary keyT valueT + (VarBoxStructure x) -> let + Structure items = x + in DBusStructure (map variantType items) +: + +:d type exports +, variantType +: + +A macro is useful for reducing verbosity in simple {\tt Variable} +instances. + +:f DBus/Types.cpphs +#define INSTANCE_VARIABLE(TYPE) \ + instance Variable TYPE where \ + { toVariant = VarBox/**/TYPE \ + ; fromVariant (VarBox/**/TYPE x) = Just x \ + ; fromVariant _ = Nothing \ + } +: + +Since {\tt Variant}s are D-Bus values themselves, they can be stored in variants. + +:f DBus/Types.cpphs +INSTANCE_VARIABLE(Variant) +: + +For testing, {\tt Variant}s are usually generated by type. + +:f Tests.hs +instance Arbitrary Variant where + arbitrary = arbitrary >>= genVariant + +genVariant :: Type -> Gen Variant +genVariant t = case t of + DBusBoolean -> fmap toVariant (arbitrary :: Gen Bool) + DBusByte -> fmap toVariant (arbitrary :: Gen Word8) + DBusWord16 -> fmap toVariant (arbitrary :: Gen Word16) + DBusWord32 -> fmap toVariant (arbitrary :: Gen Word32) + DBusWord64 -> fmap toVariant (arbitrary :: Gen Word64) + DBusInt16 -> fmap toVariant (arbitrary :: Gen Int16) + DBusInt32 -> fmap toVariant (arbitrary :: Gen Int32) + DBusInt64 -> fmap toVariant (arbitrary :: Gen Int64) + DBusDouble -> fmap toVariant (arbitrary :: Gen Double) + DBusString -> fmap toVariant (arbitrary :: Gen String) + DBusObjectPath -> fmap toVariant (arbitrary :: Gen ObjectPath) + DBusSignature -> fmap toVariant (arbitrary :: Gen Signature) + (DBusArray _) -> fmap toVariant (arbitrary :: Gen Array) + (DBusDictionary _ _) -> fmap toVariant (arbitrary :: Gen Dictionary) + (DBusStructure _) -> fmap toVariant (arbitrary :: Gen Structure) + DBusVariant -> fmap toVariant (arbitrary :: Gen Variant) +: + +\subsection{Numerics} + +D-Bus supports most common numeric types: + +\begin{table}[h] +\caption{D-Bus Numeric types} +\begin{center} +\begin{tabular}{ll} +\toprule +Type & Description \\ +\midrule +Boolean & Either {\tt True} or {\tt False} \\ +Byte & 8-bit unsigned integer \\ +Int16 & 16-bit signed integer \\ +Int32 & 32-bit signed integer \\ +Int64 & 64-bit signed integer \\ +Word16 & 16-bit unsigned integer \\ +Word32 & 32-bit unsigned integer \\ +Word64 & 64-bit unsigned integer \\ +Double & 64-bit IEEE754 floating-point \\ +\bottomrule +\end{tabular} +\end{center} +\end{table} + +All D-Bus numeric types are fixed-length, so the {\tt Int} and {\tt Integer} +types can't be used. Instead, instances for the fixed-length integer types +are defined and any others will have to be converted. + +:d type imports +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int16, Int32, Int64) +: + +:f DBus/Types.cpphs +INSTANCE_VARIABLE(Bool) +INSTANCE_VARIABLE(Word8) +INSTANCE_VARIABLE(Int16) +INSTANCE_VARIABLE(Int32) +INSTANCE_VARIABLE(Int64) +INSTANCE_VARIABLE(Word16) +INSTANCE_VARIABLE(Word32) +INSTANCE_VARIABLE(Word64) +INSTANCE_VARIABLE(Double) +: + +\subsection{Strings} + +Strings are a weird case; the built-in type, {\tt String}, is horribly +inefficent. To provide better performance for large strings, packed Unicode +strings defined in {\tt Data.Text} are used internally. + +:f DBus/Types.cpphs +instance Variable TL.Text where + toVariant = VarBoxString + fromVariant (VarBoxString x) = Just x + fromVariant _ = Nothing +: + +There's two different {\tt Text} types, strict and lazy. It'd be a pain +to store both and have to convert later, so instead, all strict {\tt Text} +values are converted to lazy values. + +:d type imports +import qualified Data.Text as T +: + +:f DBus/Types.cpphs +instance Variable T.Text where + toVariant = toVariant . TL.fromChunks . (:[]) + fromVariant = fmap (T.concat . TL.toChunks) . fromVariant +: + +Built-in {\tt String}s can still be stored, of course, but it requires +a language extension. + +:d type extensions +{-# LANGUAGE TypeSynonymInstances #-} +: + +:f DBus/Types.cpphs +instance Variable String where + toVariant = toVariant . TL.pack + fromVariant = fmap TL.unpack . fromVariant +: + +All this is verified using some QuickCheck properties + +:d test cases +, F.testGroup "String" + [ testProperty "String -> strict Text" + $ funEq (fromVariant . toVariant) (Just . T.pack) + , testProperty "String <- strict Text" + $ funEq (fromVariant . toVariant) (Just . T.unpack) + , testProperty "String -> lazy Text" + $ funEq (fromVariant . toVariant) (Just . TL.pack) + , testProperty "String <- lazy Text" + $ funEq (fromVariant . toVariant) (Just . TL.unpack) + , testProperty "Strict Text -> lazy Text" + $ funEq (fromVariant . toVariant) (Just . TL.pack . T.unpack) + , testProperty "Strict Text <- lazy Text" + $ funEq (fromVariant . toVariant) (Just . T.pack . TL.unpack) + ] +: + +\subsection{Signatures} + +Valid D-Bus types must obey certain rules, such as ``dict keys must be +atomic'', which are difficult to express in the Haskell type system. A +{\tt Signature} is guaranteed to be valid according to these rules. Creating +one requires using the {\tt mkSignature} function, which will convert a valid +D-Bus signature string into a {\tt Signature}. + +:f DBus/Types.cpphs +INSTANCE_VARIABLE(Signature) +data Signature = Signature { signatureTypes :: [Type] } + deriving (Eq) + +instance Show Signature where + showsPrec d x = showParen (d > 10) $ + showString "Signature " . shows (strSignature x) +: + +Signatures can also be converted back into text, by concatenating the +type codes of their contained types. + +:f DBus/Types.cpphs +strSignature :: Signature -> Text +strSignature (Signature ts) = TL.concat $ map typeCode ts +: + +It doesn't make much sense to sort signatures, but since they can be used +as dictionary keys, it's useful to have them as an instance of {\tt Ord}. + +:d type imports +import Data.Ord (comparing) +: + +:f DBus/Types.cpphs +instance Ord Signature where + compare = comparing strSignature +: + +:d type exports + -- * Signatures +, Signature +, signatureTypes +, strSignature +: + +\subsubsection{Type codes} + +For atomic types, the type code is a single letter. Arrays, structures, +and dictionary types are multiple characters. + +:d type codes +typeCode DBusBoolean = "b" +typeCode DBusByte = "y" +typeCode DBusInt16 = "n" +typeCode DBusInt32 = "i" +typeCode DBusInt64 = "x" +typeCode DBusWord16 = "q" +typeCode DBusWord32 = "u" +typeCode DBusWord64 = "t" +typeCode DBusDouble = "d" +typeCode DBusString = "s" +typeCode DBusSignature = "g" +typeCode DBusObjectPath = "o" +typeCode DBusVariant = "v" +: + +An array's type code is ``a'' followed by the type it contains. For example, +an array of booleans would have the type string ``ab''. + +:d type codes +typeCode (DBusArray t) = TL.cons 'a' $ typeCode t +: + +A dictionary's type code is ``a\{$key\_type$ $value\_type$\}''. For example, +a dictionary of bytes to booleans would have the type string ``a\{yb\}''. + +:d type codes +typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"] +: + +A structure's type code is the concatenation of its contained types, +wrapped by ``('' and ``)''. Structures may be empty, in which case their +type code is simply ``()''. + +:d type codes +typeCode (DBusStructure ts) = TL.concat $ + ["("] ++ map typeCode ts ++ [")"] +: + +\subsubsection{Parsing} + +When parsing, additional restrictions apply which are not inherent to the +D-Bus type system. {\tt mkSignature} guarantees that any {\tt Signature} is +valid according to D-Bus rules. + +:f DBus/Types.cpphs +mkSignature :: Text -> Maybe Signature +mkSignature text = parsed where + |fast signature parser| + |slow signature parser| + parsed = case TL.length text of + 0 -> Just $ Signature [] + 1 -> fast + _ -> slow +: + +Since single-type and empty signatures are very common, they are +special-cased for performance. + +:d fast signature parser +just t = Just $ Signature [t] +fast = case TL.head text of + 'b' -> just DBusBoolean + 'y' -> just DBusByte + 'n' -> just DBusInt16 + 'i' -> just DBusInt32 + 'x' -> just DBusInt64 + 'q' -> just DBusWord16 + 'u' -> just DBusWord32 + 't' -> just DBusWord64 + 'd' -> just DBusDouble + 's' -> just DBusString + 'g' -> just DBusSignature + 'o' -> just DBusObjectPath + 'v' -> just DBusVariant + _ -> Nothing +: + +Parsec is used to parse more complex signatures. + +:d type imports +import Text.Parsec ((<|>)) +import qualified Text.Parsec as P +import DBus.Util (checkLength, parseMaybe) +: + +:d slow signature parser +slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text +sigParser = do + types <- P.many parseType + P.eof + return $ Signature types +: + +Types may be either containers or atoms. Containers can't be dictionary +keys. + +:d slow signature parser +parseType = parseAtom <|> parseContainer +parseContainer = + parseArray + <|> parseStruct + <|> (P.char 'v' >> return DBusVariant) +: + +:d slow signature parser +parseArray = do + P.char 'a' + parseDict <|> fmap DBusArray parseType +parseDict = do + P.char '{' + keyType <- parseAtom + valueType <- parseType + P.char '}' + return $ DBusDictionary keyType valueType +: + +Structures can contain any types. + +:d slow signature parser +parseStruct = do + P.char '(' + types <- P.many parseType + P.char ')' + return $ DBusStructure types +: + +:d slow signature parser +parseAtom = + (P.char 'b' >> return DBusBoolean) + <|> (P.char 'y' >> return DBusByte) + <|> (P.char 'n' >> return DBusInt16) + <|> (P.char 'i' >> return DBusInt32) + <|> (P.char 'x' >> return DBusInt64) + <|> (P.char 'q' >> return DBusWord16) + <|> (P.char 'u' >> return DBusWord32) + <|> (P.char 't' >> return DBusWord64) + <|> (P.char 'd' >> return DBusDouble) + <|> (P.char 's' >> return DBusString) + <|> (P.char 'g' >> return DBusSignature) + <|> (P.char 'o' >> return DBusObjectPath) +: + +Since many signatures are defined as string literals, it's useful to +have a helper function to construct a signature directly from a string. +If the input string is invalid, {\tt error} will be called. + +:d type imports +import DBus.Util (mkUnsafe) +import qualified Data.String as String +: + +:f DBus/Types.cpphs +mkSignature_ :: Text -> Signature +mkSignature_ = mkUnsafe "signature" mkSignature + +instance String.IsString Signature where + fromString = mkSignature_ . TL.pack +: + +Most signature-related functions are exposed to clients, except the +{\tt Signature} value constructor. If that were exposed, clients could +construct invalid signatures. + +:d type exports +, mkSignature +, mkSignature_ +: + +:f Tests.hs +instance Arbitrary Signature where + arbitrary = sizedText 255 $ fmap (TL.concat . map typeCode) arbitrary +: + +:d test cases +, F.testGroup "Signature" + [ testProperty "Signature identity" + $ funEq (mkSignature . strSignature) Just + ] +: + +\subsection{Object paths} + +:f DBus/Types.cpphs +INSTANCE_VARIABLE(ObjectPath) +newtype ObjectPath = ObjectPath + { strObjectPath :: Text + } + deriving (Eq, Ord) + +instance Show ObjectPath where + showsPrec d (ObjectPath x) = showParen (d > 10) $ + showString "ObjectPath " . shows x + +instance String.IsString ObjectPath where + fromString = mkObjectPath_ . TL.pack +: + +An object path may be one of + +\begin{itemize} +\item The root path, {\tt "/"}. +\item {\tt '/'}, followed by one or more element names. Each element name + contains characters in the set {\tt [a-zA-Z0-9\_]}, and must have at + least one character. +\end{itemize} + +Element names are separated by {\tt '/'}, and the path may not end in +{\tt '/'} unless it is the root path. + +:f DBus/Types.cpphs +mkObjectPath :: Text -> Maybe ObjectPath +mkObjectPath s = parseMaybe path' (TL.unpack s) where + c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" + path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char + path' = path >> P.eof >> return (ObjectPath s) + +mkObjectPath_ :: Text -> ObjectPath +mkObjectPath_ = mkUnsafe "object path" mkObjectPath +: + +:d type exports + -- * Object paths +, ObjectPath +, strObjectPath +, mkObjectPath +, mkObjectPath_ +: + +:f Tests.hs +instance Arbitrary ObjectPath where + arbitrary = fmap (mkObjectPath_ . TL.pack) path' where + c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" + path = fmap (intercalate "/" . ([] :)) genElements + path' = frequency [(1, return "/"), (9, path)] + genElements = atLeast 1 (atLeast 1 (elements c)) +: + +:d test cases +, F.testGroup "ObjectPath" + [ testProperty "ObjectPath identity" + $ funEq (mkObjectPath . strObjectPath) Just + ] +: + +\subsection{Arrays} + +Arrays are homogenous sequences of any valid D-Bus type. Arrays might be +empty, so the type they contain is stored instead of being calculated from +their contents (as in {\tt variantType}). + +Many D-Bus APIs represent binary data using an array of bytes; therefore, +there is a special constructor for {\tt ByteString}-based arrays. + +:d type imports +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as ByteString +: + +:f DBus/Types.cpphs +INSTANCE_VARIABLE(Array) +data Array + = VariantArray Type [Variant] + | ByteArray ByteString + deriving (Eq) + +|apidoc arrayType| +arrayType :: Array -> Type +arrayType (VariantArray t _) = t +arrayType (ByteArray _) = DBusByte + +arrayItems :: Array -> [Variant] +arrayItems (VariantArray _ xs) = xs +arrayItems (ByteArray xs) = map toVariant $ ByteString.unpack xs +: + +:d type exports + -- * Arrays +, Array +, arrayType +, arrayItems +: + +Like {\tt Variant}, deriving {\tt Show} for {\tt Array} is mostly +just useful for debugging. + +:f DBus/Types.cpphs +instance Show Array where + showsPrec d array = showParen (d > 10) $ + s "Array " . showSig . s " [" . s valueString . s "]" where + s = showString + showSig = shows . typeCode . arrayType $ array + showVar var = showsPrecVar 0 var "" + valueString = intercalate ", " $ map showVar $ arrayItems array +: + +Clients constructing an array must provide the expected item type, which +will be checked for validity. Every item in the array will be checked against +the item type, to ensure the array is homogenous. + +:f DBus/Types.cpphs +arrayFromItems :: Type -> [Variant] -> Maybe Array +arrayFromItems DBusByte vs = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs) + +arrayFromItems t vs = do + mkSignature (typeCode t) + if all (\x -> variantType x == t) vs + then Just $ VariantArray t vs + else Nothing +: + +Additionally, for ease of use, an {\tt Array} can be converted directly +to/from lists of {\tt Variable} values. + +:f DBus/Types.cpphs +toArray :: Variable a => Type -> [a] -> Maybe Array +toArray t = arrayFromItems t . map toVariant + +fromArray :: Variable a => Array -> Maybe [a] +fromArray = mapM fromVariant . arrayItems +: + +:d type exports +, toArray +, fromArray +, arrayFromItems +: + +To provide a more efficient interface for byte array literals, these +functions bypass the conversions in {\tt toArray} and {\tt fromArray} + +:f DBus/Types.cpphs +arrayToBytes :: Array -> Maybe ByteString +arrayToBytes (ByteArray x) = Just x +arrayToBytes _ = Nothing + +arrayFromBytes :: ByteString -> Array +arrayFromBytes = ByteArray +: + +:d type exports +, arrayToBytes +, arrayFromBytes +: + +And to simplify inclusion of {\tt ByteString}s in message, instances of +{\tt Variable} exist for both strict and lazy {\tt ByteString}. + +:f DBus/Types.cpphs +instance Variable ByteString where + toVariant = toVariant . arrayFromBytes + fromVariant x = fromVariant x >>= arrayToBytes +: + +:d type imports +import qualified Data.ByteString as StrictByteString +: + +:f DBus/Types.cpphs +instance Variable StrictByteString.ByteString where + toVariant x = toVariant . arrayFromBytes $ ByteString.fromChunks [x] + fromVariant x = do + chunks <- ByteString.toChunks `fmap` fromVariant x + return $ StrictByteString.concat chunks +: + +When generating random arrays for testing, only atomic values are used. +Random containers are almost never homogenous. + +:f Tests.hs +instance Arbitrary Array where + arbitrary = do + t <- atomicType + xs <- listOf $ genVariant t + return . fromJust $ arrayFromItems t xs + +prop_ArrayHomogeneous vs = isJust array == homogeneousTypes where + array = arrayFromItems firstType vs + homogeneousTypes = all (== firstType) types + types = map variantType vs + firstType = if null types + then DBusByte + else head types +: + +:d test cases +, F.testGroup "Array" + [ testProperty "Array identity" + $ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x) + , testProperty "Array homogeneity" prop_ArrayHomogeneous + ] +: + +\subsection{Dictionaries} + +Dictionaries are a homogenous (key $\rightarrow$ value) mapping, where the +key type must be atomic. Values may be of any valid D-Bus type. Like +{\tt Array}, {\tt Dictionary} stores its contained types. + +:f DBus/Types.cpphs +INSTANCE_VARIABLE(Dictionary) +data Dictionary = Dictionary + { dictionaryKeyType :: Type + , dictionaryValueType :: Type + , dictionaryItems :: [(Variant, Variant)] + } + deriving (Eq) +: + +:d type exports + -- * Dictionaries +, Dictionary +, dictionaryItems +, dictionaryKeyType +, dictionaryValueType +: + +{\tt show}ing a {\tt Dictionary} displays the mapping in a more readable +format than a list of pairs. + +:d type imports +import Data.List (intercalate) +: + +:f DBus/Types.cpphs +instance Show Dictionary where + showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $ + s "Dictionary " . showSig . s " {" . s valueString . s "}" where + s = showString + showSig = shows $ TL.append (typeCode kt) (typeCode vt) + valueString = intercalate ", " $ map showPair pairs + showPair (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 v) "" +: + +Constructing a {\tt Dictionary} works like constructing an {\tt Array}, +except that there are two types to check, and the key type must be atomic. + +:d type imports +import Control.Monad (unless) +: + +:f DBus/Types.cpphs +dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary +dictionaryFromItems kt vt pairs = do + unless (isAtomicType kt) Nothing + mkSignature (typeCode kt) + mkSignature (typeCode vt) + + let sameType (k, v) = variantType k == kt && + variantType v == vt + if all sameType pairs + then Just $ Dictionary kt vt pairs + else Nothing +: + +The closest match for dictionary semantics in Haskell is the +{\tt Data.Map.Map} type. Therefore, the utility conversion functions work +with {\tt Map}s instead of pair lists. + +:d type imports +import Control.Arrow ((***)) +import qualified Data.Map as Map +: + +:f DBus/Types.cpphs +toDictionary :: (Variable a, Variable b) => Type -> Type -> Map.Map a b + -> Maybe Dictionary +toDictionary kt vt = dictionaryFromItems kt vt . pairs where + pairs = map (toVariant *** toVariant) . Map.toList +: + +:d type imports +import Control.Monad (forM) +: + +:f DBus/Types.cpphs +fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary + -> Maybe (Map.Map a b) +fromDictionary (Dictionary _ _ vs) = do + pairs <- forM vs $ \(k, v) -> do + k' <- fromVariant k + v' <- fromVariant v + return (k', v') + return $ Map.fromList pairs +: + +:d type exports +, toDictionary +, fromDictionary +, dictionaryFromItems +: + +When generating random dictionaries for testing, only atomic values are used. +Random containers are almost never homogenous. + +:f Tests.hs +instance Arbitrary Dictionary where + arbitrary = do + kt <- atomicType + vt <- atomicType + ks <- listOf $ genVariant kt + vs <- vectorOf (length ks) $ genVariant vt + + return . fromJust $ dictionaryFromItems kt vt $ zip ks vs + +prop_DictionaryHomogeneous x = all correctType pairs where + pairs = dictionaryItems x + kType = dictionaryKeyType x + vType = dictionaryValueType x + correctType (k, v) = variantType k == kType && + variantType v == vType +: + +:d test cases +, F.testGroup "Dictionary" + [ testProperty "Dictionary identity" + $ \x -> Just x == dictionaryFromItems + (dictionaryKeyType x) + (dictionaryValueType x) + (dictionaryItems x) + , testProperty "Dictionary homogeneity" prop_DictionaryHomogeneous + , testProperty "Dictionary must have atomic keys" + $ \vt -> forAll containerType $ \kt -> + isNothing (dictionaryFromItems kt vt []) + , testProperty "Dictionary <-> Array conversion" + $ funEq (arrayToDictionary . dictionaryToArray) Just + ] +: + +\subsubsection{Converting between {\tt Array} and {\tt Dictionary}} + +Converting between {\tt Array} and {\tt Dictionary} is useful when +(un)marshaling -- dictionaries can be thought of as arrays of two-element +structures, much as a {\tt Map} is a list of pairs. + +:f DBus/Types.cpphs +dictionaryToArray :: Dictionary -> Array +dictionaryToArray (Dictionary kt vt items) = array where + Just array = toArray itemType structs + itemType = DBusStructure [kt, vt] + structs = [Structure [k, v] | (k, v) <- items] +: + +:f DBus/Types.cpphs +arrayToDictionary :: Array -> Maybe Dictionary +arrayToDictionary array = do + let toPair x = do + struct <- fromVariant x + case struct of + Structure [k, v] -> Just (k, v) + _ -> Nothing + (kt, vt) <- case arrayType array of + DBusStructure [kt, vt] -> Just (kt, vt) + _ -> Nothing + pairs <- mapM toPair $ arrayItems array + dictionaryFromItems kt vt pairs +: + +:d type exports +, dictionaryToArray +, arrayToDictionary +: + +\subsection{Structures} + +A heterogeneous, fixed-length container; equivalent in purpose to a Haskell +tuple. + +:f DBus/Types.cpphs +INSTANCE_VARIABLE(Structure) +data Structure = Structure [Variant] + deriving (Show, Eq) +: + +:d type exports + -- * Structures +, Structure (..) +: + +:f Tests.hs +instance Arbitrary Structure where + arbitrary = fmap Structure $ halfSized arbitrary +: + +\subsection{Names} + +Various aspects of D-Bus require the use of specially-formatted strings, +called ``names''. All names are limited to 255 characters, and use subsets +of ASCII. + +Since all names have basically the same structure (a {\tt newtype} +declaration and some helper functions), I define a macro to automate +the definitions. + +:f DBus/Types.cpphs +#define NAME_TYPE(TYPE, NAME) \ + newtype TYPE = TYPE {str/**/TYPE :: Text} \ + deriving (Eq, Ord); \ + \ + instance Show TYPE where \ + { showsPrec d (TYPE x) = showParen (d > 10) $ \ + showString "TYPE " . shows x \ + }; \ + \ + instance String.IsString TYPE where \ + { fromString = mk/**/TYPE/**/_ . TL.pack }; \ + \ + instance Variable TYPE where \ + { toVariant = toVariant . str/**/TYPE \ + ; fromVariant = (mk/**/TYPE =<<) . fromVariant }; \ + \ + mk/**/TYPE/**/_ :: Text -> TYPE; \ + mk/**/TYPE/**/_ = mkUnsafe NAME mk/**/TYPE +: + +:d type exports +-- * Names +: + +\subsubsection{Bus names} + +There are two forms of bus names, ``unique'' and ``well-known''. + +Unique names begin with {\tt `:'} and contain two or more elements, separated +by {\tt `.'}. Each element consists of characters from the set +{\tt [a-zA-Z0-9\_-]}. + +Well-known names contain two or more elements, separated by {\tt `.'}. Each +element consists of characters from the set {\tt [a-zA-Z0-9\_-]}, and must +not start with a digit. + +:f DBus/Types.cpphs +NAME_TYPE(BusName, "bus name") + +mkBusName :: Text -> Maybe BusName +mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" + c' = c ++ ['0'..'9'] + parser = (unique <|> wellKnown) >> P.eof >> return (BusName s) + unique = P.char ':' >> elems c' + wellKnown = elems c + elems start = elem' start >> P.many1 (P.char '.' >> elem' start) + elem' start = P.oneOf start >> P.many (P.oneOf c') +: + +:d type exports + -- ** Bus names +, BusName +, strBusName +, mkBusName +, mkBusName_ +: + +:f Tests.hs +instance Arbitrary BusName where + arbitrary = sizedText 255 (oneof [unique, wellKnown]) where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" + c' = c ++ ['0'..'9'] + + unique = do + elems' <- atLeast 2 $ elems c' + return . TL.pack $ ':' : intercalate "." elems' + + wellKnown = do + elems' <- atLeast 2 $ elems c + return . TL.pack $ intercalate "." elems' + + elems start = do + x <- elements start + xs <- atLeast 0 (elements c') + return (x:xs) +: + +:d test cases +, F.testGroup "BusName" + [ testProperty "BusName identity" + $ funEq (mkBusName . strBusName) Just + ] +: + +\subsubsection{Interface names} + +An interface name consists of two or more {\tt '.'}-separated elements. Each +element constists of characters from the set {\tt [a-zA-Z0-9\_]}, may not +start with a digit, and must have at least one character. + +:f DBus/Types.cpphs +NAME_TYPE(InterfaceName, "interface name") + +mkInterfaceName :: Text -> Maybe InterfaceName +mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + element = P.oneOf c >> P.many (P.oneOf c') + name = element >> P.many1 (P.char '.' >> element) + parser = name >> P.eof >> return (InterfaceName s) +: + +:d type exports + -- ** Interface names +, InterfaceName +, strInterfaceName +, mkInterfaceName +, mkInterfaceName_ +: + +:f Tests.hs +instance Arbitrary InterfaceName where + arbitrary = sizedText 255 genName where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + + genName = fmap (TL.pack . intercalate ".") genElements + genElements = atLeast 2 genElement + genElement = do + x <- elements c + xs <- atLeast 0 (elements c') + return (x:xs) +: + +:d test cases +, F.testGroup "InterfaceName" + [ testProperty "InterfaceName identity" + $ funEq (mkInterfaceName . strInterfaceName) Just + ] +: + +\subsubsection{Error names} + +Error names have the same format as interface names, so the parser logic +can just be re-purposed. + +:f DBus/Types.cpphs +NAME_TYPE(ErrorName, "error name") + +mkErrorName :: Text -> Maybe ErrorName +mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName +: + +:d type exports + -- ** Error names +, ErrorName +, strErrorName +, mkErrorName +, mkErrorName_ +: + +:f Tests.hs +instance Arbitrary ErrorName where + arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary +: + +:d test cases +, F.testGroup "ErrorName" + [ testProperty "ErrorName identity" + $ funEq (mkErrorName . strErrorName) Just + ] +: + +\subsubsection{Member names} + +Member names must contain only characters from the set {\tt [a-zA-Z0-9\_]}, +may not begin with a digit, and must be at least one character long. + +:f DBus/Types.cpphs +NAME_TYPE(MemberName, "member name") + +mkMemberName :: Text -> Maybe MemberName +mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + name = P.oneOf c >> P.many (P.oneOf c') + parser = name >> P.eof >> return (MemberName s) +: + +:d type exports + -- ** Member names +, MemberName +, strMemberName +, mkMemberName +, mkMemberName_ +: + +:f Tests.hs +instance Arbitrary MemberName where + arbitrary = sizedText 255 genName where + c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" + c' = c ++ ['0'..'9'] + + genName = do + x <- elements c + xs <- atLeast 0 (elements c') + return . TL.pack $ (x:xs) +: + +:d test cases +, F.testGroup "MemberName" + [ testProperty "MemberName identity" + $ funEq (mkMemberName . strMemberName) Just + ] +: diff --git a/src/util.anansi b/src/util.anansi new file mode 100644 --- /dev/null +++ b/src/util.anansi @@ -0,0 +1,262 @@ +:# Copyright (C) 2009-2010 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 . + +\section{UUIDs} + +D-Bus {\sc uuid}s are 128-bit unique identifiers, used for server instances +and machine {\sc id}s. They are not compatible with {\sc rfc4122}. + +:f DBus/UUID.hs +|copyright| +module DBus.UUID + ( UUID + , toHex + , fromHex + ) where +|text imports| + +newtype UUID = UUID Text -- TODO: (Word64, Word64)? + deriving (Eq) + +instance Show UUID where + showsPrec d uuid = showParen (d > 10) $ + showString "UUID " . shows (toHex uuid) + +toHex :: UUID -> Text +toHex (UUID text) = text + +fromHex :: Text -> Maybe UUID +fromHex text = if validUUID text + then Just $ UUID text + else Nothing + +validUUID :: Text -> Bool +validUUID text = valid where + valid = and [TL.length text == 32, TL.all validChar text] + validChar c = or + [ c >= '0' && c <= '9' + , c >= 'a' && c <= 'f' + , c >= 'A' && c <= 'F' + ] +: + +\section{Misc. utility functions} + +:f DBus/Util.hs +|copyright| +module DBus.Util where +import Text.Parsec (Parsec, parse) +import Data.Char (digitToInt) +import Data.List (isPrefixOf) + +checkLength :: Int -> String -> Maybe String +checkLength length' s | length s <= length' = Just s +checkLength _ _ = Nothing + +parseMaybe :: Parsec String () a -> String -> Maybe a +parseMaybe p = either (const Nothing) Just . parse p "" + +mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b +mkUnsafe label f x = case f x of + Just x' -> x' + Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x + +hexToInt :: String -> Int +hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt + +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (Left _) = Nothing +eitherToMaybe (Right x) = Just x + +fromRight :: Either a b -> b +fromRight (Right x) = x +fromRight _ = error "DBus.Util.fromRight: Left" + +maybeIndex :: [a] -> Int -> Maybe a +maybeIndex (x:_ ) 0 = Just x +maybeIndex (_:xs) n | n > 0 = maybeIndex xs (n - 1) +maybeIndex _ _ = Nothing + +-- | Read values from a monad until a guard value is read; return all +-- values, including the guard. +-- +readUntil :: (Monad m, Eq a) => [a] -> m a -> m [a] +readUntil guard getx = readUntil' [] where + guard' = reverse guard + step xs | isPrefixOf guard' xs = return . reverse $ xs + | otherwise = readUntil' xs + readUntil' xs = do + x <- getx + step $ x:xs + +-- | Drop /n/ items from the end of a list +dropEnd :: Int -> [a] -> [a] +dropEnd n xs = take (length xs - n) xs +: + +\subsection{Bundled ErrorT variant} + +The default {\tt ErrorT} type in the {\tt transformers} package has an idiotic +dependency on the {\tt Error} class, which is used to implement the obsolete +{\tt fail} function. This module is a variant, which doesn't include this +dependency. + +:f DBus/Util/MonadError.hs +|copyright| +{-# LANGUAGE TypeFamilies #-} +module DBus.Util.MonadError + ( ErrorT (..) + , throwError + ) where +import Control.Monad.Trans.Class +import Control.Monad.State +import Control.Monad.Error.Class + +newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } + +instance Functor m => Functor (ErrorT e m) where + fmap f = ErrorT . fmap (fmap f) . runErrorT + +instance Monad m => Monad (ErrorT e m) where + return = ErrorT . return . Right + (>>=) m k = ErrorT $ do + x <- runErrorT m + case x of + Left l -> return $ Left l + Right r -> runErrorT $ k r + +instance MonadTrans (ErrorT e) where + lift = ErrorT . liftM Right + +instance Monad m => MonadError (ErrorT e m) where + type ErrorType (ErrorT e m) = e + throwError = ErrorT . return . Left + catchError m h = ErrorT $ do + x <- runErrorT m + case x of + Left l -> runErrorT $ h l + Right r -> return $ Right r + +instance MonadState m => MonadState (ErrorT e m) where + type StateType (ErrorT e m) = StateType m + get = lift get + put = lift . put +: + +\subsection{Extra test support} + +The test suite requires a whole bunch of imports + +:d test imports +import Test.QuickCheck +import qualified Test.Framework as F +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Control.Arrow ((&&&)) +import Control.Monad (replicateM) +import qualified Data.Binary.Get as G +import Data.Char (isPrint) +import Data.String +import Data.List (intercalate, isInfixOf) +import Data.Maybe (fromJust, isJust, isNothing) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int16, Int32, Int64) + +import DBus.Address +import DBus.Message.Internal +import DBus.Types +import DBus.Wire.Internal +import DBus.Wire.Marshal +import DBus.Wire.Unmarshal +import qualified DBus.Introspection as I +: + +:f Tests.hs +halfSized :: Gen a -> Gen a +halfSized gen = sized $ \n -> if n > 0 then + resize (n `div` 2) gen + else gen + +funEq :: Eq b => (a -> b) -> (a -> b) -> a -> Bool +funEq f g x = f x == g x + +sizedText :: (IsString a, Arbitrary a) => Integer -> Gen TL.Text -> Gen a +sizedText maxSize gen = step where + step = do + s <- gen + if toInteger (TL.length s) > maxSize + then halfSized step + else return . fromString . TL.unpack $ s + +atLeast :: Int -> Gen a -> Gen [a] +atLeast minSize g = sized $ \n -> do + count <- choose (minSize, max minSize n) + replicateM count g + +isRight :: Either a b -> Bool +isRight = either (const False) (const True) +: + +Some tests, such as address parsing, are single-case tests instead of +the more common ``property''. This function lets them be run only once. + +:f Tests.hs +test :: Testable a => F.TestName -> a -> F.Test +test name prop = F.plusTestOptions options (testProperty name prop) where + options = F.TestOptions Nothing (Just 1) Nothing Nothing +: + +QuickCheck doesn't define instances for fixed-size integral types or +variants of {\tt Text}, so define them here. + +:f Tests.hs +instance Arbitrary Word8 where + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word16 where + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word32 where + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word64 where + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int16 where + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int32 where + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int64 where + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary T.Text where + arbitrary = fmap T.pack arbitrary + +instance Arbitrary TL.Text where + arbitrary = fmap TL.pack arbitrary +: diff --git a/src/wire.anansi b/src/wire.anansi new file mode 100644 --- /dev/null +++ b/src/wire.anansi @@ -0,0 +1,1170 @@ +:# Copyright (C) 2009-2010 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 . + +\section{Wire format} + +{\tt DBus.Wire} is also split into an internal and external interface. + +:f DBus/Wire.hs +|copyright| +module DBus.Wire ( + |wire exports| + ) where +import DBus.Wire.Internal +import DBus.Wire.Marshal +import DBus.Wire.Unmarshal +: + +:f DBus/Wire/Internal.hs +|copyright| +module DBus.Wire.Internal where +import Data.Word (Word8, Word64) +import qualified DBus.Types as T +: + +\subsection{Endianness} + +:f DBus/Wire/Internal.hs +data Endianness = LittleEndian | BigEndian + deriving (Show, Eq) + +encodeEndianness :: Endianness -> Word8 +encodeEndianness LittleEndian = 108 +encodeEndianness BigEndian = 66 + +decodeEndianness :: Word8 -> Maybe Endianness +decodeEndianness 108 = Just LittleEndian +decodeEndianness 66 = Just BigEndian +decodeEndianness _ = Nothing +: + +:d wire exports + Endianness (..) +: + +:f Tests.hs +instance Arbitrary Endianness where + arbitrary = elements [LittleEndian, BigEndian] +: + +\subsection{Alignment} + +Every built-in type has an associated alignment. If a value of the given +type is marshaled, it must have {\sc nul} bytes inserted until it starts +on a byte index divisible by its alignment. + +:f DBus/Wire/Internal.hs +alignment :: T.Type -> Word8 +|alignments| + +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 +: + +\subsection{Marshaling} + +Marshaling is implemented using an error transformer over an internal +state. The {\tt Builder} type is used for efficient construction of lazy +byte strings, but it doesn't provide any way to retrieve the length of its +internal buffer, so the byte count is tracked separately. + +:f DBus/Wire/Marshal.hs +|copyright| +{-# LANGUAGE TypeFamilies #-} +module DBus.Wire.Marshal where +|text imports| +|marshal imports| +import DBus.Wire.Internal +import Control.Monad (when) +import Data.Maybe (fromJust) +import Data.Word (Word8, Word32, Word64) +import Data.Int (Int16, Int32, Int64) + +import qualified DBus.Types as T +: + +:d marshal imports +import qualified Control.Monad.State as State +import qualified DBus.Util.MonadError as E +import qualified Data.ByteString.Lazy as L +import qualified Data.Binary.Builder as B +: + +:f DBus/Wire/Marshal.hs +data MarshalState = MarshalState Endianness B.Builder !Word64 +type MarshalM = E.ErrorT MarshalError (State.State MarshalState) +type Marshal = MarshalM () +: + +Clients can perform marshaling via {\tt marshal} and {\tt runMarshal}, +which will generate a {\tt ByteString} with the fully marshaled data. + +:f DBus/Wire/Marshal.hs +runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString +runMarshal m e = case State.runState (E.runErrorT m) initialState of + (Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder) + (Left x, _) -> Left x + where initialState = MarshalState e B.empty 0 +: + +:f DBus/Wire/Marshal.hs +marshal :: T.Variant -> Marshal +marshal v = marshalType (T.variantType v) where + x :: T.Variable a => a + x = fromJust . T.fromVariant $ v + marshalType :: T.Type -> Marshal + |marshalers| +: + +TODO: describe these functions + +:f DBus/Wire/Marshal.hs +append :: L.ByteString -> Marshal +append bytes = do + (MarshalState e builder count) <- State.get + let builder' = B.append builder $ B.fromLazyByteString bytes + count' = count + fromIntegral (L.length bytes) + State.put $ MarshalState e builder' count' +: + +:f DBus/Wire/Marshal.hs +pad :: Word8 -> Marshal +pad count = do + (MarshalState _ _ existing) <- State.get + let padding' = fromIntegral $ padding existing count + append $ L.replicate padding' 0 +: + +Most numeric values already have marshalers implemented in the +{\tt Data.Binary.Builder} module; this function lets them be re-used easily. + +:f DBus/Wire/Marshal.hs +marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal +marshalBuilder size be le x = do + pad size + (MarshalState e builder count) <- State.get + let builder' = B.append builder $ case e of + BigEndian -> be x + LittleEndian -> le x + let count' = count + fromIntegral size + State.put $ MarshalState e builder' count' +: + +\subsubsection{Errors} + +Marshaling can fail for four reasons: + +\begin{itemize} +\item The message exceeds the maximum message size of $2^{27}$ bytes. +\item An array in the message exceeds the maximum array size of $2^{26}$ bytes. +\item The body's signature is not valid (for example, more than 255 fields). +\item A variant's signature is not valid -- same causes as an invalid body + signature. +\item Some text is invalid -- for example, it contains {\sc nul} + ({\tt '\textbackslash{}0'}) or invalid Unicode. +\end{itemize} + +:f DBus/Wire/Marshal.hs +data MarshalError + = MessageTooLong Word64 + | ArrayTooLong Word64 + | InvalidBodySignature Text + | InvalidVariantSignature Text + | InvalidText Text + deriving (Eq) + +instance Show MarshalError where + show (MessageTooLong x) = concat + ["Message too long (", show x, " bytes)."] + show (ArrayTooLong x) = concat + ["Array too long (", show x, " bytes)."] + show (InvalidBodySignature x) = concat + ["Invalid body signature: ", show x] + show (InvalidVariantSignature x) = concat + ["Invalid variant signature: ", show x] + show (InvalidText x) = concat + ["Text cannot be marshaled: ", show x] +: + +:d wire exports +, MarshalError (..) +: + +\subsection{Unmarshaling} + +Unmarshaling also uses an error transformer and internal state. + +:f DBus/Wire/Unmarshal.hs +|copyright| +|text extensions| +{-# LANGUAGE TypeFamilies #-} +module DBus.Wire.Unmarshal where +|text imports| +|unmarshal imports| +import Control.Monad (when, unless, liftM) +import Data.Maybe (fromJust, listToMaybe, fromMaybe) +import Data.Word (Word8, Word32, Word64) +import Data.Int (Int16, Int32, Int64) + +import DBus.Wire.Internal +import qualified DBus.Types as T +: + +:d unmarshal imports +import qualified Control.Monad.State as State +import Control.Monad.Trans.Class (lift) +import qualified DBus.Util.MonadError as E +import qualified Data.ByteString.Lazy as L +: + +:f DBus/Wire/Unmarshal.hs +data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64 +type Unmarshal = E.ErrorT UnmarshalError (State.State UnmarshalState) +: + +:f DBus/Wire/Unmarshal.hs +runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a +runUnmarshal m e bytes = State.evalState (E.runErrorT m) state where + state = UnmarshalState e bytes 0 +: + +:f DBus/Wire/Unmarshal.hs +unmarshal :: T.Signature -> Unmarshal [T.Variant] +unmarshal = mapM unmarshalType . T.signatureTypes + +unmarshalType :: T.Type -> Unmarshal T.Variant +|unmarshalers| +: + +TODO: describe these functions + +:f DBus/Wire/Unmarshal.hs +consume :: Word64 -> Unmarshal L.ByteString +consume count = do + (UnmarshalState e bytes offset) <- State.get + let (x, bytes') = L.splitAt (fromIntegral count) bytes + unless (L.length x == fromIntegral count) $ + E.throwError $ UnexpectedEOF offset + + State.put $ UnmarshalState e bytes' (offset + count) + return x +: + +:f DBus/Wire/Unmarshal.hs +skipPadding :: Word8 -> Unmarshal () +skipPadding count = do + (UnmarshalState _ _ offset) <- State.get + bytes <- consume $ padding offset count + unless (L.all (== 0) bytes) $ + E.throwError $ InvalidPadding offset +: + +:f DBus/Wire/Unmarshal.hs +skipTerminator :: Unmarshal () +skipTerminator = do + (UnmarshalState _ _ offset) <- State.get + bytes <- consume 1 + unless (L.all (== 0) bytes) $ + E.throwError $ MissingTerminator offset +: + +:f DBus/Wire/Unmarshal.hs +fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b +fromMaybeU label f x = case f x of + Just x' -> return x' + Nothing -> E.throwError . Invalid label . TL.pack . show $ x + +fromMaybeU' :: (Show a, T.Variable b) => Text -> (a -> Maybe b) -> a + -> Unmarshal T.Variant +fromMaybeU' label f x = do + x' <- fromMaybeU label f x + return $ T.toVariant x' +: + +:d unmarshal imports +import qualified Data.Binary.Get as G +: + +:f DBus/Wire/Unmarshal.hs +unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a +unmarshalGet count be le = do + skipPadding count + (UnmarshalState e _ _) <- State.get + bs <- consume . fromIntegral $ count + let get' = case e of + BigEndian -> be + LittleEndian -> le + return $ G.runGet get' bs + +unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a + -> Unmarshal T.Variant +unmarshalGet' count be le = T.toVariant `fmap` unmarshalGet count be le +: + +:f DBus/Wire/Unmarshal.hs +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 +: + +\subsubsection{Errors} + +Unmarshaling can fail for four reasons: + +\begin{itemize} +\item The message's declared protocol version is unsupported. +\item Unexpected {\sc eof}, when there are less bytes remaining than are + required. +\item An invalid byte sequence for a given value type. +\item Missing required header fields for the declared message type. +\item Non-zero bytes were found where padding was expected. +\item A string, signature, or object path was not {\sc null}-terminated. +\item An array's size didn't match the number of elements +\end{itemize} + +:f DBus/Wire/Unmarshal.hs +data UnmarshalError + = UnsupportedProtocolVersion Word8 + | UnexpectedEOF Word64 + | Invalid Text Text + | MissingHeaderField Text + | InvalidHeaderField Text T.Variant + | InvalidPadding Word64 + | MissingTerminator Word64 + | ArraySizeMismatch + deriving (Eq) + +instance Show UnmarshalError where + show (UnsupportedProtocolVersion x) = concat + ["Unsupported protocol version: ", show x] + show (UnexpectedEOF pos) = concat + ["Unexpected EOF at position ", show pos] + show (Invalid label x) = TL.unpack $ TL.concat + ["Invalid ", label, ": ", x] + show (MissingHeaderField x) = concat + ["Required field " , show x , " is missing."] + show (InvalidHeaderField x got) = concat + [ "Invalid header field ", show x, ": ", show got] + show (InvalidPadding pos) = concat + ["Invalid padding at position ", show pos] + show (MissingTerminator pos) = concat + ["Missing NUL terminator at position ", show pos] + show ArraySizeMismatch = "Array size mismatch" +: + +:d wire exports +, UnmarshalError (..) +: + +\subsection{Numerics} + +Numeric values are fixed-length, and aligned ``naturally'' -- ie, a 4-byte +integer will have a 4-byte alignment. + +:d alignments +alignment T.DBusByte = 1 +alignment T.DBusWord16 = 2 +alignment T.DBusWord32 = 4 +alignment T.DBusWord64 = 8 +alignment T.DBusInt16 = 2 +alignment T.DBusInt32 = 4 +alignment T.DBusInt64 = 8 +alignment T.DBusDouble = 8 +: + +Because {\tt Word32}s are often used for other types, there's +separate functions for handling them. + +:f DBus/Wire/Marshal.hs +marshalWord32 :: Word32 -> Marshal +marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le +: + +:f DBus/Wire/Unmarshal.hs +unmarshalWord32 :: Unmarshal Word32 +unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le +: + +:d marshalers +marshalType T.DBusByte = append $ L.singleton x +marshalType T.DBusWord16 = marshalBuilder 2 B.putWord16be B.putWord16le x +marshalType T.DBusWord32 = marshalBuilder 4 B.putWord32be B.putWord32le x +marshalType T.DBusWord64 = marshalBuilder 8 B.putWord64be B.putWord64le x +marshalType T.DBusInt16 = marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral (x :: Int16) +marshalType T.DBusInt32 = marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral (x :: Int32) +marshalType T.DBusInt64 = marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral (x :: Int64) +: + +:d unmarshalers +unmarshalType T.DBusByte = fmap (T.toVariant . L.head) $ consume 1 +unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le +unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le +unmarshalType T.DBusWord64 = unmarshalGet' 8 G.getWord64be G.getWord64le + +unmarshalType T.DBusInt16 = do + x <- unmarshalGet 2 G.getWord16be G.getWord16le + return . T.toVariant $ (fromIntegral x :: Int16) + +unmarshalType T.DBusInt32 = do + x <- unmarshalGet 4 G.getWord32be G.getWord32le + return . T.toVariant $ (fromIntegral x :: Int32) + +unmarshalType T.DBusInt64 = do + x <- unmarshalGet 8 G.getWord64be G.getWord64le + return . T.toVariant $ (fromIntegral x :: Int64) +: + +{\tt Double}s are marshaled as in-bit IEEE-754 floating-point format. + +:d marshal imports +import Data.Binary.Put (runPut) +import qualified Data.Binary.IEEE754 as IEEE +: + +:d unmarshal imports +import qualified Data.Binary.IEEE754 as IEEE +: + +:d marshalers +marshalType T.DBusDouble = do + pad 8 + (MarshalState e _ _) <- State.get + let put = case e of + BigEndian -> IEEE.putFloat64be + LittleEndian -> IEEE.putFloat64le + let bytes = runPut $ put x + append bytes +: + +:d unmarshalers +unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le +: + +\subsection{Booleans} + +Booleans are marshaled as 4-byte unsigned integers containing either of +the values 0 or 1. Yes, really. + +:d alignments +alignment T.DBusBoolean = 4 +: + +:d marshalers +marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0 +: + +:d unmarshalers +unmarshalType T.DBusBoolean = unmarshalWord32 >>= + fromMaybeU' "boolean" (\x -> case x of + 0 -> Just False + 1 -> Just True + _ -> Nothing) +: + +\subsection{Strings and object paths} + +Strings are encoded in {\sc utf-8}, terminated with {\tt NUL}, and prefixed +with their length as an unsigned 32-bit integer. Their alignment is that of +their length. Object paths are marshaled just like strings, though additional +checks are required when unmarshaling. + +Because the encoding functions from {\tt Data.Text} raise exceptions on +error, checking their return value requires some ugly workarounds. + +:f DBus/Wire/Unicode.hs +|copyright| +module DBus.Wire.Unicode + ( maybeEncodeUtf8 + , maybeDecodeUtf8) where +import Data.ByteString.Lazy (ByteString) +import Data.Text.Lazy (Text) +import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) +import Data.Text.Encoding.Error (UnicodeException) +import qualified Control.Exception as Exc +import System.IO.Unsafe (unsafePerformIO) + +excToMaybe :: a -> Maybe a +excToMaybe x = unsafePerformIO $ fmap Just (Exc.evaluate x) `Exc.catch` unicodeError + +unicodeError :: UnicodeException -> IO (Maybe a) +unicodeError = const $ return Nothing + +maybeEncodeUtf8 :: Text -> Maybe ByteString +maybeEncodeUtf8 = excToMaybe . encodeUtf8 + +maybeDecodeUtf8 :: ByteString -> Maybe Text +maybeDecodeUtf8 = excToMaybe . decodeUtf8 +: + +:d marshal imports +import DBus.Wire.Unicode (maybeEncodeUtf8) +: + +:f DBus/Wire/Marshal.hs +marshalText :: Text -> Marshal +marshalText x = do + bytes <- case maybeEncodeUtf8 x of + Just x' -> return x' + Nothing -> E.throwError $ InvalidText x + when (L.any (== 0) bytes) $ + E.throwError $ InvalidText x + marshalWord32 . fromIntegral . L.length $ bytes + append bytes + append (L.singleton 0) +: + +:d unmarshal imports +import DBus.Wire.Unicode (maybeDecodeUtf8) +: + +:f DBus/Wire/Unmarshal.hs +unmarshalText :: Unmarshal Text +unmarshalText = do + byteCount <- unmarshalWord32 + bytes <- consume . fromIntegral $ byteCount + skipTerminator + fromMaybeU "text" maybeDecodeUtf8 bytes +: + +:d alignments +alignment T.DBusString = 4 +alignment T.DBusObjectPath = 4 +: + +:d marshalers +marshalType T.DBusString = marshalText x +marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x +: + +:d unmarshalers +unmarshalType T.DBusString = fmap T.toVariant unmarshalText + +unmarshalType T.DBusObjectPath = unmarshalText >>= + fromMaybeU' "object path" T.mkObjectPath +: + +\subsection{Signatures} + +Signatures are similar to strings, except their length is limited to 255 +characters and is therefore stored as a single byte. + +:d marshal imports +import Data.Text.Lazy.Encoding (encodeUtf8) +: + +:f DBus/Wire/Marshal.hs +marshalSignature :: T.Signature -> Marshal +marshalSignature x = do + let bytes = encodeUtf8 . T.strSignature $ x + let size = fromIntegral . L.length $ bytes + append (L.singleton size) + append bytes + append (L.singleton 0) +: + +:f DBus/Wire/Unmarshal.hs +unmarshalSignature :: Unmarshal T.Signature +unmarshalSignature = do + byteCount <- L.head `fmap` consume 1 + bytes <- consume $ fromIntegral byteCount + sigText <- fromMaybeU "text" maybeDecodeUtf8 bytes + skipTerminator + fromMaybeU "signature" T.mkSignature sigText +: + +:d alignments +alignment T.DBusSignature = 1 +: + +:d marshalers +marshalType T.DBusSignature = marshalSignature x +: + +:d unmarshalers +unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature +: + +\subsection{Containers} + +\subsubsection{Arrays} + +:d alignments +alignment (T.DBusArray _) = 4 +: + +:d marshalers +marshalType (T.DBusArray _) = marshalArray x +: + +:d unmarshalers +unmarshalType (T.DBusArray t) = T.toVariant `fmap` unmarshalArray t +: + +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. + +:d marshal imports +import qualified DBus.Constants as C +: + +:f DBus/Wire/Marshal.hs +marshalArray :: T.Array -> Marshal +marshalArray x = do + (arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x + let arrayLen = L.length arrayBytes + when (arrayLen > fromIntegral C.arrayMaximumLength) + (E.throwError $ ArrayTooLong $ fromIntegral arrayLen) + marshalWord32 $ fromIntegral arrayLen + append $ L.replicate arrayPadding 0 + append arrayBytes +: + +:f DBus/Wire/Marshal.hs +getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString) +getArrayBytes T.DBusByte x = return (0, bytes) where + Just bytes = T.arrayToBytes x +: + +:f DBus/Wire/Marshal.hs +getArrayBytes itemType x = do + let vs = T.arrayItems x + s <- State.get + (MarshalState _ _ afterLength) <- marshalWord32 0 >> State.get + (MarshalState e _ afterPadding) <- pad (alignment itemType) >> State.get + + State.put $ MarshalState e B.empty afterPadding + (MarshalState _ itemBuilder _) <- mapM_ marshal vs >> State.get + + let itemBytes = B.toLazyByteString itemBuilder + paddingSize = fromIntegral $ afterPadding - afterLength + + State.put s + return (paddingSize, itemBytes) +: + +Unmarshaling is much easier, especially if it's a byte array. + +:f DBus/Wire/Unmarshal.hs +unmarshalArray :: T.Type -> Unmarshal T.Array +unmarshalArray T.DBusByte = do + byteCount <- unmarshalWord32 + T.arrayFromBytes `fmap` consume (fromIntegral byteCount) +: + +:f DBus/Wire/Unmarshal.hs +unmarshalArray itemType = do + let getOffset = do + (UnmarshalState _ _ o) <- State.get + return o + byteCount <- unmarshalWord32 + skipPadding (alignment itemType) + start <- getOffset + let end = start + fromIntegral byteCount + vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType) + end' <- getOffset + when (end' > end) $ + E.throwError ArraySizeMismatch + fromMaybeU "array" (T.arrayFromItems itemType) vs +: + +\subsubsection{Dictionaries} + +:d alignments +alignment (T.DBusDictionary _ _) = 4 +: + +:d marshalers +marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x) +: + +:d unmarshalers +unmarshalType (T.DBusDictionary kt vt) = do + let pairType = T.DBusStructure [kt, vt] + array <- unmarshalArray pairType + fromMaybeU' "dictionary" T.arrayToDictionary array +: + +\subsubsection{Structures} + +:d alignments +alignment (T.DBusStructure _) = 8 +: + +:d marshalers +marshalType (T.DBusStructure _) = do + let T.Structure vs = x + pad 8 + mapM_ marshal vs +: + +:d unmarshalers +unmarshalType (T.DBusStructure ts) = do + skipPadding 8 + fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts +: + +\subsubsection{Variants} + +:d alignments +alignment T.DBusVariant = 1 +: + +:d marshalers +marshalType T.DBusVariant = do + let rawSig = T.typeCode . T.variantType $ x + sig <- case T.mkSignature rawSig of + Just x' -> return x' + Nothing -> E.throwError $ InvalidVariantSignature rawSig + marshalSignature sig + marshal x +: + +:d unmarshalers +unmarshalType T.DBusVariant = do + let getType sig = case T.signatureTypes sig of + [t] -> Just t + _ -> Nothing + + t <- fromMaybeU "variant signature" getType =<< unmarshalSignature + T.toVariant `fmap` unmarshalType t +: + +\subsection{Messages} + +:d marshal imports +import qualified DBus.Message.Internal as M +: + +:d unmarshal imports +import qualified DBus.Message.Internal as M +: + +\subsubsection{Flags} + +:d unmarshal imports +import Data.Bits ((.&.)) +import qualified Data.Set as Set +: + +:d marshal imports +import Data.Bits ((.|.)) +import qualified Data.Set as Set +: + +:f DBus/Wire/Marshal.hs +encodeFlags :: Set.Set M.Flag -> Word8 +encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where + flagValue M.NoReplyExpected = 0x1 + flagValue M.NoAutoStart = 0x2 +: + +:f DBus/Wire/Unmarshal.hs +decodeFlags :: Word8 -> Set.Set M.Flag +decodeFlags word = Set.fromList flags where + flagSet = [ (0x1, M.NoReplyExpected) + , (0x2, M.NoAutoStart) + ] + flags = flagSet >>= \(x, y) -> [y | word .&. x > 0] +: + +\subsubsection{Header fields} + +:f DBus/Wire/Marshal.hs +encodeField :: M.HeaderField -> T.Structure +encodeField (M.Path x) = encodeField' 1 x +encodeField (M.Interface x) = encodeField' 2 x +encodeField (M.Member x) = encodeField' 3 x +encodeField (M.ErrorName x) = encodeField' 4 x +encodeField (M.ReplySerial x) = encodeField' 5 x +encodeField (M.Destination x) = encodeField' 6 x +encodeField (M.Sender x) = encodeField' 7 x +encodeField (M.Signature x) = encodeField' 8 x + +encodeField' :: T.Variable a => Word8 -> a -> T.Structure +encodeField' code x = T.Structure + [ T.toVariant code + , T.toVariant $ T.toVariant x + ] +: + +:f DBus/Wire/Unmarshal.hs +decodeField :: Monad m => T.Structure + -> E.ErrorT UnmarshalError m [M.HeaderField] +decodeField struct = case unpackField struct of + (1, x) -> decodeField' x M.Path "path" + (2, x) -> decodeField' x M.Interface "interface" + (3, x) -> decodeField' x M.Member "member" + (4, x) -> decodeField' x M.ErrorName "error name" + (5, x) -> decodeField' x M.ReplySerial "reply serial" + (6, x) -> decodeField' x M.Destination "destination" + (7, x) -> decodeField' x M.Sender "sender" + (8, x) -> decodeField' x M.Signature "signature" + _ -> return [] + +decodeField' :: (Monad m, T.Variable a) => T.Variant -> (a -> b) -> Text + -> E.ErrorT UnmarshalError m [b] +decodeField' x f label = case T.fromVariant x of + Just x' -> return [f x'] + Nothing -> E.throwError $ InvalidHeaderField label x +: + +:f DBus/Wire/Unmarshal.hs +unpackField :: T.Structure -> (Word8, T.Variant) +unpackField struct = (c', v') where + T.Structure [c, v] = struct + c' = fromJust . T.fromVariant $ c + v' = fromJust . T.fromVariant $ v +: + +\subsubsection{Header layout} + +TODO: describe header layout here + +\subsubsection{Marshaling} + +:d wire exports +, marshalMessage +: + +:f DBus/Wire/Marshal.hs +|apidoc marshalMessage| +marshalMessage :: M.Message a => Endianness -> M.Serial -> a + -> Either MarshalError L.ByteString +marshalMessage e serial msg = runMarshal marshaler e where + body = M.messageBody msg + marshaler = do + sig <- checkBodySig body + empty <- State.get + mapM_ marshal body + (MarshalState _ bodyBytesB _) <- State.get + State.put empty + marshalEndianness e + let bodyBytes = B.toLazyByteString bodyBytesB + marshalHeader msg serial sig + $ fromIntegral . L.length $ bodyBytes + pad 8 + append bodyBytes + checkMaximumSize +: + +:f DBus/Wire/Marshal.hs +checkBodySig :: [T.Variant] -> MarshalM T.Signature +checkBodySig vs = let + sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs + invalid = E.throwError $ InvalidBodySignature sigStr + in case T.mkSignature sigStr of + Just x -> return x + Nothing -> invalid +: + +:f DBus/Wire/Marshal.hs +marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32 + -> Marshal +marshalHeader msg serial bodySig bodyLength = do + let fields = M.Signature bodySig : M.messageHeaderFields msg + marshal . T.toVariant . M.messageTypeCode $ msg + marshal . T.toVariant . encodeFlags . M.messageFlags $ msg + marshal . T.toVariant $ C.protocolVersion + marshalWord32 bodyLength + marshal . T.toVariant $ serial + let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant] + marshal . T.toVariant . fromJust . T.toArray fieldType + $ map encodeField fields +: + +:f DBus/Wire/Marshal.hs +marshalEndianness :: Endianness -> Marshal +marshalEndianness = marshal . T.toVariant . encodeEndianness +: + +:f DBus/Wire/Marshal.hs +checkMaximumSize :: Marshal +checkMaximumSize = do + (MarshalState _ _ messageLength) <- State.get + when (messageLength > fromIntegral C.messageMaximumLength) + (E.throwError $ MessageTooLong $ fromIntegral messageLength) +: + +\subsubsection{Unmarshaling} + +:d unmarshal imports +import qualified DBus.Constants as C +: + +:d wire exports +, unmarshalMessage +: + +:f DBus/Wire/Unmarshal.hs +|apidoc unmarshalMessage| +unmarshalMessage :: Monad m => (Word32 -> m L.ByteString) + -> m (Either UnmarshalError M.ReceivedMessage) +unmarshalMessage getBytes' = E.runErrorT $ do + let getBytes = lift . getBytes' + + |read fixed-length header| + |read full header| + |read body| + |build message| +: + +The first part of the header has a fixed size of 16 bytes, so it can be +retrieved without any size calculations. + +:d read fixed-length header +let fixedSig = "yyyyuuu" +fixedBytes <- getBytes 16 +: + +The first field of interest is the protocol version; if the incoming +message's version is different from this library, the message cannot be +parsed. + +:d read fixed-length header +let messageVersion = L.index fixedBytes 3 +when (messageVersion /= C.protocolVersion) $ + E.throwError $ UnsupportedProtocolVersion messageVersion +: + +Next is the endianness, used for parsing pretty much every other field. + +:d read fixed-length header +let eByte = L.index fixedBytes 0 +endianness <- case decodeEndianness eByte of + Just x' -> return x' + Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte +: + +With the endianness out of the way, the rest of the fixed header +can be decoded + +:d read fixed-length header +let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of + Right x' -> return x' + Left e -> E.throwError e +fixed <- unmarshal' fixedSig fixedBytes +let typeCode = fromJust . T.fromVariant $ fixed !! 1 +let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2 +let bodyLength = fromJust . T.fromVariant $ fixed !! 4 +let serial = fromJust . T.fromVariant $ fixed !! 5 +: + +The last field of the fixed header is actually part of the field array, +but is treated as a single {\tt Word32} so it'll be known how many bytes +to retrieve. + +:d read fixed-length header +let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6 +: + +With the field byte count, the remainder of the header bytes can be +pulled out of the monad. + +:d read full header +let headerSig = "yyyyuua(yv)" +fieldBytes <- getBytes fieldByteCount +let headerBytes = L.append fixedBytes fieldBytes +header <- unmarshal' headerSig headerBytes +: + +And the header fields can be parsed. + +:d read full header +let fieldArray = fromJust . T.fromVariant $ header !! 6 +let fieldStructures = fromJust . T.fromArray $ fieldArray +fields <- concat `liftM` mapM decodeField fieldStructures +: + +The body is always aligned to 8 bytes, so pull out the padding before +unmarshaling it. + +:d read body +let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 +getBytes . fromIntegral $ bodyPadding +: + +:f DBus/Wire/Unmarshal.hs +findBodySignature :: [M.HeaderField] -> T.Signature +findBodySignature fields = fromMaybe "" signature where + signature = listToMaybe [x | M.Signature x <- fields] +: + +:d read body +let bodySig = findBodySignature fields +: + +Then pull the body bytes, and unmarshal it. + +:d read body +bodyBytes <- getBytes bodyLength +body <- unmarshal' bodySig bodyBytes +: + +Even if the received message was structurally valid, building the +{\tt ReceivedMessage} can still fail due to missing header fields. + +Slightly ugly; to avoid orphan instances of either {\tt Text} or +{\tt Either}, a newtype is used to turn {\tt Either} into a monad. + +:f DBus/Wire/Unmarshal.hs +newtype EitherM a b = EitherM (Either a b) + +instance Monad (EitherM a) where + return = EitherM . Right + (EitherM (Left x)) >>= _ = EitherM (Left x) + (EitherM (Right x)) >>= k = k x +: + +:d build message +y <- case buildReceivedMessage typeCode fields of + EitherM (Right x) -> return x + EitherM (Left x) -> E.throwError $ MissingHeaderField x +return $ y serial flags body +: + +This really belongs in the Message section... + +:f DBus/Wire/Unmarshal.hs +buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text + (M.Serial -> (Set.Set M.Flag) -> [T.Variant] + -> M.ReceivedMessage) +: + +Method calls + +:f DBus/Wire/Unmarshal.hs +buildReceivedMessage 1 fields = do + path <- require "path" [x | M.Path x <- fields] + member <- require "member name" [x | M.Member x <- fields] + return $ \serial flags body -> let + iface = listToMaybe [x | M.Interface x <- fields] + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.MethodCall path member iface dest flags body + in M.ReceivedMethodCall serial sender msg +: + +Method returns + +:f DBus/Wire/Unmarshal.hs +buildReceivedMessage 2 fields = do + replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] + return $ \serial _ body -> let + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.MethodReturn replySerial dest body + in M.ReceivedMethodReturn serial sender msg +: + +Errors + +:f DBus/Wire/Unmarshal.hs +buildReceivedMessage 3 fields = do + name <- require "error name" [x | M.ErrorName x <- fields] + replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] + return $ \serial _ body -> let + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.Error name replySerial dest body + in M.ReceivedError serial sender msg +: + +Signals + +:f DBus/Wire/Unmarshal.hs +buildReceivedMessage 4 fields = do + path <- require "path" [x | M.Path x <- fields] + member <- require "member name" [x | M.Member x <- fields] + iface <- require "interface" [x | M.Interface x <- fields] + return $ \serial _ body -> let + dest = listToMaybe [x | M.Destination x <- fields] + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.Signal path member iface dest body + in M.ReceivedSignal serial sender msg +: + +Unknown + +:f DBus/Wire/Unmarshal.hs +buildReceivedMessage typeCode fields = return $ \serial flags body -> let + sender = listToMaybe [x | M.Sender x <- fields] + msg = M.Unknown typeCode flags body + in M.ReceivedUnknown serial sender msg +: + +:f DBus/Wire/Unmarshal.hs +require :: Text -> [a] -> EitherM Text a +require _ (x:_) = return x +require label _ = EitherM $ Left label +: + +:f Tests.hs +prop_Unmarshal :: Endianness -> Variant -> Property +prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where + sig = mkSignature . typeCode . variantType $ x + Just sig' = sig + + bytes = runMarshal (marshal x) e + Right bytes' = bytes + + valid = isJust sig && isRight bytes + unmarshaled = runUnmarshal (unmarshal sig') e bytes' + +prop_MarshalMessage e serial msg expected = valid ==> correct where + bytes = marshalMessage e serial msg + Right bytes' = bytes + + getBytes = G.getLazyByteString . fromIntegral + unmarshaled = G.runGet (unmarshalMessage getBytes) bytes' + + valid = isRight bytes + correct = unmarshaled == Right expected + +prop_WireMethodCall e serial msg = prop_MarshalMessage e serial msg + $ ReceivedMethodCall serial Nothing msg + +prop_WireMethodReturn e serial msg = prop_MarshalMessage e serial msg + $ ReceivedMethodReturn serial Nothing msg + +prop_WireError e serial msg = prop_MarshalMessage e serial msg + $ ReceivedError serial Nothing msg + +prop_WireSignal e serial msg = prop_MarshalMessage e serial msg + $ ReceivedSignal serial Nothing msg +: + +:d test cases +, F.testGroup "Wire format" + [ testProperty "Marshal -> Ummarshal" prop_Unmarshal + , F.testGroup "Messages" + [ testProperty "Method calls" prop_WireMethodCall + , testProperty "Method returns" prop_WireMethodReturn + , testProperty "Errors" prop_WireError + , testProperty "Signals" prop_WireSignal + ] + ] +: