dbus 0.10.12 → 0.10.13

raw patch · 37 files changed

+6831/−6835 lines, 37 filesdep ~QuickCheckdep ~basedep ~bytestringnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: QuickCheck, base, bytestring, cereal, chell, chell-quickcheck, containers, criterion, deepseq, libxml-sax, network, parsec, process, random, text, transformers, unix, vector, xml-types

API changes (from Hackage documentation)

Files

• benchmarks/DBusBenchmarks.hs +47/−47
• dbus.cabal +63/−66
• examples/dbus-monitor.hs +202/−202
• examples/export.hs +30/−30
• examples/introspect.hs +55/−55
• examples/list-names.hs +17/−17
• lib/DBus.hs +167/−167
• lib/DBus/Address.hs +0/−178
• lib/DBus/Client.hs +863/−863
• lib/DBus/Internal/Address.hs +178/−0
• lib/DBus/Internal/Message.hs +314/−0
• lib/DBus/Internal/Types.hs +1341/−0
• lib/DBus/Internal/Wire.hs +782/−0
• lib/DBus/Introspection.hs +249/−249
• lib/DBus/Message.hs +0/−314
• lib/DBus/Socket.hs +197/−197
• lib/DBus/Transport.hs +342/−341
• lib/DBus/Types.hs +0/−1341
• lib/DBus/Wire.hs +0/−781
• tests/DBusTests.hs +24/−24
• tests/DBusTests/Address.hs +145/−145
• tests/DBusTests/BusName.hs +51/−51
• tests/DBusTests/Client.hs +395/−395
• tests/DBusTests/ErrorName.hs +43/−43
• tests/DBusTests/Integration.hs +73/−73
• tests/DBusTests/InterfaceName.hs +43/−43
• tests/DBusTests/Introspection.hs +133/−133
• tests/DBusTests/MemberName.hs +30/−30
• tests/DBusTests/Message.hs +24/−24
• tests/DBusTests/ObjectPath.hs +27/−27
• tests/DBusTests/Serialization.hs +120/−120
• tests/DBusTests/Signature.hs +107/−107
• tests/DBusTests/Socket.hs +102/−102
• tests/DBusTests/Transport.hs +390/−390
• tests/DBusTests/Util.hs +164/−167
• tests/DBusTests/Variant.hs +103/−103
• tests/DBusTests/Wire.hs +10/−10

@@ -1,17 +1,17 @@ {-# LANGUAGE OverloadedStrings #-}  -- Copyright (C) 2010-2011 John Millikin <john@john-millikin.com>--- +-- -- 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 <http://www.gnu.org/licenses/>. @@ -36,7 +36,7 @@ instance NFData Type  instance NFData Signature where-	rnf = rnf . signatureTypes+    rnf = rnf . signatureTypes  instance NFData ObjectPath @@ -59,51 +59,51 @@  benchUnmarshal :: Message msg => String -> msg -> Benchmark benchUnmarshal name msg = bench name (whnf unmarshal bytes) where-	Right bytes = marshal LittleEndian (serial 0) msg+    Right bytes = marshal LittleEndian (serial 0) msg  benchmarks :: [Benchmark]-benchmarks = -	[  bgroup "Types"-		[ bgroup "Signature"-			[ bench "parseSignature/small" (nf parseSignature "y")-			, bench "parseSignature/medium" (nf parseSignature "yyyyuua(yv)")-			, bench "parseSignature/large" (nf parseSignature "a{s(asiiiiasa(siiia{s(iiiiv)}))}")-			]-		, bgroup "ObjectPath"-			[ bench "objectPath_/small" (nf objectPath_ "/")-			, bench "objectPath_/medium" (nf objectPath_ "/foo/bar")-			, bench "objectPath_/large" (nf objectPath_ "/f0OO/b4R/baz_qux/blahblahblah")-			]-		, bgroup "InterfaceName"-			[ bench "interfaceName_/small" (nf interfaceName_ "f.b")-			, bench "interfaceName_/medium" (nf interfaceName_ "foo.bar.baz")-			, bench "interfaceName_/large" (nf interfaceName_ "f0OOO.b4R.baz_qux.blahblahblah")-			]-		, bgroup "MemberName"-			[ bench "memberName_/small" (nf memberName_ "f")-			, bench "memberName_/medium" (nf memberName_ "FooBar")-			, bench "memberName_/large" (nf memberName_ "f0OOOb4RBazQuxBlahBlahBlah")-			]-		, bgroup "ErrorName"-			[ bench "errorName_/small" (nf errorName_ "f.b")-			, bench "errorName_/medium" (nf errorName_ "foo.bar.baz")-			, bench "errorName_/large" (nf errorName_ "f0OOO.b4R.baz_qux.blahblahblah")-			]-		, bgroup "BusName"-			[ bench "busName_/small" (nf busName_ "f.b")-			, bench "busName_/medium" (nf busName_ "foo.bar.baz")-			, bench "busName_/large" (nf busName_ "f0OOO.b4R.baz-qux.blahblahblah")-			]-		]-	,  bgroup "Marshal"-		[ benchMarshal "MethodCall/empty" empty_MethodCall-		, benchMarshal "MethodReturn/empty" empty_MethodReturn-		]-	, bgroup "Unmarshal"-		[ benchUnmarshal "MethodCall/empty" empty_MethodCall-		, benchUnmarshal "MethodReturn/empty" empty_MethodReturn-		]-	]+benchmarks =+    [  bgroup "Types"+        [ bgroup "Signature"+            [ bench "parseSignature/small" (nf parseSignature "y")+            , bench "parseSignature/medium" (nf parseSignature "yyyyuua(yv)")+            , bench "parseSignature/large" (nf parseSignature "a{s(asiiiiasa(siiia{s(iiiiv)}))}")+            ]+        , bgroup "ObjectPath"+            [ bench "objectPath_/small" (nf objectPath_ "/")+            , bench "objectPath_/medium" (nf objectPath_ "/foo/bar")+            , bench "objectPath_/large" (nf objectPath_ "/f0OO/b4R/baz_qux/blahblahblah")+            ]+        , bgroup "InterfaceName"+            [ bench "interfaceName_/small" (nf interfaceName_ "f.b")+            , bench "interfaceName_/medium" (nf interfaceName_ "foo.bar.baz")+            , bench "interfaceName_/large" (nf interfaceName_ "f0OOO.b4R.baz_qux.blahblahblah")+            ]+        , bgroup "MemberName"+            [ bench "memberName_/small" (nf memberName_ "f")+            , bench "memberName_/medium" (nf memberName_ "FooBar")+            , bench "memberName_/large" (nf memberName_ "f0OOOb4RBazQuxBlahBlahBlah")+            ]+        , bgroup "ErrorName"+            [ bench "errorName_/small" (nf errorName_ "f.b")+            , bench "errorName_/medium" (nf errorName_ "foo.bar.baz")+            , bench "errorName_/large" (nf errorName_ "f0OOO.b4R.baz_qux.blahblahblah")+            ]+        , bgroup "BusName"+            [ bench "busName_/small" (nf busName_ "f.b")+            , bench "busName_/medium" (nf busName_ "foo.bar.baz")+            , bench "busName_/large" (nf busName_ "f0OOO.b4R.baz-qux.blahblahblah")+            ]+        ]+    ,  bgroup "Marshal"+        [ benchMarshal "MethodCall/empty" empty_MethodCall+        , benchMarshal "MethodReturn/empty" empty_MethodReturn+        ]+    , bgroup "Unmarshal"+        [ benchUnmarshal "MethodCall/empty" empty_MethodCall+        , benchUnmarshal "MethodReturn/empty" empty_MethodReturn+        ]+    ]  main :: IO () main = Criterion.Main.defaultMainWith config (return ()) benchmarks

@@ -1,15 +1,14 @@ name: dbus-version: 0.10.12+version: 0.10.13 license: GPL-3 license-file: license.txt author: John Millikin <john@john-millikin.com>-maintainer: John Millikin <john@john-millikin.com>+maintainer: Andrey Sverdlichenko <blaze@ruddy.ru>, John Millikin <john@john-millikin.com> build-type: Simple cabal-version: >= 1.8 category: Network, Desktop stability: experimental-homepage: https://john-millikin.com/software/haskell-dbus/-bug-reports: mailto:jmillikin@gmail.com+homepage: https://github.com/rblaze/haskell-dbus#readme  synopsis: A client library for the D-Bus IPC system. description:@@ -66,47 +65,33 @@   extra-source-files:-  benchmarks/DBusBenchmarks.hs-  --   examples/dbus-monitor.hs   examples/export.hs   examples/introspect.hs   examples/list-names.hs-  ---  tests/DBusTests.hs-  tests/DBusTests/*.hs  source-repository head   type: git-  location: https://john-millikin.com/code/haskell-dbus/--source-repository this-  type: git-  location: https://john-millikin.com/code/haskell-dbus/-  tag: haskell-dbus_0.10.12+  location: https://github.com/rblaze/haskell-dbus  library-  ghc-options: -Wall -O2+  ghc-options: -W -Wall   hs-source-dirs: lib -  if impl(ghc>=7.10)-    ghc-options: -fno-warn-tabs--  -- IMPORTANT: keep these in sync with the test suite   build-depends:-      base >= 4.0 && < 5.0-    , bytestring >= 0.10.2-    , cereal >= 0.3.4 && < 0.6-    , containers >= 0.1 && < 0.6-    , libxml-sax >= 0.7 && < 0.8-    , network >= 2.2.3-    , parsec >= 2.0 && < 3.2-    , random >= 1.0 && < 2.0-    , text >= 0.11.1.5-    , transformers >= 0.2-    , unix >= 2.2-    , vector >= 0.7 && < 0.12-    , xml-types >= 0.3 && < 0.4+      base >=4 && <5+    , bytestring+    , cereal+    , containers+    , libxml-sax+    , network+    , parsec+    , random+    , text+    , transformers+    , unix+    , vector+    , xml-types    exposed-modules:     DBus@@ -114,53 +99,65 @@     DBus.Introspection     DBus.Socket     DBus.Transport--  other-modules:-    DBus.Address-    DBus.Message-    DBus.Types-    DBus.Wire+    DBus.Internal.Address+    DBus.Internal.Message+    DBus.Internal.Types+    DBus.Internal.Wire  test-suite dbus_tests   type: exitcode-stdio-1.0   main-is: DBusTests.hs-  hs-source-dirs: lib,tests--  if impl(ghc>=7.10)-    ghc-options: -fno-warn-tabs+  hs-source-dirs: tests    build-depends:-      base >= 4.0 && < 5.0-    , bytestring >= 0.10.2-    , cereal >= 0.3.4 && < 0.6-    , chell >= 0.4 && < 0.5-    , chell-quickcheck >= 0.2 && < 0.3-    , containers >= 0.1 && < 0.6+      dbus+    , base+    , bytestring+    , cereal+    , chell+    , chell-quickcheck+    , containers     , directory     , filepath-    , libxml-sax >= 0.7 && < 0.8-    , network >= 2.2.3-    , parsec >= 2.0 && < 3.2-    , process >= 1.0 && < 2.0-    , QuickCheck >= 2.4-    , random >= 1.0 && < 2.0-    , text >= 0.11.1.5-    , transformers >= 0.2-    , unix >= 2.2-    , vector >= 0.7 && < 0.12-    , xml-types >= 0.3 && < 0.4+    , libxml-sax+    , network+    , parsec+    , process+    , QuickCheck+    , random+    , text+    , transformers+    , unix+    , vector+    , xml-types +  other-modules:+    DBusTests.Address+    DBusTests.BusName+    DBusTests.Client+    DBusTests.ErrorName+    DBusTests.Integration+    DBusTests.InterfaceName+    DBusTests.Introspection+    DBusTests.MemberName+    DBusTests.Message+    DBusTests.ObjectPath+    DBusTests.Serialization+    DBusTests.Signature+    DBusTests.Socket+    DBusTests.Transport+    DBusTests.Util+    DBusTests.Variant+    DBusTests.Wire+ benchmark dbus_benchmarks   type: exitcode-stdio-1.0   main-is: DBusBenchmarks.hs   hs-source-dirs: benchmarks-  ghc-options: -Wall -O2 -fno-warn-orphans--  if impl(ghc>=7.10)-    ghc-options: -fno-warn-tabs+  ghc-options: -Wall -fno-warn-orphans    build-depends:       dbus-    , base > 4.0 && < 5.0-    , criterion >= 1.0 && < 2.0+    , base+    , criterion     , deepseq

@@ -1,17 +1,17 @@ {-# LANGUAGE OverloadedStrings #-}  -- Copyright (C) 2009-2011 John Millikin <john@john-millikin.com>--- +-- -- 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 <http://www.gnu.org/licenses/>. @@ -30,81 +30,81 @@ import           DBus.Socket  data Bus = Session | System-	deriving (Show)+    deriving (Show)  data Option = BusOption Bus | AddressOption String-	deriving (Show)+    deriving (Show)  optionInfo :: [OptDescr Option] optionInfo = [-	  Option [] ["session"] (NoArg (BusOption Session))-	         "Monitor the session message bus. (default)"-	, Option [] ["system"] (NoArg (BusOption System))-	         "Monitor the system message bus."-	, Option [] ["address"] (ReqArg AddressOption "ADDRESS")-	         "Connect to a particular bus address."-	]+      Option [] ["session"] (NoArg (BusOption Session))+             "Monitor the session message bus. (default)"+    , Option [] ["system"] (NoArg (BusOption System))+             "Monitor the system message bus."+    , Option [] ["address"] (ReqArg AddressOption "ADDRESS")+             "Connect to a particular bus address."+    ]  usage :: String -> String usage name = "Usage: " ++ name ++ " [OPTION...]"  findSocket :: [Option] -> IO Socket findSocket opts = getAddress opts >>= open where-	session = do-		got <- getSessionAddress-		case got of-			Just addr -> return addr-			Nothing -> error "DBUS_SESSION_BUS_ADDRESS is not a valid address"-	-	system = do-		got <- getSystemAddress-		case got of-			Just addr -> return addr-			Nothing -> error "DBUS_SYSTEM_BUS_ADDRESS is not a valid address"-	-	getAddress [] = session-	getAddress ((BusOption Session):_) = session-	getAddress ((BusOption System):_) = system-	getAddress ((AddressOption addr):_) = case parseAddress addr of-		Nothing -> error (show addr ++ " is not a valid address")-		Just parsed -> return parsed+    session = do+        got <- getSessionAddress+        case got of+            Just addr -> return addr+            Nothing -> error "DBUS_SESSION_BUS_ADDRESS is not a valid address" +    system = do+        got <- getSystemAddress+        case got of+            Just addr -> return addr+            Nothing -> error "DBUS_SYSTEM_BUS_ADDRESS is not a valid address"++    getAddress [] = session+    getAddress ((BusOption Session):_) = session+    getAddress ((BusOption System):_) = system+    getAddress ((AddressOption addr):_) = case parseAddress addr of+        Nothing -> error (show addr ++ " is not a valid address")+        Just parsed -> return parsed+ addMatch :: Socket -> String -> IO () addMatch sock match = send sock (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "AddMatch")-	{ methodCallDestination = Just "org.freedesktop.DBus"-	, methodCallBody = [toVariant match]-	} (\_ -> return ())+    { methodCallDestination = Just "org.freedesktop.DBus"+    , methodCallBody = [toVariant match]+    } (\_ -> return ())  defaultFilters :: [String] defaultFilters =-	[ "type='signal',eavesdrop=true"-	, "type='method_call',eavesdrop=true"-	, "type='method_return',eavesdrop=true"-	, "type='error',eavesdrop=true"-	]+    [ "type='signal',eavesdrop=true"+    , "type='method_call',eavesdrop=true"+    , "type='method_return',eavesdrop=true"+    , "type='error',eavesdrop=true"+    ]  main :: IO () main = do-	args <- getArgs-	let (options, userFilters, errors) = getOpt Permute optionInfo args-	unless (null errors) $ do-		name <- getProgName-		hPutStrLn stderr (concat errors)-		hPutStrLn stderr (usageInfo (usage name) optionInfo)-		exitFailure-	-	sock <- findSocket options-	-	send sock (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "Hello")-		{ methodCallDestination = Just "org.freedesktop.DBus"-		} (\_ -> return ())-	-	mapM_ (addMatch sock) (if null userFilters then defaultFilters else userFilters)-	-	forever $ do-		received <- receive sock-		putStrLn (formatMessage received ++ "\n")+    args <- getArgs+    let (options, userFilters, errors) = getOpt Permute optionInfo args+    unless (null errors) $ do+        name <- getProgName+        hPutStrLn stderr (concat errors)+        hPutStrLn stderr (usageInfo (usage name) optionInfo)+        exitFailure +    sock <- findSocket options++    send sock (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "Hello")+        { methodCallDestination = Just "org.freedesktop.DBus"+        } (\_ -> return ())++    mapM_ (addMatch sock) (if null userFilters then defaultFilters else userFilters)++    forever $ do+        received <- receive sock+        putStrLn (formatMessage received ++ "\n")+ -- Message formatting is verbose and mostly uninteresting, except as an -- excersise in string manipulation. @@ -112,83 +112,83 @@  -- Method call formatMessage (ReceivedMethodCall serial msg) = concat-	[ "method call"-	, " sender="-	, maybe "(null)" formatBusName (methodCallSender msg)-	, " -> dest="-	, maybe "(null)" formatBusName (methodCallDestination msg)-	, " serial="-	, show (serialValue serial)-	, " path="-	, formatObjectPath (methodCallPath msg)-	, "; interface="-	, maybe "(null)" formatInterfaceName (methodCallInterface msg)-	, "; member="-	, formatMemberName (methodCallMember msg)-	, formatBody (methodCallBody msg)-	]+    [ "method call"+    , " sender="+    , maybe "(null)" formatBusName (methodCallSender msg)+    , " -> dest="+    , maybe "(null)" formatBusName (methodCallDestination msg)+    , " serial="+    , show (serialValue serial)+    , " path="+    , formatObjectPath (methodCallPath msg)+    , "; interface="+    , maybe "(null)" formatInterfaceName (methodCallInterface msg)+    , "; member="+    , formatMemberName (methodCallMember msg)+    , formatBody (methodCallBody msg)+    ]  -- Method return formatMessage (ReceivedMethodReturn _ msg) = concat-	[ "method return"-	, " sender="-	, maybe "(null)" formatBusName (methodReturnSender msg)-	, " -> dest="-	, maybe "(null)" formatBusName (methodReturnDestination msg)-	, " reply_serial="-	, show (serialValue (methodReturnSerial msg))-	, formatBody (methodReturnBody msg)-	]+    [ "method return"+    , " sender="+    , maybe "(null)" formatBusName (methodReturnSender msg)+    , " -> dest="+    , maybe "(null)" formatBusName (methodReturnDestination msg)+    , " reply_serial="+    , show (serialValue (methodReturnSerial msg))+    , formatBody (methodReturnBody msg)+    ]  -- Method error formatMessage (ReceivedMethodError _ msg) = concat-	[ "error"-	, " sender="-	, maybe "(null)" formatBusName (methodErrorSender msg)-	, " -> dest="-	, maybe "(null)" formatBusName (methodErrorDestination msg)-	, " error_name="-	, formatErrorName (methodErrorName msg)-	, " reply_serial="-	, show (serialValue (methodErrorSerial msg))-	, formatBody (methodErrorBody msg)-	]+    [ "error"+    , " sender="+    , maybe "(null)" formatBusName (methodErrorSender msg)+    , " -> dest="+    , maybe "(null)" formatBusName (methodErrorDestination msg)+    , " error_name="+    , formatErrorName (methodErrorName msg)+    , " reply_serial="+    , show (serialValue (methodErrorSerial msg))+    , formatBody (methodErrorBody msg)+    ]  -- Signal formatMessage (ReceivedSignal serial msg) = concat-	[ "signal"-	, " sender="-	, maybe "(null)" formatBusName (signalSender msg)-	, " -> dest="-	, maybe "(null)" formatBusName (signalDestination msg)-	, " serial="-	, show (serialValue serial)-	, " path="-	, formatObjectPath (signalPath msg)-	, "; interface="-	, formatInterfaceName (signalInterface msg)-	, "; member="-	, formatMemberName (signalMember msg)-	, formatBody (signalBody msg)-	]+    [ "signal"+    , " sender="+    , maybe "(null)" formatBusName (signalSender msg)+    , " -> dest="+    , maybe "(null)" formatBusName (signalDestination msg)+    , " serial="+    , show (serialValue serial)+    , " path="+    , formatObjectPath (signalPath msg)+    , "; interface="+    , formatInterfaceName (signalInterface msg)+    , "; member="+    , formatMemberName (signalMember msg)+    , formatBody (signalBody msg)+    ]  formatMessage msg = concat-	[ "unknown"-	, " sender="-	, maybe "(null)" formatBusName (receivedMessageSender msg)-	, " serial="-	, show (serialValue (receivedMessageSerial msg))-	, formatBody (receivedMessageBody msg)-	]+    [ "unknown"+    , " sender="+    , maybe "(null)" formatBusName (receivedMessageSender msg)+    , " serial="+    , show (serialValue (receivedMessageSerial msg))+    , formatBody (receivedMessageBody msg)+    ]  formatBody :: [Variant] -> String formatBody body = formatted where-	tree = Children (map formatVariant body)-	formatted = intercalate "\n" ("" : collapseTree 0 tree)+    tree = Children (map formatVariant body)+    formatted = intercalate "\n" ("" : collapseTree 0 tree)  -- A string tree allows easy indentation of nested structures data StringTree = Line String | MultiLine [StringTree] | Children [StringTree]-	deriving (Show)+    deriving (Show)  collapseTree :: Int -> StringTree -> [String] collapseTree d (Line x)       = [replicate (d*3) ' ' ++ x]@@ -198,88 +198,88 @@ -- Formatting for various kinds of variants, keyed to their signature type. formatVariant :: Variant -> StringTree formatVariant x = case variantType x of-	-	TypeBoolean -> Line $ let-		Just x' = fromVariant x-		in "boolean " ++ if x' then "true" else "false"-	-	TypeWord8 -> Line $ let-		Just x' = fromVariant x-		in "byte " ++ show (x' :: Word8)-	-	TypeWord16 -> Line $ let-		Just x' = fromVariant x-		in "uint16 " ++ show (x' :: Word16)-	-	TypeWord32 -> Line $ let-		Just x' = fromVariant x-		in "uint32 " ++ show (x' :: Word32)-	-	TypeWord64 -> Line $ let-		Just x' = fromVariant x-		in "uint64 " ++ show (x' :: Word64)-	-	TypeInt16 -> Line $ let-		Just x' = fromVariant x-		in "int16 " ++ show (x' :: Int16)-	-	TypeInt32 -> Line $ let-		Just x' = fromVariant x-		in "int32 " ++ show (x' :: Int32)-	-	TypeInt64 -> Line $ let-		Just x' = fromVariant x-		in "int64 " ++ show (x' :: Int64)-	-	TypeDouble -> Line $ let-		Just x' = fromVariant x-		in "double " ++ show (x' :: Double)-	-	TypeString -> Line $ let-		Just x' = fromVariant x-		in "string " ++ show (x' :: String)-	-	TypeObjectPath -> Line $ let-		Just x' = fromVariant x-		in "object path " ++ show (formatObjectPath x')-	-	TypeSignature -> Line $ let-		Just x' = fromVariant x-		in "signature " ++ show (formatSignature x')-	-	TypeArray _ -> MultiLine $ let-		Just x' = fromVariant x-		items = arrayItems x'-		lines' = [ Line "array ["-		         , Children (map formatVariant items)-		         , Line "]"-		         ]-		in lines'-	-	TypeDictionary _ _ -> MultiLine $ let-		Just x' = fromVariant x-		items = dictionaryItems x'-		lines' = [ Line "dictionary {"-		         , Children (map formatItem items)-		         , Line "}"-		         ]-		formatItem (k, v) = MultiLine (firstLine : vTail) where-			Line k' = formatVariant k-			v' = collapseTree 0 (formatVariant v)-			vHead = head v'-			vTail = map Line (tail v')-			firstLine = Line (k' ++ " -> " ++ vHead)-		in lines'-	-	TypeStructure _ -> MultiLine $ let-		Just x' = fromVariant x-		items = structureItems x'-		lines' = [ Line "struct ("-		         , Children (map formatVariant items)-		         , Line ")"-		         ]-		in lines'-	-	TypeVariant -> let-		Just x' = fromVariant x-		in MultiLine [Line "variant", Children [formatVariant x']]++    TypeBoolean -> Line $ let+        Just x' = fromVariant x+        in "boolean " ++ if x' then "true" else "false"++    TypeWord8 -> Line $ let+        Just x' = fromVariant x+        in "byte " ++ show (x' :: Word8)++    TypeWord16 -> Line $ let+        Just x' = fromVariant x+        in "uint16 " ++ show (x' :: Word16)++    TypeWord32 -> Line $ let+        Just x' = fromVariant x+        in "uint32 " ++ show (x' :: Word32)++    TypeWord64 -> Line $ let+        Just x' = fromVariant x+        in "uint64 " ++ show (x' :: Word64)++    TypeInt16 -> Line $ let+        Just x' = fromVariant x+        in "int16 " ++ show (x' :: Int16)++    TypeInt32 -> Line $ let+        Just x' = fromVariant x+        in "int32 " ++ show (x' :: Int32)++    TypeInt64 -> Line $ let+        Just x' = fromVariant x+        in "int64 " ++ show (x' :: Int64)++    TypeDouble -> Line $ let+        Just x' = fromVariant x+        in "double " ++ show (x' :: Double)++    TypeString -> Line $ let+        Just x' = fromVariant x+        in "string " ++ show (x' :: String)++    TypeObjectPath -> Line $ let+        Just x' = fromVariant x+        in "object path " ++ show (formatObjectPath x')++    TypeSignature -> Line $ let+        Just x' = fromVariant x+        in "signature " ++ show (formatSignature x')++    TypeArray _ -> MultiLine $ let+        Just x' = fromVariant x+        items = arrayItems x'+        lines' = [ Line "array ["+                 , Children (map formatVariant items)+                 , Line "]"+                 ]+        in lines'++    TypeDictionary _ _ -> MultiLine $ let+        Just x' = fromVariant x+        items = dictionaryItems x'+        lines' = [ Line "dictionary {"+                 , Children (map formatItem items)+                 , Line "}"+                 ]+        formatItem (k, v) = MultiLine (firstLine : vTail) where+            Line k' = formatVariant k+            v' = collapseTree 0 (formatVariant v)+            vHead = head v'+            vTail = map Line (tail v')+            firstLine = Line (k' ++ " -> " ++ vHead)+        in lines'++    TypeStructure _ -> MultiLine $ let+        Just x' = fromVariant x+        items = structureItems x'+        lines' = [ Line "struct ("+                 , Children (map formatVariant items)+                 , Line ")"+                 ]+        in lines'++    TypeVariant -> let+        Just x' = fromVariant x+        in MultiLine [Line "variant", Children [formatVariant x']]

@@ -1,17 +1,17 @@ {-# LANGUAGE OverloadedStrings #-}  -- Copyright (C) 2009-2011 John Millikin <john@john-millikin.com>--- +-- -- 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 <http://www.gnu.org/licenses/>. @@ -25,36 +25,36 @@  onFoo :: String -> String -> IO (String, String) onFoo x y = do-	putStrLn ("Foo " ++ show x ++ " " ++ show y)-	return (x, y)+    putStrLn ("Foo " ++ show x ++ " " ++ show y)+    return (x, y)  onBar :: String -> String -> IO (String, String) onBar x y = do-	putStrLn ("Bar " ++ show x ++ " " ++ show y)-	throwError "com.example.ErrorBar" "Bar failed" []+    putStrLn ("Bar " ++ show x ++ " " ++ show y)+    throwError "com.example.ErrorBar" "Bar failed" []  main :: IO () main = do-	-- Connect to the bus-	client <- connectSession-	-	-- Request a unique name on the bus.-	requestResult <- requestName client "com.example.exporting" []-	when (requestResult /= NamePrimaryOwner) $ do-		putStrLn "Another service owns the \"com.example.exporting\" bus name"-		exitFailure-	-	-- Export two example objects-	export client "/a"-		[ autoMethod "test.iface_1" "Foo" (onFoo "hello" "a")-		, autoMethod "test.iface_1" "Bar" (onBar "hello" "a")-		]-	export client "/b"-		[ autoMethod "test.iface_1" "Foo" (onFoo "hello")-		, autoMethod "test.iface_1" "Bar" (onBar "hello")-		]-	-	putStrLn "Exported objects /a and /b to bus name com.example.exporting"-	-	-- Wait forever for method calls-	forever (threadDelay 50000)+    -- Connect to the bus+    client <- connectSession++    -- Request a unique name on the bus.+    requestResult <- requestName client "com.example.exporting" []+    when (requestResult /= NamePrimaryOwner) $ do+        putStrLn "Another service owns the \"com.example.exporting\" bus name"+        exitFailure++    -- Export two example objects+    export client "/a"+        [ autoMethod "test.iface_1" "Foo" (onFoo "hello" "a")+        , autoMethod "test.iface_1" "Bar" (onBar "hello" "a")+        ]+    export client "/b"+        [ autoMethod "test.iface_1" "Foo" (onFoo "hello")+        , autoMethod "test.iface_1" "Bar" (onBar "hello")+        ]++    putStrLn "Exported objects /a and /b to bus name com.example.exporting"++    -- Wait forever for method calls+    forever (threadDelay 50000)

@@ -1,17 +1,17 @@ {-# LANGUAGE OverloadedStrings #-}  -- Copyright (C) 2009-2011 John Millikin <john@john-millikin.com>--- +-- -- 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 <http://www.gnu.org/licenses/>. @@ -29,81 +29,81 @@  main :: IO () main = do-	args <- getArgs-	(service, path) <- case args of-		a1:a2:_ -> return (fromString a1, fromString a2)-		_ -> do-			name <- getProgName-			hPutStrLn stderr ("Usage: " ++ name ++ " <service> <path>")-			exitFailure-	client <- connectSession-	printObj (introspect client service) path+    args <- getArgs+    (service, path) <- case args of+        a1:a2:_ -> return (fromString a1, fromString a2)+        _ -> do+            name <- getProgName+            hPutStrLn stderr ("Usage: " ++ name ++ " <service> <path>")+            exitFailure+    client <- connectSession+    printObj (introspect client service) path  introspect :: Client -> BusName -> ObjectPath -> IO I.Object introspect client service path = do-	reply <- call_ client (methodCall path "org.freedesktop.DBus.Introspectable" "Introspect")-		{ methodCallDestination = Just service-		}-	let Just xml = fromVariant (methodReturnBody reply !! 0)-	case I.parseXML path xml of-		Just info -> return info-		Nothing -> error ("Invalid introspection XML: " ++ show xml)+    reply <- call_ client (methodCall path "org.freedesktop.DBus.Introspectable" "Introspect")+        { methodCallDestination = Just service+        }+    let Just xml = fromVariant (methodReturnBody reply !! 0)+    case I.parseXML path xml of+        Just info -> return info+        Nothing -> error ("Invalid introspection XML: " ++ show xml)  -- most of this stuff is just boring text formatting  printObj :: (ObjectPath -> IO I.Object) -> ObjectPath -> IO () printObj get path = do-	obj <- get path-	putStrLn (formatObjectPath path)-	mapM_ printIface (I.objectInterfaces obj)-	putStrLn ""-	mapM_ (printObj get) [I.objectPath x | x <- I.objectChildren obj]+    obj <- get path+    putStrLn (formatObjectPath path)+    mapM_ printIface (I.objectInterfaces obj)+    putStrLn ""+    mapM_ (printObj get) [I.objectPath x | x <- I.objectChildren obj]  printIface :: I.Interface -> IO () printIface iface = do-	putStr "    "-	putStrLn (formatInterfaceName (I.interfaceName iface))-	-	mapM_ printMethod (I.interfaceMethods iface)-	mapM_ printSignal (I.interfaceSignals iface)-	mapM_ printProperty (I.interfaceProperties iface)-	putStrLn ""+    putStr "    "+    putStrLn (formatInterfaceName (I.interfaceName iface)) +    mapM_ printMethod (I.interfaceMethods iface)+    mapM_ printSignal (I.interfaceSignals iface)+    mapM_ printProperty (I.interfaceProperties iface)+    putStrLn ""+ printMethod :: I.Method -> IO () printMethod method = do-	putStr "        method "-	putStrLn (formatMemberName (I.methodName method))-	mapM_ printMethodArg (I.methodArgs method)+    putStr "        method "+    putStrLn (formatMemberName (I.methodName method))+    mapM_ printMethodArg (I.methodArgs method)  printMethodArg :: I.MethodArg -> IO () printMethodArg arg = do-	let dir = case I.methodArgDirection arg of-		d | d == I.directionIn -> "IN "-		d | d == I.directionOut -> "OUT"-		_ -> "   "-	putStr ("            [" ++ dir ++ " ")-	putStr (show (formatSignature (signature_ [I.methodArgType arg])) ++ "] ")-	putStrLn (I.methodArgName arg)+    let dir = case I.methodArgDirection arg of+        d | d == I.directionIn -> "IN "+        d | d == I.directionOut -> "OUT"+        _ -> "   "+    putStr ("            [" ++ dir ++ " ")+    putStr (show (formatSignature (signature_ [I.methodArgType arg])) ++ "] ")+    putStrLn (I.methodArgName arg)  printSignal :: I.Signal -> IO () printSignal sig = do-	putStr "        signal "-	putStrLn (formatMemberName (I.signalName sig))-	mapM_ printSignalArg (I.signalArgs sig)+    putStr "        signal "+    putStrLn (formatMemberName (I.signalName sig))+    mapM_ printSignalArg (I.signalArgs sig)  printSignalArg :: I.SignalArg -> IO () printSignalArg arg = do-	putStr "            ["-	putStr (show (formatSignature (signature_ [I.signalArgType arg])) ++ "] ")-	putStrLn (I.signalArgName arg)+    putStr "            ["+    putStr (show (formatSignature (signature_ [I.signalArgType arg])) ++ "] ")+    putStrLn (I.signalArgName arg)  printProperty :: I.Property -> IO () printProperty prop = do-	putStr "        property "-	putStr (show (formatSignature (signature_ [I.propertyType prop])) ++ " ")-	putStrLn (I.propertyName prop)-	-	putStr "            "-	when (I.propertyRead prop) (putStr "Read")-	when (I.propertyWrite prop) (putStr "Write")-	putStrLn ""+    putStr "        property "+    putStr (show (formatSignature (signature_ [I.propertyType prop])) ++ " ")+    putStrLn (I.propertyName prop)++    putStr "            "+    when (I.propertyRead prop) (putStr "Read")+    when (I.propertyWrite prop) (putStr "Write")+    putStrLn ""

@@ -1,17 +1,17 @@ {-# LANGUAGE OverloadedStrings #-}  -- Copyright (C) 2009-2011 John Millikin <john@john-millikin.com>--- +-- -- 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 <http://www.gnu.org/licenses/>. @@ -23,17 +23,17 @@  main :: IO () main = do-	client <- connectSession-	-	-- Request a list of connected clients from the bus-	reply <- call_ client (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "ListNames")-		{ methodCallDestination = Just "org.freedesktop.DBus"-		}-	-	-- org.freedesktop.DBus.ListNames returns a single value, which is-	-- a list of names (here represented as [String])-	let Just names = fromVariant (methodReturnBody reply !! 0)-	-	-- Print each name on a line, sorted so reserved names are below-	-- temporary names.-	mapM_ putStrLn (sort names)+    client <- connectSession++    -- Request a list of connected clients from the bus+    reply <- call_ client (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "ListNames")+        { methodCallDestination = Just "org.freedesktop.DBus"+        }++    -- org.freedesktop.DBus.ListNames returns a single value, which is+    -- a list of names (here represented as [String])+    let Just names = fromVariant (methodReturnBody reply !! 0)++    -- Print each name on a line, sorted so reserved names are below+    -- temporary names.+    mapM_ putStrLn (sort names)

@@ -18,174 +18,174 @@ -- Authors of client applications should import "DBus.Client", which provides -- an easy RPC-oriented interface to D-Bus methods and signals. module DBus-	(-	-- * Messages-	  Message-	-	-- ** Method calls-	, MethodCall-	, methodCall-	, methodCallPath-	, methodCallInterface-	, methodCallMember-	, methodCallSender-	, methodCallDestination-	, methodCallAutoStart-	, methodCallReplyExpected-	, methodCallBody-	-	-- ** Method returns-	, MethodReturn-	, methodReturn-	, methodReturnSerial-	, methodReturnSender-	, methodReturnDestination-	, methodReturnBody-	-	-- ** Method errors-	, MethodError-	, methodError-	, methodErrorName-	, methodErrorSerial-	, methodErrorSender-	, methodErrorDestination-	, methodErrorBody-	, methodErrorMessage-	-	-- ** Signals-	, Signal-	, signal-	, signalPath-	, signalMember-	, signalInterface-	, signalSender-	, signalDestination-	, signalBody-	-	-- ** Received messages-	, ReceivedMessage(ReceivedMethodCall, ReceivedMethodReturn, ReceivedMethodError, ReceivedSignal)-	, receivedMessageSerial-	, receivedMessageSender-	, receivedMessageBody-	-	-- * Variants-	, Variant-	, IsVariant(..)-	, variantType-	-	, IsAtom-	, IsValue-	, typeOf-	-	-- * Signatures-	, Signature-	, Type(..)-	, signature-	, signature_-	, signatureTypes-	, formatSignature-	, parseSignature-	-	-- * Object paths-	, ObjectPath-	, objectPath_-	, formatObjectPath-	, parseObjectPath-	-	-- * Names-	-	-- ** Interface names-	, InterfaceName-	, interfaceName_-	, formatInterfaceName-	, parseInterfaceName-	-	-- ** Member names-	, MemberName-	, memberName_-	, formatMemberName-	, parseMemberName-	-	-- ** Error names-	, ErrorName-	, errorName_-	, formatErrorName-	, parseErrorName-	-	-- ** Bus names-	, BusName-	, busName_-	, formatBusName-	, parseBusName-	-	-- * Non-native containers-	-	-- ** Structures-	, Structure-	, structureItems-	-	-- ** Arrays-	, Array-	, arrayItems-	-	-- ** Dictionaries-	, Dictionary-	, dictionaryItems-	-	-- * Addresses-	, Address-	, addressMethod-	, addressParameters-	, address-	, formatAddress-	, formatAddresses-	, parseAddress-	, parseAddresses-	, getSystemAddress-	, getSessionAddress-	, getStarterAddress-	-	-- * Message marshaling-	, Endianness (..)-	-	-- ** Marshal-	, marshal-	, MarshalError-	, marshalErrorMessage-	-	-- ** Unmarshal-	, unmarshal-	, UnmarshalError-	, unmarshalErrorMessage-	-	-- ** Message serials-	, Serial-	, serialValue-	, firstSerial-	, nextSerial-	-	-- * D-Bus UUIDs-	, UUID-	, formatUUID-	, randomUUID-	) where+    (+    -- * Messages+      Message +    -- ** Method calls+    , MethodCall+    , methodCall+    , methodCallPath+    , methodCallInterface+    , methodCallMember+    , methodCallSender+    , methodCallDestination+    , methodCallAutoStart+    , methodCallReplyExpected+    , methodCallBody++    -- ** Method returns+    , MethodReturn+    , methodReturn+    , methodReturnSerial+    , methodReturnSender+    , methodReturnDestination+    , methodReturnBody++    -- ** Method errors+    , MethodError+    , methodError+    , methodErrorName+    , methodErrorSerial+    , methodErrorSender+    , methodErrorDestination+    , methodErrorBody+    , methodErrorMessage++    -- ** Signals+    , Signal+    , signal+    , signalPath+    , signalMember+    , signalInterface+    , signalSender+    , signalDestination+    , signalBody++    -- ** Received messages+    , ReceivedMessage(ReceivedMethodCall, ReceivedMethodReturn, ReceivedMethodError, ReceivedSignal)+    , receivedMessageSerial+    , receivedMessageSender+    , receivedMessageBody++    -- * Variants+    , Variant+    , IsVariant(..)+    , variantType++    , IsAtom+    , IsValue+    , typeOf++    -- * Signatures+    , Signature+    , Type(..)+    , signature+    , signature_+    , signatureTypes+    , formatSignature+    , parseSignature++    -- * Object paths+    , ObjectPath+    , objectPath_+    , formatObjectPath+    , parseObjectPath++    -- * Names++    -- ** Interface names+    , InterfaceName+    , interfaceName_+    , formatInterfaceName+    , parseInterfaceName++    -- ** Member names+    , MemberName+    , memberName_+    , formatMemberName+    , parseMemberName++    -- ** Error names+    , ErrorName+    , errorName_+    , formatErrorName+    , parseErrorName++    -- ** Bus names+    , BusName+    , busName_+    , formatBusName+    , parseBusName++    -- * Non-native containers++    -- ** Structures+    , Structure+    , structureItems++    -- ** Arrays+    , Array+    , arrayItems++    -- ** Dictionaries+    , Dictionary+    , dictionaryItems++    -- * Addresses+    , Address+    , addressMethod+    , addressParameters+    , address+    , formatAddress+    , formatAddresses+    , parseAddress+    , parseAddresses+    , getSystemAddress+    , getSessionAddress+    , getStarterAddress++    -- * Message marshaling+    , Endianness (..)++    -- ** Marshal+    , marshal+    , MarshalError+    , marshalErrorMessage++    -- ** Unmarshal+    , unmarshal+    , UnmarshalError+    , unmarshalErrorMessage++    -- ** Message serials+    , Serial+    , serialValue+    , firstSerial+    , nextSerial++    -- * D-Bus UUIDs+    , UUID+    , formatUUID+    , randomUUID+    ) where+ import           Control.Monad (replicateM) import qualified Data.ByteString.Char8 as Char8 import           Data.Word (Word16) import           System.Random (randomRIO) import           Text.Printf (printf) -import           DBus.Address-import           DBus.Message-import qualified DBus.Types-import           DBus.Types hiding (typeOf)-import           DBus.Wire+import           DBus.Internal.Address+import           DBus.Internal.Message+import qualified DBus.Internal.Types+import           DBus.Internal.Types hiding (typeOf)+import           DBus.Internal.Wire  -- | Get the D-Bus type corresponding to the given Haskell value. The value -- may be @undefined@. typeOf :: IsValue a => a -> Type-typeOf = DBus.Types.typeOf+typeOf = DBus.Internal.Types.typeOf  -- | Construct a new 'MethodCall' for the given object, interface, and method. --@@ -267,7 +267,7 @@ -- -- D-Bus UUIDs are not the same as the RFC-standardized UUIDs or GUIDs. newtype UUID = UUID Char8.ByteString-	deriving (Eq, Ord, Show)+    deriving (Eq, Ord, Show)  -- | Format a D-Bus UUID as hex-encoded ASCII. formatUUID :: UUID -> String@@ -278,12 +278,12 @@ -- @\"guid\"@ parameter. randomUUID :: IO UUID randomUUID = do-	-- The version of System.Random bundled with ghc < 7.2 doesn't define-	-- instances for any of the fixed-length word types, so we imitate-	-- them using the instance for Int.-	---	-- 128 bits is 8 16-bit integers. We use chunks of 16 instead of 32-	-- because Int is not guaranteed to be able to store a Word32.-	let hexInt16 i = printf "%04x" (i :: Int)-	int16s <- replicateM 8 (randomRIO (0, fromIntegral (maxBound :: Word16)))-	return (UUID (Char8.pack (concatMap hexInt16 int16s)))+    -- The version of System.Random bundled with ghc < 7.2 doesn't define+    -- instances for any of the fixed-length word types, so we imitate+    -- them using the instance for Int.+    --+    -- 128 bits is 8 16-bit integers. We use chunks of 16 instead of 32+    -- because Int is not guaranteed to be able to store a Word32.+    let hexInt16 i = printf "%04x" (i :: Int)+    int16s <- replicateM 8 (randomRIO (0, fromIntegral (maxBound :: Word16)))+    return (UUID (Char8.pack (concatMap hexInt16 int16s)))

@@ -1,178 +0,0 @@--- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>------ 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 <http://www.gnu.org/licenses/>.--module DBus.Address where--import qualified Control.Exception-import           Data.Char (digitToInt, ord, chr)-import           Data.List (intercalate)-import qualified Data.Map-import           Data.Map (Map)-import qualified System.Environment-import           Text.Printf (printf)--import           Text.ParserCombinators.Parsec---- | When a D-Bus server must listen for connections, or a client must connect--- to a server, the listening socket's configuration is specified with an--- /address/. An address contains the /method/, which determines the--- protocol and transport mechanism, and /parameters/, which provide--- additional method-specific information about the address.-data Address = Address String (Map String String)-	deriving (Eq)--addressMethod :: Address -> String-addressMethod (Address x _ ) = x--addressParameters :: Address -> Map String String-addressParameters (Address _ x) = x---- | Try to convert a method string and parameter map to an 'Address'.------ Returns 'Nothing' if the method or parameters are invalid.-address :: String -> Map String String -> Maybe Address-address method params = if validMethod method && validParams params-	then if null method && Data.Map.null params-		then Nothing-		else Just (Address method params)-	else Nothing--validMethod :: String -> Bool-validMethod = all validChar where-	validChar c = c /= ';' && c /= ':'--validParams :: Map String String -> Bool-validParams = all validItem . Data.Map.toList where-	validItem (k, v) = notNull k && notNull v && validKey k-	validKey = all validChar-	validChar c = c /= ';' && c /= ',' && c /= '='-	notNull = not . null--optionallyEncoded :: [Char]-optionallyEncoded = concat-	[ ['0'..'9']-	, ['a'..'z']-	, ['A'..'Z']-	, ['-', '_', '/', '\\', '*', '.']-	]---- | Convert an address to a string in the format expected by 'parseAddress'.-formatAddress :: Address -> String-formatAddress (Address method params) = concat [method, ":", csvParams] where-	csvParams = intercalate "," $ do-		(k, v) <- Data.Map.toList params-		let v' = concatMap escape v-		return (concat [k, "=", v'])-	-	escape c = if elem c optionallyEncoded-		then [c]-		else printf "%%%02X" (ord c)---- | Convert a list of addresses to a string in the format expected by--- 'parseAddresses'.-formatAddresses :: [Address] -> String-formatAddresses = intercalate ";" . map formatAddress--instance Show Address where-	showsPrec d x = showParen (d > 10) $-		showString "Address " .-		shows (formatAddress x)---- | Try to parse a string containing one valid address.------ An address string is in the format @method:key1=val1,key2=val2@. There--- are some limitations on the characters allowed within methods and--- parameters; see the D-Bus specification for full details.-parseAddress :: String -> Maybe Address-parseAddress = maybeParseString $ do-	addr <- parsecAddress-	eof-	return addr---- | Try to parse a string containing one or more valid addresses.------ Addresses are separated by semicolons. See 'parseAddress' for the format--- of addresses.-parseAddresses :: String -> Maybe [Address]-parseAddresses = maybeParseString $ do-	addrs <- sepEndBy parsecAddress (char ';')-	eof-	return addrs--parsecAddress :: Parser Address-parsecAddress = p where-	p = do-		method <- many (noneOf ":;")-		_ <- char ':'-		params <- sepEndBy param (char ',')-		return (Address method (Data.Map.fromList params))-	-	param = do-		key <- many1 (noneOf "=;,")-		_ <- char '='-		value <- many1 valueChar-		return (key, value)-	-	valueChar = encoded <|> unencoded-	encoded = do-		_ <- char '%'-		hex <- count 2 hexDigit-		return (chr (hexToInt hex))-	unencoded = oneOf optionallyEncoded---- | Returns the address in the environment variable--- @DBUS_SYSTEM_BUS_ADDRESS@, or--- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@--- is not set.------ Returns 'Nothing' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid address.-getSystemAddress :: IO (Maybe Address)-getSystemAddress = do-	let system = "unix:path=/var/run/dbus/system_bus_socket"-	env <- getenv "DBUS_SYSTEM_BUS_ADDRESS"-	return (parseAddress (maybe system id env))---- | Returns the address in the environment variable--- @DBUS_SESSION_BUS_ADDRESS@, which must be set.------ Returns 'Nothing' if @DBUS_SYSTEM_BUS_ADDRESS@ is unset or contains an--- invalid address.-getSessionAddress :: IO (Maybe Address)-getSessionAddress = do-	env <- getenv "DBUS_SESSION_BUS_ADDRESS"-	return (env >>= parseAddress)---- | Returns the address in the environment variable--- @DBUS_STARTER_ADDRESS@, which must be set.------ Returns 'Nothing' if @DBUS_STARTER_ADDRESS@ is unset or contains an--- invalid address.-getStarterAddress :: IO (Maybe Address)-getStarterAddress = do-	env <- getenv "DBUS_STARTER_ADDRESS"-	return (env >>= parseAddress)--getenv :: String -> IO (Maybe String)-getenv name = Control.Exception.catch-	(fmap Just (System.Environment.getEnv name))-	(\(Control.Exception.SomeException _) -> return Nothing)--hexToInt :: String -> Int-hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt--maybeParseString :: Parser a -> String -> Maybe a-maybeParseString p str = case runParser p () "" str of-	Left _ -> Nothing-	Right a -> Just a

@@ -53,869 +53,869 @@ -- @ -- module DBus.Client-	(-	-- * Clients-	  Client-	-	-- * Connecting to a bus-	, connect-	, connectSystem-	, connectSession-	, connectStarter-	, disconnect-	-	-- * Sending method calls-	, call-	, call_-	, callNoReply-	-	-- * Receiving method calls-	, export-	, unexport-	, Method-	, method-	, Reply-	, replyReturn-	, replyError-	, throwError-	-	-- ** Automatic method signatures-	, AutoMethod-	, autoMethod-	-	-- * Signals-	, SignalHandler-	, addMatch-	, removeMatch-	, emit-	, listen-	-	-- ** Match rules-	, MatchRule-	, formatMatchRule-	, matchAny-	, matchSender-	, matchDestination-	, matchPath-	, matchInterface-	, matchMember-	-	-- * Name reservation-	, requestName-	, releaseName-	-	, RequestNameFlag-	, nameAllowReplacement-	, nameReplaceExisting-	, nameDoNotQueue-	-	, RequestNameReply(NamePrimaryOwner, NameInQueue, NameExists, NameAlreadyOwner)-	, ReleaseNameReply(NameReleased, NameNonExistent, NameNotOwner)-	-	-- * Client errors-	, ClientError-	, clientError-	, clientErrorMessage-	, clientErrorFatal-	-	-- * Advanced connection options-	, ClientOptions-	, clientSocketOptions-	, clientThreadRunner-	, defaultClientOptions-	, connectWith-	) where--import           Control.Concurrent-import           Control.Exception (SomeException, throwIO)-import qualified Control.Exception-import           Control.Monad (forever, forM_, when)-import           Data.Bits ((.|.))-import           Data.IORef-import           Data.List (foldl', intercalate)-import qualified Data.Map-import           Data.Map (Map)-import           Data.Maybe (catMaybes, listToMaybe)-import           Data.Typeable (Typeable)-import           Data.Unique-import           Data.Word (Word32)--import           DBus-import qualified DBus.Introspection as I-import qualified DBus.Socket-import           DBus.Transport (TransportOpen, SocketTransport)--data ClientError = ClientError-	{ clientErrorMessage :: String-	, clientErrorFatal :: Bool-	}-	deriving (Eq, Show, Typeable)--instance Control.Exception.Exception ClientError--clientError :: String -> ClientError-clientError msg = ClientError msg True---- | An active client session to a message bus. Clients may send or receive--- method calls, and listen for or emit signals.-data Client = Client-	{ clientSocket :: DBus.Socket.Socket-	, clientPendingCalls :: IORef (Map Serial (MVar (Either MethodError MethodReturn)))-	, clientSignalHandlers :: IORef (Map Unique SignalHandler)-	, clientObjects :: IORef (Map ObjectPath ObjectInfo)-	, clientThreadID :: ThreadId-	}--data ClientOptions t = ClientOptions-	{-	-- | Options for the underlying socket, for advanced use cases. See-	-- the "DBus.Socket" module.-	  clientSocketOptions :: DBus.Socket.SocketOptions t-	-	-- | A function to run the client thread. The provided IO computation-	-- should be called repeatedly; each time it is called, it will process-	-- one incoming message.-	---	-- The provided computation will throw a 'ClientError' if it fails to-	-- process an incoming message, or if the connection is lost.-	---	-- The default implementation is 'forever'.-	, clientThreadRunner :: IO () -> IO ()-	}--type Callback = (ReceivedMessage -> IO ())--type FormattedMatchRule = String-data SignalHandler = SignalHandler Unique FormattedMatchRule (IORef Bool) (Signal -> IO ())--data Reply-	= ReplyReturn [Variant]-	| ReplyError ErrorName [Variant]---- | Reply to a method call with a successful return, containing the given body.-replyReturn :: [Variant] -> Reply-replyReturn = ReplyReturn---- | Reply to a method call with an error, containing the given error name and--- body.------ Typically, the first item of the error body is a string with a message--- describing the error.-replyError :: ErrorName -> [Variant] -> Reply-replyError = ReplyError--data Method = Method InterfaceName MemberName Signature Signature (MethodCall -> IO Reply)--type ObjectInfo = Map InterfaceName InterfaceInfo-type InterfaceInfo = Map MemberName MethodInfo-data MethodInfo = MethodInfo Signature Signature Callback---- | 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.------ Throws a 'ClientError' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid--- address, or if connecting to the bus failed.-connectSystem :: IO Client-connectSystem = do-	env <- getSystemAddress-	case env of-		Nothing -> throwIO (clientError "connectSystem: DBUS_SYSTEM_BUS_ADDRESS is invalid.")-		Just addr -> connect addr---- | Connect to the bus specified in the environment variable--- @DBUS_SESSION_BUS_ADDRESS@, which must be set.------ Throws a 'ClientError' if @DBUS_SESSION_BUS_ADDRESS@ is unset, contains an--- invalid address, or if connecting to the bus failed.-connectSession :: IO Client-connectSession = do-	env <- getSessionAddress-	case env of-		Nothing -> throwIO (clientError "connectSession: DBUS_SESSION_BUS_ADDRESS is missing or invalid.")-		Just addr -> connect addr---- | Connect to the bus specified in the environment variable--- @DBUS_STARTER_ADDRESS@, which must be set.------ Throws a 'ClientError' if @DBUS_STARTER_ADDRESS@ is unset, contains an--- invalid address, or if connecting to the bus failed.-connectStarter :: IO Client-connectStarter = do-	env <- getStarterAddress-	case env of-		Nothing -> throwIO (clientError "connectStarter: DBUS_STARTER_ADDRESS is missing or invalid.")-		Just addr -> connect addr---- | Connect to the bus at the specified address.------ Throws a 'ClientError' on failure.-connect :: Address -> IO Client-connect = connectWith defaultClientOptions---- | Connect to the bus at the specified address, with the given connection--- options. Most users should use 'connect' instead.------ Throws a 'ClientError' on failure.-connectWith :: TransportOpen t => ClientOptions t -> Address -> IO Client-connectWith opts addr = do-	sock <- DBus.Socket.openWith (clientSocketOptions opts) addr-	-	pendingCalls <- newIORef Data.Map.empty-	signalHandlers <- newIORef Data.Map.empty-	objects <- newIORef Data.Map.empty-	-	let threadRunner = clientThreadRunner opts-	-	clientMVar <- newEmptyMVar-	threadID <- forkIO $ do-		client <- readMVar clientMVar-		threadRunner (mainLoop client)-	-	let client = Client-		{ clientSocket = sock-		, clientPendingCalls = pendingCalls-		, clientSignalHandlers = signalHandlers-		, clientObjects = objects-		, clientThreadID = threadID-		}-	putMVar clientMVar client-	-	export client "/" [introspectRoot client]-	-	callNoReply client (methodCall dbusPath dbusInterface "Hello")-		{ methodCallDestination = Just dbusName-		}-	-	return client---- | Default client options. Uses the built-in Socket-based transport, which--- supports the @tcp:@ and @unix:@ methods.-defaultClientOptions :: ClientOptions SocketTransport-defaultClientOptions = ClientOptions-	{ clientSocketOptions = DBus.Socket.defaultSocketOptions-	, clientThreadRunner = forever-	}---- | Stop a 'Client''s callback thread and close its underlying socket.-disconnect :: Client -> IO ()-disconnect client = do-	killThread (clientThreadID client)-	disconnect' client--disconnect' :: Client -> IO ()-disconnect' client = do-	pendingCalls <- atomicModifyIORef (clientPendingCalls client) (\p -> (Data.Map.empty, p))-	forM_ (Data.Map.toList pendingCalls) $ \(k, v) -> do-		putMVar v (Left (methodError k errorDisconnected))-	-	atomicWriteIORef (clientSignalHandlers client) Data.Map.empty-	atomicWriteIORef (clientObjects client) Data.Map.empty-	-	DBus.Socket.close (clientSocket client)--mainLoop :: Client -> IO ()-mainLoop client = do-	let sock = clientSocket client-	-	received <- Control.Exception.try (DBus.Socket.receive sock)-	msg <- case received of-		Left err -> do-			disconnect' client-			throwIO (clientError (DBus.Socket.socketErrorMessage err))-		Right msg -> return msg-	-	dispatch client msg--dispatch :: Client -> ReceivedMessage -> IO ()-dispatch client = go where-	go (ReceivedMethodReturn _ msg) = dispatchReply (methodReturnSerial msg) (Right msg)-	go (ReceivedMethodError _ msg) = dispatchReply (methodErrorSerial msg) (Left msg)-	go (ReceivedSignal _ msg) = do-		handlers <- readIORef (clientSignalHandlers client)-		forM_ (Data.Map.toAscList handlers) (\(_, SignalHandler _ _ _ h) -> forkIO (h msg) >> return ())-	go received@(ReceivedMethodCall serial msg) = do-		objects <- readIORef (clientObjects client)-		let sender = methodCallSender msg-		_ <- forkIO $ case findMethod objects msg of-			Right io -> io received-			Left errName -> send_ client-				(methodError serial errName)-					{ methodErrorDestination = sender-					}-				(\_ -> return ())-		return ()-	go _ = return ()-	-	dispatchReply serial result = do-		pending <- atomicModifyIORef-			(clientPendingCalls client)-			(\p -> case Data.Map.lookup serial p of-				Nothing -> (p, Nothing)-				Just mvar -> (Data.Map.delete serial p, Just mvar))-		case pending of-			Just mvar -> putMVar mvar result-			Nothing -> return ()--data RequestNameFlag-	= AllowReplacement-	| ReplaceExisting-	| DoNotQueue-	deriving (Eq, Show)---- | Allow this client's reservation to be replaced, if another client--- requests it with the 'nameReplaceExisting' flag.------ If this client's reservation is replaced, this client will be added to the--- wait queue unless the request also included the 'nameDoNotQueue' flag.-nameAllowReplacement :: RequestNameFlag-nameAllowReplacement = AllowReplacement---- | If the name being requested is already reserved, attempt to replace it.--- This only works if the current owner provided the 'nameAllowReplacement'--- flag.-nameReplaceExisting :: RequestNameFlag-nameReplaceExisting = ReplaceExisting---- | If the name is already in use, do not add this client to the queue, just--- return an error.-nameDoNotQueue :: RequestNameFlag-nameDoNotQueue = DoNotQueue--data RequestNameReply-	-- | This client is now the primary owner of the requested name.-	= NamePrimaryOwner-	-	-- | The name was already reserved by another client, and replacement-	-- was either not attempted or not successful.-	| NameInQueue-	-	-- | The name was already reserved by another client, 'DoNotQueue'-	-- was set, and replacement was either not attempted or not-	-- successful.-	| NameExists-	-	-- | This client is already the primary owner of the requested name.-	| NameAlreadyOwner-	-	-- | Not exported; exists to generate a compiler warning if users-	-- case on the reply and forget to include a default case.-	| UnknownRequestNameReply Word32-	deriving (Eq, Show)--data ReleaseNameReply-	-- | This client has released the provided name.-	= NameReleased-	-	-- | The provided name is not assigned to any client on the bus.-	| NameNonExistent-	-	-- | The provided name is not assigned to this client.-	| NameNotOwner-	-	-- | Not exported; exists to generate a compiler warning if users-	-- case on the reply and forget to include a default case.-	| UnknownReleaseNameReply Word32-	deriving (Eq, Show)--encodeFlags :: [RequestNameFlag] -> Word32-encodeFlags = foldr (.|.) 0 . map flagValue where-	flagValue AllowReplacement = 0x1-	flagValue ReplaceExisting  = 0x2-	flagValue DoNotQueue       = 0x4---- | Asks the message bus to assign the given name to this client. The bus--- maintains a queue of possible owners, where the head of the queue is the--- current (\"primary\") owner.------ There are several uses for name reservation:------ * Clients which export methods reserve a name so users and applications---   can send them messages. For example, the GNOME Keyring reserves the name---   @\"org.gnome.keyring\"@ on the user's session bus, and NetworkManager---   reserves @\"org.freedesktop.NetworkManager\"@ on the system bus.------ * When there are multiple implementations of a particular service, the---   service standard will ususally include a generic bus name for the---   service. This allows other clients to avoid depending on any particular---   implementation's name. For example, both the GNOME Keyring and KDE---   KWallet services request the @\"org.freedesktop.secrets\"@ name on the---   user's session bus.------ * A process with \"single instance\" behavior can use name assignment to---   check whether the instance is already running, and invoke some method---   on it (e.g. opening a new window).------ Throws a 'ClientError' if the call failed.-requestName :: Client -> BusName -> [RequestNameFlag] -> IO RequestNameReply-requestName client name flags = do-	reply <- call_ client (methodCall dbusPath dbusInterface "RequestName")-		{ methodCallDestination = Just dbusName-		, methodCallBody = [toVariant name, toVariant (encodeFlags flags)]-		}-	var <- case listToMaybe (methodReturnBody reply) of-		Just x -> return x-		Nothing -> throwIO (clientError "requestName: received empty response")-			{ clientErrorFatal = False-			}-	code <- case fromVariant var of-		Just x -> return x-		Nothing -> throwIO (clientError ("requestName: received invalid response code " ++ showsPrec 11 var ""))-			{ clientErrorFatal = False-			}-	return $ case code :: Word32 of-		1 -> NamePrimaryOwner-		2 -> NameInQueue-		3 -> NameExists-		4 -> NameAlreadyOwner-		_ -> UnknownRequestNameReply code---- | Release a name that this client previously requested. See 'requestName'--- for an explanation of name reservation.------ Throws a 'ClientError' if the call failed.-releaseName :: Client -> BusName -> IO ReleaseNameReply-releaseName client name = do-	reply <- call_ client (methodCall dbusPath dbusInterface "ReleaseName")-		{ methodCallDestination = Just dbusName-		, methodCallBody = [toVariant name]-		}-	var <- case listToMaybe (methodReturnBody reply) of-		Just x -> return x-		Nothing -> throwIO (clientError "releaseName: received empty response")-			{ clientErrorFatal = False-			}-	code <- case fromVariant var of-		Just x -> return x-		Nothing -> throwIO (clientError ("releaseName: received invalid response code " ++ showsPrec 11 var ""))-			{ clientErrorFatal = False-			}-	return $ case code :: Word32 of-		1 -> NameReleased-		2 -> NameNonExistent-		3 -> NameNotOwner-		_ -> UnknownReleaseNameReply code--send_ :: Message msg => Client -> msg -> (Serial -> IO a) -> IO a-send_ client msg io = do-	result <- Control.Exception.try (DBus.Socket.send (clientSocket client) msg io)-	case result of-		Right x -> return x-		Left err -> throwIO (clientError (DBus.Socket.socketErrorMessage err))-			{ clientErrorFatal = DBus.Socket.socketErrorFatal err-			}---- | Send a method call to the bus, and wait for the response.------ Throws a 'ClientError' if the method call couldn't be sent, or if the reply--- couldn't be parsed.-call :: Client -> MethodCall -> IO (Either MethodError MethodReturn)-call client msg = do-	-- If ReplyExpected is False, this function would block indefinitely-	-- if the remote side honors it.-	let safeMsg = msg-		{ methodCallReplyExpected = True-		}-	mvar <- newEmptyMVar-	let ref = clientPendingCalls client-	serial <- send_ client safeMsg (\serial -> atomicModifyIORef ref (\p -> (Data.Map.insert serial mvar p, serial)))-	-	-- At this point, we wait for the reply to arrive. The user may cancel-	-- a pending call by sending this thread an exception via something-	-- like 'timeout'; in that case, we want to clean up the pending call.-	Control.Exception.onException-		(takeMVar mvar)-		(atomicModifyIORef_ ref (Data.Map.delete serial))---- | Send a method call to the bus, and wait for the response.------ Unsets the 'noReplyExpected' message flag before sending.------ Throws a 'ClientError' if the method call couldn't sent, if the reply--- couldn't be parsed, or if the reply was a 'MethodError'.-call_ :: Client -> MethodCall -> IO MethodReturn-call_ client msg = do-	result <- call client msg-	case result of-		Left err -> throwIO (clientError ("Call failed: " ++ methodErrorMessage err))-			{ clientErrorFatal = methodErrorName err == errorDisconnected-			}-		Right ret -> return ret---- | Send a method call to the bus, and do not wait for a response.------ Sets the 'noReplyExpected' message flag before sending.------ Throws a 'ClientError' if the method call couldn't be sent.-callNoReply :: Client -> MethodCall -> IO ()-callNoReply client msg = do-	-- Ensure that noReplyExpected is always set.-	let safeMsg = msg-		{ methodCallReplyExpected = False-		}-	send_ client safeMsg (\_ -> return ())---- | Request that the bus forward signals matching the given rule to this--- client, and process them in a callback.------ A received signal might be processed by more than one callback at a time.--- Callbacks each run in their own thread.------ The returned 'SignalHandler' can be passed to 'removeMatch'--- to stop handling this signal.------ Throws a 'ClientError' if the match rule couldn't be added to the bus.-addMatch :: Client -> MatchRule -> (Signal -> IO ()) -> IO SignalHandler-addMatch client rule io = do-	let formatted = case formatMatchRule rule of-		"" -> "type='signal'"-		x -> "type='signal'," ++ x-	-	handlerId <- newUnique-	registered <- newIORef True-	let handler = SignalHandler handlerId formatted registered (\msg -> when (checkMatchRule rule msg) (io msg))-	-	atomicModifyIORef (clientSignalHandlers client) (\hs -> (Data.Map.insert handlerId handler hs, ()))-	_ <- call_ client (methodCall dbusPath dbusInterface "AddMatch")-		{ methodCallDestination = Just dbusName-		, methodCallBody = [toVariant formatted]-		}-	return handler---- | Request that the bus stop forwarding signals for the given handler.------ Throws a 'ClientError' if the match rule couldn't be removed from the bus.-removeMatch :: Client -> SignalHandler -> IO ()-removeMatch client (SignalHandler handlerId formatted registered _) = do-	shouldUnregister <- atomicModifyIORef registered (\wasRegistered -> (False, wasRegistered))-	when shouldUnregister $ do-		atomicModifyIORef (clientSignalHandlers client) (\hs -> (Data.Map.delete handlerId hs, ()))-		_ <- call_ client (methodCall dbusPath dbusInterface "RemoveMatch")-			{ methodCallDestination = Just dbusName-			, methodCallBody = [toVariant formatted]-			}-		return ()---- | Equivalent to 'addMatch', but does not return the added 'SignalHandler'.-listen :: Client -> MatchRule -> (Signal -> IO ()) -> IO ()-listen client rule io = addMatch client rule io >> return ()-{-# DEPRECATED listen "Prefer DBus.Client.addMatch in new code." #-}---- | Emit the signal on the bus.------ Throws a 'ClientError' if the signal message couldn't be sent.-emit :: Client -> Signal -> IO ()-emit client msg = send_ client msg (\_ -> return ())---- | A match rule describes which signals a particular callback is interested--- in. Use 'matchAny' to construct match rules.------ Example: a match rule which matches signals sent by the root object.------ @---matchFromRoot :: MatchRule---matchFromRoot = 'matchAny' { 'matchPath' = Just \"/\" }--- @-data MatchRule = MatchRule-	{-	-- | If set, only receives signals sent from the given bus name.-	---	-- The standard D-Bus implementation from <http://dbus.freedesktop.org/>-	-- almost always sets signal senders to the unique name of the sending-	-- client. If 'matchSender' is a requested name like-	-- @\"com.example.Foo\"@, it will not match any signals.-	---	-- The exception is for signals sent by the bus itself, which always-	-- have a sender of @\"org.freedesktop.DBus\"@.-	  matchSender :: Maybe BusName-	-	-- | If set, only receives signals sent to the given bus name.-	, matchDestination :: Maybe BusName-	-	-- | If set, only receives signals sent with the given path.-	, matchPath  :: Maybe ObjectPath-	-	-- | If set, only receives signals sent with the given interface name.-	, matchInterface :: Maybe InterfaceName-	-	-- | If set, only receives signals sent with the given member name.-	, matchMember :: Maybe MemberName-	}--instance Show MatchRule where-	showsPrec d rule = showParen (d > 10) (showString "MatchRule " . shows (formatMatchRule rule))---- | Convert a match rule into the textual format accepted by the bus.-formatMatchRule :: MatchRule -> String-formatMatchRule rule = intercalate "," predicates where-	predicates = catMaybes-		[ f "sender" matchSender formatBusName-		, f "destination" matchDestination formatBusName-		, f "path" matchPath formatObjectPath-		, f "interface" matchInterface formatInterfaceName-		, f "member" matchMember formatMemberName-		]-	-	f :: String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String-	f key get text = do-		val <- fmap text (get rule)-		return (concat [key, "='", val, "'"])---- | Match any signal.-matchAny :: MatchRule-matchAny = MatchRule Nothing Nothing Nothing Nothing Nothing--checkMatchRule :: MatchRule -> Signal -> Bool-checkMatchRule rule msg = and-	[ maybe True (\x -> signalSender msg == Just x) (matchSender rule)-	, maybe True (\x -> signalDestination msg == Just x) (matchDestination rule)-	, maybe True (== signalPath msg) (matchPath rule)-	, maybe True (== signalInterface msg) (matchInterface rule)-	, maybe True (== signalMember msg) (matchMember rule)-	]--data MethodExc = MethodExc ErrorName [Variant]-	deriving (Show, Eq, Typeable)--instance Control.Exception.Exception MethodExc---- | Normally, any exceptions raised while executing a method will be--- given the generic @\"org.freedesktop.DBus.Error.Failed\"@ name.--- 'throwError' allows the programmer to specify an error name, and provide--- additional information to the remote application. You may use this instead--- of 'Control.Exception.throwIO' to abort a method call.-throwError :: ErrorName-           -> String -- ^ Error message-           -> [Variant] -- ^ Additional items of the error body-           -> IO a-throwError name message extra = Control.Exception.throwIO (MethodExc name (toVariant message : extra))---- | Define a method handler, which will accept method calls with the given--- interface and member name.------ Note that the input and output parameter signatures are used for--- introspection, but are not checked when executing a method.------ See 'autoMethod' for an easier way to export functions with simple--- parameter and return types.-method :: InterfaceName-       -> MemberName-       -> Signature -- ^ Input parameter signature-       -> Signature -- ^ Output parameter signature-       -> (MethodCall -> IO Reply)-       -> Method-method iface name inSig outSig io = Method iface name inSig outSig-	(\msg -> Control.Exception.catch-		(Control.Exception.catch-			(io msg)-			(\(MethodExc name' vs') -> return (ReplyError name' vs')))-		(\exc -> return (ReplyError errorFailed-			[toVariant (show (exc :: SomeException))])))---- | Export the given functions under the given 'ObjectPath' and--- 'InterfaceName'. ------ Use 'autoMethod' to construct a 'Method' from a function that accepts and--- returns simple types.------ Use 'method' to construct a 'Method' from a function that handles parameter--- conversion manually.------ @---ping :: MethodCall -> IO 'Reply'---ping _ = replyReturn []------sayHello :: String -> IO String---sayHello name = return (\"Hello \" ++ name ++ \"!\")------export client \"/hello_world\"---    [ 'method' \"com.example.HelloWorld\" \"Ping\" ping---    , 'autoMethod' \"com.example.HelloWorld\" \"Hello\" sayHello---    ]--- @-export :: Client -> ObjectPath -> [Method] -> IO ()-export client path methods = atomicModifyIORef (clientObjects client) addObject where-	addObject objs = (Data.Map.insert path info objs, ())-	-	info = foldl' addMethod Data.Map.empty (defaultIntrospect : methods)-	addMethod m (Method iface name inSig outSig cb) = Data.Map.insertWith'-		Data.Map.union iface-		(Data.Map.fromList [(name, MethodInfo inSig outSig (wrapCB cb))]) m-	-	wrapCB cb (ReceivedMethodCall serial msg) = do-		reply <- cb msg-		let sender = methodCallSender msg-		case reply of-			ReplyReturn vs -> send_ client (methodReturn serial)-				{ methodReturnDestination = sender-				, methodReturnBody = vs-				} (\_ -> return ())-			ReplyError name vs -> send_ client (methodError serial name)-				{ methodErrorDestination = sender-				, methodErrorBody = vs-				} (\_ -> return ())-	wrapCB _ _ = return ()-	-	defaultIntrospect = methodIntrospect $ do-		objects <- readIORef (clientObjects client)-		let Just obj = Data.Map.lookup path objects-		return (introspect path obj)---- | Revokes the export of the given 'ObjectPath'. This will remove all--- interfaces and methods associated with the path.-unexport :: Client -> ObjectPath -> IO ()-unexport client path = atomicModifyIORef (clientObjects client) deleteObject where-	deleteObject objs = (Data.Map.delete path objs, ())--findMethod :: Map ObjectPath ObjectInfo -> MethodCall -> Either ErrorName Callback-findMethod objects msg = case Data.Map.lookup (methodCallPath msg) objects of-	Nothing -> Left errorUnknownObject-	Just obj -> case methodCallInterface msg of-		Nothing -> let-			members = do-				iface <- Data.Map.elems obj-				case Data.Map.lookup (methodCallMember msg) iface of-					Just member -> [member]-					Nothing -> []-			in case members of-				[MethodInfo _ _ io] -> Right io-				_ -> Left errorUnknownMethod-		Just ifaceName -> case Data.Map.lookup ifaceName obj of-			Nothing -> Left errorUnknownInterface-			Just iface -> case Data.Map.lookup (methodCallMember msg) iface of-				Just (MethodInfo _ _ io) -> Right io-				_ -> Left errorUnknownMethod--introspectRoot :: Client -> Method-introspectRoot client = methodIntrospect $ do-	objects <- readIORef (clientObjects client)-	let paths = filter (/= "/") (Data.Map.keys objects)-	return (I.object "/")-		{ I.objectInterfaces =-			[ (I.interface interfaceIntrospectable)-				{ I.interfaceMethods =-					[ (I.method "Introspect")-						{ I.methodArgs =-							[ I.methodArg "" TypeString I.directionOut-							]-						}-					]-				}-			]-		, I.objectChildren = [I.object p | p <- paths]-		}--methodIntrospect :: IO I.Object -> Method-methodIntrospect get = method interfaceIntrospectable "Introspect" "" "s" $-	\msg -> case methodCallBody msg of-		[] -> do-			obj <- get-			let Just xml = I.formatXML obj-			return (replyReturn [toVariant xml])-		_ -> return (replyError errorInvalidParameters [])--introspect :: ObjectPath -> ObjectInfo -> I.Object-introspect path obj = (I.object path) { I.objectInterfaces = interfaces } where-	interfaces = map introspectIface (Data.Map.toList obj)-	-	introspectIface (name, iface) = (I.interface name)-		{ I.interfaceMethods = concatMap introspectMethod (Data.Map.toList iface)-		}-	-	args inSig outSig =-		map (introspectArg I.directionIn) (signatureTypes inSig) ++-		map (introspectArg I.directionOut) (signatureTypes outSig)-	-	introspectMethod (name, MethodInfo inSig outSig _) =-		[ (I.method name)-			{ I.methodArgs = args inSig outSig-			}-		]-	-	introspectArg dir t = I.methodArg "" t dir---- | Used to automatically generate method signatures for introspection--- documents. To support automatic signatures, a method's parameters and--- return value must all be instances of 'IsValue'.------ This class maps Haskell idioms to D-Bus; it is therefore unable to--- generate some signatures. In particular, it does not support methods--- which accept/return a single structure, or single-element structures.--- It also cannot generate signatures for methods with parameters or return--- values which are only instances of 'IsVariant'. For these cases, please--- use 'DBus.Client.method'.------ To match common Haskell use, if the return value is a tuple, it will be--- converted to a list of return values.-class AutoMethod a where-	funTypes :: a -> ([Type], [Type])-	apply :: a -> [Variant] -> Maybe (IO [Variant])--instance AutoMethod (IO ()) where-	funTypes _ = ([], [])-	-	apply io [] = Just (io >> return [])-	apply _ _ = Nothing--instance IsValue a => AutoMethod (IO a) where-	funTypes io = cased where-		cased = ([], case ioT io undefined of-			(_, t) -> case t of-				TypeStructure ts -> ts-				_ -> [t])-		-		ioT :: IsValue a => IO a -> a -> (a, Type)-		ioT _ a = (a, typeOf a)-	-	apply io [] = Just (do-		var <- fmap toVariant io-		case fromVariant var of-			Just struct -> return (structureItems struct)-			Nothing -> return [var])-	apply _ _ = Nothing--instance (IsValue a, AutoMethod fn) => AutoMethod (a -> fn) where-	funTypes fn = cased where-		cased = case valueT undefined of-			(a, t) -> case funTypes (fn a) of-				(ts, ts') -> (t : ts, ts')-		-		valueT :: IsValue a => a -> (a, Type)-		valueT a = (a, typeOf a)-	-	apply _ [] = Nothing-	apply fn (v:vs) = case fromVariant v of-		Just v' -> apply (fn v') vs-		Nothing -> Nothing---- | Prepare a Haskell function for export, automatically detecting the--- function's type signature.------ See 'AutoMethod' for details on the limitations of this function.------ See 'method' for exporting functions with user-defined types.-autoMethod :: (AutoMethod fn) => InterfaceName -> MemberName -> fn -> Method-autoMethod iface name fun = DBus.Client.method iface name inSig outSig io where-	(typesIn, typesOut) = funTypes fun-	inSig = case signature typesIn of-		Just sig -> sig-		Nothing -> invalid "input"-	outSig = case signature typesOut of-		Just sig -> sig-		Nothing -> invalid "output"-	io msg = case apply fun (methodCallBody msg) of-		Nothing -> return (ReplyError errorInvalidParameters [])-		Just io' -> fmap ReplyReturn io'-	-	invalid label = error (concat-		[ "Method "-		, formatInterfaceName iface-		, "."-		, formatMemberName name-		, " has an invalid "-		, label-		, " signature."])+    (+    -- * Clients+      Client++    -- * Connecting to a bus+    , connect+    , connectSystem+    , connectSession+    , connectStarter+    , disconnect++    -- * Sending method calls+    , call+    , call_+    , callNoReply++    -- * Receiving method calls+    , export+    , unexport+    , Method+    , method+    , Reply+    , replyReturn+    , replyError+    , throwError++    -- ** Automatic method signatures+    , AutoMethod+    , autoMethod++    -- * Signals+    , SignalHandler+    , addMatch+    , removeMatch+    , emit+    , listen++    -- ** Match rules+    , MatchRule+    , formatMatchRule+    , matchAny+    , matchSender+    , matchDestination+    , matchPath+    , matchInterface+    , matchMember++    -- * Name reservation+    , requestName+    , releaseName++    , RequestNameFlag+    , nameAllowReplacement+    , nameReplaceExisting+    , nameDoNotQueue++    , RequestNameReply(NamePrimaryOwner, NameInQueue, NameExists, NameAlreadyOwner)+    , ReleaseNameReply(NameReleased, NameNonExistent, NameNotOwner)++    -- * Client errors+    , ClientError+    , clientError+    , clientErrorMessage+    , clientErrorFatal++    -- * Advanced connection options+    , ClientOptions+    , clientSocketOptions+    , clientThreadRunner+    , defaultClientOptions+    , connectWith+    ) where++import           Control.Concurrent+import           Control.Exception (SomeException, throwIO)+import qualified Control.Exception+import           Control.Monad (forever, forM_, when)+import           Data.Bits ((.|.))+import           Data.IORef+import           Data.List (foldl', intercalate)+import qualified Data.Map+import           Data.Map (Map)+import           Data.Maybe (catMaybes, listToMaybe)+import           Data.Typeable (Typeable)+import           Data.Unique+import           Data.Word (Word32)++import           DBus+import qualified DBus.Introspection as I+import qualified DBus.Socket+import           DBus.Transport (TransportOpen, SocketTransport)++data ClientError = ClientError+    { clientErrorMessage :: String+    , clientErrorFatal :: Bool+    }+    deriving (Eq, Show, Typeable)++instance Control.Exception.Exception ClientError++clientError :: String -> ClientError+clientError msg = ClientError msg True++-- | An active client session to a message bus. Clients may send or receive+-- method calls, and listen for or emit signals.+data Client = Client+    { clientSocket :: DBus.Socket.Socket+    , clientPendingCalls :: IORef (Map Serial (MVar (Either MethodError MethodReturn)))+    , clientSignalHandlers :: IORef (Map Unique SignalHandler)+    , clientObjects :: IORef (Map ObjectPath ObjectInfo)+    , clientThreadID :: ThreadId+    }++data ClientOptions t = ClientOptions+    {+    -- | Options for the underlying socket, for advanced use cases. See+    -- the "DBus.Socket" module.+      clientSocketOptions :: DBus.Socket.SocketOptions t++    -- | A function to run the client thread. The provided IO computation+    -- should be called repeatedly; each time it is called, it will process+    -- one incoming message.+    --+    -- The provided computation will throw a 'ClientError' if it fails to+    -- process an incoming message, or if the connection is lost.+    --+    -- The default implementation is 'forever'.+    , clientThreadRunner :: IO () -> IO ()+    }++type Callback = (ReceivedMessage -> IO ())++type FormattedMatchRule = String+data SignalHandler = SignalHandler Unique FormattedMatchRule (IORef Bool) (Signal -> IO ())++data Reply+    = ReplyReturn [Variant]+    | ReplyError ErrorName [Variant]++-- | Reply to a method call with a successful return, containing the given body.+replyReturn :: [Variant] -> Reply+replyReturn = ReplyReturn++-- | Reply to a method call with an error, containing the given error name and+-- body.+--+-- Typically, the first item of the error body is a string with a message+-- describing the error.+replyError :: ErrorName -> [Variant] -> Reply+replyError = ReplyError++data Method = Method InterfaceName MemberName Signature Signature (MethodCall -> IO Reply)++type ObjectInfo = Map InterfaceName InterfaceInfo+type InterfaceInfo = Map MemberName MethodInfo+data MethodInfo = MethodInfo Signature Signature Callback++-- | 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.+--+-- Throws a 'ClientError' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid+-- address, or if connecting to the bus failed.+connectSystem :: IO Client+connectSystem = do+    env <- getSystemAddress+    case env of+        Nothing -> throwIO (clientError "connectSystem: DBUS_SYSTEM_BUS_ADDRESS is invalid.")+        Just addr -> connect addr++-- | Connect to the bus specified in the environment variable+-- @DBUS_SESSION_BUS_ADDRESS@, which must be set.+--+-- Throws a 'ClientError' if @DBUS_SESSION_BUS_ADDRESS@ is unset, contains an+-- invalid address, or if connecting to the bus failed.+connectSession :: IO Client+connectSession = do+    env <- getSessionAddress+    case env of+        Nothing -> throwIO (clientError "connectSession: DBUS_SESSION_BUS_ADDRESS is missing or invalid.")+        Just addr -> connect addr++-- | Connect to the bus specified in the environment variable+-- @DBUS_STARTER_ADDRESS@, which must be set.+--+-- Throws a 'ClientError' if @DBUS_STARTER_ADDRESS@ is unset, contains an+-- invalid address, or if connecting to the bus failed.+connectStarter :: IO Client+connectStarter = do+    env <- getStarterAddress+    case env of+        Nothing -> throwIO (clientError "connectStarter: DBUS_STARTER_ADDRESS is missing or invalid.")+        Just addr -> connect addr++-- | Connect to the bus at the specified address.+--+-- Throws a 'ClientError' on failure.+connect :: Address -> IO Client+connect = connectWith defaultClientOptions++-- | Connect to the bus at the specified address, with the given connection+-- options. Most users should use 'connect' instead.+--+-- Throws a 'ClientError' on failure.+connectWith :: TransportOpen t => ClientOptions t -> Address -> IO Client+connectWith opts addr = do+    sock <- DBus.Socket.openWith (clientSocketOptions opts) addr++    pendingCalls <- newIORef Data.Map.empty+    signalHandlers <- newIORef Data.Map.empty+    objects <- newIORef Data.Map.empty++    let threadRunner = clientThreadRunner opts++    clientMVar <- newEmptyMVar+    threadID <- forkIO $ do+        client <- readMVar clientMVar+        threadRunner (mainLoop client)++    let client = Client+            { clientSocket = sock+            , clientPendingCalls = pendingCalls+            , clientSignalHandlers = signalHandlers+            , clientObjects = objects+            , clientThreadID = threadID+            }+    putMVar clientMVar client++    export client "/" [introspectRoot client]++    callNoReply client (methodCall dbusPath dbusInterface "Hello")+        { methodCallDestination = Just dbusName+        }++    return client++-- | Default client options. Uses the built-in Socket-based transport, which+-- supports the @tcp:@ and @unix:@ methods.+defaultClientOptions :: ClientOptions SocketTransport+defaultClientOptions = ClientOptions+    { clientSocketOptions = DBus.Socket.defaultSocketOptions+    , clientThreadRunner = forever+    }++-- | Stop a 'Client''s callback thread and close its underlying socket.+disconnect :: Client -> IO ()+disconnect client = do+    killThread (clientThreadID client)+    disconnect' client++disconnect' :: Client -> IO ()+disconnect' client = do+    pendingCalls <- atomicModifyIORef (clientPendingCalls client) (\p -> (Data.Map.empty, p))+    forM_ (Data.Map.toList pendingCalls) $ \(k, v) -> do+        putMVar v (Left (methodError k errorDisconnected))++    atomicWriteIORef (clientSignalHandlers client) Data.Map.empty+    atomicWriteIORef (clientObjects client) Data.Map.empty++    DBus.Socket.close (clientSocket client)++mainLoop :: Client -> IO ()+mainLoop client = do+    let sock = clientSocket client++    received <- Control.Exception.try (DBus.Socket.receive sock)+    msg <- case received of+        Left err -> do+            disconnect' client+            throwIO (clientError (DBus.Socket.socketErrorMessage err))+        Right msg -> return msg++    dispatch client msg++dispatch :: Client -> ReceivedMessage -> IO ()+dispatch client = go where+    go (ReceivedMethodReturn _ msg) = dispatchReply (methodReturnSerial msg) (Right msg)+    go (ReceivedMethodError _ msg) = dispatchReply (methodErrorSerial msg) (Left msg)+    go (ReceivedSignal _ msg) = do+        handlers <- readIORef (clientSignalHandlers client)+        forM_ (Data.Map.toAscList handlers) (\(_, SignalHandler _ _ _ h) -> forkIO (h msg) >> return ())+    go received@(ReceivedMethodCall serial msg) = do+        objects <- readIORef (clientObjects client)+        let sender = methodCallSender msg+        _ <- forkIO $ case findMethod objects msg of+            Right io -> io received+            Left errName -> send_ client+                (methodError serial errName)+                    { methodErrorDestination = sender+                    }+                (\_ -> return ())+        return ()+    go _ = return ()++    dispatchReply serial result = do+        pending <- atomicModifyIORef+            (clientPendingCalls client)+            (\p -> case Data.Map.lookup serial p of+                Nothing -> (p, Nothing)+                Just mvar -> (Data.Map.delete serial p, Just mvar))+        case pending of+            Just mvar -> putMVar mvar result+            Nothing -> return ()++data RequestNameFlag+    = AllowReplacement+    | ReplaceExisting+    | DoNotQueue+    deriving (Eq, Show)++-- | Allow this client's reservation to be replaced, if another client+-- requests it with the 'nameReplaceExisting' flag.+--+-- If this client's reservation is replaced, this client will be added to the+-- wait queue unless the request also included the 'nameDoNotQueue' flag.+nameAllowReplacement :: RequestNameFlag+nameAllowReplacement = AllowReplacement++-- | If the name being requested is already reserved, attempt to replace it.+-- This only works if the current owner provided the 'nameAllowReplacement'+-- flag.+nameReplaceExisting :: RequestNameFlag+nameReplaceExisting = ReplaceExisting++-- | If the name is already in use, do not add this client to the queue, just+-- return an error.+nameDoNotQueue :: RequestNameFlag+nameDoNotQueue = DoNotQueue++data RequestNameReply+    -- | This client is now the primary owner of the requested name.+    = NamePrimaryOwner++    -- | The name was already reserved by another client, and replacement+    -- was either not attempted or not successful.+    | NameInQueue++    -- | The name was already reserved by another client, 'DoNotQueue'+    -- was set, and replacement was either not attempted or not+    -- successful.+    | NameExists++    -- | This client is already the primary owner of the requested name.+    | NameAlreadyOwner++    -- | Not exported; exists to generate a compiler warning if users+    -- case on the reply and forget to include a default case.+    | UnknownRequestNameReply Word32+    deriving (Eq, Show)++data ReleaseNameReply+    -- | This client has released the provided name.+    = NameReleased++    -- | The provided name is not assigned to any client on the bus.+    | NameNonExistent++    -- | The provided name is not assigned to this client.+    | NameNotOwner++    -- | Not exported; exists to generate a compiler warning if users+    -- case on the reply and forget to include a default case.+    | UnknownReleaseNameReply Word32+    deriving (Eq, Show)++encodeFlags :: [RequestNameFlag] -> Word32+encodeFlags = foldr (.|.) 0 . map flagValue where+    flagValue AllowReplacement = 0x1+    flagValue ReplaceExisting  = 0x2+    flagValue DoNotQueue       = 0x4++-- | Asks the message bus to assign the given name to this client. The bus+-- maintains a queue of possible owners, where the head of the queue is the+-- current (\"primary\") owner.+--+-- There are several uses for name reservation:+--+-- * Clients which export methods reserve a name so users and applications+--   can send them messages. For example, the GNOME Keyring reserves the name+--   @\"org.gnome.keyring\"@ on the user's session bus, and NetworkManager+--   reserves @\"org.freedesktop.NetworkManager\"@ on the system bus.+--+-- * When there are multiple implementations of a particular service, the+--   service standard will ususally include a generic bus name for the+--   service. This allows other clients to avoid depending on any particular+--   implementation's name. For example, both the GNOME Keyring and KDE+--   KWallet services request the @\"org.freedesktop.secrets\"@ name on the+--   user's session bus.+--+-- * A process with \"single instance\" behavior can use name assignment to+--   check whether the instance is already running, and invoke some method+--   on it (e.g. opening a new window).+--+-- Throws a 'ClientError' if the call failed.+requestName :: Client -> BusName -> [RequestNameFlag] -> IO RequestNameReply+requestName client name flags = do+    reply <- call_ client (methodCall dbusPath dbusInterface "RequestName")+        { methodCallDestination = Just dbusName+        , methodCallBody = [toVariant name, toVariant (encodeFlags flags)]+        }+    var <- case listToMaybe (methodReturnBody reply) of+        Just x -> return x+        Nothing -> throwIO (clientError "requestName: received empty response")+            { clientErrorFatal = False+            }+    code <- case fromVariant var of+        Just x -> return x+        Nothing -> throwIO (clientError ("requestName: received invalid response code " ++ showsPrec 11 var ""))+            { clientErrorFatal = False+            }+    return $ case code :: Word32 of+        1 -> NamePrimaryOwner+        2 -> NameInQueue+        3 -> NameExists+        4 -> NameAlreadyOwner+        _ -> UnknownRequestNameReply code++-- | Release a name that this client previously requested. See 'requestName'+-- for an explanation of name reservation.+--+-- Throws a 'ClientError' if the call failed.+releaseName :: Client -> BusName -> IO ReleaseNameReply+releaseName client name = do+    reply <- call_ client (methodCall dbusPath dbusInterface "ReleaseName")+        { methodCallDestination = Just dbusName+        , methodCallBody = [toVariant name]+        }+    var <- case listToMaybe (methodReturnBody reply) of+        Just x -> return x+        Nothing -> throwIO (clientError "releaseName: received empty response")+            { clientErrorFatal = False+            }+    code <- case fromVariant var of+        Just x -> return x+        Nothing -> throwIO (clientError ("releaseName: received invalid response code " ++ showsPrec 11 var ""))+            { clientErrorFatal = False+            }+    return $ case code :: Word32 of+        1 -> NameReleased+        2 -> NameNonExistent+        3 -> NameNotOwner+        _ -> UnknownReleaseNameReply code++send_ :: Message msg => Client -> msg -> (Serial -> IO a) -> IO a+send_ client msg io = do+    result <- Control.Exception.try (DBus.Socket.send (clientSocket client) msg io)+    case result of+        Right x -> return x+        Left err -> throwIO (clientError (DBus.Socket.socketErrorMessage err))+            { clientErrorFatal = DBus.Socket.socketErrorFatal err+            }++-- | Send a method call to the bus, and wait for the response.+--+-- Throws a 'ClientError' if the method call couldn't be sent, or if the reply+-- couldn't be parsed.+call :: Client -> MethodCall -> IO (Either MethodError MethodReturn)+call client msg = do+    -- If ReplyExpected is False, this function would block indefinitely+    -- if the remote side honors it.+    let safeMsg = msg+            { methodCallReplyExpected = True+            }+    mvar <- newEmptyMVar+    let ref = clientPendingCalls client+    serial <- send_ client safeMsg (\serial -> atomicModifyIORef ref (\p -> (Data.Map.insert serial mvar p, serial)))++    -- At this point, we wait for the reply to arrive. The user may cancel+    -- a pending call by sending this thread an exception via something+    -- like 'timeout'; in that case, we want to clean up the pending call.+    Control.Exception.onException+        (takeMVar mvar)+        (atomicModifyIORef_ ref (Data.Map.delete serial))++-- | Send a method call to the bus, and wait for the response.+--+-- Unsets the 'noReplyExpected' message flag before sending.+--+-- Throws a 'ClientError' if the method call couldn't sent, if the reply+-- couldn't be parsed, or if the reply was a 'MethodError'.+call_ :: Client -> MethodCall -> IO MethodReturn+call_ client msg = do+    result <- call client msg+    case result of+        Left err -> throwIO (clientError ("Call failed: " ++ methodErrorMessage err))+            { clientErrorFatal = methodErrorName err == errorDisconnected+            }+        Right ret -> return ret++-- | Send a method call to the bus, and do not wait for a response.+--+-- Sets the 'noReplyExpected' message flag before sending.+--+-- Throws a 'ClientError' if the method call couldn't be sent.+callNoReply :: Client -> MethodCall -> IO ()+callNoReply client msg = do+    -- Ensure that noReplyExpected is always set.+    let safeMsg = msg+            { methodCallReplyExpected = False+            }+    send_ client safeMsg (\_ -> return ())++-- | Request that the bus forward signals matching the given rule to this+-- client, and process them in a callback.+--+-- A received signal might be processed by more than one callback at a time.+-- Callbacks each run in their own thread.+--+-- The returned 'SignalHandler' can be passed to 'removeMatch'+-- to stop handling this signal.+--+-- Throws a 'ClientError' if the match rule couldn't be added to the bus.+addMatch :: Client -> MatchRule -> (Signal -> IO ()) -> IO SignalHandler+addMatch client rule io = do+    let formatted = case formatMatchRule rule of+            "" -> "type='signal'"+            x -> "type='signal'," ++ x++    handlerId <- newUnique+    registered <- newIORef True+    let handler = SignalHandler handlerId formatted registered (\msg -> when (checkMatchRule rule msg) (io msg))++    atomicModifyIORef (clientSignalHandlers client) (\hs -> (Data.Map.insert handlerId handler hs, ()))+    _ <- call_ client (methodCall dbusPath dbusInterface "AddMatch")+        { methodCallDestination = Just dbusName+        , methodCallBody = [toVariant formatted]+        }+    return handler++-- | Request that the bus stop forwarding signals for the given handler.+--+-- Throws a 'ClientError' if the match rule couldn't be removed from the bus.+removeMatch :: Client -> SignalHandler -> IO ()+removeMatch client (SignalHandler handlerId formatted registered _) = do+    shouldUnregister <- atomicModifyIORef registered (\wasRegistered -> (False, wasRegistered))+    when shouldUnregister $ do+        atomicModifyIORef (clientSignalHandlers client) (\hs -> (Data.Map.delete handlerId hs, ()))+        _ <- call_ client (methodCall dbusPath dbusInterface "RemoveMatch")+            { methodCallDestination = Just dbusName+            , methodCallBody = [toVariant formatted]+            }+        return ()++-- | Equivalent to 'addMatch', but does not return the added 'SignalHandler'.+listen :: Client -> MatchRule -> (Signal -> IO ()) -> IO ()+listen client rule io = addMatch client rule io >> return ()+{-# DEPRECATED listen "Prefer DBus.Client.addMatch in new code." #-}++-- | Emit the signal on the bus.+--+-- Throws a 'ClientError' if the signal message couldn't be sent.+emit :: Client -> Signal -> IO ()+emit client msg = send_ client msg (\_ -> return ())++-- | A match rule describes which signals a particular callback is interested+-- in. Use 'matchAny' to construct match rules.+--+-- Example: a match rule which matches signals sent by the root object.+--+-- @+--matchFromRoot :: MatchRule+--matchFromRoot = 'matchAny' { 'matchPath' = Just \"/\" }+-- @+data MatchRule = MatchRule+    {+    -- | If set, only receives signals sent from the given bus name.+    --+    -- The standard D-Bus implementation from <http://dbus.freedesktop.org/>+    -- almost always sets signal senders to the unique name of the sending+    -- client. If 'matchSender' is a requested name like+    -- @\"com.example.Foo\"@, it will not match any signals.+    --+    -- The exception is for signals sent by the bus itself, which always+    -- have a sender of @\"org.freedesktop.DBus\"@.+      matchSender :: Maybe BusName++    -- | If set, only receives signals sent to the given bus name.+    , matchDestination :: Maybe BusName++    -- | If set, only receives signals sent with the given path.+    , matchPath  :: Maybe ObjectPath++    -- | If set, only receives signals sent with the given interface name.+    , matchInterface :: Maybe InterfaceName++    -- | If set, only receives signals sent with the given member name.+    , matchMember :: Maybe MemberName+    }++instance Show MatchRule where+    showsPrec d rule = showParen (d > 10) (showString "MatchRule " . shows (formatMatchRule rule))++-- | Convert a match rule into the textual format accepted by the bus.+formatMatchRule :: MatchRule -> String+formatMatchRule rule = intercalate "," predicates where+    predicates = catMaybes+        [ f "sender" matchSender formatBusName+        , f "destination" matchDestination formatBusName+        , f "path" matchPath formatObjectPath+        , f "interface" matchInterface formatInterfaceName+        , f "member" matchMember formatMemberName+        ]++    f :: String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String+    f key get text = do+        val <- fmap text (get rule)+        return (concat [key, "='", val, "'"])++-- | Match any signal.+matchAny :: MatchRule+matchAny = MatchRule Nothing Nothing Nothing Nothing Nothing++checkMatchRule :: MatchRule -> Signal -> Bool+checkMatchRule rule msg = and+    [ maybe True (\x -> signalSender msg == Just x) (matchSender rule)+    , maybe True (\x -> signalDestination msg == Just x) (matchDestination rule)+    , maybe True (== signalPath msg) (matchPath rule)+    , maybe True (== signalInterface msg) (matchInterface rule)+    , maybe True (== signalMember msg) (matchMember rule)+    ]++data MethodExc = MethodExc ErrorName [Variant]+    deriving (Show, Eq, Typeable)++instance Control.Exception.Exception MethodExc++-- | Normally, any exceptions raised while executing a method will be+-- given the generic @\"org.freedesktop.DBus.Error.Failed\"@ name.+-- 'throwError' allows the programmer to specify an error name, and provide+-- additional information to the remote application. You may use this instead+-- of 'Control.Exception.throwIO' to abort a method call.+throwError :: ErrorName+           -> String -- ^ Error message+           -> [Variant] -- ^ Additional items of the error body+           -> IO a+throwError name message extra = Control.Exception.throwIO (MethodExc name (toVariant message : extra))++-- | Define a method handler, which will accept method calls with the given+-- interface and member name.+--+-- Note that the input and output parameter signatures are used for+-- introspection, but are not checked when executing a method.+--+-- See 'autoMethod' for an easier way to export functions with simple+-- parameter and return types.+method :: InterfaceName+       -> MemberName+       -> Signature -- ^ Input parameter signature+       -> Signature -- ^ Output parameter signature+       -> (MethodCall -> IO Reply)+       -> Method+method iface name inSig outSig io = Method iface name inSig outSig+    (\msg -> Control.Exception.catch+        (Control.Exception.catch+            (io msg)+            (\(MethodExc name' vs') -> return (ReplyError name' vs')))+        (\exc -> return (ReplyError errorFailed+            [toVariant (show (exc :: SomeException))])))++-- | Export the given functions under the given 'ObjectPath' and+-- 'InterfaceName'.+--+-- Use 'autoMethod' to construct a 'Method' from a function that accepts and+-- returns simple types.+--+-- Use 'method' to construct a 'Method' from a function that handles parameter+-- conversion manually.+--+-- @+--ping :: MethodCall -> IO 'Reply'+--ping _ = replyReturn []+--+--sayHello :: String -> IO String+--sayHello name = return (\"Hello \" ++ name ++ \"!\")+--+--export client \"/hello_world\"+--    [ 'method' \"com.example.HelloWorld\" \"Ping\" ping+--    , 'autoMethod' \"com.example.HelloWorld\" \"Hello\" sayHello+--    ]+-- @+export :: Client -> ObjectPath -> [Method] -> IO ()+export client path methods = atomicModifyIORef (clientObjects client) addObject where+    addObject objs = (Data.Map.insert path info objs, ())++    info = foldl' addMethod Data.Map.empty (defaultIntrospect : methods)+    addMethod m (Method iface name inSig outSig cb) = Data.Map.insertWith'+        Data.Map.union iface+        (Data.Map.fromList [(name, MethodInfo inSig outSig (wrapCB cb))]) m++    wrapCB cb (ReceivedMethodCall serial msg) = do+        reply <- cb msg+        let sender = methodCallSender msg+        case reply of+            ReplyReturn vs -> send_ client (methodReturn serial)+                { methodReturnDestination = sender+                , methodReturnBody = vs+                } (\_ -> return ())+            ReplyError name vs -> send_ client (methodError serial name)+                { methodErrorDestination = sender+                , methodErrorBody = vs+                } (\_ -> return ())+    wrapCB _ _ = return ()++    defaultIntrospect = methodIntrospect $ do+        objects <- readIORef (clientObjects client)+        let Just obj = Data.Map.lookup path objects+        return (introspect path obj)++-- | Revokes the export of the given 'ObjectPath'. This will remove all+-- interfaces and methods associated with the path.+unexport :: Client -> ObjectPath -> IO ()+unexport client path = atomicModifyIORef (clientObjects client) deleteObject where+    deleteObject objs = (Data.Map.delete path objs, ())++findMethod :: Map ObjectPath ObjectInfo -> MethodCall -> Either ErrorName Callback+findMethod objects msg = case Data.Map.lookup (methodCallPath msg) objects of+    Nothing -> Left errorUnknownObject+    Just obj -> case methodCallInterface msg of+        Nothing -> let+            members = do+                iface <- Data.Map.elems obj+                case Data.Map.lookup (methodCallMember msg) iface of+                    Just member -> [member]+                    Nothing -> []+            in case members of+                [MethodInfo _ _ io] -> Right io+                _ -> Left errorUnknownMethod+        Just ifaceName -> case Data.Map.lookup ifaceName obj of+            Nothing -> Left errorUnknownInterface+            Just iface -> case Data.Map.lookup (methodCallMember msg) iface of+                Just (MethodInfo _ _ io) -> Right io+                _ -> Left errorUnknownMethod++introspectRoot :: Client -> Method+introspectRoot client = methodIntrospect $ do+    objects <- readIORef (clientObjects client)+    let paths = filter (/= "/") (Data.Map.keys objects)+    return (I.object "/")+        { I.objectInterfaces =+            [ (I.interface interfaceIntrospectable)+                { I.interfaceMethods =+                    [ (I.method "Introspect")+                        { I.methodArgs =+                            [ I.methodArg "" TypeString I.directionOut+                            ]+                        }+                    ]+                }+            ]+        , I.objectChildren = [I.object p | p <- paths]+        }++methodIntrospect :: IO I.Object -> Method+methodIntrospect get = method interfaceIntrospectable "Introspect" "" "s" $+    \msg -> case methodCallBody msg of+        [] -> do+            obj <- get+            let Just xml = I.formatXML obj+            return (replyReturn [toVariant xml])+        _ -> return (replyError errorInvalidParameters [])++introspect :: ObjectPath -> ObjectInfo -> I.Object+introspect path obj = (I.object path) { I.objectInterfaces = interfaces } where+    interfaces = map introspectIface (Data.Map.toList obj)++    introspectIface (name, iface) = (I.interface name)+        { I.interfaceMethods = concatMap introspectMethod (Data.Map.toList iface)+        }++    args inSig outSig =+        map (introspectArg I.directionIn) (signatureTypes inSig) +++        map (introspectArg I.directionOut) (signatureTypes outSig)++    introspectMethod (name, MethodInfo inSig outSig _) =+        [ (I.method name)+            { I.methodArgs = args inSig outSig+            }+        ]++    introspectArg dir t = I.methodArg "" t dir++-- | Used to automatically generate method signatures for introspection+-- documents. To support automatic signatures, a method's parameters and+-- return value must all be instances of 'IsValue'.+--+-- This class maps Haskell idioms to D-Bus; it is therefore unable to+-- generate some signatures. In particular, it does not support methods+-- which accept/return a single structure, or single-element structures.+-- It also cannot generate signatures for methods with parameters or return+-- values which are only instances of 'IsVariant'. For these cases, please+-- use 'DBus.Client.method'.+--+-- To match common Haskell use, if the return value is a tuple, it will be+-- converted to a list of return values.+class AutoMethod a where+    funTypes :: a -> ([Type], [Type])+    apply :: a -> [Variant] -> Maybe (IO [Variant])++instance AutoMethod (IO ()) where+    funTypes _ = ([], [])++    apply io [] = Just (io >> return [])+    apply _ _ = Nothing++instance IsValue a => AutoMethod (IO a) where+    funTypes io = cased where+        cased = ([], case ioT io undefined of+            (_, t) -> case t of+                TypeStructure ts -> ts+                _ -> [t])++        ioT :: IsValue a => IO a -> a -> (a, Type)+        ioT _ a = (a, typeOf a)++    apply io [] = Just (do+        var <- fmap toVariant io+        case fromVariant var of+            Just struct -> return (structureItems struct)+            Nothing -> return [var])+    apply _ _ = Nothing++instance (IsValue a, AutoMethod fn) => AutoMethod (a -> fn) where+    funTypes fn = cased where+        cased = case valueT undefined of+            (a, t) -> case funTypes (fn a) of+                (ts, ts') -> (t : ts, ts')++        valueT :: IsValue a => a -> (a, Type)+        valueT a = (a, typeOf a)++    apply _ [] = Nothing+    apply fn (v:vs) = case fromVariant v of+        Just v' -> apply (fn v') vs+        Nothing -> Nothing++-- | Prepare a Haskell function for export, automatically detecting the+-- function's type signature.+--+-- See 'AutoMethod' for details on the limitations of this function.+--+-- See 'method' for exporting functions with user-defined types.+autoMethod :: (AutoMethod fn) => InterfaceName -> MemberName -> fn -> Method+autoMethod iface name fun = DBus.Client.method iface name inSig outSig io where+    (typesIn, typesOut) = funTypes fun+    inSig = case signature typesIn of+        Just sig -> sig+        Nothing -> invalid "input"+    outSig = case signature typesOut of+        Just sig -> sig+        Nothing -> invalid "output"+    io msg = case apply fun (methodCallBody msg) of+        Nothing -> return (ReplyError errorInvalidParameters [])+        Just io' -> fmap ReplyReturn io'++    invalid label = error (concat+        [ "Method "+        , formatInterfaceName iface+        , "."+        , formatMemberName name+        , " has an invalid "+        , label+        , " signature."])  errorFailed :: ErrorName errorFailed = errorName_ "org.freedesktop.DBus.Error.Failed"

@@ -0,0 +1,178 @@+-- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>+--+-- 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 <http://www.gnu.org/licenses/>.++module DBus.Internal.Address where++import qualified Control.Exception+import           Data.Char (digitToInt, ord, chr)+import           Data.List (intercalate)+import qualified Data.Map+import           Data.Map (Map)+import qualified System.Environment+import           Text.Printf (printf)++import           Text.ParserCombinators.Parsec++-- | When a D-Bus server must listen for connections, or a client must connect+-- to a server, the listening socket's configuration is specified with an+-- /address/. An address contains the /method/, which determines the+-- protocol and transport mechanism, and /parameters/, which provide+-- additional method-specific information about the address.+data Address = Address String (Map String String)+    deriving (Eq)++addressMethod :: Address -> String+addressMethod (Address x _ ) = x++addressParameters :: Address -> Map String String+addressParameters (Address _ x) = x++-- | Try to convert a method string and parameter map to an 'Address'.+--+-- Returns 'Nothing' if the method or parameters are invalid.+address :: String -> Map String String -> Maybe Address+address method params = if validMethod method && validParams params+    then if null method && Data.Map.null params+        then Nothing+        else Just (Address method params)+    else Nothing++validMethod :: String -> Bool+validMethod = all validChar where+    validChar c = c /= ';' && c /= ':'++validParams :: Map String String -> Bool+validParams = all validItem . Data.Map.toList where+    validItem (k, v) = notNull k && notNull v && validKey k+    validKey = all validChar+    validChar c = c /= ';' && c /= ',' && c /= '='+    notNull = not . null++optionallyEncoded :: [Char]+optionallyEncoded = concat+    [ ['0'..'9']+    , ['a'..'z']+    , ['A'..'Z']+    , ['-', '_', '/', '\\', '*', '.']+    ]++-- | Convert an address to a string in the format expected by 'parseAddress'.+formatAddress :: Address -> String+formatAddress (Address method params) = concat [method, ":", csvParams] where+    csvParams = intercalate "," $ do+        (k, v) <- Data.Map.toList params+        let v' = concatMap escape v+        return (concat [k, "=", v'])++    escape c = if elem c optionallyEncoded+        then [c]+        else printf "%%%02X" (ord c)++-- | Convert a list of addresses to a string in the format expected by+-- 'parseAddresses'.+formatAddresses :: [Address] -> String+formatAddresses = intercalate ";" . map formatAddress++instance Show Address where+    showsPrec d x = showParen (d > 10) $+        showString "Address " .+        shows (formatAddress x)++-- | Try to parse a string containing one valid address.+--+-- An address string is in the format @method:key1=val1,key2=val2@. There+-- are some limitations on the characters allowed within methods and+-- parameters; see the D-Bus specification for full details.+parseAddress :: String -> Maybe Address+parseAddress = maybeParseString $ do+    addr <- parsecAddress+    eof+    return addr++-- | Try to parse a string containing one or more valid addresses.+--+-- Addresses are separated by semicolons. See 'parseAddress' for the format+-- of addresses.+parseAddresses :: String -> Maybe [Address]+parseAddresses = maybeParseString $ do+    addrs <- sepEndBy parsecAddress (char ';')+    eof+    return addrs++parsecAddress :: Parser Address+parsecAddress = p where+    p = do+        method <- many (noneOf ":;")+        _ <- char ':'+        params <- sepEndBy param (char ',')+        return (Address method (Data.Map.fromList params))++    param = do+        key <- many1 (noneOf "=;,")+        _ <- char '='+        value <- many1 valueChar+        return (key, value)++    valueChar = encoded <|> unencoded+    encoded = do+        _ <- char '%'+        hex <- count 2 hexDigit+        return (chr (hexToInt hex))+    unencoded = oneOf optionallyEncoded++-- | Returns the address in the environment variable+-- @DBUS_SYSTEM_BUS_ADDRESS@, or+-- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@+-- is not set.+--+-- Returns 'Nothing' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid address.+getSystemAddress :: IO (Maybe Address)+getSystemAddress = do+    let system = "unix:path=/var/run/dbus/system_bus_socket"+    env <- getenv "DBUS_SYSTEM_BUS_ADDRESS"+    return (parseAddress (maybe system id env))++-- | Returns the address in the environment variable+-- @DBUS_SESSION_BUS_ADDRESS@, which must be set.+--+-- Returns 'Nothing' if @DBUS_SYSTEM_BUS_ADDRESS@ is unset or contains an+-- invalid address.+getSessionAddress :: IO (Maybe Address)+getSessionAddress = do+    env <- getenv "DBUS_SESSION_BUS_ADDRESS"+    return (env >>= parseAddress)++-- | Returns the address in the environment variable+-- @DBUS_STARTER_ADDRESS@, which must be set.+--+-- Returns 'Nothing' if @DBUS_STARTER_ADDRESS@ is unset or contains an+-- invalid address.+getStarterAddress :: IO (Maybe Address)+getStarterAddress = do+    env <- getenv "DBUS_STARTER_ADDRESS"+    return (env >>= parseAddress)++getenv :: String -> IO (Maybe String)+getenv name = Control.Exception.catch+    (fmap Just (System.Environment.getEnv name))+    (\(Control.Exception.SomeException _) -> return Nothing)++hexToInt :: String -> Int+hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt++maybeParseString :: Parser a -> String -> Maybe a+maybeParseString p str = case runParser p () "" str of+    Left _ -> Nothing+    Right a -> Just a

@@ -0,0 +1,314 @@+-- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>+--+-- 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 <http://www.gnu.org/licenses/>.++module DBus.Internal.Message+    ( Message(..)++    , UnknownMessage(..)+    , MethodCall(..)+    , MethodReturn(..)+    , MethodError(..)+    , methodErrorMessage+    , Signal(..)+    , ReceivedMessage(..)++    -- for use in Wire+    , HeaderField(..)+    , setMethodCallFlags+    ) where++import           Data.Bits ((.|.), (.&.))+import           Data.Maybe (fromMaybe, listToMaybe)+import           Data.Word (Word8, Word32)++import           DBus.Internal.Types++class Message a where+    messageTypeCode :: a -> Word8+    messageHeaderFields :: a -> [HeaderField]+    messageBody :: a -> [Variant]++    messageFlags :: a -> Word8+    messageFlags _ = 0++maybe' :: (a -> b) -> Maybe a -> [b]+maybe' f = maybe [] (\x' -> [f x'])++data UnknownMessage = UnknownMessage+    { unknownMessageType :: Word8+    , unknownMessageSender :: Maybe BusName+    , unknownMessageBody :: [Variant]+    }+    deriving (Show, Eq)++data HeaderField+    = HeaderPath        ObjectPath+    | HeaderInterface   InterfaceName+    | HeaderMember      MemberName+    | HeaderErrorName   ErrorName+    | HeaderReplySerial Serial+    | HeaderDestination BusName+    | HeaderSender      BusName+    | HeaderSignature   Signature+    | HeaderUnixFds     Word32+    deriving (Show, Eq)++-- | A method call is a request to run some procedure exported by the+-- remote process. Procedures are identified by an (object_path,+-- interface_name, method_name) tuple.+data MethodCall = MethodCall+    {+    -- | The object path of the method call. Conceptually, object paths+    -- act like a procedural language's pointers. Each object referenced+    -- by a path is a collection of procedures.+      methodCallPath :: ObjectPath++    -- | The interface of the method call. Each object may implement any+    -- number of interfaces. Each method is part of at least one+    -- interface.+    --+    -- In certain cases, this may be @Nothing@, but most users should set+    -- it to a value.+    , methodCallInterface :: Maybe InterfaceName++    -- | The method name of the method call. Method names are unique within+    -- an interface, but might not be unique within an object.+    , methodCallMember :: MemberName++    -- | The name of the application that sent this call.+    --+    -- Most users will just leave this empty, because the bus overwrites+    -- the sender for security reasons. Setting the sender manually is+    -- used for peer-peer connections.+    --+    -- Defaults to @Nothing@.+    , methodCallSender :: Maybe BusName++    -- | The name of the application to send the call to.+    --+    -- Most users should set this. If a message with no destination is+    -- sent to the bus, the bus will behave as if the destination was+    -- set to @org.freedesktop.DBus@. For peer-peer connections, the+    -- destination can be empty because there is only one peer.+    --+    -- Defaults to @Nothing@.+    , methodCallDestination :: Maybe BusName++    -- | Set whether a reply is expected. This can save network and cpu+    -- resources by inhibiting unnecessary replies.+    --+    -- Defaults to @True@.+    , methodCallReplyExpected :: Bool++    -- | Set whether the bus should auto-start the remote+    --+    -- Defaults to @True@.+    , methodCallAutoStart :: Bool++    -- | The arguments to the method call. See 'toVariant'.+    --+    -- Defaults to @[]@.+    , methodCallBody :: [Variant]+    }+    deriving (Eq, Show)++setMethodCallFlags :: MethodCall -> Word8 -> MethodCall+setMethodCallFlags c w = c+    { methodCallReplyExpected = w .&. 0x1 == 0+    , methodCallAutoStart = w .&. 0x2 == 0+    }++instance Message MethodCall where+    messageTypeCode _ = 1+    messageFlags c = foldr (.|.) 0+        [ if methodCallReplyExpected c then 0 else 0x1+        , if methodCallAutoStart c then 0 else 0x2+        ]+    messageBody = methodCallBody+    messageHeaderFields m = concat+        [ [ HeaderPath (methodCallPath m)+          , HeaderMember (methodCallMember m)+          ]+        , maybe' HeaderInterface (methodCallInterface m)+        , maybe' HeaderSender (methodCallSender m)+        , maybe' HeaderDestination (methodCallDestination m)+        ]++-- | A method return is a reply to a method call, indicating that the call+-- succeeded.+data MethodReturn = MethodReturn+    {+    -- | The serial of the original method call. This lets the original+    -- caller match up this reply to the pending call.+      methodReturnSerial :: Serial++    -- | The name of the application that is returning from a call.+    --+    -- Most users will just leave this empty, because the bus overwrites+    -- the sender for security reasons. Setting the sender manually is+    -- used for peer-peer connections.+    --+    -- Defaults to @Nothing@.+    , methodReturnSender :: Maybe BusName++    -- | The name of the application that initiated the call.+    --+    -- Most users should set this. If a message with no destination is+    -- sent to the bus, the bus will behave as if the destination was+    -- set to @org.freedesktop.DBus@. For peer-peer connections, the+    -- destination can be empty because there is only one peer.+    --+    -- Defaults to @Nothing@.+    , methodReturnDestination :: Maybe BusName++    -- | Values returned from the method call. See 'toVariant'.+    --+    -- Defaults to @[]@.+    , methodReturnBody :: [Variant]+    }+    deriving (Show, Eq)++instance Message MethodReturn where+    messageTypeCode _ = 2+    messageBody       = methodReturnBody+    messageHeaderFields m = concat+        [ [ HeaderReplySerial (methodReturnSerial m)+          ]+        , maybe' HeaderSender (methodReturnSender m)+        , maybe' HeaderDestination (methodReturnDestination m)+        ]++-- | A method error is a reply to a method call, indicating that the call+-- received an error and did not succeed.+data MethodError = MethodError+    {+    -- | The name of the error type. Names are used so clients can+    -- handle certain classes of error differently from others.+      methodErrorName :: ErrorName++    -- | The serial of the original method call. This lets the original+    -- caller match up this reply to the pending call.+    , methodErrorSerial :: Serial++    -- | The name of the application that is returning from a call.+    --+    -- Most users will just leave this empty, because the bus overwrites+    -- the sender for security reasons. Setting the sender manually is+    -- used for peer-peer connections.+    --+    -- Defaults to @Nothing@.+    , methodErrorSender :: Maybe BusName++    -- | The name of the application that initiated the call.+    --+    -- Most users should set this. If a message with no destination is+    -- sent to the bus, the bus will behave as if the destination was+    -- set to @org.freedesktop.DBus@. For peer-peer connections, the+    -- destination can be empty because there is only one peer.+    --+    -- Defaults to @Nothing@.+    , methodErrorDestination :: Maybe BusName++    -- | Additional information about the error. By convention, if+    -- the error body contains any items, the first item should be a+    -- string describing the error.+    , methodErrorBody :: [Variant]+    }+    deriving (Show, Eq)++instance Message MethodError where+    messageTypeCode _ = 3+    messageBody       = methodErrorBody+    messageHeaderFields m = concat+        [ [ HeaderErrorName (methodErrorName m)+          , HeaderReplySerial (methodErrorSerial m)+          ]+        , maybe' HeaderSender (methodErrorSender m)+        , maybe' HeaderDestination (methodErrorDestination m)+        ]++-- | Get a human-readable description of the error, by returning the first+-- item in the error body if it's a string.+methodErrorMessage :: MethodError -> String+methodErrorMessage err = fromMaybe "(no error message)" $ do+    field <- listToMaybe (methodErrorBody err)+    msg <- fromVariant field+    if null msg+        then Nothing+        else return msg++-- | Signals are broadcast by applications to notify other clients of some+-- event.+data Signal = Signal+    {+    -- | The path of the object that emitted this signal.+      signalPath :: ObjectPath++    -- | The interface that this signal belongs to.+    , signalInterface :: InterfaceName++    -- | The name of this signal.+    , signalMember :: MemberName++    -- | The name of the application that emitted this signal.+    --+    -- Most users will just leave this empty, because the bus overwrites+    -- the sender for security reasons. Setting the sender manually is+    -- used for peer-peer connections.+    --+    -- Defaults to @Nothing@.+    , signalSender :: Maybe BusName++    -- | The name of the application to emit the signal to. If @Nothing@,+    -- the signal is sent to any application that has registered an+    -- appropriate match rule.+    --+    -- Defaults to @Nothing@.+    , signalDestination :: Maybe BusName++    -- | Additional information about the signal, such as the new value+    -- or the time.+    --+    -- Defaults to @[]@.+    , signalBody :: [Variant]+    }+    deriving (Show, Eq)++instance Message Signal where+    messageTypeCode _ = 4+    messageBody       = signalBody+    messageHeaderFields m = concat+        [ [ HeaderPath (signalPath m)+          , HeaderMember (signalMember m)+          , HeaderInterface (signalInterface m)+          ]+        , maybe' HeaderSender (signalSender m)+        , maybe' HeaderDestination (signalDestination m)+        ]++-- | Not an actual message type, but a wrapper around messages received from+-- the bus. Each value contains the message's 'Serial'.+--+-- If casing against these constructors, always include a default case to+-- handle messages of an unknown type. New message types may be added to the+-- D-Bus specification, and applications should handle them gracefully by+-- either ignoring or logging them.+data ReceivedMessage+    = ReceivedMethodCall Serial MethodCall+    | ReceivedMethodReturn Serial MethodReturn+    | ReceivedMethodError Serial MethodError+    | ReceivedSignal Serial Signal+    | ReceivedUnknown Serial UnknownMessage+    deriving (Show, Eq)

@@ -0,0 +1,1341 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}++-- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>+--+-- 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 <http://www.gnu.org/licenses/>.++module DBus.Internal.Types where++import           Control.Monad (liftM, when, (>=>))+import           Control.Exception (Exception, handle, throwIO)+import           Data.ByteString (ByteString)+import qualified Data.ByteString+import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString.Lazy+import qualified Data.ByteString.Unsafe+import           Data.Char (ord)+import           Data.Int+import           Data.List (intercalate)+import qualified Data.Map+import           Data.Map (Map)+import qualified Data.String+import qualified Data.Text+import           Data.Text (Text)+import qualified Data.Text.Lazy+import           Data.Typeable (Typeable)+import qualified Data.Vector+import           Data.Vector (Vector)+import           Data.Word+import qualified Foreign+import           System.IO.Unsafe (unsafePerformIO)+import           System.Posix.Types (Fd)++import qualified Text.ParserCombinators.Parsec as Parsec+import           Text.ParserCombinators.Parsec ((<|>), oneOf)++data Type+    = TypeBoolean+    | TypeWord8+    | TypeWord16+    | TypeWord32+    | TypeWord64+    | TypeInt16+    | TypeInt32+    | TypeInt64+    | TypeDouble+    | TypeUnixFd+    | TypeString+    | TypeSignature+    | TypeObjectPath+    | TypeVariant+    | TypeArray Type+    | TypeDictionary Type Type+    | TypeStructure [Type]+    deriving (Eq, Ord)++instance Show Type where+    showsPrec d = showString . showType (d > 10)++showType :: Bool -> Type -> String+showType paren t = case t of+    TypeBoolean -> "Bool"+    TypeWord8 -> "Word8"+    TypeWord16 -> "Word16"+    TypeWord32 -> "Word32"+    TypeWord64 -> "Word64"+    TypeInt16 -> "Int16"+    TypeInt32 -> "Int32"+    TypeInt64 -> "Int64"+    TypeDouble -> "Double"+    TypeUnixFd -> "UnixFd"+    TypeString -> "String"+    TypeSignature -> "Signature"+    TypeObjectPath -> "ObjectPath"+    TypeVariant -> "Variant"+    TypeArray t' -> concat ["[", show t', "]"]+    TypeDictionary kt vt -> showParen paren (+                            showString "Dict " .+                            shows kt .+                            showString " " .+                            showsPrec 11 vt) ""+    TypeStructure ts -> concat+        ["(", intercalate ", " (map show ts), ")"]++-- | A signature is a list of D-Bus types, obeying some basic rules of+-- validity.+--+-- The rules of signature validity are complex: see+-- <http://dbus.freedesktop.org/doc/dbus-specification.html#message-protocol-signatures>+-- for details.+newtype Signature = Signature [Type]+    deriving (Eq, Ord)++-- | Get the list of types in a signature. The inverse of 'signature'.+signatureTypes :: Signature -> [Type]+signatureTypes (Signature types) = types++instance Show Signature where+    showsPrec d sig = showParen (d > 10) $+        showString "Signature " .+        shows (formatSignature sig)++-- | Convert a signature into a signature string. The inverse of+-- 'parseSignature'.+formatSignature :: Signature -> String+formatSignature = concatMap typeCode . signatureTypes++typeCode :: Type -> String+typeCode TypeBoolean    = "b"+typeCode TypeWord8      = "y"+typeCode TypeWord16     = "q"+typeCode TypeWord32     = "u"+typeCode TypeWord64     = "t"+typeCode TypeInt16      = "n"+typeCode TypeInt32      = "i"+typeCode TypeInt64      = "x"+typeCode TypeDouble     = "d"+typeCode TypeUnixFd     = "h"+typeCode TypeString     = "s"+typeCode TypeSignature  = "g"+typeCode TypeObjectPath = "o"+typeCode TypeVariant    = "v"+typeCode (TypeArray t)  = 'a' : typeCode t+typeCode (TypeDictionary kt vt) = concat+    [ "a{", typeCode kt , typeCode vt, "}"]++typeCode (TypeStructure ts) = concat+    ["(", concatMap typeCode ts, ")"]++instance Data.String.IsString Signature where+    fromString = forceParse "signature" parseSignature++-- | Convert a list of types into a valid signature.+--+-- Returns @Nothing@ if the given types are not a valid signature.+signature :: [Type] -> Maybe Signature+signature = check where+    check ts = if sumLen ts > 255+        then Nothing+        else Just (Signature ts)+    sumLen :: [Type] -> Int+    sumLen = sum . map len++    len (TypeArray t) = 1 + len t+    len (TypeDictionary kt vt)+        | typeIsAtomic kt = 3 + len kt + len vt+        | otherwise = 256+    len (TypeStructure []) = 256+    len (TypeStructure ts) = 2 + sumLen ts+    len _ = 1++    typeIsAtomic TypeVariant = False+    typeIsAtomic TypeArray{} = False+    typeIsAtomic TypeDictionary{} = False+    typeIsAtomic TypeStructure{} = False+    typeIsAtomic _ = True++-- | Convert a list of types into a valid signature.+--+-- Throws an exception if the given types are not a valid signature.+signature_ :: [Type] -> Signature+signature_ ts = case signature ts of+    Just sig -> sig+    Nothing -> error ("invalid signature: " ++ show ts)++-- | Parse a signature string into a valid signature.+--+-- Returns @Nothing@ if the given string is not a valid signature.+parseSignature :: String -> Maybe Signature+parseSignature s = do+    when (length s > 255) Nothing+    when (any (\c -> ord c > 0x7F) s) Nothing+    parseSignatureBytes (Char8.pack s)++parseSignatureBytes :: ByteString -> Maybe Signature+parseSignatureBytes bytes =+    case Data.ByteString.length bytes of+        0 -> Just (Signature [])+        1 -> parseSigFast bytes+        len | len <= 255 -> parseSigFull bytes+        _ -> Nothing++parseSigFast :: ByteString -> Maybe Signature+parseSigFast bytes =+    let byte = Data.ByteString.Unsafe.unsafeHead bytes in+    parseAtom (fromIntegral byte)+        (\t -> Just (Signature [t]))+        (case byte of+            0x76 -> Just (Signature [TypeVariant])+            _ -> Nothing)++parseAtom :: Int -> (Type -> a) -> a -> a+parseAtom byte yes no = case byte of+    0x62 -> yes TypeBoolean+    0x6E -> yes TypeInt16+    0x69 -> yes TypeInt32+    0x78 -> yes TypeInt64+    0x79 -> yes TypeWord8+    0x71 -> yes TypeWord16+    0x75 -> yes TypeWord32+    0x74 -> yes TypeWord64+    0x64 -> yes TypeDouble+    0x68 -> yes TypeUnixFd+    0x73 -> yes TypeString+    0x67 -> yes TypeSignature+    0x6F -> yes TypeObjectPath+    _ -> no+{-# INLINE parseAtom #-}++data SigParseError = SigParseError+    deriving (Show, Typeable)++instance Exception SigParseError++peekWord8AsInt :: Foreign.Ptr Word8 -> Int -> IO Int+peekWord8AsInt ptr off = do+    w <- Foreign.peekElemOff ptr off+    return (fromIntegral w)++parseSigFull :: ByteString -> Maybe Signature+parseSigFull bytes = unsafePerformIO io where+    io = handle+        (\SigParseError -> return Nothing)+        $ Data.ByteString.Unsafe.unsafeUseAsCStringLen bytes+        $ \(ptr, len) -> do+            ts <- parseSigBuf (Foreign.castPtr ptr, len)+            return (Just (Signature ts))++    parseSigBuf (buf, len) = mainLoop [] 0 where++        mainLoop acc ii | ii >= len = return (reverse acc)+        mainLoop acc ii = do+            c <- peekWord8AsInt buf ii+            let next t = mainLoop (t : acc) (ii + 1)+            parseAtom c next $ case c of+                0x76 -> next TypeVariant+                0x28 -> do -- '('+                    (ii', t) <- structure (ii + 1)+                    mainLoop (t : acc) ii'+                0x61 -> do -- 'a'+                    (ii', t) <- array (ii + 1)+                    mainLoop (t : acc) ii'+                _ -> throwIO SigParseError++        structure :: Int -> IO (Int, Type)+        structure = loop [] where+            loop _ ii | ii >= len = throwIO SigParseError+            loop acc ii = do+                c <- peekWord8AsInt buf ii+                let next t = loop (t : acc) (ii + 1)+                parseAtom c next $ case c of+                    0x76 -> next TypeVariant+                    0x28 -> do -- '('+                        (ii', t) <- structure (ii + 1)+                        loop (t : acc) ii'+                    0x61 -> do -- 'a'+                        (ii', t) <- array (ii + 1)+                        loop (t : acc) ii'+                    -- ')'+                    0x29 -> case acc of+                        [] -> throwIO SigParseError+                        _ -> return (ii + 1, TypeStructure (reverse acc))+                    _ -> throwIO SigParseError++        array :: Int -> IO (Int, Type)+        array ii | ii >= len = throwIO SigParseError+        array ii = do+            c <- peekWord8AsInt buf ii+            let next t = return (ii + 1, TypeArray t)+            parseAtom c next $ case c of+                0x76 -> next TypeVariant+                0x7B -> dict (ii + 1) -- '{'+                0x28 -> do -- '('+                    (ii', t) <- structure (ii + 1)+                    return (ii', TypeArray t)+                0x61 -> do -- 'a'+                    (ii', t) <- array (ii + 1)+                    return (ii', TypeArray t)+                _ -> throwIO SigParseError++        dict :: Int -> IO (Int, Type)+        dict ii | ii + 1 >= len = throwIO SigParseError+        dict ii = do+            c1 <- peekWord8AsInt buf ii+            c2 <- peekWord8AsInt buf (ii + 1)++            let next t = return (ii + 2, t)+            (ii', t2) <- parseAtom c2 next $ case c2 of+                0x76 -> next TypeVariant+                0x28 -> structure (ii + 2) -- '('+                0x61 -> array (ii + 2) -- 'a'+                _ -> throwIO SigParseError++            if ii' >= len+                then throwIO SigParseError+                else do+                    c3 <- peekWord8AsInt buf ii'+                    if c3 == 0x7D+                        then do+                            t1 <- parseAtom c1 return (throwIO SigParseError)+                            return (ii' + 1, TypeDictionary t1 t2)+                        else throwIO SigParseError++class IsVariant a where+    toVariant :: a -> Variant+    fromVariant :: Variant -> Maybe a++-- | Value types can be used as items in containers, such as lists or+-- dictionaries.+--+-- Users may not provide new instances of 'IsValue' because this could allow+-- containers to be created with items of heterogenous types.+class IsVariant a => IsValue a where+    typeOf :: a -> Type+    toValue :: a -> Value+    fromValue :: Value -> Maybe a++-- | Atomic types can be used as keys to dictionaries.+--+-- Users may not provide new instances of 'IsAtom' because this could allow+-- dictionaries to be created with invalid keys.+class IsValue a => IsAtom a where+    toAtom :: a -> Atom+    fromAtom :: Atom -> Maybe a++-- | Variants may contain any other built-in D-Bus value. Besides+-- representing native @VARIANT@ values, they allow type-safe storage and+-- inspection of D-Bus collections.+newtype Variant = Variant Value+    deriving (Eq)++data Value+    = ValueAtom Atom+    | ValueVariant Variant+    | ValueBytes ByteString+    | ValueVector Type (Vector Value)+    | ValueMap Type Type (Map Atom Value)+    | ValueStructure [Value]+    deriving (Show)++data Atom+    = AtomBool Bool+    | AtomWord8 Word8+    | AtomWord16 Word16+    | AtomWord32 Word32+    | AtomWord64 Word64+    | AtomInt16 Int16+    | AtomInt32 Int32+    | AtomInt64 Int64+    | AtomDouble Double+    | AtomUnixFd Fd+    | AtomText Text+    | AtomSignature Signature+    | AtomObjectPath ObjectPath+    deriving (Show, Eq, Ord)++instance Eq Value where+    (==) (ValueBytes x) y = case y of+        ValueBytes y' -> x == y'+        ValueVector TypeWord8 y' -> x == vectorToBytes y'+        _ -> False++    (==) (ValueVector TypeWord8 x) y = case y of+        ValueBytes y' -> vectorToBytes x == y'+        ValueVector TypeWord8 y' -> x == y'+        _ -> False++    (==) (ValueAtom x) (ValueAtom y) = x == y+    (==) (ValueVariant x) (ValueVariant y) = x == y+    (==) (ValueVector tx x) (ValueVector ty y) = tx == ty && x == y+    (==) (ValueMap ktx vtx x) (ValueMap kty vty y) = ktx == kty && vtx == vty && x == y+    (==) (ValueStructure x) (ValueStructure y) = x == y+    (==) _ _ = False++showAtom :: Bool -> Atom -> String+showAtom _ (AtomBool x) = show x+showAtom _ (AtomWord8 x) = show x+showAtom _ (AtomWord16 x) = show x+showAtom _ (AtomWord32 x) = show x+showAtom _ (AtomWord64 x) = show x+showAtom _ (AtomInt16 x) = show x+showAtom _ (AtomInt32 x) = show x+showAtom _ (AtomInt64 x) = show x+showAtom _ (AtomDouble x) = show x+showAtom p (AtomUnixFd x) = showParen p (showString "UnixFd " . shows x) ""+showAtom _ (AtomText x) = show x+showAtom p (AtomSignature x) = showsPrec (if p then 11 else 0) x ""+showAtom p (AtomObjectPath x) = showsPrec (if p then 11 else 0) x ""++showValue :: Bool -> Value -> String+showValue p (ValueAtom x) = showAtom p x+showValue p (ValueVariant x) = showsPrec (if p then 11 else 0) x ""+showValue _ (ValueBytes xs) = 'b' : show xs+showValue _ (ValueVector TypeWord8 xs) = 'b' : show (vectorToBytes xs)+showValue _ (ValueVector _ xs) = showThings "[" (showValue False) "]" (Data.Vector.toList xs)+showValue _ (ValueMap _ _ xs) = showThings "{" showPair "}" (Data.Map.toList xs) where+    showPair (k, v) = showAtom False k ++ ": " ++ showValue False v+showValue _ (ValueStructure xs) = showThings "(" (showValue False) ")" xs++showThings :: String -> (a -> String) -> String -> [a] -> String+showThings a s z xs = a ++ intercalate ", " (map s xs) ++ z++vectorToBytes :: Vector Value -> ByteString+vectorToBytes = Data.ByteString.pack+              . Data.Vector.toList+              . Data.Vector.map (\(ValueAtom (AtomWord8 x)) -> x)++instance Show Variant where+    showsPrec d (Variant x) = showParen (d > 10) $+        showString "Variant " .  showString (showValue True 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 (Variant val) = valueType val++valueType :: Value -> Type+valueType (ValueAtom x) = atomType x+valueType (ValueVariant _) = TypeVariant+valueType (ValueVector t _) = TypeArray t+valueType (ValueBytes _) = TypeArray TypeWord8+valueType (ValueMap kt vt _) = TypeDictionary kt vt+valueType (ValueStructure vs) = TypeStructure (map valueType vs)++atomType :: Atom -> Type+atomType (AtomBool _) = TypeBoolean+atomType (AtomWord8 _) = TypeWord8+atomType (AtomWord16 _) = TypeWord16+atomType (AtomWord32 _) = TypeWord32+atomType (AtomWord64 _) = TypeWord64+atomType (AtomInt16 _) = TypeInt16+atomType (AtomInt32 _) = TypeInt32+atomType (AtomInt64 _) = TypeInt64+atomType (AtomDouble _) = TypeDouble+atomType (AtomUnixFd _) = TypeUnixFd+atomType (AtomText _) = TypeString+atomType (AtomSignature _) = TypeSignature+atomType (AtomObjectPath _) = TypeObjectPath++#define IS_ATOM(HsType, AtomCons, TypeCons) \+    instance IsAtom HsType where \+    { toAtom = AtomCons \+    ; fromAtom (AtomCons x) = Just x \+    ; fromAtom _ = Nothing \+    }; \+    instance IsValue HsType where \+    { typeOf _ = TypeCons \+    ; toValue = ValueAtom . toAtom \+    ; fromValue (ValueAtom x) = fromAtom x \+    ; fromValue _ = Nothing \+    }; \+    instance IsVariant HsType where \+    { toVariant = Variant . toValue \+    ; fromVariant (Variant val) = fromValue val \+    }++IS_ATOM(Bool,       AtomBool,       TypeBoolean)+IS_ATOM(Word8,      AtomWord8,      TypeWord8)+IS_ATOM(Word16,     AtomWord16,     TypeWord16)+IS_ATOM(Word32,     AtomWord32,     TypeWord32)+IS_ATOM(Word64,     AtomWord64,     TypeWord64)+IS_ATOM(Int16,      AtomInt16,      TypeInt16)+IS_ATOM(Int32,      AtomInt32,      TypeInt32)+IS_ATOM(Int64,      AtomInt64,      TypeInt64)+IS_ATOM(Double,     AtomDouble,     TypeDouble)+IS_ATOM(Fd,         AtomUnixFd,     TypeUnixFd)+IS_ATOM(Text,       AtomText,       TypeString)+IS_ATOM(Signature,  AtomSignature,  TypeSignature)+IS_ATOM(ObjectPath, AtomObjectPath, TypeObjectPath)++instance IsValue Variant where+    typeOf _ = TypeVariant+    toValue = ValueVariant+    fromValue (ValueVariant x) = Just x+    fromValue _ = Nothing++instance IsVariant Variant where+    toVariant = Variant . toValue+    fromVariant (Variant val) = fromValue val++instance IsAtom Data.Text.Lazy.Text where+    toAtom = toAtom . Data.Text.Lazy.toStrict+    fromAtom = fmap Data.Text.Lazy.fromStrict . fromAtom++instance IsValue Data.Text.Lazy.Text where+    typeOf _ = TypeString+    toValue = ValueAtom . toAtom+    fromValue (ValueAtom x) = fromAtom x+    fromValue _ = Nothing++instance IsVariant Data.Text.Lazy.Text where+    toVariant = Variant . toValue+    fromVariant (Variant val) = fromValue val++instance IsAtom String where+    toAtom = toAtom . Data.Text.pack+    fromAtom = fmap Data.Text.unpack . fromAtom++instance IsValue String where+    typeOf _ = TypeString+    toValue = ValueAtom . toAtom+    fromValue (ValueAtom x) = fromAtom x+    fromValue _ = Nothing++instance IsVariant String where+    toVariant = Variant . toValue+    fromVariant (Variant val) = fromValue val++instance IsValue a => IsValue (Vector a) where+    typeOf v = TypeArray (vectorItemType v)+    toValue v = ValueVector (vectorItemType v) (Data.Vector.map toValue v)+    fromValue (ValueVector _ v) = Data.Vector.mapM fromValue v+    fromValue _ = Nothing++vectorItemType :: IsValue a => Vector a -> Type+vectorItemType v = typeOf (undefined `asTypeOf` Data.Vector.head v)++instance IsValue a => IsVariant (Vector a) where+    toVariant = Variant . toValue+    fromVariant (Variant val) = fromValue val++instance IsValue a => IsValue [a] where+    typeOf v = TypeArray (typeOf (undefined `asTypeOf` head v))+    toValue = toValue . Data.Vector.fromList+    fromValue = fmap Data.Vector.toList . fromValue++instance IsValue a => IsVariant [a] where+    toVariant = toVariant . Data.Vector.fromList+    fromVariant = fmap Data.Vector.toList . fromVariant++instance IsValue ByteString where+    typeOf _ = TypeArray TypeWord8+    toValue = ValueBytes+    fromValue (ValueBytes bs) = Just bs+    fromValue (ValueVector TypeWord8 v) = Just (vectorToBytes v)+    fromValue _ = Nothing++instance IsVariant ByteString where+    toVariant = Variant . toValue+    fromVariant (Variant val) = fromValue val++instance IsValue Data.ByteString.Lazy.ByteString where+    typeOf _ = TypeArray TypeWord8+    toValue = toValue+            . Data.ByteString.concat+            . Data.ByteString.Lazy.toChunks+    fromValue = fmap (\bs -> Data.ByteString.Lazy.fromChunks [bs])+              . fromValue++instance IsVariant Data.ByteString.Lazy.ByteString where+    toVariant = Variant . toValue+    fromVariant (Variant val) = fromValue val++instance (Ord k, IsAtom k, IsValue v) => IsValue (Map k v) where+    typeOf m = TypeDictionary kt vt where+        (kt, vt) = mapItemType m++    toValue m = ValueMap kt vt (bimap box m) where+        (kt, vt) = mapItemType m+        box k v = (toAtom k, toValue v)++    fromValue (ValueMap _ _ m) = bimapM unbox m where+        unbox k v = do+            k' <- fromAtom k+            v' <- fromValue v+            return (k', v')+    fromValue _ = Nothing++bimap :: Ord k' => (k -> v -> (k', v')) -> Map k v -> Map k' v'+bimap f = Data.Map.fromList . map (\(k, v) -> f k v) . Data.Map.toList++bimapM :: (Monad m, Ord k') => (k -> v -> m (k', v')) -> Map k v -> m (Map k' v')+bimapM f = liftM Data.Map.fromList . mapM (\(k, v) -> f k v) . Data.Map.toList++mapItemType :: (IsValue k, IsValue v) => Map k v -> (Type, Type)+mapItemType m = (typeOf k, typeOf v) where+    mapItem :: Map k v -> (k, v)+    mapItem _ = (undefined, undefined)+    (k, v) = mapItem m++instance (Ord k, IsAtom k, IsValue v) => IsVariant (Map k v) where+    toVariant = Variant . toValue+    fromVariant (Variant val) = fromValue val++instance (IsValue a1, IsValue a2) => IsValue (a1, a2) where+    typeOf ~(a1, a2) = TypeStructure [typeOf a1, typeOf a2]+    toValue (a1, a2) = ValueStructure [toValue a1, toValue a2]+    fromValue (ValueStructure [a1, a2]) = do+        a1' <- fromValue a1+        a2' <- fromValue a2+        return (a1', a2')+    fromValue _ = Nothing++instance (IsVariant a1, IsVariant a2) => IsVariant (a1, a2) where+    toVariant (a1, a2) = Variant (ValueStructure [varToVal a1, varToVal a2])+    fromVariant (Variant (ValueStructure [a1, a2])) = do+        a1' <- (fromVariant . Variant) a1+        a2' <- (fromVariant . Variant) a2+        return (a1', a2')+    fromVariant _ = Nothing++varToVal :: IsVariant a => a -> Value+varToVal a = case toVariant a of+    Variant val -> val++-- | Object paths are special strings, used to identify a particular object+-- exported from a D-Bus application.+--+-- Object paths must begin with a slash, and consist of alphanumeric+-- characters separated by slashes.+--+-- See+-- <http://dbus.freedesktop.org/doc/dbus-specification.html#message-protocol-marshaling-object-path>+-- for details.+newtype ObjectPath = ObjectPath String+    deriving (Eq, Ord, Show)++formatObjectPath :: ObjectPath -> String+formatObjectPath (ObjectPath s) = s++parseObjectPath :: String -> Maybe ObjectPath+parseObjectPath s = do+    maybeParseString parserObjectPath s+    return (ObjectPath s)++objectPath_ :: String -> ObjectPath+objectPath_ = forceParse "object path" parseObjectPath++instance Data.String.IsString ObjectPath where+    fromString = objectPath_++parserObjectPath :: Parsec.Parser ()+parserObjectPath = root <|> object where+    root = Parsec.try $ do+        slash+        Parsec.eof++    object = do+        slash+        skipSepBy1 element slash+        Parsec.eof++    element = Parsec.skipMany1 (oneOf chars)++    slash = Parsec.char '/' >> return ()+    chars = concat [ ['a'..'z']+                   , ['A'..'Z']+                   , ['0'..'9']+                   , "_"]++-- | Interfaces are used to group a set of methods and signals within an+-- exported object. Interface names consist of alphanumeric characters+-- separated by periods.+--+-- See+-- <http://dbus.freedesktop.org/doc/dbus-specification.html#message-protocol-names-interface>+-- for details.+newtype InterfaceName = InterfaceName String+    deriving (Eq, Ord, Show)++formatInterfaceName :: InterfaceName -> String+formatInterfaceName (InterfaceName s) = s++parseInterfaceName :: String -> Maybe InterfaceName+parseInterfaceName s = do+    when (length s > 255) Nothing+    maybeParseString parserInterfaceName s+    return (InterfaceName s)++interfaceName_ :: String -> InterfaceName+interfaceName_ = forceParse "interface name" parseInterfaceName++instance Data.String.IsString InterfaceName where+    fromString = interfaceName_++instance IsVariant InterfaceName where+    toVariant = toVariant . formatInterfaceName+    fromVariant = fromVariant >=> parseInterfaceName++parserInterfaceName :: Parsec.Parser ()+parserInterfaceName = name >> Parsec.eof where+    alpha = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+    alphanum = alpha ++ ['0'..'9']+    element = do+        _ <- oneOf alpha+        Parsec.skipMany (oneOf alphanum)+    name = do+        element+        _ <- Parsec.char '.'+        skipSepBy1 element (Parsec.char '.')++-- | Member names are used to identify a single method or signal within an+-- interface. Method names consist of alphanumeric characters.+--+-- See+-- <http://dbus.freedesktop.org/doc/dbus-specification.html#message-protocol-names-member>+-- for details.+newtype MemberName = MemberName String+    deriving (Eq, Ord, Show)++formatMemberName :: MemberName -> String+formatMemberName (MemberName s) = s++parseMemberName :: String -> Maybe MemberName+parseMemberName s = do+    when (length s > 255) Nothing+    maybeParseString parserMemberName s+    return (MemberName s)++memberName_ :: String -> MemberName+memberName_ = forceParse "member name" parseMemberName++instance Data.String.IsString MemberName where+    fromString = memberName_++instance IsVariant MemberName where+    toVariant = toVariant . formatMemberName+    fromVariant = fromVariant >=> parseMemberName++parserMemberName :: Parsec.Parser ()+parserMemberName = name >> Parsec.eof where+    alpha = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+    alphanum = alpha ++ ['0'..'9']+    name = do+        _ <- oneOf alpha+        Parsec.skipMany (oneOf alphanum)++-- | Error names are used to identify which type of error was returned from+-- a method call. Error names consist of alphanumeric characters+-- separated by periods.+--+-- See+-- <http://dbus.freedesktop.org/doc/dbus-specification.html#message-protocol-names-error>+-- for details.+newtype ErrorName = ErrorName String+    deriving (Eq, Ord, Show)++formatErrorName :: ErrorName -> String+formatErrorName (ErrorName s) = s++parseErrorName :: String -> Maybe ErrorName+parseErrorName s = do+    when (length s > 255) Nothing+    maybeParseString parserInterfaceName s+    return (ErrorName s)++errorName_ :: String -> ErrorName+errorName_ = forceParse "error name" parseErrorName++instance Data.String.IsString ErrorName where+    fromString = errorName_++instance IsVariant ErrorName where+    toVariant = toVariant . formatErrorName+    fromVariant = fromVariant >=> parseErrorName++-- | Bus names are used to identify particular clients on the message bus.+-- A bus name may be either /unique/ or /well-known/, where unique names+-- start with a colon. Bus names consist of alphanumeric characters separated+-- by periods.+--+-- See+-- <http://dbus.freedesktop.org/doc/dbus-specification.html#message-protocol-names-bus>+-- for details.+newtype BusName = BusName String+    deriving (Eq, Ord, Show)++formatBusName :: BusName -> String+formatBusName (BusName s) = s++parseBusName :: String -> Maybe BusName+parseBusName s = do+    when (length s > 255) Nothing+    maybeParseString parserBusName s+    return (BusName s)++busName_ :: String -> BusName+busName_ = forceParse "bus name" parseBusName++instance Data.String.IsString BusName where+    fromString = busName_++instance IsVariant BusName where+    toVariant = toVariant . formatBusName+    fromVariant = fromVariant >=> parseBusName++parserBusName :: Parsec.Parser ()+parserBusName = name >> Parsec.eof where+    alpha = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"+    alphanum = alpha ++ ['0'..'9']++    name = unique <|> wellKnown+    unique = do+        _ <- Parsec.char ':'+        elements alphanum++    wellKnown = elements alpha++    elements :: [Char] -> Parsec.Parser ()+    elements start = do+        element start+        Parsec.skipMany1 $ do+            _ <- Parsec.char '.'+            element start++    element :: [Char] -> Parsec.Parser ()+    element start = do+        _ <- oneOf start+        Parsec.skipMany (oneOf alphanum)++-- | A D-Bus Structure is a container type similar to Haskell tuples, storing+-- values of any type that is convertable to 'IsVariant'. A Structure may+-- contain up to 255 values.+--+-- Most users can use the 'IsVariant' instance for tuples to extract the+-- values of a structure. This type is for very large structures, which may+-- be awkward to work with as tuples.+newtype Structure = Structure [Value]+    deriving (Eq)++instance Show Structure where+    show (Structure xs) = showValue True (ValueStructure xs)++instance IsVariant Structure where+    toVariant (Structure xs) = Variant (ValueStructure xs)+    fromVariant (Variant (ValueStructure xs)) = Just (Structure xs)+    fromVariant _ = Nothing++structureItems :: Structure -> [Variant]+structureItems (Structure xs) = map Variant xs++-- | A D-Bus Array is a container type similar to Haskell lists, storing+-- zero or more values of a single D-Bus type.+--+-- Most users can use the 'IsVariant' instance for lists or vectors to extract+-- the values of an array. This type is for advanced use cases, where the user+-- wants to convert array values to Haskell types that are not instances of+-- 'IsValue'.+data Array+    = Array Type (Vector Value)+    | ArrayBytes ByteString++instance Show Array where+    show (Array t xs) = showValue True (ValueVector t xs)+    show (ArrayBytes xs) = showValue True (ValueBytes xs)++instance Eq Array where+    x == y = norm x == norm y where+        norm (Array TypeWord8 xs) = Left (vectorToBytes xs)+        norm (Array t xs) = Right (t, xs)+        norm (ArrayBytes xs) = Left xs++instance IsVariant Array where+    toVariant (Array t xs) = Variant (ValueVector t xs)+    toVariant (ArrayBytes bs) = Variant (ValueBytes bs)+    fromVariant (Variant (ValueVector t xs)) = Just (Array t xs)+    fromVariant (Variant (ValueBytes bs)) = Just (ArrayBytes bs)+    fromVariant _ = Nothing++arrayItems :: Array -> [Variant]+arrayItems (Array _ xs) = map Variant (Data.Vector.toList xs)+arrayItems (ArrayBytes bs) = map toVariant (Data.ByteString.unpack bs)++-- | A D-Bus Dictionary is a container type similar to Haskell maps, storing+-- zero or more associations between keys and values.+--+-- Most users can use the 'IsVariant' instance for maps to extract the values+-- of a dictionary. This type is for advanced use cases, where the user+-- wants to convert dictionary items to Haskell types that are not instances+-- of 'IsValue'.+data Dictionary = Dictionary Type Type (Map Atom Value)+    deriving (Eq)++instance Show Dictionary where+    show (Dictionary kt vt xs) = showValue True (ValueMap kt vt xs)++instance IsVariant Dictionary where+    toVariant (Dictionary kt vt xs) = Variant (ValueMap kt vt xs)+    fromVariant (Variant (ValueMap kt vt xs)) = Just (Dictionary kt vt xs)+    fromVariant _ = Nothing++dictionaryItems :: Dictionary -> [(Variant, Variant)]+dictionaryItems (Dictionary _ _ xs) = do+    (k, v) <- Data.Map.toList xs+    return (Variant (ValueAtom k), Variant v)++instance (IsValue a1, IsValue a2, IsValue a3) => IsValue (a1, a2, a3) where+    typeOf ~(a1, a2, a3) = TypeStructure [typeOf a1, typeOf a2, typeOf a3]+    toValue (a1, a2, a3) = ValueStructure [toValue a1, toValue a2, toValue a3]+    fromValue (ValueStructure [a1, a2, a3]) = do+        a1' <- fromValue a1+        a2' <- fromValue a2+        a3' <- fromValue a3+        return (a1', a2', a3')+    fromValue _ = Nothing++instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4) => IsValue (a1, a2, a3, a4) where+    typeOf ~(a1, a2, a3, a4) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4]+    toValue (a1, a2, a3, a4) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4]+    fromValue (ValueStructure [a1, a2, a3, a4]) = do+        a1' <- fromValue a1+        a2' <- fromValue a2+        a3' <- fromValue a3+        a4' <- fromValue a4+        return (a1', a2', a3', a4')+    fromValue _ = Nothing++instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5) => IsValue (a1, a2, a3, a4, a5) where+    typeOf ~(a1, a2, a3, a4, a5) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5]+    toValue (a1, a2, a3, a4, a5) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5]+    fromValue (ValueStructure [a1, a2, a3, a4, a5]) = do+        a1' <- fromValue a1+        a2' <- fromValue a2+        a3' <- fromValue a3+        a4' <- fromValue a4+        a5' <- fromValue a5+        return (a1', a2', a3', a4', a5')+    fromValue _ = Nothing++instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6) => IsValue (a1, a2, a3, a4, a5, a6) where+    typeOf ~(a1, a2, a3, a4, a5, a6) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6]+    toValue (a1, a2, a3, a4, a5, a6) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6]+    fromValue (ValueStructure [a1, a2, a3, a4, a5, a6]) = do+        a1' <- fromValue a1+        a2' <- fromValue a2+        a3' <- fromValue a3+        a4' <- fromValue a4+        a5' <- fromValue a5+        a6' <- fromValue a6+        return (a1', a2', a3', a4', a5', a6')+    fromValue _ = Nothing++instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7) => IsValue (a1, a2, a3, a4, a5, a6, a7) where+    typeOf ~(a1, a2, a3, a4, a5, a6, a7) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7]+    toValue (a1, a2, a3, a4, a5, a6, a7) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7]+    fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7]) = do+        a1' <- fromValue a1+        a2' <- fromValue a2+        a3' <- fromValue a3+        a4' <- fromValue a4+        a5' <- fromValue a5+        a6' <- fromValue a6+        a7' <- fromValue a7+        return (a1', a2', a3', a4', a5', a6', a7')+    fromValue _ = Nothing++instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8) where+    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8]+    toValue (a1, a2, a3, a4, a5, a6, a7, a8) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8]+    fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8]) = do+        a1' <- fromValue a1+        a2' <- fromValue a2+        a3' <- fromValue a3+        a4' <- fromValue a4+        a5' <- fromValue a5+        a6' <- fromValue a6+        a7' <- fromValue a7+        a8' <- fromValue a8+        return (a1', a2', a3', a4', a5', a6', a7', a8')+    fromValue _ = Nothing++instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9) where+    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8, a9) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8, typeOf a9]+    toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9]+    fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9]) = do+        a1' <- fromValue a1+        a2' <- fromValue a2+        a3' <- fromValue a3+        a4' <- fromValue a4+        a5' <- fromValue a5+        a6' <- fromValue a6+        a7' <- fromValue a7+        a8' <- fromValue a8+        a9' <- fromValue a9+        return (a1', a2', a3', a4', a5', a6', a7', a8', a9')+    fromValue _ = Nothing++instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) where+    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8, typeOf a9, typeOf a10]+    toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10]+    fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10]) = do+        a1' <- fromValue a1+        a2' <- fromValue a2+        a3' <- fromValue a3+        a4' <- fromValue a4+        a5' <- fromValue a5+        a6' <- fromValue a6+        a7' <- fromValue a7+        a8' <- fromValue a8+        a9' <- fromValue a9+        a10' <- fromValue a10+        return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10')+    fromValue _ = Nothing++instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10, IsValue a11) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) where+    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8, typeOf a9, typeOf a10, typeOf a11]+    toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10, toValue a11]+    fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11]) = do+        a1' <- fromValue a1+        a2' <- fromValue a2+        a3' <- fromValue a3+        a4' <- fromValue a4+        a5' <- fromValue a5+        a6' <- fromValue a6+        a7' <- fromValue a7+        a8' <- fromValue a8+        a9' <- fromValue a9+        a10' <- fromValue a10+        a11' <- fromValue a11+        return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11')+    fromValue _ = Nothing++instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10, IsValue a11, IsValue a12) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) where+    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8, typeOf a9, typeOf a10, typeOf a11, typeOf a12]+    toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10, toValue a11, toValue a12]+    fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12]) = do+        a1' <- fromValue a1+        a2' <- fromValue a2+        a3' <- fromValue a3+        a4' <- fromValue a4+        a5' <- fromValue a5+        a6' <- fromValue a6+        a7' <- fromValue a7+        a8' <- fromValue a8+        a9' <- fromValue a9+        a10' <- fromValue a10+        a11' <- fromValue a11+        a12' <- fromValue a12+        return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12')+    fromValue _ = Nothing++instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10, IsValue a11, IsValue a12, IsValue a13) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) where+    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8, typeOf a9, typeOf a10, typeOf a11, typeOf a12, typeOf a13]+    toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10, toValue a11, toValue a12, toValue a13]+    fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13]) = do+        a1' <- fromValue a1+        a2' <- fromValue a2+        a3' <- fromValue a3+        a4' <- fromValue a4+        a5' <- fromValue a5+        a6' <- fromValue a6+        a7' <- fromValue a7+        a8' <- fromValue a8+        a9' <- fromValue a9+        a10' <- fromValue a10+        a11' <- fromValue a11+        a12' <- fromValue a12+        a13' <- fromValue a13+        return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12', a13')+    fromValue _ = Nothing++instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10, IsValue a11, IsValue a12, IsValue a13, IsValue a14) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) where+    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8, typeOf a9, typeOf a10, typeOf a11, typeOf a12, typeOf a13, typeOf a14]+    toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10, toValue a11, toValue a12, toValue a13, toValue a14]+    fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14]) = do+        a1' <- fromValue a1+        a2' <- fromValue a2+        a3' <- fromValue a3+        a4' <- fromValue a4+        a5' <- fromValue a5+        a6' <- fromValue a6+        a7' <- fromValue a7+        a8' <- fromValue a8+        a9' <- fromValue a9+        a10' <- fromValue a10+        a11' <- fromValue a11+        a12' <- fromValue a12+        a13' <- fromValue a13+        a14' <- fromValue a14+        return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12', a13', a14')+    fromValue _ = Nothing++instance (IsValue a1, IsValue a2, IsValue a3, IsValue a4, IsValue a5, IsValue a6, IsValue a7, IsValue a8, IsValue a9, IsValue a10, IsValue a11, IsValue a12, IsValue a13, IsValue a14, IsValue a15) => IsValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) where+    typeOf ~(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) = TypeStructure [typeOf a1, typeOf a2, typeOf a3, typeOf a4, typeOf a5, typeOf a6, typeOf a7, typeOf a8, typeOf a9, typeOf a10, typeOf a11, typeOf a12, typeOf a13, typeOf a14, typeOf a15]+    toValue (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) = ValueStructure [toValue a1, toValue a2, toValue a3, toValue a4, toValue a5, toValue a6, toValue a7, toValue a8, toValue a9, toValue a10, toValue a11, toValue a12, toValue a13, toValue a14, toValue a15]+    fromValue (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15]) = do+        a1' <- fromValue a1+        a2' <- fromValue a2+        a3' <- fromValue a3+        a4' <- fromValue a4+        a5' <- fromValue a5+        a6' <- fromValue a6+        a7' <- fromValue a7+        a8' <- fromValue a8+        a9' <- fromValue a9+        a10' <- fromValue a10+        a11' <- fromValue a11+        a12' <- fromValue a12+        a13' <- fromValue a13+        a14' <- fromValue a14+        a15' <- fromValue a15+        return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12', a13', a14', a15')+    fromValue _ = Nothing++instance (IsVariant a1, IsVariant a2, IsVariant a3) => IsVariant (a1, a2, a3) where+    toVariant (a1, a2, a3) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3])+    fromVariant (Variant (ValueStructure [a1, a2, a3])) = do+        a1' <- (fromVariant . Variant) a1+        a2' <- (fromVariant . Variant) a2+        a3' <- (fromVariant . Variant) a3+        return (a1', a2', a3')+    fromVariant _ = Nothing++instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4) => IsVariant (a1, a2, a3, a4) where+    toVariant (a1, a2, a3, a4) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4])+    fromVariant (Variant (ValueStructure [a1, a2, a3, a4])) = do+        a1' <- (fromVariant . Variant) a1+        a2' <- (fromVariant . Variant) a2+        a3' <- (fromVariant . Variant) a3+        a4' <- (fromVariant . Variant) a4+        return (a1', a2', a3', a4')+    fromVariant _ = Nothing++instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5) => IsVariant (a1, a2, a3, a4, a5) where+    toVariant (a1, a2, a3, a4, a5) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5])+    fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5])) = do+        a1' <- (fromVariant . Variant) a1+        a2' <- (fromVariant . Variant) a2+        a3' <- (fromVariant . Variant) a3+        a4' <- (fromVariant . Variant) a4+        a5' <- (fromVariant . Variant) a5+        return (a1', a2', a3', a4', a5')+    fromVariant _ = Nothing++instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6) => IsVariant (a1, a2, a3, a4, a5, a6) where+    toVariant (a1, a2, a3, a4, a5, a6) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6])+    fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6])) = do+        a1' <- (fromVariant . Variant) a1+        a2' <- (fromVariant . Variant) a2+        a3' <- (fromVariant . Variant) a3+        a4' <- (fromVariant . Variant) a4+        a5' <- (fromVariant . Variant) a5+        a6' <- (fromVariant . Variant) a6+        return (a1', a2', a3', a4', a5', a6')+    fromVariant _ = Nothing++instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7) => IsVariant (a1, a2, a3, a4, a5, a6, a7) where+    toVariant (a1, a2, a3, a4, a5, a6, a7) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7])+    fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7])) = do+        a1' <- (fromVariant . Variant) a1+        a2' <- (fromVariant . Variant) a2+        a3' <- (fromVariant . Variant) a3+        a4' <- (fromVariant . Variant) a4+        a5' <- (fromVariant . Variant) a5+        a6' <- (fromVariant . Variant) a6+        a7' <- (fromVariant . Variant) a7+        return (a1', a2', a3', a4', a5', a6', a7')+    fromVariant _ = Nothing++instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8) where+    toVariant (a1, a2, a3, a4, a5, a6, a7, a8) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8])+    fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8])) = do+        a1' <- (fromVariant . Variant) a1+        a2' <- (fromVariant . Variant) a2+        a3' <- (fromVariant . Variant) a3+        a4' <- (fromVariant . Variant) a4+        a5' <- (fromVariant . Variant) a5+        a6' <- (fromVariant . Variant) a6+        a7' <- (fromVariant . Variant) a7+        a8' <- (fromVariant . Variant) a8+        return (a1', a2', a3', a4', a5', a6', a7', a8')+    fromVariant _ = Nothing++instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8, IsVariant a9) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9) where+    toVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8, varToVal a9])+    fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9])) = do+        a1' <- (fromVariant . Variant) a1+        a2' <- (fromVariant . Variant) a2+        a3' <- (fromVariant . Variant) a3+        a4' <- (fromVariant . Variant) a4+        a5' <- (fromVariant . Variant) a5+        a6' <- (fromVariant . Variant) a6+        a7' <- (fromVariant . Variant) a7+        a8' <- (fromVariant . Variant) a8+        a9' <- (fromVariant . Variant) a9+        return (a1', a2', a3', a4', a5', a6', a7', a8', a9')+    fromVariant _ = Nothing++instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8, IsVariant a9, IsVariant a10) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) where+    toVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8, varToVal a9, varToVal a10])+    fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10])) = do+        a1' <- (fromVariant . Variant) a1+        a2' <- (fromVariant . Variant) a2+        a3' <- (fromVariant . Variant) a3+        a4' <- (fromVariant . Variant) a4+        a5' <- (fromVariant . Variant) a5+        a6' <- (fromVariant . Variant) a6+        a7' <- (fromVariant . Variant) a7+        a8' <- (fromVariant . Variant) a8+        a9' <- (fromVariant . Variant) a9+        a10' <- (fromVariant . Variant) a10+        return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10')+    fromVariant _ = Nothing++instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8, IsVariant a9, IsVariant a10, IsVariant a11) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) where+    toVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8, varToVal a9, varToVal a10, varToVal a11])+    fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11])) = do+        a1' <- (fromVariant . Variant) a1+        a2' <- (fromVariant . Variant) a2+        a3' <- (fromVariant . Variant) a3+        a4' <- (fromVariant . Variant) a4+        a5' <- (fromVariant . Variant) a5+        a6' <- (fromVariant . Variant) a6+        a7' <- (fromVariant . Variant) a7+        a8' <- (fromVariant . Variant) a8+        a9' <- (fromVariant . Variant) a9+        a10' <- (fromVariant . Variant) a10+        a11' <- (fromVariant . Variant) a11+        return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11')+    fromVariant _ = Nothing++instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8, IsVariant a9, IsVariant a10, IsVariant a11, IsVariant a12) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) where+    toVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8, varToVal a9, varToVal a10, varToVal a11, varToVal a12])+    fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12])) = do+        a1' <- (fromVariant . Variant) a1+        a2' <- (fromVariant . Variant) a2+        a3' <- (fromVariant . Variant) a3+        a4' <- (fromVariant . Variant) a4+        a5' <- (fromVariant . Variant) a5+        a6' <- (fromVariant . Variant) a6+        a7' <- (fromVariant . Variant) a7+        a8' <- (fromVariant . Variant) a8+        a9' <- (fromVariant . Variant) a9+        a10' <- (fromVariant . Variant) a10+        a11' <- (fromVariant . Variant) a11+        a12' <- (fromVariant . Variant) a12+        return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12')+    fromVariant _ = Nothing++instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8, IsVariant a9, IsVariant a10, IsVariant a11, IsVariant a12, IsVariant a13) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) where+    toVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8, varToVal a9, varToVal a10, varToVal a11, varToVal a12, varToVal a13])+    fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13])) = do+        a1' <- (fromVariant . Variant) a1+        a2' <- (fromVariant . Variant) a2+        a3' <- (fromVariant . Variant) a3+        a4' <- (fromVariant . Variant) a4+        a5' <- (fromVariant . Variant) a5+        a6' <- (fromVariant . Variant) a6+        a7' <- (fromVariant . Variant) a7+        a8' <- (fromVariant . Variant) a8+        a9' <- (fromVariant . Variant) a9+        a10' <- (fromVariant . Variant) a10+        a11' <- (fromVariant . Variant) a11+        a12' <- (fromVariant . Variant) a12+        a13' <- (fromVariant . Variant) a13+        return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12', a13')+    fromVariant _ = Nothing++instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8, IsVariant a9, IsVariant a10, IsVariant a11, IsVariant a12, IsVariant a13, IsVariant a14) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) where+    toVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8, varToVal a9, varToVal a10, varToVal a11, varToVal a12, varToVal a13, varToVal a14])+    fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14])) = do+        a1' <- (fromVariant . Variant) a1+        a2' <- (fromVariant . Variant) a2+        a3' <- (fromVariant . Variant) a3+        a4' <- (fromVariant . Variant) a4+        a5' <- (fromVariant . Variant) a5+        a6' <- (fromVariant . Variant) a6+        a7' <- (fromVariant . Variant) a7+        a8' <- (fromVariant . Variant) a8+        a9' <- (fromVariant . Variant) a9+        a10' <- (fromVariant . Variant) a10+        a11' <- (fromVariant . Variant) a11+        a12' <- (fromVariant . Variant) a12+        a13' <- (fromVariant . Variant) a13+        a14' <- (fromVariant . Variant) a14+        return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12', a13', a14')+    fromVariant _ = Nothing++instance (IsVariant a1, IsVariant a2, IsVariant a3, IsVariant a4, IsVariant a5, IsVariant a6, IsVariant a7, IsVariant a8, IsVariant a9, IsVariant a10, IsVariant a11, IsVariant a12, IsVariant a13, IsVariant a14, IsVariant a15) => IsVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) where+    toVariant (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) = Variant (ValueStructure [varToVal a1, varToVal a2, varToVal a3, varToVal a4, varToVal a5, varToVal a6, varToVal a7, varToVal a8, varToVal a9, varToVal a10, varToVal a11, varToVal a12, varToVal a13, varToVal a14, varToVal a15])+    fromVariant (Variant (ValueStructure [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15])) = do+        a1' <- (fromVariant . Variant) a1+        a2' <- (fromVariant . Variant) a2+        a3' <- (fromVariant . Variant) a3+        a4' <- (fromVariant . Variant) a4+        a5' <- (fromVariant . Variant) a5+        a6' <- (fromVariant . Variant) a6+        a7' <- (fromVariant . Variant) a7+        a8' <- (fromVariant . Variant) a8+        a9' <- (fromVariant . Variant) a9+        a10' <- (fromVariant . Variant) a10+        a11' <- (fromVariant . Variant) a11+        a12' <- (fromVariant . Variant) a12+        a13' <- (fromVariant . Variant) a13+        a14' <- (fromVariant . Variant) a14+        a15' <- (fromVariant . Variant) a15+        return (a1', a2', a3', a4', a5', a6', a7', a8', a9', a10', a11', a12', a13', a14', a15')+    fromVariant _ = Nothing++-- | A value used to uniquely identify a particular message within a session.+-- Serials are 32-bit unsigned integers, and eventually wrap.+newtype Serial = Serial Word32+    deriving (Eq, Ord, Show)++instance IsVariant Serial where+    toVariant (Serial x) = toVariant x+    fromVariant = fmap Serial . fromVariant++serialValue :: Serial -> Word32+serialValue (Serial x) = x++-- | Get the first serial in the sequence.+firstSerial :: Serial+firstSerial = Serial 1++-- | Get the next serial in the sequence. This may wrap around to+-- 'firstSerial'.+nextSerial :: Serial -> Serial+nextSerial (Serial x) = Serial (if x + 1 == 0+    then 1 -- wrap to firstSerial+    else x + 1)++skipSepBy1 :: Parsec.Parser a -> Parsec.Parser b -> Parsec.Parser ()+skipSepBy1 p sep = do+    _ <- p+    Parsec.skipMany (sep >> p)++forceParse :: String -> (String -> Maybe a) -> String -> a+forceParse label parse str = case parse str of+    Just x -> x+    Nothing -> error ("Invalid " ++ label ++ ": " ++ show str)++maybeParseString :: Parsec.Parser a -> String -> Maybe a+maybeParseString parser s = case Parsec.parse parser "" s of+    Left _ -> Nothing+    Right a -> Just a

@@ -0,0 +1,782 @@+-- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>+--+-- 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 <http://www.gnu.org/licenses/>.++module DBus.Internal.Wire+    ( Endianness(..)+    , MarshalError+    , marshalErrorMessage++    , UnmarshalError+    , unmarshalErrorMessage++    , marshalMessage+    , unmarshalMessage+    , unmarshalMessageM+    ) where++import qualified Control.Applicative+import           Control.Monad (ap, liftM, when, unless)+import qualified Data.ByteString+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Char8+import qualified Data.ByteString.Lazy as Lazy+import           Data.Int (Int16, Int32, Int64)+import qualified Data.Map+import           Data.Map (Map)+import           Data.Maybe (fromJust, listToMaybe, fromMaybe)+import           Data.Monoid+import           Data.Text (Text)+import qualified Data.Text.Encoding+import qualified Data.Vector+import           Data.Vector (Vector)+import           Data.Word (Word8, Word16, Word32, Word64)+import           Foreign.C.Types (CInt)+import           System.Posix.Types (Fd(..))+import           Prelude++import qualified Data.Serialize.Get as Get+import           Data.Serialize.IEEE754 (getFloat64be, getFloat64le, putFloat64be, putFloat64le)+import           Data.Serialize.Put (runPut)++import           DBus.Internal.Message+import           DBus.Internal.Types++data Endianness = LittleEndian | BigEndian+    deriving (Show, Eq)++encodeEndianness :: Endianness -> Word8+encodeEndianness LittleEndian = 0x6C+encodeEndianness BigEndian    = 0x42++decodeEndianness :: Word8 -> Maybe Endianness+decodeEndianness 0x6C = Just LittleEndian+decodeEndianness 0x42 = Just BigEndian+decodeEndianness _    = Nothing++alignment :: Type -> Word8+alignment TypeBoolean = 4+alignment TypeWord8 = 1+alignment TypeWord16 = 2+alignment TypeWord32 = 4+alignment TypeWord64 = 8+alignment TypeInt16 = 2+alignment TypeInt32 = 4+alignment TypeInt64 = 8+alignment TypeDouble = 8+alignment TypeUnixFd = 4+alignment TypeString = 4+alignment TypeObjectPath = 4+alignment TypeSignature = 1+alignment (TypeArray _) = 4+alignment (TypeDictionary _ _) = 4+alignment (TypeStructure _) = 8+alignment TypeVariant = 1++{-# INLINE padding #-}+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++data WireR s a+    = WireRL String+    | WireRR a !s++newtype Wire s a = Wire+    { unWire :: Endianness -> s -> WireR s a+    }++instance Functor (Wire s) where+    {-# INLINE fmap #-}+    fmap = liftM++instance Control.Applicative.Applicative (Wire s) where+    {-# INLINE pure #-}+    pure = return++    {-# INLINE (<*>) #-}+    (<*>) = ap++instance Monad (Wire s) where+    {-# INLINE return #-}+    return a = Wire (\_ s -> WireRR a s)++    {-# INLINE (>>=) #-}+    m >>= k = Wire $ \e s -> case unWire m e s of+        WireRL err -> WireRL err+        WireRR a s' -> unWire (k a) e s'++    {-# INLINE (>>) #-}+    m >> k = Wire $ \e s -> case unWire m e s of+        WireRL err -> WireRL err+        WireRR _ s' -> unWire k e s'++throwError :: String -> Wire s a+throwError err = Wire (\_ _ -> WireRL err)++{-# INLINE getState #-}+getState :: Wire s s+getState = Wire (\_ s -> WireRR s s)++{-# INLINE putState #-}+putState :: s -> Wire s ()+putState s = Wire (\_ _ -> WireRR () s)++{-# INLINE chooseEndian #-}+chooseEndian :: a -> a -> Wire s a+chooseEndian big little = Wire (\e s -> case e of+    BigEndian -> WireRR big s+    LittleEndian -> WireRR little s)++type Marshal = Wire MarshalState++newtype MarshalError = MarshalError String+    deriving (Show, Eq)++marshalErrorMessage :: MarshalError -> String+marshalErrorMessage (MarshalError s) = s++data MarshalState = MarshalState+    !Builder.Builder+    {-# UNPACK #-} !Word64++marshal :: Value -> Marshal ()+marshal (ValueAtom x) = marshalAtom x+marshal (ValueBytes xs) = marshalStrictBytes xs+marshal (ValueVector t xs) = marshalVector t xs+marshal (ValueMap kt vt xs) = marshalMap kt vt xs+marshal (ValueStructure xs) = marshalStructure xs+marshal (ValueVariant x) = marshalVariant x++marshalAtom :: Atom -> Marshal ()+marshalAtom (AtomWord8 x) = marshalWord8 x+marshalAtom (AtomWord16 x) = marshalWord16 x+marshalAtom (AtomWord32 x) = marshalWord32 x+marshalAtom (AtomWord64 x) = marshalWord64 x+marshalAtom (AtomInt16 x) = marshalInt16 x+marshalAtom (AtomInt32 x) = marshalInt32 x+marshalAtom (AtomInt64 x) = marshalInt64 x+marshalAtom (AtomDouble x) = marshalDouble x+marshalAtom (AtomUnixFd x) = marshalUnixFd x+marshalAtom (AtomBool x) = marshalBool x+marshalAtom (AtomText x) = marshalText x+marshalAtom (AtomObjectPath x) = marshalObjectPath x+marshalAtom (AtomSignature x) = marshalSignature x++appendB :: Word64 -> Builder.Builder -> Marshal ()+appendB size bytes = Wire (\_ (MarshalState builder count) -> let+    builder' = mappend builder bytes+    count' = count + size+    in WireRR () (MarshalState builder' count'))++appendS :: ByteString -> Marshal ()+appendS bytes = appendB+    (fromIntegral (Data.ByteString.length bytes))+    (Builder.byteString bytes)++appendL :: Lazy.ByteString -> Marshal ()+appendL bytes = appendB+    (fromIntegral (Lazy.length bytes))+    (Builder.lazyByteString bytes)++pad :: Word8 -> Marshal ()+pad count = do+    (MarshalState _ existing) <- getState+    let padding' = fromIntegral (padding existing count)+    appendS (Data.ByteString.replicate padding' 0)++marshalBuilder :: Word8+               -> (a -> Builder.Builder)+               -> (a -> Builder.Builder)+               -> a -> Marshal ()+marshalBuilder size be le x = do+    builder <- chooseEndian (be x) (le x)+    pad size+    appendB (fromIntegral size) builder++type Unmarshal = Wire UnmarshalState++newtype UnmarshalError = UnmarshalError String+    deriving (Show, Eq)++unmarshalErrorMessage :: UnmarshalError -> String+unmarshalErrorMessage (UnmarshalError s) = s++data UnmarshalState = UnmarshalState+    {-# UNPACK #-} !ByteString+    {-# UNPACK #-} !Word64++unmarshal :: Type -> Unmarshal Value+unmarshal TypeWord8 = liftM toValue unmarshalWord8+unmarshal TypeWord16 = liftM toValue unmarshalWord16+unmarshal TypeWord32 = liftM toValue unmarshalWord32+unmarshal TypeWord64 = liftM toValue unmarshalWord64+unmarshal TypeInt16 = liftM toValue unmarshalInt16+unmarshal TypeInt32 = liftM toValue unmarshalInt32+unmarshal TypeInt64 = liftM toValue unmarshalInt64+unmarshal TypeDouble = liftM toValue unmarshalDouble+unmarshal TypeUnixFd = liftM toValue unmarshalUnixFd+unmarshal TypeBoolean = liftM toValue unmarshalBool+unmarshal TypeString = liftM toValue unmarshalText+unmarshal TypeObjectPath = liftM toValue unmarshalObjectPath+unmarshal TypeSignature = liftM toValue unmarshalSignature+unmarshal (TypeArray TypeWord8) = liftM toValue unmarshalByteArray+unmarshal (TypeArray t) = liftM (ValueVector t) (unmarshalArray t)+unmarshal (TypeDictionary kt vt) = unmarshalDictionary kt vt+unmarshal (TypeStructure ts) = unmarshalStructure ts+unmarshal TypeVariant = unmarshalVariant++{-# INLINE consume #-}+consume :: Word64 -> Unmarshal ByteString+consume count = do+    (UnmarshalState bytes offset) <- getState+    let count' = fromIntegral count+    let (x, bytes') = Data.ByteString.splitAt count' bytes+    let lenConsumed = Data.ByteString.length x+    if lenConsumed == count'+        then do+            putState (UnmarshalState bytes' (offset + count))+            return x+        else throwError ("Unexpected EOF at offset " ++ show (offset + fromIntegral lenConsumed))++skipPadding :: Word8 -> Unmarshal ()+skipPadding count = do+    (UnmarshalState _ offset) <- getState+    bytes <- consume (padding offset count)+    unless (Data.ByteString.all (== 0) bytes)+        (throwError ("Value padding " ++ show bytes ++ " contains invalid bytes."))++skipTerminator :: Unmarshal ()+skipTerminator = do+    byte <- unmarshalWord8+    when (byte /= 0) (throwError "Textual value is not NUL-terminated.")++fromMaybeU :: Show a => String -> (a -> Maybe b) -> a -> Unmarshal b+fromMaybeU label f x = case f x of+    Just x' -> return x'+    Nothing -> throwError ("Invalid " ++ label ++ ": " ++ show x)++unmarshalGet :: Word8 -> Get.Get a -> Get.Get a -> Unmarshal a+unmarshalGet count be le = do+    skipPadding count+    bytes <- consume (fromIntegral count)+    get <- chooseEndian be le+    let Right ret = Get.runGet get bytes+    return ret++marshalWord8 :: Word8 -> Marshal ()+marshalWord8 x = appendB 1 (Builder.word8 x)++unmarshalWord8 :: Unmarshal Word8+unmarshalWord8 = liftM Data.ByteString.head (consume 1)++marshalWord16 :: Word16 -> Marshal ()+marshalWord16 = marshalBuilder 2+    Builder.word16BE+    Builder.word16LE++marshalWord32 :: Word32 -> Marshal ()+marshalWord32 = marshalBuilder 4+    Builder.word32BE+    Builder.word32LE++marshalWord64 :: Word64 -> Marshal ()+marshalWord64 = marshalBuilder 8+    Builder.word64BE+    Builder.word64LE++marshalInt16 :: Int16 -> Marshal ()+marshalInt16 = marshalWord16 . fromIntegral++marshalInt32 :: Int32 -> Marshal ()+marshalInt32 = marshalWord32 . fromIntegral++marshalInt64 :: Int64 -> Marshal ()+marshalInt64 = marshalWord64 . fromIntegral++unmarshalWord16 :: Unmarshal Word16+unmarshalWord16 = unmarshalGet 2+    Get.getWord16be+    Get.getWord16le++unmarshalWord32 :: Unmarshal Word32+unmarshalWord32 = unmarshalGet 4+    Get.getWord32be+    Get.getWord32le++unmarshalWord64 :: Unmarshal Word64+unmarshalWord64 = unmarshalGet 8+    Get.getWord64be+    Get.getWord64le++unmarshalInt16 :: Unmarshal Int16+unmarshalInt16 = liftM fromIntegral unmarshalWord16++unmarshalInt32 :: Unmarshal Int32+unmarshalInt32 = liftM fromIntegral unmarshalWord32++unmarshalInt64 :: Unmarshal Int64+unmarshalInt64 = liftM fromIntegral unmarshalWord64++marshalDouble :: Double -> Marshal ()+marshalDouble x = do+    put <- chooseEndian putFloat64be putFloat64le+    pad 8+    appendS (runPut (put x))++unmarshalDouble :: Unmarshal Double+unmarshalDouble = unmarshalGet 8+    getFloat64be+    getFloat64le++marshalUnixFd :: Fd -> Marshal ()+marshalUnixFd (Fd x)+    | x < 0 = throwError ("Invalid file descriptor: " ++ show x)+    | toInteger x > toInteger (maxBound :: Word32) = throwError ("D-Bus forbids file descriptors exceeding UINT32_MAX: " ++ show x)+    | otherwise = marshalWord32 (fromIntegral x)++unmarshalUnixFd :: Unmarshal Fd+unmarshalUnixFd = do+    x <- unmarshalWord32+    when (toInteger x > toInteger (maxBound :: CInt))+        (throwError ("Invalid file descriptor: " ++ show x))+    return (Fd (fromIntegral x))++marshalBool :: Bool -> Marshal ()+marshalBool False = marshalWord32 0+marshalBool True  = marshalWord32 1++unmarshalBool :: Unmarshal Bool+unmarshalBool = do+    word <- unmarshalWord32+    case word of+        0 -> return False+        1 -> return True+        _ -> throwError ("Invalid boolean: " ++ show word)++marshalText :: Text -> Marshal ()+marshalText text = do+    let bytes = Data.Text.Encoding.encodeUtf8 text+    when (Data.ByteString.any (== 0) bytes)+        (throwError ("String " ++ show text ++ " contained forbidden character: '\\x00'"))+    marshalWord32 (fromIntegral (Data.ByteString.length bytes))+    appendS bytes+    marshalWord8 0++unmarshalText :: Unmarshal Text+unmarshalText = do+    byteCount <- unmarshalWord32+    bytes <- consume (fromIntegral byteCount)+    skipTerminator+    fromMaybeU "text" maybeDecodeUtf8 bytes++maybeDecodeUtf8 :: ByteString -> Maybe Text+maybeDecodeUtf8 bs = case Data.Text.Encoding.decodeUtf8' bs of+    Right text -> Just text+    _ -> Nothing++marshalObjectPath :: ObjectPath -> Marshal ()+marshalObjectPath p = do+    let bytes = Data.ByteString.Char8.pack (formatObjectPath p)+    marshalWord32 (fromIntegral (Data.ByteString.length bytes))+    appendS bytes+    marshalWord8 0++unmarshalObjectPath :: Unmarshal ObjectPath+unmarshalObjectPath = do+    byteCount <- unmarshalWord32+    bytes <- consume (fromIntegral byteCount)+    skipTerminator+    fromMaybeU "object path" parseObjectPath (Data.ByteString.Char8.unpack bytes)++signatureBytes :: Signature -> ByteString+signatureBytes (Signature ts) = Data.ByteString.Char8.pack (concatMap typeCode ts)++marshalSignature :: Signature -> Marshal ()+marshalSignature x = do+    let bytes = signatureBytes x+    marshalWord8 (fromIntegral (Data.ByteString.length bytes))+    appendS bytes+    marshalWord8 0++unmarshalSignature :: Unmarshal Signature+unmarshalSignature = do+    byteCount <- unmarshalWord8+    bytes <- consume (fromIntegral byteCount)+    skipTerminator+    fromMaybeU "signature" parseSignatureBytes bytes++arrayMaximumLength :: Int64+arrayMaximumLength = 67108864++marshalVector :: Type -> Vector Value -> Marshal ()+marshalVector t x = do+    (arrayPadding, arrayBytes) <- getArrayBytes t x+    let arrayLen = Lazy.length arrayBytes+    when (arrayLen > arrayMaximumLength) (throwError ("Marshaled array size (" ++ show arrayLen ++ " bytes) exceeds maximum limit of (" ++ show arrayMaximumLength ++ " bytes)."))+    marshalWord32 (fromIntegral arrayLen)+    appendS (Data.ByteString.replicate arrayPadding 0)+    appendL arrayBytes++marshalStrictBytes :: ByteString -> Marshal ()+marshalStrictBytes bytes = do+    let arrayLen = Lazy.length (Lazy.fromStrict bytes)+    when (fromIntegral arrayLen > arrayMaximumLength) (throwError ("Marshaled array size (" ++ show arrayLen ++ " bytes) exceeds maximum limit of (" ++ show arrayMaximumLength ++ " bytes)."))+    marshalWord32 (fromIntegral arrayLen)+    appendS bytes++getArrayBytes :: Type -> Vector Value -> Marshal (Int, Lazy.ByteString)+getArrayBytes itemType vs = do+    s <- getState+    (MarshalState _ afterLength) <- marshalWord32 0 >> getState+    (MarshalState _ afterPadding) <- pad (alignment itemType) >> getState++    putState (MarshalState mempty afterPadding)+    (MarshalState itemBuilder _) <- Data.Vector.mapM_ marshal vs >> getState++    let itemBytes = Builder.toLazyByteString itemBuilder+        paddingSize = fromIntegral (afterPadding - afterLength)++    putState s+    return (paddingSize, itemBytes)++unmarshalByteArray :: Unmarshal ByteString+unmarshalByteArray = do+    byteCount <- unmarshalWord32+    consume (fromIntegral byteCount)++unmarshalArray :: Type -> Unmarshal (Vector Value)+unmarshalArray itemType = do+    let getOffset = do+        (UnmarshalState _ o) <- getState+        return o+    byteCount <- unmarshalWord32+    skipPadding (alignment itemType)+    start <- getOffset+    let end = start + fromIntegral byteCount+    vs <- untilM (liftM (>= end) getOffset) (unmarshal itemType)+    end' <- getOffset+    when (end' > end) (throwError ("Array data size exeeds array size of " ++ show end))+    return (Data.Vector.fromList vs)++dictionaryToArray :: Map Atom Value -> Vector Value+dictionaryToArray = Data.Vector.fromList . map step . Data.Map.toList where+    step (k, v) = ValueStructure [ValueAtom k, v]++arrayToDictionary :: Vector Value -> Map Atom Value+arrayToDictionary = Data.Map.fromList . map step . Data.Vector.toList where+    step (ValueStructure [ValueAtom k, v]) = (k, v)+    step _ = error "arrayToDictionary: internal error"++marshalMap :: Type -> Type -> Map Atom Value -> Marshal ()+marshalMap kt vt x = let+    structType = TypeStructure [kt, vt]+    array = dictionaryToArray x+    in marshalVector structType array++unmarshalDictionary :: Type -> Type -> Unmarshal Value+unmarshalDictionary kt vt = do+    let pairType = TypeStructure [kt, vt]+    array <- unmarshalArray pairType+    return (ValueMap kt vt (arrayToDictionary array))++marshalStructure :: [Value] -> Marshal ()+marshalStructure vs = do+    pad 8+    mapM_ marshal vs++unmarshalStructure :: [Type] -> Unmarshal Value+unmarshalStructure ts = do+    skipPadding 8+    liftM ValueStructure (mapM unmarshal ts)++marshalVariant :: Variant -> Marshal ()+marshalVariant var@(Variant val) = do+    sig <- case signature [valueType val] of+        Just x' -> return x'+        Nothing -> throwError ("Signature " ++ show (typeCode (valueType val)) ++ " for variant " ++ show var ++ " is malformed or too large.")+    marshalSignature sig+    marshal val++unmarshalVariant :: Unmarshal Value+unmarshalVariant = do+    let getType sig = case signatureTypes sig of+            [t] -> Just t+            _   -> Nothing++    t <- fromMaybeU "variant signature" getType =<< unmarshalSignature+    (toValue . Variant) `liftM` unmarshal t++protocolVersion :: Word8+protocolVersion = 1++messageMaximumLength :: Integer+messageMaximumLength = 134217728++encodeField :: HeaderField -> Value+encodeField (HeaderPath x)        = encodeField' 1 x+encodeField (HeaderInterface x)   = encodeField' 2 x+encodeField (HeaderMember x)      = encodeField' 3 x+encodeField (HeaderErrorName x)   = encodeField' 4 x+encodeField (HeaderReplySerial x) = encodeField' 5 x+encodeField (HeaderDestination x) = encodeField' 6 x+encodeField (HeaderSender x)      = encodeField' 7 x+encodeField (HeaderSignature x)   = encodeField' 8 x+encodeField (HeaderUnixFds x)     = encodeField' 9 x++encodeField' :: IsVariant a => Word8 -> a -> Value+encodeField' code x = toValue (code, toVariant x)++decodeField :: (Word8, Variant)+            -> ErrorM UnmarshalError [HeaderField]+decodeField struct = case struct of+    (1, x) -> decodeField' x HeaderPath "path"+    (2, x) -> decodeField' x HeaderInterface "interface"+    (3, x) -> decodeField' x HeaderMember "member"+    (4, x) -> decodeField' x HeaderErrorName "error name"+    (5, x) -> decodeField' x HeaderReplySerial "reply serial"+    (6, x) -> decodeField' x HeaderDestination "destination"+    (7, x) -> decodeField' x HeaderSender "sender"+    (8, x) -> decodeField' x HeaderSignature "signature"+    (9, x) -> decodeField' x HeaderUnixFds "unix fds"+    _      -> return []++decodeField' :: IsVariant a => Variant -> (a -> b) -> String+             -> ErrorM UnmarshalError [b]+decodeField' x f label = case fromVariant x of+    Just x' -> return [f x']+    Nothing -> throwErrorM (UnmarshalError ("Header field " ++ show label ++ " contains invalid value " ++ show x))++marshalMessage :: Message a => Endianness -> Serial -> a+               -> Either MarshalError ByteString+marshalMessage e serial msg = runMarshal where+    body = messageBody msg+    marshaler = do+        sig <- checkBodySig body+        empty <- getState+        mapM_ (marshal . (\(Variant x) -> x)) body+        (MarshalState bodyBytesB _) <- getState+        putState empty+        marshal (toValue (encodeEndianness e))+        let bodyBytes = Builder.toLazyByteString bodyBytesB+        marshalHeader msg serial sig (fromIntegral (Lazy.length bodyBytes))+        pad 8+        appendL bodyBytes+        checkMaximumSize+    emptyState = MarshalState mempty 0+    runMarshal = case unWire marshaler e emptyState of+        WireRL err -> Left (MarshalError err)+        WireRR _ (MarshalState builder _) -> Right (Lazy.toStrict (Builder.toLazyByteString builder))++checkBodySig :: [Variant] -> Marshal Signature+checkBodySig vs = case signature (map variantType vs) of+    Just x -> return x+    Nothing -> throwError ("Message body " ++ show vs ++ " has too many items")++marshalHeader :: Message a => a -> Serial -> Signature -> Word32+              -> Marshal ()+marshalHeader msg serial bodySig bodyLength = do+    let fields = HeaderSignature bodySig : messageHeaderFields msg+    marshalWord8 (messageTypeCode msg)+    marshalWord8 (messageFlags msg)+    marshalWord8 protocolVersion+    marshalWord32 bodyLength+    marshalWord32 (serialValue serial)+    let fieldType = TypeStructure [TypeWord8, TypeVariant]+    marshalVector fieldType (Data.Vector.fromList (map encodeField fields))++checkMaximumSize :: Marshal ()+checkMaximumSize = do+    (MarshalState _ messageLength) <- getState+    when (toInteger messageLength > messageMaximumLength)+        (throwError ("Marshaled message size (" ++ show messageLength ++ " bytes) exeeds maximum limit of (" ++ show messageMaximumLength ++ " bytes)."))++unmarshalMessageM :: Monad m => (Int -> m ByteString)+                  -> m (Either UnmarshalError ReceivedMessage)+unmarshalMessageM getBytes' = runErrorT $ do+    let getBytes count = do+        bytes <- ErrorT (liftM Right (getBytes' count))+        if Data.ByteString.length bytes < count+            then throwErrorT (UnmarshalError "Unexpected end of input while parsing message header.")+            else return bytes++    let Just fixedSig = parseSignature "yyyyuuu"+    fixedBytes <- getBytes 16++    let messageVersion = Data.ByteString.index fixedBytes 3+    when (messageVersion /= protocolVersion) (throwErrorT (UnmarshalError ("Unsupported protocol version: " ++ show messageVersion)))++    let eByte = Data.ByteString.index fixedBytes 0+    endianness <- case decodeEndianness eByte of+        Just x' -> return x'+        Nothing -> throwErrorT (UnmarshalError ("Invalid endianness: " ++ show eByte))++    let unmarshalSig = mapM unmarshal . signatureTypes+    let unmarshal' x bytes = case unWire (unmarshalSig x) endianness (UnmarshalState bytes 0) of+            WireRR x' _ -> return x'+            WireRL err  -> throwErrorT (UnmarshalError err)+    fixed <- unmarshal' fixedSig fixedBytes+    let messageType = fromJust (fromValue (fixed !! 1))+    let flags = fromJust (fromValue (fixed !! 2))+    let bodyLength = fromJust (fromValue (fixed !! 4)) :: Word32+    let serial = fromJust (fromVariant (Variant (fixed !! 5)))++    let fieldByteCount = fromJust (fromValue (fixed !! 6)) :: Word32+    let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8++    -- Forbid messages larger than 'messageMaximumLength'+    let messageLength = 16 + toInteger fieldByteCount + toInteger bodyPadding + toInteger bodyLength+    when (messageLength > messageMaximumLength) $+        throwErrorT (UnmarshalError ("Message size " ++ show messageLength ++ " exceeds limit of " ++ show messageMaximumLength))++    let Just headerSig  = parseSignature "yyyyuua(yv)"+    fieldBytes <- getBytes (fromIntegral fieldByteCount)+    let headerBytes = Data.ByteString.append fixedBytes fieldBytes+    header <- unmarshal' headerSig headerBytes++    let fieldArray = Data.Vector.toList (fromJust (fromValue (header !! 6)))+    fields <- case runErrorM $ concat `liftM` mapM decodeField fieldArray of+        Left err -> throwErrorT err+        Right x -> return x+    _ <- getBytes (fromIntegral bodyPadding)+    let bodySig = findBodySignature fields+    bodyBytes <- getBytes (fromIntegral bodyLength)+    body <- unmarshal' bodySig bodyBytes+    y <- case runErrorM (buildReceivedMessage messageType fields) of+        Right x -> return x+        Left err -> throwErrorT (UnmarshalError ("Header field " ++ show err ++ " is required, but missing"))+    return (y serial flags (map Variant body))++findBodySignature :: [HeaderField] -> Signature+findBodySignature fields = fromMaybe (signature_ []) (listToMaybe [x | HeaderSignature x <- fields])++buildReceivedMessage :: Word8 -> [HeaderField] -> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)+buildReceivedMessage 1 fields = do+    path <- require "path" [x | HeaderPath x <- fields]+    member <- require "member name" [x | HeaderMember x <- fields]+    return $ \serial flags body -> let+        iface = listToMaybe [x | HeaderInterface x <- fields]+        dest = listToMaybe [x | HeaderDestination x <- fields]+        sender = listToMaybe [x | HeaderSender x <- fields]+        msg = MethodCall path iface member sender dest True True body+        in ReceivedMethodCall serial (setMethodCallFlags msg flags)++buildReceivedMessage 2 fields = do+    replySerial <- require "reply serial" [x | HeaderReplySerial x <- fields]+    return $ \serial _ body -> let+        dest = listToMaybe [x | HeaderDestination x <- fields]+        sender = listToMaybe [x | HeaderSender x <- fields]+        msg = MethodReturn replySerial sender dest body+        in ReceivedMethodReturn serial msg++buildReceivedMessage 3 fields = do+    name <- require "error name" [x | HeaderErrorName x <- fields]+    replySerial <- require "reply serial" [x | HeaderReplySerial x <- fields]+    return $ \serial _ body -> let+        dest = listToMaybe [x | HeaderDestination x <- fields]+        sender = listToMaybe [x | HeaderSender x <- fields]+        msg = MethodError name replySerial sender dest body+        in ReceivedMethodError serial msg++buildReceivedMessage 4 fields = do+    path <- require "path" [x | HeaderPath x <- fields]+    member <- require "member name" [x | HeaderMember x <- fields]+    iface <- require "interface" [x | HeaderInterface x <- fields]+    return $ \serial _ body -> let+        dest = listToMaybe [x | HeaderDestination x <- fields]+        sender = listToMaybe [x | HeaderSender x <- fields]+        msg = Signal path iface member sender dest body+        in ReceivedSignal serial msg++buildReceivedMessage messageType fields = return $ \serial _ body -> let+    sender = listToMaybe [x | HeaderSender x <- fields]+    msg = UnknownMessage messageType sender body+    in ReceivedUnknown serial msg++require :: String -> [a] -> ErrorM String a+require _     (x:_) = return x+require label _     = throwErrorM label++unmarshalMessage :: ByteString -> Either UnmarshalError ReceivedMessage+unmarshalMessage bytes = checkError (Get.runGet get bytes) where+    get = unmarshalMessageM getBytes++    -- wrap getByteString, so it will behave like transportGet and return+    -- a truncated result on EOF instead of throwing an exception.+    getBytes count = do+        remaining <- Get.remaining+        Get.getByteString (min remaining count)++    checkError (Left err) = Left (UnmarshalError err)+    checkError (Right x) = x++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)++-------------------------------------------------------------------------------+-- local ErrorT and MonadError, which don't have the silly Error => dependency+-- found in the "transformers" package.+-------------------------------------------------------------------------------++newtype ErrorM e a = ErrorM { runErrorM :: Either e a }++instance Functor (ErrorM e) where+    fmap f m = ErrorM $ case runErrorM m of+        Left err -> Left err+        Right x -> Right (f x)++instance Control.Applicative.Applicative (ErrorM e) where+    pure = return+    (<*>) = ap++instance Monad (ErrorM e) where+    return = ErrorM . Right+    (>>=) m k = case runErrorM m of+        Left err -> ErrorM (Left err)+        Right x -> k x++throwErrorM :: e -> ErrorM e a+throwErrorM = ErrorM . Left++newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }++instance Monad m => Functor (ErrorT e m) where+    fmap = liftM++instance Monad m => Control.Applicative.Applicative (ErrorT e m) where+    pure = return+    (<*>) = ap++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)++throwErrorT :: Monad m => e -> ErrorT e m a+throwErrorT = ErrorT . return . Left

@@ -16,64 +16,64 @@ -- along with this program.  If not, see <http://www.gnu.org/licenses/>.  module DBus.Introspection-	(-	-- * XML conversion-	  parseXML-	, formatXML-	-	-- * Objects-	, Object-	, object-	, objectPath-	, objectInterfaces-	, objectChildren-	-	-- * Interfaces-	, Interface-	, interface-	, interfaceName-	, interfaceMethods-	, interfaceSignals-	, interfaceProperties-	-	-- * Methods-	, Method-	, method-	, methodName-	, methodArgs-	-	-- ** Method arguments-	, MethodArg-	, methodArg-	, methodArgName-	, methodArgType-	, methodArgDirection-	-	, Direction-	, directionIn-	, directionOut-	-	-- * Signals-	, Signal-	, signal-	, signalName-	, signalArgs-	-	-- ** Signal arguments-	, SignalArg-	, signalArg-	, signalArgName-	, signalArgType-	-	-- * Properties-	, Property-	, property-	, propertyName-	, propertyType-	, propertyRead-	, propertyWrite-	) where+    (+    -- * XML conversion+      parseXML+    , formatXML +    -- * Objects+    , Object+    , object+    , objectPath+    , objectInterfaces+    , objectChildren++    -- * Interfaces+    , Interface+    , interface+    , interfaceName+    , interfaceMethods+    , interfaceSignals+    , interfaceProperties++    -- * Methods+    , Method+    , method+    , methodName+    , methodArgs++    -- ** Method arguments+    , MethodArg+    , methodArg+    , methodArgName+    , methodArgType+    , methodArgDirection++    , Direction+    , directionIn+    , directionOut++    -- * Signals+    , Signal+    , signal+    , signalName+    , signalArgs++    -- ** Signal arguments+    , SignalArg+    , signalArg+    , signalArgName+    , signalArgType++    -- * Properties+    , Property+    , property+    , propertyName+    , propertyType+    , propertyRead+    , propertyWrite+    ) where+ import qualified Control.Applicative import           Control.Monad ((>=>), ap, liftM) import           Control.Monad.ST (runST)@@ -88,47 +88,47 @@ import qualified DBus as T  data Object = Object-	{ objectPath :: T.ObjectPath-	, objectInterfaces :: [Interface]-	, objectChildren :: [Object]-	}-	deriving (Show, Eq)+    { objectPath :: T.ObjectPath+    , objectInterfaces :: [Interface]+    , objectChildren :: [Object]+    }+    deriving (Show, Eq)  object :: T.ObjectPath -> Object object path = Object path [] []  data Interface = Interface-	{ interfaceName :: T.InterfaceName-	, interfaceMethods :: [Method]-	, interfaceSignals :: [Signal]-	, interfaceProperties :: [Property]-	}-	deriving (Show, Eq)+    { interfaceName :: T.InterfaceName+    , interfaceMethods :: [Method]+    , interfaceSignals :: [Signal]+    , interfaceProperties :: [Property]+    }+    deriving (Show, Eq)  interface :: T.InterfaceName -> Interface interface name = Interface name [] [] []  data Method = Method-	{ methodName :: T.MemberName-	, methodArgs :: [MethodArg]-	}-	deriving (Show, Eq)+    { methodName :: T.MemberName+    , methodArgs :: [MethodArg]+    }+    deriving (Show, Eq)  method :: T.MemberName -> Method method name = Method name []  data MethodArg = MethodArg-	{ methodArgName :: String-	, methodArgType :: T.Type-	, methodArgDirection :: Direction-	}-	deriving (Show, Eq)+    { methodArgName :: String+    , methodArgType :: T.Type+    , methodArgDirection :: Direction+    }+    deriving (Show, Eq)  methodArg :: String -> T.Type -> Direction -> MethodArg methodArg = MethodArg  data Direction = In | Out-	deriving (Show, Eq)+    deriving (Show, Eq)  directionIn :: Direction directionIn = In@@ -137,146 +137,146 @@ directionOut = Out  data Signal = Signal-	{ signalName :: T.MemberName-	, signalArgs :: [SignalArg]-	}-	deriving (Show, Eq)+    { signalName :: T.MemberName+    , signalArgs :: [SignalArg]+    }+    deriving (Show, Eq)  signal :: T.MemberName -> Signal signal name = Signal name []  data SignalArg = SignalArg-	{ signalArgName :: String-	, signalArgType :: T.Type-	}-	deriving (Show, Eq)+    { signalArgName :: String+    , signalArgType :: T.Type+    }+    deriving (Show, Eq)  signalArg :: String -> T.Type -> SignalArg signalArg = SignalArg  data Property = Property-	{ propertyName :: String-	, propertyType :: T.Type-	, propertyRead :: Bool-	, propertyWrite :: Bool-	}-	deriving (Show, Eq)+    { propertyName :: String+    , propertyType :: T.Type+    , propertyRead :: Bool+    , propertyWrite :: Bool+    }+    deriving (Show, Eq)  property :: String -> T.Type -> Property property name t = Property name t False False  parseXML :: T.ObjectPath -> String -> Maybe Object parseXML path xml = do-	root <- parseElement (Data.Text.pack xml)-	parseRoot path root+    root <- parseElement (Data.Text.pack xml)+    parseRoot path root  parseElement :: Text -> Maybe X.Element parseElement xml = runST $ do-	stackRef <- ST.newSTRef [([], [])]-	let onError _ = do-		ST.writeSTRef stackRef []-		return False-	let onBegin _ attrs = do-		ST.modifySTRef stackRef ((attrs, []):)-		return True-	let onEnd name = do-		stack <- ST.readSTRef stackRef-		let (attrs, children'):stack' = stack-		let e = X.Element name attrs (map X.NodeElement (reverse children'))-		let (pAttrs, pChildren):stack'' = stack'-		let parent = (pAttrs, e:pChildren)-		ST.writeSTRef stackRef (parent:stack'')-		return True-	-	p <- SAX.newParserST Nothing-	SAX.setCallback p SAX.parsedBeginElement onBegin-	SAX.setCallback p SAX.parsedEndElement onEnd-	SAX.setCallback p SAX.reportError onError-	SAX.parseBytes p (Data.Text.Encoding.encodeUtf8 xml)-	SAX.parseComplete p-	stack <- ST.readSTRef stackRef-	return $ case stack of-		[] -> Nothing-		(_, children'):_ -> Just (head children')+    stackRef <- ST.newSTRef [([], [])]+    let onError _ = do+        ST.writeSTRef stackRef []+        return False+    let onBegin _ attrs = do+        ST.modifySTRef stackRef ((attrs, []):)+        return True+    let onEnd name = do+        stack <- ST.readSTRef stackRef+        let (attrs, children'):stack' = stack+        let e = X.Element name attrs (map X.NodeElement (reverse children'))+        let (pAttrs, pChildren):stack'' = stack'+        let parent = (pAttrs, e:pChildren)+        ST.writeSTRef stackRef (parent:stack'')+        return True +    p <- SAX.newParserST Nothing+    SAX.setCallback p SAX.parsedBeginElement onBegin+    SAX.setCallback p SAX.parsedEndElement onEnd+    SAX.setCallback p SAX.reportError onError+    SAX.parseBytes p (Data.Text.Encoding.encodeUtf8 xml)+    SAX.parseComplete p+    stack <- ST.readSTRef stackRef+    return $ case stack of+        [] -> Nothing+        (_, children'):_ -> Just (head children')+ parseRoot :: T.ObjectPath -> X.Element -> Maybe Object parseRoot defaultPath e = do-	path <- case X.attributeText "name" e of-		Nothing -> Just defaultPath-		Just x  -> T.parseObjectPath (Data.Text.unpack x)-	parseObject path e+    path <- case X.attributeText "name" e of+        Nothing -> Just defaultPath+        Just x  -> T.parseObjectPath (Data.Text.unpack x)+    parseObject path e  parseChild :: T.ObjectPath -> X.Element -> Maybe Object parseChild parentPath e = do-	let parentPath' = case T.formatObjectPath parentPath of-		"/" -> "/"-		x   -> x ++ "/"-	pathSegment <- X.attributeText "name" e-	path <- T.parseObjectPath (parentPath' ++ Data.Text.unpack pathSegment)-	parseObject path e+    let parentPath' = case T.formatObjectPath parentPath of+            "/" -> "/"+            x   -> x ++ "/"+    pathSegment <- X.attributeText "name" e+    path <- T.parseObjectPath (parentPath' ++ Data.Text.unpack pathSegment)+    parseObject path e  parseObject :: T.ObjectPath -> X.Element -> Maybe Object parseObject path e | X.elementName e == "node" = do-	interfaces <- children parseInterface (X.isNamed "interface") e-	children' <- children (parseChild path) (X.isNamed "node") e-	return (Object path interfaces children')+    interfaces <- children parseInterface (X.isNamed "interface") e+    children' <- children (parseChild path) (X.isNamed "node") e+    return (Object path interfaces children') parseObject _ _ = Nothing  parseInterface :: X.Element -> Maybe Interface parseInterface e = do-	name <- T.parseInterfaceName =<< attributeString "name" e-	methods <- children parseMethod (X.isNamed "method") e-	signals <- children parseSignal (X.isNamed "signal") e-	properties <- children parseProperty (X.isNamed "property") e-	return (Interface name methods signals properties)+    name <- T.parseInterfaceName =<< attributeString "name" e+    methods <- children parseMethod (X.isNamed "method") e+    signals <- children parseSignal (X.isNamed "signal") e+    properties <- children parseProperty (X.isNamed "property") e+    return (Interface name methods signals properties)  parseMethod :: X.Element -> Maybe Method parseMethod e = do-	name <- T.parseMemberName =<< attributeString "name" e-	args <- children parseMethodArg (isArg ["in", "out", ""]) e-	return (Method name args)+    name <- T.parseMemberName =<< attributeString "name" e+    args <- children parseMethodArg (isArg ["in", "out", ""]) e+    return (Method name args)  parseSignal :: X.Element -> Maybe Signal parseSignal e = do-	name <- T.parseMemberName =<< attributeString "name" e-	args <- children parseSignalArg (isArg ["out", ""]) e-	return (Signal name args)+    name <- T.parseMemberName =<< attributeString "name" e+    args <- children parseSignalArg (isArg ["out", ""]) e+    return (Signal name args)  parseType :: X.Element -> Maybe T.Type parseType e = do-	typeStr <- attributeString "type" e-	sig <- T.parseSignature typeStr-	case T.signatureTypes sig of-		[t] -> Just t-		_ -> Nothing+    typeStr <- attributeString "type" e+    sig <- T.parseSignature typeStr+    case T.signatureTypes sig of+        [t] -> Just t+        _ -> Nothing  parseMethodArg :: X.Element -> Maybe MethodArg parseMethodArg e = do-	t <- parseType e-	let dir = case getattr "direction" e of-		"out" -> Out-		_ -> In-	Just (MethodArg (getattr "name" e) t dir)+    t <- parseType e+    let dir = case getattr "direction" e of+            "out" -> Out+            _ -> In+    Just (MethodArg (getattr "name" e) t dir)  parseSignalArg :: X.Element -> Maybe SignalArg parseSignalArg e = do-	t <- parseType e-	Just (SignalArg (getattr "name" e) t)+    t <- parseType e+    Just (SignalArg (getattr "name" e) t)  isArg :: [String] -> X.Element -> [X.Element] isArg dirs = X.isNamed "arg" >=> checkDir where-	checkDir e = [e | getattr "direction" e `elem` dirs]+    checkDir e = [e | getattr "direction" e `elem` dirs]  parseProperty :: X.Element -> Maybe Property parseProperty e = do-	t <- parseType e-	(canRead, canWrite) <- case getattr "access" e of-		""          -> Just (False, False)-		"read"      -> Just (True, False)-		"write"     -> Just (False, True)-		"readwrite" -> Just (True, True)-		_           -> Nothing-	Just (Property (getattr "name" e) t canRead canWrite)+    t <- parseType e+    (canRead, canWrite) <- case getattr "access" e of+        ""          -> Just (False, False)+        "read"      -> Just (True, False)+        "write"     -> Just (False, True)+        "readwrite" -> Just (True, True)+        _           -> Nothing+    Just (Property (getattr "name" e) t canRead canWrite)  getattr :: X.Name -> X.Element -> String getattr name e = maybe "" Data.Text.unpack (X.attributeText name e)@@ -287,142 +287,142 @@ newtype XmlWriter a = XmlWriter { runXmlWriter :: Maybe (a, String) }  instance Functor XmlWriter where-	fmap = liftM+    fmap = liftM  instance Control.Applicative.Applicative XmlWriter where-	pure = return-	(<*>) = ap+    pure = return+    (<*>) = ap  instance Monad XmlWriter where-	return a = XmlWriter $ Just (a, "")-	m >>= f = XmlWriter $ do-		(a, w) <- runXmlWriter m-		(b, w') <- runXmlWriter (f a)-		return (b, w ++ w')+    return a = XmlWriter $ Just (a, "")+    m >>= f = XmlWriter $ do+        (a, w) <- runXmlWriter m+        (b, w') <- runXmlWriter (f a)+        return (b, w ++ w')  tell :: String -> XmlWriter () tell s = XmlWriter (Just ((), s))  formatXML :: Object -> Maybe String formatXML obj = do-	(_, xml) <- runXmlWriter (writeRoot obj)-	return xml+    (_, xml) <- runXmlWriter (writeRoot obj)+    return xml  writeRoot :: Object -> XmlWriter () writeRoot obj@(Object path _ _) = do-	tell "<!DOCTYPE node PUBLIC '-//freedesktop//DTD D-BUS Object Introspection 1.0//EN'"-	tell " 'http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd'>\n"-	writeObject (T.formatObjectPath path) obj+    tell "<!DOCTYPE node PUBLIC '-//freedesktop//DTD D-BUS Object Introspection 1.0//EN'"+    tell " 'http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd'>\n"+    writeObject (T.formatObjectPath path) obj  writeChild :: T.ObjectPath -> Object -> XmlWriter () writeChild parentPath obj@(Object path _ _) = write where-	path' = T.formatObjectPath path-	parent' = T.formatObjectPath  parentPath-	relpathM = if parent' `isPrefixOf` path'-		then Just $ if parent' == "/"-			then drop 1 path'-			else drop (length parent' + 1) path'-		else Nothing-	-	write = case relpathM of-		Just relpath -> writeObject relpath obj-		Nothing -> XmlWriter Nothing+    path' = T.formatObjectPath path+    parent' = T.formatObjectPath  parentPath+    relpathM = if parent' `isPrefixOf` path'+        then Just $ if parent' == "/"+            then drop 1 path'+            else drop (length parent' + 1) path'+        else Nothing +    write = case relpathM of+        Just relpath -> writeObject relpath obj+        Nothing -> XmlWriter Nothing+ writeObject :: String -> Object -> XmlWriter () writeObject path (Object fullPath interfaces children') = writeElement "node"-	[("name", path)] $ do-		mapM_ writeInterface interfaces-		mapM_ (writeChild fullPath) children'+    [("name", path)] $ do+        mapM_ writeInterface interfaces+        mapM_ (writeChild fullPath) children'  writeInterface :: Interface -> XmlWriter () writeInterface (Interface name methods signals properties) = writeElement "interface"-	[("name", T.formatInterfaceName name)] $ do-		mapM_ writeMethod methods-		mapM_ writeSignal signals-		mapM_ writeProperty properties+    [("name", T.formatInterfaceName name)] $ do+        mapM_ writeMethod methods+        mapM_ writeSignal signals+        mapM_ writeProperty properties  writeMethod :: Method -> XmlWriter () writeMethod (Method name args) = writeElement "method"-	[("name", T.formatMemberName name)] $ do-		mapM_ writeMethodArg args+    [("name", T.formatMemberName name)] $ do+        mapM_ writeMethodArg args  writeSignal :: Signal -> XmlWriter () writeSignal (Signal name args) = writeElement "signal"-	[("name", T.formatMemberName name)] $ do-		mapM_ writeSignalArg args+    [("name", T.formatMemberName name)] $ do+        mapM_ writeSignalArg args  formatType :: T.Type -> XmlWriter String formatType t = do-	sig <- case T.signature [t] of-		Just x -> return x-		Nothing -> XmlWriter Nothing-	return (T.formatSignature sig)+    sig <- case T.signature [t] of+        Just x -> return x+        Nothing -> XmlWriter Nothing+    return (T.formatSignature sig)  writeMethodArg :: MethodArg -> XmlWriter () writeMethodArg (MethodArg name t dir) = do-	typeStr <- formatType t-	let dirAttr = case dir of-		In -> "in"-		Out -> "out"-	writeEmptyElement "arg" $-		[ ("name", name)-		, ("type", typeStr)-		, ("direction", dirAttr)-		]+    typeStr <- formatType t+    let dirAttr = case dir of+            In -> "in"+            Out -> "out"+    writeEmptyElement "arg" $+        [ ("name", name)+        , ("type", typeStr)+        , ("direction", dirAttr)+        ]  writeSignalArg :: SignalArg -> XmlWriter () writeSignalArg (SignalArg name t) = do-	typeStr <- formatType t-	writeEmptyElement "arg" $-		[ ("name", name)-		, ("type", typeStr)-		]+    typeStr <- formatType t+    writeEmptyElement "arg" $+        [ ("name", name)+        , ("type", typeStr)+        ]  writeProperty :: Property -> XmlWriter () writeProperty (Property name t canRead canWrite) = do-	typeStr <- formatType t-	let readS = if canRead then "read" else ""-	let writeS = if canWrite then "write" else ""-	writeEmptyElement "property"-		[ ("name", name)-		, ("type", typeStr)-		, ("access", readS ++ writeS)-		]+    typeStr <- formatType t+    let readS = if canRead then "read" else ""+    let writeS = if canWrite then "write" else ""+    writeEmptyElement "property"+        [ ("name", name)+        , ("type", typeStr)+        , ("access", readS ++ writeS)+        ]  attributeString :: X.Name -> X.Element -> Maybe String attributeString name e = fmap Data.Text.unpack (X.attributeText name e)  writeElement :: String -> [(String, String)] -> XmlWriter () -> XmlWriter () writeElement name attrs content = do-	tell "<"-	tell name-	mapM_ writeAttribute attrs-	tell ">"-	content-	tell "</"-	tell name-	tell ">"+    tell "<"+    tell name+    mapM_ writeAttribute attrs+    tell ">"+    content+    tell "</"+    tell name+    tell ">"  writeEmptyElement :: String -> [(String, String)] -> XmlWriter () writeEmptyElement name attrs = do-	tell "<"-	tell name-	mapM_ writeAttribute attrs-	tell "/>"+    tell "<"+    tell name+    mapM_ writeAttribute attrs+    tell "/>"  writeAttribute :: (String, String) -> XmlWriter () writeAttribute (name, content) = do-	tell " "-	tell name-	tell "='"-	tell (escape content)-	tell "'"+    tell " "+    tell name+    tell "='"+    tell (escape content)+    tell "'"  escape :: String -> String escape = concatMap $ \c -> case c of-	'&' -> "&amp;"-	'<' -> "&lt;"-	'>' -> "&gt;"-	'"' -> "&quot;"-	'\'' -> "&apos;"-	_ -> [c]+    '&' -> "&amp;"+    '<' -> "&lt;"+    '>' -> "&gt;"+    '"' -> "&quot;"+    '\'' -> "&apos;"+    _ -> [c]

@@ -1,314 +0,0 @@--- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>------ 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 <http://www.gnu.org/licenses/>.--module DBus.Message-	( Message(..)-	-	, UnknownMessage(..)-	, MethodCall(..)-	, MethodReturn(..)-	, MethodError(..)-	, methodErrorMessage-	, Signal(..)-	, ReceivedMessage(..)-	-	-- for use in Wire-	, HeaderField(..)-	, setMethodCallFlags-	) where--import           Data.Bits ((.|.), (.&.))-import           Data.Maybe (fromMaybe, listToMaybe)-import           Data.Word (Word8, Word32)--import           DBus.Types--class Message a where-	messageTypeCode :: a -> Word8-	messageHeaderFields :: a -> [HeaderField]-	messageBody :: a -> [Variant]-	-	messageFlags :: a -> Word8-	messageFlags _ = 0--maybe' :: (a -> b) -> Maybe a -> [b]-maybe' f = maybe [] (\x' -> [f x'])--data UnknownMessage = UnknownMessage-	{ unknownMessageType :: Word8-	, unknownMessageSender :: Maybe BusName-	, unknownMessageBody :: [Variant]-	}-	deriving (Show, Eq)--data HeaderField-	= HeaderPath        ObjectPath-	| HeaderInterface   InterfaceName-	| HeaderMember      MemberName-	| HeaderErrorName   ErrorName-	| HeaderReplySerial Serial-	| HeaderDestination BusName-	| HeaderSender      BusName-	| HeaderSignature   Signature-	| HeaderUnixFds     Word32-	deriving (Show, Eq)---- | A method call is a request to run some procedure exported by the--- remote process. Procedures are identified by an (object_path,--- interface_name, method_name) tuple.-data MethodCall = MethodCall-	{-	-- | The object path of the method call. Conceptually, object paths-	-- act like a procedural language's pointers. Each object referenced-	-- by a path is a collection of procedures.-	  methodCallPath :: ObjectPath-	-	-- | The interface of the method call. Each object may implement any-	-- number of interfaces. Each method is part of at least one-	-- interface.-	---	-- In certain cases, this may be @Nothing@, but most users should set-	-- it to a value.-	, methodCallInterface :: Maybe InterfaceName-	-	-- | The method name of the method call. Method names are unique within-	-- an interface, but might not be unique within an object.-	, methodCallMember :: MemberName-	-	-- | The name of the application that sent this call.-	---	-- Most users will just leave this empty, because the bus overwrites-	-- the sender for security reasons. Setting the sender manually is-	-- used for peer-peer connections.-	---	-- Defaults to @Nothing@.-	, methodCallSender :: Maybe BusName-	-	-- | The name of the application to send the call to.-	---	-- Most users should set this. If a message with no destination is-	-- sent to the bus, the bus will behave as if the destination was-	-- set to @org.freedesktop.DBus@. For peer-peer connections, the-	-- destination can be empty because there is only one peer.-	---	-- Defaults to @Nothing@.-	, methodCallDestination :: Maybe BusName-	-	-- | Set whether a reply is expected. This can save network and cpu-	-- resources by inhibiting unnecessary replies.-	---	-- Defaults to @True@.-	, methodCallReplyExpected :: Bool-	-	-- | Set whether the bus should auto-start the remote-	---	-- Defaults to @True@.-	, methodCallAutoStart :: Bool-	-	-- | The arguments to the method call. See 'toVariant'.-	---	-- Defaults to @[]@.-	, methodCallBody :: [Variant]-	}-	deriving (Eq, Show)--setMethodCallFlags :: MethodCall -> Word8 -> MethodCall-setMethodCallFlags c w = c-	{ methodCallReplyExpected = w .&. 0x1 == 0-	, methodCallAutoStart = w .&. 0x2 == 0-	}--instance Message MethodCall where-	messageTypeCode _ = 1-	messageFlags c = foldr (.|.) 0-		[ if methodCallReplyExpected c then 0 else 0x1-		, if methodCallAutoStart c then 0 else 0x2-		]-	messageBody = methodCallBody-	messageHeaderFields m = concat-		[ [ HeaderPath (methodCallPath m)-		  , HeaderMember (methodCallMember m)-		  ]-		, maybe' HeaderInterface (methodCallInterface m)-		, maybe' HeaderSender (methodCallSender m)-		, maybe' HeaderDestination (methodCallDestination m)-		]---- | A method return is a reply to a method call, indicating that the call--- succeeded.-data MethodReturn = MethodReturn-	{-	-- | The serial of the original method call. This lets the original-	-- caller match up this reply to the pending call.-	  methodReturnSerial :: Serial-	-	-- | The name of the application that is returning from a call.-	---	-- Most users will just leave this empty, because the bus overwrites-	-- the sender for security reasons. Setting the sender manually is-	-- used for peer-peer connections.-	---	-- Defaults to @Nothing@.-	, methodReturnSender :: Maybe BusName-	-	-- | The name of the application that initiated the call.-	---	-- Most users should set this. If a message with no destination is-	-- sent to the bus, the bus will behave as if the destination was-	-- set to @org.freedesktop.DBus@. For peer-peer connections, the-	-- destination can be empty because there is only one peer.-	---	-- Defaults to @Nothing@.-	, methodReturnDestination :: Maybe BusName-	-	-- | Values returned from the method call. See 'toVariant'.-	---	-- Defaults to @[]@.-	, methodReturnBody :: [Variant]-	}-	deriving (Show, Eq)--instance Message MethodReturn where-	messageTypeCode _ = 2-	messageBody       = methodReturnBody-	messageHeaderFields m = concat-		[ [ HeaderReplySerial (methodReturnSerial m)-		  ]-		, maybe' HeaderSender (methodReturnSender m)-		, maybe' HeaderDestination (methodReturnDestination m)-		]---- | A method error is a reply to a method call, indicating that the call--- received an error and did not succeed.-data MethodError = MethodError-	{-	-- | The name of the error type. Names are used so clients can-	-- handle certain classes of error differently from others.-	  methodErrorName :: ErrorName-	-	-- | The serial of the original method call. This lets the original-	-- caller match up this reply to the pending call.-	, methodErrorSerial :: Serial-	-	-- | The name of the application that is returning from a call.-	---	-- Most users will just leave this empty, because the bus overwrites-	-- the sender for security reasons. Setting the sender manually is-	-- used for peer-peer connections.-	---	-- Defaults to @Nothing@.-	, methodErrorSender :: Maybe BusName-	-	-- | The name of the application that initiated the call.-	---	-- Most users should set this. If a message with no destination is-	-- sent to the bus, the bus will behave as if the destination was-	-- set to @org.freedesktop.DBus@. For peer-peer connections, the-	-- destination can be empty because there is only one peer.-	---	-- Defaults to @Nothing@.-	, methodErrorDestination :: Maybe BusName-	-	-- | Additional information about the error. By convention, if-	-- the error body contains any items, the first item should be a-	-- string describing the error.-	, methodErrorBody :: [Variant]-	}-	deriving (Show, Eq)--instance Message MethodError where-	messageTypeCode _ = 3-	messageBody       = methodErrorBody-	messageHeaderFields m = concat-		[ [ HeaderErrorName (methodErrorName m)-		  , HeaderReplySerial (methodErrorSerial m)-		  ]-		, maybe' HeaderSender (methodErrorSender m)-		, maybe' HeaderDestination (methodErrorDestination m)-		]---- | Get a human-readable description of the error, by returning the first--- item in the error body if it's a string.-methodErrorMessage :: MethodError -> String-methodErrorMessage err = fromMaybe "(no error message)" $ do-	field <- listToMaybe (methodErrorBody err)-	msg <- fromVariant field-	if null msg-		then Nothing-		else return msg---- | Signals are broadcast by applications to notify other clients of some--- event.-data Signal = Signal-	{-	-- | The path of the object that emitted this signal.-	  signalPath :: ObjectPath-	-	-- | The interface that this signal belongs to.-	, signalInterface :: InterfaceName-	-	-- | The name of this signal.-	, signalMember :: MemberName-	-	-- | The name of the application that emitted this signal.-	---	-- Most users will just leave this empty, because the bus overwrites-	-- the sender for security reasons. Setting the sender manually is-	-- used for peer-peer connections.-	---	-- Defaults to @Nothing@.-	, signalSender :: Maybe BusName-	-	-- | The name of the application to emit the signal to. If @Nothing@,-	-- the signal is sent to any application that has registered an-	-- appropriate match rule.-	---	-- Defaults to @Nothing@.-	, signalDestination :: Maybe BusName-	-	-- | Additional information about the signal, such as the new value-	-- or the time.-	---	-- Defaults to @[]@.-	, signalBody :: [Variant]-	}-	deriving (Show, Eq)--instance Message Signal where-	messageTypeCode _ = 4-	messageBody       = signalBody-	messageHeaderFields m = concat-		[ [ HeaderPath (signalPath m)-		  , HeaderMember (signalMember m)-		  , HeaderInterface (signalInterface m)-		  ]-		, maybe' HeaderSender (signalSender m)-		, maybe' HeaderDestination (signalDestination m)-		]---- | Not an actual message type, but a wrapper around messages received from--- the bus. Each value contains the message's 'Serial'.------ If casing against these constructors, always include a default case to--- handle messages of an unknown type. New message types may be added to the--- D-Bus specification, and applications should handle them gracefully by--- either ignoring or logging them.-data ReceivedMessage-	= ReceivedMethodCall Serial MethodCall-	| ReceivedMethodReturn Serial MethodReturn-	| ReceivedMethodError Serial MethodError-	| ReceivedSignal Serial Signal-	| ReceivedUnknown Serial UnknownMessage-	deriving (Show, Eq)

@@ -22,46 +22,46 @@ -- -- Most users will want to use the "DBus.Client" module instead. module DBus.Socket-	(-	-	-- * Sockets-	  Socket-	, send-	, receive-	-	-- * Socket errors-	, SocketError-	, socketError-	, socketErrorMessage-	, socketErrorFatal-	, socketErrorAddress-	-	-- * Socket options-	, SocketOptions-	, socketAuthenticator-	, socketTransportOptions-	, defaultSocketOptions-	-	-- * Opening and closing sockets-	, open-	, openWith-	, close-	-	-- * Listening for connections-	, SocketListener-	, listen-	, listenWith-	, accept-	, closeListener-	, socketListenerAddress-	-	-- * Authentication-	, Authenticator-	, authenticator-	, authenticatorClient-	, authenticatorServer-	) where+    ( +    -- * Sockets+      Socket+    , send+    , receive++    -- * Socket errors+    , SocketError+    , socketError+    , socketErrorMessage+    , socketErrorFatal+    , socketErrorAddress++    -- * Socket options+    , SocketOptions+    , socketAuthenticator+    , socketTransportOptions+    , defaultSocketOptions++    -- * Opening and closing sockets+    , open+    , openWith+    , close++    -- * Listening for connections+    , SocketListener+    , listen+    , listenWith+    , accept+    , closeListener+    , socketListenerAddress++    -- * Authentication+    , Authenticator+    , authenticator+    , authenticatorClient+    , authenticatorServer+    ) where+ import           Prelude hiding (getLine)  import           Control.Concurrent@@ -78,16 +78,16 @@  import           DBus import           DBus.Transport-import           DBus.Wire (unmarshalMessageM)+import           DBus.Internal.Wire (unmarshalMessageM)  -- | Stores information about an error encountered while creating or using a -- 'Socket'. data SocketError = SocketError-	{ socketErrorMessage :: String-	, socketErrorFatal :: Bool-	, socketErrorAddress :: Maybe Address-	}-	deriving (Eq, Show, Typeable)+    { socketErrorMessage :: String+    , socketErrorFatal :: Bool+    , socketErrorAddress :: Maybe Address+    }+    deriving (Eq, Show, Typeable)  instance Exception SocketError @@ -97,58 +97,58 @@ data SomeTransport = forall t. (Transport t) => SomeTransport t  instance Transport SomeTransport where-	data TransportOptions SomeTransport = SomeTransportOptions-	transportDefaultOptions = SomeTransportOptions-	transportPut (SomeTransport t) = transportPut t-	transportGet (SomeTransport t) = transportGet t-	transportClose (SomeTransport t) = transportClose t+    data TransportOptions SomeTransport = SomeTransportOptions+    transportDefaultOptions = SomeTransportOptions+    transportPut (SomeTransport t) = transportPut t+    transportGet (SomeTransport t) = transportGet t+    transportClose (SomeTransport t) = transportClose t  -- | An open socket to another process. Messages can be sent to the remote -- peer using 'send', or received using 'receive'. data Socket = Socket-	{ socketTransport :: SomeTransport-	, socketAddress :: Maybe Address-	, socketSerial :: IORef Serial-	, socketReadLock :: MVar ()-	, socketWriteLock :: MVar ()-	}+    { socketTransport :: SomeTransport+    , socketAddress :: Maybe Address+    , socketSerial :: IORef Serial+    , socketReadLock :: MVar ()+    , socketWriteLock :: MVar ()+    }  -- | An Authenticator defines how the local peer (client) authenticates -- itself to the remote peer (server). data Authenticator t = Authenticator-	{-	-- | Defines the client-side half of an authenticator.-	  authenticatorClient :: t -> IO Bool-	-	-- | Defines the server-side half of an authenticator. The UUID is-	-- allocated by the socket listener.-	, authenticatorServer :: t -> UUID -> IO Bool-	}+    {+    -- | Defines the client-side half of an authenticator.+      authenticatorClient :: t -> IO Bool +    -- | Defines the server-side half of an authenticator. The UUID is+    -- allocated by the socket listener.+    , authenticatorServer :: t -> UUID -> IO Bool+    }+ -- | Used with 'openWith' and 'listenWith' to provide custom authenticators or -- transport options. data SocketOptions t = SocketOptions-	{-	-- | Used to perform authentication with the remote peer. After a-	-- transport has been opened, it will be passed to the authenticator.-	-- If the authenticator returns true, then the socket was-	-- authenticated.-	  socketAuthenticator :: Authenticator t-	-	-- | Options for the underlying transport, to be used by custom transports-	-- for controlling how to connect to the remote peer.-	---	-- See "DBus.Transport" for details on defining custom transports-	, socketTransportOptions :: TransportOptions t-	}+    {+    -- | Used to perform authentication with the remote peer. After a+    -- transport has been opened, it will be passed to the authenticator.+    -- If the authenticator returns true, then the socket was+    -- authenticated.+      socketAuthenticator :: Authenticator t +    -- | Options for the underlying transport, to be used by custom transports+    -- for controlling how to connect to the remote peer.+    --+    -- See "DBus.Transport" for details on defining custom transports+    , socketTransportOptions :: TransportOptions t+    }+ -- | Default 'SocketOptions', which uses the default Unix/TCP transport and -- authenticator. defaultSocketOptions :: SocketOptions SocketTransport defaultSocketOptions = SocketOptions-	{ socketTransportOptions = transportDefaultOptions-	, socketAuthenticator = authExternal-	}+    { socketTransportOptions = transportDefaultOptions+    , socketAuthenticator = authExternal+    }  -- | Open a socket to a remote peer listening at the given address. --@@ -168,19 +168,19 @@ -- Throws 'SocketError' on failure. openWith :: TransportOpen t => SocketOptions t -> Address -> IO Socket openWith opts addr = toSocketError (Just addr) $ bracketOnError-	(transportOpen (socketTransportOptions opts) addr)-	transportClose-	(\t -> do-		authed <- authenticatorClient (socketAuthenticator opts) t-		if not authed-			then throwIO (socketError "Authentication failed")-				{ socketErrorAddress = Just addr-				}-			else do-				serial <- newIORef firstSerial-				readLock <- newMVar ()-				writeLock <- newMVar ()-				return (Socket (SomeTransport t) (Just addr) serial readLock writeLock))+    (transportOpen (socketTransportOptions opts) addr)+    transportClose+    (\t -> do+        authed <- authenticatorClient (socketAuthenticator opts) t+        if not authed+            then throwIO (socketError "Authentication failed")+                { socketErrorAddress = Just addr+                }+            else do+                serial <- newIORef firstSerial+                readLock <- newMVar ()+                writeLock <- newMVar ()+                return (Socket (SomeTransport t) (Just addr) serial readLock writeLock))  data SocketListener = forall t. (TransportListen t) => SocketListener (TransportListener t) (Authenticator t) @@ -208,27 +208,27 @@ -- Throws 'SocketError' on failure. listenWith :: TransportListen t => SocketOptions t -> Address -> IO SocketListener listenWith opts addr = toSocketError (Just addr) $ bracketOnError-	(transportListen (socketTransportOptions opts) addr)-	transportListenerClose-	(\l -> return (SocketListener l (socketAuthenticator opts)))+    (transportListen (socketTransportOptions opts) addr)+    transportListenerClose+    (\l -> return (SocketListener l (socketAuthenticator opts)))  -- | Accept a new connection from a socket listener. -- -- Throws 'SocketError' on failure. accept :: SocketListener -> IO Socket accept (SocketListener l auth) = toSocketError Nothing $ bracketOnError-	(transportAccept l)-	transportClose-	(\t -> do-		let uuid = transportListenerUUID l-		authed <- authenticatorServer auth t uuid-		if not authed-			then throwIO (socketError "Authentication failed")-			else do-				serial <- newIORef firstSerial-				readLock <- newMVar ()-				writeLock <- newMVar ()-				return (Socket (SomeTransport t) Nothing serial readLock writeLock))+    (transportAccept l)+    transportClose+    (\t -> do+        let uuid = transportListenerUUID l+        authed <- authenticatorServer auth t uuid+        if not authed+            then throwIO (socketError "Authentication failed")+            else do+                serial <- newIORef firstSerial+                readLock <- newMVar ()+                writeLock <- newMVar ()+                return (Socket (SomeTransport t) Nothing serial readLock writeLock))  -- | Close an open 'Socket'. Once closed, the socket is no longer valid and -- must not be used.@@ -256,16 +256,16 @@ -- Throws 'SocketError' on failure. send :: Message msg => Socket -> msg -> (Serial -> IO a) -> IO a send sock msg io = toSocketError (socketAddress sock) $ do-	serial <- nextSocketSerial sock-	case marshal LittleEndian serial msg of-		Right bytes -> do-			let t = socketTransport sock-			a <- io serial-			withMVar (socketWriteLock sock) (\_ -> transportPut t bytes)-			return a-		Left err -> throwIO (socketError ("Message cannot be sent: " ++ show err))-			{ socketErrorFatal = False-			}+    serial <- nextSocketSerial sock+    case marshal LittleEndian serial msg of+        Right bytes -> do+            let t = socketTransport sock+            a <- io serial+            withMVar (socketWriteLock sock) (\_ -> transportPut t bytes)+            return a+        Left err -> throwIO (socketError ("Message cannot be sent: " ++ show err))+            { socketErrorFatal = False+            }  nextSocketSerial :: Socket -> IO Serial nextSocketSerial sock = atomicModifyIORef (socketSerial sock) (\x -> (nextSerial x, x))@@ -279,34 +279,34 @@ -- Throws 'SocketError' on failure. receive :: Socket -> IO ReceivedMessage receive sock = toSocketError (socketAddress sock) $ do-	-- TODO: after reading the length, read all bytes from the-	--       handle, then return a closure to perform the parse-	--       outside of the lock.-	let t = socketTransport sock-	let get n = if n == 0-		then return Data.ByteString.empty-		else transportGet t n-	received <- withMVar (socketReadLock sock) (\_ -> unmarshalMessageM get)-	case received of-		Left err -> throwIO (socketError ("Error reading message from socket: " ++ show err))-		Right msg -> return msg+    -- TODO: after reading the length, read all bytes from the+    --       handle, then return a closure to perform the parse+    --       outside of the lock.+    let t = socketTransport sock+    let get n = if n == 0+            then return Data.ByteString.empty+            else transportGet t n+    received <- withMVar (socketReadLock sock) (\_ -> unmarshalMessageM get)+    case received of+        Left err -> throwIO (socketError ("Error reading message from socket: " ++ show err))+        Right msg -> return msg  toSocketError :: Maybe Address -> IO a -> IO a toSocketError addr io = catches io handlers where-	handlers =-		[ Handler catchTransportError-		, Handler updateSocketError-		, Handler catchIOException-		]-	catchTransportError err = throwIO (socketError (transportErrorMessage err))-		{ socketErrorAddress = addr-		}-	updateSocketError err = throwIO err-		{ socketErrorAddress = mplus (socketErrorAddress err) addr-		}-	catchIOException exc = throwIO (socketError (show (exc :: IOException)))-		{ socketErrorAddress = addr-		}+    handlers =+        [ Handler catchTransportError+        , Handler updateSocketError+        , Handler catchIOException+        ]+    catchTransportError err = throwIO (socketError (transportErrorMessage err))+        { socketErrorAddress = addr+        }+    updateSocketError err = throwIO err+        { socketErrorAddress = mplus (socketErrorAddress err) addr+        }+    catchIOException exc = throwIO (socketError (show (exc :: IOException)))+        { socketErrorAddress = addr+        }  -- | An empty authenticator. Use 'authenticatorClient' or 'authenticatorServer' -- to control how the authentication is performed.@@ -328,64 +328,64 @@ -- passing over a Unix socket. authExternal :: Authenticator SocketTransport authExternal = authenticator-	{ authenticatorClient = clientAuthExternal-	, authenticatorServer = serverAuthExternal-	}+    { authenticatorClient = clientAuthExternal+    , authenticatorServer = serverAuthExternal+    }  clientAuthExternal :: SocketTransport -> IO Bool clientAuthExternal t = do-	transportPut t (Data.ByteString.pack [0])-	uid <- System.Posix.User.getRealUserID-	let token = concatMap (printf "%02X" . ord) (show uid)-	transportPutLine t ("AUTH EXTERNAL " ++ token)-	resp <- transportGetLine t-	case splitPrefix "OK " resp of-		Just _ -> do-			transportPutLine t "BEGIN"-			return True-		Nothing -> return False+    transportPut t (Data.ByteString.pack [0])+    uid <- System.Posix.User.getRealUserID+    let token = concatMap (printf "%02X" . ord) (show uid)+    transportPutLine t ("AUTH EXTERNAL " ++ token)+    resp <- transportGetLine t+    case splitPrefix "OK " resp of+        Just _ -> do+            transportPutLine t "BEGIN"+            return True+        Nothing -> return False  serverAuthExternal :: SocketTransport -> UUID -> IO Bool serverAuthExternal t uuid = do-	let waitForBegin = do-		resp <- transportGetLine t-		if resp == "BEGIN"-			then return ()-			else waitForBegin-	-	let checkToken token = do-		(_, uid, _) <- socketTransportCredentials t-		let wantToken = concatMap (printf "%02X" . ord) (show uid)-		if token == wantToken-			then do-				transportPutLine t ("OK " ++ formatUUID uuid)-				waitForBegin-				return True-			else return False-	-	c <- transportGet t 1-	if c /= Char8.pack "\x00"-		then return False-		else do-			line <- transportGetLine t-			case splitPrefix "AUTH EXTERNAL " line of-				Just token -> checkToken token-				Nothing -> if line == "AUTH EXTERNAL"-					then do-						dataLine <- transportGetLine t-						case splitPrefix "DATA " dataLine of-							Just token -> checkToken token-							Nothing -> return False-					else return False+    let waitForBegin = do+        resp <- transportGetLine t+        if resp == "BEGIN"+            then return ()+            else waitForBegin +    let checkToken token = do+        (_, uid, _) <- socketTransportCredentials t+        let wantToken = concatMap (printf "%02X" . ord) (show uid)+        if token == wantToken+            then do+                transportPutLine t ("OK " ++ formatUUID uuid)+                waitForBegin+                return True+            else return False++    c <- transportGet t 1+    if c /= Char8.pack "\x00"+        then return False+        else do+            line <- transportGetLine t+            case splitPrefix "AUTH EXTERNAL " line of+                Just token -> checkToken token+                Nothing -> if line == "AUTH EXTERNAL"+                    then do+                        dataLine <- transportGetLine t+                        case splitPrefix "DATA " dataLine of+                            Just token -> checkToken token+                            Nothing -> return False+                    else return False+ transportPutLine :: Transport t => t -> String -> IO () transportPutLine t line = transportPut t (Char8.pack (line ++ "\r\n"))  transportGetLine :: Transport t => t -> IO String transportGetLine t = do-	let getchr = Char8.head `fmap` transportGet t 1-	raw <- readUntil "\r\n" getchr-	return (dropEnd 2 raw)+    let getchr = Char8.head `fmap` transportGet t 1+    raw <- readUntil "\r\n" getchr+    return (dropEnd 2 raw)  -- | Drop /n/ items from the end of a list dropEnd :: Int -> [a] -> [a]@@ -393,16 +393,16 @@  splitPrefix :: String -> String -> Maybe String splitPrefix prefix str = if isPrefixOf prefix str-	then Just (drop (length prefix) str)-	else Nothing+    then Just (drop (length prefix) str)+    else 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)+    guard' = reverse guard+    step xs | isPrefixOf guard' xs = return (reverse xs)+            | otherwise            = readUntil' xs+    readUntil' xs = do+        x <- getx+        step (x:xs)