dbus 1.2.29 → 1.3.0

raw patch · 15 files changed

+485/−162 lines, 15 filesdep +temporaryPVP ok

version bump matches the API change (PVP)

Dependencies added: temporary

API changes (from Hackage documentation)

Files

• benchmarks/DBusBenchmarks.hs +3/−3
• dbus.cabal +2/−1
• lib/DBus.hs +23/−2
• lib/DBus/Client.hs +0/−1
• lib/DBus/Generation.hs +0/−1
• lib/DBus/Internal/Wire.hs +91/−58
• lib/DBus/Introspection/Render.hs +0/−1
• lib/DBus/Socket.hs +55/−24
• lib/DBus/Transport.hs +98/−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

@@ -34,11 +34,11 @@ empty_MethodReturn = methodReturn (serial 0)  benchMarshal :: Message msg => String -> msg -> Benchmark-benchMarshal name msg = bench name (whnf (marshal LittleEndian (serial 0)) msg)+benchMarshal name msg = bench name (whnf (marshalWithFds 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+benchUnmarshal name msg = bench name (whnf (uncurry unmarshalWithFds) (bytes, fds)) where+    Right (bytes, fds) = marshalWithFds LittleEndian (serial 0) msg  parseSig :: String -> Maybe Signature parseSig = parseSignature

@@ -1,5 +1,5 @@ name: dbus-version: 1.2.29+version: 1.3.0 license: Apache-2.0 license-file: license.txt author: John Millikin <john@john-millikin.com>@@ -144,6 +144,7 @@     , tasty < 1.5     , tasty-hunit < 0.11     , tasty-quickcheck < 0.11+    , temporary >= 1.3 && < 1.4     , text < 2.1     , transformers < 0.7     , unix < 2.9

@@ -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) @@ -256,14 +259,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.

@@ -181,7 +181,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)

@@ -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

@@ -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)@@ -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).")) -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

@@ -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

@@ -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))@@ -323,16 +326,23 @@ 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 +350,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 +389,7 @@             if token == wantToken                 then do                     transportPutLine t ("OK " ++ formatUUID uuid)-                    waitForBegin+                    negotiateFdsAndBegin                     return True                 else return False 

@@ -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.Address (SocketAddress(..))+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,31 +177,50 @@           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)+-- todo: import NullSockAddr from network package, when released+-- (https://github.com/haskell/network/pull/562)+data NullSockAddr = NullSockAddr -                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)+instance SocketAddress NullSockAddr where+    sizeOfSocketAddress NullSockAddr = 0+    peekSocketAddress _ptr = return NullSockAddr+    pokeSocketAddress _ptr NullSockAddr = return () +sendWithFds :: Socket -> ByteString -> [Fd] -> IO ()+sendWithFds s msg fds = loop 0 where+    loop acc  = do+        let cmsgs = if acc == 0 then (encodeCmsg <$> 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++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         "unix" -> openUnix a@@ -446,3 +497,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 /= CmsgIdFd = Nothing+  | otherwise =+    unsafeDupablePerformIO $ withForeignPtr fptr $ \p0 -> do+      let p = castPtr (p0 `plusPtr` off)+          numFds = len `div` sizeOf (undefined :: Fd)+      Just <$> peekArray numFds p

@@ -15,7 +15,6 @@  module DBusTests.Introspection (test_Introspection) where -import Control.Applicative ((<$>), (<*>)) import Control.Monad (liftM, liftM2) import Test.QuickCheck import Test.Tasty

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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).")