├── Setup.hs ├── .codeclimate.yml ├── lib ├── DBus │ ├── Introspection.hs │ ├── TH.hs │ ├── Introspection │ │ ├── Types.hs │ │ ├── Render.hs │ │ └── Parse.hs │ ├── Internal │ │ ├── Address.hs │ │ └── Message.hs │ ├── Socket.hs │ └── Transport.hs └── DBus.hs ├── .gitignore ├── tests ├── DBusTests │ ├── TH.hs │ ├── Generation.hs │ ├── Message.hs │ ├── ObjectPath.hs │ ├── MemberName.hs │ ├── ErrorName.hs │ ├── InterfaceName.hs │ ├── BusName.hs │ ├── Wire.hs │ ├── Integration.hs │ ├── Signature.hs │ ├── Introspection.hs │ ├── Socket.hs │ ├── Variant.hs │ ├── Serialization.hs │ ├── Address.hs │ └── Util.hs └── DBusTests.hs ├── README.md ├── .github └── workflows │ ├── stackage_nightly.yaml │ ├── stackage.yaml │ └── cabal.yaml ├── examples ├── list-names.hs ├── property.hs ├── export.hs ├── introspect.hs └── dbus-monitor.hs ├── stack.yaml ├── idlxml └── dbus.xml ├── benchmarks └── DBusBenchmarks.hs ├── dbus.cabal └── license.txt /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.codeclimate.yml: -------------------------------------------------------------------------------- 1 | engines: 2 | hlint: 3 | enabled: true 4 | fixme: 5 | enabled: true 6 | 7 | ratings: 8 | paths: 9 | - "**.hs" 10 | -------------------------------------------------------------------------------- /lib/DBus/Introspection.hs: -------------------------------------------------------------------------------- 1 | module DBus.Introspection 2 | ( module X 3 | ) where 4 | 5 | import DBus.Introspection.Types as X 6 | import DBus.Introspection.Parse as X 7 | import DBus.Introspection.Render as X 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | stack.yaml.lock 21 | *.swp 22 | -------------------------------------------------------------------------------- /tests/DBusTests/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module DBusTests.TH where 4 | 5 | import DBus.Generation 6 | import DBusTests.Generation 7 | 8 | generateClient defaultGenerationParams testIntrospectionInterface 9 | generateSignalsFromInterface defaultGenerationParams testIntrospectionInterface 10 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | D-Bus is a simple, message-based protocol for inter-process communication, which 2 | allows applications to interact with other parts of the machine and the user's 3 | session using remote procedure calls. 4 | 5 | D-Bus is a essential part of the modern Linux desktop, where it replaces earlier 6 | protocols such as CORBA and DCOP. 7 | 8 | This library is an implementation of the D-Bus protocol in Haskell. It can be used 9 | to add D-Bus support to Haskell applications, without the awkward interfaces 10 | common to foreign bindings. 11 | -------------------------------------------------------------------------------- /.github/workflows/stackage_nightly.yaml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | name: Stackage nightly (ignore failures) 3 | jobs: 4 | build-stackage-nightly: 5 | name: Build with stackage nightly 6 | runs-on: ubuntu-latest 7 | steps: 8 | - uses: actions/checkout@v4 9 | - uses: haskell-actions/setup@v2 10 | with: 11 | enable-stack: true 12 | - name: stack test 13 | run: 'stack test --resolver nightly --only-dependencies && stack test --resolver nightly --haddock --no-haddock-deps' 14 | continue-on-error: true 15 | -------------------------------------------------------------------------------- /.github/workflows/stackage.yaml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | name: Stackage multi-version build 3 | jobs: 4 | build-stackage: 5 | name: LTS ${{ matrix.lts }} 6 | runs-on: ubuntu-latest 7 | strategy: 8 | matrix: 9 | lts: ['23.25'] 10 | steps: 11 | - uses: actions/checkout@v4 12 | - uses: haskell-actions/setup@v2 13 | with: 14 | enable-stack: true 15 | - name: stack test 16 | run: 'stack test --resolver lts-${{ matrix.lts }} --only-dependencies && stack test --resolver lts-${{ matrix.lts }} --haddock --no-haddock-deps' 17 | -------------------------------------------------------------------------------- /.github/workflows/cabal.yaml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | name: Cabal multi-version build 3 | jobs: 4 | build-ghc: 5 | name: ghc ${{ matrix.ghc }} 6 | runs-on: ubuntu-latest 7 | strategy: 8 | matrix: 9 | ghc: ['9.2', '9.4.8', '9.6.7', '9.8.4', '9.10.2', '9.12.2'] 10 | steps: 11 | - uses: actions/checkout@v4 12 | - uses: haskell-actions/setup@v2 13 | with: 14 | ghc-version: ${{ matrix.ghc }} 15 | - run: cabal configure --enable-tests 16 | - run: cabal build --only-dependencies 17 | - run: cabal build 18 | - run: cabal test 19 | -------------------------------------------------------------------------------- /lib/DBus/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module DBus.TH where 4 | 5 | import DBus.Client 6 | import DBus.Generation 7 | import System.FilePath 8 | 9 | generateSignalsFromInterface defaultGenerationParams $ 10 | buildIntrospectionInterface $ 11 | buildPropertiesInterface undefined 12 | 13 | generateFromFilePath defaultGenerationParams { genBusName = Just dbusName 14 | , genObjectPath = Just dbusPath 15 | } $ "idlxml" "dbus.xml" 16 | -------------------------------------------------------------------------------- /lib/DBus/Introspection/Types.hs: -------------------------------------------------------------------------------- 1 | module DBus.Introspection.Types where 2 | 3 | import qualified DBus as T 4 | 5 | data Object = Object 6 | { objectPath :: T.ObjectPath 7 | , objectInterfaces :: [Interface] 8 | , objectChildren :: [Object] 9 | } 10 | deriving (Show, Eq) 11 | 12 | data Interface = Interface 13 | { interfaceName :: T.InterfaceName 14 | , interfaceMethods :: [Method] 15 | , interfaceSignals :: [Signal] 16 | , interfaceProperties :: [Property] 17 | } 18 | deriving (Show, Eq) 19 | 20 | data Method = Method 21 | { methodName :: T.MemberName 22 | , methodArgs :: [MethodArg] 23 | } 24 | deriving (Show, Eq) 25 | 26 | data MethodArg = MethodArg 27 | { methodArgName :: String 28 | , methodArgType :: T.Type 29 | , methodArgDirection :: Direction 30 | } 31 | deriving (Show, Eq) 32 | 33 | data Direction = In | Out 34 | deriving (Show, Eq) 35 | 36 | data Signal = Signal 37 | { signalName :: T.MemberName 38 | , signalArgs :: [SignalArg] 39 | } 40 | deriving (Show, Eq) 41 | 42 | data SignalArg = SignalArg 43 | { signalArgName :: String 44 | , signalArgType :: T.Type 45 | } 46 | deriving (Show, Eq) 47 | 48 | data Property = Property 49 | { propertyName :: String 50 | , propertyType :: T.Type 51 | , propertyRead :: Bool 52 | , propertyWrite :: Bool 53 | } 54 | deriving (Show, Eq) 55 | -------------------------------------------------------------------------------- /examples/list-names.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- Copyright (C) 2009-2011 John Millikin 4 | -- 5 | -- Licensed under the Apache License, Version 2.0 (the "License"); 6 | -- you may not use this file except in compliance with the License. 7 | -- You may obtain a copy of the License at 8 | -- 9 | -- http://www.apache.org/licenses/LICENSE-2.0 10 | -- 11 | -- Unless required by applicable law or agreed to in writing, software 12 | -- distributed under the License is distributed on an "AS IS" BASIS, 13 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | -- See the License for the specific language governing permissions and 15 | -- limitations under the License. 16 | 17 | module Main (main) where 18 | 19 | import Data.List (sort) 20 | import DBus 21 | import DBus.Client 22 | 23 | main :: IO () 24 | main = do 25 | client <- connectSession 26 | 27 | -- Request a list of connected clients from the bus 28 | reply <- call_ client (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "ListNames") 29 | { methodCallDestination = Just "org.freedesktop.DBus" 30 | } 31 | 32 | -- org.freedesktop.DBus.ListNames returns a single value, which is 33 | -- a list of names (here represented as [String]) 34 | let Just names = fromVariant (methodReturnBody reply !! 0) 35 | 36 | -- Print each name on a line, sorted so reserved names are below 37 | -- temporary names. 38 | mapM_ putStrLn (sort names) 39 | -------------------------------------------------------------------------------- /tests/DBusTests/Generation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module DBusTests.Generation where 4 | 5 | import DBus.Client 6 | import qualified DBus.Internal.Types as T 7 | import qualified DBus.Introspection.Types as I 8 | import Data.Int 9 | import Data.Map as M 10 | 11 | sampleMethod1 :: String -> Int32 -> IO (M.Map String Int32) 12 | sampleMethod1 a b = return $ M.insert a b M.empty 13 | 14 | serviceArg :: I.SignalArg 15 | serviceArg = I.SignalArg { I.signalArgName = "service" 16 | , I.signalArgType = T.TypeString 17 | } 18 | 19 | testSignals :: [I.Signal] 20 | testSignals = [ I.Signal { I.signalName = "StatusNotifierItemRegistered" 21 | , I.signalArgs = [serviceArg] 22 | } 23 | ] 24 | 25 | testInterface :: Interface 26 | testInterface = 27 | defaultInterface { interfaceMethods = 28 | [autoMethod "SampleMethod1" sampleMethod1] 29 | , interfaceProperties = 30 | [autoProperty "SampleWriteProperty" 31 | (Just $ return (1 :: Int32)) 32 | (Just $ const $ return ()) 33 | ] 34 | , interfaceName = "org.TestInterface" 35 | , interfaceSignals = testSignals 36 | } 37 | 38 | testIntrospectionInterface :: I.Interface 39 | testIntrospectionInterface = buildIntrospectionInterface testInterface 40 | -------------------------------------------------------------------------------- /tests/DBusTests/Message.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (C) 2012 John Millikin 2 | -- 3 | -- Licensed under the Apache License, Version 2.0 (the "License"); 4 | -- you may not use this file except in compliance with the License. 5 | -- You may obtain a copy of the License at 6 | -- 7 | -- http://www.apache.org/licenses/LICENSE-2.0 8 | -- 9 | -- Unless required by applicable law or agreed to in writing, software 10 | -- distributed under the License is distributed on an "AS IS" BASIS, 11 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | -- See the License for the specific language governing permissions and 13 | -- limitations under the License. 14 | 15 | module DBusTests.Message (test_Message) where 16 | 17 | import Test.Tasty 18 | import Test.Tasty.HUnit 19 | 20 | import DBus 21 | 22 | test_Message :: TestTree 23 | test_Message = testGroup "Message" 24 | [ test_MethodErrorMessage 25 | ] 26 | 27 | test_MethodErrorMessage :: TestTree 28 | test_MethodErrorMessage = testCase "methodErrorMessage" $ do 29 | let emptyError = methodError firstSerial (errorName_ "com.example.Error") 30 | 31 | "(no error message)" @=? 32 | methodErrorMessage emptyError 33 | { methodErrorBody = [] 34 | } 35 | "(no error message)" @=? 36 | methodErrorMessage emptyError 37 | { methodErrorBody = [toVariant True] 38 | } 39 | "(no error message)" @=? 40 | methodErrorMessage emptyError 41 | { methodErrorBody = [toVariant ""] 42 | } 43 | "error" @=? 44 | methodErrorMessage emptyError 45 | { methodErrorBody = [toVariant "error"] 46 | } 47 | -------------------------------------------------------------------------------- /tests/DBusTests/ObjectPath.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (C) 2010-2012 John Millikin 2 | -- 3 | -- Licensed under the Apache License, Version 2.0 (the "License"); 4 | -- you may not use this file except in compliance with the License. 5 | -- You may obtain a copy of the License at 6 | -- 7 | -- http://www.apache.org/licenses/LICENSE-2.0 8 | -- 9 | -- Unless required by applicable law or agreed to in writing, software 10 | -- distributed under the License is distributed on an "AS IS" BASIS, 11 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | -- See the License for the specific language governing permissions and 13 | -- limitations under the License. 14 | 15 | module DBusTests.ObjectPath (test_ObjectPath) where 16 | 17 | import Data.List (intercalate) 18 | import Test.QuickCheck 19 | import Test.Tasty 20 | import Test.Tasty.HUnit 21 | import Test.Tasty.QuickCheck 22 | 23 | import DBus 24 | 25 | test_ObjectPath :: TestTree 26 | test_ObjectPath = testGroup "ObjectPath" 27 | [ test_Parse 28 | , test_ParseInvalid 29 | ] 30 | 31 | test_Parse :: TestTree 32 | test_Parse = testProperty "parse" prop where 33 | prop = forAll gen_ObjectPath check 34 | check x = case parseObjectPath x of 35 | Nothing -> False 36 | Just parsed -> formatObjectPath parsed == x 37 | 38 | test_ParseInvalid :: TestTree 39 | test_ParseInvalid = testCase "parse-invalid" $ do 40 | -- empty 41 | Nothing @=? parseObjectPath "" 42 | 43 | -- bad char 44 | Nothing @=? parseObjectPath "/f!oo" 45 | 46 | -- ends with a slash 47 | Nothing @=? parseObjectPath "/foo/" 48 | 49 | -- empty element 50 | Nothing @=? parseObjectPath "/foo//bar" 51 | 52 | -- trailing chars 53 | Nothing @=? parseObjectPath "/foo!" 54 | 55 | gen_ObjectPath :: Gen String 56 | gen_ObjectPath = gen where 57 | chars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" 58 | 59 | gen = do 60 | xs <- listOf (listOf1 (elements chars)) 61 | return ("/" ++ intercalate "/" xs) 62 | 63 | instance Arbitrary ObjectPath where 64 | arbitrary = fmap objectPath_ gen_ObjectPath 65 | -------------------------------------------------------------------------------- /examples/property.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- Copyright (C) 2025 Kevin Buhr 4 | -- 5 | -- Licensed under the Apache License, Version 2.0 (the "License"); 6 | -- you may not use this file except in compliance with the License. 7 | -- You may obtain a copy of the License at 8 | -- 9 | -- http://www.apache.org/licenses/LICENSE-2.0 10 | -- 11 | -- Unless required by applicable law or agreed to in writing, software 12 | -- distributed under the License is distributed on an "AS IS" BASIS, 13 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | -- See the License for the specific language governing permissions and 15 | -- limitations under the License. 16 | 17 | module Main (main) where 18 | 19 | import System.Environment 20 | import System.IO 21 | 22 | import DBus 23 | import qualified DBus.Client as DBus 24 | 25 | wirelessPropertyMethod :: MethodCall 26 | wirelessPropertyMethod = 27 | (methodCall "/org/freedesktop/NetworkManager" "org.freedesktop.NetworkManager" "WirelessEnabled") 28 | { methodCallDestination = Just "org.freedesktop.NetworkManager" } 29 | 30 | getWirelessProperty :: IO () 31 | getWirelessProperty = do 32 | client <- DBus.connectSystem 33 | res <- DBus.getPropertyValue client wirelessPropertyMethod 34 | case res of 35 | Left err -> print err 36 | Right True -> putStrLn "Wireless enabled" 37 | Right False -> putStrLn "Wireless disabled" 38 | 39 | setWirelessProperty :: Bool -> IO () 40 | setWirelessProperty b = do 41 | client <- DBus.connectSystem 42 | res <- DBus.setPropertyValue client wirelessPropertyMethod b 43 | case res of 44 | Just err -> print err 45 | Nothing -> getWirelessProperty 46 | 47 | main :: IO () 48 | main = do 49 | args <- getArgs 50 | case args of 51 | ["enable"] -> setWirelessProperty True 52 | ["disable"] -> setWirelessProperty False 53 | ["query"] -> getWirelessProperty 54 | _ -> do 55 | cmd <- getProgName 56 | hPutStrLn stderr $ "syntax: " ++ cmd ++ " [enable|disable|query]" 57 | -------------------------------------------------------------------------------- /tests/DBusTests.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (C) 2012 John Millikin 2 | -- 3 | -- Licensed under the Apache License, Version 2.0 (the "License"); 4 | -- you may not use this file except in compliance with the License. 5 | -- You may obtain a copy of the License at 6 | -- 7 | -- http://www.apache.org/licenses/LICENSE-2.0 8 | -- 9 | -- Unless required by applicable law or agreed to in writing, software 10 | -- distributed under the License is distributed on an "AS IS" BASIS, 11 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | -- See the License for the specific language governing permissions and 13 | -- limitations under the License. 14 | 15 | module Main 16 | ( tests 17 | , main 18 | ) where 19 | 20 | import Test.Tasty 21 | 22 | import DBusTests.Address 23 | import DBusTests.BusName 24 | import DBusTests.Client 25 | import DBusTests.ErrorName 26 | import DBusTests.Integration 27 | import DBusTests.InterfaceName 28 | import DBusTests.Introspection 29 | import DBusTests.MemberName 30 | import DBusTests.Message 31 | import DBusTests.ObjectPath 32 | import DBusTests.Serialization 33 | import DBusTests.Socket 34 | import DBusTests.Signature 35 | import DBusTests.Transport 36 | import DBusTests.Variant 37 | import DBusTests.Wire 38 | 39 | -- import all dbus modules here to ensure they show up in the coverage report, 40 | -- even if not tested. 41 | import DBus () 42 | import DBus.Client () 43 | import DBus.Internal.Address () 44 | import DBus.Internal.Message () 45 | import DBus.Internal.Types () 46 | import DBus.Internal.Wire () 47 | import DBus.Introspection.Parse () 48 | import DBus.Introspection.Render () 49 | import DBus.Introspection.Types () 50 | import DBus.Socket () 51 | 52 | tests :: TestTree 53 | tests = testGroup "dbus" 54 | [ test_Address 55 | , test_BusName 56 | , test_Client 57 | , test_ErrorName 58 | , test_Integration 59 | , test_InterfaceName 60 | , test_Introspection 61 | , test_MemberName 62 | , test_Message 63 | , test_ObjectPath 64 | , test_Serialization 65 | , test_Signature 66 | , test_Socket 67 | , test_Transport 68 | , test_Variant 69 | , test_Wire 70 | ] 71 | 72 | main :: IO () 73 | main = defaultMain tests 74 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-18.18 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | # extra-deps: [] 41 | 42 | # Override default flag values for local packages and extra-deps 43 | # flags: {} 44 | 45 | # Extra package databases containing global packages 46 | # extra-package-dbs: [] 47 | 48 | # Control whether we use the GHC we find on the path 49 | # system-ghc: true 50 | # 51 | # Require a specific version of stack, using version ranges 52 | # require-stack-version: -any # Default 53 | # require-stack-version: ">=1.9" 54 | # 55 | # Override the architecture used by stack, especially useful on Windows 56 | # arch: i386 57 | # arch: x86_64 58 | # 59 | # Extra directories used by stack for building 60 | # extra-include-dirs: [/path/to/dir] 61 | # extra-lib-dirs: [/path/to/dir] 62 | # 63 | # Allow a newer minor version of GHC than the snapshot specifies 64 | # compiler-check: newer-minor 65 | -------------------------------------------------------------------------------- /examples/export.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- Copyright (C) 2009-2011 John Millikin 4 | -- 5 | -- Licensed under the Apache License, Version 2.0 (the "License"); 6 | -- you may not use this file except in compliance with the License. 7 | -- You may obtain a copy of the License at 8 | -- 9 | -- http://www.apache.org/licenses/LICENSE-2.0 10 | -- 11 | -- Unless required by applicable law or agreed to in writing, software 12 | -- distributed under the License is distributed on an "AS IS" BASIS, 13 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | -- See the License for the specific language governing permissions and 15 | -- limitations under the License. 16 | 17 | module Main (main) where 18 | 19 | import Control.Concurrent (threadDelay) 20 | import Control.Monad 21 | import System.Exit 22 | 23 | import DBus.Client 24 | 25 | onFoo :: String -> String -> IO (String, String) 26 | onFoo x y = do 27 | putStrLn ("Foo " ++ show x ++ " " ++ show y) 28 | return (x, y) 29 | 30 | onBar :: String -> String -> IO (String, String) 31 | onBar x y = do 32 | putStrLn ("Bar " ++ show x ++ " " ++ show y) 33 | throwError "com.example.ErrorBar" "Bar failed" [] 34 | 35 | main :: IO () 36 | main = do 37 | -- Connect to the bus 38 | client <- connectSession 39 | 40 | -- Request a unique name on the bus. 41 | requestResult <- requestName client "com.example.exporting" [] 42 | when (requestResult /= NamePrimaryOwner) $ do 43 | putStrLn "Another service owns the \"com.example.exporting\" bus name" 44 | exitFailure 45 | 46 | -- Export two example objects 47 | export client "/a" defaultInterface 48 | { interfaceName = "test.iface_1" 49 | , interfaceMethods = 50 | [ autoMethod "Foo" (onFoo "hello" "a") 51 | , autoMethod "Bar" (onBar "hello" "a") 52 | ] 53 | } 54 | export client "/b" defaultInterface 55 | { interfaceName = "test.iface_2" 56 | , interfaceMethods = 57 | [ autoMethod "Foo" (onFoo "hello") 58 | , autoMethod "Bar" (onBar "hello") 59 | ] 60 | } 61 | 62 | putStrLn "Exported objects /a and /b to bus name com.example.exporting" 63 | 64 | -- Wait forever for method calls 65 | forever (threadDelay 50000) 66 | -------------------------------------------------------------------------------- /tests/DBusTests/MemberName.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (C) 2010-2012 John Millikin 2 | -- 3 | -- Licensed under the Apache License, Version 2.0 (the "License"); 4 | -- you may not use this file except in compliance with the License. 5 | -- You may obtain a copy of the License at 6 | -- 7 | -- http://www.apache.org/licenses/LICENSE-2.0 8 | -- 9 | -- Unless required by applicable law or agreed to in writing, software 10 | -- distributed under the License is distributed on an "AS IS" BASIS, 11 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | -- See the License for the specific language governing permissions and 13 | -- limitations under the License. 14 | 15 | module DBusTests.MemberName (test_MemberName) where 16 | 17 | import Data.Maybe 18 | import Test.QuickCheck 19 | import Test.Tasty 20 | import Test.Tasty.HUnit 21 | import Test.Tasty.QuickCheck 22 | 23 | import DBus 24 | 25 | import DBusTests.Util 26 | 27 | test_MemberName :: TestTree 28 | test_MemberName = testGroup "MemberName" 29 | [ test_Parse 30 | , test_ParseInvalid 31 | , test_IsVariant 32 | ] 33 | 34 | test_Parse :: TestTree 35 | test_Parse = testProperty "parse" prop where 36 | prop = forAll gen_MemberName check 37 | check x = case parseMemberName x of 38 | Nothing -> False 39 | Just parsed -> formatMemberName parsed == x 40 | 41 | test_ParseInvalid :: TestTree 42 | test_ParseInvalid = testCase "parse-invalid" $ do 43 | -- empty 44 | Nothing @=? parseMemberName "" 45 | 46 | -- starts with a digit 47 | Nothing @=? parseMemberName "@foo" 48 | 49 | -- trailing chars 50 | Nothing @=? parseMemberName "foo!" 51 | 52 | -- at most 255 characters 53 | assertBool "valid parse failed" 54 | $ isJust (parseMemberName (replicate 254 'y')) 55 | assertBool "valid parse failed" 56 | $ isJust (parseMemberName (replicate 255 'y')) 57 | Nothing @=? parseMemberName (replicate 256 'y') 58 | 59 | test_IsVariant :: TestTree 60 | test_IsVariant = testCase "IsVariant" $ 61 | assertVariant TypeString (memberName_ "foo") 62 | 63 | gen_MemberName :: Gen String 64 | gen_MemberName = gen where 65 | alpha = ['a'..'z'] ++ ['A'..'Z'] ++ "_" 66 | alphanum = alpha ++ ['0'..'9'] 67 | 68 | gen = do 69 | x <- elements alpha 70 | xs <- listOf (elements alphanum) 71 | return (x:xs) 72 | 73 | instance Arbitrary MemberName where 74 | arbitrary = fmap memberName_ gen_MemberName 75 | -------------------------------------------------------------------------------- /tests/DBusTests/ErrorName.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (C) 2010-2012 John Millikin 2 | -- 3 | -- Licensed under the Apache License, Version 2.0 (the "License"); 4 | -- you may not use this file except in compliance with the License. 5 | -- You may obtain a copy of the License at 6 | -- 7 | -- http://www.apache.org/licenses/LICENSE-2.0 8 | -- 9 | -- Unless required by applicable law or agreed to in writing, software 10 | -- distributed under the License is distributed on an "AS IS" BASIS, 11 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | -- See the License for the specific language governing permissions and 13 | -- limitations under the License. 14 | 15 | module DBusTests.ErrorName (test_ErrorName) where 16 | 17 | import Data.List (intercalate) 18 | import Data.Maybe 19 | import Test.QuickCheck 20 | import Test.Tasty 21 | import Test.Tasty.HUnit 22 | import Test.Tasty.QuickCheck 23 | 24 | import DBus 25 | 26 | import DBusTests.Util 27 | 28 | test_ErrorName :: TestTree 29 | test_ErrorName = testGroup "ErrorName" 30 | [ test_Parse 31 | , test_ParseInvalid 32 | , test_IsVariant 33 | ] 34 | 35 | test_Parse :: TestTree 36 | test_Parse = testProperty "parse" prop where 37 | prop = forAll gen_ErrorName check 38 | check x = case parseErrorName x of 39 | Nothing -> False 40 | Just parsed -> formatErrorName parsed == x 41 | 42 | test_ParseInvalid :: TestTree 43 | test_ParseInvalid = testCase "parse-invalid" $ do 44 | -- empty 45 | Nothing @=? parseErrorName "" 46 | 47 | -- one element 48 | Nothing @=? parseErrorName "foo" 49 | 50 | -- element starting with a digit 51 | Nothing @=? parseErrorName "foo.0bar" 52 | 53 | -- trailing characters 54 | Nothing @=? parseErrorName "foo.bar!" 55 | 56 | -- at most 255 characters 57 | assertBool "valid parse failed" 58 | $ isJust (parseErrorName ("f." ++ replicate 252 'y')) 59 | assertBool "valid parse failed" 60 | $ isJust (parseErrorName ("f." ++ replicate 253 'y')) 61 | Nothing @=? parseErrorName ("f." ++ replicate 254 'y') 62 | 63 | test_IsVariant :: TestTree 64 | test_IsVariant = testCase "IsVariant" $ 65 | assertVariant TypeString (errorName_ "foo.bar") 66 | 67 | gen_ErrorName :: Gen String 68 | gen_ErrorName = trim chunks where 69 | alpha = ['a'..'z'] ++ ['A'..'Z'] ++ "_" 70 | alphanum = alpha ++ ['0'..'9'] 71 | 72 | trim gen = do 73 | x <- gen 74 | if length x > 255 75 | then return (dropWhileEnd (== '.') (take 255 x)) 76 | else return x 77 | 78 | chunks = do 79 | x <- chunk 80 | xs <- listOf1 chunk 81 | return (intercalate "." (x:xs)) 82 | chunk = do 83 | x <- elements alpha 84 | xs <- listOf (elements alphanum) 85 | return (x:xs) 86 | 87 | instance Arbitrary ErrorName where 88 | arbitrary = fmap errorName_ gen_ErrorName 89 | -------------------------------------------------------------------------------- /tests/DBusTests/InterfaceName.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (C) 2010-2012 John Millikin 2 | -- 3 | -- Licensed under the Apache License, Version 2.0 (the "License"); 4 | -- you may not use this file except in compliance with the License. 5 | -- You may obtain a copy of the License at 6 | -- 7 | -- http://www.apache.org/licenses/LICENSE-2.0 8 | -- 9 | -- Unless required by applicable law or agreed to in writing, software 10 | -- distributed under the License is distributed on an "AS IS" BASIS, 11 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | -- See the License for the specific language governing permissions and 13 | -- limitations under the License. 14 | 15 | module DBusTests.InterfaceName (test_InterfaceName) where 16 | 17 | import Data.List (intercalate) 18 | import Data.Maybe 19 | import Test.QuickCheck 20 | import Test.Tasty 21 | import Test.Tasty.HUnit 22 | import Test.Tasty.QuickCheck 23 | 24 | import DBus 25 | 26 | import DBusTests.Util 27 | 28 | test_InterfaceName :: TestTree 29 | test_InterfaceName = testGroup "InterfaceName" 30 | [ test_Parse 31 | , test_ParseInvalid 32 | , test_IsVariant 33 | ] 34 | 35 | test_Parse :: TestTree 36 | test_Parse = testProperty "parse" prop where 37 | prop = forAll gen_InterfaceName check 38 | check x = case parseInterfaceName x of 39 | Nothing -> False 40 | Just parsed -> formatInterfaceName parsed == x 41 | 42 | test_ParseInvalid :: TestTree 43 | test_ParseInvalid = testCase "parse-invalid" $ do 44 | -- empty 45 | Nothing @=? parseInterfaceName "" 46 | 47 | -- one element 48 | Nothing @=? parseInterfaceName "foo" 49 | 50 | -- element starting with a digit 51 | Nothing @=? parseInterfaceName "foo.0bar" 52 | 53 | -- trailing characters 54 | Nothing @=? parseInterfaceName "foo.bar!" 55 | 56 | -- at most 255 characters 57 | assertBool "valid parse failed" 58 | $ isJust (parseInterfaceName ("f." ++ replicate 252 'y')) 59 | assertBool "valid parse failed" 60 | $ isJust (parseInterfaceName ("f." ++ replicate 253 'y')) 61 | Nothing @=? parseInterfaceName ("f." ++ replicate 254 'y') 62 | 63 | test_IsVariant :: TestTree 64 | test_IsVariant = testCase "IsVariant" $ 65 | assertVariant TypeString (interfaceName_ "foo.bar") 66 | 67 | gen_InterfaceName :: Gen String 68 | gen_InterfaceName = trim chunks where 69 | alpha = ['a'..'z'] ++ ['A'..'Z'] ++ "_" 70 | alphanum = alpha ++ ['0'..'9'] 71 | 72 | trim gen = do 73 | x <- gen 74 | if length x > 255 75 | then return (dropWhileEnd (== '.') (take 255 x)) 76 | else return x 77 | 78 | chunks = do 79 | x <- chunk 80 | xs <- listOf1 chunk 81 | return (intercalate "." (x:xs)) 82 | chunk = do 83 | x <- elements alpha 84 | xs <- listOf (elements alphanum) 85 | return (x:xs) 86 | 87 | instance Arbitrary InterfaceName where 88 | arbitrary = fmap interfaceName_ gen_InterfaceName 89 | -------------------------------------------------------------------------------- /tests/DBusTests/BusName.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (C) 2010-2012 John Millikin 2 | -- 3 | -- Licensed under the Apache License, Version 2.0 (the "License"); 4 | -- you may not use this file except in compliance with the License. 5 | -- You may obtain a copy of the License at 6 | -- 7 | -- http://www.apache.org/licenses/LICENSE-2.0 8 | -- 9 | -- Unless required by applicable law or agreed to in writing, software 10 | -- distributed under the License is distributed on an "AS IS" BASIS, 11 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | -- See the License for the specific language governing permissions and 13 | -- limitations under the License. 14 | 15 | module DBusTests.BusName (test_BusName) where 16 | 17 | import Data.List (intercalate) 18 | import Data.Maybe (isJust) 19 | import Test.QuickCheck 20 | import Test.Tasty 21 | import Test.Tasty.HUnit 22 | import Test.Tasty.QuickCheck 23 | 24 | import DBus 25 | import DBusTests.Util 26 | 27 | test_BusName :: TestTree 28 | test_BusName = testGroup "BusName" 29 | [ test_Parse 30 | , test_ParseInvalid 31 | , test_IsVariant 32 | ] 33 | 34 | test_Parse :: TestTree 35 | test_Parse = testProperty "parse" prop where 36 | prop = forAll gen_BusName check 37 | check x = case parseBusName x of 38 | Nothing -> False 39 | Just parsed -> formatBusName parsed == x 40 | 41 | test_ParseInvalid :: TestTree 42 | test_ParseInvalid = testCase "parse-invalid" $ do 43 | -- empty 44 | Nothing @=? parseBusName "" 45 | 46 | -- well-known starting with a digit 47 | Nothing @=? parseBusName "foo.0bar" 48 | 49 | -- well-known with one element 50 | Nothing @=? parseBusName "foo" 51 | 52 | -- unique with one element 53 | Nothing @=? parseBusName ":foo" 54 | 55 | -- trailing characters 56 | Nothing @=? parseBusName "foo.bar!" 57 | 58 | -- at most 255 characters 59 | assertBool "valid parse failed" 60 | $ isJust (parseBusName (":0." ++ replicate 251 'y')) 61 | assertBool "valid parse failed" 62 | $ isJust (parseBusName (":0." ++ replicate 252 'y')) 63 | Nothing @=? parseBusName (":0." ++ replicate 253 'y') 64 | 65 | test_IsVariant :: TestTree 66 | test_IsVariant = testCase "IsVariant" $ 67 | assertVariant TypeString (busName_ "foo.bar") 68 | 69 | gen_BusName :: Gen String 70 | gen_BusName = oneof [unique, wellKnown] where 71 | alpha = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" 72 | alphanum = alpha ++ ['0'..'9'] 73 | 74 | unique = trim $ do 75 | x <- chunks alphanum 76 | return (":" ++ x) 77 | wellKnown = trim (chunks alpha) 78 | 79 | trim gen = do 80 | x <- gen 81 | if length x > 255 82 | then return (dropWhileEnd (== '.') (take 255 x)) 83 | else return x 84 | 85 | chunks start = do 86 | x <- chunk start 87 | xs <- listOf1 (chunk start) 88 | return (intercalate "." (x:xs)) 89 | chunk start = do 90 | x <- elements start 91 | xs <- listOf (elements alphanum) 92 | return (x:xs) 93 | 94 | instance Arbitrary BusName where 95 | arbitrary = fmap busName_ gen_BusName 96 | -------------------------------------------------------------------------------- /idlxml/dbus.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | -------------------------------------------------------------------------------- /tests/DBusTests/Wire.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- Copyright (C) 2012 John Millikin 4 | -- 5 | -- Licensed under the Apache License, Version 2.0 (the "License"); 6 | -- you may not use this file except in compliance with the License. 7 | -- You may obtain a copy of the License at 8 | -- 9 | -- http://www.apache.org/licenses/LICENSE-2.0 10 | -- 11 | -- Unless required by applicable law or agreed to in writing, software 12 | -- distributed under the License is distributed on an "AS IS" BASIS, 13 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | -- See the License for the specific language governing permissions and 15 | -- limitations under the License. 16 | 17 | module DBusTests.Wire (test_Wire) where 18 | 19 | import Data.Bifunctor (first) 20 | import Data.Either 21 | import System.Posix.Types (Fd(..)) 22 | import Test.Tasty 23 | import Test.Tasty.HUnit 24 | 25 | import qualified Data.ByteString.Char8 () 26 | 27 | import DBus 28 | import DBus.Internal.Message 29 | import DBus.Internal.Types 30 | import DBus.Internal.Wire 31 | 32 | import DBusTests.Util 33 | 34 | test_Wire :: TestTree 35 | test_Wire = testGroup "Wire" $ 36 | [ test_Unmarshal 37 | , test_FileDescriptors 38 | ] 39 | 40 | test_Unmarshal :: TestTree 41 | test_Unmarshal = testGroup "unmarshal" 42 | [ test_UnmarshalUnexpectedEof 43 | ] 44 | 45 | test_UnmarshalUnexpectedEof :: TestTree 46 | test_UnmarshalUnexpectedEof = testCase "unexpected-eof" $ do 47 | let unmarshaled = unmarshalWithFds "0" [] 48 | assertBool "invalid unmarshalled parse" (isLeft unmarshaled) 49 | 50 | let Left err = unmarshaled 51 | unmarshalErrorMessage err 52 | @=? "Unexpected end of input while parsing message header." 53 | 54 | test_FileDescriptors :: TestTree 55 | test_FileDescriptors = testGroup "Unix File Descriptor Passing" $ 56 | [ test_FileDescriptors_Marshal 57 | , test_FileDescriptors_UnmarshalHeaderError 58 | ] 59 | 60 | test_FileDescriptors_Marshal :: TestTree 61 | test_FileDescriptors_Marshal = testCaseSteps "(un)marshal round trip" $ \step -> do 62 | let baseMsg = methodCall "/" "org.example.iface" "Foo" 63 | 64 | step "marshal" 65 | let msg = baseMsg { methodCallBody = [toVariant [Fd 2, Fd 1, Fd 2, Fd 3, Fd 1]] } 66 | Right (bytes, fds) = marshalWithFds LittleEndian firstSerial msg 67 | fds @?= [Fd 2, Fd 1, Fd 3] 68 | 69 | step "unmarshal" 70 | let result = receivedMessageBody <$> unmarshalWithFds bytes [Fd 4, Fd 5, Fd 6] 71 | result @?= Right [toVariant [Fd 4, Fd 5, Fd 4, Fd 6, Fd 5]] 72 | 73 | test_FileDescriptors_UnmarshalHeaderError :: TestTree 74 | test_FileDescriptors_UnmarshalHeaderError = testCase "UnixFdHeader mismatch" $ do 75 | let msg = (methodCall "/" "org.example.iface" "Foo") 76 | { methodCallBody = [toVariant [Fd 1, Fd 2, Fd 3]] } 77 | Right (bytes, _fds) = marshalWithFds LittleEndian firstSerial msg 78 | 79 | let result = first unmarshalErrorMessage (unmarshalWithFds bytes [Fd 4, Fd 6]) 80 | result @?= Left ("File descriptor count in message header (3)" 81 | <> " does not match the number of file descriptors received from the socket (2).") 82 | -------------------------------------------------------------------------------- /benchmarks/DBusBenchmarks.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- Copyright (C) 2010-2011 John Millikin 4 | -- 5 | -- Licensed under the Apache License, Version 2.0 (the "License"); 6 | -- you may not use this file except in compliance with the License. 7 | -- You may obtain a copy of the License at 8 | -- 9 | -- http://www.apache.org/licenses/LICENSE-2.0 10 | -- 11 | -- Unless required by applicable law or agreed to in writing, software 12 | -- distributed under the License is distributed on an "AS IS" BASIS, 13 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | -- See the License for the specific language governing permissions and 15 | -- limitations under the License. 16 | 17 | module Main (benchmarks, main) where 18 | 19 | import Criterion.Types 20 | import Data.Word (Word32) 21 | import Unsafe.Coerce (unsafeCoerce) 22 | import qualified Criterion.Main 23 | 24 | import DBus 25 | 26 | serial :: Word32 -> Serial 27 | serial = unsafeCoerce -- FIXME: should the Serial constructor be exposed to 28 | -- clients? 29 | 30 | empty_MethodCall :: MethodCall 31 | empty_MethodCall = methodCall "/" "org.i" "m" 32 | 33 | empty_MethodReturn :: MethodReturn 34 | empty_MethodReturn = methodReturn (serial 0) 35 | 36 | benchMarshal :: Message msg => String -> msg -> Benchmark 37 | benchMarshal name msg = bench name (whnf (marshalWithFds LittleEndian (serial 0)) msg) 38 | 39 | benchUnmarshal :: Message msg => String -> msg -> Benchmark 40 | benchUnmarshal name msg = bench name (whnf (uncurry unmarshalWithFds) (bytes, fds)) where 41 | Right (bytes, fds) = marshalWithFds LittleEndian (serial 0) msg 42 | 43 | parseSig :: String -> Maybe Signature 44 | parseSig = parseSignature 45 | 46 | benchmarks :: [Benchmark] 47 | benchmarks = 48 | [ bgroup "Types" 49 | [ bgroup "Signature" 50 | [ bench "parseSignature/small" (nf parseSig "y") 51 | , bench "parseSignature/medium" (nf parseSig "yyyyuua(yv)") 52 | , bench "parseSignature/large" (nf parseSig "a{s(asiiiiasa(siiia{s(iiiiv)}))}") 53 | ] 54 | , bgroup "ObjectPath" 55 | [ bench "objectPath_/small" (nf objectPath_ "/") 56 | , bench "objectPath_/medium" (nf objectPath_ "/foo/bar") 57 | , bench "objectPath_/large" (nf objectPath_ "/f0OO/b4R/baz_qux/blahblahblah") 58 | ] 59 | , bgroup "InterfaceName" 60 | [ bench "interfaceName_/small" (nf interfaceName_ "f.b") 61 | , bench "interfaceName_/medium" (nf interfaceName_ "foo.bar.baz") 62 | , bench "interfaceName_/large" (nf interfaceName_ "f0OOO.b4R.baz_qux.blahblahblah") 63 | ] 64 | , bgroup "MemberName" 65 | [ bench "memberName_/small" (nf memberName_ "f") 66 | , bench "memberName_/medium" (nf memberName_ "FooBar") 67 | , bench "memberName_/large" (nf memberName_ "f0OOOb4RBazQuxBlahBlahBlah") 68 | ] 69 | , bgroup "ErrorName" 70 | [ bench "errorName_/small" (nf errorName_ "f.b") 71 | , bench "errorName_/medium" (nf errorName_ "foo.bar.baz") 72 | , bench "errorName_/large" (nf errorName_ "f0OOO.b4R.baz_qux.blahblahblah") 73 | ] 74 | , bgroup "BusName" 75 | [ bench "busName_/small" (nf busName_ "f.b") 76 | , bench "busName_/medium" (nf busName_ "foo.bar.baz") 77 | , bench "busName_/large" (nf busName_ "f0OOO.b4R.baz-qux.blahblahblah") 78 | ] 79 | ] 80 | , bgroup "Marshal" 81 | [ benchMarshal "MethodCall/empty" empty_MethodCall 82 | , benchMarshal "MethodReturn/empty" empty_MethodReturn 83 | ] 84 | , bgroup "Unmarshal" 85 | [ benchUnmarshal "MethodCall/empty" empty_MethodCall 86 | , benchUnmarshal "MethodReturn/empty" empty_MethodReturn 87 | ] 88 | ] 89 | 90 | main :: IO () 91 | main = Criterion.Main.defaultMain benchmarks 92 | -------------------------------------------------------------------------------- /examples/introspect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- Copyright (C) 2009-2011 John Millikin 4 | -- 5 | -- Licensed under the Apache License, Version 2.0 (the "License"); 6 | -- you may not use this file except in compliance with the License. 7 | -- You may obtain a copy of the License at 8 | -- 9 | -- http://www.apache.org/licenses/LICENSE-2.0 10 | -- 11 | -- Unless required by applicable law or agreed to in writing, software 12 | -- distributed under the License is distributed on an "AS IS" BASIS, 13 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | -- See the License for the specific language governing permissions and 15 | -- limitations under the License. 16 | 17 | module Main (main) where 18 | 19 | import Control.Monad (when) 20 | import Data.String (fromString) 21 | import System.Environment (getArgs, getProgName) 22 | import System.Exit (exitFailure) 23 | import System.IO (hPutStrLn, stderr) 24 | 25 | import DBus 26 | import DBus.Client 27 | import qualified DBus.Introspection as I 28 | 29 | main :: IO () 30 | main = do 31 | args <- getArgs 32 | (service, path) <- case args of 33 | a1:a2:_ -> return (fromString a1, fromString a2) 34 | _ -> do 35 | name <- getProgName 36 | hPutStrLn stderr ("Usage: " ++ name ++ " ") 37 | exitFailure 38 | client <- connectSession 39 | printObj (introspect client service) path 40 | 41 | introspect :: Client -> BusName -> ObjectPath -> IO I.Object 42 | introspect client service path = do 43 | reply <- call_ client (methodCall path "org.freedesktop.DBus.Introspectable" "Introspect") 44 | { methodCallDestination = Just service 45 | } 46 | let Just xml = fromVariant (methodReturnBody reply !! 0) 47 | case I.parseXML path xml of 48 | Just info -> return info 49 | Nothing -> error ("Invalid introspection XML: " ++ show xml) 50 | 51 | -- most of this stuff is just boring text formatting 52 | 53 | printObj :: (ObjectPath -> IO I.Object) -> ObjectPath -> IO () 54 | printObj get path = do 55 | obj <- get path 56 | putStrLn (formatObjectPath path) 57 | mapM_ printIface (I.objectInterfaces obj) 58 | putStrLn "" 59 | mapM_ (printObj get) [I.objectPath x | x <- I.objectChildren obj] 60 | 61 | printIface :: I.Interface -> IO () 62 | printIface iface = do 63 | putStr " " 64 | putStrLn (formatInterfaceName (I.interfaceName iface)) 65 | 66 | mapM_ printMethod (I.interfaceMethods iface) 67 | mapM_ printSignal (I.interfaceSignals iface) 68 | mapM_ printProperty (I.interfaceProperties iface) 69 | putStrLn "" 70 | 71 | printMethod :: I.Method -> IO () 72 | printMethod method = do 73 | putStr " method " 74 | putStrLn (formatMemberName (I.methodName method)) 75 | mapM_ printMethodArg (I.methodArgs method) 76 | 77 | printMethodArg :: I.MethodArg -> IO () 78 | printMethodArg arg = do 79 | let dir = 80 | case I.methodArgDirection arg of 81 | I.In -> "IN " 82 | I.Out -> "OUT" 83 | putStr (" [" ++ dir ++ " ") 84 | putStr (show (formatSignature (signature_ [I.methodArgType arg])) ++ "] ") 85 | putStrLn (I.methodArgName arg) 86 | 87 | printSignal :: I.Signal -> IO () 88 | printSignal sig = do 89 | putStr " signal " 90 | putStrLn (formatMemberName (I.signalName sig)) 91 | mapM_ printSignalArg (I.signalArgs sig) 92 | 93 | printSignalArg :: I.SignalArg -> IO () 94 | printSignalArg arg = do 95 | putStr " [" 96 | putStr (show (formatSignature (signature_ [I.signalArgType arg])) ++ "] ") 97 | putStrLn (I.signalArgName arg) 98 | 99 | printProperty :: I.Property -> IO () 100 | printProperty prop = do 101 | putStr " property " 102 | putStr (show (formatSignature (signature_ [I.propertyType prop])) ++ " ") 103 | putStrLn (I.propertyName prop) 104 | 105 | putStr " " 106 | when (I.propertyRead prop) (putStr "Read") 107 | when (I.propertyWrite prop) (putStr "Write") 108 | putStrLn "" 109 | -------------------------------------------------------------------------------- /lib/DBus/Introspection/Render.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | module DBus.Introspection.Render 9 | ( formatXML 10 | ) where 11 | 12 | import Conduit 13 | import Control.Monad.ST 14 | import Control.Monad.Trans.Maybe 15 | import Data.List (isPrefixOf) 16 | import Data.XML.Types (Event) 17 | import qualified Data.Text as T 18 | import qualified Data.Text.Lazy as TL 19 | import qualified Text.XML.Stream.Render as R 20 | 21 | import DBus.Internal.Types 22 | import DBus.Introspection.Types 23 | 24 | newtype Render s a = Render { runRender :: MaybeT (ST s) a } 25 | 26 | deriving instance Functor (Render s) 27 | deriving instance Applicative (Render s) 28 | deriving instance Monad (Render s) 29 | 30 | instance MonadThrow (Render s) where 31 | throwM _ = Render $ MaybeT $ pure Nothing 32 | 33 | instance PrimMonad (Render s) where 34 | type PrimState (Render s) = s 35 | primitive f = Render $ lift $ primitive f 36 | 37 | formatXML :: Object -> Maybe String 38 | formatXML obj = do 39 | xml <- runST $ runMaybeT $ runRender $ runConduit $ 40 | renderRoot obj .| R.renderText R.def .| sinkLazy 41 | pure $ TL.unpack xml 42 | 43 | renderRoot :: MonadThrow m => Object -> ConduitT i Event m () 44 | renderRoot obj = renderObject (formatObjectPath $ objectPath obj) obj 45 | 46 | renderObject :: MonadThrow m => String -> Object -> ConduitT i Event m () 47 | renderObject path Object{..} = R.tag "node" 48 | (R.attr "name" (T.pack path)) $ do 49 | mapM_ renderInterface objectInterfaces 50 | mapM_ (renderChild objectPath) objectChildren 51 | 52 | renderChild :: MonadThrow m => ObjectPath -> Object -> ConduitT i Event m () 53 | renderChild parentPath obj 54 | | not (parent' `isPrefixOf` path') = 55 | throwM $ userError "invalid child path" 56 | | parent' == "/" = renderObject (drop 1 path') obj 57 | | otherwise = renderObject (drop (length parent' + 1) path') obj 58 | where 59 | path' = formatObjectPath (objectPath obj) 60 | parent' = formatObjectPath parentPath 61 | 62 | renderInterface :: MonadThrow m => Interface -> ConduitT i Event m () 63 | renderInterface Interface{..} = R.tag "interface" 64 | (R.attr "name" $ T.pack $ formatInterfaceName interfaceName) $ do 65 | mapM_ renderMethod interfaceMethods 66 | mapM_ renderSignal interfaceSignals 67 | mapM_ renderProperty interfaceProperties 68 | 69 | renderMethod :: MonadThrow m => Method -> ConduitT i Event m () 70 | renderMethod Method{..} = R.tag "method" 71 | (R.attr "name" $ T.pack $ formatMemberName methodName) $ 72 | mapM_ renderMethodArg methodArgs 73 | 74 | renderMethodArg :: MonadThrow m => MethodArg -> ConduitT i Event m () 75 | renderMethodArg MethodArg{..} = do 76 | typeStr <- formatType methodArgType 77 | let typeAttr = R.attr "type" $ T.pack typeStr 78 | nameAttr = R.attr "name" $ T.pack methodArgName 79 | dirAttr = R.attr "direction" $ case methodArgDirection of 80 | In -> "in" 81 | Out -> "out" 82 | R.tag "arg" (nameAttr <> typeAttr <> dirAttr) $ pure () 83 | 84 | renderSignal :: MonadThrow m => Signal -> ConduitT i Event m () 85 | renderSignal Signal{..} = R.tag "signal" 86 | (R.attr "name" $ T.pack $ formatMemberName signalName) $ 87 | mapM_ renderSignalArg signalArgs 88 | 89 | renderSignalArg :: MonadThrow m => SignalArg -> ConduitT i Event m () 90 | renderSignalArg SignalArg{..} = do 91 | typeStr <- formatType signalArgType 92 | let typeAttr = R.attr "type" $ T.pack typeStr 93 | nameAttr = R.attr "name" $ T.pack signalArgName 94 | R.tag "arg" (nameAttr <> typeAttr) $ pure () 95 | 96 | renderProperty :: MonadThrow m => Property -> ConduitT i Event m () 97 | renderProperty Property{..} = do 98 | typeStr <- formatType propertyType 99 | let readStr = if propertyRead then "read" else "" 100 | writeStr = if propertyWrite then "write" else "" 101 | typeAttr = R.attr "type" $ T.pack typeStr 102 | nameAttr = R.attr "name" $ T.pack propertyName 103 | accessAttr = R.attr "access" $ T.pack (readStr ++ writeStr) 104 | R.tag "property" (nameAttr <> typeAttr <> accessAttr) $ pure () 105 | 106 | formatType :: MonadThrow f => Type -> f String 107 | formatType t = formatSignature <$> signature [t] 108 | -------------------------------------------------------------------------------- /dbus.cabal: -------------------------------------------------------------------------------- 1 | name: dbus 2 | version: 1.4.1 3 | license: Apache-2.0 4 | license-file: license.txt 5 | author: John Millikin 6 | maintainer: Andrey Sverdlichenko 7 | build-type: Simple 8 | cabal-version: >= 1.10 9 | category: Network, Desktop 10 | stability: experimental 11 | homepage: https://github.com/rblaze/haskell-dbus#readme 12 | 13 | synopsis: A client library for the D-Bus IPC system. 14 | description: 15 | D-Bus is a simple, message-based protocol for inter-process 16 | communication, which allows applications to interact with other parts of 17 | the machine and the user's session using remote procedure calls. 18 | . 19 | D-Bus is a essential part of the modern Linux desktop, where it replaces 20 | earlier protocols such as CORBA and DCOP. 21 | . 22 | This library is an implementation of the D-Bus protocol in Haskell. It 23 | can be used to add D-Bus support to Haskell applications, without the 24 | awkward interfaces common to foreign bindings. 25 | . 26 | Example: connect to the session bus, and get a list of active names. 27 | . 28 | @ 29 | {-\# LANGUAGE OverloadedStrings \#-} 30 | . 31 | import Data.List (sort) 32 | import DBus 33 | import DBus.Client 34 | . 35 | main = do 36 | client <- connectSession 37 | 38 | -- Request a list of connected clients from the bus 39 | reply <- call_ client (methodCall \"\/org\/freedesktop\/DBus\" \"org.freedesktop.DBus\" \"ListNames\") 40 | { methodCallDestination = Just \"org.freedesktop.DBus\" 41 | } 42 | 43 | -- org.freedesktop.DBus.ListNames() returns a single value, which is 44 | -- a list of names (here represented as [String]) 45 | let Just names = fromVariant (methodReturnBody reply !! 0) 46 | 47 | -- Print each name on a line, sorted so reserved names are below 48 | -- temporary names. 49 | mapM_ putStrLn (sort names) 50 | @ 51 | . 52 | >$ ghc --make list-names.hs 53 | >$ ./list-names 54 | >:1.0 55 | >:1.1 56 | >:1.10 57 | >:1.106 58 | >:1.109 59 | >:1.110 60 | >ca.desrt.dconf 61 | >org.freedesktop.DBus 62 | >org.freedesktop.Notifications 63 | >org.freedesktop.secrets 64 | >org.gnome.ScreenSaver 65 | 66 | 67 | extra-source-files: 68 | examples/dbus-monitor.hs 69 | examples/export.hs 70 | examples/introspect.hs 71 | examples/list-names.hs 72 | idlxml/dbus.xml 73 | 74 | source-repository head 75 | type: git 76 | location: https://github.com/rblaze/haskell-dbus 77 | 78 | library 79 | default-language: Haskell2010 80 | ghc-options: -W -Wall 81 | hs-source-dirs: lib 82 | 83 | build-depends: 84 | base >=4.16 && <5 85 | , bytestring < 0.13 86 | , cereal < 0.6 87 | , conduit >= 1.3.0 && < 1.4 88 | , containers < 0.8 89 | , deepseq < 1.6 90 | , exceptions < 0.11 91 | , filepath < 1.6 92 | , lens < 5.4 93 | , network >= 3.2 && < 3.3 94 | , parsec < 3.2 95 | , random < 1.4 96 | , split < 0.3 97 | , template-haskell >= 2.18 && < 2.24 98 | , text < 2.2 99 | , th-lift < 0.9 100 | , transformers < 0.7 101 | , unix < 2.9 102 | , vector < 0.14 103 | , xml-conduit >= 1.9.0.0 && < 1.11.0.0 104 | , xml-types < 0.4 105 | 106 | exposed-modules: 107 | DBus 108 | DBus.Client 109 | DBus.Generation 110 | DBus.Internal.Address 111 | DBus.Internal.Message 112 | DBus.Internal.Types 113 | DBus.Internal.Wire 114 | DBus.Introspection 115 | DBus.Introspection.Parse 116 | DBus.Introspection.Render 117 | DBus.Introspection.Types 118 | DBus.Socket 119 | DBus.TH 120 | DBus.Transport 121 | 122 | test-suite dbus_tests 123 | type: exitcode-stdio-1.0 124 | main-is: DBusTests.hs 125 | hs-source-dirs: tests 126 | default-language: Haskell2010 127 | ghc-options: -W -Wall -fno-warn-orphans 128 | 129 | build-depends: 130 | dbus 131 | , base >=4 && <5 132 | , bytestring < 0.13 133 | , cereal < 0.6 134 | , containers < 0.8 135 | , directory < 1.4 136 | , extra < 1.9 137 | , filepath < 1.6 138 | , network >= 3.2 && < 3.3 139 | , parsec < 3.2 140 | , process < 1.7 141 | , QuickCheck < 2.17 142 | , random < 1.4 143 | , resourcet < 1.4 144 | , tasty < 1.6 145 | , tasty-hunit < 0.11 146 | , tasty-quickcheck < 0.12 147 | , temporary >= 1.3 && < 1.4 148 | , text < 2.2 149 | , transformers < 0.7 150 | , unix < 2.9 151 | , vector < 0.14 152 | 153 | other-modules: 154 | DBusTests.Address 155 | DBusTests.BusName 156 | DBusTests.Client 157 | DBusTests.ErrorName 158 | DBusTests.Generation 159 | DBusTests.Integration 160 | DBusTests.InterfaceName 161 | DBusTests.Introspection 162 | DBusTests.MemberName 163 | DBusTests.Message 164 | DBusTests.ObjectPath 165 | DBusTests.Serialization 166 | DBusTests.Signature 167 | DBusTests.Socket 168 | DBusTests.TH 169 | DBusTests.Transport 170 | DBusTests.Util 171 | DBusTests.Variant 172 | DBusTests.Wire 173 | -------------------------------------------------------------------------------- /tests/DBusTests/Integration.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- Copyright (C) 2012 John Millikin 4 | -- 5 | -- Licensed under the Apache License, Version 2.0 (the "License"); 6 | -- you may not use this file except in compliance with the License. 7 | -- You may obtain a copy of the License at 8 | -- 9 | -- http://www.apache.org/licenses/LICENSE-2.0 10 | -- 11 | -- Unless required by applicable law or agreed to in writing, software 12 | -- distributed under the License is distributed on an "AS IS" BASIS, 13 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | -- See the License for the specific language governing permissions and 15 | -- limitations under the License. 16 | 17 | module DBusTests.Integration (test_Integration) where 18 | 19 | import Control.Exception (finally) 20 | import System.Directory (removeFile) 21 | import System.Exit 22 | import System.IO (hGetLine) 23 | import System.Process 24 | import Test.Tasty 25 | import Test.Tasty.HUnit 26 | 27 | import DBus 28 | import DBus.Socket 29 | import DBus.Client 30 | import DBusTests.Util 31 | 32 | test_Integration :: TestTree 33 | test_Integration = testGroup "Integration" 34 | [ test_Socket 35 | , test_Client 36 | ] 37 | 38 | test_Socket :: TestTree 39 | test_Socket = withDaemon "socket" $ \addr -> do 40 | let hello = (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "Hello") 41 | { methodCallDestination = Just "org.freedesktop.DBus" 42 | } 43 | 44 | sock <- open addr 45 | serial <- send sock hello return 46 | assertBool "invalid serial" $ serialValue serial >= 1 47 | 48 | received <- receive sock 49 | let ReceivedMethodReturn _ ret = received 50 | methodReturnSerial ret @?= serial 51 | methodReturnSender ret @?= Just "org.freedesktop.DBus" 52 | 53 | close sock 54 | 55 | test_Client :: TestTree 56 | test_Client = withDaemon "client" $ \addr -> do 57 | clientA <- connect addr 58 | clientB <- connect addr 59 | 60 | export clientA "/" 61 | defaultInterface 62 | { interfaceName = "com.example.Echo" 63 | , interfaceMethods = 64 | [ Method "Echo" (signature_ [TypeString]) (signature_ []) ( 65 | \msg -> if map variantType (methodCallBody msg) == [TypeString] 66 | then return (ReplyReturn (methodCallBody msg)) 67 | else 68 | return $ ReplyError 69 | "com.example.Error" 70 | [toVariant ("bad body: " ++ show (methodCallBody msg))]) 71 | ] 72 | } 73 | 74 | -- TODO: get bus address of clientA with a function 75 | let busAddrA = ":1.0" 76 | 77 | -- Successful call 78 | let bodyGood = [toVariant ("test" :: String)] 79 | retGood <- call clientB (methodCall "/" "com.example.Echo" "Echo") 80 | { methodCallDestination = Just busAddrA 81 | , methodCallBody = bodyGood 82 | } 83 | ret <- requireRight retGood 84 | methodReturnBody ret @?= bodyGood 85 | 86 | -- Failed call 87 | let bodyBad = [toVariant True] 88 | retBad <- call clientB (methodCall "/" "com.example.Echo" "Echo") 89 | { methodCallDestination = Just busAddrA 90 | , methodCallBody = bodyBad 91 | } 92 | err <- requireLeft retBad 93 | methodErrorName err @?= "com.example.Error" 94 | methodErrorBody err @?= [toVariant ("bad body: [Variant True]" :: String)] 95 | 96 | disconnect clientA 97 | disconnect clientB 98 | 99 | configFileContent :: String 100 | configFileContent = "\ 101 | \\ 103 | \\ 104 | \ session\ 105 | \ \ 106 | \ unix:tmpdir=/tmp\ 107 | \ \ 108 | \ \ 109 | \ \ 110 | \ \ 111 | \ \ 112 | \ \ 113 | \ \ 114 | \ \ 115 | \" 116 | 117 | withDaemon :: String -> (Address -> Assertion) -> TestTree 118 | withDaemon name io = testCase name $ do 119 | (versionExit, _, _) <- readProcessWithExitCode "dbus-daemon" ["--version"] "" 120 | case versionExit of 121 | ExitFailure _ -> assertFailure $ "dbus-daemon failed: " ++ show versionExit 122 | ExitSuccess -> do 123 | configFilePath <- getTempPath 124 | writeFile configFilePath configFileContent 125 | daemon <- createProcess (proc "dbus-daemon" ["--config-file=" ++ configFilePath, "--print-address"]) 126 | { std_out = CreatePipe 127 | , close_fds = True 128 | } 129 | let (_, Just daemonStdout, _, daemonProc) = daemon 130 | finally 131 | (do 132 | addrString <- hGetLine daemonStdout 133 | case parseAddress addrString of 134 | Nothing -> assertFailure $ "dbus-daemon returned invalid address: " ++ show addrString 135 | Just addr -> io addr) 136 | (do 137 | terminateProcess daemonProc 138 | _ <- waitForProcess daemonProc 139 | removeFile configFilePath 140 | return ()) 141 | -------------------------------------------------------------------------------- /lib/DBus/Introspection/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module DBus.Introspection.Parse 4 | ( parseXML 5 | ) where 6 | 7 | import Conduit 8 | import Data.Maybe 9 | import Data.XML.Types 10 | import qualified Data.Text as T 11 | import qualified Text.XML.Stream.Parse as X 12 | 13 | import DBus.Internal.Types 14 | import DBus.Introspection.Types 15 | 16 | data ObjectChildren 17 | = InterfaceDefinition Interface 18 | | SubNode Object 19 | 20 | data InterfaceChildren 21 | = MethodDefinition Method 22 | | SignalDefinition Signal 23 | | PropertyDefinition Property 24 | 25 | parseXML :: ObjectPath -> T.Text -> Maybe Object 26 | parseXML path xml = 27 | runConduit $ yieldMany [xml] .| X.parseText X.def .| X.force "parse error" (parseObject $ getRootName path) 28 | 29 | getRootName :: ObjectPath -> X.AttrParser ObjectPath 30 | getRootName defaultPath = do 31 | nodeName <- X.attr "name" 32 | pure $ maybe defaultPath (objectPath_ . T.unpack) nodeName 33 | 34 | getChildName :: ObjectPath -> X.AttrParser ObjectPath 35 | getChildName parentPath = do 36 | nodeName <- X.requireAttr "name" 37 | let parentPath' = case formatObjectPath parentPath of 38 | "/" -> "/" 39 | x -> x ++ "/" 40 | pure $ objectPath_ (parentPath' ++ T.unpack nodeName) 41 | 42 | parseObject 43 | :: X.AttrParser ObjectPath 44 | -> ConduitT Event o Maybe (Maybe Object) 45 | parseObject getPath = X.tag' "node" getPath parseContent 46 | where 47 | parseContent objPath = do 48 | elems <- X.many $ X.choose 49 | [ fmap SubNode <$> parseObject (getChildName objPath) 50 | , fmap InterfaceDefinition <$> parseInterface 51 | ] 52 | let base = Object objPath [] [] 53 | addElem e (Object p is cs) = case e of 54 | InterfaceDefinition i -> Object p (i:is) cs 55 | SubNode c -> Object p is (c:cs) 56 | pure $ foldr addElem base elems 57 | 58 | parseInterface 59 | :: ConduitT Event o Maybe (Maybe Interface) 60 | parseInterface = X.tag' "interface" getName parseContent 61 | where 62 | getName = do 63 | ifName <- X.requireAttr "name" 64 | pure $ interfaceName_ (T.unpack ifName) 65 | parseContent ifName = do 66 | elems <- X.many $ do 67 | X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs 68 | X.choose 69 | [ parseMethod 70 | , parseSignal 71 | , parseProperty 72 | ] 73 | X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs 74 | let base = Interface ifName [] [] [] 75 | addElem e (Interface n ms ss ps) = case e of 76 | MethodDefinition m -> Interface n (m:ms) ss ps 77 | SignalDefinition s -> Interface n ms (s:ss) ps 78 | PropertyDefinition p -> Interface n ms ss (p:ps) 79 | pure $ foldr addElem base elems 80 | 81 | parseMethod :: ConduitT Event o Maybe (Maybe InterfaceChildren) 82 | parseMethod = X.tag' "method" getName parseArgs 83 | where 84 | getName = do 85 | ifName <- X.requireAttr "name" 86 | parseMemberName (T.unpack ifName) 87 | parseArgs name = do 88 | args <- X.many $ do 89 | X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs 90 | X.tag' "arg" getArg pure 91 | X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs 92 | pure $ MethodDefinition $ Method name args 93 | getArg = do 94 | name <- fromMaybe "" <$> X.attr "name" 95 | typeStr <- X.requireAttr "type" 96 | dirStr <- fromMaybe "in" <$> X.attr "direction" 97 | X.ignoreAttrs 98 | typ <- parseType typeStr 99 | let dir = if dirStr == "in" then In else Out 100 | pure $ MethodArg (T.unpack name) typ dir 101 | 102 | parseSignal :: ConduitT Event o Maybe (Maybe InterfaceChildren) 103 | parseSignal = X.tag' "signal" getName parseArgs 104 | where 105 | getName = do 106 | ifName <- X.requireAttr "name" 107 | parseMemberName (T.unpack ifName) 108 | parseArgs name = do 109 | args <- X.many $ do 110 | X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs 111 | X.tag' "arg" getArg pure 112 | X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs 113 | pure $ SignalDefinition $ Signal name args 114 | getArg = do 115 | name <- fromMaybe "" <$> X.attr "name" 116 | typeStr <- X.requireAttr "type" 117 | X.ignoreAttrs 118 | typ <- parseType typeStr 119 | pure $ SignalArg (T.unpack name) typ 120 | 121 | parseProperty :: ConduitT Event o Maybe (Maybe InterfaceChildren) 122 | parseProperty = X.tag' "property" getProp $ \p -> do 123 | X.many_ X.ignoreAnyTreeContent 124 | pure p 125 | where 126 | getProp = do 127 | name <- T.unpack <$> X.requireAttr "name" 128 | typeStr <- X.requireAttr "type" 129 | accessStr <- fromMaybe "" <$> X.attr "access" 130 | X.ignoreAttrs 131 | typ <- parseType typeStr 132 | (canRead, canWrite) <- case accessStr of 133 | "" -> pure (False, False) 134 | "read" -> pure (True, False) 135 | "write" -> pure (False, True) 136 | "readwrite" -> pure (True, True) 137 | _ -> throwM $ userError "invalid access value" 138 | 139 | pure $ PropertyDefinition $ Property name typ canRead canWrite 140 | 141 | parseType :: MonadThrow m => T.Text -> m Type 142 | parseType typeStr = do 143 | typ <- parseSignature (T.unpack typeStr) 144 | case signatureTypes typ of 145 | [t] -> pure t 146 | _ -> throwM $ userError "invalid type sig" 147 | -------------------------------------------------------------------------------- /tests/DBusTests/Signature.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (C) 2010-2012 John Millikin 2 | -- 3 | -- Licensed under the Apache License, Version 2.0 (the "License"); 4 | -- you may not use this file except in compliance with the License. 5 | -- You may obtain a copy of the License at 6 | -- 7 | -- http://www.apache.org/licenses/LICENSE-2.0 8 | -- 9 | -- Unless required by applicable law or agreed to in writing, software 10 | -- distributed under the License is distributed on an "AS IS" BASIS, 11 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | -- See the License for the specific language governing permissions and 13 | -- limitations under the License. 14 | 15 | module DBusTests.Signature (test_Signature) where 16 | 17 | import Data.Maybe 18 | import Test.QuickCheck 19 | import Test.Tasty 20 | import Test.Tasty.HUnit 21 | import Test.Tasty.QuickCheck 22 | 23 | import DBus 24 | 25 | import DBusTests.Util 26 | 27 | test_Signature :: TestTree 28 | test_Signature = testGroup "Signature" 29 | [ test_BuildSignature 30 | , test_ParseSignature 31 | , test_ParseInvalid 32 | , test_FormatSignature 33 | , test_IsAtom 34 | , test_ShowType 35 | ] 36 | 37 | test_BuildSignature :: TestTree 38 | test_BuildSignature = testProperty "signature" prop where 39 | prop = forAll gen_SignatureTypes check 40 | check types = case signature types of 41 | Nothing -> False 42 | Just sig -> signatureTypes sig == types 43 | 44 | test_ParseSignature :: TestTree 45 | test_ParseSignature = testProperty "parseSignature" prop where 46 | prop = forAll gen_SignatureString check 47 | check (s, types) = case parseSignature s of 48 | Nothing -> False 49 | Just sig -> signatureTypes sig == types 50 | 51 | test_ParseInvalid :: TestTree 52 | test_ParseInvalid = testCase "parse-invalid" $ do 53 | -- at most 255 characters 54 | assertBool "valid parse failed" $ 55 | isJust (parseSignature (replicate 254 'y')) 56 | assertBool "valid parse failed" $ 57 | isJust (parseSignature (replicate 255 'y')) 58 | Nothing @=? parseSignature (replicate 256 'y') 59 | 60 | -- length also enforced by 'signature' 61 | assertBool "valid parse failed" $ 62 | isJust (signature (replicate 255 TypeWord8)) 63 | Nothing @=? signature (replicate 256 TypeWord8) 64 | 65 | -- struct code 66 | Nothing @=? parseSignature "r" 67 | 68 | -- empty struct 69 | Nothing @=? parseSignature "()" 70 | Nothing @=? signature [TypeStructure []] 71 | 72 | -- dict code 73 | Nothing @=? parseSignature "e" 74 | 75 | -- non-atomic dict key 76 | Nothing @=? parseSignature "a{vy}" 77 | Nothing @=? signature [TypeDictionary TypeVariant TypeVariant] 78 | 79 | test_FormatSignature :: TestTree 80 | test_FormatSignature = testProperty "formatSignature" prop where 81 | prop = forAll gen_SignatureString check 82 | check (s, _) = let 83 | Just sig = parseSignature s 84 | in formatSignature sig == s 85 | 86 | test_IsAtom :: TestTree 87 | test_IsAtom = testCase "IsAtom" $ do 88 | let Just sig = signature [] 89 | assertAtom TypeSignature sig 90 | 91 | test_ShowType :: TestTree 92 | test_ShowType = testCase "show-type" $ do 93 | "Bool" @=? show TypeBoolean 94 | "Bool" @=? show TypeBoolean 95 | "Word8" @=? show TypeWord8 96 | "Word16" @=? show TypeWord16 97 | "Word32" @=? show TypeWord32 98 | "Word64" @=? show TypeWord64 99 | "Int16" @=? show TypeInt16 100 | "Int32" @=? show TypeInt32 101 | "Int64" @=? show TypeInt64 102 | "Double" @=? show TypeDouble 103 | "UnixFd" @=? show TypeUnixFd 104 | "String" @=? show TypeString 105 | "Signature" @=? show TypeSignature 106 | "ObjectPath" @=? show TypeObjectPath 107 | "Variant" @=? show TypeVariant 108 | "[Word8]" @=? show (TypeArray TypeWord8) 109 | "Dict Word8 (Dict Word8 Word8)" @=? show (TypeDictionary TypeWord8 (TypeDictionary TypeWord8 TypeWord8)) 110 | "(Word8, Word16)" @=? show (TypeStructure [TypeWord8, TypeWord16]) 111 | 112 | gen_SignatureTypes :: Gen [Type] 113 | gen_SignatureTypes = do 114 | (_, ts) <- gen_SignatureString 115 | return ts 116 | 117 | gen_SignatureString :: Gen (String, [Type]) 118 | gen_SignatureString = gen where 119 | anyType = oneof [atom, container] 120 | atom = elements 121 | [ ("b", TypeBoolean) 122 | , ("y", TypeWord8) 123 | , ("q", TypeWord16) 124 | , ("u", TypeWord32) 125 | , ("t", TypeWord64) 126 | , ("n", TypeInt16) 127 | , ("i", TypeInt32) 128 | , ("x", TypeInt64) 129 | , ("d", TypeDouble) 130 | , ("h", TypeUnixFd) 131 | , ("s", TypeString) 132 | , ("o", TypeObjectPath) 133 | , ("g", TypeSignature) 134 | ] 135 | container = oneof 136 | [ return ("v", TypeVariant) 137 | , array 138 | , dict 139 | , struct 140 | ] 141 | array = do 142 | (tCode, tEnum) <- anyType 143 | return ('a':tCode, TypeArray tEnum) 144 | dict = do 145 | (kCode, kEnum) <- atom 146 | (vCode, vEnum) <- anyType 147 | return (concat ["a{", kCode, vCode, "}"], TypeDictionary kEnum vEnum) 148 | struct = do 149 | ts <- listOf1 (halfSized anyType) 150 | let (codes, enums) = unzip ts 151 | return ("(" ++ concat codes ++ ")", TypeStructure enums) 152 | gen = do 153 | types <- listOf anyType 154 | let (codes, enums) = unzip types 155 | let chars = concat codes 156 | if length chars > 255 157 | then halfSized gen 158 | else return (chars, enums) 159 | 160 | instance Arbitrary Signature where 161 | arbitrary = do 162 | ts <- gen_SignatureTypes 163 | let Just sig = signature ts 164 | return sig 165 | -------------------------------------------------------------------------------- /tests/DBusTests/Introspection.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | -- Copyright (C) 2010-2012 John Millikin 3 | -- 4 | -- Licensed under the Apache License, Version 2.0 (the "License"); 5 | -- you may not use this file except in compliance with the License. 6 | -- You may obtain a copy of the License at 7 | -- 8 | -- http://www.apache.org/licenses/LICENSE-2.0 9 | -- 10 | -- Unless required by applicable law or agreed to in writing, software 11 | -- distributed under the License is distributed on an "AS IS" BASIS, 12 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | -- See the License for the specific language governing permissions and 14 | -- limitations under the License. 15 | 16 | module DBusTests.Introspection (test_Introspection) where 17 | 18 | import Control.Monad (liftM, liftM2) 19 | import Test.QuickCheck 20 | import Test.Tasty 21 | import Test.Tasty.HUnit 22 | import Test.Tasty.QuickCheck 23 | import qualified Data.Text as T 24 | 25 | import DBus 26 | import qualified DBus.Introspection.Parse as I 27 | import qualified DBus.Introspection.Render as I 28 | import qualified DBus.Introspection.Types as I 29 | 30 | import DBusTests.InterfaceName () 31 | import DBusTests.MemberName () 32 | import DBusTests.ObjectPath () 33 | import DBusTests.Signature () 34 | import DBusTests.Util (halfSized) 35 | 36 | test_Introspection :: TestTree 37 | test_Introspection = testGroup "Introspection" 38 | [ test_XmlPassthrough 39 | , test_XmlParse 40 | , test_XmlParseFailed 41 | , test_XmlWriteFailed 42 | ] 43 | 44 | test_XmlPassthrough :: TestTree 45 | test_XmlPassthrough = testProperty "xml-passthrough" $ \obj -> let 46 | path = I.objectPath obj 47 | Just xml = I.formatXML obj 48 | in I.parseXML path (T.pack xml) == Just obj 49 | 50 | buildEmptyObject :: String -> I.Object 51 | buildEmptyObject name = I.Object (objectPath_ name) [] [] 52 | 53 | test_XmlParse :: TestTree 54 | test_XmlParse = testCase "xml-parse" $ do 55 | -- root object path can be inferred 56 | I.parseXML (objectPath_ "/") "" 57 | @?= Just (buildEmptyObject "/") 58 | { I.objectChildren = 59 | [ buildEmptyObject "/foo" 60 | ] 61 | } 62 | 63 | test_XmlParseFailed :: TestTree 64 | test_XmlParseFailed = testCase "xml-parse-failed" $ do 65 | Nothing @=? I.parseXML (objectPath_ "/") "" 66 | Nothing @=? I.parseXML (objectPath_ "/") "" 67 | 68 | -- invalid property access 69 | Nothing @=? I.parseXML (objectPath_ "/") 70 | "\ 71 | \ \ 72 | \ \ 73 | \ \ 74 | \ \ 75 | \" 76 | 77 | -- invalid parameter type 78 | Nothing @=? I.parseXML (objectPath_ "/") 79 | "\ 80 | \ \ 81 | \ \ 82 | \ \ 83 | \ \ 84 | \ \ 85 | \" 86 | 87 | test_XmlWriteFailed :: TestTree 88 | test_XmlWriteFailed = testCase "xml-write-failed" $ do 89 | -- child's object path isn't under parent's 90 | Nothing @=? I.formatXML (buildEmptyObject "/foo") 91 | { I.objectChildren = 92 | [ buildEmptyObject "/bar" ] 93 | } 94 | 95 | -- invalid type 96 | Nothing @=? I.formatXML 97 | ((buildEmptyObject "/foo") 98 | { I.objectInterfaces = 99 | [ I.Interface (interfaceName_ "/bar") [] [] 100 | [ I.Property "prop" (TypeDictionary TypeVariant TypeVariant) True True ]]}) 101 | 102 | instance Arbitrary Type where 103 | arbitrary = oneof [atom, container] where 104 | atom = elements 105 | [ TypeBoolean 106 | , TypeWord8 107 | , TypeWord16 108 | , TypeWord32 109 | , TypeWord64 110 | , TypeInt16 111 | , TypeInt32 112 | , TypeInt64 113 | , TypeDouble 114 | , TypeString 115 | , TypeObjectPath 116 | , TypeSignature 117 | ] 118 | container = oneof 119 | [ return TypeVariant 120 | , liftM TypeArray arbitrary 121 | , liftM2 TypeDictionary atom arbitrary 122 | , liftM TypeStructure (listOf1 (halfSized arbitrary)) 123 | ] 124 | 125 | instance Arbitrary I.Object where 126 | arbitrary = arbitrary >>= subObject 127 | 128 | subObject :: ObjectPath -> Gen I.Object 129 | subObject parentPath = sized $ \n -> resize (min n 4) $ do 130 | let nonRoot = do 131 | x <- resize 10 arbitrary 132 | case formatObjectPath x of 133 | "/" -> nonRoot 134 | x' -> return x' 135 | 136 | thisPath <- nonRoot 137 | let path' = case formatObjectPath parentPath of 138 | "/" -> thisPath 139 | x -> x ++ thisPath 140 | let path = objectPath_ path' 141 | ifaces <- arbitrary 142 | children <- halfSized (listOf (subObject path)) 143 | return $ I.Object path ifaces children 144 | 145 | instance Arbitrary I.Interface where 146 | arbitrary = do 147 | name <- arbitrary 148 | methods <- arbitrary 149 | signals <- arbitrary 150 | properties <- arbitrary 151 | return $ I.Interface name methods signals properties 152 | 153 | instance Arbitrary I.Method where 154 | arbitrary = do 155 | name <- arbitrary 156 | args <- arbitrary 157 | return $ (I.Method name args) 158 | 159 | instance Arbitrary I.Signal where 160 | arbitrary = do 161 | name <- arbitrary 162 | args <- arbitrary 163 | return $ I.Signal name args 164 | 165 | instance Arbitrary I.MethodArg where 166 | arbitrary = I.MethodArg 167 | <$> gen_Ascii 168 | <*> arbitrary 169 | <*> arbitrary 170 | 171 | instance Arbitrary I.Direction where 172 | arbitrary = elements [I.In, I.Out] 173 | 174 | instance Arbitrary I.SignalArg where 175 | arbitrary = I.SignalArg 176 | <$> gen_Ascii 177 | <*> arbitrary 178 | 179 | instance Arbitrary I.Property where 180 | arbitrary = do 181 | name <- gen_Ascii 182 | t <- arbitrary 183 | canRead <- arbitrary 184 | canWrite <- arbitrary 185 | return I.Property 186 | { I.propertyName = name 187 | , I.propertyType = t 188 | , I.propertyRead = canRead 189 | , I.propertyWrite = canWrite 190 | } 191 | 192 | gen_Ascii :: Gen String 193 | gen_Ascii = listOf (elements ['!'..'~']) 194 | -------------------------------------------------------------------------------- /lib/DBus/Internal/Address.hs: -------------------------------------------------------------------------------- 1 | {-# Language LambdaCase #-} 2 | -- Copyright (C) 2009-2012 John Millikin 3 | -- 4 | -- Licensed under the Apache License, Version 2.0 (the "License"); 5 | -- you may not use this file except in compliance with the License. 6 | -- You may obtain a copy of the License at 7 | -- 8 | -- http://www.apache.org/licenses/LICENSE-2.0 9 | -- 10 | -- Unless required by applicable law or agreed to in writing, software 11 | -- distributed under the License is distributed on an "AS IS" BASIS, 12 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | -- See the License for the specific language governing permissions and 14 | -- limitations under the License. 15 | 16 | module DBus.Internal.Address where 17 | 18 | import Data.Char (digitToInt, ord, chr) 19 | import Data.Maybe (listToMaybe, fromMaybe) 20 | import Data.List (intercalate) 21 | import qualified Data.Map 22 | import Data.Map (Map) 23 | import System.Environment (lookupEnv) 24 | import Text.Printf (printf) 25 | 26 | import Text.ParserCombinators.Parsec 27 | 28 | -- | When a D-Bus server must listen for connections, or a client must connect 29 | -- to a server, the listening socket's configuration is specified with an 30 | -- /address/. An address contains the /method/, which determines the 31 | -- protocol and transport mechanism, and /parameters/, which provide 32 | -- additional method-specific information about the address. 33 | data Address = Address String (Map String String) 34 | deriving (Eq) 35 | 36 | addressMethod :: Address -> String 37 | addressMethod (Address x _ ) = x 38 | 39 | addressParameters :: Address -> Map String String 40 | addressParameters (Address _ x) = x 41 | 42 | -- | Try to convert a method string and parameter map to an 'Address'. 43 | -- 44 | -- Returns 'Nothing' if the method or parameters are invalid. 45 | address :: String -> Map String String -> Maybe Address 46 | address method params = if validMethod method && validParams params 47 | then if null method && Data.Map.null params 48 | then Nothing 49 | else Just (Address method params) 50 | else Nothing 51 | 52 | validMethod :: String -> Bool 53 | validMethod = all validChar where 54 | validChar c = c /= ';' && c /= ':' 55 | 56 | validParams :: Map String String -> Bool 57 | validParams = all validItem . Data.Map.toList where 58 | validItem (k, v) = notNull k && notNull v && validKey k 59 | validKey = all validChar 60 | validChar c = c /= ';' && c /= ',' && c /= '=' 61 | notNull = not . null 62 | 63 | optionallyEncoded :: [Char] 64 | optionallyEncoded = concat 65 | [ ['0'..'9'] 66 | , ['a'..'z'] 67 | , ['A'..'Z'] 68 | , ['-', '_', '/', '\\', '*', '.'] 69 | ] 70 | 71 | -- | Convert an address to a string in the format expected by 'parseAddress'. 72 | formatAddress :: Address -> String 73 | formatAddress (Address method params) = concat [method, ":", csvParams] where 74 | csvParams = intercalate "," $ do 75 | (k, v) <- Data.Map.toList params 76 | let v' = concatMap escape v 77 | return (concat [k, "=", v']) 78 | 79 | escape c = if elem c optionallyEncoded 80 | then [c] 81 | else printf "%%%02X" (ord c) 82 | 83 | -- | Convert a list of addresses to a string in the format expected by 84 | -- 'parseAddresses'. 85 | formatAddresses :: [Address] -> String 86 | formatAddresses = intercalate ";" . map formatAddress 87 | 88 | instance Show Address where 89 | showsPrec d x = showParen (d > 10) $ 90 | showString "Address " . 91 | shows (formatAddress x) 92 | 93 | -- | Try to parse a string containing one valid address. 94 | -- 95 | -- An address string is in the format @method:key1=val1,key2=val2@. There 96 | -- are some limitations on the characters allowed within methods and 97 | -- parameters; see the D-Bus specification for full details. 98 | parseAddress :: String -> Maybe Address 99 | parseAddress = maybeParseString $ do 100 | addr <- parsecAddress 101 | eof 102 | return addr 103 | 104 | -- | Try to parse a string containing one or more valid addresses. 105 | -- 106 | -- Addresses are separated by semicolons. See 'parseAddress' for the format 107 | -- of addresses. 108 | parseAddresses :: String -> Maybe [Address] 109 | parseAddresses = maybeParseString $ do 110 | addrs <- sepEndBy parsecAddress (char ';') 111 | eof 112 | return addrs 113 | 114 | parsecAddress :: Parser Address 115 | parsecAddress = p where 116 | p = do 117 | method <- many (noneOf ":;") 118 | _ <- char ':' 119 | params <- sepEndBy param (char ',') 120 | return (Address method (Data.Map.fromList params)) 121 | 122 | param = do 123 | key <- many1 (noneOf "=;,") 124 | _ <- char '=' 125 | value <- many1 valueChar 126 | return (key, value) 127 | 128 | valueChar = encoded <|> unencoded 129 | encoded = do 130 | _ <- char '%' 131 | hex <- count 2 hexDigit 132 | return (chr (hexToInt hex)) 133 | unencoded = oneOf optionallyEncoded 134 | 135 | -- | Returns the address in the environment variable 136 | -- @DBUS_SYSTEM_BUS_ADDRESS@, or 137 | -- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@ 138 | -- is not set. 139 | -- 140 | -- Returns 'Nothing' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid address. 141 | getSystemAddress :: IO (Maybe Address) 142 | getSystemAddress = do 143 | let system = "unix:path=/var/run/dbus/system_bus_socket" 144 | env <- lookupEnv "DBUS_SYSTEM_BUS_ADDRESS" 145 | return (parseAddress (fromMaybe system env)) 146 | 147 | -- | Returns the first address in the environment variable 148 | -- @DBUS_SESSION_BUS_ADDRESS@, which must be set. 149 | -- 150 | -- Returns 'Nothing' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid address 151 | -- or @DBUS_SESSION_BUS_ADDRESS@ is unset @XDG_RUNTIME_DIR@ doesn't have @/bus@. 152 | getSessionAddress :: IO (Maybe Address) 153 | getSessionAddress = lookupEnv "DBUS_SESSION_BUS_ADDRESS" >>= \case 154 | Just addrs -> pure (parseAddresses addrs >>= listToMaybe) 155 | Nothing -> (>>= parseFallback) <$> lookupEnv "XDG_RUNTIME_DIR" 156 | where 157 | parseFallback dir = parseAddress ("unix:path=" ++ dir ++ "/bus") 158 | 159 | -- | Returns the address in the environment variable 160 | -- @DBUS_STARTER_ADDRESS@, which must be set. 161 | -- 162 | -- Returns 'Nothing' if @DBUS_STARTER_ADDRESS@ is unset or contains an 163 | -- invalid address. 164 | getStarterAddress :: IO (Maybe Address) 165 | getStarterAddress = do 166 | env <- lookupEnv "DBUS_STARTER_ADDRESS" 167 | return (env >>= parseAddress) 168 | 169 | hexToInt :: String -> Int 170 | hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt 171 | 172 | maybeParseString :: Parser a -> String -> Maybe a 173 | maybeParseString p str = case runParser p () "" str of 174 | Left _ -> Nothing 175 | Right a -> Just a 176 | -------------------------------------------------------------------------------- /tests/DBusTests/Socket.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | 5 | -- Copyright (C) 2012 John Millikin 6 | -- 7 | -- Licensed under the Apache License, Version 2.0 (the "License"); 8 | -- you may not use this file except in compliance with the License. 9 | -- You may obtain a copy of the License at 10 | -- 11 | -- http://www.apache.org/licenses/LICENSE-2.0 12 | -- 13 | -- Unless required by applicable law or agreed to in writing, software 14 | -- distributed under the License is distributed on an "AS IS" BASIS, 15 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | -- See the License for the specific language governing permissions and 17 | -- limitations under the License. 18 | 19 | module DBusTests.Socket (test_Socket) where 20 | 21 | import Control.Concurrent 22 | import Control.Exception 23 | import Control.Monad (void) 24 | import System.IO (SeekMode(..)) 25 | import System.Posix (Fd, fdRead, fdSeek, fdWrite) 26 | import Test.Tasty 27 | import Test.Tasty.HUnit 28 | import qualified Data.Map as Map 29 | 30 | import DBus 31 | import DBus.Socket 32 | import DBus.Transport 33 | 34 | import DBusTests.Util (forkVar, nonWindowsTestCase, withTempFd) 35 | 36 | test_Socket :: TestTree 37 | test_Socket = testGroup "Socket" 38 | [ test_Listen 39 | , test_ListenWith_CustomAuth 40 | , test_SendReceive 41 | , test_SendReceive_FileDescriptors 42 | ] 43 | 44 | test_Listen :: TestTree 45 | test_Listen = testCase "listen" $ do 46 | uuid <- randomUUID 47 | let Just addr = address "unix" (Map.singleton "abstract" (formatUUID uuid)) 48 | 49 | bracket (listen addr) closeListener $ \listener -> do 50 | acceptedVar <- forkVar (accept listener) 51 | openedVar <- forkVar (open addr) 52 | 53 | sock1 <- takeMVar acceptedVar 54 | sock2 <- takeMVar openedVar 55 | close sock1 56 | close sock2 57 | 58 | test_ListenWith_CustomAuth :: TestTree 59 | test_ListenWith_CustomAuth = testCase "listenWith-custom-auth" $ do 60 | uuid <- randomUUID 61 | let Just addr = address "unix" (Map.singleton "abstract" (formatUUID uuid)) 62 | 63 | bracket (listenWith (defaultSocketOptions 64 | { socketAuthenticator = dummyAuth 65 | }) addr) closeListener $ \listener -> do 66 | acceptedVar <- forkVar (accept listener) 67 | openedVar <- forkVar (openWith (defaultSocketOptions 68 | { socketAuthenticator = dummyAuth 69 | }) addr) 70 | 71 | sock1 <- takeMVar acceptedVar 72 | sock2 <- takeMVar openedVar 73 | close sock1 74 | close sock2 75 | 76 | test_SendReceive :: TestTree 77 | test_SendReceive = testCase "send-receive" $ do 78 | uuid <- randomUUID 79 | let Just addr = address "unix" (Map.singleton "abstract" (formatUUID uuid)) 80 | 81 | let msg = (methodCall "/" "org.example.iface" "Foo") 82 | { methodCallSender = Just "org.example.src" 83 | , methodCallDestination = Just "org.example.dst" 84 | , methodCallAutoStart = False 85 | , methodCallReplyExpected = False 86 | , methodCallBody = [toVariant True] 87 | } 88 | 89 | bracket (listen addr) closeListener $ \listener -> do 90 | acceptedVar <- forkVar (accept listener) 91 | openedVar <- forkVar (open addr) 92 | 93 | bracket (takeMVar acceptedVar) close $ \sock1 -> do 94 | bracket (takeMVar openedVar) close $ \sock2 -> do 95 | -- client -> server 96 | do 97 | serialVar <- newEmptyMVar 98 | sentVar <- forkVar (send sock2 msg (putMVar serialVar)) 99 | receivedVar <- forkVar (receive sock1) 100 | 101 | serial <- takeMVar serialVar 102 | sent <- takeMVar sentVar 103 | received <- takeMVar receivedVar 104 | 105 | sent @?= () 106 | received @?= ReceivedMethodCall serial msg 107 | 108 | -- server -> client 109 | do 110 | serialVar <- newEmptyMVar 111 | sentVar <- forkVar (send sock1 msg (putMVar serialVar)) 112 | receivedVar <- forkVar (receive sock2) 113 | 114 | serial <- takeMVar serialVar 115 | sent <- takeMVar sentVar 116 | received <- takeMVar receivedVar 117 | 118 | sent @?= () 119 | received @?= ReceivedMethodCall serial msg 120 | 121 | test_SendReceive_FileDescriptors :: TestTree 122 | test_SendReceive_FileDescriptors = nonWindowsTestCase "send-receive-file-descriptors" $ do 123 | uuid <- randomUUID 124 | let Just addr = address "unix" (Map.singleton "abstract" (formatUUID uuid)) 125 | 126 | withTempFd $ \tmpFd -> do 127 | 128 | -- in order to know that the file descriptor received by the server points to 129 | -- the same file as the file descriptor that was sent, we write "hello" on the 130 | -- client and read it back on the server. 131 | void $ fdWrite tmpFd "hello" 132 | void $ fdSeek tmpFd AbsoluteSeek 0 133 | 134 | let msg = (methodCall "/" "org.example.iface" "Foo") 135 | { methodCallBody = [toVariant tmpFd] } 136 | 137 | bracket (listen addr) closeListener $ \listener -> do 138 | acceptedVar <- forkVar (accept listener) 139 | openedVar <- forkVar (open addr) 140 | 141 | bracket (takeMVar acceptedVar) close $ \sock1 -> do 142 | bracket (takeMVar openedVar) close $ \sock2 -> do 143 | receivedVar <- forkVar (receive sock1) 144 | send sock2 msg (const (pure ())) 145 | 146 | received <- takeMVar receivedVar 147 | case receivedMessageBody received of 148 | [fromVariant -> Just (fd :: Fd)] -> do 149 | assertBool ("Expected a different Fd, not " <> show tmpFd) (fd /= tmpFd) 150 | (fdMsg, _) <- fdRead fd 5 151 | fdMsg @?= "hello" 152 | body -> do 153 | assertFailure ("Expected a single Fd, not: " <> show body) 154 | 155 | dummyAuth :: Transport t => Authenticator t 156 | dummyAuth = authenticator 157 | { authenticatorClient = dummyAuthClient 158 | , authenticatorServer = dummyAuthServer 159 | } 160 | 161 | dummyAuthClient :: Transport t => t -> IO Bool 162 | dummyAuthClient t = do 163 | transportPut t "\x00" 164 | resp <- transportGet t 4 165 | return (resp == "OK\r\n") 166 | 167 | dummyAuthServer :: Transport t => t -> UUID -> IO Bool 168 | dummyAuthServer t _ = do 169 | c <- transportGet t 1 170 | if c == "\x00" 171 | then do 172 | transportPut t "OK\r\n" 173 | return True 174 | else return False 175 | -------------------------------------------------------------------------------- /tests/DBusTests/Variant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- Copyright (C) 2010-2012 John Millikin 4 | -- 5 | -- Licensed under the Apache License, Version 2.0 (the "License"); 6 | -- you may not use this file except in compliance with the License. 7 | -- You may obtain a copy of the License at 8 | -- 9 | -- http://www.apache.org/licenses/LICENSE-2.0 10 | -- 11 | -- Unless required by applicable law or agreed to in writing, software 12 | -- distributed under the License is distributed on an "AS IS" BASIS, 13 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | -- See the License for the specific language governing permissions and 15 | -- limitations under the License. 16 | 17 | module DBusTests.Variant (test_Variant) where 18 | 19 | import Test.Tasty 20 | import Test.Tasty.HUnit 21 | 22 | import Data.Int (Int16, Int32, Int64) 23 | import Data.Word (Word8, Word16, Word32, Word64) 24 | import System.Posix.Types (Fd) 25 | import qualified Data.ByteString 26 | import qualified Data.ByteString.Lazy 27 | import qualified Data.Map 28 | import qualified Data.Text 29 | import qualified Data.Text as T 30 | import qualified Data.Text.Lazy 31 | import qualified Data.Vector 32 | 33 | import DBus 34 | import DBus.Internal.Types (toValue) 35 | 36 | import DBusTests.Util 37 | 38 | test_Variant :: TestTree 39 | test_Variant = testGroup "Variant" 40 | [ test_IsAtom 41 | , test_IsValue 42 | , test_Show 43 | , test_ByteStorage 44 | ] 45 | 46 | test_IsAtom :: TestTree 47 | test_IsAtom = testCase "IsAtom" $ do 48 | assertAtom TypeBoolean True 49 | assertAtom TypeWord8 (0 :: Word8) 50 | assertAtom TypeWord16 (0 :: Word16) 51 | assertAtom TypeWord32 (0 :: Word32) 52 | assertAtom TypeWord64 (0 :: Word64) 53 | assertAtom TypeInt16 (0 :: Int16) 54 | assertAtom TypeInt32 (0 :: Int32) 55 | assertAtom TypeInt64 (0 :: Int64) 56 | assertAtom TypeDouble (0 :: Double) 57 | assertAtom TypeUnixFd (0 :: Fd) 58 | assertAtom TypeString (Data.Text.pack "") 59 | assertAtom TypeString (Data.Text.Lazy.pack "") 60 | assertAtom TypeString ("" :: String) 61 | assertAtom TypeObjectPath (objectPath_ "/") 62 | assertAtom TypeSignature (signature_ []) 63 | 64 | test_IsValue :: TestTree 65 | test_IsValue = testCase "IsValue" $ do 66 | assertValue TypeVariant (toVariant True) 67 | assertValue (TypeArray TypeBoolean) [True] 68 | assertValue (TypeArray TypeBoolean) (Data.Vector.fromList [True]) 69 | assertValue (TypeArray TypeWord8) Data.ByteString.empty 70 | assertValue (TypeArray TypeWord8) Data.ByteString.Lazy.empty 71 | assertValue (TypeDictionary TypeBoolean TypeBoolean) (Data.Map.fromList [(True, True)]) 72 | assertValue (TypeStructure (replicate 2 TypeBoolean)) (True, True) 73 | assertValue (TypeStructure (replicate 3 TypeBoolean)) (True, True, True) 74 | assertValue (TypeStructure (replicate 4 TypeBoolean)) (True, True, True, True) 75 | assertValue (TypeStructure (replicate 5 TypeBoolean)) (True, True, True, True, True) 76 | assertValue (TypeStructure (replicate 6 TypeBoolean)) (True, True, True, True, True, True) 77 | assertValue (TypeStructure (replicate 7 TypeBoolean)) (True, True, True, True, True, True, True) 78 | assertValue (TypeStructure (replicate 8 TypeBoolean)) (True, True, True, True, True, True, True, True) 79 | assertValue (TypeStructure (replicate 9 TypeBoolean)) (True, True, True, True, True, True, True, True, True) 80 | assertValue (TypeStructure (replicate 10 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True) 81 | assertValue (TypeStructure (replicate 11 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True) 82 | assertValue (TypeStructure (replicate 12 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True, True) 83 | assertValue (TypeStructure (replicate 13 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True, True, True) 84 | assertValue (TypeStructure (replicate 14 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True, True, True, True) 85 | assertValue (TypeStructure (replicate 15 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True, True, True, True, True) 86 | 87 | test_Show :: TestTree 88 | test_Show = testCase "show" $ do 89 | "Variant True" @=? show (toVariant True) 90 | "Variant 0" @=? show (toVariant (0 :: Word8)) 91 | "Variant 0" @=? show (toVariant (0 :: Word16)) 92 | "Variant 0" @=? show (toVariant (0 :: Word32)) 93 | "Variant 0" @=? show (toVariant (0 :: Word64)) 94 | "Variant 0" @=? show (toVariant (0 :: Int16)) 95 | "Variant 0" @=? show (toVariant (0 :: Int32)) 96 | "Variant 0" @=? show (toVariant (0 :: Int64)) 97 | "Variant 0.1" @=? show (toVariant (0.1 :: Double)) 98 | "Variant (UnixFd 1)" @=? show (toVariant (1 :: Fd)) 99 | "Variant \"\"" @=? show (toVariant (T.pack "")) 100 | "Variant (ObjectPath \"/\")" @=? show (toVariant (objectPath_ "/")) 101 | "Variant (Signature \"\")" @=? show (toVariant (signature_ [])) 102 | "Variant (Variant True)" @=? show (toVariant (toVariant True)) 103 | "Variant [True, False]" @=? show (toVariant [True, False]) 104 | 105 | "Variant b\"\"" @=? show (toVariant Data.ByteString.empty) 106 | "Variant b\"\"" @=? show (toVariant Data.ByteString.Lazy.empty) 107 | "Variant b\"\"" @=? show (toVariant ([] :: [Word8])) 108 | 109 | "(Variant {False: True, True: False})" @=? showsPrec 11 (toVariant (Data.Map.fromList [(True, False), (False, True)])) "" 110 | "(Variant (True, False))" @=? showsPrec 11 (toVariant (True, False)) "" 111 | 112 | test_ByteStorage :: TestTree 113 | test_ByteStorage = testCase "byte-storage" $ do 114 | -- Vector Word8 -> Vector Word8 115 | toValue (Data.Vector.fromList [0 :: Word8]) 116 | @=? toValue (Data.Vector.fromList [0 :: Word8]) 117 | 118 | -- Vector Word8 -> ByteString 119 | toValue (Data.Vector.fromList [0 :: Word8]) 120 | @=? toValue (Data.ByteString.pack [0]) 121 | 122 | -- Vector Word8 -> Lazy.ByteString 123 | toValue (Data.Vector.fromList [0 :: Word8]) 124 | @=? toValue (Data.ByteString.Lazy.pack [0]) 125 | 126 | -- ByteString -> Vector Word8 127 | toValue (Data.ByteString.pack [0]) 128 | @=? toValue (Data.Vector.fromList [0 :: Word8]) 129 | -- ByteString -> ByteString 130 | toValue (Data.ByteString.pack [0]) 131 | @=? toValue (Data.ByteString.pack [0]) 132 | -- ByteString -> Lazy.ByteString 133 | toValue (Data.ByteString.pack [0]) 134 | @=? toValue (Data.ByteString.Lazy.pack [0]) 135 | 136 | -- Lazy.ByteString -> Vector Word8 137 | toValue (Data.ByteString.Lazy.pack [0]) 138 | @=? toValue (Data.Vector.fromList [0 :: Word8]) 139 | -- Lazy.ByteString -> ByteString 140 | toValue (Data.ByteString.Lazy.pack [0]) 141 | @=? toValue (Data.ByteString.pack [0]) 142 | -- Lazy.ByteString -> Lazy.ByteString 143 | toValue (Data.ByteString.Lazy.pack [0]) 144 | @=? toValue (Data.ByteString.Lazy.pack [0]) 145 | -------------------------------------------------------------------------------- /tests/DBusTests/Serialization.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- Copyright (C) 2010-2012 John Millikin 4 | -- 5 | -- Licensed under the Apache License, Version 2.0 (the "License"); 6 | -- you may not use this file except in compliance with the License. 7 | -- You may obtain a copy of the License at 8 | -- 9 | -- http://www.apache.org/licenses/LICENSE-2.0 10 | -- 11 | -- Unless required by applicable law or agreed to in writing, software 12 | -- distributed under the License is distributed on an "AS IS" BASIS, 13 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | -- See the License for the specific language governing permissions and 15 | -- limitations under the License. 16 | 17 | module DBusTests.Serialization (test_Serialization) where 18 | 19 | import Data.ByteString (ByteString) 20 | import Data.Int (Int16, Int32, Int64) 21 | import Data.Map (Map) 22 | import Data.Text (Text) 23 | import Data.Word (Word8, Word16, Word32, Word64) 24 | import Foreign.C.Types (CInt) 25 | import System.Posix.Types (Fd) 26 | import Test.QuickCheck 27 | import Test.Tasty 28 | import Test.Tasty.QuickCheck 29 | import qualified Data.Map 30 | import qualified Data.Vector 31 | 32 | import DBus 33 | import qualified DBus.Internal.Types 34 | 35 | import DBusTests.BusName () 36 | import DBusTests.ErrorName () 37 | import DBusTests.InterfaceName () 38 | import DBusTests.MemberName () 39 | import DBusTests.ObjectPath () 40 | import DBusTests.Signature () 41 | import DBusTests.Util (smallListOf) 42 | 43 | test_Serialization :: TestTree 44 | test_Serialization = testGroup "Serialization" 45 | [ test_MethodCall 46 | , test_MethodReturn 47 | , test_MethodError 48 | , test_Signal 49 | ] 50 | 51 | test_MethodCall :: TestTree 52 | test_MethodCall = testProperty "MethodCall" prop where 53 | prop = forAll gen_MethodCall check 54 | check msg endianness serial = let 55 | Right (bytes, fds) = marshalWithFds endianness serial msg 56 | Right received = unmarshalWithFds bytes fds 57 | in ReceivedMethodCall serial msg == received 58 | 59 | test_MethodReturn :: TestTree 60 | test_MethodReturn = testProperty "MethodReturn" prop where 61 | prop = forAll gen_MethodReturn check 62 | check msg endianness serial = let 63 | Right (bytes, fds) = marshalWithFds endianness serial msg 64 | Right received = unmarshalWithFds bytes fds 65 | in ReceivedMethodReturn serial msg == received 66 | 67 | test_MethodError :: TestTree 68 | test_MethodError = testProperty "MethodError" prop where 69 | prop = forAll gen_MethodError check 70 | check msg endianness serial = let 71 | Right (bytes, fds) = marshalWithFds endianness serial msg 72 | Right received = unmarshalWithFds bytes fds 73 | in ReceivedMethodError serial msg == received 74 | 75 | test_Signal :: TestTree 76 | test_Signal = testProperty "Signal" prop where 77 | prop = forAll gen_Signal check 78 | check msg endianness serial = let 79 | Right (bytes, fds) = marshalWithFds endianness serial msg 80 | Right received = unmarshalWithFds bytes fds 81 | in ReceivedSignal serial msg == received 82 | 83 | gen_Atom :: Gen Variant 84 | gen_Atom = oneof 85 | [ fmap toVariant (arbitrary :: Gen Word8) 86 | , fmap toVariant (arbitrary :: Gen Word16) 87 | , fmap toVariant (arbitrary :: Gen Word32) 88 | , fmap toVariant (arbitrary :: Gen Word64) 89 | , fmap toVariant (arbitrary :: Gen Int16) 90 | , fmap toVariant (arbitrary :: Gen Int32) 91 | , fmap toVariant (arbitrary :: Gen Int64) 92 | , fmap toVariant (arbitrary :: Gen Bool) 93 | , fmap toVariant (arbitrary :: Gen Double) 94 | , fmap toVariant gen_UnixFd 95 | , fmap toVariant (arbitrary :: Gen Text) 96 | , fmap toVariant (arbitrary :: Gen ObjectPath) 97 | , fmap toVariant (arbitrary :: Gen Signature) 98 | ] 99 | 100 | gen_UnixFd :: Gen Fd 101 | gen_UnixFd = do 102 | let maxWord32 = toInteger (maxBound :: Word32) 103 | let maxCInt = toInteger (maxBound :: CInt) 104 | x <- choose (0, toInteger (min maxWord32 maxCInt)) 105 | return (fromInteger x) 106 | 107 | gen_Variant :: Gen Variant 108 | gen_Variant = oneof 109 | [ gen_Atom 110 | , fmap toVariant (arbitrary :: Gen ByteString) 111 | 112 | -- TODO: proper arbitrary vectors 113 | , elements 114 | [ toVariant (Data.Vector.fromList ([] :: [Word8])) 115 | , toVariant (Data.Vector.fromList ([0, 1, 2, 3, 4, 5] :: [Word8])) 116 | , toVariant (Data.Vector.fromList ([0, 1, 2, 3, 4, 5] :: [Word16])) 117 | , toVariant (Data.Vector.fromList ([0, 1, 2, 3, 4, 5] :: [Word32])) 118 | , toVariant (Data.Vector.fromList ([0, 1, 2, 3, 4, 5] :: [Word64])) 119 | , toVariant (Data.Vector.fromList (["foo", "bar", "baz"] :: [Text])) 120 | ] 121 | 122 | -- TODO: proper arbitrary maps 123 | , elements 124 | [ toVariant (Data.Map.fromList [] :: Map Text Text) 125 | , toVariant (Data.Map.fromList [("foo", "bar"), ("baz", "qux")] :: Map Text Text) 126 | ] 127 | 128 | -- TODO: proper arbitrary structures 129 | , elements 130 | [ toVariant (True, "foo" :: Text, ["bar" :: Text]) 131 | , toVariant (1 :: Word8, 1 :: Word16, 1 :: Word32, 1 :: Word64) 132 | ] 133 | , fmap toVariant gen_Variant 134 | ] 135 | 136 | gen_MethodCall :: Gen MethodCall 137 | gen_MethodCall = do 138 | path <- arbitrary 139 | iface <- arbitrary 140 | member <- arbitrary 141 | sender <- arbitrary 142 | dest <- arbitrary 143 | 144 | flagReplyExpected <- arbitrary 145 | flagAutoStart <- arbitrary 146 | 147 | body <- smallListOf gen_Variant 148 | return (methodCall path "com.example.ignored" member) 149 | { methodCallInterface = iface 150 | , methodCallSender = sender 151 | , methodCallDestination = dest 152 | , methodCallReplyExpected = flagReplyExpected 153 | , methodCallAutoStart = flagAutoStart 154 | , methodCallBody = body 155 | } 156 | 157 | gen_MethodReturn :: Gen MethodReturn 158 | gen_MethodReturn = do 159 | serial <- arbitrary 160 | sender <- arbitrary 161 | dest <- arbitrary 162 | body <- smallListOf gen_Variant 163 | return (methodReturn serial) 164 | { methodReturnSender = sender 165 | , methodReturnDestination = dest 166 | , methodReturnBody = body 167 | } 168 | 169 | gen_MethodError :: Gen MethodError 170 | gen_MethodError = do 171 | serial <- arbitrary 172 | name <- arbitrary 173 | sender <- arbitrary 174 | dest <- arbitrary 175 | body <- smallListOf gen_Variant 176 | return (methodError serial name) 177 | { methodErrorSender = sender 178 | , methodErrorDestination = dest 179 | , methodErrorBody = body 180 | } 181 | 182 | gen_Signal :: Gen Signal 183 | gen_Signal = do 184 | path <- arbitrary 185 | iface <- arbitrary 186 | member <- arbitrary 187 | sender <- arbitrary 188 | dest <- arbitrary 189 | body <- smallListOf gen_Variant 190 | return (signal path iface member) 191 | { signalSender = sender 192 | , signalDestination = dest 193 | , signalBody = body 194 | } 195 | 196 | instance Arbitrary Endianness where 197 | arbitrary = elements [BigEndian, LittleEndian] 198 | 199 | instance Arbitrary Serial where 200 | arbitrary = fmap DBus.Internal.Types.Serial arbitrary 201 | -------------------------------------------------------------------------------- /tests/DBusTests/Address.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (C) 2010-2012 John Millikin 2 | -- 3 | -- Licensed under the Apache License, Version 2.0 (the "License"); 4 | -- you may not use this file except in compliance with the License. 5 | -- You may obtain a copy of the License at 6 | -- 7 | -- http://www.apache.org/licenses/LICENSE-2.0 8 | -- 9 | -- Unless required by applicable law or agreed to in writing, software 10 | -- distributed under the License is distributed on an "AS IS" BASIS, 11 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | -- See the License for the specific language governing permissions and 13 | -- limitations under the License. 14 | 15 | module DBusTests.Address (test_Address) where 16 | 17 | import Data.Char (ord) 18 | import Data.List (intercalate) 19 | import Data.Map (Map) 20 | import Data.Maybe 21 | import Test.QuickCheck 22 | import Test.Tasty 23 | import Test.Tasty.HUnit 24 | import Test.Tasty.QuickCheck 25 | import Text.Printf (printf) 26 | import qualified Data.Map 27 | 28 | import DBus 29 | 30 | import DBusTests.Util (smallListOf, smallListOf1, withEnv) 31 | 32 | test_Address :: TestTree 33 | test_Address = testGroup "Address" 34 | [ test_BuildAddress 35 | , test_ParseAddress 36 | , test_ParseAddresses 37 | , test_ParseInvalid 38 | , test_FormatAddress 39 | , test_FormatAddresses 40 | , test_GetSystemAddress 41 | , test_GetSessionAddress 42 | , test_GetStarterAddress 43 | ] 44 | 45 | test_BuildAddress :: TestTree 46 | test_BuildAddress = testProperty "address" prop where 47 | prop = forAll gen_Address check 48 | check (method, params) = case address method params of 49 | Nothing -> False 50 | Just addr -> and 51 | [ addressMethod addr == method 52 | , addressParameters addr == params 53 | ] 54 | 55 | test_ParseAddress :: TestTree 56 | test_ParseAddress = testProperty "parseAddress" prop where 57 | prop = forAll gen_AddressBytes check 58 | check (bytes, method, params) = case parseAddress bytes of 59 | Nothing -> False 60 | Just addr -> and 61 | [ addressMethod addr == method 62 | , addressParameters addr == params 63 | ] 64 | 65 | test_ParseAddresses :: TestTree 66 | test_ParseAddresses = testProperty "parseAddresses" prop where 67 | prop = forAll gen_AddressesBytes checkMany 68 | checkMany (bytes, expectedAddrs) = case parseAddresses bytes of 69 | Nothing -> False 70 | Just addrs -> and 71 | [ length addrs == length expectedAddrs 72 | , and (map checkOne (zip addrs expectedAddrs)) 73 | ] 74 | checkOne (addr, (method, params)) = and 75 | [ addressMethod addr == method 76 | , addressParameters addr == params 77 | ] 78 | 79 | test_ParseInvalid :: TestTree 80 | test_ParseInvalid = testCase "parse-invalid" $ do 81 | -- empty 82 | Nothing @=? address "" Data.Map.empty 83 | Nothing @=? parseAddress "" 84 | 85 | -- no colon 86 | Nothing @=? parseAddress "a" 87 | 88 | -- no equals sign 89 | Nothing @=? parseAddress "a:b" 90 | 91 | -- no parameter 92 | -- TODO: should this be OK? what about the trailing comma rule? 93 | Nothing @=? parseAddress "a:," 94 | 95 | -- no key 96 | Nothing @=? address "" (Data.Map.fromList [("", "c")]) 97 | Nothing @=? parseAddress "a:=c" 98 | 99 | -- no value 100 | Nothing @=? address "" (Data.Map.fromList [("b", "")]) 101 | Nothing @=? parseAddress "a:b=" 102 | 103 | test_FormatAddress :: TestTree 104 | test_FormatAddress = testProperty "formatAddress" prop where 105 | prop = forAll gen_Address check where 106 | check (method, params) = let 107 | Just addr = address method params 108 | bytes = formatAddress addr 109 | parsed = parseAddress bytes 110 | shown = show addr 111 | in and 112 | [ parsed == Just addr 113 | , shown == "Address " ++ show bytes 114 | ] 115 | 116 | test_FormatAddresses :: TestTree 117 | test_FormatAddresses = testProperty "formatAddresses" prop where 118 | prop = forAll (smallListOf1 gen_Address) check where 119 | check pairs = let 120 | addrs = do 121 | (method, params) <- pairs 122 | let Just addr = address method params 123 | return addr 124 | bytes = formatAddresses addrs 125 | parsed = parseAddresses bytes 126 | in parsed == Just addrs 127 | 128 | test_GetSystemAddress :: TestTree 129 | test_GetSystemAddress = testCase "getSystemAddress" $ do 130 | do 131 | addr <- withEnv "DBUS_SYSTEM_BUS_ADDRESS" Nothing getSystemAddress 132 | assertBool "can't get system address" $ isJust addr 133 | addr @?= address "unix" (Data.Map.fromList [("path", "/var/run/dbus/system_bus_socket")]) 134 | do 135 | addr <- withEnv "DBUS_SYSTEM_BUS_ADDRESS" (Just "a:b=c") getSystemAddress 136 | assertBool "can't get system address" $ isJust addr 137 | addr @?= address "a" (Data.Map.fromList [("b", "c")]) 138 | 139 | test_GetSessionAddress :: TestTree 140 | test_GetSessionAddress = testCase "getSessionAddress" $ do 141 | addr <- withEnv "DBUS_SESSION_BUS_ADDRESS" (Just "a:b=c") getSessionAddress 142 | assertBool "can't get session address" $ isJust addr 143 | addr @?= address "a" (Data.Map.fromList [("b", "c")]) 144 | 145 | test_GetStarterAddress :: TestTree 146 | test_GetStarterAddress = testCase "getStarterAddress" $ do 147 | addr <- withEnv "DBUS_STARTER_ADDRESS" (Just "a:b=c") getStarterAddress 148 | assertBool "can't get starter address" $ isJust addr 149 | addr @?= address "a" (Data.Map.fromList [("b", "c")]) 150 | 151 | gen_Address :: Gen (String, Map String String) 152 | gen_Address = gen where 153 | methodChars = filter (`notElem` ":;") ['!'..'~'] 154 | keyChars = filter (`notElem` "=;,") ['!'..'~'] 155 | 156 | param = do 157 | key <- smallListOf1 (elements keyChars) 158 | value <- smallListOf1 (elements ['\x00'..'\xFF']) 159 | return (key, value) 160 | 161 | gen = do 162 | params <- smallListOf param 163 | method <- if null params 164 | then smallListOf1 (elements methodChars) 165 | else smallListOf (elements methodChars) 166 | 167 | return (method, Data.Map.fromList params) 168 | 169 | gen_AddressBytes :: Gen (String, String, Map String String) 170 | gen_AddressBytes = gen where 171 | methodChars = filter (`notElem` ":;") ['!'..'~'] 172 | keyChars = filter (`notElem` "=;,") ['!'..'~'] 173 | 174 | plainChars = concat 175 | [ ['0'..'9'] 176 | , ['a'..'z'] 177 | , ['A'..'Z'] 178 | , "-_/\\*." 179 | ] 180 | 181 | encodedChars = [(printf "%%%02X" (ord x), x) | x <- ['\x00'..'\xFF']] 182 | 183 | plainChar = do 184 | x <- elements plainChars 185 | return ([x], x) 186 | encodedChar = elements encodedChars 187 | 188 | param = do 189 | key <- smallListOf1 (elements keyChars) 190 | value <- smallListOf1 (oneof [plainChar, encodedChar]) 191 | let (valueChunks, valueChars) = unzip value 192 | 193 | let str = key ++ "=" ++ concat (valueChunks) 194 | return (str, key, valueChars) 195 | 196 | gen = do 197 | params <- smallListOf param 198 | method <- if null params 199 | then smallListOf1 (elements methodChars) 200 | else smallListOf (elements methodChars) 201 | 202 | let paramStrs = [s | (s, _, _) <- params] 203 | let mapItems = [(k, v) | (_, k, v) <- params] 204 | 205 | let str = method ++ ":" ++ (intercalate "," paramStrs) 206 | 207 | return (str, method, Data.Map.fromList mapItems) 208 | 209 | gen_AddressesBytes :: Gen (String, [(String, Map String String)]) 210 | gen_AddressesBytes = do 211 | addrs <- smallListOf1 gen_AddressBytes 212 | let bytes = [b | (b, _, _) <- addrs] 213 | let expected = [(m, p) | (_, m, p) <- addrs] 214 | return (intercalate ";" bytes, expected) 215 | -------------------------------------------------------------------------------- /examples/dbus-monitor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- Copyright (C) 2009-2011 John Millikin 4 | -- 5 | -- Licensed under the Apache License, Version 2.0 (the "License"); 6 | -- you may not use this file except in compliance with the License. 7 | -- You may obtain a copy of the License at 8 | -- 9 | -- http://www.apache.org/licenses/LICENSE-2.0 10 | -- 11 | -- Unless required by applicable law or agreed to in writing, software 12 | -- distributed under the License is distributed on an "AS IS" BASIS, 13 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | -- See the License for the specific language governing permissions and 15 | -- limitations under the License. 16 | 17 | module Main (main) where 18 | 19 | import Control.Monad 20 | import Data.List (intercalate) 21 | import Data.Int 22 | import Data.Word 23 | import System.Environment 24 | import System.Exit 25 | import System.IO 26 | import System.Console.GetOpt 27 | 28 | import DBus 29 | import DBus.Socket 30 | 31 | data Bus = Session | System 32 | deriving (Show) 33 | 34 | data Option = BusOption Bus | AddressOption String 35 | deriving (Show) 36 | 37 | optionInfo :: [OptDescr Option] 38 | optionInfo = [ 39 | Option [] ["session"] (NoArg (BusOption Session)) 40 | "Monitor the session message bus. (default)" 41 | , Option [] ["system"] (NoArg (BusOption System)) 42 | "Monitor the system message bus." 43 | , Option [] ["address"] (ReqArg AddressOption "ADDRESS") 44 | "Connect to a particular bus address." 45 | ] 46 | 47 | usage :: String -> String 48 | usage name = "Usage: " ++ name ++ " [OPTION...]" 49 | 50 | findSocket :: [Option] -> IO Socket 51 | findSocket opts = getAddress opts >>= open where 52 | session = do 53 | got <- getSessionAddress 54 | case got of 55 | Just addr -> return addr 56 | Nothing -> error "DBUS_SESSION_BUS_ADDRESS is not a valid address" 57 | 58 | system = do 59 | got <- getSystemAddress 60 | case got of 61 | Just addr -> return addr 62 | Nothing -> error "DBUS_SYSTEM_BUS_ADDRESS is not a valid address" 63 | 64 | getAddress [] = session 65 | getAddress ((BusOption Session):_) = session 66 | getAddress ((BusOption System):_) = system 67 | getAddress ((AddressOption addr):_) = case parseAddress addr of 68 | Nothing -> error (show addr ++ " is not a valid address") 69 | Just parsed -> return parsed 70 | 71 | addMatch :: Socket -> String -> IO () 72 | addMatch sock match = send sock (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "AddMatch") 73 | { methodCallDestination = Just "org.freedesktop.DBus" 74 | , methodCallBody = [toVariant match] 75 | } (\_ -> return ()) 76 | 77 | defaultFilters :: [String] 78 | defaultFilters = 79 | [ "type='signal',eavesdrop=true" 80 | , "type='method_call',eavesdrop=true" 81 | , "type='method_return',eavesdrop=true" 82 | , "type='error',eavesdrop=true" 83 | ] 84 | 85 | main :: IO () 86 | main = do 87 | args <- getArgs 88 | let (options, userFilters, errors) = getOpt Permute optionInfo args 89 | unless (null errors) $ do 90 | name <- getProgName 91 | hPutStrLn stderr (concat errors) 92 | hPutStrLn stderr (usageInfo (usage name) optionInfo) 93 | exitFailure 94 | 95 | sock <- findSocket options 96 | 97 | send sock (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "Hello") 98 | { methodCallDestination = Just "org.freedesktop.DBus" 99 | } (\_ -> return ()) 100 | 101 | mapM_ (addMatch sock) (if null userFilters then defaultFilters else userFilters) 102 | 103 | forever $ do 104 | received <- receive sock 105 | putStrLn (formatMessage received ++ "\n") 106 | 107 | -- Message formatting is verbose and mostly uninteresting, except as an 108 | -- excersise in string manipulation. 109 | 110 | formatMessage :: ReceivedMessage -> String 111 | 112 | -- Method call 113 | formatMessage (ReceivedMethodCall serial msg) = concat 114 | [ "method call" 115 | , " sender=" 116 | , maybe "(null)" formatBusName (methodCallSender msg) 117 | , " -> dest=" 118 | , maybe "(null)" formatBusName (methodCallDestination msg) 119 | , " serial=" 120 | , show (serialValue serial) 121 | , " path=" 122 | , formatObjectPath (methodCallPath msg) 123 | , "; interface=" 124 | , maybe "(null)" formatInterfaceName (methodCallInterface msg) 125 | , "; member=" 126 | , formatMemberName (methodCallMember msg) 127 | , formatBody (methodCallBody msg) 128 | ] 129 | 130 | -- Method return 131 | formatMessage (ReceivedMethodReturn _ msg) = concat 132 | [ "method return" 133 | , " sender=" 134 | , maybe "(null)" formatBusName (methodReturnSender msg) 135 | , " -> dest=" 136 | , maybe "(null)" formatBusName (methodReturnDestination msg) 137 | , " reply_serial=" 138 | , show (serialValue (methodReturnSerial msg)) 139 | , formatBody (methodReturnBody msg) 140 | ] 141 | 142 | -- Method error 143 | formatMessage (ReceivedMethodError _ msg) = concat 144 | [ "error" 145 | , " sender=" 146 | , maybe "(null)" formatBusName (methodErrorSender msg) 147 | , " -> dest=" 148 | , maybe "(null)" formatBusName (methodErrorDestination msg) 149 | , " error_name=" 150 | , formatErrorName (methodErrorName msg) 151 | , " reply_serial=" 152 | , show (serialValue (methodErrorSerial msg)) 153 | , formatBody (methodErrorBody msg) 154 | ] 155 | 156 | -- Signal 157 | formatMessage (ReceivedSignal serial msg) = concat 158 | [ "signal" 159 | , " sender=" 160 | , maybe "(null)" formatBusName (signalSender msg) 161 | , " -> dest=" 162 | , maybe "(null)" formatBusName (signalDestination msg) 163 | , " serial=" 164 | , show (serialValue serial) 165 | , " path=" 166 | , formatObjectPath (signalPath msg) 167 | , "; interface=" 168 | , formatInterfaceName (signalInterface msg) 169 | , "; member=" 170 | , formatMemberName (signalMember msg) 171 | , formatBody (signalBody msg) 172 | ] 173 | 174 | formatMessage msg = concat 175 | [ "unknown" 176 | , " sender=" 177 | , maybe "(null)" formatBusName (receivedMessageSender msg) 178 | , " serial=" 179 | , show (serialValue (receivedMessageSerial msg)) 180 | , formatBody (receivedMessageBody msg) 181 | ] 182 | 183 | formatBody :: [Variant] -> String 184 | formatBody body = formatted where 185 | tree = Children (map formatVariant body) 186 | formatted = intercalate "\n" ("" : collapseTree 0 tree) 187 | 188 | -- A string tree allows easy indentation of nested structures 189 | data StringTree = Line String | MultiLine [StringTree] | Children [StringTree] 190 | deriving (Show) 191 | 192 | collapseTree :: Int -> StringTree -> [String] 193 | collapseTree d (Line x) = [replicate (d*3) ' ' ++ x] 194 | collapseTree d (MultiLine xs) = concatMap (collapseTree d) xs 195 | collapseTree d (Children xs) = concatMap (collapseTree (d + 1)) xs 196 | 197 | -- Formatting for various kinds of variants, keyed to their signature type. 198 | formatVariant :: Variant -> StringTree 199 | formatVariant x = case variantType x of 200 | 201 | TypeBoolean -> Line $ let 202 | Just x' = fromVariant x 203 | in "boolean " ++ if x' then "true" else "false" 204 | 205 | TypeWord8 -> Line $ let 206 | Just x' = fromVariant x 207 | in "byte " ++ show (x' :: Word8) 208 | 209 | TypeWord16 -> Line $ let 210 | Just x' = fromVariant x 211 | in "uint16 " ++ show (x' :: Word16) 212 | 213 | TypeWord32 -> Line $ let 214 | Just x' = fromVariant x 215 | in "uint32 " ++ show (x' :: Word32) 216 | 217 | TypeWord64 -> Line $ let 218 | Just x' = fromVariant x 219 | in "uint64 " ++ show (x' :: Word64) 220 | 221 | TypeInt16 -> Line $ let 222 | Just x' = fromVariant x 223 | in "int16 " ++ show (x' :: Int16) 224 | 225 | TypeInt32 -> Line $ let 226 | Just x' = fromVariant x 227 | in "int32 " ++ show (x' :: Int32) 228 | 229 | TypeInt64 -> Line $ let 230 | Just x' = fromVariant x 231 | in "int64 " ++ show (x' :: Int64) 232 | 233 | TypeDouble -> Line $ let 234 | Just x' = fromVariant x 235 | in "double " ++ show (x' :: Double) 236 | 237 | TypeString -> Line $ let 238 | Just x' = fromVariant x 239 | in "string " ++ show (x' :: String) 240 | 241 | TypeObjectPath -> Line $ let 242 | Just x' = fromVariant x 243 | in "object path " ++ show (formatObjectPath x') 244 | 245 | TypeSignature -> Line $ let 246 | Just x' = fromVariant x 247 | in "signature " ++ show (formatSignature x') 248 | 249 | TypeArray _ -> MultiLine $ let 250 | Just x' = fromVariant x 251 | items = arrayItems x' 252 | lines' = [ Line "array [" 253 | , Children (map formatVariant items) 254 | , Line "]" 255 | ] 256 | in lines' 257 | 258 | TypeDictionary _ _ -> MultiLine $ let 259 | Just x' = fromVariant x 260 | items = dictionaryItems x' 261 | lines' = [ Line "dictionary {" 262 | , Children (map formatItem items) 263 | , Line "}" 264 | ] 265 | formatItem (k, v) = MultiLine (firstLine : vTail) where 266 | Line k' = formatVariant k 267 | v' = collapseTree 0 (formatVariant v) 268 | vHead = head v' 269 | vTail = map Line (tail v') 270 | firstLine = Line (k' ++ " -> " ++ vHead) 271 | in lines' 272 | 273 | TypeStructure _ -> MultiLine $ let 274 | Just x' = fromVariant x 275 | items = structureItems x' 276 | lines' = [ Line "struct (" 277 | , Children (map formatVariant items) 278 | , Line ")" 279 | ] 280 | in lines' 281 | 282 | TypeVariant -> let 283 | Just x' = fromVariant x 284 | in MultiLine [Line "variant", Children [formatVariant x']] 285 | -------------------------------------------------------------------------------- /lib/DBus.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (C) 2009-2012 John Millikin 2 | -- 3 | -- Licensed under the Apache License, Version 2.0 (the "License"); 4 | -- you may not use this file except in compliance with the License. 5 | -- You may obtain a copy of the License at 6 | -- 7 | -- http://www.apache.org/licenses/LICENSE-2.0 8 | -- 9 | -- Unless required by applicable law or agreed to in writing, software 10 | -- distributed under the License is distributed on an "AS IS" BASIS, 11 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | -- See the License for the specific language governing permissions and 13 | -- limitations under the License. 14 | 15 | -- | Basic types, useful to every D-Bus application. 16 | -- 17 | -- Authors of client applications should import "DBus.Client", which provides 18 | -- an easy RPC-oriented interface to D-Bus methods and signals. 19 | module DBus 20 | ( 21 | -- * Messages 22 | Message 23 | 24 | -- ** Method calls 25 | , MethodCall 26 | , methodCall 27 | , methodCallPath 28 | , methodCallInterface 29 | , methodCallMember 30 | , methodCallSender 31 | , methodCallDestination 32 | , methodCallAutoStart 33 | , methodCallReplyExpected 34 | , methodCallBody 35 | 36 | -- ** Method returns 37 | , MethodReturn 38 | , methodReturn 39 | , methodReturnSerial 40 | , methodReturnSender 41 | , methodReturnDestination 42 | , methodReturnBody 43 | 44 | -- ** Method errors 45 | , MethodError 46 | , methodError 47 | , methodErrorName 48 | , methodErrorSerial 49 | , methodErrorSender 50 | , methodErrorDestination 51 | , methodErrorBody 52 | , methodErrorMessage 53 | 54 | -- ** Signals 55 | , Signal 56 | , signal 57 | , signalPath 58 | , signalMember 59 | , signalInterface 60 | , signalSender 61 | , signalDestination 62 | , signalBody 63 | 64 | -- ** Received messages 65 | , ReceivedMessage(ReceivedMethodCall, ReceivedMethodReturn, ReceivedMethodError, ReceivedSignal) 66 | , receivedMessageSerial 67 | , receivedMessageSender 68 | , receivedMessageBody 69 | 70 | -- * Variants 71 | , Variant 72 | , IsVariant(..) 73 | , variantType 74 | 75 | , IsAtom 76 | , IsValue 77 | , typeOf 78 | , typeOf' 79 | 80 | -- * Signatures 81 | , Signature 82 | , Type(..) 83 | , signature 84 | , signature_ 85 | , signatureTypes 86 | , formatSignature 87 | , parseSignature 88 | 89 | -- * Object paths 90 | , ObjectPath 91 | , objectPath_ 92 | , formatObjectPath 93 | , parseObjectPath 94 | 95 | -- * Names 96 | 97 | -- ** Interface names 98 | , InterfaceName 99 | , interfaceName_ 100 | , formatInterfaceName 101 | , parseInterfaceName 102 | 103 | -- ** Member names 104 | , MemberName 105 | , memberName_ 106 | , formatMemberName 107 | , parseMemberName 108 | 109 | -- ** Error names 110 | , ErrorName 111 | , errorName_ 112 | , formatErrorName 113 | , parseErrorName 114 | 115 | -- ** Bus names 116 | , BusName 117 | , busName_ 118 | , formatBusName 119 | , parseBusName 120 | 121 | -- * Non-native containers 122 | 123 | -- ** Structures 124 | , Structure 125 | , structureItems 126 | 127 | -- ** Arrays 128 | , Array 129 | , arrayItems 130 | 131 | -- ** Dictionaries 132 | , Dictionary 133 | , dictionaryItems 134 | 135 | -- * Addresses 136 | , Address 137 | , addressMethod 138 | , addressParameters 139 | , address 140 | , formatAddress 141 | , formatAddresses 142 | , parseAddress 143 | , parseAddresses 144 | , getSystemAddress 145 | , getSessionAddress 146 | , getStarterAddress 147 | 148 | -- * Message marshaling 149 | , Endianness (..) 150 | 151 | -- ** Marshal 152 | , marshal 153 | , marshalWithFds 154 | , MarshalError 155 | , marshalErrorMessage 156 | 157 | -- ** Unmarshal 158 | , unmarshal 159 | , unmarshalWithFds 160 | , UnmarshalError 161 | , unmarshalErrorMessage 162 | 163 | -- ** Message serials 164 | , Serial 165 | , serialValue 166 | , firstSerial 167 | , nextSerial 168 | 169 | -- * D-Bus UUIDs 170 | , UUID 171 | , formatUUID 172 | , randomUUID 173 | ) where 174 | 175 | import Control.Monad (replicateM) 176 | import qualified Data.ByteString.Char8 as Char8 177 | import Data.Proxy (Proxy(..)) 178 | import Data.Word (Word16) 179 | import System.Posix.Types (Fd) 180 | import System.Random (randomRIO) 181 | import Text.Printf (printf) 182 | 183 | import DBus.Internal.Address 184 | import DBus.Internal.Message 185 | import qualified DBus.Internal.Types 186 | import DBus.Internal.Types hiding (typeOf) 187 | import DBus.Internal.Wire 188 | 189 | -- | Deprecated. Get the D-Bus type corresponding to the given Haskell value. The value 190 | -- may be @undefined@. 191 | typeOf :: IsValue a => a -> Type 192 | typeOf = DBus.Internal.Types.typeOf 193 | 194 | -- | Get the D-Bus type corresponding to the given Haskell type 'a'. 195 | typeOf' :: IsValue a => Proxy a -> Type 196 | typeOf' = DBus.Internal.Types.typeOf_ 197 | 198 | -- | Construct a new 'MethodCall' for the given object, interface, and method. 199 | -- 200 | -- Use fields such as 'methodCallDestination' and 'methodCallBody' to populate 201 | -- a 'MethodCall'. 202 | -- 203 | -- @ 204 | --{-\# LANGUAGE OverloadedStrings \#-} 205 | -- 206 | --methodCall \"/\" \"org.example.Math\" \"Add\" 207 | -- { 'methodCallDestination' = Just \"org.example.Calculator\" 208 | -- , 'methodCallBody' = ['toVariant' (1 :: Int32), 'toVariant' (2 :: Int32)] 209 | -- } 210 | -- @ 211 | methodCall :: ObjectPath -> InterfaceName -> MemberName -> MethodCall 212 | methodCall path iface member = MethodCall path (Just iface) member Nothing Nothing True True [] 213 | 214 | -- | Construct a new 'MethodReturn', in reply to a method call with the given 215 | -- serial. 216 | -- 217 | -- Use fields such as 'methodReturnBody' to populate a 'MethodReturn'. 218 | methodReturn :: Serial -> MethodReturn 219 | methodReturn s = MethodReturn s Nothing Nothing [] 220 | 221 | -- | Construct a new 'MethodError', in reply to a method call with the given 222 | -- serial. 223 | -- 224 | -- Use fields such as 'methodErrorBody' to populate a 'MethodError'. 225 | methodError :: Serial -> ErrorName -> MethodError 226 | methodError s name = MethodError name s Nothing Nothing [] 227 | 228 | -- | Construct a new 'Signal' for the given object, interface, and signal name. 229 | -- 230 | -- Use fields such as 'signalBody' to populate a 'Signal'. 231 | signal :: ObjectPath -> InterfaceName -> MemberName -> Signal 232 | signal path iface member = Signal path iface member Nothing Nothing [] 233 | 234 | -- | No matter what sort of message was received, get its serial. 235 | receivedMessageSerial :: ReceivedMessage -> Serial 236 | receivedMessageSerial (ReceivedMethodCall s _) = s 237 | receivedMessageSerial (ReceivedMethodReturn s _) = s 238 | receivedMessageSerial (ReceivedMethodError s _) = s 239 | receivedMessageSerial (ReceivedSignal s _) = s 240 | receivedMessageSerial (ReceivedUnknown s _) = s 241 | 242 | -- | No matter what sort of message was received, get its sender (if provided). 243 | receivedMessageSender :: ReceivedMessage -> Maybe BusName 244 | receivedMessageSender (ReceivedMethodCall _ msg) = methodCallSender msg 245 | receivedMessageSender (ReceivedMethodReturn _ msg) = methodReturnSender msg 246 | receivedMessageSender (ReceivedMethodError _ msg) = methodErrorSender msg 247 | receivedMessageSender (ReceivedSignal _ msg) = signalSender msg 248 | receivedMessageSender (ReceivedUnknown _ msg) = unknownMessageSender msg 249 | 250 | -- | No matter what sort of message was received, get its body (if provided). 251 | receivedMessageBody :: ReceivedMessage -> [Variant] 252 | receivedMessageBody (ReceivedMethodCall _ msg) = methodCallBody msg 253 | receivedMessageBody (ReceivedMethodReturn _ msg) = methodReturnBody msg 254 | receivedMessageBody (ReceivedMethodError _ msg) = methodErrorBody msg 255 | receivedMessageBody (ReceivedSignal _ msg) = signalBody msg 256 | receivedMessageBody (ReceivedUnknown _ msg) = unknownMessageBody msg 257 | 258 | -- | Convert a 'Message' into a 'Char8.ByteString'. Although unusual, it is 259 | -- possible for marshaling to fail; if this occurs, an error will be 260 | -- returned instead. 261 | marshal :: Message msg => Endianness -> Serial -> msg -> Either MarshalError Char8.ByteString 262 | marshal end serial msg = fst <$> marshalWithFds end serial msg 263 | 264 | -- | Convert a 'Message' into a 'Char8.ByteString' along with all 'Fd' values 265 | -- mentioned in the message (the marshaled bytes will contain indices into 266 | -- this list). Although unusual, it is possible for marshaling to fail; if this 267 | -- occurs, an error will be returned instead. 268 | marshalWithFds :: Message msg => Endianness -> Serial -> msg -> Either MarshalError (Char8.ByteString, [Fd]) 269 | marshalWithFds = marshalMessage 270 | 271 | -- | Parse a 'Char8.ByteString' into a 'ReceivedMessage'. The result can be 272 | -- inspected to see what type of message was parsed. Unknown message types 273 | -- can still be parsed successfully, as long as they otherwise conform to 274 | -- the D-Bus standard. 275 | -- 276 | -- Unmarshaling will fail if the message contains file descriptors. If you 277 | -- need file descriptor support then use 'unmarshalWithFds' instead. 278 | unmarshal :: Char8.ByteString -> Either UnmarshalError ReceivedMessage 279 | unmarshal bs = unmarshalWithFds bs [] 280 | 281 | -- | Parse a 'Char8.ByteString' into a 'ReceivedMessage'. The 'Fd' values are needed 282 | -- because the marshaled message contains indices into the 'Fd' list rather then 283 | -- 'Fd' values directly. The result can be inspected to see what type of message 284 | -- was parsed. Unknown message types can still be parsed successfully, as long 285 | -- as they otherwise conform to the D-Bus standard. 286 | unmarshalWithFds :: Char8.ByteString -> [Fd] -> Either UnmarshalError ReceivedMessage 287 | unmarshalWithFds = unmarshalMessage 288 | 289 | -- | A D-Bus UUID is 128 bits of data, usually randomly generated. They are 290 | -- used for identifying unique server instances to clients. 291 | -- 292 | -- Older versions of the D-Bus spec also called these values /GUIDs/. 293 | -- 294 | -- D-Bus UUIDs are not the same as the RFC-standardized UUIDs or GUIDs. 295 | newtype UUID = UUID Char8.ByteString 296 | deriving (Eq, Ord, Show) 297 | 298 | -- | Format a D-Bus UUID as hex-encoded ASCII. 299 | formatUUID :: UUID -> String 300 | formatUUID (UUID bytes) = Char8.unpack bytes 301 | 302 | -- | Generate a random D-Bus UUID. This value is suitable for use in a 303 | -- randomly-allocated address, or as a listener's socket address 304 | -- @\"guid\"@ parameter. 305 | randomUUID :: IO UUID 306 | randomUUID = do 307 | -- The version of System.Random bundled with ghc < 7.2 doesn't define 308 | -- instances for any of the fixed-length word types, so we imitate 309 | -- them using the instance for Int. 310 | -- 311 | -- 128 bits is 8 16-bit integers. We use chunks of 16 instead of 32 312 | -- because Int is not guaranteed to be able to store a Word32. 313 | let hexInt16 i = printf "%04x" (i :: Int) 314 | int16s <- replicateM 8 (randomRIO (0, fromIntegral (maxBound :: Word16))) 315 | return (UUID (Char8.pack (concatMap hexInt16 int16s))) 316 | -------------------------------------------------------------------------------- /tests/DBusTests/Util.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (C) 2010-2012 John Millikin 2 | -- 3 | -- Licensed under the Apache License, Version 2.0 (the "License"); 4 | -- you may not use this file except in compliance with the License. 5 | -- You may obtain a copy of the License at 6 | -- 7 | -- http://www.apache.org/licenses/LICENSE-2.0 8 | -- 9 | -- Unless required by applicable law or agreed to in writing, software 10 | -- distributed under the License is distributed on an "AS IS" BASIS, 11 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | -- See the License for the specific language governing permissions and 13 | -- limitations under the License. 14 | 15 | module DBusTests.Util 16 | ( assertVariant 17 | , assertValue 18 | , assertAtom 19 | , assertException 20 | , assertThrows 21 | 22 | , nonWindowsTestCase 23 | 24 | , getTempPath 25 | , withTempFd 26 | , listenRandomUnixPath 27 | , listenRandomUnixAbstract 28 | , listenRandomIPv4 29 | , listenRandomIPv6 30 | , noIPv6 31 | , forkVar 32 | 33 | , withEnv 34 | , countFileDescriptors 35 | 36 | , dropWhileEnd 37 | 38 | , halfSized 39 | , clampedSize 40 | , smallListOf 41 | , smallListOf1 42 | 43 | , DBusTests.Util.requireLeft 44 | , DBusTests.Util.requireRight 45 | ) where 46 | 47 | import Control.Concurrent 48 | import Control.Exception (Exception, IOException, try, bracket, bracket_) 49 | import Control.Monad.IO.Class (MonadIO, liftIO) 50 | import Control.Monad.Trans.Resource 51 | import Data.Bits ((.&.)) 52 | import Data.Char (chr) 53 | import System.Directory (getTemporaryDirectory, removeFile) 54 | import System.FilePath (()) 55 | import System.IO.Temp (withSystemTempFile) 56 | import System.Posix (Fd, closeFd, handleToFd) 57 | import Test.QuickCheck hiding ((.&.)) 58 | import Test.Tasty 59 | import Test.Tasty.HUnit 60 | import qualified Data.ByteString 61 | import qualified Data.ByteString.Lazy 62 | import qualified Data.Map as Map 63 | import qualified Data.Text as T 64 | import qualified Network.Socket as NS 65 | import qualified System.Info 66 | import qualified System.Posix as Posix 67 | 68 | import DBus 69 | import DBus.Internal.Types 70 | 71 | assertVariant :: (Eq a, Show a, IsVariant a) => Type -> a -> Test.Tasty.HUnit.Assertion 72 | assertVariant t a = do 73 | t @=? variantType (toVariant a) 74 | Just a @=? fromVariant (toVariant a) 75 | toVariant a @=? toVariant a 76 | 77 | assertValue :: (Eq a, Show a, IsValue a) => Type -> a -> Test.Tasty.HUnit.Assertion 78 | assertValue t a = do 79 | t @=? DBus.typeOf a 80 | t @=? DBus.Internal.Types.typeOf a 81 | t @=? valueType (toValue a) 82 | fromValue (toValue a) @?= Just a 83 | toValue a @=? toValue a 84 | assertVariant t a 85 | 86 | assertAtom :: (Eq a, Show a, IsAtom a) => Type -> a -> Test.Tasty.HUnit.Assertion 87 | assertAtom t a = do 88 | t @=? (atomType (toAtom a)) 89 | fromAtom (toAtom a) @?= (Just a) 90 | toAtom a @=? toAtom a 91 | assertValue t a 92 | 93 | getTempPath :: IO String 94 | getTempPath = do 95 | tmp <- getTemporaryDirectory 96 | uuid <- randomUUID 97 | return (tmp formatUUID uuid) 98 | 99 | withTempFd :: (Fd -> IO ()) -> IO () 100 | withTempFd cmd = 101 | withSystemTempFile "haskell-dbus" $ \_path handle -> do 102 | bracket (handleToFd handle) closeFd cmd 103 | 104 | listenRandomUnixPath :: MonadResource m => m Address 105 | listenRandomUnixPath = do 106 | path <- liftIO getTempPath 107 | 108 | let sockAddr = NS.SockAddrUnix path 109 | (_, sock) <- allocate 110 | (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol) 111 | NS.close 112 | liftIO (NS.bind sock sockAddr) 113 | liftIO (NS.listen sock 1) 114 | _ <- register (removeFile path) 115 | 116 | let Just addr = address "unix" (Map.fromList 117 | [ ("path", path) 118 | ]) 119 | return addr 120 | 121 | listenRandomUnixAbstract :: MonadResource m => m (Address, NS.Socket, ReleaseKey) 122 | listenRandomUnixAbstract = do 123 | uuid <- liftIO randomUUID 124 | let sockAddr = NS.SockAddrUnix ('\x00' : formatUUID uuid) 125 | 126 | (key, sock) <- allocate 127 | (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol) 128 | NS.close 129 | 130 | liftIO $ NS.bind sock sockAddr 131 | liftIO $ NS.listen sock 1 132 | 133 | let Just addr = address "unix" (Map.fromList 134 | [ ("abstract", formatUUID uuid) 135 | ]) 136 | return (addr, sock, key) 137 | 138 | listenRandomIPv4 :: MonadResource m => m (Address, NS.Socket, ReleaseKey) 139 | listenRandomIPv4 = do 140 | let hints = NS.defaultHints 141 | { NS.addrFlags = [NS.AI_NUMERICHOST] 142 | , NS.addrFamily = NS.AF_INET 143 | , NS.addrSocketType = NS.Stream 144 | } 145 | hostAddr <- liftIO $ NS.getAddrInfo (Just hints) (Just "127.0.0.1") Nothing 146 | let sockAddr = NS.addrAddress $ head hostAddr 147 | 148 | (key, sock) <- allocate 149 | (NS.socket NS.AF_INET NS.Stream NS.defaultProtocol) 150 | NS.close 151 | liftIO $ NS.bind sock sockAddr 152 | liftIO $ NS.listen sock 1 153 | 154 | sockPort <- liftIO $ NS.socketPort sock 155 | let Just addr = address "tcp" (Map.fromList 156 | [ ("family", "ipv4") 157 | , ("host", "localhost") 158 | , ("port", show (toInteger sockPort)) 159 | ]) 160 | return (addr, sock, key) 161 | 162 | listenRandomIPv6 :: MonadResource m => m Address 163 | listenRandomIPv6 = do 164 | addrs <- liftIO $ NS.getAddrInfo Nothing (Just "::1") Nothing 165 | let sockAddr = case addrs of 166 | [] -> error "listenRandomIPv6: no address for localhost?" 167 | a:_ -> NS.addrAddress a 168 | 169 | (_, sock) <- allocate 170 | (NS.socket NS.AF_INET6 NS.Stream NS.defaultProtocol) 171 | NS.close 172 | liftIO $ NS.bind sock sockAddr 173 | liftIO $ NS.listen sock 1 174 | 175 | sockPort <- liftIO $ NS.socketPort sock 176 | let Just addr = address "tcp" (Map.fromList 177 | [ ("family", "ipv6") 178 | , ("host", "::1") 179 | , ("port", show (toInteger sockPort)) 180 | ]) 181 | return addr 182 | 183 | noIPv6 :: IO Bool 184 | noIPv6 = do 185 | tried <- try (NS.getAddrInfo Nothing (Just "::1") Nothing) 186 | case (tried :: Either IOException [NS.AddrInfo]) of 187 | Left _ -> return True 188 | Right addrs -> return (null addrs) 189 | 190 | forkVar :: MonadIO m => IO a -> m (MVar a) 191 | forkVar io = liftIO $ do 192 | var <- newEmptyMVar 193 | _ <- forkIO (io >>= putMVar var) 194 | return var 195 | 196 | withEnv :: MonadIO m => String -> Maybe String -> IO a -> m a 197 | withEnv name value io = liftIO $ do 198 | let set val = case val of 199 | Just x -> Posix.setEnv name x True 200 | Nothing -> Posix.unsetEnv name 201 | old <- Posix.getEnv name 202 | bracket_ (set value) (set old) io 203 | 204 | countFileDescriptors :: MonadIO m => m Int 205 | countFileDescriptors = liftIO io where 206 | io = do 207 | pid <- Posix.getProcessID 208 | let fdDir = "/proc/" ++ show pid ++ "/fd" 209 | bracket (Posix.openDirStream fdDir) Posix.closeDirStream countDirEntries 210 | countDirEntries dir = loop 0 where 211 | loop n = do 212 | name <- Posix.readDirStream dir 213 | if null name 214 | then return n 215 | else loop (n + 1) 216 | 217 | halfSized :: Gen a -> Gen a 218 | halfSized gen = sized (\n -> if n > 0 219 | then resize (div n 2) gen 220 | else gen) 221 | 222 | smallListOf :: Gen a -> Gen [a] 223 | smallListOf gen = clampedSize 10 (listOf gen) 224 | 225 | smallListOf1 :: Gen a -> Gen [a] 226 | smallListOf1 gen = clampedSize 10 (listOf1 gen) 227 | 228 | clampedSize :: Int -> Gen a -> Gen a 229 | clampedSize maxN gen = sized (\n -> resize (min n maxN) gen) 230 | 231 | instance Arbitrary T.Text where 232 | arbitrary = fmap T.pack genUnicode 233 | 234 | genUnicode :: Gen [Char] 235 | genUnicode = string where 236 | string = sized $ \n -> do 237 | k <- choose (0,n) 238 | sequence [ char | _ <- [1..k] ] 239 | 240 | excluding :: [a -> Bool] -> Gen a -> Gen a 241 | excluding bad gen = loop where 242 | loop = do 243 | x <- gen 244 | if or (map ($ x) bad) 245 | then loop 246 | else return x 247 | 248 | reserved = [lowSurrogate, highSurrogate, noncharacter] 249 | lowSurrogate c = c >= 0xDC00 && c <= 0xDFFF 250 | highSurrogate c = c >= 0xD800 && c <= 0xDBFF 251 | noncharacter c = masked == 0xFFFE || masked == 0xFFFF where 252 | masked = c .&. 0xFFFF 253 | 254 | ascii = choose (0x20, 0x7F) 255 | plane0 = choose (0xF0, 0xFFFF) 256 | plane1 = oneof [ choose (0x10000, 0x10FFF) 257 | , choose (0x11000, 0x11FFF) 258 | , choose (0x12000, 0x12FFF) 259 | , choose (0x13000, 0x13FFF) 260 | , choose (0x1D000, 0x1DFFF) 261 | , choose (0x1F000, 0x1FFFF) 262 | ] 263 | plane2 = oneof [ choose (0x20000, 0x20FFF) 264 | , choose (0x21000, 0x21FFF) 265 | , choose (0x22000, 0x22FFF) 266 | , choose (0x23000, 0x23FFF) 267 | , choose (0x24000, 0x24FFF) 268 | , choose (0x25000, 0x25FFF) 269 | , choose (0x26000, 0x26FFF) 270 | , choose (0x27000, 0x27FFF) 271 | , choose (0x28000, 0x28FFF) 272 | , choose (0x29000, 0x29FFF) 273 | , choose (0x2A000, 0x2AFFF) 274 | , choose (0x2B000, 0x2BFFF) 275 | , choose (0x2F000, 0x2FFFF) 276 | ] 277 | plane14 = choose (0xE0000, 0xE0FFF) 278 | planes = [ascii, plane0, plane1, plane2, plane14] 279 | 280 | char = chr `fmap` excluding reserved (oneof planes) 281 | 282 | instance Arbitrary Data.ByteString.ByteString where 283 | arbitrary = fmap Data.ByteString.pack arbitrary 284 | 285 | instance Arbitrary Data.ByteString.Lazy.ByteString where 286 | arbitrary = fmap Data.ByteString.Lazy.fromChunks arbitrary 287 | 288 | dropWhileEnd :: (Char -> Bool) -> String -> String 289 | dropWhileEnd p = T.unpack . T.dropWhileEnd p . T.pack 290 | 291 | requireLeft :: Show b => Either a b -> IO a 292 | requireLeft (Left a) = return a 293 | requireLeft (Right b) = assertFailure ("Right " ++ show b ++ " is not Left") >> undefined 294 | 295 | requireRight :: Show a => Either a b -> IO b 296 | requireRight (Right b) = return b 297 | requireRight (Left a) = assertFailure ("Left " ++ show a ++ " is not Right") >> undefined 298 | 299 | assertException :: (Eq e, Exception e) => e -> IO a -> Test.Tasty.HUnit.Assertion 300 | assertException e f = do 301 | result <- try f 302 | case result of 303 | Left ex -> ex @?= e 304 | Right _ -> assertFailure "expected exception not thrown" 305 | 306 | assertThrows :: Exception e => (e -> Bool) -> IO a -> Test.Tasty.HUnit.Assertion 307 | assertThrows check f = do 308 | result <- try f 309 | case result of 310 | Left ex -> assertBool ("unexpected exception " ++ show ex) (check ex) 311 | Right _ -> assertFailure "expected exception not thrown" 312 | 313 | nonWindowsTestCase :: TestName -> Assertion -> TestTree 314 | nonWindowsTestCase name assertion = testCase name $ do 315 | case System.Info.os of 316 | "mingw32" -> pure () 317 | _ -> assertion 318 | -------------------------------------------------------------------------------- /license.txt: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /lib/DBus/Internal/Message.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (C) 2009-2012 John Millikin 2 | -- 3 | -- This program is free software: you can redistribute it and/or modify 4 | -- it under the terms of the GNU General Public License as published by 5 | -- the Free Software Foundation, either version 3 of the License, or 6 | -- any later version. 7 | -- 8 | -- This program is distributed in the hope that it will be useful, 9 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | -- GNU General Public License for more details. 12 | -- 13 | -- You should have received a copy of the GNU General Public License 14 | -- along with this program. If not, see . 15 | 16 | module DBus.Internal.Message 17 | ( Message(..) 18 | 19 | , UnknownMessage(..) 20 | , MethodCall(..) 21 | , MethodReturn(..) 22 | , MethodError(..) 23 | , methodErrorMessage 24 | , Signal(..) 25 | , ReceivedMessage(..) 26 | 27 | -- for use in Wire 28 | , HeaderField(..) 29 | , setMethodCallFlags 30 | ) where 31 | 32 | import Data.Bits ((.|.), (.&.)) 33 | import Data.Maybe (fromMaybe, listToMaybe) 34 | import Data.Word (Word8, Word32) 35 | 36 | import DBus.Internal.Types 37 | 38 | class Message a where 39 | messageTypeCode :: a -> Word8 40 | messageHeaderFields :: a -> [HeaderField] 41 | messageBody :: a -> [Variant] 42 | 43 | messageFlags :: a -> Word8 44 | messageFlags _ = 0 45 | 46 | maybe' :: (a -> b) -> Maybe a -> [b] 47 | maybe' f = maybe [] (\x' -> [f x']) 48 | 49 | data UnknownMessage = UnknownMessage 50 | { unknownMessageType :: Word8 51 | , unknownMessageSender :: Maybe BusName 52 | , unknownMessageBody :: [Variant] 53 | } 54 | deriving (Show, Eq) 55 | 56 | data HeaderField 57 | = HeaderPath ObjectPath 58 | | HeaderInterface InterfaceName 59 | | HeaderMember MemberName 60 | | HeaderErrorName ErrorName 61 | | HeaderReplySerial Serial 62 | | HeaderDestination BusName 63 | | HeaderSender BusName 64 | | HeaderSignature Signature 65 | | HeaderUnixFds Word32 66 | deriving (Show, Eq) 67 | 68 | -- | A method call is a request to run some procedure exported by the 69 | -- remote process. Procedures are identified by an (object_path, 70 | -- interface_name, method_name) tuple. 71 | data MethodCall = MethodCall 72 | { 73 | -- | The object path of the method call. Conceptually, object paths 74 | -- act like a procedural language's pointers. Each object referenced 75 | -- by a path is a collection of procedures. 76 | methodCallPath :: ObjectPath 77 | 78 | -- | The interface of the method call. Each object may implement any 79 | -- number of interfaces. Each method is part of at least one 80 | -- interface. 81 | -- 82 | -- In certain cases, this may be @Nothing@, but most users should set 83 | -- it to a value. 84 | , methodCallInterface :: Maybe InterfaceName 85 | 86 | -- | The method name of the method call. Method names are unique within 87 | -- an interface, but might not be unique within an object. 88 | , methodCallMember :: MemberName 89 | 90 | -- | The name of the application that sent this call. 91 | -- 92 | -- Most users will just leave this empty, because the bus overwrites 93 | -- the sender for security reasons. Setting the sender manually is 94 | -- used for peer-peer connections. 95 | -- 96 | -- Defaults to @Nothing@. 97 | , methodCallSender :: Maybe BusName 98 | 99 | -- | The name of the application to send the call to. 100 | -- 101 | -- Most users should set this. If a message with no destination is 102 | -- sent to the bus, the bus will behave as if the destination was 103 | -- set to @org.freedesktop.DBus@. For peer-peer connections, the 104 | -- destination can be empty because there is only one peer. 105 | -- 106 | -- Defaults to @Nothing@. 107 | , methodCallDestination :: Maybe BusName 108 | 109 | -- | Set whether a reply is expected. This can save network and cpu 110 | -- resources by inhibiting unnecessary replies. 111 | -- 112 | -- Defaults to @True@. 113 | , methodCallReplyExpected :: Bool 114 | 115 | -- | Set whether the bus should auto-start the remote 116 | -- 117 | -- Defaults to @True@. 118 | , methodCallAutoStart :: Bool 119 | 120 | -- | The arguments to the method call. See 'toVariant'. 121 | -- 122 | -- Defaults to @[]@. 123 | , methodCallBody :: [Variant] 124 | } 125 | deriving (Eq, Show) 126 | 127 | setMethodCallFlags :: MethodCall -> Word8 -> MethodCall 128 | setMethodCallFlags c w = c 129 | { methodCallReplyExpected = w .&. 0x1 == 0 130 | , methodCallAutoStart = w .&. 0x2 == 0 131 | } 132 | 133 | instance Message MethodCall where 134 | messageTypeCode _ = 1 135 | messageFlags c = foldr (.|.) 0 136 | [ if methodCallReplyExpected c then 0 else 0x1 137 | , if methodCallAutoStart c then 0 else 0x2 138 | ] 139 | messageBody = methodCallBody 140 | messageHeaderFields m = concat 141 | [ [ HeaderPath (methodCallPath m) 142 | , HeaderMember (methodCallMember m) 143 | ] 144 | , maybe' HeaderInterface (methodCallInterface m) 145 | , maybe' HeaderSender (methodCallSender m) 146 | , maybe' HeaderDestination (methodCallDestination m) 147 | ] 148 | 149 | -- | A method return is a reply to a method call, indicating that the call 150 | -- succeeded. 151 | data MethodReturn = MethodReturn 152 | { 153 | -- | The serial of the original method call. This lets the original 154 | -- caller match up this reply to the pending call. 155 | methodReturnSerial :: Serial 156 | 157 | -- | The name of the application that is returning from a call. 158 | -- 159 | -- Most users will just leave this empty, because the bus overwrites 160 | -- the sender for security reasons. Setting the sender manually is 161 | -- used for peer-peer connections. 162 | -- 163 | -- Defaults to @Nothing@. 164 | , methodReturnSender :: Maybe BusName 165 | 166 | -- | The name of the application that initiated the call. 167 | -- 168 | -- Most users should set this. If a message with no destination is 169 | -- sent to the bus, the bus will behave as if the destination was 170 | -- set to @org.freedesktop.DBus@. For peer-peer connections, the 171 | -- destination can be empty because there is only one peer. 172 | -- 173 | -- Defaults to @Nothing@. 174 | , methodReturnDestination :: Maybe BusName 175 | 176 | -- | Values returned from the method call. See 'toVariant'. 177 | -- 178 | -- Defaults to @[]@. 179 | , methodReturnBody :: [Variant] 180 | } 181 | deriving (Show, Eq) 182 | 183 | instance Message MethodReturn where 184 | messageTypeCode _ = 2 185 | messageBody = methodReturnBody 186 | messageHeaderFields m = concat 187 | [ [ HeaderReplySerial (methodReturnSerial m) 188 | ] 189 | , maybe' HeaderSender (methodReturnSender m) 190 | , maybe' HeaderDestination (methodReturnDestination m) 191 | ] 192 | 193 | -- | A method error is a reply to a method call, indicating that the call 194 | -- received an error and did not succeed. 195 | data MethodError = MethodError 196 | { 197 | -- | The name of the error type. Names are used so clients can 198 | -- handle certain classes of error differently from others. 199 | methodErrorName :: ErrorName 200 | 201 | -- | The serial of the original method call. This lets the original 202 | -- caller match up this reply to the pending call. 203 | , methodErrorSerial :: Serial 204 | 205 | -- | The name of the application that is returning from a call. 206 | -- 207 | -- Most users will just leave this empty, because the bus overwrites 208 | -- the sender for security reasons. Setting the sender manually is 209 | -- used for peer-peer connections. 210 | -- 211 | -- Defaults to @Nothing@. 212 | , methodErrorSender :: Maybe BusName 213 | 214 | -- | The name of the application that initiated the call. 215 | -- 216 | -- Most users should set this. If a message with no destination is 217 | -- sent to the bus, the bus will behave as if the destination was 218 | -- set to @org.freedesktop.DBus@. For peer-peer connections, the 219 | -- destination can be empty because there is only one peer. 220 | -- 221 | -- Defaults to @Nothing@. 222 | , methodErrorDestination :: Maybe BusName 223 | 224 | -- | Additional information about the error. By convention, if 225 | -- the error body contains any items, the first item should be a 226 | -- string describing the error. 227 | , methodErrorBody :: [Variant] 228 | } 229 | deriving (Show, Eq) 230 | 231 | instance Message MethodError where 232 | messageTypeCode _ = 3 233 | messageBody = methodErrorBody 234 | messageHeaderFields m = concat 235 | [ [ HeaderErrorName (methodErrorName m) 236 | , HeaderReplySerial (methodErrorSerial m) 237 | ] 238 | , maybe' HeaderSender (methodErrorSender m) 239 | , maybe' HeaderDestination (methodErrorDestination m) 240 | ] 241 | 242 | -- | Get a human-readable description of the error, by returning the first 243 | -- item in the error body if it's a string. 244 | methodErrorMessage :: MethodError -> String 245 | methodErrorMessage err = fromMaybe "(no error message)" $ do 246 | field <- listToMaybe (methodErrorBody err) 247 | msg <- fromVariant field 248 | if null msg 249 | then Nothing 250 | else return msg 251 | 252 | -- | Signals are broadcast by applications to notify other clients of some 253 | -- event. 254 | data Signal = Signal 255 | { 256 | -- | The path of the object that emitted this signal. 257 | signalPath :: ObjectPath 258 | 259 | -- | The interface that this signal belongs to. 260 | , signalInterface :: InterfaceName 261 | 262 | -- | The name of this signal. 263 | , signalMember :: MemberName 264 | 265 | -- | The name of the application that emitted this signal. 266 | -- 267 | -- Most users will just leave this empty, because the bus overwrites 268 | -- the sender for security reasons. Setting the sender manually is 269 | -- used for peer-peer connections. 270 | -- 271 | -- Defaults to @Nothing@. 272 | , signalSender :: Maybe BusName 273 | 274 | -- | The name of the application to emit the signal to. If @Nothing@, 275 | -- the signal is sent to any application that has registered an 276 | -- appropriate match rule. 277 | -- 278 | -- Defaults to @Nothing@. 279 | , signalDestination :: Maybe BusName 280 | 281 | -- | Additional information about the signal, such as the new value 282 | -- or the time. 283 | -- 284 | -- Defaults to @[]@. 285 | , signalBody :: [Variant] 286 | } 287 | deriving (Show, Eq) 288 | 289 | instance Message Signal where 290 | messageTypeCode _ = 4 291 | messageBody = signalBody 292 | messageHeaderFields m = concat 293 | [ [ HeaderPath (signalPath m) 294 | , HeaderMember (signalMember m) 295 | , HeaderInterface (signalInterface m) 296 | ] 297 | , maybe' HeaderSender (signalSender m) 298 | , maybe' HeaderDestination (signalDestination m) 299 | ] 300 | 301 | -- | Not an actual message type, but a wrapper around messages received from 302 | -- the bus. Each value contains the message's 'Serial'. 303 | -- 304 | -- If casing against these constructors, always include a default case to 305 | -- handle messages of an unknown type. New message types may be added to the 306 | -- D-Bus specification, and applications should handle them gracefully by 307 | -- either ignoring or logging them. 308 | data ReceivedMessage 309 | = ReceivedMethodCall Serial MethodCall 310 | | ReceivedMethodReturn Serial MethodReturn 311 | | ReceivedMethodError Serial MethodError 312 | | ReceivedSignal Serial Signal 313 | | ReceivedUnknown Serial UnknownMessage 314 | deriving (Show, Eq) 315 | -------------------------------------------------------------------------------- /lib/DBus/Socket.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | -- Copyright (C) 2009-2012 John Millikin 6 | -- 7 | -- Licensed under the Apache License, Version 2.0 (the "License"); 8 | -- you may not use this file except in compliance with the License. 9 | -- You may obtain a copy of the License at 10 | -- 11 | -- http://www.apache.org/licenses/LICENSE-2.0 12 | -- 13 | -- Unless required by applicable law or agreed to in writing, software 14 | -- distributed under the License is distributed on an "AS IS" BASIS, 15 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | -- See the License for the specific language governing permissions and 17 | -- limitations under the License. 18 | 19 | -- | D-Bus sockets are used for communication between two peers. In this model, 20 | -- there is no \"bus\" or \"client\", simply two endpoints sending messages. 21 | -- 22 | -- Most users will want to use the "DBus.Client" module instead. 23 | module DBus.Socket 24 | ( 25 | 26 | -- * Sockets 27 | Socket 28 | , send 29 | , receive 30 | 31 | -- * Socket errors 32 | , SocketError 33 | , socketError 34 | , socketErrorMessage 35 | , socketErrorFatal 36 | , socketErrorAddress 37 | 38 | -- * Socket options 39 | , SocketOptions 40 | , socketAuthenticator 41 | , socketTransportOptions 42 | , defaultSocketOptions 43 | 44 | -- * Opening and closing sockets 45 | , open 46 | , openWith 47 | , close 48 | 49 | -- * Listening for connections 50 | , SocketListener 51 | , listen 52 | , listenWith 53 | , accept 54 | , closeListener 55 | , socketListenerAddress 56 | 57 | -- * Authentication 58 | , Authenticator 59 | , authenticator 60 | , authenticatorWithUnixFds 61 | , authenticatorClient 62 | , authenticatorServer 63 | ) where 64 | 65 | import Prelude hiding (getLine) 66 | 67 | import Control.Concurrent 68 | import Control.Exception 69 | import Control.Monad (mplus) 70 | import qualified Data.ByteString 71 | import qualified Data.ByteString.Char8 as Char8 72 | import Data.Char (ord) 73 | import Data.IORef 74 | import Data.List (isPrefixOf) 75 | import Data.Typeable (Typeable) 76 | import qualified System.Posix.User 77 | import Text.Printf (printf) 78 | 79 | import DBus 80 | import DBus.Transport 81 | import DBus.Internal.Wire (unmarshalMessageM) 82 | 83 | -- | Stores information about an error encountered while creating or using a 84 | -- 'Socket'. 85 | data SocketError = SocketError 86 | { socketErrorMessage :: String 87 | , socketErrorFatal :: Bool 88 | , socketErrorAddress :: Maybe Address 89 | } 90 | deriving (Eq, Show, Typeable) 91 | 92 | instance Exception SocketError 93 | 94 | socketError :: String -> SocketError 95 | socketError msg = SocketError msg True Nothing 96 | 97 | data SomeTransport = forall t. (Transport t) => SomeTransport t 98 | 99 | instance Transport SomeTransport where 100 | data TransportOptions SomeTransport = SomeTransportOptions 101 | transportDefaultOptions = SomeTransportOptions 102 | transportPut (SomeTransport t) = transportPut t 103 | transportPutWithFds (SomeTransport t) = transportPutWithFds t 104 | transportGet (SomeTransport t) = transportGet t 105 | transportGetWithFds (SomeTransport t) = transportGetWithFds t 106 | transportClose (SomeTransport t) = transportClose t 107 | 108 | -- | An open socket to another process. Messages can be sent to the remote 109 | -- peer using 'send', or received using 'receive'. 110 | data Socket = Socket 111 | { socketTransport :: SomeTransport 112 | , socketAddress :: Maybe Address 113 | , socketSerial :: IORef Serial 114 | , socketReadLock :: MVar () 115 | , socketWriteLock :: MVar () 116 | } 117 | 118 | -- | An Authenticator defines how the local peer (client) authenticates 119 | -- itself to the remote peer (server). 120 | data Authenticator t = Authenticator 121 | { 122 | -- | Defines the client-side half of an authenticator. 123 | authenticatorClient :: t -> IO Bool 124 | 125 | -- | Defines the server-side half of an authenticator. The UUID is 126 | -- allocated by the socket listener. 127 | , authenticatorServer :: t -> UUID -> IO Bool 128 | } 129 | 130 | -- | Used with 'openWith' and 'listenWith' to provide custom authenticators or 131 | -- transport options. 132 | data SocketOptions t = SocketOptions 133 | { 134 | -- | Used to perform authentication with the remote peer. After a 135 | -- transport has been opened, it will be passed to the authenticator. 136 | -- If the authenticator returns true, then the socket was 137 | -- authenticated. 138 | socketAuthenticator :: Authenticator t 139 | 140 | -- | Options for the underlying transport, to be used by custom transports 141 | -- for controlling how to connect to the remote peer. 142 | -- 143 | -- See "DBus.Transport" for details on defining custom transports 144 | , socketTransportOptions :: TransportOptions t 145 | } 146 | 147 | -- | Default 'SocketOptions', which uses the default Unix/TCP transport and 148 | -- authenticator (without support for Unix file descriptor passing). 149 | defaultSocketOptions :: SocketOptions SocketTransport 150 | defaultSocketOptions = SocketOptions 151 | { socketTransportOptions = transportDefaultOptions 152 | , socketAuthenticator = authExternal UnixFdsNotSupported 153 | } 154 | 155 | -- | Open a socket to a remote peer listening at the given address. 156 | -- 157 | -- @ 158 | --open = 'openWith' 'defaultSocketOptions' 159 | -- @ 160 | -- 161 | -- Throws 'SocketError' on failure. 162 | open :: Address -> IO Socket 163 | open = openWith defaultSocketOptions 164 | 165 | -- | Open a socket to a remote peer listening at the given address. 166 | -- 167 | -- Most users should use 'open'. This function is for users who need to define 168 | -- custom authenticators or transports. 169 | -- 170 | -- Throws 'SocketError' on failure. 171 | openWith :: TransportOpen t => SocketOptions t -> Address -> IO Socket 172 | openWith opts addr = toSocketError (Just addr) $ bracketOnError 173 | (transportOpen (socketTransportOptions opts) addr) 174 | transportClose 175 | (\t -> do 176 | authed <- authenticatorClient (socketAuthenticator opts) t 177 | if not authed 178 | then throwIO (socketError "Authentication failed") 179 | { socketErrorAddress = Just addr 180 | } 181 | else do 182 | serial <- newIORef firstSerial 183 | readLock <- newMVar () 184 | writeLock <- newMVar () 185 | return (Socket (SomeTransport t) (Just addr) serial readLock writeLock)) 186 | 187 | data SocketListener = forall t. (TransportListen t) => SocketListener (TransportListener t) (Authenticator t) 188 | 189 | -- | Begin listening at the given address. 190 | -- 191 | -- Use 'accept' to create sockets from incoming connections. 192 | -- 193 | -- Use 'closeListener' to stop listening, and to free underlying transport 194 | -- resources such as file descriptors. 195 | -- 196 | -- Throws 'SocketError' on failure. 197 | listen :: Address -> IO SocketListener 198 | listen = listenWith defaultSocketOptions 199 | 200 | -- | Begin listening at the given address. 201 | -- 202 | -- Use 'accept' to create sockets from incoming connections. 203 | -- 204 | -- Use 'closeListener' to stop listening, and to free underlying transport 205 | -- resources such as file descriptors. 206 | -- 207 | -- This function is for users who need to define custom authenticators 208 | -- or transports. 209 | -- 210 | -- Throws 'SocketError' on failure. 211 | listenWith :: TransportListen t => SocketOptions t -> Address -> IO SocketListener 212 | listenWith opts addr = toSocketError (Just addr) $ bracketOnError 213 | (transportListen (socketTransportOptions opts) addr) 214 | transportListenerClose 215 | (\l -> return (SocketListener l (socketAuthenticator opts))) 216 | 217 | -- | Accept a new connection from a socket listener. 218 | -- 219 | -- Throws 'SocketError' on failure. 220 | accept :: SocketListener -> IO Socket 221 | accept (SocketListener l auth) = toSocketError Nothing $ bracketOnError 222 | (transportAccept l) 223 | transportClose 224 | (\t -> do 225 | let uuid = transportListenerUUID l 226 | authed <- authenticatorServer auth t uuid 227 | if not authed 228 | then throwIO (socketError "Authentication failed") 229 | else do 230 | serial <- newIORef firstSerial 231 | readLock <- newMVar () 232 | writeLock <- newMVar () 233 | return (Socket (SomeTransport t) Nothing serial readLock writeLock)) 234 | 235 | -- | Close an open 'Socket'. Once closed, the socket is no longer valid and 236 | -- must not be used. 237 | close :: Socket -> IO () 238 | close = transportClose . socketTransport 239 | 240 | -- | Close an open 'SocketListener'. Once closed, the listener is no longer 241 | -- valid and must not be used. 242 | closeListener :: SocketListener -> IO () 243 | closeListener (SocketListener l _) = transportListenerClose l 244 | 245 | -- | Get the address to use to connect to a listener. 246 | socketListenerAddress :: SocketListener -> Address 247 | socketListenerAddress (SocketListener l _) = transportListenerAddress l 248 | 249 | -- | Send a single message, with a generated 'Serial'. The second parameter 250 | -- exists to prevent race conditions when registering a reply handler; it 251 | -- receives the serial the message /will/ be sent with, before it's 252 | -- actually sent. 253 | -- 254 | -- Sockets are thread-safe. Only one message may be sent at a time; if 255 | -- multiple threads attempt to send messages concurrently, one will block 256 | -- until after the other has finished. 257 | -- 258 | -- Throws 'SocketError' on failure. 259 | send :: Message msg => Socket -> msg -> (Serial -> IO a) -> IO a 260 | send sock msg io = toSocketError (socketAddress sock) $ do 261 | serial <- nextSocketSerial sock 262 | case marshalWithFds LittleEndian serial msg of 263 | Right (bytes, fds) -> do 264 | let t = socketTransport sock 265 | a <- io serial 266 | withMVar (socketWriteLock sock) (\_ -> transportPutWithFds t bytes fds) 267 | return a 268 | Left err -> throwIO (socketError ("Message cannot be sent: " ++ show err)) 269 | { socketErrorFatal = False 270 | } 271 | 272 | nextSocketSerial :: Socket -> IO Serial 273 | nextSocketSerial sock = atomicModifyIORef (socketSerial sock) (\x -> (nextSerial x, x)) 274 | 275 | -- | Receive the next message from the socket , blocking until one is available. 276 | -- 277 | -- Sockets are thread-safe. Only one message may be received at a time; if 278 | -- multiple threads attempt to receive messages concurrently, one will block 279 | -- until after the other has finished. 280 | -- 281 | -- Throws 'SocketError' on failure. 282 | receive :: Socket -> IO ReceivedMessage 283 | receive sock = toSocketError (socketAddress sock) $ do 284 | -- TODO: after reading the length, read all bytes from the 285 | -- handle, then return a closure to perform the parse 286 | -- outside of the lock. 287 | let t = socketTransport sock 288 | let get n = if n == 0 289 | then return (Data.ByteString.empty, []) 290 | else transportGetWithFds t n 291 | received <- withMVar (socketReadLock sock) (\_ -> unmarshalMessageM get) 292 | case received of 293 | Left err -> throwIO (socketError ("Error reading message from socket: " ++ show err)) 294 | Right msg -> return msg 295 | 296 | toSocketError :: Maybe Address -> IO a -> IO a 297 | toSocketError addr io = catches io handlers where 298 | handlers = 299 | [ Handler catchTransportError 300 | , Handler updateSocketError 301 | , Handler catchIOException 302 | ] 303 | catchTransportError err = throwIO (socketError (transportErrorMessage err)) 304 | { socketErrorAddress = addr 305 | } 306 | updateSocketError err = throwIO err 307 | { socketErrorAddress = mplus (socketErrorAddress err) addr 308 | } 309 | catchIOException exc = throwIO (socketError (show (exc :: IOException))) 310 | { socketErrorAddress = addr 311 | } 312 | 313 | -- | An empty authenticator. Use 'authenticatorClient' or 'authenticatorServer' 314 | -- to control how the authentication is performed. 315 | -- 316 | -- @ 317 | --myAuthenticator :: Authenticator MyTransport 318 | --myAuthenticator = authenticator 319 | -- { 'authenticatorClient' = clientMyAuth 320 | -- , 'authenticatorServer' = serverMyAuth 321 | -- } 322 | -- 323 | --clientMyAuth :: MyTransport -> IO Bool 324 | --serverMyAuth :: MyTransport -> String -> IO Bool 325 | -- @ 326 | authenticator :: Authenticator t 327 | authenticator = Authenticator (\_ -> return False) (\_ _ -> return False) 328 | 329 | data UnixFdSupport = UnixFdsSupported | UnixFdsNotSupported 330 | 331 | -- | An authenticator that implements the D-Bus @EXTERNAL@ mechanism, which uses 332 | -- credential passing over a Unix socket, with support for Unix file descriptor passing. 333 | authenticatorWithUnixFds :: Authenticator SocketTransport 334 | authenticatorWithUnixFds = authExternal UnixFdsSupported 335 | 336 | -- | Implements the D-Bus @EXTERNAL@ mechanism, which uses credential 337 | -- passing over a Unix socket, optionally supporting Unix file descriptor passing. 338 | authExternal :: UnixFdSupport -> Authenticator SocketTransport 339 | authExternal unixFdSupport = authenticator 340 | { authenticatorClient = clientAuthExternal unixFdSupport 341 | , authenticatorServer = serverAuthExternal unixFdSupport 342 | } 343 | 344 | clientAuthExternal :: UnixFdSupport -> SocketTransport -> IO Bool 345 | clientAuthExternal unixFdSupport t = do 346 | transportPut t (Data.ByteString.pack [0]) 347 | uid <- System.Posix.User.getRealUserID 348 | let token = concatMap (printf "%02X" . ord) (show uid) 349 | transportPutLine t ("AUTH EXTERNAL " ++ token) 350 | resp <- transportGetLine t 351 | case splitPrefix "OK " resp of 352 | Just _ -> do 353 | ok <- do 354 | case unixFdSupport of 355 | UnixFdsSupported -> do 356 | transportPutLine t "NEGOTIATE_UNIX_FD" 357 | respFd <- transportGetLine t 358 | return (respFd == "AGREE_UNIX_FD") 359 | UnixFdsNotSupported -> do 360 | return True 361 | if ok then do 362 | transportPutLine t "BEGIN" 363 | return True 364 | else 365 | return False 366 | Nothing -> return False 367 | 368 | serverAuthExternal :: UnixFdSupport -> SocketTransport -> UUID -> IO Bool 369 | serverAuthExternal unixFdSupport t uuid = do 370 | let negotiateFdsAndBegin = do 371 | line <- transportGetLine t 372 | case line of 373 | "NEGOTIATE_UNIX_FD" -> do 374 | let msg = case unixFdSupport of 375 | UnixFdsSupported -> 376 | "AGREE_UNIX_FD" 377 | UnixFdsNotSupported -> 378 | "ERROR Unix File Descriptor support is not configured." 379 | transportPutLine t msg 380 | negotiateFdsAndBegin 381 | "BEGIN" -> 382 | return () 383 | _ -> 384 | negotiateFdsAndBegin 385 | 386 | let checkToken token = do 387 | (_, uid, _) <- socketTransportCredentials t 388 | let wantToken = concatMap (printf "%02X" . ord) (maybe "XXX" show uid) 389 | if token == wantToken 390 | then do 391 | transportPutLine t ("OK " ++ formatUUID uuid) 392 | negotiateFdsAndBegin 393 | return True 394 | else return False 395 | 396 | c <- transportGet t 1 397 | if c /= Char8.pack "\x00" 398 | then return False 399 | else do 400 | line <- transportGetLine t 401 | case splitPrefix "AUTH EXTERNAL " line of 402 | Just token -> checkToken token 403 | Nothing -> if line == "AUTH EXTERNAL" 404 | then do 405 | dataLine <- transportGetLine t 406 | case splitPrefix "DATA " dataLine of 407 | Just token -> checkToken token 408 | Nothing -> return False 409 | else return False 410 | 411 | transportPutLine :: Transport t => t -> String -> IO () 412 | transportPutLine t line = transportPut t (Char8.pack (line ++ "\r\n")) 413 | 414 | transportGetLine :: Transport t => t -> IO String 415 | transportGetLine t = do 416 | let getchr = Char8.head `fmap` transportGet t 1 417 | raw <- readUntil "\r\n" getchr 418 | return (dropEnd 2 raw) 419 | 420 | -- | Drop /n/ items from the end of a list 421 | dropEnd :: Int -> [a] -> [a] 422 | dropEnd n xs = take (length xs - n) xs 423 | 424 | splitPrefix :: String -> String -> Maybe String 425 | splitPrefix prefix str = if isPrefixOf prefix str 426 | then Just (drop (length prefix) str) 427 | else Nothing 428 | 429 | -- | Read values from a monad until a guard value is read; return all 430 | -- values, including the guard. 431 | readUntil :: (Monad m, Eq a) => [a] -> m a -> m [a] 432 | readUntil guard getx = readUntil' [] where 433 | guard' = reverse guard 434 | step xs | isPrefixOf guard' xs = return (reverse xs) 435 | | otherwise = readUntil' xs 436 | readUntil' xs = do 437 | x <- getx 438 | step (x:xs) 439 | -------------------------------------------------------------------------------- /lib/DBus/Transport.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | -- Copyright (C) 2009-2012 John Millikin 6 | -- 7 | -- Licensed under the Apache License, Version 2.0 (the "License"); 8 | -- you may not use this file except in compliance with the License. 9 | -- You may obtain a copy of the License at 10 | -- 11 | -- http://www.apache.org/licenses/LICENSE-2.0 12 | -- 13 | -- Unless required by applicable law or agreed to in writing, software 14 | -- distributed under the License is distributed on an "AS IS" BASIS, 15 | -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | -- See the License for the specific language governing permissions and 17 | -- limitations under the License. 18 | 19 | -- | Support for defining custom transport mechanisms. Most users will not 20 | -- need to care about the types defined in this module. 21 | module DBus.Transport 22 | ( 23 | -- * Transports 24 | Transport(..) 25 | , TransportOpen(..) 26 | , TransportListen(..) 27 | 28 | -- * Transport errors 29 | , TransportError 30 | , transportError 31 | , transportErrorMessage 32 | , transportErrorAddress 33 | 34 | -- * Socket transport 35 | , SocketTransport 36 | , socketTransportOptionBacklog 37 | , socketTransportCredentials 38 | ) where 39 | 40 | import Control.Concurrent (rtsSupportsBoundThreads, threadWaitWrite) 41 | import Control.Exception 42 | import Control.Monad (when) 43 | import qualified Data.ByteString 44 | import qualified Data.ByteString.Builder as Builder 45 | import Data.ByteString.Internal (ByteString(PS)) 46 | import qualified Data.ByteString.Lazy as Lazy 47 | import Data.ByteString.Unsafe (unsafeUseAsCString) 48 | import qualified Data.Kind 49 | import qualified Data.Map as Map 50 | import Data.Maybe (fromMaybe) 51 | import Data.Monoid 52 | import Data.Typeable (Typeable) 53 | import Foreign.C (CInt, CUInt) 54 | import Foreign.ForeignPtr (withForeignPtr) 55 | import Foreign.Marshal.Array (peekArray) 56 | import Foreign.Ptr (castPtr, plusPtr) 57 | import Foreign.Storable (sizeOf) 58 | import Network.Socket 59 | import Network.Socket.Internal (NullSockAddr(..)) 60 | import qualified Network.Socket.Address 61 | import Network.Socket.ByteString (recvMsg) 62 | import qualified System.Info 63 | import System.IO.Unsafe (unsafeDupablePerformIO) 64 | import System.Posix.Types (Fd) 65 | import Prelude 66 | 67 | import DBus 68 | 69 | -- | Thrown from transport methods when an error occurs. 70 | data TransportError = TransportError 71 | { transportErrorMessage :: String 72 | , transportErrorAddress :: Maybe Address 73 | } 74 | deriving (Eq, Show, Typeable) 75 | 76 | instance Exception TransportError 77 | 78 | transportError :: String -> TransportError 79 | transportError msg = TransportError msg Nothing 80 | 81 | -- | A 'Transport' can exchange bytes with a remote peer. 82 | class Transport t where 83 | -- | Additional options that this transport type may use when establishing 84 | -- a connection. 85 | data TransportOptions t :: Data.Kind.Type 86 | 87 | -- | Default values for this transport's options. 88 | transportDefaultOptions :: TransportOptions t 89 | 90 | -- | Send a 'ByteString' over the transport. 91 | -- 92 | -- Throws a 'TransportError' if an error occurs. 93 | transportPut :: t -> ByteString -> IO () 94 | 95 | -- | Send a 'ByteString' and Unix file descriptors over the transport. 96 | -- 97 | -- Throws a 'TransportError' if an error occurs. 98 | transportPutWithFds :: t -> ByteString -> [Fd] -> IO () 99 | transportPutWithFds t bs _fds = transportPut t bs 100 | 101 | -- | Receive a 'ByteString' of the given size from the transport. The 102 | -- transport should block until sufficient bytes are available, and 103 | -- only return fewer than the requested amount if there will not be 104 | -- any more data. 105 | -- 106 | -- Throws a 'TransportError' if an error occurs. 107 | transportGet :: t -> Int -> IO ByteString 108 | 109 | -- | Receive a 'ByteString' of the given size from the transport, plus 110 | -- any Unix file descriptors that arrive with the byte data. The 111 | -- transport should block until sufficient bytes are available, and 112 | -- only return fewer than the requested amount if there will not be 113 | -- any more data. 114 | -- 115 | -- Throws a 'TransportError' if an error occurs. 116 | transportGetWithFds :: t -> Int -> IO (ByteString, [Fd]) 117 | transportGetWithFds t n = do 118 | bs <- transportGet t n 119 | return (bs, []) 120 | 121 | -- | Close an open transport, and release any associated resources 122 | -- or handles. 123 | transportClose :: t -> IO () 124 | 125 | -- | A 'Transport' which can open a connection to a remote peer. 126 | class Transport t => TransportOpen t where 127 | -- | Open a connection to the given address, using the given options. 128 | -- 129 | -- Throws a 'TransportError' if the connection could not be 130 | -- established. 131 | transportOpen :: TransportOptions t -> Address -> IO t 132 | 133 | -- | A 'Transport' which can listen for and accept connections from remote 134 | -- peers. 135 | class Transport t => TransportListen t where 136 | -- | Used for transports that listen on a port or address. 137 | data TransportListener t :: Data.Kind.Type 138 | 139 | -- | Begin listening for connections on the given address, using the 140 | -- given options. 141 | -- 142 | -- Throws a 'TransportError' if it's not possible to listen at that 143 | -- address (for example, if the port is already in use). 144 | transportListen :: TransportOptions t -> Address -> IO (TransportListener t) 145 | 146 | -- | Accept a new connection. 147 | -- 148 | -- Throws a 'TransportError' if some error happens before the 149 | -- transport is ready to exchange bytes. 150 | transportAccept :: TransportListener t -> IO t 151 | 152 | -- | Close an open listener. 153 | transportListenerClose :: TransportListener t -> IO () 154 | 155 | -- | Get the address to use to connect to a listener. 156 | transportListenerAddress :: TransportListener t -> Address 157 | 158 | -- | Get the UUID allocated to this transport listener. 159 | -- 160 | -- See 'randomUUID'. 161 | transportListenerUUID :: TransportListener t -> UUID 162 | 163 | -- | Supports connecting over Unix or TCP sockets. 164 | -- 165 | -- Unix sockets are similar to pipes, but exist as special files in the 166 | -- filesystem. On Linux, /abstract sockets/ have a path-like address, but do 167 | -- not actually have entries in the filesystem. 168 | -- 169 | -- TCP sockets may use either IPv4 or IPv6. 170 | data SocketTransport = SocketTransport (Maybe Address) Socket 171 | 172 | instance Transport SocketTransport where 173 | data TransportOptions SocketTransport = SocketTransportOptions 174 | { 175 | -- | The maximum size of the connection queue for a listening 176 | -- socket. 177 | socketTransportOptionBacklog :: Int 178 | } 179 | transportDefaultOptions = SocketTransportOptions 30 180 | transportPut st bytes = transportPutWithFds st bytes [] 181 | transportPutWithFds (SocketTransport addr s) bytes fds = catchIOException addr (sendWithFds s bytes fds) 182 | transportGet st n = fst <$> transportGetWithFds st n 183 | transportGetWithFds (SocketTransport addr s) n = catchIOException addr (recvWithFds s n) 184 | transportClose (SocketTransport addr s) = catchIOException addr (close s) 185 | 186 | sendWithFds :: Socket -> ByteString -> [Fd] -> IO () 187 | sendWithFds s msg fds = loop 0 where 188 | loop acc = do 189 | let cmsgs = if acc == 0 then (encodeCmsg . (pure :: Fd -> [Fd]) <$> fds) else [] 190 | n <- unsafeUseAsCString msg $ \cstr -> do 191 | let buf = [(plusPtr (castPtr cstr) acc, len - acc)] 192 | Network.Socket.Address.sendBufMsg s NullSockAddr buf cmsgs mempty 193 | waitWhen0 n s -- copy Network.Socket.ByteString.sendAll 194 | when (acc + n < len) $ do 195 | loop (acc + n) 196 | len = Data.ByteString.length msg 197 | 198 | recvWithFds :: Socket -> Int -> IO (ByteString, [Fd]) 199 | recvWithFds s = loop mempty [] where 200 | loop accBuf accFds n = do 201 | (_sa, buf, cmsgs, flag) <- recvMsg s (min n chunkSize) cmsgsSize mempty 202 | let recvLen = Data.ByteString.length buf 203 | accBuf' = accBuf <> Builder.byteString buf 204 | accFds' = accFds <> decodeFdCmsgs cmsgs 205 | case flag of 206 | MSG_CTRUNC -> throwIO (transportError ("Unexpected MSG_CTRUNC: more than " <> show maxFds <> " file descriptors?")) 207 | -- no data means unexpected end of connection; maybe the remote end went away. 208 | _ | recvLen == 0 || recvLen == n -> do 209 | return (Lazy.toStrict (Builder.toLazyByteString accBuf'), accFds') 210 | _ -> loop accBuf' accFds' (n - recvLen) 211 | chunkSize = 4096 212 | maxFds = 16 -- same as DBUS_DEFAULT_MESSAGE_UNIX_FDS in DBUS reference implementation 213 | cmsgsSize = sizeOf (undefined :: CInt) * maxFds 214 | 215 | instance TransportOpen SocketTransport where 216 | transportOpen _ a = case addressMethod a of 217 | "unix" -> openUnix a 218 | "tcp" -> openTcp a 219 | method -> throwIO (transportError ("Unknown address method: " ++ show method)) 220 | { transportErrorAddress = Just a 221 | } 222 | 223 | instance TransportListen SocketTransport where 224 | data TransportListener SocketTransport = SocketTransportListener Address UUID Socket 225 | transportListen opts a = do 226 | uuid <- randomUUID 227 | (a', sock) <- case addressMethod a of 228 | "unix" -> listenUnix uuid a opts 229 | "tcp" -> listenTcp uuid a opts 230 | method -> throwIO (transportError ("Unknown address method: " ++ show method)) 231 | { transportErrorAddress = Just a 232 | } 233 | return (SocketTransportListener a' uuid sock) 234 | transportAccept (SocketTransportListener a _ s) = catchIOException (Just a) $ do 235 | (s', _) <- accept s 236 | return (SocketTransport Nothing s') 237 | transportListenerClose (SocketTransportListener a _ s) = catchIOException (Just a) (close s) 238 | transportListenerAddress (SocketTransportListener a _ _) = a 239 | transportListenerUUID (SocketTransportListener _ uuid _) = uuid 240 | 241 | -- | Returns the processID, userID, and groupID of the socket's peer. 242 | -- 243 | -- See 'getPeerCredential'. 244 | socketTransportCredentials :: SocketTransport -> IO (Maybe CUInt, Maybe CUInt, Maybe CUInt) 245 | socketTransportCredentials (SocketTransport a s) = catchIOException a (getPeerCredential s) 246 | 247 | openUnix :: Address -> IO SocketTransport 248 | openUnix transportAddr = go where 249 | params = addressParameters transportAddr 250 | param key = Map.lookup key params 251 | 252 | tooMany = "Only one of 'path' or 'abstract' may be specified for the\ 253 | \ 'unix' transport." 254 | tooFew = "One of 'path' or 'abstract' must be specified for the\ 255 | \ 'unix' transport." 256 | 257 | path = case (param "path", param "abstract") of 258 | (Just x, Nothing) -> Right x 259 | (Nothing, Just x) -> Right ('\x00' : x) 260 | (Nothing, Nothing) -> Left tooFew 261 | _ -> Left tooMany 262 | 263 | go = case path of 264 | Left err -> throwIO (transportError err) 265 | { transportErrorAddress = Just transportAddr 266 | } 267 | Right p -> catchIOException (Just transportAddr) $ bracketOnError 268 | (socket AF_UNIX Stream defaultProtocol) 269 | close 270 | (\sock -> do 271 | connect sock (SockAddrUnix p) 272 | return (SocketTransport (Just transportAddr) sock)) 273 | 274 | tcpHostname :: Maybe String -> Either a Network.Socket.Family -> String 275 | tcpHostname (Just host) _ = host 276 | tcpHostname Nothing (Right AF_INET) = "127.0.0.1" 277 | tcpHostname Nothing (Right AF_INET6) = "::1" 278 | tcpHostname _ _ = "localhost" 279 | 280 | openTcp :: Address -> IO SocketTransport 281 | openTcp transportAddr = go where 282 | params = addressParameters transportAddr 283 | param key = Map.lookup key params 284 | 285 | hostname = tcpHostname (param "host") getFamily 286 | unknownFamily x = "Unknown socket family for TCP transport: " ++ show x 287 | getFamily = case param "family" of 288 | Just "ipv4" -> Right AF_INET 289 | Just "ipv6" -> Right AF_INET6 290 | Nothing -> Right AF_UNSPEC 291 | Just x -> Left (unknownFamily x) 292 | missingPort = "TCP transport requires the `port' parameter." 293 | badPort x = "Invalid socket port for TCP transport: " ++ show x 294 | getPort = case param "port" of 295 | Nothing -> Left missingPort 296 | Just x -> case readPortNumber x of 297 | Just port -> Right port 298 | Nothing -> Left (badPort x) 299 | 300 | getAddresses family_ = getAddrInfo (Just (defaultHints 301 | { addrFlags = [AI_ADDRCONFIG] 302 | , addrFamily = family_ 303 | , addrSocketType = Stream 304 | })) (Just hostname) Nothing 305 | 306 | openOneSocket [] = throwIO (transportError "openTcp: no addresses") 307 | { transportErrorAddress = Just transportAddr 308 | } 309 | openOneSocket (addr:addrs) = do 310 | tried <- Control.Exception.try $ bracketOnError 311 | (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) 312 | close 313 | (\sock -> do 314 | connect sock (addrAddress addr) 315 | return sock) 316 | case tried of 317 | Left err -> case addrs of 318 | [] -> throwIO (transportError (show (err :: IOException))) 319 | { transportErrorAddress = Just transportAddr 320 | } 321 | _ -> openOneSocket addrs 322 | Right sock -> return sock 323 | 324 | go = case getPort of 325 | Left err -> throwIO (transportError err) 326 | { transportErrorAddress = Just transportAddr 327 | } 328 | Right port -> case getFamily of 329 | Left err -> throwIO (transportError err) 330 | { transportErrorAddress = Just transportAddr 331 | } 332 | Right family_ -> catchIOException (Just transportAddr) $ do 333 | addrs <- getAddresses family_ 334 | sock <- openOneSocket (map (setPort port) addrs) 335 | return (SocketTransport (Just transportAddr) sock) 336 | 337 | listenUnix :: UUID -> Address -> TransportOptions SocketTransport -> IO (Address, Socket) 338 | listenUnix uuid origAddr opts = getPath >>= go where 339 | params = addressParameters origAddr 340 | param key = Map.lookup key params 341 | 342 | tooMany = "Only one of 'abstract', 'path', or 'tmpdir' may be\ 343 | \ specified for the 'unix' transport." 344 | tooFew = "One of 'abstract', 'path', or 'tmpdir' must be specified\ 345 | \ for the 'unix' transport." 346 | 347 | getPath = case (param "abstract", param "path", param "tmpdir") of 348 | (Just path, Nothing, Nothing) -> let 349 | addr = address_ "unix" 350 | [ ("abstract", path) 351 | , ("guid", formatUUID uuid) 352 | ] 353 | in return (Right (addr, '\x00' : path)) 354 | (Nothing, Just path, Nothing) -> let 355 | addr = address_ "unix" 356 | [ ("path", path) 357 | , ("guid", formatUUID uuid) 358 | ] 359 | in return (Right (addr, path)) 360 | (Nothing, Nothing, Just x) -> do 361 | let fileName = x ++ "/haskell-dbus-" ++ formatUUID uuid 362 | 363 | -- Abstract paths are supported on Linux, but not on 364 | -- other Unix-like systems. 365 | let (addrParams, path) = if System.Info.os == "linux" 366 | then ([("abstract", fileName)], '\x00' : fileName) 367 | else ([("path", fileName)], fileName) 368 | 369 | let addr = address_ "unix" (addrParams ++ [("guid", formatUUID uuid)]) 370 | return (Right (addr, path)) 371 | (Nothing, Nothing, Nothing) -> return (Left tooFew) 372 | _ -> return (Left tooMany) 373 | 374 | go path = case path of 375 | Left err -> throwIO (transportError err) 376 | { transportErrorAddress = Just origAddr 377 | } 378 | Right (addr, p) -> catchIOException (Just origAddr) $ bracketOnError 379 | (socket AF_UNIX Stream defaultProtocol) 380 | close 381 | (\sock -> do 382 | bind sock (SockAddrUnix p) 383 | Network.Socket.listen sock (socketTransportOptionBacklog opts) 384 | return (addr, sock)) 385 | 386 | listenTcp :: UUID -> Address -> TransportOptions SocketTransport -> IO (Address, Socket) 387 | listenTcp uuid origAddr opts = go where 388 | params = addressParameters origAddr 389 | param key = Map.lookup key params 390 | 391 | unknownFamily x = "Unknown socket family for TCP transport: " ++ show x 392 | getFamily = case param "family" of 393 | Just "ipv4" -> Right AF_INET 394 | Just "ipv6" -> Right AF_INET6 395 | Nothing -> Right AF_UNSPEC 396 | Just x -> Left (unknownFamily x) 397 | 398 | badPort x = "Invalid socket port for TCP transport: " ++ show x 399 | getPort = case param "port" of 400 | Nothing -> Right 0 401 | Just x -> case readPortNumber x of 402 | Just port -> Right port 403 | Nothing -> Left (badPort x) 404 | 405 | paramBind = case param "bind" of 406 | Just "*" -> Nothing 407 | Just x -> Just x 408 | Nothing -> Just (tcpHostname (param "host") getFamily) 409 | 410 | getAddresses family_ = getAddrInfo (Just (defaultHints 411 | { addrFlags = [AI_ADDRCONFIG, AI_PASSIVE] 412 | , addrFamily = family_ 413 | , addrSocketType = Stream 414 | })) paramBind Nothing 415 | 416 | bindAddrs _ [] = throwIO (transportError "listenTcp: no addresses") 417 | { transportErrorAddress = Just origAddr 418 | } 419 | bindAddrs sock (addr:addrs) = do 420 | tried <- Control.Exception.try (bind sock (addrAddress addr)) 421 | case tried of 422 | Left err -> case addrs of 423 | [] -> throwIO (transportError (show (err :: IOException))) 424 | { transportErrorAddress = Just origAddr 425 | } 426 | _ -> bindAddrs sock addrs 427 | Right _ -> return () 428 | 429 | sockAddr port = address_ "tcp" p where 430 | p = baseParams ++ hostParam ++ familyParam 431 | baseParams = 432 | [ ("port", show port) 433 | , ("guid", formatUUID uuid) 434 | ] 435 | hostParam = case param "host" of 436 | Just x -> [("host", x)] 437 | Nothing -> [] 438 | familyParam = case param "family" of 439 | Just x -> [("family", x)] 440 | Nothing -> [] 441 | 442 | go = case getPort of 443 | Left err -> throwIO (transportError err) 444 | { transportErrorAddress = Just origAddr 445 | } 446 | Right port -> case getFamily of 447 | Left err -> throwIO (transportError err) 448 | { transportErrorAddress = Just origAddr 449 | } 450 | Right family_ -> catchIOException (Just origAddr) $ do 451 | sockAddrs <- getAddresses family_ 452 | bracketOnError 453 | (socket family_ Stream defaultProtocol) 454 | close 455 | (\sock -> do 456 | setSocketOption sock ReuseAddr 1 457 | bindAddrs sock (map (setPort port) sockAddrs) 458 | 459 | Network.Socket.listen sock (socketTransportOptionBacklog opts) 460 | sockPort <- socketPort sock 461 | return (sockAddr sockPort, sock)) 462 | 463 | catchIOException :: Maybe Address -> IO a -> IO a 464 | catchIOException addr io = do 465 | tried <- try io 466 | case tried of 467 | Right a -> return a 468 | Left err -> throwIO (transportError (show (err :: IOException))) 469 | { transportErrorAddress = addr 470 | } 471 | 472 | address_ :: String -> [(String, String)] -> Address 473 | address_ method params = addr where 474 | Just addr = address method (Map.fromList params) 475 | 476 | setPort :: PortNumber -> AddrInfo -> AddrInfo 477 | setPort port info = case addrAddress info of 478 | (SockAddrInet _ x) -> info { addrAddress = SockAddrInet port x } 479 | (SockAddrInet6 _ x y z) -> info { addrAddress = SockAddrInet6 port x y z } 480 | _ -> info 481 | 482 | readPortNumber :: String -> Maybe PortNumber 483 | readPortNumber s = do 484 | case dropWhile (\c -> c >= '0' && c <= '9') s of 485 | [] -> return () 486 | _ -> Nothing 487 | let word = read s :: Integer 488 | if word > 0 && word <= 65535 489 | then Just (fromInteger word) 490 | else Nothing 491 | 492 | -- | Copied from Network.Socket.ByteString.IO 493 | waitWhen0 :: Int -> Socket -> IO () 494 | waitWhen0 0 s = when rtsSupportsBoundThreads $ 495 | withFdSocket s $ \fd -> threadWaitWrite $ fromIntegral fd 496 | waitWhen0 _ _ = return () 497 | 498 | decodeFdCmsgs :: [Cmsg] -> [Fd] 499 | decodeFdCmsgs cmsgs = 500 | foldMap (fromMaybe [] . decodeFdCmsg) cmsgs 501 | 502 | -- | Special decode function to handle > 1 Fd. Should be able to replace with a function 503 | -- from the network package in future (https://github.com/haskell/network/issues/566) 504 | decodeFdCmsg :: Cmsg -> Maybe [Fd] 505 | decodeFdCmsg (Cmsg cmsid (PS fptr off len)) 506 | | cmsid /= CmsgIdFds = Nothing 507 | | otherwise = 508 | unsafeDupablePerformIO $ withForeignPtr fptr $ \p0 -> do 509 | let p = castPtr (p0 `plusPtr` off) 510 | numFds = len `div` sizeOf (undefined :: Fd) 511 | Just <$> peekArray numFds p 512 | --------------------------------------------------------------------------------