dbus 0.10.15 → 1.4.3
raw patch · 41 files changed
Files
- benchmarks/DBusBenchmarks.hs +0/−89
- dbus.cabal +68/−63
- examples/dbus-monitor.hs +10/−11
- examples/export.hs +23/−18
- examples/introspect.hs +13/−14
- examples/list-names.hs +9/−10
- idlxml/dbus.xml +90/−0
- lib/DBus.hs +48/−19
- lib/DBus/Client.hs +1407/−962
- lib/DBus/Generation.hs +552/−0
- lib/DBus/Internal/Address.hs +23/−26
- lib/DBus/Internal/Types.hs +320/−181
- lib/DBus/Internal/Wire.hs +96/−63
- lib/DBus/Introspection.hs +4/−425
- lib/DBus/Introspection/Parse.hs +146/−0
- lib/DBus/Introspection/Render.hs +107/−0
- lib/DBus/Introspection/Types.hs +54/−0
- lib/DBus/Socket.hs +89/−50
- lib/DBus/TH.hs +15/−0
- lib/DBus/Transport.hs +106/−44
- license.txt +169/−641
- tests/DBusTests.hs +12/−11
- tests/DBusTests/Address.hs +9/−10
- tests/DBusTests/BusName.hs +9/−10
- tests/DBusTests/Client.hs +271/−72
- tests/DBusTests/ErrorName.hs +9/−10
- tests/DBusTests/Generation.hs +39/−0
- tests/DBusTests/Integration.hs +21/−15
- tests/DBusTests/InterfaceName.hs +9/−10
- tests/DBusTests/Introspection.hs +61/−70
- tests/DBusTests/MemberName.hs +9/−10
- tests/DBusTests/Message.hs +9/−10
- tests/DBusTests/ObjectPath.hs +9/−10
- tests/DBusTests/Serialization.hs +17/−19
- tests/DBusTests/Signature.hs +9/−10
- tests/DBusTests/Socket.hs +74/−41
- tests/DBusTests/TH.hs +9/−0
- tests/DBusTests/Transport.hs +120/−42
- tests/DBusTests/Util.hs +48/−27
- tests/DBusTests/Variant.hs +9/−10
- tests/DBusTests/Wire.hs +47/−11
− benchmarks/DBusBenchmarks.hs
@@ -1,89 +0,0 @@-{-# 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/>.--module Main (benchmarks, main) where--import Criterion.Types-import Data.Word (Word32)-import Unsafe.Coerce (unsafeCoerce)-import qualified Criterion.Main--import DBus--serial :: Word32 -> Serial-serial = unsafeCoerce -- FIXME: should the Serial constructor be exposed to- -- clients?--empty_MethodCall :: MethodCall-empty_MethodCall = methodCall "/" "org.i" "m"--empty_MethodReturn :: MethodReturn-empty_MethodReturn = methodReturn (serial 0)--benchMarshal :: Message msg => String -> msg -> Benchmark-benchMarshal name msg = bench name (whnf (marshal LittleEndian (serial 0)) msg)--benchUnmarshal :: Message msg => String -> msg -> Benchmark-benchUnmarshal name msg = bench name (whnf unmarshal bytes) where- 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- ]- ]--main :: IO ()-main = Criterion.Main.defaultMain benchmarks
dbus.cabal view
@@ -1,11 +1,11 @@ name: dbus-version: 0.10.15-license: GPL-3+version: 1.4.3+license: Apache-2.0 license-file: license.txt author: John Millikin <john@john-millikin.com>-maintainer: Andrey Sverdlichenko <blaze@ruddy.ru>+maintainer: Andrey Sverdlichenko <blaze@rusty.zone> build-type: Simple-cabal-version: >= 1.8+cabal-version: >= 1.10 category: Network, Desktop stability: experimental homepage: https://github.com/rblaze/haskell-dbus#readme@@ -34,18 +34,18 @@ . main = do   client <- connectSession-   //-   \-- Request a list of connected clients from the bus+  +   -- 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])+  +   -- 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.+  +   -- Print each name on a line, sorted so reserved names are below+   -- temporary names.   mapM_ putStrLn (sort names) @ .@@ -69,78 +69,93 @@ examples/export.hs examples/introspect.hs examples/list-names.hs+ idlxml/dbus.xml source-repository head type: git location: https://github.com/rblaze/haskell-dbus library+ default-language: Haskell2010 ghc-options: -W -Wall hs-source-dirs: lib build-depends:- base >=4 && <5- , bytestring- , cereal- , containers- , deepseq- , libxml-sax- , network- , parsec- , random- , text- , transformers- , unix- , vector- , xml-types+ base >=4.16 && <5+ , bytestring < 0.13+ , cereal < 0.6+ , conduit >= 1.3.0 && < 1.4+ , containers < 0.9+ , deepseq < 1.6+ , exceptions < 0.11+ , filepath < 1.6+ , lens < 5.4+ , network >= 3.2 && < 3.3+ , parsec < 3.2+ , random < 1.4+ , split < 0.3+ , template-haskell >= 2.18 && < 2.25+ , text < 2.2+ , th-lift < 0.9+ , transformers < 0.7+ , unix < 2.9+ , vector < 0.14+ , xml-conduit >= 1.9.0.0 && < 1.11.0.0+ , xml-types < 0.4 exposed-modules: DBus DBus.Client- DBus.Introspection- DBus.Socket- DBus.Transport+ DBus.Generation DBus.Internal.Address DBus.Internal.Message DBus.Internal.Types DBus.Internal.Wire+ DBus.Introspection+ DBus.Introspection.Parse+ DBus.Introspection.Render+ DBus.Introspection.Types+ DBus.Socket+ DBus.TH+ DBus.Transport test-suite dbus_tests type: exitcode-stdio-1.0 main-is: DBusTests.hs hs-source-dirs: tests- ghc-options: -W -Wall+ default-language: Haskell2010+ ghc-options: -W -Wall -fno-warn-orphans build-depends: dbus- , base- , bytestring- , cereal- , containers- , directory- , extra- , filepath- , libxml-sax- , network- , parsec- , process- , QuickCheck- , random- , resourcet- , tasty- , tasty-hunit- , tasty-quickcheck- , text- , transformers- , unix- , vector- , xml-types+ , base >=4 && <5+ , bytestring < 0.13+ , cereal < 0.6+ , containers < 0.9+ , directory < 1.4+ , extra < 1.9+ , filepath < 1.6+ , network >= 3.2 && < 3.3+ , parsec < 3.2+ , process < 1.7+ , QuickCheck < 2.19+ , random < 1.4+ , resourcet < 1.4+ , tasty < 1.6+ , tasty-hunit < 0.11+ , tasty-quickcheck < 0.12+ , temporary >= 1.3 && < 1.4+ , text < 2.2+ , transformers < 0.7+ , unix < 2.9+ , vector < 0.14 other-modules: DBusTests.Address DBusTests.BusName DBusTests.Client DBusTests.ErrorName+ DBusTests.Generation DBusTests.Integration DBusTests.InterfaceName DBusTests.Introspection@@ -150,18 +165,8 @@ DBusTests.Serialization DBusTests.Signature DBusTests.Socket+ DBusTests.TH 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 -fno-warn-orphans-- build-depends:- dbus- , base- , criterion
examples/dbus-monitor.hs view
@@ -2,18 +2,17 @@ -- 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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module Main (main) where @@ -106,7 +105,7 @@ putStrLn (formatMessage received ++ "\n") -- Message formatting is verbose and mostly uninteresting, except as an--- excersise in string manipulation.+-- exercise in string manipulation. formatMessage :: ReceivedMessage -> String
examples/export.hs view
@@ -2,18 +2,17 @@ -- 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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module Main (main) where @@ -45,14 +44,20 @@ 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")- ]+ export client "/a" defaultInterface+ { interfaceName = "test.iface_1"+ , interfaceMethods =+ [ autoMethod "Foo" (onFoo "hello" "a")+ , autoMethod "Bar" (onBar "hello" "a")+ ]+ }+ export client "/b" defaultInterface+ { interfaceName = "test.iface_2"+ , interfaceMethods =+ [ autoMethod "Foo" (onFoo "hello")+ , autoMethod "Bar" (onBar "hello")+ ]+ } putStrLn "Exported objects /a and /b to bus name com.example.exporting"
examples/introspect.hs view
@@ -2,18 +2,17 @@ -- 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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module Main (main) where @@ -77,10 +76,10 @@ printMethodArg :: I.MethodArg -> IO () printMethodArg arg = do- let dir = case I.methodArgDirection arg of- d | d == I.directionIn -> "IN "- d | d == I.directionOut -> "OUT"- _ -> " "+ let dir =+ case I.methodArgDirection arg of+ I.In -> "IN "+ I.Out -> "OUT" putStr (" [" ++ dir ++ " ") putStr (show (formatSignature (signature_ [I.methodArgType arg])) ++ "] ") putStrLn (I.methodArgName arg)
examples/list-names.hs view
@@ -2,18 +2,17 @@ -- 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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module Main (main) where
+ idlxml/dbus.xml view
@@ -0,0 +1,90 @@+<node>+ <interface name="org.freedesktop.DBus">+ <method name="Hello">+ <arg direction="out" type="s"/>+ </method>+ <method name="RequestName">+ <arg direction="in" type="s"/>+ <arg direction="in" type="u"/>+ <arg direction="out" type="u"/>+ </method>+ <method name="ReleaseName">+ <arg direction="in" type="s"/>+ <arg direction="out" type="u"/>+ </method>+ <method name="StartServiceByName">+ <arg direction="in" type="s"/>+ <arg direction="in" type="u"/>+ <arg direction="out" type="u"/>+ </method>+ <method name="UpdateActivationEnvironment">+ <arg direction="in" type="a{ss}"/>+ </method>+ <method name="NameHasOwner">+ <arg direction="in" type="s"/>+ <arg direction="out" type="b"/>+ </method>+ <method name="ListNames">+ <arg direction="out" type="as"/>+ </method>+ <method name="ListActivatableNames">+ <arg direction="out" type="as"/>+ </method>+ <method name="AddMatch">+ <arg direction="in" type="s"/>+ </method>+ <method name="RemoveMatch">+ <arg direction="in" type="s"/>+ </method>+ <method name="GetNameOwner">+ <arg direction="in" type="s"/>+ <arg direction="out" type="s"/>+ </method>+ <method name="ListQueuedOwners">+ <arg direction="in" type="s"/>+ <arg direction="out" type="as"/>+ </method>+ <method name="GetConnectionUnixUser">+ <arg direction="in" type="s"/>+ <arg direction="out" type="u"/>+ </method>+ <method name="GetConnectionUnixProcessID">+ <arg direction="in" type="s"/>+ <arg direction="out" type="u"/>+ </method>+ <method name="GetAdtAuditSessionData">+ <arg direction="in" type="s"/>+ <arg direction="out" type="ay"/>+ </method>+ <method name="GetConnectionSELinuxSecurityContext">+ <arg direction="in" type="s"/>+ <arg direction="out" type="ay"/>+ </method>+ <method name="ReloadConfig">+ </method>+ <method name="GetId">+ <arg direction="out" type="s"/>+ </method>+ <method name="GetConnectionCredentials">+ <arg direction="in" type="s"/>+ <arg direction="out" type="a{sv}"/>+ </method>+ <property name="Features" type="as" access="read">+ <annotation name="org.freedesktop.DBus.Property.EmitsChangedSignal" value="const"/>+ </property>+ <property name="Interfaces" type="as" access="read">+ <annotation name="org.freedesktop.DBus.Property.EmitsChangedSignal" value="const"/>+ </property>+ <signal name="NameOwnerChanged">+ <arg type="s"/>+ <arg type="s"/>+ <arg type="s"/>+ </signal>+ <signal name="NameLost">+ <arg type="s"/>+ </signal>+ <signal name="NameAcquired">+ <arg type="s"/>+ </signal>+ </interface>+</node>
lib/DBus.hs view
@@ -1,17 +1,16 @@ -- 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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. -- | Basic types, useful to every D-Bus application. --@@ -76,6 +75,7 @@ , IsAtom , IsValue , typeOf+ , typeOf' -- * Signatures , Signature@@ -150,11 +150,13 @@ -- ** Marshal , marshal+ , marshalWithFds , MarshalError , marshalErrorMessage -- ** Unmarshal , unmarshal+ , unmarshalWithFds , UnmarshalError , unmarshalErrorMessage @@ -172,7 +174,9 @@ import Control.Monad (replicateM) import qualified Data.ByteString.Char8 as Char8+import Data.Proxy (Proxy(..)) import Data.Word (Word16)+import System.Posix.Types (Fd) import System.Random (randomRIO) import Text.Printf (printf) @@ -182,24 +186,31 @@ import DBus.Internal.Types hiding (typeOf) import DBus.Internal.Wire --- | Get the D-Bus type corresponding to the given Haskell value. The value+-- | Deprecated. Get the D-Bus type corresponding to the given Haskell value. The value -- may be @undefined@. typeOf :: IsValue a => a -> Type typeOf = DBus.Internal.Types.typeOf +-- | Get the D-Bus type corresponding to the given Haskell type @a@.+typeOf' :: IsValue a => Proxy a -> Type+typeOf' = DBus.Internal.Types.typeOf_+ -- | Construct a new 'MethodCall' for the given object, interface, and method. -- -- Use fields such as 'methodCallDestination' and 'methodCallBody' to populate -- a 'MethodCall'. ----- @---{-\# LANGUAGE OverloadedStrings \#-}+-- >>> :seti -XOverloadedStrings -----methodCall \"/\" \"org.example.Math\" \"Add\"--- { 'methodCallDestination' = Just \"org.example.Calculator\"--- , 'methodCallBody' = ['toVariant' (1 :: Int32), 'toVariant' (2 :: Int32)]+-- >>> import Data.Int+--+-- >>> :{+-- (methodCall "/" "org.example.Math" "Add")+-- { methodCallDestination = Just "org.example.Calculator"+-- , methodCallBody = [toVariant (1 :: Int32), toVariant (2 :: Int32)] -- }--- @+-- :}+-- MethodCall {methodCallPath = ObjectPath "/", methodCallInterface = Just (InterfaceName "org.example.Math"), methodCallMember = MemberName "Add", methodCallSender = Nothing, methodCallDestination = Just (BusName "org.example.Calculator"), methodCallReplyExpected = True, methodCallAutoStart = True, methodCallBody = [Variant 1,Variant 2]} methodCall :: ObjectPath -> InterfaceName -> MemberName -> MethodCall methodCall path iface member = MethodCall path (Just iface) member Nothing Nothing True True [] @@ -251,14 +262,32 @@ -- possible for marshaling to fail; if this occurs, an error will be -- returned instead. marshal :: Message msg => Endianness -> Serial -> msg -> Either MarshalError Char8.ByteString-marshal = marshalMessage+marshal end serial msg = fst <$> marshalWithFds end serial msg +-- | Convert a 'Message' into a 'Char8.ByteString' along with all 'Fd' values+-- mentioned in the message (the marshaled bytes will contain indices into+-- this list). Although unusual, it is possible for marshaling to fail; if this+-- occurs, an error will be returned instead.+marshalWithFds :: Message msg => Endianness -> Serial -> msg -> Either MarshalError (Char8.ByteString, [Fd])+marshalWithFds = marshalMessage+ -- | Parse a 'Char8.ByteString' into a 'ReceivedMessage'. The result can be -- inspected to see what type of message was parsed. Unknown message types -- can still be parsed successfully, as long as they otherwise conform to -- the D-Bus standard.+--+-- Unmarshaling will fail if the message contains file descriptors. If you+-- need file descriptor support then use 'unmarshalWithFds' instead. unmarshal :: Char8.ByteString -> Either UnmarshalError ReceivedMessage-unmarshal = unmarshalMessage+unmarshal bs = unmarshalWithFds bs []++-- | Parse a 'Char8.ByteString' into a 'ReceivedMessage'. The 'Fd' values are needed+-- because the marshaled message contains indices into the 'Fd' list rather then+-- 'Fd' values directly. The result can be inspected to see what type of message+-- was parsed. Unknown message types can still be parsed successfully, as long+-- as they otherwise conform to the D-Bus standard.+unmarshalWithFds :: Char8.ByteString -> [Fd] -> Either UnmarshalError ReceivedMessage+unmarshalWithFds = unmarshalMessage -- | A D-Bus UUID is 128 bits of data, usually randomly generated. They are -- used for identifying unique server instances to clients.
lib/DBus/Client.hs view
@@ -1,965 +1,1410 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE OverloadedStrings #-}---- 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/>.---- | D-Bus clients are an abstraction over the lower-level messaging--- system. When combined with an external daemon called the \"bus\", clients--- can perform remote procedure calls to other clients on the bus.------ Clients may also listen for or emit /signals/, which are asynchronous--- broadcast notifications.------ Example: connect to the session bus, and get a list of active names.------ @---{-\# LANGUAGE OverloadedStrings \#-}------import Data.List (sort)---import DBus---import DBus.Client------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)--- @----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- , matchPathNamespace-- -- * 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, isPrefixOf)-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 Data.Function--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-- -- | If set, only receives signals sent with the given path or any of- -- its children.- , matchPathNamespace :: Maybe ObjectPath- }--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 "path_namespace" matchPathNamespace formatObjectPath- ]-- 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 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)- , maybe True (`pathPrefix` signalPath msg) (matchPathNamespace rule)- ] where- pathPrefix = isPrefixOf `on` formatObjectPath--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"--errorDisconnected :: ErrorName-errorDisconnected = errorName_ "org.freedesktop.DBus.Error.Disconnected"--errorUnknownObject :: ErrorName-errorUnknownObject = errorName_ "org.freedesktop.DBus.Error.UnknownObject"--errorUnknownInterface :: ErrorName-errorUnknownInterface = errorName_ "org.freedesktop.DBus.Error.UnknownInterface"--errorUnknownMethod :: ErrorName-errorUnknownMethod = errorName_ "org.freedesktop.DBus.Error.UnknownMethod"--errorInvalidParameters :: ErrorName-errorInvalidParameters = errorName_ "org.freedesktop.DBus.Error.InvalidParameters"--dbusName :: BusName-dbusName = busName_ "org.freedesktop.DBus"--dbusPath :: ObjectPath-dbusPath = objectPath_ "/org/freedesktop/DBus"--dbusInterface :: InterfaceName-dbusInterface = interfaceName_ "org.freedesktop.DBus"--interfaceIntrospectable :: InterfaceName-interfaceIntrospectable = interfaceName_ "org.freedesktop.DBus.Introspectable"--atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()-atomicModifyIORef_ ref fn = atomicModifyIORef ref (\x -> (fn x, ()))--#if !MIN_VERSION_base(4,6,0)-atomicWriteIORef :: IORef a -> a -> IO ()-atomicWriteIORef ref x = atomicModifyIORef ref (\_ -> (x, ()))+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++-- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | D-Bus clients are an abstraction over the lower-level messaging+-- system. When combined with an external daemon called the \"bus\", clients+-- can perform remote procedure calls to other clients on the bus.+--+-- Clients may also listen for or emit /signals/, which are asynchronous+-- broadcast notifications.+--+-- Example: connect to the session bus, and get a list of active names.+--+-- >>> :seti -XOverloadedStrings+--+-- >>> import Data.List (sort)+-- >>> import DBus+-- >>> import DBus.Client+--+-- >>> :{+-- getActiveNames :: IO ()+-- getActiveNames = 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)+-- :}+module DBus.Client+ (+ -- * Clients+ Client(..)+ , DBusR++ -- * Path/Interface storage+ , PathInfo(..)+ , pathInterfaces+ , pathChildren+ , pathLens+ , findPath+ , Interface(..)+ , defaultInterface++ -- * Connecting to a bus+ , connect+ , connectSystem+ , connectSession+ , connectStarter+ , disconnect++ -- * Sending method calls+ , call+ , call_+ , callNoReply+ , getProperty+ , getPropertyValue+ , setProperty+ , setPropertyValue+ , getAllProperties+ , getAllPropertiesMap+ , buildPropertiesInterface++ -- * Receiving method calls+ , export+ , unexport+ , Method(..)+ , makeMethod+ , AutoMethod+ , autoMethod+ , autoMethodWithMsg+ , Property(..)+ , autoProperty+ , readOnlyProperty+ , Reply(..)+ , throwError++ -- * Signals+ , SignalHandler+ , addMatch+ , removeMatch+ , emit+ , listen++ -- ** Match rules+ , MatchRule+ , formatMatchRule+ , matchAny+ , matchSender+ , matchDestination+ , matchPath+ , matchInterface+ , matchMember+ , matchPathNamespace++ -- * Introspection+ , buildIntrospectionObject+ , buildIntrospectionInterface+ , buildIntrospectionMethod+ , buildIntrospectionProperty+ , buildIntrospectableInterface++ -- * Name reservation+ , requestName+ , releaseName++ , RequestNameFlag+ , nameAllowReplacement+ , nameReplaceExisting+ , nameDoNotQueue++ , RequestNameReply(..)+ , ReleaseNameReply(..)++ -- * Client errors+ , ClientError+ , clientError+ , clientErrorMessage+ , clientErrorFatal++ -- * Advanced connection options+ , ClientOptions+ , clientSocketOptions+ , clientThreadRunner+ , defaultClientOptions+ , connectWith+ , connectWithName++ , dbusName+ , dbusPath++ , ErrorName+ , errorFailed+ , errorInvalidParameters+ , errorUnknownMethod+ ) where++import Control.Applicative+import Control.Arrow+import Control.Concurrent+import qualified Control.Exception+import Control.Exception (SomeException, throwIO)+import Control.Lens+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Except+import Data.Bits ((.|.))+import Data.Coerce+import Data.Foldable hiding (forM_, and)+import Data.Function+import Data.IORef+import Data.List (intercalate, isPrefixOf)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Monoid+import Data.String+import qualified Data.Traversable as T+import Data.Typeable (Typeable, Proxy(..))+import Data.Unique+import Data.Word (Word32)+import Prelude hiding (foldl, foldr, concat)++import DBus+import DBus.Internal.Message+import qualified DBus.Internal.Types as T+import qualified DBus.Introspection.Types as I+import qualified DBus.Introspection.Render 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 PathInfo+ , clientThreadID :: ThreadId+ , clientInterfaces :: [Interface]+ }++type DBusR a = ReaderT Client IO a++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 ()+ -- | A function to build the interfaces that should be present at every+ -- point where there is an object present. The default value builds the+ -- property and introspection interfaces.+ , clientBuildInterfaces :: Client -> [Interface]+ }++type FormattedMatchRule = String+data SignalHandler =+ SignalHandler Unique FormattedMatchRule (IORef Bool) (Signal -> IO ())++data Method = Method+ { methodName :: MemberName+ , inSignature :: Signature+ , outSignature :: Signature+ , methodHandler :: MethodCall -> DBusR Reply+ }++data Property = Property+ { propertyName :: MemberName+ , propertyType :: Type+ , propertyGetter :: Maybe (IO Variant)+ , propertySetter :: Maybe (Variant -> IO ())+ }++data Reply+ = ReplyReturn [Variant]+ | ReplyError ErrorName [Variant]++data Interface = Interface+ { interfaceName :: InterfaceName+ , interfaceMethods :: [Method]+ , interfaceProperties :: [Property]+ , interfaceSignals :: [I.Signal]+ }++defaultInterface :: Interface+defaultInterface =+ Interface { interfaceName = ""+ , interfaceMethods = []+ , interfaceProperties = []+ , interfaceSignals = []+ }++data PathInfo = PathInfo+ { _pathInterfaces :: [Interface]+ , _pathChildren :: Map String PathInfo+ }++-- NOTE: This instance is needed to make modifyNothingHandler work, but it+-- shouldn't really be used for much else. A more complete implementation can't+-- be provided because PathInfo > Interface > Method contain functions which+-- can't/don't have an eq instance.+instance Eq PathInfo where+ a == b = null (_pathInterfaces a) &&+ null (_pathInterfaces b) &&+ M.null (_pathChildren a) &&+ M.null (_pathChildren b)++makeLenses ''PathInfo++emptyPathInfo :: PathInfo+emptyPathInfo = PathInfo+ { _pathInterfaces = []+ , _pathChildren = M.empty+ }++traverseElement+ :: Applicative f+ => (a -> Maybe PathInfo -> f (Maybe PathInfo))+ -> String+ -> a+ -> PathInfo+ -> f PathInfo+traverseElement nothingHandler pathElement =+ pathChildren . at pathElement . nothingHandler++lookupNothingHandler+ :: (a -> Const (Data.Monoid.First PathInfo) b)+ -> Maybe a+ -> Const (Data.Monoid.First PathInfo) (Maybe b)+lookupNothingHandler = _Just++modifyNothingHandler ::+ (PathInfo -> Identity PathInfo)+ -> Maybe PathInfo+ -> Identity (Maybe PathInfo)+modifyNothingHandler = non emptyPathInfo++pathLens ::+ Applicative f =>+ ObjectPath+ -> ((PathInfo -> f PathInfo) -> Maybe PathInfo -> f (Maybe PathInfo))+ -> (PathInfo -> f PathInfo)+ -> PathInfo+ -> f PathInfo+pathLens path nothingHandler =+ foldl (\f pathElem -> f . traverseElement nothingHandler pathElem) id $+ T.pathElements path++modifyPathInfoLens+ :: ObjectPath+ -> (PathInfo -> Identity PathInfo) -> PathInfo -> Identity PathInfo+modifyPathInfoLens path = pathLens path modifyNothingHandler++modifyPathInterfacesLens+ :: ObjectPath+ -> ([Interface] -> Identity [Interface])+ -> PathInfo+ -> Identity PathInfo+modifyPathInterfacesLens path = modifyPathInfoLens path . pathInterfaces++addInterface :: ObjectPath -> Interface -> PathInfo -> PathInfo+addInterface path interface =+ over (modifyPathInterfacesLens path) (interface :)++findPath :: ObjectPath -> PathInfo -> Maybe PathInfo+findPath path = preview (pathLens path lookupNothingHandler)++findByGetterAndName ::+ (Coercible a2 a1, Eq a1, Foldable t) =>+ t a3 -> (a3 -> a2) -> a1 -> Maybe a3+findByGetterAndName options getter name =+ find ((== name) . coerce . getter) options++findInterface :: [Interface] -> InterfaceName -> PathInfo -> Maybe Interface+findInterface alwaysPresent (T.InterfaceName name) info =+ findByGetterAndName (_pathInterfaces info ++ alwaysPresent) interfaceName name++findMethod :: MemberName -> Interface -> Maybe Method+findMethod (T.MemberName name) interface =+ findByGetterAndName (interfaceMethods interface) methodName name++findProperty :: MemberName -> Interface -> Maybe Property+findProperty (T.MemberName name) interface =+ findByGetterAndName (interfaceProperties interface) propertyName name++-- | 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 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+ client <- connectWith' opts addr++ callNoReply client (methodCall dbusPath dbusInterface "Hello")+ { methodCallDestination = Just dbusName+ }++ return client++-- | Connect to the bus at the specified address, with the given connection+-- options, and return the unique client bus name. Most users should use+-- 'connect' or 'connectWith' instead.+--+-- Throws a 'ClientError' on failure.+connectWithName :: TransportOpen t => ClientOptions t -> Address -> IO (Client, BusName)+connectWithName opts addr = do+ client <- connectWith' opts addr++ reply <- call_ client (methodCall dbusPath dbusInterface "Hello")+ { methodCallDestination = Just dbusName+ }+ + case methodReturnBody reply of+ [name] | Just nameStr <- fromVariant name -> do+ busName <- parseBusName nameStr+ return (client, busName)+ _ ->+ throwIO (clientError "connectWithName: Hello response did not contain client name.")++connectWith' :: TransportOpen t => ClientOptions t -> Address -> IO Client+connectWith' opts addr = do+ sock <- DBus.Socket.openWith (clientSocketOptions opts) addr++ pendingCalls <- newIORef M.empty+ signalHandlers <- newIORef M.empty+ objects <- newIORef $ PathInfo [] M.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+ , clientInterfaces = clientBuildInterfaces opts client+ }+ putMVar clientMVar client++ return client++makeErrorReply :: ErrorName -> Reply+makeErrorReply errorName = ReplyError errorName []++buildPropertiesInterface :: Client -> Interface+buildPropertiesInterface client =+ let alwaysPresent = clientInterfaces client+ getPropertyObjF propertyInterfaceName memberName path info =+ findInterfaceAtPath alwaysPresent info path+ (Just $ fromString propertyInterfaceName) >>=+ (maybeToEither errorUnknownMethod . findProperty (fromString memberName))+ getPropertyObj propertyInterfaceName memberName path =+ getPropertyObjF propertyInterfaceName memberName path <$>+ readIORef (clientObjects client)+ callGet MethodCall { methodCallPath = path }+ propertyInterfaceName memberName =+ left makeErrorReply <$>+ runExceptT (do+ property <- ExceptT $ getPropertyObj propertyInterfaceName+ memberName path+ ExceptT $ sequenceA $ maybeToEither errorNotAuthorized $+ propertyGetter property)+ callSet MethodCall { methodCallPath = path }+ propertyInterfaceName memberName value =+ left makeErrorReply <$>+ runExceptT (do+ property <- ExceptT $ getPropertyObj propertyInterfaceName memberName path+ setter <- ExceptT $ return $ maybeToEither errorNotAuthorized $+ propertySetter property+ lift $ setter value)+ callGetAll MethodCall { methodCallPath = path } propertyInterfaceName =+ left makeErrorReply <$>+ runExceptT (do+ info <- lift $ readIORef (clientObjects client)+ propertyInterface <-+ ExceptT $ return $ findInterfaceAtPath alwaysPresent info path $+ Just $ fromString propertyInterfaceName+ let properties = interfaceProperties propertyInterface+ nameGetters :: [IO (String, Variant)]+ nameGetters = [ (coerce name,) <$> getter |+ Property { propertyName = name+ , propertyGetter = Just getter+ } <- properties]+ lift $ M.fromList <$> T.sequenceA nameGetters)+ in+ defaultInterface+ { interfaceName = propertiesInterfaceName+ , interfaceMethods =+ [ autoMethodWithMsg "Get" callGet+ , autoMethodWithMsg "GetAll" callGetAll+ , autoMethodWithMsg "Set" callSet+ ]+ , interfaceSignals =+ [ I.Signal+ { I.signalName = "PropertiesChanged"+ , I.signalArgs =+ [ I.SignalArg+ { I.signalArgName = "interface_name"+ , I.signalArgType = T.TypeString+ }+ , I.SignalArg+ { I.signalArgName = "changed_properties"+ , I.signalArgType = T.TypeDictionary T.TypeString T.TypeVariant+ }+ , I.SignalArg+ { I.signalArgName = "invalidated_properties"+ , I.signalArgType = T.TypeArray T.TypeString+ }+ ]+ }+ ]+ }++buildIntrospectableInterface :: Client -> Interface+buildIntrospectableInterface client =+ defaultInterface+ { interfaceName = introspectableInterfaceName+ , interfaceMethods = [ autoMethodWithMsg "Introspect" callIntrospect ]+ } where+ callIntrospect MethodCall { methodCallPath = path } = do+ info <- readIORef (clientObjects client)+ return $ left makeErrorReply $ do+ targetInfo <- maybeToEither errorUnknownObject $ findPath path info+ -- TODO: We should probably return a better error here:+ maybeToEither errorUnknownObject $ I.formatXML $+ buildIntrospectionObject defaultInterfaces+ targetInfo (T.pathElements path)+ defaultInterfaces = map buildIntrospectionInterface $ clientInterfaces 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+ , clientBuildInterfaces =+ \client -> map ($ client) [buildPropertiesInterface, buildIntrospectableInterface]+ }++-- | 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 -> (M.empty, p))+ forM_ (M.toList pendingCalls) $ \(k, v) ->+ putMVar v (Left (methodError k errorDisconnected))++ atomicWriteIORef (clientSignalHandlers client) M.empty++ atomicWriteIORef (clientObjects client) emptyPathInfo++ 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++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_ (M.toAscList handlers) (\(_, SignalHandler _ _ _ h) -> forkIO $ void $ h msg)+ go (ReceivedMethodCall serial msg) = do+ pathInfo <- readIORef (clientObjects client)+ let sender = methodCallSender msg+ sendResult reply =+ 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 ())+ _ <- forkIO $ case findMethodForCall (clientInterfaces client) pathInfo msg of+ Right Method { methodHandler = handler } ->+ runReaderT (handler msg) client >>= sendResult+ Left errName -> send_ client+ (methodError serial errName) { methodErrorDestination = sender }+ (\_ -> return ())+ return ()+ go _ = return ()++ dispatchReply serial result = do+ pending <- atomicModifyIORef+ (clientPendingCalls client)+ (\p -> case M.lookup serial p of+ Nothing -> (p, Nothing)+ Just mvar -> (M.delete serial p, Just mvar))+ case pending of+ Just mvar -> putMVar mvar result+ Nothing -> return ()++findInterfaceAtPath+ :: [Interface]+ -> PathInfo+ -> ObjectPath+ -> Maybe InterfaceName+ -> Either ErrorName Interface+findInterfaceAtPath defaultInterfaces info path name =+ maybeToEither errorUnknownObject (findPath path info) >>=+ (maybeToEither errorUnknownInterface .+ maybe (const Nothing) (findInterface defaultInterfaces) name)++findMethodForCall ::+ [Interface] -> PathInfo -> MethodCall -> Either ErrorName Method+findMethodForCall defaultInterfaces info+ MethodCall { methodCallInterface = interface+ , methodCallMember = member+ , methodCallPath = path+ } =+ findInterfaceAtPath defaultInterfaces info path interface >>=+ (maybeToEither errorUnknownMethod . findMethod member)+++-- Request name++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 ((.|.) . flagValue) 0 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 usually 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+++-- Requests++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 -> (M.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 (M.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 ())++orDefaultInterface :: Maybe InterfaceName -> InterfaceName+orDefaultInterface = fromMaybe "org.freedesktop.DBus"++dummyMethodError :: MethodError+dummyMethodError =+ MethodError { methodErrorName = errorName_ "org.ClientTypeMismatch"+ , methodErrorSerial = T.Serial 1+ , methodErrorSender = Nothing+ , methodErrorDestination = Nothing+ , methodErrorBody = []+ }++unpackVariant :: IsValue a => MethodCall -> Variant -> Either MethodError a+unpackVariant MethodCall { methodCallSender = sender } variant =+ maybeToEither dummyMethodError { methodErrorBody =+ [variant, toVariant $ show $ variantType variant]+ , methodErrorSender = sender+ } $ fromVariant variant++-- | Like `getPropertyValue`, but returns the value as a 'Variant'.+--+-- Throws a 'ClientError' if the property request couldn't be sent.+getProperty :: Client -> MethodCall -> IO (Either MethodError Variant)+getProperty client+ msg@MethodCall { methodCallInterface = interface+ , methodCallMember = member+ } =+ (>>= (unpackVariant msg . head . methodReturnBody)) <$>+ call client msg { methodCallInterface = Just propertiesInterfaceName+ , methodCallMember = getMemberName+ , methodCallBody = [ toVariant (coerce (orDefaultInterface interface) :: String)+ , toVariant (coerce member :: String)+ ]+ }++-- | Get a property using the standard @\"org.freedesktop.DBus.Properties.Get\"@ method.+-- The interface and property name are given by the 'methodCallInterface' and 'methodCallMember'+-- fields of the supplied 'MethodCall'. This function handles properties of fixed type. For+-- properties of varying types, use 'getProperty'.+--+-- Throws a 'ClientError' if the property request couldn't be sent.+getPropertyValue :: IsValue a => Client -> MethodCall -> IO (Either MethodError a)+getPropertyValue client msg =+ (>>= unpackVariant msg) <$> getProperty client msg++-- | Like 'setPropertyValue', but expects the new value to be wrapped in a 'Variant'.+--+-- Throws a 'ClientError' if the property request couldn't be sent.+setProperty :: Client -> MethodCall -> Variant -> IO (Either MethodError MethodReturn)+setProperty client+ msg@MethodCall { methodCallInterface = interface+ , methodCallMember = member+ } value =+ call client msg { methodCallInterface = Just propertiesInterfaceName+ , methodCallMember = setMemberName+ , methodCallBody =+ [ toVariant (coerce (orDefaultInterface interface) :: String)+ , toVariant (coerce member :: String)+ , toVariant value+ ]+ }++-- | Set a property using the standard @\"org.freedesktop.DBus.Properties.Set\"@ method.+-- The interface and property name are given by the 'methodCallInterface' and 'methodCallMember'+-- fields of the supplied 'MethodCall'. See `setProperty` for a version that accepts a 'Variant'.+--+-- Throws a 'ClientError' if the property request couldn't be sent.+setPropertyValue+ :: IsValue a+ => Client -> MethodCall -> a -> IO (Maybe MethodError)+setPropertyValue client msg v = eitherToMaybe <$> setProperty client msg (toVariant v)+ where eitherToMaybe (Left a) = Just a+ eitherToMaybe (Right _) = Nothing++getAllProperties :: Client -> MethodCall -> IO (Either MethodError MethodReturn)+getAllProperties client+ msg@MethodCall { methodCallInterface = interface } =+ call client msg { methodCallInterface = Just propertiesInterfaceName+ , methodCallMember = getAllMemberName+ , methodCallBody = [toVariant (coerce (orDefaultInterface interface) :: String)]+ }++getAllPropertiesMap :: Client -> MethodCall -> IO (Either MethodError (M.Map String Variant))+getAllPropertiesMap client msg =+ -- NOTE: We should never hit the error case here really unless the client+ -- returns the wrong type of object.+ (>>= (maybeToEither dummyMethodError . fromVariant . head . methodReturnBody))+ <$> getAllProperties client msg+++-- Signals++-- | 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 -> (M.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 -> (M.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 = void $ addMatch client rule io+{-# 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++ -- | If set, only receives signals sent with the given path or any of+ -- its children.+ , matchPathNamespace :: Maybe ObjectPath+ }++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 "path_namespace" matchPathNamespace formatObjectPath+ ]++ 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 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)+ , maybe True (`pathPrefix` signalPath msg) (matchPathNamespace rule)+ ] where+ pathPrefix = isPrefixOf `on` formatObjectPath++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))+++-- Method construction++returnInvalidParameters :: Monad m => m Reply+returnInvalidParameters = return $ ReplyError errorInvalidParameters []++-- | 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] -> DBusR Reply++handleTopLevelReturn :: IsVariant a => a -> [Variant]+handleTopLevelReturn value =+ case toVariant value of+ T.Variant (T.ValueStructure xs) -> fmap T.Variant xs+ v -> [v]++instance IsValue a => AutoMethod (IO a) where+ funTypes io = funTypes (lift io :: DBusR a)+ apply io = apply (lift io :: DBusR a)++instance IsValue a => AutoMethod (DBusR a) where+ funTypes _ = ([], outTypes) where+ aType :: Type+ aType = typeOf' (Proxy :: Proxy a)+ outTypes =+ case aType of+ TypeStructure ts -> ts+ _ -> [aType]++ apply io [] = ReplyReturn . handleTopLevelReturn <$> io+ apply _ _ = returnInvalidParameters++instance IsValue a => AutoMethod (IO (Either Reply a)) where+ funTypes io = funTypes (lift io :: DBusR (Either Reply a))+ apply io = apply (lift io :: DBusR (Either Reply a))++instance IsValue a => AutoMethod (DBusR (Either Reply a)) where+ funTypes _ = ([], outTypes) where+ aType :: Type+ aType = typeOf' (Proxy :: Proxy a)+ outTypes =+ case aType of+ TypeStructure ts -> ts+ _ -> [aType]++ apply io [] = either id (ReplyReturn . handleTopLevelReturn) <$> io+ apply _ _ = returnInvalidParameters++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 _ [] = returnInvalidParameters+ apply fn (v:vs) = case fromVariant v of+ Just v' -> apply (fn v') vs+ Nothing -> returnInvalidParameters++-- | 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) => MemberName -> fn -> Method+autoMethod name fun = autoMethodWithMsg name $ const fun++autoMethodWithMsg :: (AutoMethod fn) => MemberName -> (MethodCall -> fn) -> Method+autoMethodWithMsg name fun = makeMethod name inSig outSig io where+ (typesIn, typesOut) = funTypes (fun undefined)+ inSig = fromMaybe (invalid "input") $ signature typesIn+ outSig = fromMaybe (invalid "output") $ signature typesOut+ io msg = apply (fun msg) (methodCallBody msg)++ invalid label = error (concat+ [ "Method "+ , "."+ , formatMemberName name+ , " has an invalid "+ , label+ , " signature."])++autoProperty+ :: forall v. (IsValue v)+ => MemberName -> Maybe (IO v) -> Maybe (v -> IO ()) -> Property+autoProperty name mgetter msetter =+ Property name propType (fmap toVariant <$> mgetter) (variantSetter <$> msetter)+ where propType = typeOf' (Proxy :: Proxy v)+ variantSetter setter =+ let newFun variant = maybe (return ()) setter (fromVariant variant)+ in newFun++readOnlyProperty :: (IsValue v) => MemberName -> IO v -> Property+readOnlyProperty name getter = autoProperty name (Just getter) Nothing++-- | 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.+makeMethod+ :: MemberName+ -> Signature -- ^ Input parameter signature+ -> Signature -- ^ Output parameter signature+ -> (MethodCall -> DBusR Reply)+ -> Method+makeMethod name inSig outSig io = Method name inSig outSig+ (\msg -> do+ fromReader <- ask+ lift $ Control.Exception.catch+ (Control.Exception.catch+ (runReaderT (io msg) fromReader)+ (\(MethodExc name' vs') -> return (ReplyError name' vs')))+ (\exc -> return (ReplyError errorFailed+ [toVariant (show (exc :: SomeException))])))++-- | Export the given 'Interface' at the given 'ObjectPath'+--+-- Use 'autoMethod' to construct a 'Method' from a function that accepts and+-- returns simple types.+--+-- Use 'makeMethod' to construct a 'Method' from a function that handles parameter+-- conversion manually.+--+-- >>> :seti -XOverloadedStrings+--+-- >>> :{+-- ping :: MethodCall -> DBusR Reply+-- ping _ = pure $ ReplyReturn []+-- :}+--+-- >>> :{+-- sayHello :: String -> IO String+-- sayHello name = return ("Hello " ++ name ++ "!")+-- :}+--+-- >>> :{+-- doExport :: IO ()+-- doExport = do+-- client <- connectSession+-- export client "/hello_world"+-- defaultInterface { interfaceName = "com.example.HelloWorld"+-- , interfaceMethods =+-- [ makeMethod "Ping" (signature_ []) (signature_ []) ping+-- , autoMethod "Hello" sayHello+-- ]+-- }+-- :}+export :: Client -> ObjectPath -> Interface -> IO ()+export client path interface =+ atomicModifyIORef_ (clientObjects client) $ addInterface path interface++-- | 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) clear+ where clear = over (modifyPathInterfacesLens path) $ const []+++-- Introspection++buildIntrospectionObject :: [I.Interface] -> PathInfo -> [String] -> I.Object+buildIntrospectionObject defaultInterfaces+ PathInfo+ { _pathInterfaces = interfaces+ , _pathChildren = infoChildren+ } elems =+ I.Object+ { I.objectPath = T.fromElements elems+ , I.objectInterfaces =+ (if null interfaces then [] else defaultInterfaces) +++ map buildIntrospectionInterface interfaces+ -- TODO: Eventually we should support not outputting everything if there is+ -- a lot of stuff.+ , I.objectChildren = M.elems $ M.mapWithKey recurseFromString infoChildren+ }+ where recurseFromString stringNode nodeInfo =+ buildIntrospectionObject defaultInterfaces nodeInfo $ elems ++ [stringNode]++buildIntrospectionInterface :: Interface -> I.Interface+buildIntrospectionInterface Interface+ { interfaceName = name+ , interfaceMethods = methods+ , interfaceProperties = properties+ , interfaceSignals = signals+ } =+ I.Interface+ { I.interfaceName = name+ , I.interfaceMethods = map buildIntrospectionMethod methods+ , I.interfaceProperties = map buildIntrospectionProperty properties+ , I.interfaceSignals = signals+ }++buildIntrospectionProperty :: Property -> I.Property+buildIntrospectionProperty (Property memberName ptype getter setter) =+ I.Property { I.propertyName = coerce memberName+ , I.propertyType = ptype+ , I.propertyRead = isJust getter+ , I.propertyWrite = isJust setter+ }++buildIntrospectionMethod :: Method -> I.Method+buildIntrospectionMethod Method+ { methodName = name+ , inSignature = inSig+ , outSignature = outSig+ } = I.Method+ { I.methodName = name+ , I.methodArgs = zipWith makeMethodArg ['a'..'z'] $ inTuples ++ outTuples+ }+ where inTuples = map (, I.In) $ coerce inSig+ outTuples = map (, I.Out) $ coerce outSig+ makeMethodArg nameChar (t, dir) =+ I.MethodArg { I.methodArgName = [nameChar]+ , I.methodArgType = t+ , I.methodArgDirection = dir+ }+++-- Constants++errorFailed :: ErrorName+errorFailed = errorName_ "org.freedesktop.DBus.Error.Failed"++errorDisconnected :: ErrorName+errorDisconnected = errorName_ "org.freedesktop.DBus.Error.Disconnected"++errorUnknownObject :: ErrorName+errorUnknownObject = errorName_ "org.freedesktop.DBus.Error.UnknownObject"++errorUnknownInterface :: ErrorName+errorUnknownInterface = errorName_ "org.freedesktop.DBus.Error.UnknownInterface"++errorUnknownMethod :: ErrorName+errorUnknownMethod = errorName_ "org.freedesktop.DBus.Error.UnknownMethod"++errorInvalidParameters :: ErrorName+errorInvalidParameters = errorName_ "org.freedesktop.DBus.Error.InvalidParameters"++errorNotAuthorized :: ErrorName+errorNotAuthorized = errorName_ "org.freedesktop.DBus.Error.NotAuthorized"++dbusName :: BusName+dbusName = busName_ "org.freedesktop.DBus"++dbusPath :: ObjectPath+dbusPath = objectPath_ "/org/freedesktop/DBus"++dbusInterface :: InterfaceName+dbusInterface = interfaceName_ "org.freedesktop.DBus"++introspectableInterfaceName :: InterfaceName+introspectableInterfaceName = interfaceName_ "org.freedesktop.DBus.Introspectable"++propertiesInterfaceName :: InterfaceName+propertiesInterfaceName = fromString "org.freedesktop.DBus.Properties"++getAllMemberName :: MemberName+getAllMemberName = fromString "GetAll"++getMemberName :: MemberName+getMemberName = fromString "Get"++setMemberName :: MemberName+setMemberName = fromString "Set"+++-- Miscellaneous++maybeToEither :: b -> Maybe a -> Either b a+maybeToEither = flip maybe Right . Left++atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()+atomicModifyIORef_ ref fn = atomicModifyIORef ref (fn &&& const ())++#if !MIN_VERSION_base(4,6,0)+atomicWriteIORef :: IORef a -> a -> IO ()+atomicWriteIORef ref x = atomicModifyIORef ref $ const x &&& const () #endif
+ lib/DBus/Generation.hs view
@@ -0,0 +1,552 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module DBus.Generation where++import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import DBus.Client as C+import qualified DBus.Internal.Message as M+import qualified DBus.Internal.Types as T+import qualified DBus.Introspection.Parse as I+import qualified DBus.Introspection.Types as I+import qualified Data.ByteString as BS+import qualified Data.Char as Char+import Data.Coerce+import Data.Int+import Data.List+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid+import Data.String+import qualified Data.Text.IO as Text+import Data.Traversable+import Data.Word+import Language.Haskell.TH+import Prelude hiding (mapM)+import System.Posix.Types (Fd(..))++-- | Compatibility helper to create (total) tuple expressions+mkTupE :: [Exp] -> Exp+mkTupE = TupE+#if MIN_VERSION_template_haskell(2,16,0)+ . map Just+#endif++type ClientBusPathR a = ReaderT (Client, T.BusName, T.ObjectPath) IO a++dbusInvoke :: (Client -> T.BusName -> T.ObjectPath -> a) -> ClientBusPathR a+dbusInvoke fn = (\(c, b, p) -> fn c b p) <$> ask++-- Use these operators together with dbusInvoke to invoke functions of the form+-- Client -> T.BusName -> T.ObjectPath+infixl 4 ??+(??) :: Functor f => f (a -> b) -> a -> f b+fab ?? a = fmap ($ a) fab+{-# INLINE (??) #-}++infixl 4 ?/?+(?/?) :: ClientBusPathR (a -> IO b) -> a -> ClientBusPathR b+soFar ?/? arg = do+ returnValue <- fmap ($ arg) soFar+ lift returnValue++data GenerationParams = GenerationParams+ { genBusName :: Maybe T.BusName+ , genObjectPath :: Maybe T.ObjectPath+ , genInterfaceName :: T.InterfaceName+ , genTakeSignalErrorHandler :: Bool+ , getTHType :: T.Type -> Type+ }++defaultGetDictType :: Type -> Type -> Type+defaultGetDictType k =+ AppT (AppT (ConT ''Map.Map) k)++defaultGetTHType :: T.Type -> Type+defaultGetTHType = buildGetTHType (AppT ListT) defaultGetDictType++buildGetTHType ::+ (Type -> Type) -> (Type -> Type -> Type) -> T.Type -> Type+buildGetTHType arrayTypeBuilder dictTypeBuilder = fn+ where fn t =+ case t of+ -- Because of a quirk in how we unmarshal things, we currently HAVE+ -- to decode arrays of Word8 in this way.+ T.TypeArray T.TypeWord8 -> ConT ''BS.ByteString+ T.TypeBoolean -> ConT ''Bool+ T.TypeWord8 -> ConT ''Word8+ T.TypeWord16 -> ConT ''Word16+ T.TypeWord32 -> ConT ''Word32+ T.TypeWord64 -> ConT ''Word64+ T.TypeInt16 -> ConT ''Int16+ T.TypeInt32 -> ConT ''Int32+ T.TypeInt64 -> ConT ''Int64+ T.TypeDouble -> ConT ''Double+ T.TypeUnixFd -> ConT ''Fd+ T.TypeString -> ConT ''String+ T.TypeSignature -> ConT ''T.Signature+ T.TypeObjectPath -> ConT ''T.ObjectPath+ T.TypeVariant -> ConT ''T.Variant+ T.TypeArray arrayType -> arrayTypeBuilder $ fn arrayType+ T.TypeDictionary k v -> dictTypeBuilder (fn k) (fn v)+ T.TypeStructure ts -> foldl AppT (TupleT $ length ts) $ map fn ts++newNameDef :: String -> Q Name+newNameDef n =+ case n of+ "" -> newName "arg"+ "data" -> newName "arg"+ _ -> newName n++defaultGenerationParams :: GenerationParams+defaultGenerationParams =+ GenerationParams+ { genBusName = Nothing+ , genInterfaceName = fromString ""+ , getTHType = defaultGetTHType+ , genObjectPath = Nothing+ , genTakeSignalErrorHandler = False+ }++addTypeArg :: Type -> Type -> Type+addTypeArg argT = AppT (AppT ArrowT argT)++addTypeArgIf :: Bool -> Type -> Type -> Type+addTypeArgIf condition theType = if condition then addTypeArg theType else id++unitIOType :: Type+unitIOType = AppT (ConT ''IO) (TupleT 0)++addArgIf :: Bool -> a -> [a] -> [a]+addArgIf condition name = if condition then (name:) else id++mkFunD :: Name -> [Name] -> Exp -> Dec+mkFunD name argNames body =+ FunD name [Clause (map VarP argNames) (NormalB body) []]++generateClient :: GenerationParams -> I.Interface -> Q [Dec]+generateClient params+ I.Interface{ I.interfaceName = name+ , I.interfaceProperties = properties+ , I.interfaceMethods = methods+ } =+ let params' = params { genInterfaceName = coerce name } in+ fmap concat <$> sequenceA $+ map (generateClientMethod params') methods+ +++ map (generateClientProperty params') properties++maybeName :: a -> Bool -> Maybe a+maybeName name condition = if condition then Just name else Nothing++makeToVariantApp :: Name -> Exp+makeToVariantApp name = AppE (VarE 'T.toVariant) $ VarE name++makeFromVariantApp :: Name -> Exp+makeFromVariantApp name = AppE (VarE 'T.fromVariant) $ VarE name++makeJustPattern :: Name -> Pat+makeJustPattern name = ConP 'Just [] [VarP name]++mapOrHead ::+ (Num a, Eq a) => a -> (t -> b) -> [t] -> ([b] -> b) -> b+mapOrHead outputLength fn names cons =+ case outputLength of+ 1 -> fn $ head names+ _ -> cons $ map fn names++runGetFirst :: [Maybe a] -> Maybe a+runGetFirst options = getFirst $ mconcat $ map First options++buildGeneratedSignature :: Bool -> Bool -> Type -> Type+buildGeneratedSignature takeBusArg takeObjectPathArg =+ addTypeArg (ConT ''C.Client) . addTypeArgIf takeBusArg (ConT ''T.BusName) .+ addTypeArgIf takeObjectPathArg (ConT ''T.ObjectPath)++getSetMethodCallParams ::+ Name -> Maybe Name -> Maybe Name -> ExpQ -> ExpQ+getSetMethodCallParams methodCallN mBusN mObjectPathN variantsE =+ case (mBusN, mObjectPathN) of+ (Just busN, Just objectPathN) -> [|+ $( varE methodCallN )+ { M.methodCallDestination = Just $( varE busN )+ , M.methodCallPath = $( varE objectPathN )+ , M.methodCallBody = $( variantsE )+ }+ |]+ (Just busN, Nothing) -> [|+ $( varE methodCallN )+ { M.methodCallDestination = Just $( varE busN )+ , M.methodCallBody = $( variantsE )+ }+ |]+ (Nothing, Just objectPathN) -> [|+ $( varE methodCallN )+ { M.methodCallPath = $( varE objectPathN )+ , M.methodCallBody = $( variantsE )+ }+ |]+ (Nothing, Nothing) -> [|+ $( varE methodCallN ) { M.methodCallBody = $( variantsE ) }+ |]++clientArgumentUnpackingMessage :: String+clientArgumentUnpackingMessage =+ "The client method could not unpack the message that was received."++clientArgumentUnpackingError :: [T.Variant] -> M.MethodError+clientArgumentUnpackingError variants =+ M.MethodError+ { M.methodErrorName = C.errorFailed+ , M.methodErrorSerial = T.Serial 0+ , M.methodErrorSender = Nothing+ , M.methodErrorDestination = Nothing+ , M.methodErrorBody = T.toVariant clientArgumentUnpackingMessage : variants+ }++generateClientMethod :: GenerationParams -> I.Method -> Q [Dec]+generateClientMethod GenerationParams+ { getTHType = getArgType+ , genInterfaceName = methodInterface+ , genObjectPath = objectPathM+ , genBusName = busNameM+ }+ I.Method+ { I.methodArgs = args+ , I.methodName = methodNameMN+ } =+ do+ let (inputArgs, outputArgs) = partition ((== I.In) . I.methodArgDirection) args+ outputLength = length outputArgs+ buildArgNames = mapM (newNameDef . I.methodArgName) inputArgs+ buildOutputNames = mapM (newNameDef . I.methodArgName) outputArgs+ takeBusArg = isNothing busNameM+ takeObjectPathArg = isNothing objectPathM+ functionNameFirst:functionNameRest = coerce methodNameMN+ functionName = Char.toLower functionNameFirst:functionNameRest+ functionN = mkName $ Char.toLower functionNameFirst:functionNameRest+ methodCallDefN = mkName $ functionName ++ "MethodCall"+ defObjectPath = fromMaybe (fromString "/") objectPathM+ clientN <- newName "client"+ busN <- newName "busName"+ objectPathN <- newName "objectPath"+ methodCallN <- newName "methodCall"+ callResultN <- newName "callResult"+ replySuccessN <- newName "replySuccess"+ methodArgNames <- buildArgNames+ fromVariantOutputNames <- buildOutputNames+ finalOutputNames <- buildOutputNames+ let variantListExp = map makeToVariantApp methodArgNames+ mapOrHead' = mapOrHead outputLength+ fromVariantExp = mapOrHead' makeFromVariantApp fromVariantOutputNames mkTupE+ finalResultTuple = mapOrHead' VarE finalOutputNames mkTupE+ maybeExtractionPattern = mapOrHead' makeJustPattern finalOutputNames TupP+ getMethodCallDefDec = [d|+ $( varP methodCallDefN ) =+ M.MethodCall { M.methodCallPath = defObjectPath+ , M.methodCallInterface = Just methodInterface+ , M.methodCallMember = methodNameMN+ , M.methodCallDestination = busNameM+ , M.methodCallSender = Nothing+ , M.methodCallReplyExpected = True+ , M.methodCallAutoStart = True+ , M.methodCallBody = []+ }+ |]+ setMethodCallParamsE = getSetMethodCallParams methodCallDefN+ (maybeName busN takeBusArg)+ (maybeName objectPathN takeObjectPathArg)+ (return $ ListE variantListExp)+ handleReplySuccess =+ if outputLength == 0+ then+ [| Right () |]+ else+ [|+ case M.methodReturnBody $( varE replySuccessN ) of+ $( return $ ListP $ map VarP fromVariantOutputNames ) ->+ case $( return fromVariantExp ) of+ $( return maybeExtractionPattern ) -> Right $( return finalResultTuple )+ _ -> Left $ clientArgumentUnpackingError $+ M.methodReturnBody $( varE replySuccessN )+ _ -> Left $ clientArgumentUnpackingError $+ M.methodReturnBody $( varE replySuccessN )+ |]+ getFunctionBody = [|+ do+ let $( varP methodCallN ) = $( setMethodCallParamsE )+ $( varP callResultN ) <- call $( return $ VarE clientN ) $( varE methodCallN )+ return $ case $( varE callResultN ) of+ Right $( return rightPattern ) -> $( handleReplySuccess )+ Left e -> Left e+ |]+ where rightPattern = if outputLength == 0+ then WildP+ else VarP replySuccessN+ functionBody <- getFunctionBody+ methodCallDef <- getMethodCallDefDec+ let methodSignature = foldr addInArg fullOutputSignature inputArgs+ addInArg arg = addTypeArg $ getArgType $ I.methodArgType arg+ fullOutputSignature = AppT (ConT ''IO) $+ AppT (AppT (ConT ''Either)+ (ConT ''M.MethodError))+ outputSignature+ outputSignature =+ case outputLength of+ 1 -> getArgType $ I.methodArgType $ head outputArgs+ _ -> foldl addOutArg (TupleT outputLength) outputArgs+ addOutArg target arg = AppT target $ getArgType $ I.methodArgType arg+ fullSignature = buildGeneratedSignature takeBusArg takeObjectPathArg methodSignature+ fullArgNames =+ clientN:addArgIf takeBusArg busN+ (addArgIf takeObjectPathArg objectPathN methodArgNames)+ definitionDec = SigD functionN fullSignature+ function = mkFunD functionN fullArgNames functionBody+ methodCallSignature = SigD methodCallDefN $ ConT ''M.MethodCall+ return $ methodCallSignature:methodCallDef ++ [definitionDec, function]++generateClientProperty :: GenerationParams -> I.Property -> Q [Dec]+generateClientProperty GenerationParams+ { getTHType = getArgType+ , genInterfaceName = propertyInterface+ , genObjectPath = objectPathM+ , genBusName = busNameM+ }+ I.Property+ { I.propertyName = name+ , I.propertyType = propType+ , I.propertyRead = readable+ , I.propertyWrite = writable+ } =+ do+ clientN <- newName "client"+ busN <- newName "busName"+ objectPathN <- newName "objectPath"+ methodCallN <- newName "methodCall"+ argN <- newName "arg"+ let takeBusArg = isNothing busNameM+ takeObjectPathArg = isNothing objectPathM+ defObjectPath = fromMaybe (fromString "/") objectPathM+ methodCallDefN = mkName $ "methodCallFor" ++ name+ getMethodCallDefDec = [d|+ $( varP methodCallDefN ) =+ M.MethodCall { M.methodCallPath = defObjectPath+ , M.methodCallInterface = Just propertyInterface+ , M.methodCallMember = fromString name+ , M.methodCallDestination = busNameM+ , M.methodCallSender = Nothing+ , M.methodCallReplyExpected = True+ , M.methodCallAutoStart = True+ , M.methodCallBody = []+ }+ |]+ setMethodCallParamsE = getSetMethodCallParams methodCallDefN+ (maybeName busN takeBusArg)+ (maybeName objectPathN takeObjectPathArg)+ (return $ ListE [])+ makeGetterBody = [|+ do+ let $( varP methodCallN ) = $( setMethodCallParamsE )+ getPropertyValue $( return $ VarE clientN )+ $( varE methodCallN )+ |]+ makeSetterBody = [|+ do+ let $( varP methodCallN ) = $( setMethodCallParamsE )+ setPropertyValue $( varE clientN ) $( varE methodCallN ) $( varE argN )+ |]+ methodCallDefs <- getMethodCallDefDec+ getterBody <- makeGetterBody+ setterBody <- makeSetterBody+ let buildSignature = buildGeneratedSignature takeBusArg takeObjectPathArg+ getterSigType =+ buildSignature $ AppT (ConT ''IO) $+ AppT (AppT (ConT ''Either)+ (ConT ''M.MethodError)) $ getArgType propType+ setterSigType = buildSignature $ addTypeArg (getArgType propType) $+ AppT (ConT ''IO) $ AppT (ConT ''Maybe) (ConT ''M.MethodError)+ buildArgs rest = clientN:addArgIf takeBusArg busN+ (addArgIf takeObjectPathArg objectPathN rest)+ getterArgNames = buildArgs []+ setterArgNames = buildArgs [argN]+ propertyString = coerce name+ getterName = mkName $ "get" ++ propertyString+ setterName = mkName $ "set" ++ propertyString+ getterFunction = mkFunD getterName getterArgNames getterBody+ setterFunction = mkFunD setterName setterArgNames setterBody+ getterSignature = SigD getterName getterSigType+ setterSignature = SigD setterName setterSigType+ getterDefs = if readable then [getterSignature, getterFunction] else []+ setterDefs = if writable then [setterSignature, setterFunction] else []+ methodCallSignature = SigD methodCallDefN $ ConT ''M.MethodCall+ return $ methodCallSignature:methodCallDefs ++ getterDefs ++ setterDefs++generateSignalsFromInterface :: GenerationParams -> I.Interface -> Q [Dec]+generateSignalsFromInterface params+ I.Interface{ I.interfaceName = name+ , I.interfaceSignals = signals+ } = generateSignals params name signals++generateSignals :: GenerationParams -> T.InterfaceName -> [I.Signal] -> Q [Dec]+generateSignals params name signals =+ fmap concat <$> sequenceA $+ map (generateSignal params { genInterfaceName = coerce name })+ signals++generateSignal :: GenerationParams -> I.Signal -> Q [Dec]+generateSignal GenerationParams+ { getTHType = getArgType+ , genInterfaceName = signalInterface+ , genObjectPath = objectPathM+ , genBusName = busNameM+ , genTakeSignalErrorHandler = takeErrorHandler+ }+ I.Signal+ { I.signalName = name+ , I.signalArgs = args+ } =+ do+ let buildArgNames = mapM (newNameDef . I.signalArgName) args++ argNames <- buildArgNames+ fromVariantOutputNames <- buildArgNames+ toHandlerOutputNames <- buildArgNames+ objectPathN <- newName "objectPath"+ variantsN <- newName "variants"+ signalN <- newName "signal"+ receivedSignalN <- newName "signal"+ clientN <- newName "client"+ handlerArgN <- newName "handlerArg"+ errorHandlerN <- newName "errorHandler"+ matchRuleN <- newName "matchRule"+ matchRuleArgN <- newName "matchRuleArg"++ let variantListExp = map makeToVariantApp argNames+ signalString = coerce name+ signalDefN = mkName $ "signalFor" ++ signalString+ takeObjectPathArg = isNothing objectPathM+ defObjectPath = fromMaybe (fromString "/") objectPathM+ argCount = length argNames+ getSignalDefDec = [d|+ $( varP signalDefN ) =+ M.Signal { M.signalPath = defObjectPath+ , M.signalInterface = signalInterface+ , M.signalMember = name+ , M.signalDestination = Nothing+ , M.signalSender = Nothing+ , M.signalBody = []+ }+ |]+ let mapOrHead' = mapOrHead argCount+ fromVariantExp = mapOrHead' makeFromVariantApp fromVariantOutputNames mkTupE+ maybeExtractionPattern = mapOrHead' makeJustPattern toHandlerOutputNames TupP+ applyToName toApply n = AppE toApply $ VarE n+ finalApplication = foldl applyToName (VarE handlerArgN)+ (receivedSignalN:toHandlerOutputNames)+ makeHandlerN = mkName $ "makeHandlerFor" ++ signalString+ makeHandlerCall =+ if takeErrorHandler+ then AppE base (VarE errorHandlerN)+ else base+ where base = AppE (VarE makeHandlerN) (VarE handlerArgN)+ getSetSignal =+ if takeObjectPathArg+ then [|+ $( varE signalDefN )+ { M.signalPath = $( varE objectPathN )+ , M.signalBody = $( varE variantsN )+ }+ |]+ else [| $( varE signalDefN )+ { M.signalBody = $( varE variantsN ) }+ |]+ getEmitBody = [|+ let $( varP variantsN ) = $( return $ ListE variantListExp )+ $( varP signalN ) = $( getSetSignal )+ in+ emit $( varE clientN ) $( varE signalN )+ |]+ getErrorHandler =+ if takeErrorHandler then+ [| $( varE errorHandlerN ) $( varE receivedSignalN )|]+ else [| return () |]+ getMakeHandlerBody =+ if argCount == 0+ then+ [| $( return finalApplication ) |]+ else+ [|+ case M.signalBody $( varE receivedSignalN ) of+ $( return $ ListP $ map VarP fromVariantOutputNames ) ->+ case $( return fromVariantExp ) of+ $( return maybeExtractionPattern ) -> $( return finalApplication )+ _ -> $( getErrorHandler )+ _ -> $( getErrorHandler )+ |]+ getRegisterBody = [|+ let $( varP matchRuleN ) = $( varE matchRuleArgN )+ { C.matchInterface = Just signalInterface+ , C.matchMember = Just name+ , C.matchSender =+ runGetFirst+ [ C.matchSender $( varE matchRuleArgN )+ , busNameM+ ]+ , C.matchPath =+ runGetFirst+ [ C.matchPath $( varE matchRuleArgN )+ , objectPathM+ ]+ }+ in+ C.addMatch $( varE clientN ) $( varE matchRuleN ) $ $( return makeHandlerCall )+ |]+ registerBody <- getRegisterBody+ makeHandlerBody <- getMakeHandlerBody+ signalDef <- getSignalDefDec+ emitBody <- getEmitBody+ let methodSignature = foldr addInArg unitIOType args+ addInArg arg = addTypeArg $ getArgType $ I.signalArgType arg+ fullArgNames = clientN:addArgIf takeObjectPathArg objectPathN argNames+ -- Never take bus arg because it is set automatically anyway+ fullSignature =+ buildGeneratedSignature False takeObjectPathArg methodSignature+ functionN = mkName $ "emit" ++ signalString+ emitSignature = SigD functionN fullSignature+ emitFunction = mkFunD functionN fullArgNames emitBody+ handlerType = addTypeArg (ConT ''M.Signal) methodSignature+ errorHandlerType = addTypeArg (ConT ''M.Signal) unitIOType+ registerN = mkName $ "registerFor" ++ signalString+ registerArgs = clientN:matchRuleArgN:handlerArgN:+ addArgIf takeErrorHandler errorHandlerN []+ registerFunction = mkFunD registerN registerArgs registerBody+ registerType =+ addTypeArg (ConT ''C.Client) $+ addTypeArg (ConT ''C.MatchRule) $+ addTypeArg handlerType $+ addTypeArgIf takeErrorHandler (addTypeArg (ConT ''M.Signal) unitIOType) $+ AppT (ConT ''IO) (ConT ''C.SignalHandler)+ registerSignature = SigD registerN registerType+ makeHandlerArgs =+ handlerArgN:addArgIf takeErrorHandler errorHandlerN [receivedSignalN]+ makeHandlerFunction = mkFunD makeHandlerN makeHandlerArgs makeHandlerBody+ makeHandlerType = addTypeArg handlerType $+ addTypeArgIf takeErrorHandler errorHandlerType $+ addTypeArg (ConT ''M.Signal) unitIOType+ makeHandlerSignature = SigD makeHandlerN makeHandlerType+ signalSignature = SigD signalDefN (ConT ''M.Signal)+ return $ signalSignature:+ signalDef ++ [ emitSignature, emitFunction+ , makeHandlerSignature, makeHandlerFunction+ , registerSignature, registerFunction+ ]++generateFromFilePath :: GenerationParams -> FilePath -> Q [Dec]+generateFromFilePath generationParams filepath = do+ xml <- runIO $ Text.readFile filepath+ let obj = head $ maybeToList $ I.parseXML "/" xml+ interface = head $ I.objectInterfaces obj+ signals = generateSignalsFromInterface generationParams interface+ client = generateClient generationParams interface+ in fmap (++) signals <*> client
lib/DBus/Internal/Address.hs view
@@ -1,26 +1,26 @@+{-# Language LambdaCase #-} -- 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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBus.Internal.Address where -import qualified Control.Exception import Data.Char (digitToInt, ord, chr)+import Data.Maybe (listToMaybe, fromMaybe) import Data.List (intercalate) import qualified Data.Map import Data.Map (Map)-import qualified System.Environment+import System.Environment (lookupEnv) import Text.Printf (printf) import Text.ParserCombinators.Parsec@@ -141,18 +141,20 @@ 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))+ env <- lookupEnv "DBUS_SYSTEM_BUS_ADDRESS"+ return (parseAddress (fromMaybe system env)) --- | Returns the address in the environment variable+-- | Returns the first 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.+-- Returns 'Nothing' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid address+-- or @DBUS_SESSION_BUS_ADDRESS@ is unset @XDG_RUNTIME_DIR@ doesn't have @/bus@. getSessionAddress :: IO (Maybe Address)-getSessionAddress = do- env <- getenv "DBUS_SESSION_BUS_ADDRESS"- return (env >>= parseAddress)+getSessionAddress = lookupEnv "DBUS_SESSION_BUS_ADDRESS" >>= \case+ Just addrs -> pure (parseAddresses addrs >>= listToMaybe)+ Nothing -> (>>= parseFallback) <$> lookupEnv "XDG_RUNTIME_DIR"+ where+ parseFallback dir = parseAddress ("unix:path=" ++ dir ++ "/bus") -- | Returns the address in the environment variable -- @DBUS_STARTER_ADDRESS@, which must be set.@@ -161,13 +163,8 @@ -- invalid address. getStarterAddress :: IO (Maybe Address) getStarterAddress = do- env <- getenv "DBUS_STARTER_ADDRESS"+ env <- lookupEnv "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
lib/DBus/Internal/Types.hs view
@@ -1,14 +1,12 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE IncoherentInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} -- 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.@@ -23,32 +21,31 @@ module DBus.Internal.Types where -import Control.DeepSeq-import Control.Exception (Exception, handle, throwIO)-import Control.Monad (liftM, when, (>=>))-import Data.ByteString (ByteString)-import Data.Char (ord)-import Data.Int-import Data.List (intercalate)-import Data.Map (Map)-import Data.Text (Text)-import Data.Typeable (Typeable)-import Data.Vector (Vector)-import Data.Word-import GHC.Generics-import System.IO.Unsafe (unsafePerformIO)-import System.Posix.Types (Fd)-import Text.ParserCombinators.Parsec ((<|>), oneOf)-import qualified Data.ByteString-import qualified Data.ByteString.Char8 as Char8-import qualified Data.ByteString.Lazy-import qualified Data.ByteString.Unsafe+import Control.DeepSeq+import Control.Monad (liftM, when, (>=>))+import Control.Monad.Catch+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BL+import Data.Char (ord)+import Data.Coerce+import Data.Int+import Data.List (intercalate)+import Data.List.Split (splitOn) 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, Proxy(..)) import qualified Data.Vector-import qualified Foreign+import Data.Vector (Vector)+import Data.Word+import GHC.Generics+import qualified Language.Haskell.TH.Lift as THL+import System.Posix.Types (Fd)+import Text.ParserCombinators.Parsec ((<|>), oneOf) import qualified Text.ParserCombinators.Parsec as Parsec data Type@@ -151,12 +148,12 @@ -- | Convert a list of types into a valid signature. ----- Returns @Nothing@ if the given types are not a valid signature.-signature :: [Type] -> Maybe Signature+-- Throws if the given types are not a valid signature.+signature :: MonadThrow m => [Type] -> m Signature signature = check where check ts = if sumLen ts > 255- then Nothing- else Just (Signature ts)+ then throwM $ userError "invalid signature"+ else pure (Signature ts) sumLen :: [Type] -> Int sumLen = sum . map len @@ -184,29 +181,29 @@ -- | Parse a signature string into a valid signature. ----- Returns @Nothing@ if the given string is not a valid signature.-parseSignature :: String -> Maybe Signature+-- Throws if the given string is not a valid signature.+parseSignature :: MonadThrow m => String -> m Signature parseSignature s = do- when (length s > 255) Nothing- when (any (\c -> ord c > 0x7F) s) Nothing- parseSignatureBytes (Char8.pack s)+ when (length s > 255) $ throwM $ userError "string too long"+ when (any (\c -> ord c > 0x7F) s) $ throwM $ userError "invalid signature"+ parseSignatureBytes (BS8.pack s) -parseSignatureBytes :: ByteString -> Maybe Signature+parseSignatureBytes :: MonadThrow m => BS.ByteString -> m Signature parseSignatureBytes bytes =- case Data.ByteString.length bytes of- 0 -> Just (Signature [])+ case BS.length bytes of+ 0 -> pure (Signature []) 1 -> parseSigFast bytes len | len <= 255 -> parseSigFull bytes- _ -> Nothing+ _ -> throwM $ userError "string too long" -parseSigFast :: ByteString -> Maybe Signature+parseSigFast :: MonadThrow m => BS.ByteString -> m 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)+ let byte = BS.head bytes+ in parseAtom (fromIntegral byte)+ (\t -> pure (Signature [t]))+ (case byte of+ 0x76 -> pure (Signature [TypeVariant])+ _ -> throwM $ userError "invalid signature") parseAtom :: Int -> (Type -> a) -> a -> a parseAtom byte yes no = case byte of@@ -231,95 +228,90 @@ 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))+peekWord8AsInt :: BS.ByteString -> Int -> Int+peekWord8AsInt str i = fromIntegral $ BS.index str i - parseSigBuf (buf, len) = mainLoop [] 0 where+parseSigFull :: MonadThrow m => BS.ByteString -> m Signature+parseSigFull bytes = Signature <$> mainLoop [] 0+ where+ len = BS.length bytes+ mainLoop acc ii | ii >= len = pure (reverse acc)+ mainLoop acc ii = do+ let c = peekWord8AsInt bytes 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'+ _ -> throwM SigParseError - mainLoop acc ii | ii >= len = return (reverse acc)- mainLoop acc ii = do- c <- peekWord8AsInt buf ii- let next t = mainLoop (t : acc) (ii + 1)+ structure = loop [] where+ loop _ ii | ii >= len = throwM SigParseError+ loop acc ii = do+ let c = peekWord8AsInt bytes 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)- mainLoop (t : acc) ii'+ loop (t : acc) ii' 0x61 -> do -- 'a' (ii', t) <- array (ii + 1)- mainLoop (t : acc) ii'- _ -> throwIO SigParseError+ loop (t : acc) ii'+ -- ')'+ 0x29 -> case acc of+ [] -> throwM SigParseError+ _ -> pure (ii + 1, TypeStructure (reverse acc))+ _ -> throwM 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 ii | ii >= len = throwM SigParseError+ array ii = do+ let c = peekWord8AsInt bytes ii+ let next t = pure (ii + 1, TypeArray t)+ parseAtom c next $ case c of+ 0x76 -> next TypeVariant+ 0x7B -> dict (ii + 1) -- '{'+ 0x28 -> do -- '('+ (ii', t) <- structure (ii + 1)+ pure (ii', TypeArray t)+ 0x61 -> do -- 'a'+ (ii', t) <- array (ii + 1)+ pure (ii', TypeArray t)+ _ -> throwM 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 ii | ii + 1 >= len = throwM SigParseError+ dict ii = do+ let c1 = peekWord8AsInt bytes ii+ let c2 = peekWord8AsInt bytes (ii + 1) - 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 = pure (ii + 2, t)+ (ii', t2) <- parseAtom c2 next $ case c2 of+ 0x76 -> next TypeVariant+ 0x28 -> structure (ii + 2) -- '('+ 0x61 -> array (ii + 2) -- 'a'+ _ -> throwM SigParseError - 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 throwM SigParseError+ else do+ let c3 = peekWord8AsInt bytes ii'+ if c3 == 0x7D+ then do+ t1 <- parseAtom c1 pure (throwM SigParseError)+ pure (ii' + 1, TypeDictionary t1 t2)+ else throwM 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+extractFromVariant :: IsValue a => Variant -> Maybe a+extractFromVariant (Variant (ValueVariant v)) = extractFromVariant v+extractFromVariant v = fromVariant v +typeOf :: forall a. IsValue a => a -> Type+typeOf _ = typeOf_ (Proxy :: Proxy a)+ class IsVariant a where toVariant :: a -> Variant fromVariant :: Variant -> Maybe a@@ -330,7 +322,7 @@ -- 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+ typeOf_ :: Proxy a -> Type toValue :: a -> Value fromValue :: Value -> Maybe a @@ -351,7 +343,7 @@ data Value = ValueAtom Atom | ValueVariant Variant- | ValueBytes ByteString+ | ValueBytes BS.ByteString | ValueVector Type (Vector Value) | ValueMap Type Type (Map Atom Value) | ValueStructure [Value]@@ -419,8 +411,8 @@ 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+vectorToBytes :: Vector Value -> BS.ByteString+vectorToBytes = BS.pack . Data.Vector.toList . Data.Vector.map (\(ValueAtom (AtomWord8 x)) -> x) @@ -464,7 +456,7 @@ ; fromAtom _ = Nothing \ }; \ instance IsValue HsType where \- { typeOf _ = TypeCons \+ { typeOf_ _ = TypeCons \ ; toValue = ValueAtom . toAtom \ ; fromValue (ValueAtom x) = fromAtom x \ ; fromValue _ = Nothing \@@ -489,7 +481,7 @@ IS_ATOM(ObjectPath, AtomObjectPath, TypeObjectPath) instance IsValue Variant where- typeOf _ = TypeVariant+ typeOf_ _ = TypeVariant toValue = ValueVariant fromValue (ValueVariant x) = Just x fromValue _ = Nothing@@ -503,7 +495,7 @@ fromAtom = fmap Data.Text.Lazy.fromStrict . fromAtom instance IsValue Data.Text.Lazy.Text where- typeOf _ = TypeString+ typeOf_ _ = TypeString toValue = ValueAtom . toAtom fromValue (ValueAtom x) = fromAtom x fromValue _ = Nothing@@ -517,7 +509,7 @@ fromAtom = fmap Data.Text.unpack . fromAtom instance IsValue String where- typeOf _ = TypeString+ typeOf_ _ = TypeString toValue = ValueAtom . toAtom fromValue (ValueAtom x) = fromAtom x fromValue _ = Nothing@@ -527,20 +519,19 @@ 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)+ typeOf_ _ = TypeArray (typeOf_ (Proxy :: Proxy a))+ toValue v = ValueVector+ (typeOf_ (Proxy :: Proxy a))+ (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))+ typeOf_ _ = TypeArray (typeOf_ (Proxy :: Proxy a)) toValue = toValue . Data.Vector.fromList fromValue = fmap Data.Vector.toList . fromValue @@ -548,35 +539,37 @@ toVariant = toVariant . Data.Vector.fromList fromVariant = fmap Data.Vector.toList . fromVariant -instance IsValue ByteString where- typeOf _ = TypeArray TypeWord8+instance IsValue BS.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+instance IsVariant BS.ByteString where toVariant = Variant . toValue fromVariant (Variant val) = fromValue val -instance IsValue Data.ByteString.Lazy.ByteString where- typeOf _ = TypeArray TypeWord8+instance IsValue BL.ByteString where+ typeOf_ _ = TypeArray TypeWord8 toValue = toValue- . Data.ByteString.concat- . Data.ByteString.Lazy.toChunks- fromValue = fmap (\bs -> Data.ByteString.Lazy.fromChunks [bs])+ . BS.concat+ . BL.toChunks+ fromValue = fmap (\bs -> BL.fromChunks [bs]) . fromValue -instance IsVariant Data.ByteString.Lazy.ByteString where+instance IsVariant BL.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+ typeOf_ _ = TypeDictionary+ (typeOf_ (Proxy :: Proxy k))+ (typeOf_ (Proxy :: Proxy v)) toValue m = ValueMap kt vt (bimap box m) where- (kt, vt) = mapItemType m+ kt = typeOf_ (Proxy :: Proxy k)+ vt = typeOf_ (Proxy :: Proxy v) box k v = (toAtom k, toValue v) fromValue (ValueMap _ _ m) = bimapM unbox m where@@ -592,18 +585,26 @@ 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 () where+ typeOf_ _ = TypeStructure []+ toValue _ = ValueStructure []+ fromValue (ValueStructure []) = return ()+ fromValue _ = Nothing++instance IsVariant () where+ toVariant () = Variant (ValueStructure [])+ fromVariant (Variant (ValueStructure [])) = Just ()+ fromVariant _ = Nothing+ instance (IsValue a1, IsValue a2) => IsValue (a1, a2) where- typeOf ~(a1, a2) = TypeStructure [typeOf a1, typeOf a2]+ typeOf_ _ = TypeStructure+ [ typeOf_ (Proxy :: Proxy a1)+ , typeOf_ (Proxy :: Proxy a2)+ ] toValue (a1, a2) = ValueStructure [toValue a1, toValue a2] fromValue (ValueStructure [a1, a2]) = do a1' <- fromValue a1@@ -635,10 +636,16 @@ newtype ObjectPath = ObjectPath String deriving (Eq, Ord, Show, NFData) +pathElements :: ObjectPath -> [String]+pathElements = filter (not . null) . splitOn "/" . coerce++fromElements :: [String] -> ObjectPath+fromElements elems = objectPath_ $ '/':intercalate "/" elems+ formatObjectPath :: ObjectPath -> String formatObjectPath (ObjectPath s) = s -parseObjectPath :: String -> Maybe ObjectPath+parseObjectPath :: MonadThrow m => String -> m ObjectPath parseObjectPath s = do maybeParseString parserObjectPath s return (ObjectPath s)@@ -681,9 +688,9 @@ formatInterfaceName :: InterfaceName -> String formatInterfaceName (InterfaceName s) = s -parseInterfaceName :: String -> Maybe InterfaceName+parseInterfaceName :: MonadThrow m => String -> m InterfaceName parseInterfaceName s = do- when (length s > 255) Nothing+ when (length s > 255) $ throwM $ userError "name too long" maybeParseString parserInterfaceName s return (InterfaceName s) @@ -721,9 +728,9 @@ formatMemberName :: MemberName -> String formatMemberName (MemberName s) = s -parseMemberName :: String -> Maybe MemberName+parseMemberName :: MonadThrow m => String -> m MemberName parseMemberName s = do- when (length s > 255) Nothing+ when (length s > 255) $ throwM $ userError "name too long" maybeParseString parserMemberName s return (MemberName s) @@ -758,9 +765,9 @@ formatErrorName :: ErrorName -> String formatErrorName (ErrorName s) = s -parseErrorName :: String -> Maybe ErrorName+parseErrorName :: MonadThrow m => String -> m ErrorName parseErrorName s = do- when (length s > 255) Nothing+ when (length s > 255) $ throwM $ userError "name too long" maybeParseString parserInterfaceName s return (ErrorName s) @@ -788,9 +795,9 @@ formatBusName :: BusName -> String formatBusName (BusName s) = s -parseBusName :: String -> Maybe BusName+parseBusName :: MonadThrow m => String -> m BusName parseBusName s = do- when (length s > 255) Nothing+ when (length s > 255) $ throwM $ userError "name too long" maybeParseString parserBusName s return (BusName s) @@ -829,7 +836,7 @@ 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+-- values of any type that is convertible to 'IsVariant'. A Structure may -- contain up to 255 values. -- -- Most users can use the 'IsVariant' instance for tuples to extract the@@ -858,7 +865,7 @@ -- 'IsValue'. data Array = Array Type (Vector Value)- | ArrayBytes ByteString+ | ArrayBytes BS.ByteString instance Show Array where show (Array t xs) = showValue True (ValueVector t xs)@@ -879,7 +886,7 @@ arrayItems :: Array -> [Variant] arrayItems (Array _ xs) = map Variant (Data.Vector.toList xs)-arrayItems (ArrayBytes bs) = map toVariant (Data.ByteString.unpack bs)+arrayItems (ArrayBytes bs) = map toVariant (BS.unpack bs) -- | A D-Bus Dictionary is a container type similar to Haskell maps, storing -- zero or more associations between keys and values.@@ -905,7 +912,11 @@ 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]+ typeOf_ _ = TypeStructure+ [ typeOf_ (Proxy :: Proxy a1)+ , typeOf_ (Proxy :: Proxy a2)+ , typeOf_ (Proxy :: Proxy a3)+ ] toValue (a1, a2, a3) = ValueStructure [toValue a1, toValue a2, toValue a3] fromValue (ValueStructure [a1, a2, a3]) = do a1' <- fromValue a1@@ -915,7 +926,12 @@ 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]+ typeOf_ _ = TypeStructure+ [ typeOf_ (Proxy :: Proxy a1)+ , typeOf_ (Proxy :: Proxy a2)+ , typeOf_ (Proxy :: Proxy a3)+ , typeOf_ (Proxy :: Proxy 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@@ -926,7 +942,13 @@ 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]+ typeOf_ _ = TypeStructure+ [ typeOf_ (Proxy :: Proxy a1)+ , typeOf_ (Proxy :: Proxy a2)+ , typeOf_ (Proxy :: Proxy a3)+ , typeOf_ (Proxy :: Proxy a4)+ , typeOf_ (Proxy :: Proxy 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@@ -938,7 +960,14 @@ 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]+ typeOf_ _ = TypeStructure+ [ typeOf_ (Proxy :: Proxy a1)+ , typeOf_ (Proxy :: Proxy a2)+ , typeOf_ (Proxy :: Proxy a3)+ , typeOf_ (Proxy :: Proxy a4)+ , typeOf_ (Proxy :: Proxy a5)+ , typeOf_ (Proxy :: Proxy 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@@ -951,7 +980,15 @@ 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]+ typeOf_ _ = TypeStructure+ [ typeOf_ (Proxy :: Proxy a1)+ , typeOf_ (Proxy :: Proxy a2)+ , typeOf_ (Proxy :: Proxy a3)+ , typeOf_ (Proxy :: Proxy a4)+ , typeOf_ (Proxy :: Proxy a5)+ , typeOf_ (Proxy :: Proxy a6)+ , typeOf_ (Proxy :: Proxy 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@@ -965,7 +1002,16 @@ 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]+ typeOf_ _ = TypeStructure+ [ typeOf_ (Proxy :: Proxy a1)+ , typeOf_ (Proxy :: Proxy a2)+ , typeOf_ (Proxy :: Proxy a3)+ , typeOf_ (Proxy :: Proxy a4)+ , typeOf_ (Proxy :: Proxy a5)+ , typeOf_ (Proxy :: Proxy a6)+ , typeOf_ (Proxy :: Proxy a7)+ , typeOf_ (Proxy :: Proxy 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@@ -980,7 +1026,17 @@ 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]+ typeOf_ _ = TypeStructure+ [ typeOf_ (Proxy :: Proxy a1)+ , typeOf_ (Proxy :: Proxy a2)+ , typeOf_ (Proxy :: Proxy a3)+ , typeOf_ (Proxy :: Proxy a4)+ , typeOf_ (Proxy :: Proxy a5)+ , typeOf_ (Proxy :: Proxy a6)+ , typeOf_ (Proxy :: Proxy a7)+ , typeOf_ (Proxy :: Proxy a8)+ , typeOf_ (Proxy :: Proxy 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@@ -996,7 +1052,18 @@ 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]+ typeOf_ _ = TypeStructure+ [ typeOf_ (Proxy :: Proxy a1)+ , typeOf_ (Proxy :: Proxy a2)+ , typeOf_ (Proxy :: Proxy a3)+ , typeOf_ (Proxy :: Proxy a4)+ , typeOf_ (Proxy :: Proxy a5)+ , typeOf_ (Proxy :: Proxy a6)+ , typeOf_ (Proxy :: Proxy a7)+ , typeOf_ (Proxy :: Proxy a8)+ , typeOf_ (Proxy :: Proxy a9)+ , typeOf_ (Proxy :: Proxy 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@@ -1013,7 +1080,19 @@ 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]+ typeOf_ _ = TypeStructure+ [ typeOf_ (Proxy :: Proxy a1)+ , typeOf_ (Proxy :: Proxy a2)+ , typeOf_ (Proxy :: Proxy a3)+ , typeOf_ (Proxy :: Proxy a4)+ , typeOf_ (Proxy :: Proxy a5)+ , typeOf_ (Proxy :: Proxy a6)+ , typeOf_ (Proxy :: Proxy a7)+ , typeOf_ (Proxy :: Proxy a8)+ , typeOf_ (Proxy :: Proxy a9)+ , typeOf_ (Proxy :: Proxy a10)+ , typeOf_ (Proxy :: Proxy 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@@ -1031,7 +1110,20 @@ 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]+ typeOf_ _ = TypeStructure+ [ typeOf_ (Proxy :: Proxy a1)+ , typeOf_ (Proxy :: Proxy a2)+ , typeOf_ (Proxy :: Proxy a3)+ , typeOf_ (Proxy :: Proxy a4)+ , typeOf_ (Proxy :: Proxy a5)+ , typeOf_ (Proxy :: Proxy a6)+ , typeOf_ (Proxy :: Proxy a7)+ , typeOf_ (Proxy :: Proxy a8)+ , typeOf_ (Proxy :: Proxy a9)+ , typeOf_ (Proxy :: Proxy a10)+ , typeOf_ (Proxy :: Proxy a11)+ , typeOf_ (Proxy :: Proxy 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@@ -1050,7 +1142,21 @@ 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]+ typeOf_ _ = TypeStructure+ [ typeOf_ (Proxy :: Proxy a1)+ , typeOf_ (Proxy :: Proxy a2)+ , typeOf_ (Proxy :: Proxy a3)+ , typeOf_ (Proxy :: Proxy a4)+ , typeOf_ (Proxy :: Proxy a5)+ , typeOf_ (Proxy :: Proxy a6)+ , typeOf_ (Proxy :: Proxy a7)+ , typeOf_ (Proxy :: Proxy a8)+ , typeOf_ (Proxy :: Proxy a9)+ , typeOf_ (Proxy :: Proxy a10)+ , typeOf_ (Proxy :: Proxy a11)+ , typeOf_ (Proxy :: Proxy a12)+ , typeOf_ (Proxy :: Proxy 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@@ -1070,7 +1176,22 @@ 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]+ typeOf_ _ = TypeStructure+ [ typeOf_ (Proxy :: Proxy a1)+ , typeOf_ (Proxy :: Proxy a2)+ , typeOf_ (Proxy :: Proxy a3)+ , typeOf_ (Proxy :: Proxy a4)+ , typeOf_ (Proxy :: Proxy a5)+ , typeOf_ (Proxy :: Proxy a6)+ , typeOf_ (Proxy :: Proxy a7)+ , typeOf_ (Proxy :: Proxy a8)+ , typeOf_ (Proxy :: Proxy a9)+ , typeOf_ (Proxy :: Proxy a10)+ , typeOf_ (Proxy :: Proxy a11)+ , typeOf_ (Proxy :: Proxy a12)+ , typeOf_ (Proxy :: Proxy a13)+ , typeOf_ (Proxy :: Proxy 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@@ -1091,7 +1212,23 @@ 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]+ typeOf_ _ = TypeStructure+ [ typeOf_ (Proxy :: Proxy a1)+ , typeOf_ (Proxy :: Proxy a2)+ , typeOf_ (Proxy :: Proxy a3)+ , typeOf_ (Proxy :: Proxy a4)+ , typeOf_ (Proxy :: Proxy a5)+ , typeOf_ (Proxy :: Proxy a6)+ , typeOf_ (Proxy :: Proxy a7)+ , typeOf_ (Proxy :: Proxy a8)+ , typeOf_ (Proxy :: Proxy a9)+ , typeOf_ (Proxy :: Proxy a10)+ , typeOf_ (Proxy :: Proxy a11)+ , typeOf_ (Proxy :: Proxy a12)+ , typeOf_ (Proxy :: Proxy a13)+ , typeOf_ (Proxy :: Proxy a14)+ , typeOf_ (Proxy :: Proxy 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@@ -1340,7 +1477,9 @@ Just x -> x Nothing -> error ("Invalid " ++ label ++ ": " ++ show str) -maybeParseString :: Parsec.Parser a -> String -> Maybe a+maybeParseString :: MonadThrow m => Parsec.Parser a -> String -> m a maybeParseString parser s = case Parsec.parse parser "" s of- Left _ -> Nothing- Right a -> Just a+ Left err -> throwM $ userError $ show err+ Right a -> pure a++THL.deriveLiftMany [''BusName, ''ObjectPath, ''InterfaceName, ''MemberName]
lib/DBus/Internal/Wire.hs view
@@ -1,3 +1,4 @@+{-# Language LambdaCase #-} -- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com> -- -- This program is free software: you can redistribute it and/or modify@@ -34,6 +35,7 @@ import qualified Data.ByteString.Char8 import qualified Data.ByteString.Lazy as Lazy import Data.Int (Int16, Int32, Int64)+import Data.List (sortOn) import qualified Data.Map import Data.Map (Map) import Data.Maybe (fromJust, listToMaybe, fromMaybe)@@ -43,7 +45,6 @@ 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 @@ -108,25 +109,22 @@ instance Control.Applicative.Applicative (Wire s) where {-# INLINE pure #-}- pure = return+ pure a = Wire (\_ s -> WireRR a s) + {-# INLINE (*>) #-}+ m *> k = Wire $ \e s -> case unWire m e s of+ WireRL err -> WireRL err+ WireRR _ s' -> unWire k e s'+ {-# 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) @@ -155,6 +153,7 @@ data MarshalState = MarshalState !Builder.Builder {-# UNPACK #-} !Word64+ !(Map Fd Word32) marshal :: Value -> Marshal () marshal (ValueAtom x) = marshalAtom x@@ -180,10 +179,10 @@ marshalAtom (AtomSignature x) = marshalSignature x appendB :: Word64 -> Builder.Builder -> Marshal ()-appendB size bytes = Wire (\_ (MarshalState builder count) -> let+appendB size bytes = Wire (\_ (MarshalState builder count fds) -> let builder' = mappend builder bytes count' = count + size- in WireRR () (MarshalState builder' count'))+ in WireRR () (MarshalState builder' count' fds)) appendS :: ByteString -> Marshal () appendS bytes = appendB@@ -197,7 +196,7 @@ pad :: Word8 -> Marshal () pad count = do- (MarshalState _ existing) <- getState+ (MarshalState _ existing _) <- getState let padding' = fromIntegral (padding existing count) appendS (Data.ByteString.replicate padding' 0) @@ -221,6 +220,7 @@ data UnmarshalState = UnmarshalState {-# UNPACK #-} !ByteString {-# UNPACK #-} !Word64+ ![Fd] unmarshal :: Type -> Unmarshal Value unmarshal TypeWord8 = liftM toValue unmarshalWord8@@ -245,19 +245,19 @@ {-# INLINE consume #-} consume :: Word64 -> Unmarshal ByteString consume count = do- (UnmarshalState bytes offset) <- getState+ (UnmarshalState bytes offset fds) <- 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))+ putState (UnmarshalState bytes' (offset + count) fds) return x else throwError ("Unexpected EOF at offset " ++ show (offset + fromIntegral lenConsumed)) skipPadding :: Word8 -> Unmarshal () skipPadding count = do- (UnmarshalState _ offset) <- getState+ (UnmarshalState _ offset _) <- getState bytes <- consume (padding offset count) unless (Data.ByteString.all (== 0) bytes) (throwError ("Value padding " ++ show bytes ++ " contains invalid bytes."))@@ -346,17 +346,25 @@ getFloat64le marshalUnixFd :: Fd -> Marshal ()-marshalUnixFd (Fd x)+marshalUnixFd fd@(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)+ | otherwise = do+ MarshalState builder count fds <- getState+ case Data.Map.lookup fd fds of+ Just i -> marshalWord32 i+ Nothing -> do+ let i = fromIntegral (Data.Map.size fds)+ putState (MarshalState builder count (Data.Map.insert fd i fds))+ marshalWord32 i unmarshalUnixFd :: Unmarshal Fd unmarshalUnixFd = do- x <- unmarshalWord32- when (toInteger x > toInteger (maxBound :: CInt))- (throwError ("Invalid file descriptor: " ++ show x))- return (Fd (fromIntegral x))+ x <- fromIntegral <$> unmarshalWord32+ UnmarshalState _ _ fds <- getState+ when (x >= length fds) $ do+ throwError ("File descriptor index " ++ show x ++ " out of bounds - only " ++ show (length fds) ++ " file descriptors in message header.")+ return (fds !! x) marshalBool :: Bool -> Marshal () marshalBool False = marshalWord32 0@@ -443,17 +451,17 @@ 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+ (MarshalState bytes count fds) <- getState+ (MarshalState _ afterLength _) <- marshalWord32 0 >> getState+ (MarshalState _ afterPadding _) <- pad (alignment itemType) >> getState - putState (MarshalState mempty afterPadding)- (MarshalState itemBuilder _) <- Data.Vector.mapM_ marshal vs >> getState+ putState (MarshalState mempty afterPadding fds)+ (MarshalState itemBuilder _ fds') <- Data.Vector.mapM_ marshal vs >> getState let itemBytes = Builder.toLazyByteString itemBuilder paddingSize = fromIntegral (afterPadding - afterLength) - putState s+ putState (MarshalState bytes count fds') return (paddingSize, itemBytes) unmarshalByteArray :: Unmarshal ByteString@@ -464,15 +472,15 @@ unmarshalArray :: Type -> Unmarshal (Vector Value) unmarshalArray itemType = do let getOffset = do- (UnmarshalState _ o) <- getState- return o+ (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))+ when (end' > end) (throwError ("Array data size exceeds array size of " ++ show end)) return (Data.Vector.fromList vs) dictionaryToArray :: Map Atom Value -> Vector Value@@ -564,35 +572,37 @@ Nothing -> throwErrorM (UnmarshalError ("Header field " ++ show label ++ " contains invalid value " ++ show x)) marshalMessage :: Message a => Endianness -> Serial -> a- -> Either MarshalError ByteString+ -> Either MarshalError (ByteString, [Fd]) marshalMessage e serial msg = runMarshal where body = messageBody msg marshaler = do sig <- checkBodySig body- empty <- getState+ MarshalState emptyBytes emptyCount _ <- getState mapM_ (marshal . (\(Variant x) -> x)) body- (MarshalState bodyBytesB _) <- getState- putState empty+ (MarshalState bodyBytesB _ fds) <- getState+ putState (MarshalState emptyBytes emptyCount fds) marshal (toValue (encodeEndianness e)) let bodyBytes = Builder.toLazyByteString bodyBytesB- marshalHeader msg serial sig (fromIntegral (Lazy.length bodyBytes))+ marshalHeader msg serial sig (fromIntegral (Lazy.length bodyBytes)) (Data.Map.size fds) pad 8 appendL bodyBytes checkMaximumSize- emptyState = MarshalState mempty 0+ emptyState = MarshalState mempty 0 mempty runMarshal = case unWire marshaler e emptyState of WireRL err -> Left (MarshalError err)- WireRR _ (MarshalState builder _) -> Right (Lazy.toStrict (Builder.toLazyByteString builder))+ WireRR _ (MarshalState builder _ fds) ->+ let fdList = (map fst . sortOn snd . Data.Map.toList) fds+ in Right (Lazy.toStrict (Builder.toLazyByteString builder), fdList) 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+marshalHeader :: Message a => a -> Serial -> Signature -> Word32 -> Int -> Marshal ()-marshalHeader msg serial bodySig bodyLength = do- let fields = HeaderSignature bodySig : messageHeaderFields msg+marshalHeader msg serial bodySig bodyLength numFds = do+ let fields = HeaderSignature bodySig : consUnixFdsField numFds (messageHeaderFields msg) marshalWord8 (messageTypeCode msg) marshalWord8 (messageFlags msg) marshalWord8 protocolVersion@@ -601,23 +611,34 @@ let fieldType = TypeStructure [TypeWord8, TypeVariant] marshalVector fieldType (Data.Vector.fromList (map encodeField fields)) +consUnixFdsField :: Int -> [HeaderField] -> [HeaderField]+consUnixFdsField numFds headers =+ if numFds == 0+ then filteredHeaders+ else HeaderUnixFds (fromIntegral numFds) : filteredHeaders+ where+ filteredHeaders = filter (not . isHeaderUnixFds) headers+ isHeaderUnixFds = \case+ HeaderUnixFds _ -> True+ _ -> False+ checkMaximumSize :: Marshal () checkMaximumSize = do- (MarshalState _ messageLength) <- getState+ (MarshalState _ messageLength _) <- getState when (toInteger messageLength > messageMaximumLength)- (throwError ("Marshaled message size (" ++ show messageLength ++ " bytes) exeeds maximum limit of (" ++ show messageMaximumLength ++ " bytes)."))+ (throwError ("Marshaled message size (" ++ show messageLength ++ " bytes) exceeds maximum limit of (" ++ show messageMaximumLength ++ " bytes).")) -unmarshalMessageM :: Monad m => (Int -> m ByteString)+unmarshalMessageM :: Monad m => (Int -> m (ByteString, [Fd])) -> 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+ (bytes, fds) <- 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, fds) let Just fixedSig = parseSignature "yyyyuuu"- fixedBytes <- getBytes 16+ (fixedBytes, fixedFds) <- getBytes 16 let messageVersion = Data.ByteString.index fixedBytes 3 when (messageVersion /= protocolVersion) (throwErrorT (UnmarshalError ("Unsupported protocol version: " ++ show messageVersion)))@@ -628,10 +649,10 @@ 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+ let unmarshal' x bytes fds = case unWire (unmarshalSig x) endianness (UnmarshalState bytes 0 fds) of WireRR x' _ -> return x' WireRL err -> throwErrorT (UnmarshalError err)- fixed <- unmarshal' fixedSig fixedBytes+ fixed <- unmarshal' fixedSig fixedBytes [] let messageType = fromJust (fromValue (fixed !! 1)) let flags = fromJust (fromValue (fixed !! 2)) let bodyLength = fromJust (fromValue (fixed !! 4)) :: Word32@@ -646,26 +667,39 @@ throwErrorT (UnmarshalError ("Message size " ++ show messageLength ++ " exceeds limit of " ++ show messageMaximumLength)) let Just headerSig = parseSignature "yyyyuua(yv)"- fieldBytes <- getBytes (fromIntegral fieldByteCount)+ (fieldBytes, fieldFds) <- getBytes (fromIntegral fieldByteCount) let headerBytes = Data.ByteString.append fixedBytes fieldBytes- header <- unmarshal' headerSig headerBytes+ 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)+ (_, paddingFds) <- getBytes (fromIntegral bodyPadding) let bodySig = findBodySignature fields- bodyBytes <- getBytes (fromIntegral bodyLength)- body <- unmarshal' bodySig bodyBytes+ (bodyBytes, bodyFds) <- getBytes (fromIntegral bodyLength)+ let fds = fixedFds <> fieldFds <> paddingFds <> bodyFds+ checkUnixFdsHeader fields fds+ body <- unmarshal' bodySig bodyBytes fds 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)) +checkUnixFdsHeader :: Monad m => [HeaderField] -> [Fd] -> ErrorT UnmarshalError m ()+checkUnixFdsHeader fields fds = do+ let headerCount = findUnixFds fields+ when (headerCount /= length fds) $+ throwErrorT (UnmarshalError ("File descriptor count in message header"+ <> " (" <> show headerCount <> ") does not match the number of file descriptors"+ <> " received from the socket (" <> show (length fds) <> ")."))+ findBodySignature :: [HeaderField] -> Signature findBodySignature fields = fromMaybe (signature_ []) (listToMaybe [x | HeaderSignature x <- fields]) +findUnixFds :: [HeaderField] -> Int+findUnixFds fields = fromMaybe 0 (listToMaybe [fromIntegral n | HeaderUnixFds n <- fields])+ buildReceivedMessage :: Word8 -> [HeaderField] -> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage) buildReceivedMessage 1 fields = do path <- require "path" [x | HeaderPath x <- fields]@@ -713,15 +747,16 @@ require _ (x:_) = return x require label _ = throwErrorM label -unmarshalMessage :: ByteString -> Either UnmarshalError ReceivedMessage-unmarshalMessage bytes = checkError (Get.runGet get bytes) where+unmarshalMessage :: ByteString -> [Fd] -> Either UnmarshalError ReceivedMessage+unmarshalMessage bytes fds = 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)+ buf <- Get.getByteString (min remaining count)+ return (buf, if remaining == Data.ByteString.length bytes then fds else []) checkError (Left err) = Left (UnmarshalError err) checkError (Right x) = x@@ -749,11 +784,10 @@ Right x -> Right (f x) instance Control.Applicative.Applicative (ErrorM e) where- pure = return+ pure = ErrorM . Right (<*>) = ap instance Monad (ErrorM e) where- return = ErrorM . Right (>>=) m k = case runErrorM m of Left err -> ErrorM (Left err) Right x -> k x@@ -767,11 +801,10 @@ fmap = liftM instance Monad m => Control.Applicative.Applicative (ErrorT e m) where- pure = return+ pure = ErrorT . return . Right (<*>) = ap instance Monad m => Monad (ErrorT e m) where- return = ErrorT . return . Right (>>=) m k = ErrorT $ do x <- runErrorT m case x of
lib/DBus/Introspection.hs view
@@ -1,428 +1,7 @@-{-# LANGUAGE OverloadedStrings #-}---- 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.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+ ( module X ) where -import qualified Control.Applicative-import Control.Monad ((>=>), ap, liftM)-import Control.Monad.ST (runST)-import Data.List (isPrefixOf)-import qualified Data.STRef as ST-import qualified Data.Text-import Data.Text (Text)-import qualified Data.Text.Encoding-import qualified Data.XML.Types as X-import qualified Text.XML.LibXML.SAX as SAX--import qualified DBus as T--data Object = Object- { 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)--interface :: T.InterfaceName -> Interface-interface name = Interface name [] [] []--data Method = Method- { 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)--methodArg :: String -> T.Type -> Direction -> MethodArg-methodArg = MethodArg--data Direction = In | Out- deriving (Show, Eq)--directionIn :: Direction-directionIn = In--directionOut :: Direction-directionOut = Out--data Signal = Signal- { 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)--signalArg :: String -> T.Type -> SignalArg-signalArg = SignalArg--data Property = Property- { 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--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')--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--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--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')-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)--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)--parseSignal :: X.Element -> Maybe Signal-parseSignal e = do- 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--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)--parseSignalArg :: X.Element -> Maybe SignalArg-parseSignalArg e = do- 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]--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)--getattr :: X.Name -> X.Element -> String-getattr name e = maybe "" Data.Text.unpack (X.attributeText name e)--children :: Monad m => (X.Element -> m b) -> (X.Element -> [X.Element]) -> X.Element -> m [b]-children f p = mapM f . concatMap p . X.elementChildren--newtype XmlWriter a = XmlWriter { runXmlWriter :: Maybe (a, String) }--instance Functor XmlWriter where- fmap = liftM--instance Control.Applicative.Applicative XmlWriter where- 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')--tell :: String -> XmlWriter ()-tell s = XmlWriter (Just ((), s))--formatXML :: Object -> Maybe String-formatXML obj = do- (_, 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--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--writeObject :: String -> Object -> XmlWriter ()-writeObject path (Object fullPath interfaces children') = writeElement "node"- [("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--writeMethod :: Method -> XmlWriter ()-writeMethod (Method name args) = writeElement "method"- [("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--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)--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)- ]--writeSignalArg :: SignalArg -> XmlWriter ()-writeSignalArg (SignalArg name t) = do- 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)- ]--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 ">"--writeEmptyElement :: String -> [(String, String)] -> XmlWriter ()-writeEmptyElement name attrs = do- tell "<"- tell name- mapM_ writeAttribute attrs- tell "/>"--writeAttribute :: (String, String) -> XmlWriter ()-writeAttribute (name, content) = do- tell " "- tell name- tell "='"- tell (escape content)- tell "'"--escape :: String -> String-escape = concatMap $ \c -> case c of- '&' -> "&"- '<' -> "<"- '>' -> ">"- '"' -> """- '\'' -> "'"- _ -> [c]+import DBus.Introspection.Types as X+import DBus.Introspection.Parse as X+import DBus.Introspection.Render as X
+ lib/DBus/Introspection/Parse.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE OverloadedStrings #-}++module DBus.Introspection.Parse+ ( parseXML+ ) where++import Conduit+import Data.Maybe+import Data.XML.Types+import qualified Data.Text as T+import qualified Text.XML.Stream.Parse as X++import DBus.Internal.Types+import DBus.Introspection.Types++data ObjectChildren+ = InterfaceDefinition Interface+ | SubNode Object++data InterfaceChildren+ = MethodDefinition Method+ | SignalDefinition Signal+ | PropertyDefinition Property++parseXML :: ObjectPath -> T.Text -> Maybe Object+parseXML path xml =+ runConduit $ yieldMany [xml] .| X.parseText X.def .| X.force "parse error" (parseObject $ getRootName path)++getRootName :: ObjectPath -> X.AttrParser ObjectPath+getRootName defaultPath = do+ nodeName <- X.attr "name"+ pure $ maybe defaultPath (objectPath_ . T.unpack) nodeName++getChildName :: ObjectPath -> X.AttrParser ObjectPath+getChildName parentPath = do+ nodeName <- X.requireAttr "name"+ let parentPath' = case formatObjectPath parentPath of+ "/" -> "/"+ x -> x ++ "/"+ pure $ objectPath_ (parentPath' ++ T.unpack nodeName)++parseObject+ :: X.AttrParser ObjectPath+ -> ConduitT Event o Maybe (Maybe Object)+parseObject getPath = X.tag' "node" getPath parseContent+ where+ parseContent objPath = do+ elems <- X.many $ X.choose+ [ fmap SubNode <$> parseObject (getChildName objPath)+ , fmap InterfaceDefinition <$> parseInterface+ ]+ let base = Object objPath [] []+ addElem e (Object p is cs) = case e of+ InterfaceDefinition i -> Object p (i:is) cs+ SubNode c -> Object p is (c:cs)+ pure $ foldr addElem base elems++parseInterface+ :: ConduitT Event o Maybe (Maybe Interface)+parseInterface = X.tag' "interface" getName parseContent+ where+ getName = do+ ifName <- X.requireAttr "name"+ pure $ interfaceName_ (T.unpack ifName)+ parseContent ifName = do+ elems <- X.many $ do+ X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs+ X.choose+ [ parseMethod+ , parseSignal+ , parseProperty+ ]+ X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs+ let base = Interface ifName [] [] []+ addElem e (Interface n ms ss ps) = case e of+ MethodDefinition m -> Interface n (m:ms) ss ps+ SignalDefinition s -> Interface n ms (s:ss) ps+ PropertyDefinition p -> Interface n ms ss (p:ps)+ pure $ foldr addElem base elems++parseMethod :: ConduitT Event o Maybe (Maybe InterfaceChildren)+parseMethod = X.tag' "method" getName parseArgs+ where+ getName = do+ ifName <- X.requireAttr "name"+ parseMemberName (T.unpack ifName)+ parseArgs name = do+ args <- X.many $ do+ X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs+ X.tag' "arg" getArg pure+ X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs+ pure $ MethodDefinition $ Method name args+ getArg = do+ name <- fromMaybe "" <$> X.attr "name"+ typeStr <- X.requireAttr "type"+ dirStr <- fromMaybe "in" <$> X.attr "direction"+ X.ignoreAttrs+ typ <- parseType typeStr+ let dir = if dirStr == "in" then In else Out+ pure $ MethodArg (T.unpack name) typ dir++parseSignal :: ConduitT Event o Maybe (Maybe InterfaceChildren)+parseSignal = X.tag' "signal" getName parseArgs+ where+ getName = do+ ifName <- X.requireAttr "name"+ parseMemberName (T.unpack ifName)+ parseArgs name = do+ args <- X.many $ do+ X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs+ X.tag' "arg" getArg pure+ X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs+ pure $ SignalDefinition $ Signal name args+ getArg = do+ name <- fromMaybe "" <$> X.attr "name"+ typeStr <- X.requireAttr "type"+ X.ignoreAttrs+ typ <- parseType typeStr+ pure $ SignalArg (T.unpack name) typ++parseProperty :: ConduitT Event o Maybe (Maybe InterfaceChildren)+parseProperty = X.tag' "property" getProp $ \p -> do+ X.many_ X.ignoreAnyTreeContent+ pure p+ where+ getProp = do+ name <- T.unpack <$> X.requireAttr "name"+ typeStr <- X.requireAttr "type"+ accessStr <- fromMaybe "" <$> X.attr "access"+ X.ignoreAttrs+ typ <- parseType typeStr+ (canRead, canWrite) <- case accessStr of+ "" -> pure (False, False)+ "read" -> pure (True, False)+ "write" -> pure (False, True)+ "readwrite" -> pure (True, True)+ _ -> throwM $ userError "invalid access value"++ pure $ PropertyDefinition $ Property name typ canRead canWrite++parseType :: MonadThrow m => T.Text -> m Type+parseType typeStr = do+ typ <- parseSignature (T.unpack typeStr)+ case signatureTypes typ of+ [t] -> pure t+ _ -> throwM $ userError "invalid type sig"
+ lib/DBus/Introspection/Render.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module DBus.Introspection.Render+ ( formatXML+ ) where++import Conduit+import Control.Monad.ST+import Control.Monad.Trans.Maybe+import Data.List (isPrefixOf)+import Data.XML.Types (Event)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Text.XML.Stream.Render as R++import DBus.Internal.Types+import DBus.Introspection.Types++newtype Render s a = Render { runRender :: MaybeT (ST s) a }++deriving instance Functor (Render s)+deriving instance Applicative (Render s)+deriving instance Monad (Render s)++instance MonadThrow (Render s) where+ throwM _ = Render $ MaybeT $ pure Nothing++instance PrimMonad (Render s) where+ type PrimState (Render s) = s+ primitive f = Render $ lift $ primitive f++formatXML :: Object -> Maybe String+formatXML obj = do+ xml <- runST $ runMaybeT $ runRender $ runConduit $+ renderRoot obj .| R.renderText R.def .| sinkLazy+ pure $ TL.unpack xml++renderRoot :: MonadThrow m => Object -> ConduitT i Event m ()+renderRoot obj = renderObject (formatObjectPath $ objectPath obj) obj++renderObject :: MonadThrow m => String -> Object -> ConduitT i Event m ()+renderObject path Object{..} = R.tag "node"+ (R.attr "name" (T.pack path)) $ do+ mapM_ renderInterface objectInterfaces+ mapM_ (renderChild objectPath) objectChildren++renderChild :: MonadThrow m => ObjectPath -> Object -> ConduitT i Event m ()+renderChild parentPath obj+ | not (parent' `isPrefixOf` path') =+ throwM $ userError "invalid child path"+ | parent' == "/" = renderObject (drop 1 path') obj+ | otherwise = renderObject (drop (length parent' + 1) path') obj+ where+ path' = formatObjectPath (objectPath obj)+ parent' = formatObjectPath parentPath++renderInterface :: MonadThrow m => Interface -> ConduitT i Event m ()+renderInterface Interface{..} = R.tag "interface"+ (R.attr "name" $ T.pack $ formatInterfaceName interfaceName) $ do+ mapM_ renderMethod interfaceMethods+ mapM_ renderSignal interfaceSignals+ mapM_ renderProperty interfaceProperties++renderMethod :: MonadThrow m => Method -> ConduitT i Event m ()+renderMethod Method{..} = R.tag "method"+ (R.attr "name" $ T.pack $ formatMemberName methodName) $+ mapM_ renderMethodArg methodArgs++renderMethodArg :: MonadThrow m => MethodArg -> ConduitT i Event m ()+renderMethodArg MethodArg{..} = do+ typeStr <- formatType methodArgType+ let typeAttr = R.attr "type" $ T.pack typeStr+ nameAttr = R.attr "name" $ T.pack methodArgName+ dirAttr = R.attr "direction" $ case methodArgDirection of+ In -> "in"+ Out -> "out"+ R.tag "arg" (nameAttr <> typeAttr <> dirAttr) $ pure ()++renderSignal :: MonadThrow m => Signal -> ConduitT i Event m ()+renderSignal Signal{..} = R.tag "signal"+ (R.attr "name" $ T.pack $ formatMemberName signalName) $+ mapM_ renderSignalArg signalArgs++renderSignalArg :: MonadThrow m => SignalArg -> ConduitT i Event m ()+renderSignalArg SignalArg{..} = do+ typeStr <- formatType signalArgType+ let typeAttr = R.attr "type" $ T.pack typeStr+ nameAttr = R.attr "name" $ T.pack signalArgName+ R.tag "arg" (nameAttr <> typeAttr) $ pure ()++renderProperty :: MonadThrow m => Property -> ConduitT i Event m ()+renderProperty Property{..} = do+ typeStr <- formatType propertyType+ let readStr = if propertyRead then "read" else ""+ writeStr = if propertyWrite then "write" else ""+ typeAttr = R.attr "type" $ T.pack typeStr+ nameAttr = R.attr "name" $ T.pack propertyName+ accessAttr = R.attr "access" $ T.pack (readStr ++ writeStr)+ R.tag "property" (nameAttr <> typeAttr <> accessAttr) $ pure ()++formatType :: MonadThrow f => Type -> f String+formatType t = formatSignature <$> signature [t]
+ lib/DBus/Introspection/Types.hs view
@@ -0,0 +1,54 @@+module DBus.Introspection.Types where++import qualified DBus as T++data Object = Object+ { objectPath :: T.ObjectPath+ , objectInterfaces :: [Interface]+ , objectChildren :: [Object]+ }+ deriving (Show, Eq)++data Interface = Interface+ { interfaceName :: T.InterfaceName+ , interfaceMethods :: [Method]+ , interfaceSignals :: [Signal]+ , interfaceProperties :: [Property]+ }+ deriving (Show, Eq)++data Method = Method+ { methodName :: T.MemberName+ , methodArgs :: [MethodArg]+ }+ deriving (Show, Eq)++data MethodArg = MethodArg+ { methodArgName :: String+ , methodArgType :: T.Type+ , methodArgDirection :: Direction+ }+ deriving (Show, Eq)++data Direction = In | Out+ deriving (Show, Eq)++data Signal = Signal+ { signalName :: T.MemberName+ , signalArgs :: [SignalArg]+ }+ deriving (Show, Eq)++data SignalArg = SignalArg+ { signalArgName :: String+ , signalArgType :: T.Type+ }+ deriving (Show, Eq)++data Property = Property+ { propertyName :: String+ , propertyType :: T.Type+ , propertyRead :: Bool+ , propertyWrite :: Bool+ }+ deriving (Show, Eq)
lib/DBus/Socket.hs view
@@ -4,18 +4,17 @@ -- 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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. -- | D-Bus sockets are used for communication between two peers. In this model, -- there is no \"bus\" or \"client\", simply two endpoints sending messages.@@ -58,6 +57,7 @@ -- * Authentication , Authenticator , authenticator+ , authenticatorWithUnixFds , authenticatorClient , authenticatorServer ) where@@ -100,7 +100,9 @@ data TransportOptions SomeTransport = SomeTransportOptions transportDefaultOptions = SomeTransportOptions transportPut (SomeTransport t) = transportPut t+ transportPutWithFds (SomeTransport t) = transportPutWithFds t transportGet (SomeTransport t) = transportGet t+ transportGetWithFds (SomeTransport t) = transportGetWithFds t transportClose (SomeTransport t) = transportClose t -- | An open socket to another process. Messages can be sent to the remote@@ -143,11 +145,11 @@ } -- | Default 'SocketOptions', which uses the default Unix/TCP transport and--- authenticator.+-- authenticator (without support for Unix file descriptor passing). defaultSocketOptions :: SocketOptions SocketTransport defaultSocketOptions = SocketOptions { socketTransportOptions = transportDefaultOptions- , socketAuthenticator = authExternal+ , socketAuthenticator = authExternal UnixFdsNotSupported } -- | Open a socket to a remote peer listening at the given address.@@ -257,11 +259,11 @@ 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+ case marshalWithFds LittleEndian serial msg of+ Right (bytes, fds) -> do let t = socketTransport sock a <- io serial- withMVar (socketWriteLock sock) (\_ -> transportPut t bytes)+ withMVar (socketWriteLock sock) (\_ -> transportPutWithFds t bytes fds) return a Left err -> throwIO (socketError ("Message cannot be sent: " ++ show err)) { socketErrorFatal = False@@ -284,8 +286,8 @@ -- outside of the lock. let t = socketTransport sock let get n = if n == 0- then return Data.ByteString.empty- else transportGet t n+ then return (Data.ByteString.empty, [])+ else transportGetWithFds t n received <- withMVar (socketReadLock sock) (\_ -> unmarshalMessageM get) case received of Left err -> throwIO (socketError ("Error reading message from socket: " ++ show err))@@ -311,29 +313,45 @@ -- | An empty authenticator. Use 'authenticatorClient' or 'authenticatorServer' -- to control how the authentication is performed. ----- @---myAuthenticator :: Authenticator MyTransport---myAuthenticator = authenticator--- { 'authenticatorClient' = clientMyAuth--- , 'authenticatorServer' = serverMyAuth--- }+-- >>> data MyTransport -----clientMyAuth :: MyTransport -> IO Bool---serverMyAuth :: MyTransport -> String -> IO Bool--- @+-- >>> :{+-- clientMyAuth :: MyTransport -> IO Bool+-- clientMyAuth = error "example"+-- :}+--+-- >>> :{+-- serverMyAuth :: MyTransport -> UUID -> IO Bool+-- serverMyAuth = error "example"+-- :}+--+-- >>> :{+-- myAuthenticator :: Authenticator MyTransport+-- myAuthenticator = authenticator+-- { authenticatorClient = clientMyAuth+-- , authenticatorServer = serverMyAuth+-- }+-- :} authenticator :: Authenticator t authenticator = Authenticator (\_ -> return False) (\_ _ -> return False) +data UnixFdSupport = UnixFdsSupported | UnixFdsNotSupported++-- | An authenticator that implements the D-Bus @EXTERNAL@ mechanism, which uses+-- credential passing over a Unix socket, with support for Unix file descriptor passing.+authenticatorWithUnixFds :: Authenticator SocketTransport+authenticatorWithUnixFds = authExternal UnixFdsSupported+ -- | Implements the D-Bus @EXTERNAL@ mechanism, which uses credential--- passing over a Unix socket.-authExternal :: Authenticator SocketTransport-authExternal = authenticator- { authenticatorClient = clientAuthExternal- , authenticatorServer = serverAuthExternal+-- passing over a Unix socket, optionally supporting Unix file descriptor passing.+authExternal :: UnixFdSupport -> Authenticator SocketTransport+authExternal unixFdSupport = authenticator+ { authenticatorClient = clientAuthExternal unixFdSupport+ , authenticatorServer = serverAuthExternal unixFdSupport } -clientAuthExternal :: SocketTransport -> IO Bool-clientAuthExternal t = do+clientAuthExternal :: UnixFdSupport -> SocketTransport -> IO Bool+clientAuthExternal unixFdSupport t = do transportPut t (Data.ByteString.pack [0]) uid <- System.Posix.User.getRealUserID let token = concatMap (printf "%02X" . ord) (show uid)@@ -341,27 +359,48 @@ resp <- transportGetLine t case splitPrefix "OK " resp of Just _ -> do- transportPutLine t "BEGIN"- return True+ ok <- do+ case unixFdSupport of+ UnixFdsSupported -> do+ transportPutLine t "NEGOTIATE_UNIX_FD"+ respFd <- transportGetLine t+ return (respFd == "AGREE_UNIX_FD")+ UnixFdsNotSupported -> do+ return True+ if ok then do+ transportPutLine t "BEGIN"+ return True+ else+ return False 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+serverAuthExternal :: UnixFdSupport -> SocketTransport -> UUID -> IO Bool+serverAuthExternal unixFdSupport t uuid = do+ let negotiateFdsAndBegin = do+ line <- transportGetLine t+ case line of+ "NEGOTIATE_UNIX_FD" -> do+ let msg = case unixFdSupport of+ UnixFdsSupported ->+ "AGREE_UNIX_FD"+ UnixFdsNotSupported ->+ "ERROR Unix File Descriptor support is not configured."+ transportPutLine t msg+ negotiateFdsAndBegin+ "BEGIN" ->+ return ()+ _ ->+ negotiateFdsAndBegin 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+ (_, uid, _) <- socketTransportCredentials t+ let wantToken = concatMap (printf "%02X" . ord) (maybe "XXX" show uid)+ if token == wantToken+ then do+ transportPutLine t ("OK " ++ formatUUID uuid)+ negotiateFdsAndBegin+ return True+ else return False c <- transportGet t 1 if c /= Char8.pack "\x00"
+ lib/DBus/TH.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module DBus.TH where++import DBus.Client+import DBus.Generation+import System.FilePath++generateSignalsFromInterface defaultGenerationParams $+ buildIntrospectionInterface $+ buildPropertiesInterface undefined++generateFromFilePath defaultGenerationParams { genBusName = Just dbusName+ , genObjectPath = Just dbusPath+ } $ "idlxml" </> "dbus.xml"
lib/DBus/Transport.hs view
@@ -1,20 +1,20 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} -- 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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. -- | Support for defining custom transport mechanisms. Most users will not -- need to care about the types defined in this module.@@ -37,18 +37,31 @@ , socketTransportCredentials ) where +import Control.Concurrent (rtsSupportsBoundThreads, threadWaitWrite) import Control.Exception+import Control.Monad (when) import qualified Data.ByteString-import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as Builder+import Data.ByteString.Internal (ByteString(PS)) import qualified Data.ByteString.Lazy as Lazy+import Data.ByteString.Unsafe (unsafeUseAsCString)+import qualified Data.Kind import qualified Data.Map as Map+import Data.Maybe (fromMaybe) import Data.Monoid import Data.Typeable (Typeable)-import Foreign.C (CUInt)-import Network.Socket hiding (recv)-import Network.Socket.ByteString (sendAll, recv)+import Foreign.C (CInt, CUInt)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Array (peekArray)+import Foreign.Ptr (castPtr, plusPtr)+import Foreign.Storable (sizeOf)+import Network.Socket+import Network.Socket.Internal (NullSockAddr(..))+import qualified Network.Socket.Address+import Network.Socket.ByteString (recvMsg) import qualified System.Info+import System.IO.Unsafe (unsafeDupablePerformIO)+import System.Posix.Types (Fd) import Prelude import DBus@@ -69,7 +82,7 @@ class Transport t where -- | Additional options that this transport type may use when establishing -- a connection.- data TransportOptions t :: *+ data TransportOptions t :: Data.Kind.Type -- | Default values for this transport's options. transportDefaultOptions :: TransportOptions t@@ -78,6 +91,12 @@ -- -- Throws a 'TransportError' if an error occurs. transportPut :: t -> ByteString -> IO ()+ + -- | Send a 'ByteString' and Unix file descriptors over the transport.+ --+ -- Throws a 'TransportError' if an error occurs.+ transportPutWithFds :: t -> ByteString -> [Fd] -> IO ()+ transportPutWithFds t bs _fds = transportPut t bs -- | Receive a 'ByteString' of the given size from the transport. The -- transport should block until sufficient bytes are available, and@@ -87,6 +106,18 @@ -- Throws a 'TransportError' if an error occurs. transportGet :: t -> Int -> IO ByteString + -- | Receive a 'ByteString' of the given size from the transport, plus+ -- any Unix file descriptors that arrive with the byte data. The+ -- transport should block until sufficient bytes are available, and+ -- only return fewer than the requested amount if there will not be+ -- any more data.+ --+ -- Throws a 'TransportError' if an error occurs.+ transportGetWithFds :: t -> Int -> IO (ByteString, [Fd])+ transportGetWithFds t n = do+ bs <- transportGet t n+ return (bs, [])+ -- | Close an open transport, and release any associated resources -- or handles. transportClose :: t -> IO ()@@ -103,7 +134,7 @@ -- peers. class Transport t => TransportListen t where -- | Used for transports that listen on a port or address.- data TransportListener t :: *+ data TransportListener t :: Data.Kind.Type -- | Begin listening for connections on the given address, using the -- given options.@@ -146,30 +177,40 @@ socketTransportOptionBacklog :: Int } transportDefaultOptions = SocketTransportOptions 30- transportPut (SocketTransport addr s) bytes = catchIOException addr (sendAll s bytes)- transportGet (SocketTransport addr s) n = catchIOException addr (recvLoop s n)+ transportPut st bytes = transportPutWithFds st bytes []+ transportPutWithFds (SocketTransport addr s) bytes fds = catchIOException addr (sendWithFds s bytes fds)+ transportGet st n = fst <$> transportGetWithFds st n+ transportGetWithFds (SocketTransport addr s) n = catchIOException addr (recvWithFds s n) transportClose (SocketTransport addr s) = catchIOException addr (close s) -recvLoop :: Socket -> Int -> IO ByteString-recvLoop s = \n -> Lazy.toStrict `fmap` loop mempty n where- chunkSize = 4096- loop acc n = if n > chunkSize- then do- chunk <- recv s chunkSize- let builder = mappend acc (Builder.byteString chunk)- loop builder (n - Data.ByteString.length chunk)- else do- chunk <- recv s n- case Data.ByteString.length chunk of- -- Unexpected end of connection; maybe the remote end went away.- -- Return what we've got so far.- 0 -> return (Builder.toLazyByteString acc)+sendWithFds :: Socket -> ByteString -> [Fd] -> IO ()+sendWithFds s msg fds = loop 0 where+ loop acc = do+ let cmsgs = if acc == 0 then (encodeCmsg . (pure :: Fd -> [Fd]) <$> fds) else []+ n <- unsafeUseAsCString msg $ \cstr -> do+ let buf = [(plusPtr (castPtr cstr) acc, len - acc)]+ Network.Socket.Address.sendBufMsg s NullSockAddr buf cmsgs mempty+ waitWhen0 n s -- copy Network.Socket.ByteString.sendAll+ when (acc + n < len) $ do+ loop (acc + n)+ len = Data.ByteString.length msg - len -> do- let builder = mappend acc (Builder.byteString chunk)- if len == n- then return (Builder.toLazyByteString builder)- else loop builder (n - Data.ByteString.length chunk)+recvWithFds :: Socket -> Int -> IO (ByteString, [Fd])+recvWithFds s = loop mempty [] where+ loop accBuf accFds n = do+ (_sa, buf, cmsgs, flag) <- recvMsg s (min n chunkSize) cmsgsSize mempty+ let recvLen = Data.ByteString.length buf+ accBuf' = accBuf <> Builder.byteString buf+ accFds' = accFds <> decodeFdCmsgs cmsgs+ case flag of+ MSG_CTRUNC -> throwIO (transportError ("Unexpected MSG_CTRUNC: more than " <> show maxFds <> " file descriptors?"))+ -- no data means unexpected end of connection; maybe the remote end went away.+ _ | recvLen == 0 || recvLen == n -> do+ return (Lazy.toStrict (Builder.toLazyByteString accBuf'), accFds')+ _ -> loop accBuf' accFds' (n - recvLen)+ chunkSize = 4096+ maxFds = 16 -- same as DBUS_DEFAULT_MESSAGE_UNIX_FDS in DBUS reference implementation+ cmsgsSize = sizeOf (undefined :: CInt) * maxFds instance TransportOpen SocketTransport where transportOpen _ a = case addressMethod a of@@ -199,9 +240,9 @@ -- | Returns the processID, userID, and groupID of the socket's peer. ----- See 'getPeerCred'.-socketTransportCredentials :: SocketTransport -> IO (CUInt, CUInt, CUInt)-socketTransportCredentials (SocketTransport a s) = catchIOException a (getPeerCred s)+-- See 'getPeerCredential'.+socketTransportCredentials :: SocketTransport -> IO (Maybe CUInt, Maybe CUInt, Maybe CUInt)+socketTransportCredentials (SocketTransport a s) = catchIOException a (getPeerCredential s) openUnix :: Address -> IO SocketTransport openUnix transportAddr = go where@@ -262,10 +303,10 @@ , addrSocketType = Stream })) (Just hostname) Nothing - openSocket [] = throwIO (transportError "openTcp: no addresses")+ openOneSocket [] = throwIO (transportError "openTcp: no addresses") { transportErrorAddress = Just transportAddr }- openSocket (addr:addrs) = do+ openOneSocket (addr:addrs) = do tried <- Control.Exception.try $ bracketOnError (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) close@@ -277,7 +318,7 @@ [] -> throwIO (transportError (show (err :: IOException))) { transportErrorAddress = Just transportAddr }- _ -> openSocket addrs+ _ -> openOneSocket addrs Right sock -> return sock go = case getPort of@@ -290,7 +331,7 @@ } Right family_ -> catchIOException (Just transportAddr) $ do addrs <- getAddresses family_- sock <- openSocket (map (setPort port) addrs)+ sock <- openOneSocket (map (setPort port) addrs) return (SocketTransport (Just transportAddr) sock) listenUnix :: UUID -> Address -> TransportOptions SocketTransport -> IO (Address, Socket)@@ -447,3 +488,24 @@ if word > 0 && word <= 65535 then Just (fromInteger word) else Nothing++-- | Copied from Network.Socket.ByteString.IO+waitWhen0 :: Int -> Socket -> IO ()+waitWhen0 0 s = when rtsSupportsBoundThreads $+ withFdSocket s $ \fd -> threadWaitWrite $ fromIntegral fd+waitWhen0 _ _ = return ()++decodeFdCmsgs :: [Cmsg] -> [Fd]+decodeFdCmsgs cmsgs =+ foldMap (fromMaybe [] . decodeFdCmsg) cmsgs++-- | Special decode function to handle > 1 Fd. Should be able to replace with a function+-- from the network package in future (https://github.com/haskell/network/issues/566)+decodeFdCmsg :: Cmsg -> Maybe [Fd]+decodeFdCmsg (Cmsg cmsid (PS fptr off len))+ | cmsid /= CmsgIdFds = Nothing+ | otherwise =+ unsafeDupablePerformIO $ withForeignPtr fptr $ \p0 -> do+ let p = castPtr (p0 `plusPtr` off)+ numFds = len `div` sizeOf (undefined :: Fd)+ Just <$> peekArray numFds p
license.txt view
@@ -1,674 +1,202 @@- GNU GENERAL PUBLIC LICENSE- Version 3, 29 June 2007 - Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>- Everyone is permitted to copy and distribute verbatim copies- of this license document, but changing it is not allowed.-- Preamble-- The GNU General Public License is a free, copyleft license for-software and other kinds of works.-- The licenses for most software and other practical works are designed-to take away your freedom to share and change the works. By contrast,-the GNU General Public License is intended to guarantee your freedom to-share and change all versions of a program--to make sure it remains free-software for all its users. We, the Free Software Foundation, use the-GNU General Public License for most of our software; it applies also to-any other work released this way by its authors. You can apply it to-your programs, too.-- When we speak of free software, we are referring to freedom, not-price. Our General Public Licenses are designed to make sure that you-have the freedom to distribute copies of free software (and charge for-them if you wish), that you receive source code or can get it if you-want it, that you can change the software or use pieces of it in new-free programs, and that you know you can do these things.-- To protect your rights, we need to prevent others from denying you-these rights or asking you to surrender the rights. Therefore, you have-certain responsibilities if you distribute copies of the software, or if-you modify it: responsibilities to respect the freedom of others.-- For example, if you distribute copies of such a program, whether-gratis or for a fee, you must pass on to the recipients the same-freedoms that you received. You must make sure that they, too, receive-or can get the source code. And you must show them these terms so they-know their rights.-- Developers that use the GNU GPL protect your rights with two steps:-(1) assert copyright on the software, and (2) offer you this License-giving you legal permission to copy, distribute and/or modify it.-- For the developers' and authors' protection, the GPL clearly explains-that there is no warranty for this free software. For both users' and-authors' sake, the GPL requires that modified versions be marked as-changed, so that their problems will not be attributed erroneously to-authors of previous versions.-- Some devices are designed to deny users access to install or run-modified versions of the software inside them, although the manufacturer-can do so. This is fundamentally incompatible with the aim of-protecting users' freedom to change the software. The systematic-pattern of such abuse occurs in the area of products for individuals to-use, which is precisely where it is most unacceptable. Therefore, we-have designed this version of the GPL to prohibit the practice for those-products. If such problems arise substantially in other domains, we-stand ready to extend this provision to those domains in future versions-of the GPL, as needed to protect the freedom of users.-- Finally, every program is threatened constantly by software patents.-States should not allow patents to restrict development and use of-software on general-purpose computers, but in those that do, we wish to-avoid the special danger that patents applied to a free program could-make it effectively proprietary. To prevent this, the GPL assures that-patents cannot be used to render the program non-free.-- The precise terms and conditions for copying, distribution and-modification follow.-- TERMS AND CONDITIONS-- 0. Definitions.-- "This License" refers to version 3 of the GNU General Public License.-- "Copyright" also means copyright-like laws that apply to other kinds of-works, such as semiconductor masks.-- "The Program" refers to any copyrightable work licensed under this-License. Each licensee is addressed as "you". "Licensees" and-"recipients" may be individuals or organizations.-- To "modify" a work means to copy from or adapt all or part of the work-in a fashion requiring copyright permission, other than the making of an-exact copy. The resulting work is called a "modified version" of the-earlier work or a work "based on" the earlier work.-- A "covered work" means either the unmodified Program or a work based-on the Program.-- To "propagate" a work means to do anything with it that, without-permission, would make you directly or secondarily liable for-infringement under applicable copyright law, except executing it on a-computer or modifying a private copy. Propagation includes copying,-distribution (with or without modification), making available to the-public, and in some countries other activities as well.-- To "convey" a work means any kind of propagation that enables other-parties to make or receive copies. Mere interaction with a user through-a computer network, with no transfer of a copy, is not conveying.-- An interactive user interface displays "Appropriate Legal Notices"-to the extent that it includes a convenient and prominently visible-feature that (1) displays an appropriate copyright notice, and (2)-tells the user that there is no warranty for the work (except to the-extent that warranties are provided), that licensees may convey the-work under this License, and how to view a copy of this License. If-the interface presents a list of user commands or options, such as a-menu, a prominent item in the list meets this criterion.-- 1. Source Code.-- The "source code" for a work means the preferred form of the work-for making modifications to it. "Object code" means any non-source-form of a work.-- A "Standard Interface" means an interface that either is an official-standard defined by a recognized standards body, or, in the case of-interfaces specified for a particular programming language, one that-is widely used among developers working in that language.-- The "System Libraries" of an executable work include anything, other-than the work as a whole, that (a) is included in the normal form of-packaging a Major Component, but which is not part of that Major-Component, and (b) serves only to enable use of the work with that-Major Component, or to implement a Standard Interface for which an-implementation is available to the public in source code form. A-"Major Component", in this context, means a major essential component-(kernel, window system, and so on) of the specific operating system-(if any) on which the executable work runs, or a compiler used to-produce the work, or an object code interpreter used to run it.-- The "Corresponding Source" for a work in object code form means all-the source code needed to generate, install, and (for an executable-work) run the object code and to modify the work, including scripts to-control those activities. However, it does not include the work's-System Libraries, or general-purpose tools or generally available free-programs which are used unmodified in performing those activities but-which are not part of the work. For example, Corresponding Source-includes interface definition files associated with source files for-the work, and the source code for shared libraries and dynamically-linked subprograms that the work is specifically designed to require,-such as by intimate data communication or control flow between those-subprograms and other parts of the work.-- The Corresponding Source need not include anything that users-can regenerate automatically from other parts of the Corresponding-Source.-- The Corresponding Source for a work in source code form is that-same work.-- 2. Basic Permissions.-- All rights granted under this License are granted for the term of-copyright on the Program, and are irrevocable provided the stated-conditions are met. This License explicitly affirms your unlimited-permission to run the unmodified Program. The output from running a-covered work is covered by this License only if the output, given its-content, constitutes a covered work. This License acknowledges your-rights of fair use or other equivalent, as provided by copyright law.-- You may make, run and propagate covered works that you do not-convey, without conditions so long as your license otherwise remains-in force. You may convey covered works to others for the sole purpose-of having them make modifications exclusively for you, or provide you-with facilities for running those works, provided that you comply with-the terms of this License in conveying all material for which you do-not control copyright. Those thus making or running the covered works-for you must do so exclusively on your behalf, under your direction-and control, on terms that prohibit them from making any copies of-your copyrighted material outside their relationship with you.-- Conveying under any other circumstances is permitted solely under-the conditions stated below. Sublicensing is not allowed; section 10-makes it unnecessary.-- 3. Protecting Users' Legal Rights From Anti-Circumvention Law.-- No covered work shall be deemed part of an effective technological-measure under any applicable law fulfilling obligations under article-11 of the WIPO copyright treaty adopted on 20 December 1996, or-similar laws prohibiting or restricting circumvention of such-measures.-- When you convey a covered work, you waive any legal power to forbid-circumvention of technological measures to the extent such circumvention-is effected by exercising rights under this License with respect to-the covered work, and you disclaim any intention to limit operation or-modification of the work as a means of enforcing, against the work's-users, your or third parties' legal rights to forbid circumvention of-technological measures.-- 4. Conveying Verbatim Copies.-- You may convey verbatim copies of the Program's source code as you-receive it, in any medium, provided that you conspicuously and-appropriately publish on each copy an appropriate copyright notice;-keep intact all notices stating that this License and any-non-permissive terms added in accord with section 7 apply to the code;-keep intact all notices of the absence of any warranty; and give all-recipients a copy of this License along with the Program.-- You may charge any price or no price for each copy that you convey,-and you may offer support or warranty protection for a fee.-- 5. Conveying Modified Source Versions.-- You may convey a work based on the Program, or the modifications to-produce it from the Program, in the form of source code under the-terms of section 4, provided that you also meet all of these conditions:-- a) The work must carry prominent notices stating that you modified- it, and giving a relevant date.-- b) The work must carry prominent notices stating that it is- released under this License and any conditions added under section- 7. This requirement modifies the requirement in section 4 to- "keep intact all notices".-- c) You must license the entire work, as a whole, under this- License to anyone who comes into possession of a copy. This- License will therefore apply, along with any applicable section 7- additional terms, to the whole of the work, and all its parts,- regardless of how they are packaged. This License gives no- permission to license the work in any other way, but it does not- invalidate such permission if you have separately received it.-- d) If the work has interactive user interfaces, each must display- Appropriate Legal Notices; however, if the Program has interactive- interfaces that do not display Appropriate Legal Notices, your- work need not make them do so.-- A compilation of a covered work with other separate and independent-works, which are not by their nature extensions of the covered work,-and which are not combined with it such as to form a larger program,-in or on a volume of a storage or distribution medium, is called an-"aggregate" if the compilation and its resulting copyright are not-used to limit the access or legal rights of the compilation's users-beyond what the individual works permit. Inclusion of a covered work-in an aggregate does not cause this License to apply to the other-parts of the aggregate.-- 6. Conveying Non-Source Forms.-- You may convey a covered work in object code form under the terms-of sections 4 and 5, provided that you also convey the-machine-readable Corresponding Source under the terms of this License,-in one of these ways:-- a) Convey the object code in, or embodied in, a physical product- (including a physical distribution medium), accompanied by the- Corresponding Source fixed on a durable physical medium- customarily used for software interchange.-- b) Convey the object code in, or embodied in, a physical product- (including a physical distribution medium), accompanied by a- written offer, valid for at least three years and valid for as- long as you offer spare parts or customer support for that product- model, to give anyone who possesses the object code either (1) a- copy of the Corresponding Source for all the software in the- product that is covered by this License, on a durable physical- medium customarily used for software interchange, for a price no- more than your reasonable cost of physically performing this- conveying of source, or (2) access to copy the- Corresponding Source from a network server at no charge.-- c) Convey individual copies of the object code with a copy of the- written offer to provide the Corresponding Source. This- alternative is allowed only occasionally and noncommercially, and- only if you received the object code with such an offer, in accord- with subsection 6b.-- d) Convey the object code by offering access from a designated- place (gratis or for a charge), and offer equivalent access to the- Corresponding Source in the same way through the same place at no- further charge. You need not require recipients to copy the- Corresponding Source along with the object code. If the place to- copy the object code is a network server, the Corresponding Source- may be on a different server (operated by you or a third party)- that supports equivalent copying facilities, provided you maintain- clear directions next to the object code saying where to find the- Corresponding Source. Regardless of what server hosts the- Corresponding Source, you remain obligated to ensure that it is- available for as long as needed to satisfy these requirements.-- e) Convey the object code using peer-to-peer transmission, provided- you inform other peers where the object code and Corresponding- Source of the work are being offered to the general public at no- charge under subsection 6d.-- A separable portion of the object code, whose source code is excluded-from the Corresponding Source as a System Library, need not be-included in conveying the object code work.-- A "User Product" is either (1) a "consumer product", which means any-tangible personal property which is normally used for personal, family,-or household purposes, or (2) anything designed or sold for incorporation-into a dwelling. In determining whether a product is a consumer product,-doubtful cases shall be resolved in favor of coverage. For a particular-product received by a particular user, "normally used" refers to a-typical or common use of that class of product, regardless of the status-of the particular user or of the way in which the particular user-actually uses, or expects or is expected to use, the product. A product-is a consumer product regardless of whether the product has substantial-commercial, industrial or non-consumer uses, unless such uses represent-the only significant mode of use of the product.-- "Installation Information" for a User Product means any methods,-procedures, authorization keys, or other information required to install-and execute modified versions of a covered work in that User Product from-a modified version of its Corresponding Source. The information must-suffice to ensure that the continued functioning of the modified object-code is in no case prevented or interfered with solely because-modification has been made.-- If you convey an object code work under this section in, or with, or-specifically for use in, a User Product, and the conveying occurs as-part of a transaction in which the right of possession and use of the-User Product is transferred to the recipient in perpetuity or for a-fixed term (regardless of how the transaction is characterized), the-Corresponding Source conveyed under this section must be accompanied-by the Installation Information. But this requirement does not apply-if neither you nor any third party retains the ability to install-modified object code on the User Product (for example, the work has-been installed in ROM).-- The requirement to provide Installation Information does not include a-requirement to continue to provide support service, warranty, or updates-for a work that has been modified or installed by the recipient, or for-the User Product in which it has been modified or installed. Access to a-network may be denied when the modification itself materially and-adversely affects the operation of the network or violates the rules and-protocols for communication across the network.-- Corresponding Source conveyed, and Installation Information provided,-in accord with this section must be in a format that is publicly-documented (and with an implementation available to the public in-source code form), and must require no special password or key for-unpacking, reading or copying.-- 7. Additional Terms.-- "Additional permissions" are terms that supplement the terms of this-License by making exceptions from one or more of its conditions.-Additional permissions that are applicable to the entire Program shall-be treated as though they were included in this License, to the extent-that they are valid under applicable law. If additional permissions-apply only to part of the Program, that part may be used separately-under those permissions, but the entire Program remains governed by-this License without regard to the additional permissions.-- When you convey a copy of a covered work, you may at your option-remove any additional permissions from that copy, or from any part of-it. (Additional permissions may be written to require their own-removal in certain cases when you modify the work.) You may place-additional permissions on material, added by you to a covered work,-for which you have or can give appropriate copyright permission.-- Notwithstanding any other provision of this License, for material you-add to a covered work, you may (if authorized by the copyright holders of-that material) supplement the terms of this License with terms:-- a) Disclaiming warranty or limiting liability differently from the- terms of sections 15 and 16 of this License; or-- b) Requiring preservation of specified reasonable legal notices or- author attributions in that material or in the Appropriate Legal- Notices displayed by works containing it; or-- c) Prohibiting misrepresentation of the origin of that material, or- requiring that modified versions of such material be marked in- reasonable ways as different from the original version; or-- d) Limiting the use for publicity purposes of names of licensors or- authors of the material; or-- e) Declining to grant rights under trademark law for use of some- trade names, trademarks, or service marks; or-- f) Requiring indemnification of licensors and authors of that- material by anyone who conveys the material (or modified versions of- it) with contractual assumptions of liability to the recipient, for- any liability that these contractual assumptions directly impose on- those licensors and authors.-- All other non-permissive additional terms are considered "further-restrictions" within the meaning of section 10. If the Program as you-received it, or any part of it, contains a notice stating that it is-governed by this License along with a term that is a further-restriction, you may remove that term. If a license document contains-a further restriction but permits relicensing or conveying under this-License, you may add to a covered work material governed by the terms-of that license document, provided that the further restriction does-not survive such relicensing or conveying.-- If you add terms to a covered work in accord with this section, you-must place, in the relevant source files, a statement of the-additional terms that apply to those files, or a notice indicating-where to find the applicable terms.-- Additional terms, permissive or non-permissive, may be stated in the-form of a separately written license, or stated as exceptions;-the above requirements apply either way.-- 8. Termination.-- You may not propagate or modify a covered work except as expressly-provided under this License. Any attempt otherwise to propagate or-modify it is void, and will automatically terminate your rights under-this License (including any patent licenses granted under the third-paragraph of section 11).-- However, if you cease all violation of this License, then your-license from a particular copyright holder is reinstated (a)-provisionally, unless and until the copyright holder explicitly and-finally terminates your license, and (b) permanently, if the copyright-holder fails to notify you of the violation by some reasonable means-prior to 60 days after the cessation.-- Moreover, your license from a particular copyright holder is-reinstated permanently if the copyright holder notifies you of the-violation by some reasonable means, this is the first time you have-received notice of violation of this License (for any work) from that-copyright holder, and you cure the violation prior to 30 days after-your receipt of the notice.-- Termination of your rights under this section does not terminate the-licenses of parties who have received copies or rights from you under-this License. If your rights have been terminated and not permanently-reinstated, you do not qualify to receive new licenses for the same-material under section 10.-- 9. Acceptance Not Required for Having Copies.-- You are not required to accept this License in order to receive or-run a copy of the Program. Ancillary propagation of a covered work-occurring solely as a consequence of using peer-to-peer transmission-to receive a copy likewise does not require acceptance. However,-nothing other than this License grants you permission to propagate or-modify any covered work. These actions infringe copyright if you do-not accept this License. Therefore, by modifying or propagating a-covered work, you indicate your acceptance of this License to do so.-- 10. Automatic Licensing of Downstream Recipients.-- Each time you convey a covered work, the recipient automatically-receives a license from the original licensors, to run, modify and-propagate that work, subject to this License. You are not responsible-for enforcing compliance by third parties with this License.-- An "entity transaction" is a transaction transferring control of an-organization, or substantially all assets of one, or subdividing an-organization, or merging organizations. If propagation of a covered-work results from an entity transaction, each party to that-transaction who receives a copy of the work also receives whatever-licenses to the work the party's predecessor in interest had or could-give under the previous paragraph, plus a right to possession of the-Corresponding Source of the work from the predecessor in interest, if-the predecessor has it or can get it with reasonable efforts.-- You may not impose any further restrictions on the exercise of the-rights granted or affirmed under this License. For example, you may-not impose a license fee, royalty, or other charge for exercise of-rights granted under this License, and you may not initiate litigation-(including a cross-claim or counterclaim in a lawsuit) alleging that-any patent claim is infringed by making, using, selling, offering for-sale, or importing the Program or any portion of it.-- 11. Patents.-- A "contributor" is a copyright holder who authorizes use under this-License of the Program or a work on which the Program is based. The-work thus licensed is called the contributor's "contributor version".-- A contributor's "essential patent claims" are all patent claims-owned or controlled by the contributor, whether already acquired or-hereafter acquired, that would be infringed by some manner, permitted-by this License, of making, using, or selling its contributor version,-but do not include claims that would be infringed only as a-consequence of further modification of the contributor version. For-purposes of this definition, "control" includes the right to grant-patent sublicenses in a manner consistent with the requirements of-this License.-- Each contributor grants you a non-exclusive, worldwide, royalty-free-patent license under the contributor's essential patent claims, to-make, use, sell, offer for sale, import and otherwise run, modify and-propagate the contents of its contributor version.-- In the following three paragraphs, a "patent license" is any express-agreement or commitment, however denominated, not to enforce a patent-(such as an express permission to practice a patent or covenant not to-sue for patent infringement). To "grant" such a patent license to a-party means to make such an agreement or commitment not to enforce a-patent against the party.-- If you convey a covered work, knowingly relying on a patent license,-and the Corresponding Source of the work is not available for anyone-to copy, free of charge and under the terms of this License, through a-publicly available network server or other readily accessible means,-then you must either (1) cause the Corresponding Source to be so-available, or (2) arrange to deprive yourself of the benefit of the-patent license for this particular work, or (3) arrange, in a manner-consistent with the requirements of this License, to extend the patent-license to downstream recipients. "Knowingly relying" means you have-actual knowledge that, but for the patent license, your conveying the-covered work in a country, or your recipient's use of the covered work-in a country, would infringe one or more identifiable patents in that-country that you have reason to believe are valid.+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/ - If, pursuant to or in connection with a single transaction or-arrangement, you convey, or propagate by procuring conveyance of, a-covered work, and grant a patent license to some of the parties-receiving the covered work authorizing them to use, propagate, modify-or convey a specific copy of the covered work, then the patent license-you grant is automatically extended to all recipients of the covered-work and works based on it.+ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION - A patent license is "discriminatory" if it does not include within-the scope of its coverage, prohibits the exercise of, or is-conditioned on the non-exercise of one or more of the rights that are-specifically granted under this License. You may not convey a covered-work if you are a party to an arrangement with a third party that is-in the business of distributing software, under which you make payment-to the third party based on the extent of your activity of conveying-the work, and under which the third party grants, to any of the-parties who would receive the covered work from you, a discriminatory-patent license (a) in connection with copies of the covered work-conveyed by you (or copies made from those copies), or (b) primarily-for and in connection with specific products or compilations that-contain the covered work, unless you entered into that arrangement,-or that patent license was granted, prior to 28 March 2007.+ 1. Definitions. - Nothing in this License shall be construed as excluding or limiting-any implied license or other defenses to infringement that may-otherwise be available to you under applicable patent law.+ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document. - 12. No Surrender of Others' Freedom.+ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License. - If conditions are imposed on you (whether by court order, agreement or-otherwise) that contradict the conditions of this License, they do not-excuse you from the conditions of this License. If you cannot convey a-covered work so as to satisfy simultaneously your obligations under this-License and any other pertinent obligations, then as a consequence you may-not convey it at all. For example, if you agree to terms that obligate you-to collect a royalty for further conveying from those to whom you convey-the Program, the only way you could satisfy both those terms and this-License would be to refrain entirely from conveying the Program.+ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity. - 13. Use with the GNU Affero General Public License.+ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License. - Notwithstanding any other provision of this License, you have-permission to link or combine any covered work with a work licensed-under version 3 of the GNU Affero General Public License into a single-combined work, and to convey the resulting work. The terms of this-License will continue to apply to the part which is the covered work,-but the special requirements of the GNU Affero General Public License,-section 13, concerning interaction through a network will apply to the-combination as such.+ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files. - 14. Revised Versions of this License.+ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types. - The Free Software Foundation may publish revised and/or new versions of-the GNU General Public License from time to time. Such new versions will-be similar in spirit to the present version, but may differ in detail to-address new problems or concerns.+ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below). - Each version is given a distinguishing version number. If the-Program specifies that a certain numbered version of the GNU General-Public License "or any later version" applies to it, you have the-option of following the terms and conditions either of that numbered-version or of any later version published by the Free Software-Foundation. If the Program does not specify a version number of the-GNU General Public License, you may choose any version ever published-by the Free Software Foundation.+ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof. - If the Program specifies that a proxy can decide which future-versions of the GNU General Public License can be used, that proxy's-public statement of acceptance of a version permanently authorizes you-to choose that version for the Program.+ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution." - Later license versions may give you additional or different-permissions. However, no additional obligations are imposed on any-author or copyright holder as a result of your choosing to follow a-later version.+ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work. - 15. Disclaimer of Warranty.+ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form. - THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY-APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT-HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY-OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,-THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR-PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM-IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF-ALL NECESSARY SERVICING, REPAIR OR CORRECTION.+ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed. - 16. Limitation of Liability.+ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions: - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS-THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY-GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE-USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF-DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD-PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),-EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF-SUCH DAMAGES.+ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and - 17. Interpretation of Sections 15 and 16.+ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and - If the disclaimer of warranty and limitation of liability provided-above cannot be given local legal effect according to their terms,-reviewing courts shall apply local law that most closely approximates-an absolute waiver of all civil liability in connection with the-Program, unless a warranty or assumption of liability accompanies a-copy of the Program in return for a fee.+ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and - END OF TERMS AND CONDITIONS+ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License. - How to Apply These Terms to Your New Programs+ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License. - If you develop a new program, and you want it to be of the greatest-possible use to the public, the best way to achieve this is to make it-free software which everyone can redistribute and change under these terms.+ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions. - To do so, attach the following notices to the program. It is safest-to attach them to the start of each source file to most effectively-state the exclusion of warranty; and each file should have at least-the "copyright" line and a pointer to where the full notice is found.+ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file. - <one line to give the program's name and a brief idea of what it does.>- Copyright (C) <year> <name of author>+ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License. - 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- (at your option) any later version.+ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages. - 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.+ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability. - You should have received a copy of the GNU General Public License- along with this program. If not, see <http://www.gnu.org/licenses/>.+ END OF TERMS AND CONDITIONS -Also add information on how to contact you by electronic and paper mail.+ APPENDIX: How to apply the Apache License to your work. - If the program does terminal interaction, make it output a short-notice like this when it starts in an interactive mode:+ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives. - <program> Copyright (C) <year> <name of author>- This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.- This is free software, and you are welcome to redistribute it- under certain conditions; type `show c' for details.+ Copyright [yyyy] [name of copyright owner] -The hypothetical commands `show w' and `show c' should show the appropriate-parts of the General Public License. Of course, your program's commands-might be different; for a GUI interface, you would use an "about box".+ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at - You should also get your employer (if you work as a programmer) or school,-if any, to sign a "copyright disclaimer" for the program, if necessary.-For more information on this, and how to apply and follow the GNU GPL, see-<http://www.gnu.org/licenses/>.+ http://www.apache.org/licenses/LICENSE-2.0 - The GNU General Public License does not permit incorporating your program-into proprietary programs. If your program is a subroutine library, you-may consider it more useful to permit linking proprietary applications with-the library. If this is what you want to do, use the GNU Lesser General-Public License instead of this License. But first, please read-<http://www.gnu.org/philosophy/why-not-lgpl.html>.+ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
tests/DBusTests.hs view
@@ -1,17 +1,16 @@ -- Copyright (C) 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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module Main ( tests@@ -45,7 +44,9 @@ import DBus.Internal.Message () import DBus.Internal.Types () import DBus.Internal.Wire ()-import DBus.Introspection ()+import DBus.Introspection.Parse ()+import DBus.Introspection.Render ()+import DBus.Introspection.Types () import DBus.Socket () tests :: TestTree
tests/DBusTests/Address.hs view
@@ -1,17 +1,16 @@ -- Copyright (C) 2010-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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.Address (test_Address) where
tests/DBusTests/BusName.hs view
@@ -1,17 +1,16 @@ -- Copyright (C) 2010-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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.BusName (test_BusName) where
tests/DBusTests/Client.hs view
@@ -1,23 +1,23 @@ -- Copyright (C) 2010-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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.Client (test_Client) where import Control.Concurrent import Control.Exception (try) import Data.Word+import Data.Int import Test.Tasty import Test.Tasty.HUnit import qualified Data.Map as Map@@ -25,14 +25,27 @@ import DBus import qualified DBus.Client import qualified DBus.Socket+import DBus.Introspection.Parse+import DBus.Introspection.Types+import DBus.Internal.Types import DBusTests.Util+import qualified DBusTests.TH as TH+import qualified DBusTests.Generation as G +doExport :: DBus.Client.Client -> String -> String -> [DBus.Client.Method] -> IO ()+doExport client path name methods =+ DBus.Client.export client (objectPath_ path) DBus.Client.defaultInterface+ { DBus.Client.interfaceMethods = methods+ , DBus.Client.interfaceName = interfaceName_ name+ }+ test_Client :: TestTree test_Client = testGroup "Client" $ [ test_RequestName , test_ReleaseName , test_Call+ , test_CallWithGeneration , test_CallNoReply , test_AddMatch , test_AutoMethod@@ -56,6 +69,22 @@ client <- readMVar clientVar DBus.Client.disconnect client +test_ConnectWithName :: TestTree+test_ConnectWithName = testCase "connectWithName" $ do+ (addr, sockVar) <- startDummyBus+ clientVar <- forkVar (DBus.Client.connectWithName DBus.Client.defaultClientOptions addr)++ sock <- readMVar sockVar+ receivedHello <- DBus.Socket.receive sock+ let (ReceivedMethodCall helloSerial _) = receivedHello++ let helloReturn = (methodReturn helloSerial) { methodReturnBody = [toVariant ":1.123"] }+ DBus.Socket.send sock helloReturn (\_ -> return ())++ (client, clientName) <- readMVar clientVar+ assertEqual "client name not as expected" (busName_ ":1.123") clientName+ DBus.Client.disconnect client+ suite_Connect :: TestTree suite_Connect = testGroup "connect" [ test_ConnectSystem@@ -64,6 +93,7 @@ , test_ConnectSession_NoAddress , test_ConnectStarter , test_ConnectStarter_NoAddress+ , test_ConnectWithName ] test_ConnectSystem :: TestTree@@ -89,9 +119,8 @@ test_ConnectSession_NoAddress :: TestTree test_ConnectSession_NoAddress = testCase "connectSession-no-address" $ assertException- (DBus.Client.clientError "connectSession: DBUS_SESSION_BUS_ADDRESS is missing or invalid.")- (withEnv "DBUS_SESSION_BUS_ADDRESS"- (Just "invalid")+ (DBus.Client.clientError "connectSession: DBUS_SESSION_BUS_ADDRESS is invalid.")+ (withEnv "DBUS_SESSION_BUS_ADDRESS" (Just "invalid") DBus.Client.connectSession) test_ConnectStarter :: TestTree@@ -277,6 +306,31 @@ reply @?= methodReturn (methodReturnSerial reply) +test_CallWithGeneration :: TestTree+test_CallWithGeneration = withConnectedClient $ \res -> testCase "callGeneration" $ do+ (sock, client) <- res+ let string = "test"+ busName = busName_ "org.freeDesktop.DBus"+ int = 32 :: Int32+ path = objectPath_ "/a/b/c"+ returnValue = Map.fromList [(string, int)]++ DBus.Client.export client path G.testInterface++ do+ response <- stubMethodCall sock+ (TH.sampleMethod1 client busName path string int)+ (methodCall path (DBus.Client.interfaceName G.testInterface) $+ memberName_ "SampleMethod1")+ { methodCallDestination = Just busName+ , methodCallBody = [toVariant string, toVariant int]+ }+ (\x -> (methodReturn x)+ { methodReturnBody = [toVariant returnValue]})+ reply <- requireRight response++ reply @?= returnValue+ test_CallNoReply :: TestTree test_CallNoReply = withConnectedClient $ \res -> testCase "callNoReply" $ do (sock, client) <- res@@ -346,9 +400,9 @@ let methodPair = (\x y -> return (x, y)) :: String -> String -> IO (String, String) - DBus.Client.export client (objectPath_ "/")- [ DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Max") methodMax- , DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Pair") methodPair+ doExport client "/" "com.example.Foo"+ [ DBus.Client.autoMethod (memberName_ "Max") methodMax+ , DBus.Client.autoMethod (memberName_ "Pair") methodPair ] -- valid call to com.example.Foo.Max@@ -371,62 +425,207 @@ response @?= Left (methodError serial (errorName_ "org.freedesktop.DBus.Error.InvalidParameters")) test_ExportIntrospection :: TestTree-test_ExportIntrospection = withConnectedClient $ \res -> testCase "exportIntrospection" $ do- (sock, client) <- res- DBus.Client.export client (objectPath_ "/foo")- [ DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Method1")- (undefined :: String -> IO ())- , DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Method2")- (undefined :: String -> IO String)- , DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Method3")- (undefined :: String -> IO (String, String))- ]-- let introspect path = do- (_, response) <- callClientMethod sock path "org.freedesktop.DBus.Introspectable" "Introspect" []- ret <- requireRight response- let body = methodReturnBody ret-- length body @?= 1- let Just xml = fromVariant (head body)- return xml-- root <- introspect "/"- root @?=- "<!DOCTYPE node PUBLIC '-//freedesktop//DTD D-BUS Object Introspection 1.0//EN' 'http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd'>\n\- \<node name='/'>\- \<interface name='org.freedesktop.DBus.Introspectable'>\- \<method name='Introspect'>\- \<arg name='' type='s' direction='out'/>\- \</method>\- \</interface>\- \<node name='foo'></node>\- \</node>"-- foo <- introspect "/foo"- foo @?=- "<!DOCTYPE node PUBLIC '-//freedesktop//DTD D-BUS Object Introspection 1.0//EN' 'http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd'>\n\- \<node name='/foo'>\- \<interface name='com.example.Foo'>\- \<method name='Method1'>\- \<arg name='' type='s' direction='in'/>\- \</method>\- \<method name='Method2'>\- \<arg name='' type='s' direction='in'/>\- \<arg name='' type='s' direction='out'/>\- \</method>\- \<method name='Method3'>\- \<arg name='' type='s' direction='in'/>\- \<arg name='' type='s' direction='out'/>\- \<arg name='' type='s' direction='out'/>\- \</method>\- \</interface>\- \<interface name='org.freedesktop.DBus.Introspectable'>\- \<method name='Introspect'>\- \<arg name='' type='s' direction='out'/>\- \</method>\- \</interface>\- \</node>"+test_ExportIntrospection =+ withConnectedClient $ \res ->+ testCase "exportIntrospection" $ do+ (sock, client) <- res+ let interface =+ DBus.Client.defaultInterface+ { DBus.Client.interfaceMethods =+ [ DBus.Client.autoMethod+ (memberName_ "Method1")+ (undefined :: String -> IO ())+ , DBus.Client.autoMethod+ (memberName_ "Method2")+ (undefined :: String -> IO String)+ , DBus.Client.autoMethod+ (memberName_ "Method3")+ (undefined :: String -> IO (String, String))+ ]+ , DBus.Client.interfaceName = interfaceName_ "com.example.Echo"+ }+ expectedIntrospectionInterface =+ Object+ { objectPath = ObjectPath "/foo"+ , objectInterfaces =+ [ Interface+ { interfaceName =+ InterfaceName "org.freedesktop.DBus.Properties"+ , interfaceMethods =+ [ Method+ { methodName = MemberName "Get"+ , methodArgs =+ [ MethodArg+ { methodArgName = "a"+ , methodArgType = TypeString+ , methodArgDirection = In+ }+ , MethodArg+ { methodArgName = "b"+ , methodArgType = TypeString+ , methodArgDirection = In+ }+ , MethodArg+ { methodArgName = "c"+ , methodArgType = TypeVariant+ , methodArgDirection = Out+ }+ ]+ }+ , Method+ { methodName = MemberName "GetAll"+ , methodArgs =+ [ MethodArg+ { methodArgName = "a"+ , methodArgType = TypeString+ , methodArgDirection = In+ }+ , MethodArg+ { methodArgName = "b"+ , methodArgType = TypeDictionary TypeString TypeVariant+ , methodArgDirection = Out+ }+ ]+ }+ , Method+ { methodName = MemberName "Set"+ , methodArgs =+ [ MethodArg+ { methodArgName = "a"+ , methodArgType = TypeString+ , methodArgDirection = In+ }+ , MethodArg+ { methodArgName = "b"+ , methodArgType = TypeString+ , methodArgDirection = In+ }+ , MethodArg+ { methodArgName = "c"+ , methodArgType = TypeVariant+ , methodArgDirection = In+ }+ ]+ }+ ]+ , interfaceSignals =+ [ Signal+ { signalName = MemberName "PropertiesChanged"+ , signalArgs =+ [ SignalArg+ { signalArgName = "interface_name"+ , signalArgType = TypeString+ }+ , SignalArg+ { signalArgName = "changed_properties"+ , signalArgType = TypeDictionary TypeString TypeVariant+ }+ , SignalArg+ { signalArgName = "invalidated_properties"+ , signalArgType = TypeArray TypeString+ }+ ]+ }+ ]+ , interfaceProperties = []+ }+ , Interface+ { interfaceName =+ InterfaceName "org.freedesktop.DBus.Introspectable"+ , interfaceMethods =+ [ Method+ { methodName = MemberName "Introspect"+ , methodArgs =+ [ MethodArg+ { methodArgName = "a"+ , methodArgType = TypeString+ , methodArgDirection = Out+ }+ ]+ }+ ]+ , interfaceSignals = []+ , interfaceProperties = []+ }+ , Interface+ { interfaceName = InterfaceName "com.example.Echo"+ , interfaceMethods =+ [ Method+ { methodName = MemberName "Method1"+ , methodArgs =+ [ MethodArg+ { methodArgName = "a"+ , methodArgType = TypeString+ , methodArgDirection = In+ }+ ]+ }+ , Method+ { methodName = MemberName "Method2"+ , methodArgs =+ [ MethodArg+ { methodArgName = "a"+ , methodArgType = TypeString+ , methodArgDirection = In+ }+ , MethodArg+ { methodArgName = "b"+ , methodArgType = TypeString+ , methodArgDirection = Out+ }+ ]+ }+ , Method+ { methodName = MemberName "Method3"+ , methodArgs =+ [ MethodArg+ { methodArgName = "a"+ , methodArgType = TypeString+ , methodArgDirection = In+ }+ , MethodArg+ { methodArgName = "b"+ , methodArgType = TypeString+ , methodArgDirection = Out+ }+ , MethodArg+ { methodArgName = "c"+ , methodArgType = TypeString+ , methodArgDirection = Out+ }+ ]+ }+ ]+ , interfaceSignals = []+ , interfaceProperties = []+ }+ ]+ , objectChildren = []+ }+ DBus.Client.export client (objectPath_ "/foo") interface+ let introspect path = do+ (_, response) <-+ callClientMethod+ sock+ path+ "org.freedesktop.DBus.Introspectable"+ "Introspect"+ []+ ret <- requireRight response+ let body = methodReturnBody ret+ length body @?= 1+ let Just xml = fromVariant (head body)+ return $ parseXML (objectPath_ "/") xml+ root <- introspect "/"+ root @?=+ Just+ (Object+ { objectPath = ObjectPath "/"+ , objectInterfaces = []+ , objectChildren = [ expectedIntrospectionInterface ]+ })+ foo <- introspect "/foo"+ foo @?= Just expectedIntrospectionInterface startDummyBus :: IO (Address, MVar DBus.Socket.Socket) startDummyBus = do
tests/DBusTests/ErrorName.hs view
@@ -1,17 +1,16 @@ -- Copyright (C) 2010-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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.ErrorName (test_ErrorName) where
+ tests/DBusTests/Generation.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}++module DBusTests.Generation where++import DBus.Client+import qualified DBus.Internal.Types as T+import qualified DBus.Introspection.Types as I+import Data.Int+import Data.Map as M++sampleMethod1 :: String -> Int32 -> IO (M.Map String Int32)+sampleMethod1 a b = return $ M.insert a b M.empty++serviceArg :: I.SignalArg+serviceArg = I.SignalArg { I.signalArgName = "service"+ , I.signalArgType = T.TypeString+ }++testSignals :: [I.Signal]+testSignals = [ I.Signal { I.signalName = "StatusNotifierItemRegistered"+ , I.signalArgs = [serviceArg]+ }+ ]++testInterface :: Interface+testInterface =+ defaultInterface { interfaceMethods =+ [autoMethod "SampleMethod1" sampleMethod1]+ , interfaceProperties =+ [autoProperty "SampleWriteProperty"+ (Just $ return (1 :: Int32))+ (Just $ const $ return ())+ ]+ , interfaceName = "org.TestInterface"+ , interfaceSignals = testSignals+ }++testIntrospectionInterface :: I.Interface+testIntrospectionInterface = buildIntrospectionInterface testInterface
tests/DBusTests/Integration.hs view
@@ -2,18 +2,17 @@ -- Copyright (C) 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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.Integration (test_Integration) where @@ -59,11 +58,18 @@ clientB <- connect addr export clientA "/"- [ method "com.example.Echo" "Echo" (signature_ [TypeString]) (signature_ []) (- \msg -> if map variantType (methodCallBody msg) == [TypeString]- then return (replyReturn (methodCallBody msg))- else return (replyError "com.example.Error" [toVariant ("bad body: " ++ show (methodCallBody msg))]))- ]+ defaultInterface+ { interfaceName = "com.example.Echo"+ , interfaceMethods =+ [ Method "Echo" (signature_ [TypeString]) (signature_ []) (+ \msg -> if map variantType (methodCallBody msg) == [TypeString]+ then return (ReplyReturn (methodCallBody msg))+ else+ return $ ReplyError+ "com.example.Error"+ [toVariant ("bad body: " ++ show (methodCallBody msg))])+ ]+ } -- TODO: get bus address of clientA with a function let busAddrA = ":1.0"
tests/DBusTests/InterfaceName.hs view
@@ -1,17 +1,16 @@ -- Copyright (C) 2010-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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.InterfaceName (test_InterfaceName) where
tests/DBusTests/Introspection.hs view
@@ -1,29 +1,31 @@+{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2010-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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.Introspection (test_Introspection) where -import Control.Applicative ((<$>), (<*>)) import Control.Monad (liftM, liftM2) import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck+import qualified Data.Text as T import DBus-import qualified DBus.Introspection as Introspection+import qualified DBus.Introspection.Parse as I+import qualified DBus.Introspection.Render as I+import qualified DBus.Introspection.Types as I import DBusTests.InterfaceName () import DBusTests.MemberName ()@@ -41,27 +43,30 @@ test_XmlPassthrough :: TestTree test_XmlPassthrough = testProperty "xml-passthrough" $ \obj -> let- path = Introspection.objectPath obj- Just xml = Introspection.formatXML obj- in Introspection.parseXML path xml == Just obj+ path = I.objectPath obj+ Just xml = I.formatXML obj+ in I.parseXML path (T.pack xml) == Just obj +buildEmptyObject :: String -> I.Object+buildEmptyObject name = I.Object (objectPath_ name) [] []+ test_XmlParse :: TestTree test_XmlParse = testCase "xml-parse" $ do -- root object path can be inferred- Introspection.parseXML (objectPath_ "/") "<node><node name='foo'/></node>"- @?= Just (Introspection.object (objectPath_ "/"))- { Introspection.objectChildren =- [ Introspection.object (objectPath_ "/foo")+ I.parseXML (objectPath_ "/") "<node><node name='foo'/></node>"+ @?= Just (buildEmptyObject "/")+ { I.objectChildren =+ [ buildEmptyObject "/foo" ] } test_XmlParseFailed :: TestTree test_XmlParseFailed = testCase "xml-parse-failed" $ do- Nothing @=? Introspection.parseXML (objectPath_ "/") "<invalid>"- Nothing @=? Introspection.parseXML (objectPath_ "/") "<invalid/>"+ Nothing @=? I.parseXML (objectPath_ "/") "<invalid>"+ Nothing @=? I.parseXML (objectPath_ "/") "<invalid/>" -- invalid property access- Nothing @=? Introspection.parseXML (objectPath_ "/")+ Nothing @=? I.parseXML (objectPath_ "/") "<node>\ \ <interface name='com.example.Foo'>\ \ <property type='s' access='invalid'>\@@ -70,7 +75,7 @@ \</node>" -- invalid parameter type- Nothing @=? Introspection.parseXML (objectPath_ "/")+ Nothing @=? I.parseXML (objectPath_ "/") "<node>\ \ <interface name='com.example.Foo'>\ \ <method name='Foo'>\@@ -82,22 +87,17 @@ test_XmlWriteFailed :: TestTree test_XmlWriteFailed = testCase "xml-write-failed" $ do -- child's object path isn't under parent's- Nothing @=? Introspection.formatXML (Introspection.object (objectPath_ "/foo"))- { Introspection.objectChildren =- [ Introspection.object (objectPath_ "/bar")- ]+ Nothing @=? I.formatXML (buildEmptyObject "/foo")+ { I.objectChildren =+ [ buildEmptyObject "/bar" ] } -- invalid type- Nothing @=? Introspection.formatXML (Introspection.object (objectPath_ "/foo"))- { Introspection.objectInterfaces =- [ (Introspection.interface (interfaceName_ "/bar"))- { Introspection.interfaceProperties =- [ Introspection.property "prop" (TypeDictionary TypeVariant TypeVariant)- ]- }- ]- }+ Nothing @=? I.formatXML+ ((buildEmptyObject "/foo")+ { I.objectInterfaces =+ [ I.Interface (interfaceName_ "/bar") [] []+ [ I.Property "prop" (TypeDictionary TypeVariant TypeVariant) True True ]]}) instance Arbitrary Type where arbitrary = oneof [atom, container] where@@ -122,16 +122,16 @@ , liftM TypeStructure (listOf1 (halfSized arbitrary)) ] -instance Arbitrary Introspection.Object where+instance Arbitrary I.Object where arbitrary = arbitrary >>= subObject -subObject :: ObjectPath -> Gen Introspection.Object+subObject :: ObjectPath -> Gen I.Object subObject parentPath = sized $ \n -> resize (min n 4) $ do let nonRoot = do- x <- resize 10 arbitrary- case formatObjectPath x of- "/" -> nonRoot- x' -> return x'+ x <- resize 10 arbitrary+ case formatObjectPath x of+ "/" -> nonRoot+ x' -> return x' thisPath <- nonRoot let path' = case formatObjectPath parentPath of@@ -140,62 +140,53 @@ let path = objectPath_ path' ifaces <- arbitrary children <- halfSized (listOf (subObject path))- return (Introspection.object path)- { Introspection.objectInterfaces = ifaces- , Introspection.objectChildren = children- }+ return $ I.Object path ifaces children -instance Arbitrary Introspection.Interface where+instance Arbitrary I.Interface where arbitrary = do name <- arbitrary methods <- arbitrary signals <- arbitrary properties <- arbitrary- return (Introspection.interface name)- { Introspection.interfaceMethods = methods- , Introspection.interfaceSignals = signals- , Introspection.interfaceProperties = properties- }+ return $ I.Interface name methods signals properties -instance Arbitrary Introspection.Method where+instance Arbitrary I.Method where arbitrary = do name <- arbitrary args <- arbitrary- return (Introspection.method name)- { Introspection.methodArgs = args- }+ return $ (I.Method name args) -instance Arbitrary Introspection.Signal where+instance Arbitrary I.Signal where arbitrary = do name <- arbitrary args <- arbitrary- return (Introspection.signal name)- { Introspection.signalArgs = args- }+ return $ I.Signal name args -instance Arbitrary Introspection.MethodArg where- arbitrary = Introspection.methodArg+instance Arbitrary I.MethodArg where+ arbitrary = I.MethodArg <$> gen_Ascii <*> arbitrary <*> arbitrary -instance Arbitrary Introspection.Direction where- arbitrary = elements [Introspection.directionIn, Introspection.directionOut]+instance Arbitrary I.Direction where+ arbitrary = elements [I.In, I.Out] -instance Arbitrary Introspection.SignalArg where- arbitrary = Introspection.signalArg+instance Arbitrary I.SignalArg where+ arbitrary = I.SignalArg <$> gen_Ascii <*> arbitrary -instance Arbitrary Introspection.Property where+instance Arbitrary I.Property where arbitrary = do name <- gen_Ascii t <- arbitrary canRead <- arbitrary canWrite <- arbitrary- return (Introspection.property name t)- { Introspection.propertyRead = canRead- , Introspection.propertyWrite = canWrite+ return I.Property+ { I.propertyName = name+ , I.propertyType = t+ , I.propertyRead = canRead+ , I.propertyWrite = canWrite } gen_Ascii :: Gen String
tests/DBusTests/MemberName.hs view
@@ -1,17 +1,16 @@ -- Copyright (C) 2010-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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.MemberName (test_MemberName) where
tests/DBusTests/Message.hs view
@@ -1,17 +1,16 @@ -- Copyright (C) 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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.Message (test_Message) where
tests/DBusTests/ObjectPath.hs view
@@ -1,17 +1,16 @@ -- Copyright (C) 2010-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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.ObjectPath (test_ObjectPath) where
tests/DBusTests/Serialization.hs view
@@ -2,18 +2,17 @@ -- Copyright (C) 2010-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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.Serialization (test_Serialization) where @@ -26,7 +25,6 @@ import System.Posix.Types (Fd) import Test.QuickCheck import Test.Tasty-import Test.Tasty.HUnit import Test.Tasty.QuickCheck import qualified Data.Map import qualified Data.Vector@@ -54,32 +52,32 @@ test_MethodCall = testProperty "MethodCall" prop where prop = forAll gen_MethodCall check check msg endianness serial = let- Right bytes = marshal endianness serial msg- Right received = unmarshal bytes+ Right (bytes, fds) = marshalWithFds endianness serial msg+ Right received = unmarshalWithFds bytes fds in ReceivedMethodCall serial msg == received test_MethodReturn :: TestTree test_MethodReturn = testProperty "MethodReturn" prop where prop = forAll gen_MethodReturn check check msg endianness serial = let- Right bytes = marshal endianness serial msg- Right received = unmarshal bytes+ Right (bytes, fds) = marshalWithFds endianness serial msg+ Right received = unmarshalWithFds bytes fds in ReceivedMethodReturn serial msg == received test_MethodError :: TestTree test_MethodError = testProperty "MethodError" prop where prop = forAll gen_MethodError check check msg endianness serial = let- Right bytes = marshal endianness serial msg- Right received = unmarshal bytes+ Right (bytes, fds) = marshalWithFds endianness serial msg+ Right received = unmarshalWithFds bytes fds in ReceivedMethodError serial msg == received test_Signal :: TestTree test_Signal = testProperty "Signal" prop where prop = forAll gen_Signal check check msg endianness serial = let- Right bytes = marshal endianness serial msg- Right received = unmarshal bytes+ Right (bytes, fds) = marshalWithFds endianness serial msg+ Right received = unmarshalWithFds bytes fds in ReceivedSignal serial msg == received gen_Atom :: Gen Variant
tests/DBusTests/Signature.hs view
@@ -1,17 +1,16 @@ -- Copyright (C) 2010-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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.Signature (test_Signature) where
tests/DBusTests/Socket.hs view
@@ -1,24 +1,28 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-} -- Copyright (C) 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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.Socket (test_Socket) where import Control.Concurrent import Control.Exception+import Control.Monad (void)+import System.IO (SeekMode(..))+import System.Posix (Fd, fdRead, fdSeek, fdWrite) import Test.Tasty import Test.Tasty.HUnit import qualified Data.Map as Map@@ -27,21 +31,20 @@ import DBus.Socket import DBus.Transport -import DBusTests.Util (forkVar)+import DBusTests.Util (forkVar, nonWindowsTestCase, withTempFd) test_Socket :: TestTree test_Socket = testGroup "Socket" [ test_Listen , test_ListenWith_CustomAuth , test_SendReceive+ , test_SendReceive_FileDescriptors ] test_Listen :: TestTree test_Listen = testCase "listen" $ do uuid <- randomUUID- let Just addr = address "unix" (Map.fromList- [ ("abstract", formatUUID uuid)- ])+ let Just addr = address "unix" (Map.singleton "abstract" (formatUUID uuid)) bracket (listen addr) closeListener $ \listener -> do acceptedVar <- forkVar (accept listener)@@ -55,9 +58,7 @@ test_ListenWith_CustomAuth :: TestTree test_ListenWith_CustomAuth = testCase "listenWith-custom-auth" $ do uuid <- randomUUID- let Just addr = address "unix" (Map.fromList- [ ("abstract", formatUUID uuid)- ])+ let Just addr = address "unix" (Map.singleton "abstract" (formatUUID uuid)) bracket (listenWith (defaultSocketOptions { socketAuthenticator = dummyAuth@@ -75,9 +76,7 @@ test_SendReceive :: TestTree test_SendReceive = testCase "send-receive" $ do uuid <- randomUUID- let Just addr = address "unix" (Map.fromList- [ ("abstract", formatUUID uuid)- ])+ let Just addr = address "unix" (Map.singleton "abstract" (formatUUID uuid)) let msg = (methodCall "/" "org.example.iface" "Foo") { methodCallSender = Just "org.example.src"@@ -92,32 +91,66 @@ openedVar <- forkVar (open addr) bracket (takeMVar acceptedVar) close $ \sock1 -> do- bracket (takeMVar openedVar) close $ \sock2 -> do- -- client -> server- do- serialVar <- newEmptyMVar- sentVar <- forkVar (send sock2 msg (putMVar serialVar))- receivedVar <- forkVar (receive sock1)+ bracket (takeMVar openedVar) close $ \sock2 -> do+ -- client -> server+ do+ serialVar <- newEmptyMVar+ sentVar <- forkVar (send sock2 msg (putMVar serialVar))+ receivedVar <- forkVar (receive sock1) - serial <- takeMVar serialVar- sent <- takeMVar sentVar- received <- takeMVar receivedVar+ serial <- takeMVar serialVar+ sent <- takeMVar sentVar+ received <- takeMVar receivedVar - sent @?= ()- received @?= ReceivedMethodCall serial msg+ sent @?= ()+ received @?= ReceivedMethodCall serial msg - -- server -> client- do- serialVar <- newEmptyMVar- sentVar <- forkVar (send sock1 msg (putMVar serialVar))- receivedVar <- forkVar (receive sock2)+ -- server -> client+ do+ serialVar <- newEmptyMVar+ sentVar <- forkVar (send sock1 msg (putMVar serialVar))+ receivedVar <- forkVar (receive sock2) - serial <- takeMVar serialVar- sent <- takeMVar sentVar- received <- takeMVar receivedVar+ serial <- takeMVar serialVar+ sent <- takeMVar sentVar+ received <- takeMVar receivedVar - sent @?= ()- received @?= ReceivedMethodCall serial msg+ sent @?= ()+ received @?= ReceivedMethodCall serial msg++test_SendReceive_FileDescriptors :: TestTree+test_SendReceive_FileDescriptors = nonWindowsTestCase "send-receive-file-descriptors" $ do+ uuid <- randomUUID+ let Just addr = address "unix" (Map.singleton "abstract" (formatUUID uuid))+ + withTempFd $ \tmpFd -> do++ -- in order to know that the file descriptor received by the server points to+ -- the same file as the file descriptor that was sent, we write "hello" on the+ -- client and read it back on the server.+ void $ fdWrite tmpFd "hello"+ void $ fdSeek tmpFd AbsoluteSeek 0++ let msg = (methodCall "/" "org.example.iface" "Foo")+ { methodCallBody = [toVariant tmpFd] }++ bracket (listen addr) closeListener $ \listener -> do+ acceptedVar <- forkVar (accept listener)+ openedVar <- forkVar (open addr)++ bracket (takeMVar acceptedVar) close $ \sock1 -> do+ bracket (takeMVar openedVar) close $ \sock2 -> do+ receivedVar <- forkVar (receive sock1)+ send sock2 msg (const (pure ()))++ received <- takeMVar receivedVar+ case receivedMessageBody received of+ [fromVariant -> Just (fd :: Fd)] -> do+ assertBool ("Expected a different Fd, not " <> show tmpFd) (fd /= tmpFd)+ (fdMsg, _) <- fdRead fd 5+ fdMsg @?= "hello"+ body -> do+ assertFailure ("Expected a single Fd, not: " <> show body) dummyAuth :: Transport t => Authenticator t dummyAuth = authenticator
+ tests/DBusTests/TH.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE TemplateHaskell #-}++module DBusTests.TH where++import DBus.Generation+import DBusTests.Generation++generateClient defaultGenerationParams testIntrospectionInterface+generateSignalsFromInterface defaultGenerationParams testIntrospectionInterface
tests/DBusTests/Transport.hs view
@@ -2,29 +2,35 @@ -- Copyright (C) 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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.Transport (test_Transport) where import Control.Concurrent+import Control.Monad (void) import Control.Monad.Extra (unlessM)-import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Resource+import Data.ByteString.Unsafe (unsafeUseAsCString) import Data.Function (fix) import Data.List (isInfixOf)-import Network.Socket.ByteString (sendAll, recv)+import Foreign.Ptr (castPtr)+import Network.Socket (Socket)+import Network.Socket.Address (SocketAddress(..), sendBufMsg)+import Network.Socket.ByteString (recvMsg, sendAll, sendMsg) import System.Directory (getTemporaryDirectory, removeFile)+import System.IO (SeekMode(..))+import System.Posix (fdRead, fdSeek, fdWrite) import Test.Tasty import Test.Tasty.HUnit import qualified Data.ByteString@@ -42,6 +48,8 @@ , suite_TransportListen , suite_TransportAccept , test_TransportSendReceive+ , test_TransportSendReceive_FileDescriptors+ , test_TransportSendReceive_FileDescriptors_MultiplePuts , test_HandleLostConnection ] @@ -85,7 +93,7 @@ test_OpenUnix_Path :: TestTree test_OpenUnix_Path = testCase "path" $ runResourceT $ do- (addr, networkSocket) <- listenRandomUnixPath+ addr <- listenRandomUnixPath fdcountBefore <- countFileDescriptors t <- liftIO (transportOpen socketTransportOptions addr)@@ -96,7 +104,7 @@ test_OpenUnix_Abstract :: TestTree test_OpenUnix_Abstract = testCase "abstract" $ runResourceT $ do- (addr, networkSocket, _) <- listenRandomUnixAbstract+ (addr, _, _) <- listenRandomUnixAbstract fdcountBefore <- countFileDescriptors t <- liftIO (transportOpen socketTransportOptions addr)@@ -140,7 +148,7 @@ test_OpenUnix_NotListening = testCase "not-listening" $ runResourceT $ do fdcountBefore <- countFileDescriptors - (addr, networkSocket, key) <- listenRandomUnixAbstract+ (addr, _sock, key) <- listenRandomUnixAbstract release key liftIO $ assertThrows@@ -166,7 +174,7 @@ test_OpenTcp_IPv4 :: TestTree test_OpenTcp_IPv4 = testCase "ipv4" $ runResourceT $ do- (addr, networkSocket, _) <- listenRandomIPv4+ (addr, _, _) <- listenRandomIPv4 fdcountBefore <- countFileDescriptors t <- liftIO (transportOpen socketTransportOptions addr)@@ -177,7 +185,7 @@ test_OpenTcp_IPv6 :: TestTree test_OpenTcp_IPv6 = testCase "ipv6" $ unlessM noIPv6 $ runResourceT $ do- (addr, networkSocket) <- listenRandomIPv6+ addr <- listenRandomIPv6 fdcountBefore <- countFileDescriptors t <- liftIO (transportOpen socketTransportOptions addr)@@ -257,11 +265,12 @@ fdcountBefore @=? fdcountAfter test_OpenTcp_NotListening :: TestTree-test_OpenTcp_NotListening = testCase "too-many" $ runResourceT $ do+test_OpenTcp_NotListening = testCase "not-listening" $ runResourceT $ do fdcountBefore <- countFileDescriptors - (addr, networkSocket, key) <- listenRandomIPv4+ (addr, _, key) <- listenRandomIPv4 release key+ liftIO $ assertThrows (\err -> and [ "Connection refused" `isInfixOf` transportErrorMessage err@@ -275,17 +284,7 @@ test_TransportSendReceive :: TestTree test_TransportSendReceive = testCase "send-receive" $ runResourceT $ do (addr, networkSocket, _) <- listenRandomIPv4-- -- a simple echo server, which sends back anything it receives.- _ <- liftIO $ forkIO $ do- (s, _) <- NS.accept networkSocket- fix $ \loop -> do- bytes <- recv s 50- if Data.ByteString.null bytes- then NS.sClose s- else do- sendAll s bytes- loop+ startEchoServer networkSocket (_, t) <- allocate (transportOpen socketTransportOptions addr)@@ -297,17 +296,74 @@ liftIO (transportPut t "1") liftIO (transportPut t "2") liftIO (transportPut t "3")- bytes <- liftIO (readMVar var)- liftIO (bytes @?= "123")+ result <- liftIO (readMVar var)+ liftIO (result @?= "123") -- large chunks of data are read in full do let sentBytes = Data.ByteString.replicate (4096 * 100) 0 var <- forkVar (transportGet t (4096 * 100)) liftIO (transportPut t sentBytes)- bytes <- liftIO (readMVar var)- liftIO (bytes @?= sentBytes)+ result <- liftIO (readMVar var)+ liftIO (result @?= sentBytes) +test_TransportSendReceive_FileDescriptors :: TestTree+test_TransportSendReceive_FileDescriptors = nonWindowsTestCase "send-receive-file-descriptors" $ runResourceT $ do+ (addr, networkSocket, _) <- listenRandomUnixAbstract+ startEchoServer networkSocket++ (_, t) <- allocate+ (transportOpen socketTransportOptions addr)+ transportClose+ + liftIO $ withTempFd $ \fd1 -> withTempFd $ \fd2 -> do++ -- in order to know that the file descriptors received back from the echo server+ -- point to the same files as the file descriptors that were sent, we write data+ -- on the initial file descriptors and read it back from the returned ones.+ void $ fdWrite fd1 "1"+ void $ fdSeek fd1 AbsoluteSeek 0+ void $ fdWrite fd2 "2"+ void $ fdSeek fd2 AbsoluteSeek 0++ -- file descriptors from multiple chunks are combined+ var <- forkVar (transportGetWithFds t 1)+ liftIO (transportPutWithFds t "x" [fd1, fd2])+ ("x", [fd1', fd2']) <- liftIO (readMVar var)+ (fd1Val, _) <- liftIO (fdRead fd1' 1)+ (fd2Val, _) <- liftIO (fdRead fd2' 2)+ fd1Val @?= "1"+ fd2Val @?= "2"++test_TransportSendReceive_FileDescriptors_MultiplePuts :: TestTree+test_TransportSendReceive_FileDescriptors_MultiplePuts = nonWindowsTestCase "send-receive-file-descriptors-multiple-puts" $ runResourceT $ do+ (addr, networkSocket, _) <- listenRandomUnixAbstract+ startEchoServer networkSocket++ (_, t) <- allocate+ (transportOpen socketTransportOptions addr)+ transportClose+ + liftIO $ withTempFd $ \fd1 -> withTempFd $ \fd2 -> do++ -- in order to know that the file descriptors received back from the echo server+ -- point to the same files as the file descriptors that were sent, we write data+ -- on the initial file descriptors and read it back from the returned ones.+ void $ fdWrite fd1 "1"+ void $ fdSeek fd1 AbsoluteSeek 0+ void $ fdWrite fd2 "2"+ void $ fdSeek fd2 AbsoluteSeek 0++ -- file descriptors from multiple chunks are combined+ var <- forkVar (transportGetWithFds t 2)+ liftIO (transportPutWithFds t "1" [fd1])+ liftIO (transportPutWithFds t "2" [fd2])+ ("12", [fd1', fd2']) <- liftIO (readMVar var)+ (fd1Val, _) <- liftIO (fdRead fd1' 1)+ (fd2Val, _) <- liftIO (fdRead fd2' 2)+ fd1Val @?= "1"+ fd2Val @?= "2"+ test_HandleLostConnection :: TestTree test_HandleLostConnection = testCase "handle-lost-connection" $ runResourceT $ do (addr, networkSocket, _) <- listenRandomIPv4@@ -315,14 +371,14 @@ _ <- liftIO $ forkIO $ do (s, _) <- NS.accept networkSocket sendAll s "123"- NS.sClose s+ NS.close s (_, t) <- allocate (transportOpen socketTransportOptions addr) transportClose - bytes <- liftIO (transportGet t 4)- liftIO (bytes @?= "123")+ result <- liftIO (transportGet t 4)+ liftIO (result @?= "123") test_ListenUnknown :: TestTree test_ListenUnknown = testCase "unknown" $ do@@ -418,7 +474,7 @@ ]) assertThrows (\err -> and- [ "Address already in use" `isInfixOf` transportErrorMessage err+ [ "Permission denied" `isInfixOf` transportErrorMessage err , transportErrorAddress err == Just addr ]) (transportListen socketTransportOptions addr)@@ -521,9 +577,9 @@ liftIO (transportPut opened "testing") - bytes <- liftIO (transportGet accepted 7)+ result <- liftIO (transportGet accepted 7) - liftIO (bytes @?= "testing")+ liftIO (result @?= "testing") test_AcceptSocketClosed :: TestTree test_AcceptSocketClosed = testCase "socket-closed" $ do@@ -538,11 +594,33 @@ assertThrows (\err -> and [ "accept" `isInfixOf` transportErrorMessage err- , "socket" `isInfixOf` transportErrorMessage err- , "Closed" `isInfixOf` transportErrorMessage err , transportErrorAddress err == Just listeningAddr ]) (transportAccept listener) socketTransportOptions :: TransportOptions SocketTransport socketTransportOptions = transportDefaultOptions++-- todo: import NullSockAddr from network package, when released+-- (https://github.com/haskell/network/pull/562)+data NullSockAddr = NullSockAddr++instance SocketAddress NullSockAddr where+ sizeOfSocketAddress NullSockAddr = 0+ peekSocketAddress _ptr = return NullSockAddr+ pokeSocketAddress _ptr NullSockAddr = return ()++-- a simple echo server, which sends back anything it receives.+startEchoServer :: MonadIO m => Socket -> m ()+startEchoServer listenSocket = do+ void . liftIO . forkIO $ do+ (s, _) <- NS.accept listenSocket+ fix $ \loop -> do+ (_sa, bytes, cmsgs, _flag) <- recvMsg s 50 128 mempty+ if Data.ByteString.null bytes+ then NS.close s+ else do+ void . unsafeUseAsCString bytes $ \cstr -> do+ let buf = [(castPtr cstr, Data.ByteString.length bytes)]+ sendBufMsg s NullSockAddr buf cmsgs mempty+ loop
tests/DBusTests/Util.hs view
@@ -1,17 +1,16 @@ -- Copyright (C) 2010-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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.Util ( assertVariant@@ -19,8 +18,11 @@ , assertAtom , assertException , assertThrows+ + , nonWindowsTestCase , getTempPath+ , withTempFd , listenRandomUnixPath , listenRandomUnixAbstract , listenRandomIPv4@@ -50,14 +52,17 @@ import Data.Char (chr) import System.Directory (getTemporaryDirectory, removeFile) import System.FilePath ((</>))+import System.IO.Temp (withSystemTempFile)+import System.Posix (Fd, closeFd, handleToFd) import Test.QuickCheck hiding ((.&.))+import Test.Tasty import Test.Tasty.HUnit import qualified Data.ByteString import qualified Data.ByteString.Lazy import qualified Data.Map as Map import qualified Data.Text as T-import qualified Network as N import qualified Network.Socket as NS+import qualified System.Info import qualified System.Posix as Posix import DBus@@ -91,33 +96,38 @@ uuid <- randomUUID return (tmp </> formatUUID uuid) -listenRandomUnixPath :: MonadResource m => m (Address, N.Socket)+withTempFd :: (Fd -> IO ()) -> IO ()+withTempFd cmd =+ withSystemTempFile "haskell-dbus" $ \_path handle -> do+ bracket (handleToFd handle) closeFd cmd++listenRandomUnixPath :: MonadResource m => m Address listenRandomUnixPath = do path <- liftIO getTempPath let sockAddr = NS.SockAddrUnix path (_, sock) <- allocate (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol)- N.sClose- liftIO (NS.bindSocket sock sockAddr)+ NS.close+ liftIO (NS.bind sock sockAddr) liftIO (NS.listen sock 1) _ <- register (removeFile path) let Just addr = address "unix" (Map.fromList [ ("path", path) ])- return (addr, sock)+ return addr -listenRandomUnixAbstract :: MonadResource m => m (Address, N.Socket, ReleaseKey)+listenRandomUnixAbstract :: MonadResource m => m (Address, NS.Socket, ReleaseKey) listenRandomUnixAbstract = do uuid <- liftIO randomUUID let sockAddr = NS.SockAddrUnix ('\x00' : formatUUID uuid) (key, sock) <- allocate (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol)- N.sClose+ NS.close - liftIO $ NS.bindSocket sock sockAddr+ liftIO $ NS.bind sock sockAddr liftIO $ NS.listen sock 1 let Just addr = address "unix" (Map.fromList@@ -125,15 +135,20 @@ ]) return (addr, sock, key) -listenRandomIPv4 :: MonadResource m => m (Address, N.Socket, ReleaseKey)+listenRandomIPv4 :: MonadResource m => m (Address, NS.Socket, ReleaseKey) listenRandomIPv4 = do- hostAddr <- liftIO $ NS.inet_addr "127.0.0.1"- let sockAddr = NS.SockAddrInet 0 hostAddr+ let hints = NS.defaultHints+ { NS.addrFlags = [NS.AI_NUMERICHOST]+ , NS.addrFamily = NS.AF_INET+ , NS.addrSocketType = NS.Stream+ }+ hostAddr <- liftIO $ NS.getAddrInfo (Just hints) (Just "127.0.0.1") Nothing+ let sockAddr = NS.addrAddress $ head hostAddr (key, sock) <- allocate (NS.socket NS.AF_INET NS.Stream NS.defaultProtocol)- N.sClose- liftIO $ NS.bindSocket sock sockAddr+ NS.close+ liftIO $ NS.bind sock sockAddr liftIO $ NS.listen sock 1 sockPort <- liftIO $ NS.socketPort sock@@ -144,7 +159,7 @@ ]) return (addr, sock, key) -listenRandomIPv6 :: MonadResource m => m (Address, N.Socket)+listenRandomIPv6 :: MonadResource m => m Address listenRandomIPv6 = do addrs <- liftIO $ NS.getAddrInfo Nothing (Just "::1") Nothing let sockAddr = case addrs of@@ -153,8 +168,8 @@ (_, sock) <- allocate (NS.socket NS.AF_INET6 NS.Stream NS.defaultProtocol)- N.sClose- liftIO $ NS.bindSocket sock sockAddr+ NS.close+ liftIO $ NS.bind sock sockAddr liftIO $ NS.listen sock 1 sockPort <- liftIO $ NS.socketPort sock@@ -163,7 +178,7 @@ , ("host", "::1") , ("port", show (toInteger sockPort)) ])- return (addr, sock)+ return addr noIPv6 :: IO Bool noIPv6 = do@@ -294,3 +309,9 @@ case result of Left ex -> assertBool ("unexpected exception " ++ show ex) (check ex) Right _ -> assertFailure "expected exception not thrown"++nonWindowsTestCase :: TestName -> Assertion -> TestTree+nonWindowsTestCase name assertion = testCase name $ do+ case System.Info.os of+ "mingw32" -> pure ()+ _ -> assertion
tests/DBusTests/Variant.hs view
@@ -2,18 +2,17 @@ -- Copyright (C) 2010-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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.Variant (test_Variant) where
tests/DBusTests/Wire.hs view
@@ -2,32 +2,39 @@ -- Copyright (C) 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.+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at ----- 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.+-- http://www.apache.org/licenses/LICENSE-2.0 ----- You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. module DBusTests.Wire (test_Wire) where +import Data.Bifunctor (first) import Data.Either+import System.Posix.Types (Fd(..)) import Test.Tasty import Test.Tasty.HUnit import qualified Data.ByteString.Char8 () import DBus+import DBus.Internal.Message+import DBus.Internal.Types+import DBus.Internal.Wire +import DBusTests.Util+ test_Wire :: TestTree test_Wire = testGroup "Wire" $ [ test_Unmarshal+ , test_FileDescriptors ] test_Unmarshal :: TestTree@@ -37,9 +44,38 @@ test_UnmarshalUnexpectedEof :: TestTree test_UnmarshalUnexpectedEof = testCase "unexpected-eof" $ do- let unmarshaled = unmarshal "0"+ let unmarshaled = unmarshalWithFds "0" [] assertBool "invalid unmarshalled parse" (isLeft unmarshaled) let Left err = unmarshaled unmarshalErrorMessage err @=? "Unexpected end of input while parsing message header."++test_FileDescriptors :: TestTree+test_FileDescriptors = testGroup "Unix File Descriptor Passing" $+ [ test_FileDescriptors_Marshal+ , test_FileDescriptors_UnmarshalHeaderError+ ]++test_FileDescriptors_Marshal :: TestTree+test_FileDescriptors_Marshal = testCaseSteps "(un)marshal round trip" $ \step -> do+ let baseMsg = methodCall "/" "org.example.iface" "Foo"+ + step "marshal"+ let msg = baseMsg { methodCallBody = [toVariant [Fd 2, Fd 1, Fd 2, Fd 3, Fd 1]] }+ Right (bytes, fds) = marshalWithFds LittleEndian firstSerial msg+ fds @?= [Fd 2, Fd 1, Fd 3]++ step "unmarshal"+ let result = receivedMessageBody <$> unmarshalWithFds bytes [Fd 4, Fd 5, Fd 6]+ result @?= Right [toVariant [Fd 4, Fd 5, Fd 4, Fd 6, Fd 5]]++test_FileDescriptors_UnmarshalHeaderError :: TestTree+test_FileDescriptors_UnmarshalHeaderError = testCase "UnixFdHeader mismatch" $ do+ let msg = (methodCall "/" "org.example.iface" "Foo")+ { methodCallBody = [toVariant [Fd 1, Fd 2, Fd 3]] }+ Right (bytes, _fds) = marshalWithFds LittleEndian firstSerial msg+ + let result = first unmarshalErrorMessage (unmarshalWithFds bytes [Fd 4, Fd 6])+ result @?= Left ("File descriptor count in message header (3)"+ <> " does not match the number of file descriptors received from the socket (2).")