dbus 1.2.29 → 1.4.3
raw patch · 17 files changed
Files
- benchmarks/DBusBenchmarks.hs +0/−91
- dbus.cabal +23/−34
- examples/dbus-monitor.hs +1/−1
- lib/DBus.hs +33/−9
- lib/DBus/Client.hs +58/−39
- lib/DBus/Generation.hs +1/−2
- lib/DBus/Internal/Types.hs +1/−1
- lib/DBus/Internal/Wire.hs +93/−60
- lib/DBus/Introspection/Render.hs +1/−2
- lib/DBus/Socket.hs +73/−33
- lib/DBus/Transport.hs +89/−26
- tests/DBusTests/Introspection.hs +0/−1
- tests/DBusTests/Serialization.hs +8/−8
- tests/DBusTests/Socket.hs +44/−10
- tests/DBusTests/Transport.hs +103/−23
- tests/DBusTests/Util.hs +20/−2
- tests/DBusTests/Wire.hs +38/−1
− benchmarks/DBusBenchmarks.hs
@@ -1,91 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- Copyright (C) 2010-2011 John Millikin <john@john-millikin.com>------ Licensed under the Apache License, Version 2.0 (the "License");--- you may not use this file except in compliance with the License.--- You may obtain a copy of the License at------ http://www.apache.org/licenses/LICENSE-2.0------ Unless required by applicable law or agreed to in writing, software--- distributed under the License is distributed on an "AS IS" BASIS,--- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.--- See the License for the specific language governing permissions and--- limitations under the License.--module Main (benchmarks, main) where--import Criterion.Types-import Data.Word (Word32)-import Unsafe.Coerce (unsafeCoerce)-import qualified Criterion.Main--import DBus--serial :: Word32 -> Serial-serial = unsafeCoerce -- FIXME: should the Serial constructor be exposed to- -- clients?--empty_MethodCall :: MethodCall-empty_MethodCall = methodCall "/" "org.i" "m"--empty_MethodReturn :: MethodReturn-empty_MethodReturn = methodReturn (serial 0)--benchMarshal :: Message msg => String -> msg -> Benchmark-benchMarshal name msg = bench name (whnf (marshal LittleEndian (serial 0)) msg)--benchUnmarshal :: Message msg => String -> msg -> Benchmark-benchUnmarshal name msg = bench name (whnf unmarshal bytes) where- Right bytes = marshal LittleEndian (serial 0) msg--parseSig :: String -> Maybe Signature-parseSig = parseSignature--benchmarks :: [Benchmark]-benchmarks =- [ bgroup "Types"- [ bgroup "Signature"- [ bench "parseSignature/small" (nf parseSig "y")- , bench "parseSignature/medium" (nf parseSig "yyyyuua(yv)")- , bench "parseSignature/large" (nf parseSig "a{s(asiiiiasa(siiia{s(iiiiv)}))}")- ]- , bgroup "ObjectPath"- [ bench "objectPath_/small" (nf objectPath_ "/")- , bench "objectPath_/medium" (nf objectPath_ "/foo/bar")- , bench "objectPath_/large" (nf objectPath_ "/f0OO/b4R/baz_qux/blahblahblah")- ]- , bgroup "InterfaceName"- [ bench "interfaceName_/small" (nf interfaceName_ "f.b")- , bench "interfaceName_/medium" (nf interfaceName_ "foo.bar.baz")- , bench "interfaceName_/large" (nf interfaceName_ "f0OOO.b4R.baz_qux.blahblahblah")- ]- , bgroup "MemberName"- [ bench "memberName_/small" (nf memberName_ "f")- , bench "memberName_/medium" (nf memberName_ "FooBar")- , bench "memberName_/large" (nf memberName_ "f0OOOb4RBazQuxBlahBlahBlah")- ]- , bgroup "ErrorName"- [ bench "errorName_/small" (nf errorName_ "f.b")- , bench "errorName_/medium" (nf errorName_ "foo.bar.baz")- , bench "errorName_/large" (nf errorName_ "f0OOO.b4R.baz_qux.blahblahblah")- ]- , bgroup "BusName"- [ bench "busName_/small" (nf busName_ "f.b")- , bench "busName_/medium" (nf busName_ "foo.bar.baz")- , bench "busName_/large" (nf busName_ "f0OOO.b4R.baz-qux.blahblahblah")- ]- ]- , bgroup "Marshal"- [ benchMarshal "MethodCall/empty" empty_MethodCall- , benchMarshal "MethodReturn/empty" empty_MethodReturn- ]- , bgroup "Unmarshal"- [ benchUnmarshal "MethodCall/empty" empty_MethodCall- , benchUnmarshal "MethodReturn/empty" empty_MethodReturn- ]- ]--main :: IO ()-main = Criterion.Main.defaultMain benchmarks
dbus.cabal view
@@ -1,9 +1,9 @@ name: dbus-version: 1.2.29+version: 1.4.3 license: Apache-2.0 license-file: license.txt author: John Millikin <john@john-millikin.com>-maintainer: Andrey Sverdlichenko <blaze@ruddy.ru>+maintainer: Andrey Sverdlichenko <blaze@rusty.zone> build-type: Simple cabal-version: >= 1.10 category: Network, Desktop@@ -82,25 +82,25 @@ build-depends: base >=4.16 && <5- , bytestring < 0.12+ , bytestring < 0.13 , cereal < 0.6 , conduit >= 1.3.0 && < 1.4- , containers < 0.7- , deepseq < 1.5+ , containers < 0.9+ , deepseq < 1.6 , exceptions < 0.11- , filepath < 1.5- , lens < 5.3- , network >= 3.1.2.1 && < 3.2+ , filepath < 1.6+ , lens < 5.4+ , network >= 3.2 && < 3.3 , parsec < 3.2- , random < 1.3+ , random < 1.4 , split < 0.3- , template-haskell >= 2.18 && < 2.21- , text < 2.1+ , template-haskell >= 2.18 && < 2.25+ , text < 2.2 , th-lift < 0.9 , transformers < 0.7 , unix < 2.9 , vector < 0.14- , xml-conduit >= 1.9.0.0 && < 1.10.0.0+ , xml-conduit >= 1.9.0.0 && < 1.11.0.0 , xml-types < 0.4 exposed-modules:@@ -129,22 +129,23 @@ build-depends: dbus , base >=4 && <5- , bytestring < 0.12+ , bytestring < 0.13 , cereal < 0.6- , containers < 0.7+ , containers < 0.9 , directory < 1.4- , extra < 1.8- , filepath < 1.5- , network >= 3.1.2.1 && < 3.2+ , extra < 1.9+ , filepath < 1.6+ , network >= 3.2 && < 3.3 , parsec < 3.2 , process < 1.7- , QuickCheck < 2.15- , random < 1.3+ , QuickCheck < 2.19+ , random < 1.4 , resourcet < 1.4- , tasty < 1.5+ , tasty < 1.6 , tasty-hunit < 0.11- , tasty-quickcheck < 0.11- , text < 2.1+ , tasty-quickcheck < 0.12+ , temporary >= 1.3 && < 1.4+ , text < 2.2 , transformers < 0.7 , unix < 2.9 , vector < 0.14@@ -169,15 +170,3 @@ DBusTests.Util DBusTests.Variant DBusTests.Wire--benchmark dbus_benchmarks- type: exitcode-stdio-1.0- main-is: DBusBenchmarks.hs- hs-source-dirs: benchmarks- default-language: Haskell2010- ghc-options: -Wall -fno-warn-orphans-- build-depends:- dbus- , base >=4 && <5- , criterion < 1.7
examples/dbus-monitor.hs view
@@ -105,7 +105,7 @@ putStrLn (formatMessage received ++ "\n") -- Message formatting is verbose and mostly uninteresting, except as an--- excersise in string manipulation.+-- exercise in string manipulation. formatMessage :: ReceivedMessage -> String
lib/DBus.hs view
@@ -150,11 +150,13 @@ -- ** Marshal , marshal+ , marshalWithFds , MarshalError , marshalErrorMessage -- ** Unmarshal , unmarshal+ , unmarshalWithFds , UnmarshalError , unmarshalErrorMessage @@ -174,6 +176,7 @@ import qualified Data.ByteString.Char8 as Char8 import Data.Proxy (Proxy(..)) import Data.Word (Word16)+import System.Posix.Types (Fd) import System.Random (randomRIO) import Text.Printf (printf) @@ -188,7 +191,7 @@ typeOf :: IsValue a => a -> Type typeOf = DBus.Internal.Types.typeOf --- | Get the D-Bus type corresponding to the given Haskell type 'a'.+-- | Get the D-Bus type corresponding to the given Haskell type @a@. typeOf' :: IsValue a => Proxy a -> Type typeOf' = DBus.Internal.Types.typeOf_ @@ -197,14 +200,17 @@ -- Use fields such as 'methodCallDestination' and 'methodCallBody' to populate -- a 'MethodCall'. ----- @---{-\# LANGUAGE OverloadedStrings \#-}+-- >>> :seti -XOverloadedStrings -----methodCall \"/\" \"org.example.Math\" \"Add\"--- { 'methodCallDestination' = Just \"org.example.Calculator\"--- , 'methodCallBody' = ['toVariant' (1 :: Int32), 'toVariant' (2 :: Int32)]+-- >>> import Data.Int+--+-- >>> :{+-- (methodCall "/" "org.example.Math" "Add")+-- { methodCallDestination = Just "org.example.Calculator"+-- , methodCallBody = [toVariant (1 :: Int32), toVariant (2 :: Int32)] -- }--- @+-- :}+-- MethodCall {methodCallPath = ObjectPath "/", methodCallInterface = Just (InterfaceName "org.example.Math"), methodCallMember = MemberName "Add", methodCallSender = Nothing, methodCallDestination = Just (BusName "org.example.Calculator"), methodCallReplyExpected = True, methodCallAutoStart = True, methodCallBody = [Variant 1,Variant 2]} methodCall :: ObjectPath -> InterfaceName -> MemberName -> MethodCall methodCall path iface member = MethodCall path (Just iface) member Nothing Nothing True True [] @@ -256,14 +262,32 @@ -- possible for marshaling to fail; if this occurs, an error will be -- returned instead. marshal :: Message msg => Endianness -> Serial -> msg -> Either MarshalError Char8.ByteString-marshal = marshalMessage+marshal end serial msg = fst <$> marshalWithFds end serial msg +-- | Convert a 'Message' into a 'Char8.ByteString' along with all 'Fd' values+-- mentioned in the message (the marshaled bytes will contain indices into+-- this list). Although unusual, it is possible for marshaling to fail; if this+-- occurs, an error will be returned instead.+marshalWithFds :: Message msg => Endianness -> Serial -> msg -> Either MarshalError (Char8.ByteString, [Fd])+marshalWithFds = marshalMessage+ -- | Parse a 'Char8.ByteString' into a 'ReceivedMessage'. The result can be -- inspected to see what type of message was parsed. Unknown message types -- can still be parsed successfully, as long as they otherwise conform to -- the D-Bus standard.+--+-- Unmarshaling will fail if the message contains file descriptors. If you+-- need file descriptor support then use 'unmarshalWithFds' instead. unmarshal :: Char8.ByteString -> Either UnmarshalError ReceivedMessage-unmarshal = unmarshalMessage+unmarshal bs = unmarshalWithFds bs []++-- | Parse a 'Char8.ByteString' into a 'ReceivedMessage'. The 'Fd' values are needed+-- because the marshaled message contains indices into the 'Fd' list rather then+-- 'Fd' values directly. The result can be inspected to see what type of message+-- was parsed. Unknown message types can still be parsed successfully, as long+-- as they otherwise conform to the D-Bus standard.+unmarshalWithFds :: Char8.ByteString -> [Fd] -> Either UnmarshalError ReceivedMessage+unmarshalWithFds = unmarshalMessage -- | A D-Bus UUID is 128 bits of data, usually randomly generated. They are -- used for identifying unique server instances to clients.
lib/DBus/Client.hs view
@@ -35,30 +35,27 @@ -- -- Example: connect to the session bus, and get a list of active names. ----- @---{-\# LANGUAGE OverloadedStrings \#-}+-- >>> :seti -XOverloadedStrings -----import Data.List (sort)---import DBus---import DBus.Client+-- >>> import Data.List (sort)+-- >>> import DBus+-- >>> import DBus.Client -----main = do--- client <- 'connectSession'--- //--- \-- Request a list of connected clients from the bus--- reply <- 'call_' client ('methodCall' \"\/org\/freedesktop\/DBus\" \"org.freedesktop.DBus\" \"ListNames\")--- { 'methodCallDestination' = Just \"org.freedesktop.DBus\"+-- >>> :{+-- getActiveNames :: IO ()+-- getActiveNames = do+-- client <- connectSession+-- -- Request a list of connected clients from the bus+-- reply <- call_ client (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "ListNames")+-- { methodCallDestination = Just "org.freedesktop.DBus" -- }--- //--- \-- org.freedesktop.DBus.ListNames() returns a single value, which is--- \-- a list of names (here represented as [String])--- let Just names = 'fromVariant' ('methodReturnBody' reply !! 0)--- //--- \-- Print each name on a line, sorted so reserved names are below--- \-- temporary names.+-- -- org.freedesktop.DBus.ListNames() returns a single value, which is+-- -- a list of names (here represented as [String])+-- let Just names = fromVariant (methodReturnBody reply !! 0)+-- -- Print each name on a line, sorted so reserved names are below+-- -- temporary names. -- mapM_ putStrLn (sort names)--- @---+-- :} module DBus.Client ( -- * Clients@@ -181,7 +178,6 @@ import Data.Coerce import Data.Foldable hiding (forM_, and) import Data.Function-import Data.Functor ((<$>)) import Data.IORef import Data.List (intercalate, isPrefixOf) import Data.Map.Strict (Map)@@ -292,7 +288,7 @@ -- NOTE: This instance is needed to make modifyNothingHandler work, but it -- shouldn't really be used for much else. A more complete implementation can't--- be provided because PathInfo > Interface > Method conatain functions which+-- be provided because PathInfo > Interface > Method contain functions which -- can't/don't have an eq instance. instance Eq PathInfo where a == b = null (_pathInterfaces a) &&@@ -757,7 +753,7 @@ -- reserves @\"org.freedesktop.NetworkManager\"@ on the system bus. -- -- * When there are multiple implementations of a particular service, the--- service standard will ususally include a generic bus name for the+-- service standard will usually include a generic bus name for the -- service. This allows other clients to avoid depending on any particular -- implementation's name. For example, both the GNOME Keyring and KDE -- KWallet services request the @\"org.freedesktop.secrets\"@ name on the@@ -898,7 +894,7 @@ , methodErrorSender = sender } $ fromVariant variant --- | Retrieve a property using the method call parameters that were provided.+-- | Like `getPropertyValue`, but returns the value as a 'Variant'. -- -- Throws a 'ClientError' if the property request couldn't be sent. getProperty :: Client -> MethodCall -> IO (Either MethodError Variant)@@ -914,10 +910,19 @@ ] } +-- | Get a property using the standard @\"org.freedesktop.DBus.Properties.Get\"@ method.+-- The interface and property name are given by the 'methodCallInterface' and 'methodCallMember'+-- fields of the supplied 'MethodCall'. This function handles properties of fixed type. For+-- properties of varying types, use 'getProperty'.+--+-- Throws a 'ClientError' if the property request couldn't be sent. getPropertyValue :: IsValue a => Client -> MethodCall -> IO (Either MethodError a) getPropertyValue client msg = (>>= unpackVariant msg) <$> getProperty client msg +-- | Like 'setPropertyValue', but expects the new value to be wrapped in a 'Variant'.+--+-- Throws a 'ClientError' if the property request couldn't be sent. setProperty :: Client -> MethodCall -> Variant -> IO (Either MethodError MethodReturn) setProperty client msg@MethodCall { methodCallInterface = interface@@ -928,10 +933,15 @@ , methodCallBody = [ toVariant (coerce (orDefaultInterface interface) :: String) , toVariant (coerce member :: String)- , value+ , toVariant value ] } +-- | Set a property using the standard @\"org.freedesktop.DBus.Properties.Set\"@ method.+-- The interface and property name are given by the 'methodCallInterface' and 'methodCallMember'+-- fields of the supplied 'MethodCall'. See `setProperty` for a version that accepts a 'Variant'.+--+-- Throws a 'ClientError' if the property request couldn't be sent. setPropertyValue :: IsValue a => Client -> MethodCall -> a -> IO (Maybe MethodError)@@ -1240,24 +1250,33 @@ -- Use 'autoMethod' to construct a 'Method' from a function that accepts and -- returns simple types. ----- Use 'method' to construct a 'Method' from a function that handles parameter+-- Use 'makeMethod' to construct a 'Method' from a function that handles parameter -- conversion manually. ----- @---ping :: MethodCall -> IO 'Reply'---ping _ = ReplyReturn []+-- >>> :seti -XOverloadedStrings -----sayHello :: String -> IO String---sayHello name = return (\"Hello \" ++ name ++ \"!\")+-- >>> :{+-- ping :: MethodCall -> DBusR Reply+-- ping _ = pure $ ReplyReturn []+-- :} ----- export client \"/hello_world\"--- defaultInterface { interfaceName = \"com.example.HelloWorld\"--- , interfaceMethods =--- [ 'method' \"com.example.HelloWorld\" \"Ping\" ping--- , 'autoMethod' \"com.example.HelloWorld\" \"Hello\" sayHello--- ]--- }--- @+-- >>> :{+-- sayHello :: String -> IO String+-- sayHello name = return ("Hello " ++ name ++ "!")+-- :}+--+-- >>> :{+-- doExport :: IO ()+-- doExport = do+-- client <- connectSession+-- export client "/hello_world"+-- defaultInterface { interfaceName = "com.example.HelloWorld"+-- , interfaceMethods =+-- [ makeMethod "Ping" (signature_ []) (signature_ []) ping+-- , autoMethod "Hello" sayHello+-- ]+-- }+-- :} export :: Client -> ObjectPath -> Interface -> IO () export client path interface = atomicModifyIORef_ (clientObjects client) $ addInterface path interface
lib/DBus/Generation.hs view
@@ -13,7 +13,6 @@ import qualified Data.ByteString as BS import qualified Data.Char as Char import Data.Coerce-import Data.Functor ((<$>)) import Data.Int import Data.List import qualified Data.Map as Map@@ -73,7 +72,7 @@ where fn t = case t of -- Because of a quirk in how we unmarshal things, we currently HAVE- -- to decorde arrays of Word8 in this way.+ -- to decode arrays of Word8 in this way. T.TypeArray T.TypeWord8 -> ConT ''BS.ByteString T.TypeBoolean -> ConT ''Bool T.TypeWord8 -> ConT ''Word8
lib/DBus/Internal/Types.hs view
@@ -836,7 +836,7 @@ Parsec.skipMany (oneOf alphanum) -- | A D-Bus Structure is a container type similar to Haskell tuples, storing--- values of any type that is convertable to 'IsVariant'. A Structure may+-- values of any type that is convertible to 'IsVariant'. A Structure may -- contain up to 255 values. -- -- Most users can use the 'IsVariant' instance for tuples to extract the
lib/DBus/Internal/Wire.hs view
@@ -1,3 +1,4 @@+{-# Language LambdaCase #-} -- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com> -- -- This program is free software: you can redistribute it and/or modify@@ -34,6 +35,7 @@ import qualified Data.ByteString.Char8 import qualified Data.ByteString.Lazy as Lazy import Data.Int (Int16, Int32, Int64)+import Data.List (sortOn) import qualified Data.Map import Data.Map (Map) import Data.Maybe (fromJust, listToMaybe, fromMaybe)@@ -43,7 +45,6 @@ import qualified Data.Vector import Data.Vector (Vector) import Data.Word (Word8, Word16, Word32, Word64)-import Foreign.C.Types (CInt) import System.Posix.Types (Fd(..)) import Prelude @@ -108,25 +109,22 @@ instance Control.Applicative.Applicative (Wire s) where {-# INLINE pure #-}- pure = return+ pure a = Wire (\_ s -> WireRR a s) + {-# INLINE (*>) #-}+ m *> k = Wire $ \e s -> case unWire m e s of+ WireRL err -> WireRL err+ WireRR _ s' -> unWire k e s'+ {-# INLINE (<*>) #-} (<*>) = ap instance Monad (Wire s) where- {-# INLINE return #-}- return a = Wire (\_ s -> WireRR a s)- {-# INLINE (>>=) #-} m >>= k = Wire $ \e s -> case unWire m e s of WireRL err -> WireRL err WireRR a s' -> unWire (k a) e s' - {-# INLINE (>>) #-}- m >> k = Wire $ \e s -> case unWire m e s of- WireRL err -> WireRL err- WireRR _ s' -> unWire k e s'- throwError :: String -> Wire s a throwError err = Wire (\_ _ -> WireRL err) @@ -155,6 +153,7 @@ data MarshalState = MarshalState !Builder.Builder {-# UNPACK #-} !Word64+ !(Map Fd Word32) marshal :: Value -> Marshal () marshal (ValueAtom x) = marshalAtom x@@ -180,10 +179,10 @@ marshalAtom (AtomSignature x) = marshalSignature x appendB :: Word64 -> Builder.Builder -> Marshal ()-appendB size bytes = Wire (\_ (MarshalState builder count) -> let+appendB size bytes = Wire (\_ (MarshalState builder count fds) -> let builder' = mappend builder bytes count' = count + size- in WireRR () (MarshalState builder' count'))+ in WireRR () (MarshalState builder' count' fds)) appendS :: ByteString -> Marshal () appendS bytes = appendB@@ -197,7 +196,7 @@ pad :: Word8 -> Marshal () pad count = do- (MarshalState _ existing) <- getState+ (MarshalState _ existing _) <- getState let padding' = fromIntegral (padding existing count) appendS (Data.ByteString.replicate padding' 0) @@ -221,6 +220,7 @@ data UnmarshalState = UnmarshalState {-# UNPACK #-} !ByteString {-# UNPACK #-} !Word64+ ![Fd] unmarshal :: Type -> Unmarshal Value unmarshal TypeWord8 = liftM toValue unmarshalWord8@@ -245,19 +245,19 @@ {-# INLINE consume #-} consume :: Word64 -> Unmarshal ByteString consume count = do- (UnmarshalState bytes offset) <- getState+ (UnmarshalState bytes offset fds) <- getState let count' = fromIntegral count let (x, bytes') = Data.ByteString.splitAt count' bytes let lenConsumed = Data.ByteString.length x if lenConsumed == count' then do- putState (UnmarshalState bytes' (offset + count))+ putState (UnmarshalState bytes' (offset + count) fds) return x else throwError ("Unexpected EOF at offset " ++ show (offset + fromIntegral lenConsumed)) skipPadding :: Word8 -> Unmarshal () skipPadding count = do- (UnmarshalState _ offset) <- getState+ (UnmarshalState _ offset _) <- getState bytes <- consume (padding offset count) unless (Data.ByteString.all (== 0) bytes) (throwError ("Value padding " ++ show bytes ++ " contains invalid bytes."))@@ -346,17 +346,25 @@ getFloat64le marshalUnixFd :: Fd -> Marshal ()-marshalUnixFd (Fd x)+marshalUnixFd fd@(Fd x) | x < 0 = throwError ("Invalid file descriptor: " ++ show x) | toInteger x > toInteger (maxBound :: Word32) = throwError ("D-Bus forbids file descriptors exceeding UINT32_MAX: " ++ show x)- | otherwise = marshalWord32 (fromIntegral x)+ | otherwise = do+ MarshalState builder count fds <- getState+ case Data.Map.lookup fd fds of+ Just i -> marshalWord32 i+ Nothing -> do+ let i = fromIntegral (Data.Map.size fds)+ putState (MarshalState builder count (Data.Map.insert fd i fds))+ marshalWord32 i unmarshalUnixFd :: Unmarshal Fd unmarshalUnixFd = do- x <- unmarshalWord32- when (toInteger x > toInteger (maxBound :: CInt))- (throwError ("Invalid file descriptor: " ++ show x))- return (Fd (fromIntegral x))+ x <- fromIntegral <$> unmarshalWord32+ UnmarshalState _ _ fds <- getState+ when (x >= length fds) $ do+ throwError ("File descriptor index " ++ show x ++ " out of bounds - only " ++ show (length fds) ++ " file descriptors in message header.")+ return (fds !! x) marshalBool :: Bool -> Marshal () marshalBool False = marshalWord32 0@@ -443,17 +451,17 @@ getArrayBytes :: Type -> Vector Value -> Marshal (Int, Lazy.ByteString) getArrayBytes itemType vs = do- s <- getState- (MarshalState _ afterLength) <- marshalWord32 0 >> getState- (MarshalState _ afterPadding) <- pad (alignment itemType) >> getState+ (MarshalState bytes count fds) <- getState+ (MarshalState _ afterLength _) <- marshalWord32 0 >> getState+ (MarshalState _ afterPadding _) <- pad (alignment itemType) >> getState - putState (MarshalState mempty afterPadding)- (MarshalState itemBuilder _) <- Data.Vector.mapM_ marshal vs >> getState+ putState (MarshalState mempty afterPadding fds)+ (MarshalState itemBuilder _ fds') <- Data.Vector.mapM_ marshal vs >> getState let itemBytes = Builder.toLazyByteString itemBuilder paddingSize = fromIntegral (afterPadding - afterLength) - putState s+ putState (MarshalState bytes count fds') return (paddingSize, itemBytes) unmarshalByteArray :: Unmarshal ByteString@@ -464,7 +472,7 @@ unmarshalArray :: Type -> Unmarshal (Vector Value) unmarshalArray itemType = do let getOffset = do- (UnmarshalState _ o) <- getState+ (UnmarshalState _ o _) <- getState return o byteCount <- unmarshalWord32 skipPadding (alignment itemType)@@ -472,7 +480,7 @@ let end = start + fromIntegral byteCount vs <- untilM (liftM (>= end) getOffset) (unmarshal itemType) end' <- getOffset- when (end' > end) (throwError ("Array data size exeeds array size of " ++ show end))+ when (end' > end) (throwError ("Array data size exceeds array size of " ++ show end)) return (Data.Vector.fromList vs) dictionaryToArray :: Map Atom Value -> Vector Value@@ -564,35 +572,37 @@ Nothing -> throwErrorM (UnmarshalError ("Header field " ++ show label ++ " contains invalid value " ++ show x)) marshalMessage :: Message a => Endianness -> Serial -> a- -> Either MarshalError ByteString+ -> Either MarshalError (ByteString, [Fd]) marshalMessage e serial msg = runMarshal where body = messageBody msg marshaler = do sig <- checkBodySig body- empty <- getState+ MarshalState emptyBytes emptyCount _ <- getState mapM_ (marshal . (\(Variant x) -> x)) body- (MarshalState bodyBytesB _) <- getState- putState empty+ (MarshalState bodyBytesB _ fds) <- getState+ putState (MarshalState emptyBytes emptyCount fds) marshal (toValue (encodeEndianness e)) let bodyBytes = Builder.toLazyByteString bodyBytesB- marshalHeader msg serial sig (fromIntegral (Lazy.length bodyBytes))+ marshalHeader msg serial sig (fromIntegral (Lazy.length bodyBytes)) (Data.Map.size fds) pad 8 appendL bodyBytes checkMaximumSize- emptyState = MarshalState mempty 0+ emptyState = MarshalState mempty 0 mempty runMarshal = case unWire marshaler e emptyState of WireRL err -> Left (MarshalError err)- WireRR _ (MarshalState builder _) -> Right (Lazy.toStrict (Builder.toLazyByteString builder))+ WireRR _ (MarshalState builder _ fds) ->+ let fdList = (map fst . sortOn snd . Data.Map.toList) fds+ in Right (Lazy.toStrict (Builder.toLazyByteString builder), fdList) checkBodySig :: [Variant] -> Marshal Signature checkBodySig vs = case signature (map variantType vs) of Just x -> return x Nothing -> throwError ("Message body " ++ show vs ++ " has too many items") -marshalHeader :: Message a => a -> Serial -> Signature -> Word32+marshalHeader :: Message a => a -> Serial -> Signature -> Word32 -> Int -> Marshal ()-marshalHeader msg serial bodySig bodyLength = do- let fields = HeaderSignature bodySig : messageHeaderFields msg+marshalHeader msg serial bodySig bodyLength numFds = do+ let fields = HeaderSignature bodySig : consUnixFdsField numFds (messageHeaderFields msg) marshalWord8 (messageTypeCode msg) marshalWord8 (messageFlags msg) marshalWord8 protocolVersion@@ -601,23 +611,34 @@ let fieldType = TypeStructure [TypeWord8, TypeVariant] marshalVector fieldType (Data.Vector.fromList (map encodeField fields)) +consUnixFdsField :: Int -> [HeaderField] -> [HeaderField]+consUnixFdsField numFds headers =+ if numFds == 0+ then filteredHeaders+ else HeaderUnixFds (fromIntegral numFds) : filteredHeaders+ where+ filteredHeaders = filter (not . isHeaderUnixFds) headers+ isHeaderUnixFds = \case+ HeaderUnixFds _ -> True+ _ -> False+ checkMaximumSize :: Marshal () checkMaximumSize = do- (MarshalState _ messageLength) <- getState+ (MarshalState _ messageLength _) <- getState when (toInteger messageLength > messageMaximumLength)- (throwError ("Marshaled message size (" ++ show messageLength ++ " bytes) exeeds maximum limit of (" ++ show messageMaximumLength ++ " bytes)."))+ (throwError ("Marshaled message size (" ++ show messageLength ++ " bytes) exceeds maximum limit of (" ++ show messageMaximumLength ++ " bytes).")) -unmarshalMessageM :: Monad m => (Int -> m ByteString)+unmarshalMessageM :: Monad m => (Int -> m (ByteString, [Fd])) -> m (Either UnmarshalError ReceivedMessage) unmarshalMessageM getBytes' = runErrorT $ do let getBytes count = do- bytes <- ErrorT (liftM Right (getBytes' count))+ (bytes, fds) <- ErrorT (liftM Right (getBytes' count)) if Data.ByteString.length bytes < count then throwErrorT (UnmarshalError "Unexpected end of input while parsing message header.")- else return bytes+ else return (bytes, fds) let Just fixedSig = parseSignature "yyyyuuu"- fixedBytes <- getBytes 16+ (fixedBytes, fixedFds) <- getBytes 16 let messageVersion = Data.ByteString.index fixedBytes 3 when (messageVersion /= protocolVersion) (throwErrorT (UnmarshalError ("Unsupported protocol version: " ++ show messageVersion)))@@ -628,10 +649,10 @@ Nothing -> throwErrorT (UnmarshalError ("Invalid endianness: " ++ show eByte)) let unmarshalSig = mapM unmarshal . signatureTypes- let unmarshal' x bytes = case unWire (unmarshalSig x) endianness (UnmarshalState bytes 0) of+ let unmarshal' x bytes fds = case unWire (unmarshalSig x) endianness (UnmarshalState bytes 0 fds) of WireRR x' _ -> return x' WireRL err -> throwErrorT (UnmarshalError err)- fixed <- unmarshal' fixedSig fixedBytes+ fixed <- unmarshal' fixedSig fixedBytes [] let messageType = fromJust (fromValue (fixed !! 1)) let flags = fromJust (fromValue (fixed !! 2)) let bodyLength = fromJust (fromValue (fixed !! 4)) :: Word32@@ -646,26 +667,39 @@ throwErrorT (UnmarshalError ("Message size " ++ show messageLength ++ " exceeds limit of " ++ show messageMaximumLength)) let Just headerSig = parseSignature "yyyyuua(yv)"- fieldBytes <- getBytes (fromIntegral fieldByteCount)+ (fieldBytes, fieldFds) <- getBytes (fromIntegral fieldByteCount) let headerBytes = Data.ByteString.append fixedBytes fieldBytes- header <- unmarshal' headerSig headerBytes+ header <- unmarshal' headerSig headerBytes [] let fieldArray = Data.Vector.toList (fromJust (fromValue (header !! 6))) fields <- case runErrorM $ concat `liftM` mapM decodeField fieldArray of Left err -> throwErrorT err Right x -> return x- _ <- getBytes (fromIntegral bodyPadding)+ (_, paddingFds) <- getBytes (fromIntegral bodyPadding) let bodySig = findBodySignature fields- bodyBytes <- getBytes (fromIntegral bodyLength)- body <- unmarshal' bodySig bodyBytes+ (bodyBytes, bodyFds) <- getBytes (fromIntegral bodyLength)+ let fds = fixedFds <> fieldFds <> paddingFds <> bodyFds+ checkUnixFdsHeader fields fds+ body <- unmarshal' bodySig bodyBytes fds y <- case runErrorM (buildReceivedMessage messageType fields) of Right x -> return x Left err -> throwErrorT (UnmarshalError ("Header field " ++ show err ++ " is required, but missing")) return (y serial flags (map Variant body)) +checkUnixFdsHeader :: Monad m => [HeaderField] -> [Fd] -> ErrorT UnmarshalError m ()+checkUnixFdsHeader fields fds = do+ let headerCount = findUnixFds fields+ when (headerCount /= length fds) $+ throwErrorT (UnmarshalError ("File descriptor count in message header"+ <> " (" <> show headerCount <> ") does not match the number of file descriptors"+ <> " received from the socket (" <> show (length fds) <> ")."))+ findBodySignature :: [HeaderField] -> Signature findBodySignature fields = fromMaybe (signature_ []) (listToMaybe [x | HeaderSignature x <- fields]) +findUnixFds :: [HeaderField] -> Int+findUnixFds fields = fromMaybe 0 (listToMaybe [fromIntegral n | HeaderUnixFds n <- fields])+ buildReceivedMessage :: Word8 -> [HeaderField] -> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage) buildReceivedMessage 1 fields = do path <- require "path" [x | HeaderPath x <- fields]@@ -713,15 +747,16 @@ require _ (x:_) = return x require label _ = throwErrorM label -unmarshalMessage :: ByteString -> Either UnmarshalError ReceivedMessage-unmarshalMessage bytes = checkError (Get.runGet get bytes) where+unmarshalMessage :: ByteString -> [Fd] -> Either UnmarshalError ReceivedMessage+unmarshalMessage bytes fds = checkError (Get.runGet get bytes) where get = unmarshalMessageM getBytes -- wrap getByteString, so it will behave like transportGet and return -- a truncated result on EOF instead of throwing an exception. getBytes count = do remaining <- Get.remaining- Get.getByteString (min remaining count)+ buf <- Get.getByteString (min remaining count)+ return (buf, if remaining == Data.ByteString.length bytes then fds else []) checkError (Left err) = Left (UnmarshalError err) checkError (Right x) = x@@ -749,11 +784,10 @@ Right x -> Right (f x) instance Control.Applicative.Applicative (ErrorM e) where- pure = return+ pure = ErrorM . Right (<*>) = ap instance Monad (ErrorM e) where- return = ErrorM . Right (>>=) m k = case runErrorM m of Left err -> ErrorM (Left err) Right x -> k x@@ -767,11 +801,10 @@ fmap = liftM instance Monad m => Control.Applicative.Applicative (ErrorT e m) where- pure = return+ pure = ErrorT . return . Right (<*>) = ap instance Monad m => Monad (ErrorT e m) where- return = ErrorT . return . Right (>>=) m k = ErrorT $ do x <- runErrorT m case x of
lib/DBus/Introspection/Render.hs view
@@ -13,7 +13,6 @@ import Control.Monad.ST import Control.Monad.Trans.Maybe import Data.List (isPrefixOf)-import Data.Monoid ((<>)) import Data.XML.Types (Event) import qualified Data.Text as T import qualified Data.Text.Lazy as TL@@ -38,7 +37,7 @@ formatXML :: Object -> Maybe String formatXML obj = do xml <- runST $ runMaybeT $ runRender $ runConduit $- renderRoot obj .| R.renderText (R.def {R.rsPretty = True}) .| sinkLazy+ renderRoot obj .| R.renderText R.def .| sinkLazy pure $ TL.unpack xml renderRoot :: MonadThrow m => Object -> ConduitT i Event m ()
lib/DBus/Socket.hs view
@@ -57,6 +57,7 @@ -- * Authentication , Authenticator , authenticator+ , authenticatorWithUnixFds , authenticatorClient , authenticatorServer ) where@@ -99,7 +100,9 @@ data TransportOptions SomeTransport = SomeTransportOptions transportDefaultOptions = SomeTransportOptions transportPut (SomeTransport t) = transportPut t+ transportPutWithFds (SomeTransport t) = transportPutWithFds t transportGet (SomeTransport t) = transportGet t+ transportGetWithFds (SomeTransport t) = transportGetWithFds t transportClose (SomeTransport t) = transportClose t -- | An open socket to another process. Messages can be sent to the remote@@ -142,11 +145,11 @@ } -- | Default 'SocketOptions', which uses the default Unix/TCP transport and--- authenticator.+-- authenticator (without support for Unix file descriptor passing). defaultSocketOptions :: SocketOptions SocketTransport defaultSocketOptions = SocketOptions { socketTransportOptions = transportDefaultOptions- , socketAuthenticator = authExternal+ , socketAuthenticator = authExternal UnixFdsNotSupported } -- | Open a socket to a remote peer listening at the given address.@@ -256,11 +259,11 @@ send :: Message msg => Socket -> msg -> (Serial -> IO a) -> IO a send sock msg io = toSocketError (socketAddress sock) $ do serial <- nextSocketSerial sock- case marshal LittleEndian serial msg of- Right bytes -> do+ case marshalWithFds LittleEndian serial msg of+ Right (bytes, fds) -> do let t = socketTransport sock a <- io serial- withMVar (socketWriteLock sock) (\_ -> transportPut t bytes)+ withMVar (socketWriteLock sock) (\_ -> transportPutWithFds t bytes fds) return a Left err -> throwIO (socketError ("Message cannot be sent: " ++ show err)) { socketErrorFatal = False@@ -283,8 +286,8 @@ -- outside of the lock. let t = socketTransport sock let get n = if n == 0- then return Data.ByteString.empty- else transportGet t n+ then return (Data.ByteString.empty, [])+ else transportGetWithFds t n received <- withMVar (socketReadLock sock) (\_ -> unmarshalMessageM get) case received of Left err -> throwIO (socketError ("Error reading message from socket: " ++ show err))@@ -310,29 +313,45 @@ -- | An empty authenticator. Use 'authenticatorClient' or 'authenticatorServer' -- to control how the authentication is performed. ----- @---myAuthenticator :: Authenticator MyTransport---myAuthenticator = authenticator--- { 'authenticatorClient' = clientMyAuth--- , 'authenticatorServer' = serverMyAuth--- }+-- >>> data MyTransport -----clientMyAuth :: MyTransport -> IO Bool---serverMyAuth :: MyTransport -> String -> IO Bool--- @+-- >>> :{+-- clientMyAuth :: MyTransport -> IO Bool+-- clientMyAuth = error "example"+-- :}+--+-- >>> :{+-- serverMyAuth :: MyTransport -> UUID -> IO Bool+-- serverMyAuth = error "example"+-- :}+--+-- >>> :{+-- myAuthenticator :: Authenticator MyTransport+-- myAuthenticator = authenticator+-- { authenticatorClient = clientMyAuth+-- , authenticatorServer = serverMyAuth+-- }+-- :} authenticator :: Authenticator t authenticator = Authenticator (\_ -> return False) (\_ _ -> return False) +data UnixFdSupport = UnixFdsSupported | UnixFdsNotSupported++-- | An authenticator that implements the D-Bus @EXTERNAL@ mechanism, which uses+-- credential passing over a Unix socket, with support for Unix file descriptor passing.+authenticatorWithUnixFds :: Authenticator SocketTransport+authenticatorWithUnixFds = authExternal UnixFdsSupported+ -- | Implements the D-Bus @EXTERNAL@ mechanism, which uses credential--- passing over a Unix socket.-authExternal :: Authenticator SocketTransport-authExternal = authenticator- { authenticatorClient = clientAuthExternal- , authenticatorServer = serverAuthExternal+-- passing over a Unix socket, optionally supporting Unix file descriptor passing.+authExternal :: UnixFdSupport -> Authenticator SocketTransport+authExternal unixFdSupport = authenticator+ { authenticatorClient = clientAuthExternal unixFdSupport+ , authenticatorServer = serverAuthExternal unixFdSupport } -clientAuthExternal :: SocketTransport -> IO Bool-clientAuthExternal t = do+clientAuthExternal :: UnixFdSupport -> SocketTransport -> IO Bool+clientAuthExternal unixFdSupport t = do transportPut t (Data.ByteString.pack [0]) uid <- System.Posix.User.getRealUserID let token = concatMap (printf "%02X" . ord) (show uid)@@ -340,17 +359,38 @@ resp <- transportGetLine t case splitPrefix "OK " resp of Just _ -> do- transportPutLine t "BEGIN"- return True+ ok <- do+ case unixFdSupport of+ UnixFdsSupported -> do+ transportPutLine t "NEGOTIATE_UNIX_FD"+ respFd <- transportGetLine t+ return (respFd == "AGREE_UNIX_FD")+ UnixFdsNotSupported -> do+ return True+ if ok then do+ transportPutLine t "BEGIN"+ return True+ else+ return False Nothing -> return False -serverAuthExternal :: SocketTransport -> UUID -> IO Bool-serverAuthExternal t uuid = do- let waitForBegin = do- resp <- transportGetLine t- if resp == "BEGIN"- then return ()- else waitForBegin+serverAuthExternal :: UnixFdSupport -> SocketTransport -> UUID -> IO Bool+serverAuthExternal unixFdSupport t uuid = do+ let negotiateFdsAndBegin = do+ line <- transportGetLine t+ case line of+ "NEGOTIATE_UNIX_FD" -> do+ let msg = case unixFdSupport of+ UnixFdsSupported ->+ "AGREE_UNIX_FD"+ UnixFdsNotSupported ->+ "ERROR Unix File Descriptor support is not configured."+ transportPutLine t msg+ negotiateFdsAndBegin+ "BEGIN" ->+ return ()+ _ ->+ negotiateFdsAndBegin let checkToken token = do (_, uid, _) <- socketTransportCredentials t@@ -358,7 +398,7 @@ if token == wantToken then do transportPutLine t ("OK " ++ formatUUID uuid)- waitForBegin+ negotiateFdsAndBegin return True else return False
lib/DBus/Transport.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} -- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>@@ -36,18 +37,31 @@ , socketTransportCredentials ) where +import Control.Concurrent (rtsSupportsBoundThreads, threadWaitWrite) import Control.Exception+import Control.Monad (when) import qualified Data.ByteString-import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as Builder+import Data.ByteString.Internal (ByteString(PS)) import qualified Data.ByteString.Lazy as Lazy+import Data.ByteString.Unsafe (unsafeUseAsCString)+import qualified Data.Kind import qualified Data.Map as Map+import Data.Maybe (fromMaybe) import Data.Monoid import Data.Typeable (Typeable)-import Foreign.C (CUInt)+import Foreign.C (CInt, CUInt)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Array (peekArray)+import Foreign.Ptr (castPtr, plusPtr)+import Foreign.Storable (sizeOf) import Network.Socket-import Network.Socket.ByteString (sendAll, recv)+import Network.Socket.Internal (NullSockAddr(..))+import qualified Network.Socket.Address+import Network.Socket.ByteString (recvMsg) import qualified System.Info+import System.IO.Unsafe (unsafeDupablePerformIO)+import System.Posix.Types (Fd) import Prelude import DBus@@ -68,7 +82,7 @@ class Transport t where -- | Additional options that this transport type may use when establishing -- a connection.- data TransportOptions t :: *+ data TransportOptions t :: Data.Kind.Type -- | Default values for this transport's options. transportDefaultOptions :: TransportOptions t@@ -77,6 +91,12 @@ -- -- Throws a 'TransportError' if an error occurs. transportPut :: t -> ByteString -> IO ()+ + -- | Send a 'ByteString' and Unix file descriptors over the transport.+ --+ -- Throws a 'TransportError' if an error occurs.+ transportPutWithFds :: t -> ByteString -> [Fd] -> IO ()+ transportPutWithFds t bs _fds = transportPut t bs -- | Receive a 'ByteString' of the given size from the transport. The -- transport should block until sufficient bytes are available, and@@ -86,6 +106,18 @@ -- Throws a 'TransportError' if an error occurs. transportGet :: t -> Int -> IO ByteString + -- | Receive a 'ByteString' of the given size from the transport, plus+ -- any Unix file descriptors that arrive with the byte data. The+ -- transport should block until sufficient bytes are available, and+ -- only return fewer than the requested amount if there will not be+ -- any more data.+ --+ -- Throws a 'TransportError' if an error occurs.+ transportGetWithFds :: t -> Int -> IO (ByteString, [Fd])+ transportGetWithFds t n = do+ bs <- transportGet t n+ return (bs, [])+ -- | Close an open transport, and release any associated resources -- or handles. transportClose :: t -> IO ()@@ -102,7 +134,7 @@ -- peers. class Transport t => TransportListen t where -- | Used for transports that listen on a port or address.- data TransportListener t :: *+ data TransportListener t :: Data.Kind.Type -- | Begin listening for connections on the given address, using the -- given options.@@ -145,30 +177,40 @@ socketTransportOptionBacklog :: Int } transportDefaultOptions = SocketTransportOptions 30- transportPut (SocketTransport addr s) bytes = catchIOException addr (sendAll s bytes)- transportGet (SocketTransport addr s) n = catchIOException addr (recvLoop s n)+ transportPut st bytes = transportPutWithFds st bytes []+ transportPutWithFds (SocketTransport addr s) bytes fds = catchIOException addr (sendWithFds s bytes fds)+ transportGet st n = fst <$> transportGetWithFds st n+ transportGetWithFds (SocketTransport addr s) n = catchIOException addr (recvWithFds s n) transportClose (SocketTransport addr s) = catchIOException addr (close s) -recvLoop :: Socket -> Int -> IO ByteString-recvLoop s = \n -> Lazy.toStrict `fmap` loop mempty n where- chunkSize = 4096- loop acc n = if n > chunkSize- then do- chunk <- recv s chunkSize- let builder = mappend acc (Builder.byteString chunk)- loop builder (n - Data.ByteString.length chunk)- else do- chunk <- recv s n- case Data.ByteString.length chunk of- -- Unexpected end of connection; maybe the remote end went away.- -- Return what we've got so far.- 0 -> return (Builder.toLazyByteString acc)+sendWithFds :: Socket -> ByteString -> [Fd] -> IO ()+sendWithFds s msg fds = loop 0 where+ loop acc = do+ let cmsgs = if acc == 0 then (encodeCmsg . (pure :: Fd -> [Fd]) <$> fds) else []+ n <- unsafeUseAsCString msg $ \cstr -> do+ let buf = [(plusPtr (castPtr cstr) acc, len - acc)]+ Network.Socket.Address.sendBufMsg s NullSockAddr buf cmsgs mempty+ waitWhen0 n s -- copy Network.Socket.ByteString.sendAll+ when (acc + n < len) $ do+ loop (acc + n)+ len = Data.ByteString.length msg - len -> do- let builder = mappend acc (Builder.byteString chunk)- if len == n- then return (Builder.toLazyByteString builder)- else loop builder (n - Data.ByteString.length chunk)+recvWithFds :: Socket -> Int -> IO (ByteString, [Fd])+recvWithFds s = loop mempty [] where+ loop accBuf accFds n = do+ (_sa, buf, cmsgs, flag) <- recvMsg s (min n chunkSize) cmsgsSize mempty+ let recvLen = Data.ByteString.length buf+ accBuf' = accBuf <> Builder.byteString buf+ accFds' = accFds <> decodeFdCmsgs cmsgs+ case flag of+ MSG_CTRUNC -> throwIO (transportError ("Unexpected MSG_CTRUNC: more than " <> show maxFds <> " file descriptors?"))+ -- no data means unexpected end of connection; maybe the remote end went away.+ _ | recvLen == 0 || recvLen == n -> do+ return (Lazy.toStrict (Builder.toLazyByteString accBuf'), accFds')+ _ -> loop accBuf' accFds' (n - recvLen)+ chunkSize = 4096+ maxFds = 16 -- same as DBUS_DEFAULT_MESSAGE_UNIX_FDS in DBUS reference implementation+ cmsgsSize = sizeOf (undefined :: CInt) * maxFds instance TransportOpen SocketTransport where transportOpen _ a = case addressMethod a of@@ -446,3 +488,24 @@ if word > 0 && word <= 65535 then Just (fromInteger word) else Nothing++-- | Copied from Network.Socket.ByteString.IO+waitWhen0 :: Int -> Socket -> IO ()+waitWhen0 0 s = when rtsSupportsBoundThreads $+ withFdSocket s $ \fd -> threadWaitWrite $ fromIntegral fd+waitWhen0 _ _ = return ()++decodeFdCmsgs :: [Cmsg] -> [Fd]+decodeFdCmsgs cmsgs =+ foldMap (fromMaybe [] . decodeFdCmsg) cmsgs++-- | Special decode function to handle > 1 Fd. Should be able to replace with a function+-- from the network package in future (https://github.com/haskell/network/issues/566)+decodeFdCmsg :: Cmsg -> Maybe [Fd]+decodeFdCmsg (Cmsg cmsid (PS fptr off len))+ | cmsid /= CmsgIdFds = Nothing+ | otherwise =+ unsafeDupablePerformIO $ withForeignPtr fptr $ \p0 -> do+ let p = castPtr (p0 `plusPtr` off)+ numFds = len `div` sizeOf (undefined :: Fd)+ Just <$> peekArray numFds p
tests/DBusTests/Introspection.hs view
@@ -15,7 +15,6 @@ module DBusTests.Introspection (test_Introspection) where -import Control.Applicative ((<$>), (<*>)) import Control.Monad (liftM, liftM2) import Test.QuickCheck import Test.Tasty
tests/DBusTests/Serialization.hs view
@@ -52,32 +52,32 @@ test_MethodCall = testProperty "MethodCall" prop where prop = forAll gen_MethodCall check check msg endianness serial = let- Right bytes = marshal endianness serial msg- Right received = unmarshal bytes+ Right (bytes, fds) = marshalWithFds endianness serial msg+ Right received = unmarshalWithFds bytes fds in ReceivedMethodCall serial msg == received test_MethodReturn :: TestTree test_MethodReturn = testProperty "MethodReturn" prop where prop = forAll gen_MethodReturn check check msg endianness serial = let- Right bytes = marshal endianness serial msg- Right received = unmarshal bytes+ Right (bytes, fds) = marshalWithFds endianness serial msg+ Right received = unmarshalWithFds bytes fds in ReceivedMethodReturn serial msg == received test_MethodError :: TestTree test_MethodError = testProperty "MethodError" prop where prop = forAll gen_MethodError check check msg endianness serial = let- Right bytes = marshal endianness serial msg- Right received = unmarshal bytes+ Right (bytes, fds) = marshalWithFds endianness serial msg+ Right received = unmarshalWithFds bytes fds in ReceivedMethodError serial msg == received test_Signal :: TestTree test_Signal = testProperty "Signal" prop where prop = forAll gen_Signal check check msg endianness serial = let- Right bytes = marshal endianness serial msg- Right received = unmarshal bytes+ Right (bytes, fds) = marshalWithFds endianness serial msg+ Right received = unmarshalWithFds bytes fds in ReceivedSignal serial msg == received gen_Atom :: Gen Variant
tests/DBusTests/Socket.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-} -- Copyright (C) 2012 John Millikin <john@john-millikin.com> --@@ -18,6 +20,9 @@ import Control.Concurrent import Control.Exception+import Control.Monad (void)+import System.IO (SeekMode(..))+import System.Posix (Fd, fdRead, fdSeek, fdWrite) import Test.Tasty import Test.Tasty.HUnit import qualified Data.Map as Map@@ -26,21 +31,20 @@ import DBus.Socket import DBus.Transport -import DBusTests.Util (forkVar)+import DBusTests.Util (forkVar, nonWindowsTestCase, withTempFd) test_Socket :: TestTree test_Socket = testGroup "Socket" [ test_Listen , test_ListenWith_CustomAuth , test_SendReceive+ , test_SendReceive_FileDescriptors ] test_Listen :: TestTree test_Listen = testCase "listen" $ do uuid <- randomUUID- let Just addr = address "unix" (Map.fromList- [ ("abstract", formatUUID uuid)- ])+ let Just addr = address "unix" (Map.singleton "abstract" (formatUUID uuid)) bracket (listen addr) closeListener $ \listener -> do acceptedVar <- forkVar (accept listener)@@ -54,9 +58,7 @@ test_ListenWith_CustomAuth :: TestTree test_ListenWith_CustomAuth = testCase "listenWith-custom-auth" $ do uuid <- randomUUID- let Just addr = address "unix" (Map.fromList- [ ("abstract", formatUUID uuid)- ])+ let Just addr = address "unix" (Map.singleton "abstract" (formatUUID uuid)) bracket (listenWith (defaultSocketOptions { socketAuthenticator = dummyAuth@@ -74,9 +76,7 @@ test_SendReceive :: TestTree test_SendReceive = testCase "send-receive" $ do uuid <- randomUUID- let Just addr = address "unix" (Map.fromList- [ ("abstract", formatUUID uuid)- ])+ let Just addr = address "unix" (Map.singleton "abstract" (formatUUID uuid)) let msg = (methodCall "/" "org.example.iface" "Foo") { methodCallSender = Just "org.example.src"@@ -117,6 +117,40 @@ sent @?= () received @?= ReceivedMethodCall serial msg++test_SendReceive_FileDescriptors :: TestTree+test_SendReceive_FileDescriptors = nonWindowsTestCase "send-receive-file-descriptors" $ do+ uuid <- randomUUID+ let Just addr = address "unix" (Map.singleton "abstract" (formatUUID uuid))+ + withTempFd $ \tmpFd -> do++ -- in order to know that the file descriptor received by the server points to+ -- the same file as the file descriptor that was sent, we write "hello" on the+ -- client and read it back on the server.+ void $ fdWrite tmpFd "hello"+ void $ fdSeek tmpFd AbsoluteSeek 0++ let msg = (methodCall "/" "org.example.iface" "Foo")+ { methodCallBody = [toVariant tmpFd] }++ bracket (listen addr) closeListener $ \listener -> do+ acceptedVar <- forkVar (accept listener)+ openedVar <- forkVar (open addr)++ bracket (takeMVar acceptedVar) close $ \sock1 -> do+ bracket (takeMVar openedVar) close $ \sock2 -> do+ receivedVar <- forkVar (receive sock1)+ send sock2 msg (const (pure ()))++ received <- takeMVar receivedVar+ case receivedMessageBody received of+ [fromVariant -> Just (fd :: Fd)] -> do+ assertBool ("Expected a different Fd, not " <> show tmpFd) (fd /= tmpFd)+ (fdMsg, _) <- fdRead fd 5+ fdMsg @?= "hello"+ body -> do+ assertFailure ("Expected a single Fd, not: " <> show body) dummyAuth :: Transport t => Authenticator t dummyAuth = authenticator
tests/DBusTests/Transport.hs view
@@ -17,13 +17,20 @@ module DBusTests.Transport (test_Transport) where import Control.Concurrent+import Control.Monad (void) import Control.Monad.Extra (unlessM)-import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Resource+import Data.ByteString.Unsafe (unsafeUseAsCString) import Data.Function (fix) import Data.List (isInfixOf)-import Network.Socket.ByteString (sendAll, recv)+import Foreign.Ptr (castPtr)+import Network.Socket (Socket)+import Network.Socket.Address (SocketAddress(..), sendBufMsg)+import Network.Socket.ByteString (recvMsg, sendAll, sendMsg) import System.Directory (getTemporaryDirectory, removeFile)+import System.IO (SeekMode(..))+import System.Posix (fdRead, fdSeek, fdWrite) import Test.Tasty import Test.Tasty.HUnit import qualified Data.ByteString@@ -41,6 +48,8 @@ , suite_TransportListen , suite_TransportAccept , test_TransportSendReceive+ , test_TransportSendReceive_FileDescriptors+ , test_TransportSendReceive_FileDescriptors_MultiplePuts , test_HandleLostConnection ] @@ -95,7 +104,7 @@ test_OpenUnix_Abstract :: TestTree test_OpenUnix_Abstract = testCase "abstract" $ runResourceT $ do- (addr, _) <- listenRandomUnixAbstract+ (addr, _, _) <- listenRandomUnixAbstract fdcountBefore <- countFileDescriptors t <- liftIO (transportOpen socketTransportOptions addr)@@ -139,7 +148,7 @@ test_OpenUnix_NotListening = testCase "not-listening" $ runResourceT $ do fdcountBefore <- countFileDescriptors - (addr, key) <- listenRandomUnixAbstract+ (addr, _sock, key) <- listenRandomUnixAbstract release key liftIO $ assertThrows@@ -275,17 +284,7 @@ test_TransportSendReceive :: TestTree test_TransportSendReceive = testCase "send-receive" $ runResourceT $ do (addr, networkSocket, _) <- listenRandomIPv4-- -- a simple echo server, which sends back anything it receives.- _ <- liftIO $ forkIO $ do- (s, _) <- NS.accept networkSocket- fix $ \loop -> do- bytes <- recv s 50- if Data.ByteString.null bytes- then NS.close s- else do- sendAll s bytes- loop+ startEchoServer networkSocket (_, t) <- allocate (transportOpen socketTransportOptions addr)@@ -297,17 +296,74 @@ liftIO (transportPut t "1") liftIO (transportPut t "2") liftIO (transportPut t "3")- bytes <- liftIO (readMVar var)- liftIO (bytes @?= "123")+ result <- liftIO (readMVar var)+ liftIO (result @?= "123") -- large chunks of data are read in full do let sentBytes = Data.ByteString.replicate (4096 * 100) 0 var <- forkVar (transportGet t (4096 * 100)) liftIO (transportPut t sentBytes)- bytes <- liftIO (readMVar var)- liftIO (bytes @?= sentBytes)+ result <- liftIO (readMVar var)+ liftIO (result @?= sentBytes) +test_TransportSendReceive_FileDescriptors :: TestTree+test_TransportSendReceive_FileDescriptors = nonWindowsTestCase "send-receive-file-descriptors" $ runResourceT $ do+ (addr, networkSocket, _) <- listenRandomUnixAbstract+ startEchoServer networkSocket++ (_, t) <- allocate+ (transportOpen socketTransportOptions addr)+ transportClose+ + liftIO $ withTempFd $ \fd1 -> withTempFd $ \fd2 -> do++ -- in order to know that the file descriptors received back from the echo server+ -- point to the same files as the file descriptors that were sent, we write data+ -- on the initial file descriptors and read it back from the returned ones.+ void $ fdWrite fd1 "1"+ void $ fdSeek fd1 AbsoluteSeek 0+ void $ fdWrite fd2 "2"+ void $ fdSeek fd2 AbsoluteSeek 0++ -- file descriptors from multiple chunks are combined+ var <- forkVar (transportGetWithFds t 1)+ liftIO (transportPutWithFds t "x" [fd1, fd2])+ ("x", [fd1', fd2']) <- liftIO (readMVar var)+ (fd1Val, _) <- liftIO (fdRead fd1' 1)+ (fd2Val, _) <- liftIO (fdRead fd2' 2)+ fd1Val @?= "1"+ fd2Val @?= "2"++test_TransportSendReceive_FileDescriptors_MultiplePuts :: TestTree+test_TransportSendReceive_FileDescriptors_MultiplePuts = nonWindowsTestCase "send-receive-file-descriptors-multiple-puts" $ runResourceT $ do+ (addr, networkSocket, _) <- listenRandomUnixAbstract+ startEchoServer networkSocket++ (_, t) <- allocate+ (transportOpen socketTransportOptions addr)+ transportClose+ + liftIO $ withTempFd $ \fd1 -> withTempFd $ \fd2 -> do++ -- in order to know that the file descriptors received back from the echo server+ -- point to the same files as the file descriptors that were sent, we write data+ -- on the initial file descriptors and read it back from the returned ones.+ void $ fdWrite fd1 "1"+ void $ fdSeek fd1 AbsoluteSeek 0+ void $ fdWrite fd2 "2"+ void $ fdSeek fd2 AbsoluteSeek 0++ -- file descriptors from multiple chunks are combined+ var <- forkVar (transportGetWithFds t 2)+ liftIO (transportPutWithFds t "1" [fd1])+ liftIO (transportPutWithFds t "2" [fd2])+ ("12", [fd1', fd2']) <- liftIO (readMVar var)+ (fd1Val, _) <- liftIO (fdRead fd1' 1)+ (fd2Val, _) <- liftIO (fdRead fd2' 2)+ fd1Val @?= "1"+ fd2Val @?= "2"+ test_HandleLostConnection :: TestTree test_HandleLostConnection = testCase "handle-lost-connection" $ runResourceT $ do (addr, networkSocket, _) <- listenRandomIPv4@@ -321,8 +377,8 @@ (transportOpen socketTransportOptions addr) transportClose - bytes <- liftIO (transportGet t 4)- liftIO (bytes @?= "123")+ result <- liftIO (transportGet t 4)+ liftIO (result @?= "123") test_ListenUnknown :: TestTree test_ListenUnknown = testCase "unknown" $ do@@ -521,9 +577,9 @@ liftIO (transportPut opened "testing") - bytes <- liftIO (transportGet accepted 7)+ result <- liftIO (transportGet accepted 7) - liftIO (bytes @?= "testing")+ liftIO (result @?= "testing") test_AcceptSocketClosed :: TestTree test_AcceptSocketClosed = testCase "socket-closed" $ do@@ -544,3 +600,27 @@ socketTransportOptions :: TransportOptions SocketTransport socketTransportOptions = transportDefaultOptions++-- todo: import NullSockAddr from network package, when released+-- (https://github.com/haskell/network/pull/562)+data NullSockAddr = NullSockAddr++instance SocketAddress NullSockAddr where+ sizeOfSocketAddress NullSockAddr = 0+ peekSocketAddress _ptr = return NullSockAddr+ pokeSocketAddress _ptr NullSockAddr = return ()++-- a simple echo server, which sends back anything it receives.+startEchoServer :: MonadIO m => Socket -> m ()+startEchoServer listenSocket = do+ void . liftIO . forkIO $ do+ (s, _) <- NS.accept listenSocket+ fix $ \loop -> do+ (_sa, bytes, cmsgs, _flag) <- recvMsg s 50 128 mempty+ if Data.ByteString.null bytes+ then NS.close s+ else do+ void . unsafeUseAsCString bytes $ \cstr -> do+ let buf = [(castPtr cstr, Data.ByteString.length bytes)]+ sendBufMsg s NullSockAddr buf cmsgs mempty+ loop
tests/DBusTests/Util.hs view
@@ -18,8 +18,11 @@ , assertAtom , assertException , assertThrows+ + , nonWindowsTestCase , getTempPath+ , withTempFd , listenRandomUnixPath , listenRandomUnixAbstract , listenRandomIPv4@@ -49,13 +52,17 @@ import Data.Char (chr) import System.Directory (getTemporaryDirectory, removeFile) import System.FilePath ((</>))+import System.IO.Temp (withSystemTempFile)+import System.Posix (Fd, closeFd, handleToFd) import Test.QuickCheck hiding ((.&.))+import Test.Tasty import Test.Tasty.HUnit import qualified Data.ByteString import qualified Data.ByteString.Lazy import qualified Data.Map as Map import qualified Data.Text as T import qualified Network.Socket as NS+import qualified System.Info import qualified System.Posix as Posix import DBus@@ -89,6 +96,11 @@ uuid <- randomUUID return (tmp </> formatUUID uuid) +withTempFd :: (Fd -> IO ()) -> IO ()+withTempFd cmd =+ withSystemTempFile "haskell-dbus" $ \_path handle -> do+ bracket (handleToFd handle) closeFd cmd+ listenRandomUnixPath :: MonadResource m => m Address listenRandomUnixPath = do path <- liftIO getTempPath@@ -106,7 +118,7 @@ ]) return addr -listenRandomUnixAbstract :: MonadResource m => m (Address, ReleaseKey)+listenRandomUnixAbstract :: MonadResource m => m (Address, NS.Socket, ReleaseKey) listenRandomUnixAbstract = do uuid <- liftIO randomUUID let sockAddr = NS.SockAddrUnix ('\x00' : formatUUID uuid)@@ -121,7 +133,7 @@ let Just addr = address "unix" (Map.fromList [ ("abstract", formatUUID uuid) ])- return (addr, key)+ return (addr, sock, key) listenRandomIPv4 :: MonadResource m => m (Address, NS.Socket, ReleaseKey) listenRandomIPv4 = do@@ -297,3 +309,9 @@ case result of Left ex -> assertBool ("unexpected exception " ++ show ex) (check ex) Right _ -> assertFailure "expected exception not thrown"++nonWindowsTestCase :: TestName -> Assertion -> TestTree+nonWindowsTestCase name assertion = testCase name $ do+ case System.Info.os of+ "mingw32" -> pure ()+ _ -> assertion
tests/DBusTests/Wire.hs view
@@ -16,17 +16,25 @@ module DBusTests.Wire (test_Wire) where +import Data.Bifunctor (first) import Data.Either+import System.Posix.Types (Fd(..)) import Test.Tasty import Test.Tasty.HUnit import qualified Data.ByteString.Char8 () import DBus+import DBus.Internal.Message+import DBus.Internal.Types+import DBus.Internal.Wire +import DBusTests.Util+ test_Wire :: TestTree test_Wire = testGroup "Wire" $ [ test_Unmarshal+ , test_FileDescriptors ] test_Unmarshal :: TestTree@@ -36,9 +44,38 @@ test_UnmarshalUnexpectedEof :: TestTree test_UnmarshalUnexpectedEof = testCase "unexpected-eof" $ do- let unmarshaled = unmarshal "0"+ let unmarshaled = unmarshalWithFds "0" [] assertBool "invalid unmarshalled parse" (isLeft unmarshaled) let Left err = unmarshaled unmarshalErrorMessage err @=? "Unexpected end of input while parsing message header."++test_FileDescriptors :: TestTree+test_FileDescriptors = testGroup "Unix File Descriptor Passing" $+ [ test_FileDescriptors_Marshal+ , test_FileDescriptors_UnmarshalHeaderError+ ]++test_FileDescriptors_Marshal :: TestTree+test_FileDescriptors_Marshal = testCaseSteps "(un)marshal round trip" $ \step -> do+ let baseMsg = methodCall "/" "org.example.iface" "Foo"+ + step "marshal"+ let msg = baseMsg { methodCallBody = [toVariant [Fd 2, Fd 1, Fd 2, Fd 3, Fd 1]] }+ Right (bytes, fds) = marshalWithFds LittleEndian firstSerial msg+ fds @?= [Fd 2, Fd 1, Fd 3]++ step "unmarshal"+ let result = receivedMessageBody <$> unmarshalWithFds bytes [Fd 4, Fd 5, Fd 6]+ result @?= Right [toVariant [Fd 4, Fd 5, Fd 4, Fd 6, Fd 5]]++test_FileDescriptors_UnmarshalHeaderError :: TestTree+test_FileDescriptors_UnmarshalHeaderError = testCase "UnixFdHeader mismatch" $ do+ let msg = (methodCall "/" "org.example.iface" "Foo")+ { methodCallBody = [toVariant [Fd 1, Fd 2, Fd 3]] }+ Right (bytes, _fds) = marshalWithFds LittleEndian firstSerial msg+ + let result = first unmarshalErrorMessage (unmarshalWithFds bytes [Fd 4, Fd 6])+ result @?= Left ("File descriptor count in message header (3)"+ <> " does not match the number of file descriptors received from the socket (2).")