diff --git a/dbus.cabal b/dbus.cabal --- a/dbus.cabal +++ b/dbus.cabal @@ -1,5 +1,5 @@ name: dbus -version: 0.10.9.2 +version: 0.10.10 license: GPL-3 license-file: license.txt author: John Millikin @@ -83,7 +83,7 @@ source-repository this type: git location: https://john-millikin.com/code/haskell-dbus/ - tag: haskell-dbus_0.10.9.2 + tag: haskell-dbus_0.10.10 library ghc-options: -Wall -O2 diff --git a/lib/DBus/Message.hs b/lib/DBus/Message.hs --- a/lib/DBus/Message.hs +++ b/lib/DBus/Message.hs @@ -31,7 +31,7 @@ import Data.Bits ((.|.), (.&.)) import Data.Maybe (fromMaybe, listToMaybe) -import Data.Word (Word8) +import Data.Word (Word8, Word32) import DBus.Types @@ -62,6 +62,7 @@ | HeaderDestination BusName | HeaderSender BusName | HeaderSignature Signature + | HeaderUnixFds Word32 deriving (Show, Eq) -- | A method call is a request to run some procedure exported by the diff --git a/lib/DBus/Types.hs b/lib/DBus/Types.hs --- a/lib/DBus/Types.hs +++ b/lib/DBus/Types.hs @@ -43,6 +43,7 @@ import Data.Word import qualified Foreign import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Types (Fd) import qualified Text.ParserCombinators.Parsec as Parsec import Text.ParserCombinators.Parsec ((<|>), oneOf) @@ -57,6 +58,7 @@ | TypeInt32 | TypeInt64 | TypeDouble + | TypeUnixFd | TypeString | TypeSignature | TypeObjectPath @@ -80,6 +82,7 @@ TypeInt32 -> "Int32" TypeInt64 -> "Int64" TypeDouble -> "Double" + TypeUnixFd -> "UnixFd" TypeString -> "String" TypeSignature -> "Signature" TypeObjectPath -> "ObjectPath" @@ -126,6 +129,7 @@ typeCode TypeInt32 = "i" typeCode TypeInt64 = "x" typeCode TypeDouble = "d" +typeCode TypeUnixFd = "h" typeCode TypeString = "s" typeCode TypeSignature = "g" typeCode TypeObjectPath = "o" @@ -210,6 +214,7 @@ 0x75 -> yes TypeWord32 0x74 -> yes TypeWord64 0x64 -> yes TypeDouble + 0x68 -> yes TypeUnixFd 0x73 -> yes TypeString 0x67 -> yes TypeSignature 0x6F -> yes TypeObjectPath @@ -357,6 +362,7 @@ | AtomInt32 Int32 | AtomInt64 Int64 | AtomDouble Double + | AtomUnixFd Fd | AtomText Text | AtomSignature Signature | AtomObjectPath ObjectPath @@ -390,6 +396,7 @@ showAtom _ (AtomInt32 x) = show x showAtom _ (AtomInt64 x) = show x showAtom _ (AtomDouble x) = show x +showAtom p (AtomUnixFd x) = showParen p (showString "UnixFd " . shows x) "" showAtom _ (AtomText x) = show x showAtom p (AtomSignature x) = showsPrec (if p then 11 else 0) x "" showAtom p (AtomObjectPath x) = showsPrec (if p then 11 else 0) x "" @@ -440,6 +447,7 @@ atomType (AtomInt32 _) = TypeInt32 atomType (AtomInt64 _) = TypeInt64 atomType (AtomDouble _) = TypeDouble +atomType (AtomUnixFd _) = TypeUnixFd atomType (AtomText _) = TypeString atomType (AtomSignature _) = TypeSignature atomType (AtomObjectPath _) = TypeObjectPath @@ -470,6 +478,7 @@ IS_ATOM(Int32, AtomInt32, TypeInt32) IS_ATOM(Int64, AtomInt64, TypeInt64) IS_ATOM(Double, AtomDouble, TypeDouble) +IS_ATOM(Fd, AtomUnixFd, TypeUnixFd) IS_ATOM(Text, AtomText, TypeString) IS_ATOM(Signature, AtomSignature, TypeSignature) IS_ATOM(ObjectPath, AtomObjectPath, TypeObjectPath) diff --git a/lib/DBus/Wire.hs b/lib/DBus/Wire.hs --- a/lib/DBus/Wire.hs +++ b/lib/DBus/Wire.hs @@ -40,6 +40,8 @@ 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 qualified Data.Serialize.Builder as Builder import qualified Data.Serialize.Get as Get @@ -71,6 +73,7 @@ alignment TypeInt32 = 4 alignment TypeInt64 = 8 alignment TypeDouble = 8 +alignment TypeUnixFd = 4 alignment TypeString = 4 alignment TypeObjectPath = 4 alignment TypeSignature = 1 @@ -167,6 +170,7 @@ marshalAtom (AtomInt32 x) = marshalInt32 x marshalAtom (AtomInt64 x) = marshalInt64 x marshalAtom (AtomDouble x) = marshalDouble x +marshalAtom (AtomUnixFd x) = marshalUnixFd x marshalAtom (AtomBool x) = marshalBool x marshalAtom (AtomText x) = marshalText x marshalAtom (AtomObjectPath x) = marshalObjectPath x @@ -219,6 +223,7 @@ unmarshal TypeInt32 = liftM toValue unmarshalInt32 unmarshal TypeInt64 = liftM toValue unmarshalInt64 unmarshal TypeDouble = liftM toValue unmarshalDouble +unmarshal TypeUnixFd = liftM toValue unmarshalUnixFd unmarshal TypeBoolean = liftM toValue unmarshalBool unmarshal TypeString = liftM toValue unmarshalText unmarshal TypeObjectPath = liftM toValue unmarshalObjectPath @@ -332,6 +337,19 @@ getFloat64be getFloat64le +marshalUnixFd :: Fd -> Marshal () +marshalUnixFd (Fd x) + | x < 0 = throwError ("Invalid file descriptor: " ++ show x) + | toInteger x > toInteger (maxBound :: Word32) = throwError ("D-Bus forbids file descriptors exceeding UINT32_MAX: " ++ show x) + | otherwise = marshalWord32 (fromIntegral x) + +unmarshalUnixFd :: Unmarshal Fd +unmarshalUnixFd = do + x <- unmarshalWord32 + when (toInteger x > toInteger (maxBound :: CInt)) + (throwError ("Invalid file descriptor: " ++ show x)) + return (Fd (fromIntegral x)) + marshalBool :: Bool -> Marshal () marshalBool False = marshalWord32 0 marshalBool True = marshalWord32 1 @@ -512,6 +530,7 @@ encodeField (HeaderDestination x) = encodeField' 6 x encodeField (HeaderSender x) = encodeField' 7 x encodeField (HeaderSignature x) = encodeField' 8 x +encodeField (HeaderUnixFds x) = encodeField' 9 x encodeField' :: IsVariant a => Word8 -> a -> Value encodeField' code x = toValue (code, toVariant x) @@ -527,6 +546,7 @@ (6, x) -> decodeField' x HeaderDestination "destination" (7, x) -> decodeField' x HeaderSender "sender" (8, x) -> decodeField' x HeaderSignature "signature" + (9, x) -> decodeField' x HeaderUnixFds "unix fds" _ -> return [] decodeField' :: IsVariant a => Variant -> (a -> b) -> String diff --git a/tests/DBusTests/Serialization.hs b/tests/DBusTests/Serialization.hs --- a/tests/DBusTests/Serialization.hs +++ b/tests/DBusTests/Serialization.hs @@ -29,6 +29,8 @@ import Data.Map (Map) import qualified Data.Map import qualified Data.Vector +import Foreign.C.Types (CInt) +import System.Posix.Types (Fd) import DBus import qualified DBus.Types @@ -92,10 +94,18 @@ , fmap toVariant (arbitrary :: Gen Int64) , fmap toVariant (arbitrary :: Gen Bool) , fmap toVariant (arbitrary :: Gen Double) + , fmap toVariant gen_UnixFd , fmap toVariant (arbitrary :: Gen Text) , fmap toVariant (arbitrary :: Gen ObjectPath) , fmap toVariant (arbitrary :: Gen Signature) ] + +gen_UnixFd :: Gen Fd +gen_UnixFd = do + let maxWord32 = toInteger (maxBound :: Word32) + let maxCInt = toInteger (maxBound :: CInt) + x <- choose (0, toInteger (min maxWord32 maxCInt)) + return (fromInteger x) gen_Variant :: Gen Variant gen_Variant = oneof diff --git a/tests/DBusTests/Signature.hs b/tests/DBusTests/Signature.hs --- a/tests/DBusTests/Signature.hs +++ b/tests/DBusTests/Signature.hs @@ -73,9 +73,6 @@ -- non-atomic dict key $expect (nothing (parseSignature "a{vy}")) $expect (nothing (signature [TypeDictionary TypeVariant TypeVariant])) - - -- unix fd (intentionally not supported in haskell-dbus) - $expect (nothing (parseSignature "h")) test_FormatSignature :: Test test_FormatSignature = property "formatSignature" prop where @@ -101,6 +98,7 @@ $expect (equal "Int32" (show TypeInt32)) $expect (equal "Int64" (show TypeInt64)) $expect (equal "Double" (show TypeDouble)) + $expect (equal "UnixFd" (show TypeUnixFd)) $expect (equal "String" (show TypeString)) $expect (equal "Signature" (show TypeSignature)) $expect (equal "ObjectPath" (show TypeObjectPath)) @@ -127,6 +125,7 @@ , ("i", TypeInt32) , ("x", TypeInt64) , ("d", TypeDouble) + , ("h", TypeUnixFd) , ("s", TypeString) , ("o", TypeObjectPath) , ("g", TypeSignature) diff --git a/tests/DBusTests/Variant.hs b/tests/DBusTests/Variant.hs --- a/tests/DBusTests/Variant.hs +++ b/tests/DBusTests/Variant.hs @@ -30,6 +30,7 @@ import Data.Int (Int16, Int32, Int64) import qualified Data.Map import qualified Data.Vector +import System.Posix.Types (Fd) import DBus import DBus.Types (toValue) @@ -55,6 +56,7 @@ assertAtom TypeInt32 (0 :: Int32) assertAtom TypeInt64 (0 :: Int64) assertAtom TypeDouble (0 :: Double) + assertAtom TypeUnixFd (0 :: Fd) assertAtom TypeString (Data.Text.pack "") assertAtom TypeString (Data.Text.Lazy.pack "") assertAtom TypeString ("" :: String) @@ -95,6 +97,7 @@ $expect $ equal "Variant 0" (show (toVariant (0 :: Int32))) $expect $ equal "Variant 0" (show (toVariant (0 :: Int64))) $expect $ equal "Variant 0.1" (show (toVariant (0.1 :: Double))) + $expect $ equal "Variant (UnixFd 1)" (show (toVariant (1 :: Fd))) $expect $ equal "Variant \"\"" (show (toVariant (T.pack ""))) $expect $ equal "Variant (ObjectPath \"/\")" (show (toVariant (objectPath_ "/"))) $expect $ equal "Variant (Signature \"\")" (show (toVariant (signature_ [])))