diff --git a/Examples/dbus-monitor.hs b/Examples/dbus-monitor.hs --- a/Examples/dbus-monitor.hs +++ b/Examples/dbus-monitor.hs @@ -18,11 +18,13 @@ {-# LANGUAGE OverloadedStrings #-} import DBus.Address +import DBus.Authentication import DBus.Bus import DBus.Connection import DBus.Constants import DBus.Message import DBus.Types +import DBus.Wire import Control.Monad import qualified Data.Set as Set @@ -61,18 +63,19 @@ BusOption Session -> getSessionBus BusOption System -> getSystemBus AddressOption addr -> case mkAddresses (TL.pack addr) of - Just [x] -> getBus x - Just x -> getFirstBus x + Just [x] -> getBus realUserID x + Just xs -> getFirstBus [(realUserID, addr) | addr <- xs] _ -> error $ "Invalid address: " ++ show addr addMatchMsg :: String -> MethodCall addMatchMsg match = MethodCall - dbusPath - (mkMemberName' "AddMatch") - (Just dbusInterface) - (Just dbusName) - Set.empty - [toVariant match] + { methodCallPath = dbusPath + , methodCallMember = "AddMatch" + , methodCallInterface = Just dbusInterface + , methodCallDestination = Just dbusName + , methodCallFlags = Set.empty + , methodCallBody = [toVariant match] + } addMatch :: Connection -> String -> IO () addMatch c s = send c return (addMatchMsg s) >> return () diff --git a/Examples/simple.hs b/Examples/simple.hs new file mode 100644 --- /dev/null +++ b/Examples/simple.hs @@ -0,0 +1,64 @@ +-- Copyright (C) 2009 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import DBus.Bus +import DBus.Connection +import DBus.Message +import DBus.Types +import qualified Data.Set as Set +import Data.List (sort) + +main :: IO () +main = do + -- Connect to the bus, and print which name was assigned to this + -- connection. + (bus, name) <- getSessionBus + putStrLn $ "Connected as: " ++ show name + + -- Request a list of connected clients from the bus + Right serial <- send bus return $ MethodCall + { methodCallPath = "/org/freedesktop/DBus" + , methodCallMember = "ListNames" + , methodCallInterface = Just "org.freedesktop.DBus" + , methodCallDestination = Just "org.freedesktop.DBus" + , methodCallFlags = Set.empty + , methodCallBody = [] + } + + -- Wait for the reply + reply <- waitForReply bus serial + + -- Pull out the body, and convert it to [String] + let Just names = fromArray =<< fromVariant (messageBody reply !! 0) + + -- Print each name on a line, sorted so reserved names are below + -- temporary names. + mapM_ putStrLn $ sort names + +waitForReply :: Connection -> Serial -> IO MethodReturn +waitForReply bus serial = wait where + wait = do + received <- receive bus + case received of + Right (ReceivedMethodReturn _ _ ret) -> + if methodReturnSerial ret == serial + then return ret + else wait + Right _ -> wait + Left err -> error $ show err + diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,5 +1,6 @@ HS_SOURCES=\ hs/DBus/Address.hs \ + hs/DBus/Authentication.hs \ hs/DBus/Bus.hs \ hs/DBus/Connection.hs \ hs/DBus/Constants.hs \ @@ -10,6 +11,7 @@ hs/DBus/NameReservation.hs \ hs/DBus/Types.hs \ hs/DBus/Util.hs \ + hs/DBus/UUID.hs \ hs/DBus/Wire.hs \ hs/DBus/Wire/Internal.hs \ hs/Tests.hs diff --git a/Tests.nw b/Tests.nw --- a/Tests.nw +++ b/Tests.nw @@ -128,7 +128,7 @@ arbitrary = oneof [atomicType, containerType] instance Arbitrary Signature where - arbitrary = clampedSize 255 genSig mkSignature' where + arbitrary = clampedSize 255 genSig mkSignature_ where genSig = fmap (TL.concat . map typeCode) arbitrary <>= @@ -141,7 +141,7 @@ <>= instance Arbitrary ObjectPath where - arbitrary = fmap (mkObjectPath' . TL.pack) path' where + arbitrary = fmap (mkObjectPath_ . TL.pack) path' where c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" path = fmap (intercalate "/" . ([] :)) genElements path' = frequency [(1, return "/"), (9, path)] @@ -155,7 +155,7 @@ <>= instance Arbitrary BusName where - arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName' where + arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName_ where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" c' = c ++ ['0'..'9'] @@ -180,7 +180,7 @@ <>= instance Arbitrary InterfaceName where - arbitrary = clampedSize 255 genName mkInterfaceName' where + arbitrary = clampedSize 255 genName mkInterfaceName_ where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" c' = c ++ ['0'..'9'] @@ -199,7 +199,7 @@ <>= instance Arbitrary ErrorName where - arbitrary = fmap (mkErrorName' . strInterfaceName) arbitrary + arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary <>= , testGroup "ErrorName" $ commonVariantTests (arbitrary :: Gen ErrorName) ++ @@ -209,7 +209,7 @@ <>= instance Arbitrary MemberName where - arbitrary = clampedSize 255 genName mkMemberName' where + arbitrary = clampedSize 255 genName mkMemberName_ where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" c' = c ++ ['0'..'9'] @@ -562,7 +562,7 @@ let path' = case strObjectPath parentPath of "/" -> thisPath x -> TL.append x thisPath - let path = mkObjectPath' path' + let path = mkObjectPath_ path' ifaces <- arbitrary children <- shrinkingGen . listOf . subObject $ path return $ I.Object path ifaces children diff --git a/dbus-core.cabal b/dbus-core.cabal --- a/dbus-core.cabal +++ b/dbus-core.cabal @@ -1,7 +1,7 @@ name: dbus-core -version: 0.7 +version: 0.8 synopsis: Low-level D-Bus protocol implementation -license: GPL +license: GPL-3 license-file: License.txt author: John Millikin maintainer: jmillikin@gmail.com @@ -10,6 +10,8 @@ category: Network, Desktop stability: experimental bug-reports: mailto:jmillikin@gmail.com +homepage: http://ianen.org/haskell/dbus/ +tested-with: GHC==6.10.4 extra-source-files: dbus-core.nw @@ -19,7 +21,7 @@ source-repository head type: darcs - location: http://patch-tag.com/r/jmillikin/dbus-core/pullrepo + location: http://ianen.org/haskell/dbus/core/ flag test default: False @@ -32,21 +34,22 @@ hs-source-dirs: hs build-depends: - base >=4 && < 5, - parsec >= 3.0.0, - binary, - bytestring, - data-binary-ieee754 >= 0.3, - HaXml >= 1.19.7, - pretty, - text, - mtl, - containers, - unix, - network + base >=4 && < 5 + , parsec >= 3.0.0 + , binary + , bytestring + , data-binary-ieee754 >= 0.3 + , HaXml >= 1.19.7 + , pretty + , text + , mtl + , containers + , unix + , network exposed-modules: DBus.Address + DBus.Authentication DBus.Bus DBus.Connection DBus.Constants @@ -55,6 +58,7 @@ DBus.Message DBus.NameReservation DBus.Types + DBus.UUID DBus.Wire other-modules: diff --git a/dbus-core.nw b/dbus-core.nw --- a/dbus-core.nw +++ b/dbus-core.nw @@ -127,6 +127,7 @@ deriving (Show, Eq) <>= +<> isAtomicType :: Type -> Bool isAtomicType DBusBoolean = True isAtomicType DBusByte = True @@ -146,7 +147,9 @@ signatures'' or for debugging. <>= +<> typeCode :: Type -> Text +<> <>= -- * Available types @@ -182,6 +185,7 @@ pre-defined types. <>= +<> data Variant = forall a. (Variable a, Builtin a, Typeable a) => Variant a deriving (Typeable) @@ -217,6 +221,7 @@ a {\tt Variant}. <>= +<> variantType :: Variant -> Type variantType (Variant x) = builtinDBusType x @@ -362,7 +367,7 @@ @ For atomic types, the type code is a single letter. Arrays, structures, and dictionary types are multiple characters. -<>= +<>= typeCode DBusBoolean = "b" typeCode DBusByte = "y" typeCode DBusInt16 = "n" @@ -380,20 +385,20 @@ @ An array's type code is ``a'' followed by the type it contains. For example, an array of booleans would have the type string ``ab''. -<>= +<>= typeCode (DBusArray t) = TL.cons 'a' $ typeCode t @ A dictionary's type code is ``a\{$key\_type$ $value\_type$\}''. For example, a dictionary of bytes to booleans would have the type string ``a\{yb\}''. -<>= +<>= typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"] @ A structure's type code is the concatenation of its contained types, wrapped by ``('' and ``)''. Structures may be empty, in which case their type code is simply ``()''. -<>= +<>= typeCode (DBusStructure ts) = TL.concat $ ["("] ++ map typeCode ts ++ [")"] @@ -463,16 +468,23 @@ import DBus.Util (mkUnsafe) <>= -mkSignature' :: Text -> Signature -mkSignature' = mkUnsafe "signature" mkSignature +mkSignature_ :: Text -> Signature +mkSignature_ = mkUnsafe "signature" mkSignature +<>= +import qualified Data.String as String + +<>= +instance String.IsString Signature where + fromString = mkSignature_ . TL.pack + @ Most signature-related functions are exposed to clients, except the {\tt Signature} value constructor. If that were exposed, clients could construct invalid signatures. <>= , mkSignature -, mkSignature' +, mkSignature_ @ \subsection{Object paths} @@ -481,8 +493,15 @@ newtype ObjectPath = ObjectPath { strObjectPath :: Text } - deriving (Show, Eq, Ord, Typeable) + deriving (Eq, Ord, Typeable) +instance Show ObjectPath where + showsPrec d (ObjectPath x) = showParen (d > 10) $ + showString "ObjectPath " . shows x + +instance String.IsString ObjectPath where + fromString = mkObjectPath_ . TL.pack + @ An object path may be one of \begin{itemize} @@ -502,15 +521,15 @@ path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char path' = path >> P.eof >> return (ObjectPath s) -mkObjectPath' :: Text -> ObjectPath -mkObjectPath' = mkUnsafe "object path" mkObjectPath +mkObjectPath_ :: Text -> ObjectPath +mkObjectPath_ = mkUnsafe "object path" mkObjectPath <>= -- * Object paths , ObjectPath , strObjectPath , mkObjectPath -, mkObjectPath' +, mkObjectPath_ @ \subsection{Arrays} @@ -535,6 +554,7 @@ instance Builtin Array where builtinDBusType = DBusArray . arrayType +<> arrayType :: Array -> Type arrayType (VariantArray t _) = t arrayType (ByteArray _) = DBusByte @@ -778,14 +798,22 @@ <>= #define NAME_TYPE(TYPE, NAME) \ newtype TYPE = TYPE {str##TYPE :: Text} \ - deriving (Show, Eq, Ord); \ - \ + deriving (Eq, Ord); \ + \ + instance Show TYPE where \ + { showsPrec d (TYPE x) = showParen (d > 10) $ \ + showString "TYPE " . shows x \ + }; \ + \ + instance String.IsString TYPE where \ + { fromString = mk##TYPE##_ . TL.pack }; \ + \ instance Variable TYPE where \ { toVariant = toVariant . str##TYPE \ ; fromVariant = (mk##TYPE =<<) . fromVariant }; \ \ - mk##TYPE##' :: Text -> TYPE; \ - mk##TYPE##' = mkUnsafe NAME mk##TYPE + mk##TYPE##_ :: Text -> TYPE; \ + mk##TYPE##_ = mkUnsafe NAME mk##TYPE <>= -- * Names @@ -820,7 +848,7 @@ , BusName , strBusName , mkBusName -, mkBusName' +, mkBusName_ @ \subsubsection{Interface names} @@ -844,7 +872,7 @@ , InterfaceName , strInterfaceName , mkInterfaceName -, mkInterfaceName' +, mkInterfaceName_ @ \subsubsection{Error names} @@ -862,7 +890,7 @@ , ErrorName , strErrorName , mkErrorName -, mkErrorName' +, mkErrorName_ @ \subsubsection{Member names} @@ -884,7 +912,7 @@ , MemberName , strMemberName , mkMemberName -, mkMemberName' +, mkMemberName_ @ \section{Messages} @@ -957,6 +985,7 @@ added type-safety. <>= +<> newtype Serial = Serial { serialValue :: Word32 } deriving (Eq, Ord) @@ -982,6 +1011,8 @@ <>= , Serial , serialValue +, firstSerial +, nextSerial @ \subsection{Message types} @@ -1133,6 +1164,7 @@ for sending an error reply. <>= +<> data ReceivedMessage = ReceivedMethodCall Serial (Maybe T.BusName) MethodCall | ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn @@ -1875,6 +1907,7 @@ , marshalMessage <>= +<> marshalMessage :: M.Message a => Endianness -> M.Serial -> a -> Either MarshalError L.ByteString marshalMessage e serial msg = runMarshal marshaler e where @@ -1933,6 +1966,7 @@ , unmarshalMessage <>= +<> unmarshalMessage :: Monad m => (Word32 -> m L.ByteString) -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do @@ -1947,7 +1981,7 @@ retrieved without any size calculations. <>= -let fixedSig = T.mkSignature' "yyyyuuu" +let fixedSig = "yyyyuuu" fixedBytes <- getBytes 16 @ The first field of interest is the protocol version; if the incoming @@ -1991,7 +2025,7 @@ pulled out of the monad. <>= -let headerSig = T.mkSignature' "yyyyuua(yv)" +let headerSig = "yyyyuua(yv)" fieldBytes <- getBytes fieldByteCount let headerBytes = L.append fixedBytes fieldBytes header <- unmarshal' headerSig headerBytes @@ -2012,8 +2046,7 @@ <>= findBodySignature :: [M.HeaderField] -> T.Signature -findBodySignature fields = fromMaybe empty signature where - empty = T.mkSignature' "" +findBodySignature fields = fromMaybe "" signature where signature = listToMaybe [x | M.Signature x <- fields] <>= @@ -2028,10 +2061,21 @@ @ Even if the received message was structurally valid, building the {\tt ReceivedMessage} can still fail due to missing header fields. +Slightly ugly; to avoid orphan instances of either {\tt Text} or +{\tt Either}, a newtype is used to turn {\tt Either} into a monad. + +<>= +newtype EitherM a b = EitherM (Either a b) + +instance Monad (EitherM a) where + return = EitherM . Right + (EitherM (Left x)) >>= _ = EitherM (Left x) + (EitherM (Right x)) >>= k = k x + <>= y <- case buildReceivedMessage typeCode fields of - Right x -> return x - Left x -> E.throwError $ MissingHeaderField x + EitherM (Right x) -> return x + EitherM (Left x) -> E.throwError $ MissingHeaderField x <>= return $ y serial flags body @@ -2039,7 +2083,7 @@ @ This really belongs in the Message section... <>= -buildReceivedMessage :: Word8 -> [M.HeaderField] -> Either Text +buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text (M.Serial -> (Set.Set M.Flag) -> [T.Variant] -> M.ReceivedMessage) @@ -2101,15 +2145,9 @@ in M.ReceivedUnknown serial sender msg <>= -require :: Text -> [a] -> Either Text a -require _ (x:_) = Right x -require label _ = Left label - -@ This is just needed for the Monad instance of {\tt Either Text} - -<>= -instance E.Error Text where - strMsg = TL.pack +require :: Text -> [a] -> EitherM Text a +require _ (x:_) = return x +require label _ = EitherM $ Left label @ \section{Addresses} @@ -2253,33 +2291,44 @@ <>= import qualified Control.Concurrent as C import qualified DBus.Address as A -import qualified DBus.Message.Internal as M +import qualified DBus.Message as M +import qualified DBus.UUID as UUID <>= -data Connection = Connection A.Address Transport (C.MVar M.Serial) (C.MVar ()) +data Connection = Connection + { connectionAddress :: A.Address + , connectionTransport :: Transport + , connectionSerialMVar :: C.MVar M.Serial + , connectionReadMVar :: C.MVar () + , connectionUUID :: UUID.UUID + } <>= Connection +, connectionAddress +, connectionUUID @ While not particularly useful for other functions, being able to {\tt show} a {\tt Connection} is useful when debugging. <>= instance Show Connection where - showsPrec d (Connection a _ _ _) = showParen (d > 10) $ - showString' [""] where - showString' = foldr (.) id . map showString + showsPrec d con = showParen (d > 10) strCon where + addr = A.strAddress $ connectionAddress con + strCon = s "" + s = showString @ \subsection{Transports} A transport is anything which can send and receive bytestrings, typically -over a socket. +via a socket. <>= import qualified Data.ByteString.Lazy as L import Data.Word (Word32) <>= +<> data Transport = Transport { transportSend :: L.ByteString -> IO () , transportRecv :: Word32 -> IO L.ByteString @@ -2473,28 +2522,30 @@ might fail due to external factors. <>= -import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) +import qualified DBus.Authentication as Auth <>= -connect :: A.Address -> IO Connection -connect a = do +<> +connect :: Auth.Mechanism -> A.Address -> IO Connection +connect mechanism a = do t <- connectTransport a - let putS = transportSend t . encodeUtf8 . TL.pack - let getS = fmap (TL.unpack . decodeUtf8) . transportRecv t - authenticate putS getS + let getByte = L.head `fmap` transportRecv t 1 + uuid <- Auth.authenticate mechanism (transportSend t) getByte readLock <- C.newMVar () serialMVar <- C.newMVar M.firstSerial - return $ Connection a t serialMVar readLock + return $ Connection a t serialMVar readLock uuid @ Since addresses usually come in a list, it's sensible to have a variant of {\tt connect} which tries multiple addresses. The first successfully opened {\tt Connection} is returned. <>= -connectFirst :: [A.Address] -> IO Connection +<> +connectFirst :: [(Auth.Mechanism, A.Address)] -> IO Connection connectFirst orig = connectFirst' orig where - connectFirst' [] = E.throwIO $ NoWorkingAddress orig - connectFirst' (a:as) = E.catch (connect a) $ + allAddrs = [a | (_, a) <- orig] + connectFirst' [] = E.throwIO $ NoWorkingAddress allAddrs + connectFirst' ((mech, a):as) = E.catch (connect mech a) $ \(E.SomeException _) -> connectFirst' as <>= @@ -2503,49 +2554,132 @@ @ \subsection{Authentication} -<>= -authenticate :: (String -> IO ()) -> (Word32 -> IO String) - -> IO () -authenticate put get = do - put "\x00" +Authentication is a bit iffy; currently, there's a one specified +authentication mechanism ({\tt DBUS\_COOKIE\_SHA1}), which I've never seen +in the wild. Everybody seems to use {\tt EXTERNAL}, described below. -@ {\sc external} authentication is performed using the process's real user -ID, converted to a string, and then hex-encoded. +To support multiple modes more easily in the future, and for user-defined +authentication handling (eg, in proxy servers), authentication is handled by +a separate module. -<>= +<>= +<> +<> +{-# LANGUAGE DeriveDataTypeable #-} +module DBus.Authentication + ( <> + ) where +<> +<> + +@ The authentication protocol is based on {\sc ascii} text, initiated by the +client. Commands and mechanisms are represented by a couple data types: + +<>= +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as ByteString +import qualified DBus.UUID as UUID + +<>= +type Command = Text +newtype Mechanism = Mechanism + { mechanismRun :: (Command -> IO Command) -> IO UUID.UUID + } + +<>= + Command +, Mechanism (..) + +@ If authentication fails, an exception will be raised. + +<>= +import Data.Typeable (Typeable) +import qualified Control.Exception as E + +<>= +data AuthenticationError + = AuthenticationError Text + deriving (Show, Typeable) + +instance E.Exception AuthenticationError + +<>= +, AuthenticationError (..) + +@ The process begins by the client sending a single {\sc nul} byte, followed +by exchanges of {\sc ascii} commands until authentication is complete. Which +commands are sent depends on the selected mechanism. + +<>= +import Data.Word (Word8) + +<>= +authenticate :: Mechanism -> (ByteString -> IO ()) -> IO Word8 + -> IO UUID.UUID +authenticate mech put getByte = do + put $ ByteString.singleton 0 + uuid <- mechanismRun mech (putCommand put getByte) + put "BEGIN\r\n" + return uuid + +<>= +, authenticate + +@ TODO: describe {\tt putCommand} here + +<>= +import Control.Monad (liftM) +import Data.Char (chr) +import Data.Text.Lazy.Encoding (encodeUtf8) +import DBus.Util (readUntil, dropEnd) + +<>= +putCommand :: Monad m => (ByteString -> m ()) -> m Word8 -> Command -> m Command +putCommand put get cmd = do + let getC = liftM (chr . fromIntegral) get + put $ encodeUtf8 cmd + put "\r\n" + liftM (TL.pack . dropEnd 2) $ readUntil "\r\n" getC + +@ \subsubsection{Support authentication mechanisms} + +Currently, the only supported authentication mechanism is sending the local +user's ``real user ID''. + +<>= +, realUserID + +<>= import System.Posix.User (getRealUserID) import Data.Char (ord) import Text.Printf (printf) -<>= +<>= +realUserID :: Mechanism +realUserID = Mechanism $ \sendCmd -> do uid <- getRealUserID - let authToken = concatMap (printf "%02X" . ord) (show uid) - put $ "AUTH EXTERNAL " ++ authToken ++ "\r\n" + let token = concatMap (printf "%02X" . ord) (show uid) + let cmd = "AUTH EXTERNAL " ++ token + eitherUUID <- checkOK `fmap` sendCmd (TL.pack cmd) + case eitherUUID of + Right uuid -> return uuid + Left err -> E.throwIO $ AuthenticationError err @ If authentication was successful, the server responds with {\tt OK -}. The GUID is intended to enable connection sharing, which -is currently unimplemented, so it's ignored. - -<>= -import Data.List (isPrefixOf) +}. -<>= - response <- readUntil '\n' get - if "OK" `isPrefixOf` response - then put "BEGIN\r\n" - else do - putStrLn $ "response = " ++ show response - error "Server rejected authentication token." +<>= +import Data.Maybe (isJust) -<>= -readUntil :: Monad m => Char -> (Word32 -> m String) -> m String -readUntil = readUntil' "" where - readUntil' xs c f = do - [x] <- f 1 - let xs' = xs ++ [x] - if x == c - then return xs' - else readUntil' xs' c f +<>= +checkOK :: Command -> Either Text UUID.UUID +checkOK cmd = if validUUID then Right uuid else Left errorMsg where + validUUID = TL.isPrefixOf "OK " cmd && isJust maybeUUID + maybeUUID = UUID.fromHex $ TL.drop 3 cmd + Just uuid = maybeUUID + errorMsg = if TL.isPrefixOf "ERROR " cmd + then TL.drop 6 cmd + else TL.pack $ "Unexpected response: " ++ show cmd @ \subsection{Sending and receiving messages} @@ -2558,9 +2692,10 @@ import qualified DBus.Wire as W <>= +<> send :: M.Message a => Connection -> (M.Serial -> IO b) -> a -> IO (Either W.MarshalError b) -send (Connection _ t mvar _) io msg = withSerial mvar $ \serial -> +send (Connection _ t mvar _ _) io msg = withSerial mvar $ \serial -> case W.marshalMessage W.LittleEndian serial msg of Right bytes -> do x <- io serial @@ -2584,8 +2719,9 @@ error is encountered while unmarshaling, an exception will be thrown. <>= +<> receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage) -receive (Connection _ t _ lock) = C.withMVar lock $ \_ -> +receive (Connection _ t _ lock _) = C.withMVar lock $ \_ -> W.unmarshalMessage $ transportRecv t <>= @@ -2613,6 +2749,7 @@ import System.Environment (getEnv) import qualified DBus.Address as A +import qualified DBus.Authentication as Auth import qualified DBus.Connection as C import DBus.Constants (dbusName, dbusPath, dbusInterface) import qualified DBus.Message as M @@ -2628,14 +2765,16 @@ busForConnection c = sendHello c >>= return . (,) c <>= -getBus :: A.Address -> IO (C.Connection, T.BusName) -getBus = (busForConnection =<<) . C.connect +<> +getBus :: Auth.Mechanism -> A.Address -> IO (C.Connection, T.BusName) +getBus = ((busForConnection =<<) .) . C.connect @ Optionally, multiple addresses may be provided. The first successful connection will be used. <>= -getFirstBus :: [A.Address] -> IO (C.Connection, T.BusName) +<> +getFirstBus :: [(Auth.Mechanism, A.Address)] -> IO (C.Connection, T.BusName) getFirstBus = (busForConnection =<<) . C.connectFirst @ \subsection{Default connections} @@ -2645,6 +2784,7 @@ of the user's session. <>= +<> getSystemBus :: IO (C.Connection, T.BusName) getSystemBus = getBus' $ fromEnv `E.catch` noEnv where defaultAddr = "unix:path=/var/run/dbus/system_bus_socket" @@ -2652,10 +2792,12 @@ noEnv (E.SomeException _) = return defaultAddr <>= +<> getSessionBus :: IO (C.Connection, T.BusName) getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS" <>= +<> getStarterBus :: IO (C.Connection, T.BusName) getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS" @@ -2664,8 +2806,8 @@ getBus' io = do addr <- fmap TL.pack io case A.mkAddresses addr of - Just [x] -> getBus x - Just x -> getFirstBus x + Just [x] -> getBus Auth.realUserID x + Just xs -> getFirstBus [(Auth.realUserID,x) | x <- xs] _ -> E.throwIO $ C.InvalidAddress addr @ \subsection{Sending the ``hello'' message} @@ -2673,7 +2815,7 @@ <>= hello :: M.MethodCall hello = M.MethodCall dbusPath - (T.mkMemberName' "Hello") + "Hello" (Just dbusInterface) (Just dbusName) Set.empty @@ -3071,7 +3213,7 @@ @ \section{Match rules} -Match rules are used indicate that the client is interested in messages +Match rules are used to indicate that the client is interested in messages matching a particular filter. This module provides an interface for building match rule strings. Eventually, it will support parsing them also. @@ -3096,11 +3238,12 @@ import qualified DBus.Constants as C import DBus.Util (maybeIndex) -@ A match rule is a set of filters; most filters may have one possible -value assigned, such as a single message type. The exception are parameter -filters, which are limited in number only by the server implementation. <>= +-- | A match rule is a set of filters; most filters may have one possible +-- value assigned, such as a single message type. The exception are parameter +-- filters, which are limited in number only by the server implementation. +-- data MatchRule = MatchRule { matchType :: Maybe MessageType , matchSender :: Maybe T.BusName @@ -3110,25 +3253,26 @@ , matchDestination :: Maybe T.BusName , matchParameters :: [ParameterValue] } - -@ Parameters may match against two types, strings and object paths. It's -probably an error to have two values for the same parameter. - -The constructor {\tt StringValue 3 "hello"} means that the fourth parameter -in the message body must be the string ``hello''. {\tt PathValue} is the -same, but its value must be an object path. + deriving (Show) <>= +-- | Parameters may match against two types, strings and object paths. It's +-- probably an error to have two values for the same parameter. +-- +-- The constructor @StringValue 3 \"hello\"@ means that the fourth parameter +-- in the message body must be the string @\"hello\"@. @PathValue@ is the +-- same, but its value must be an object path. +-- data ParameterValue = StringValue Word8 Text | PathValue Word8 T.ObjectPath deriving (Show, Eq) -@ The set of allowed message types to filter on is separate from the set -supported for sending over the wire. This allows the server to support -additional types not yet implemented in the library, or vice-versa. - <>= +-- | The set of allowed message types to filter on is separate from the set +-- supported for sending over the wire. This allows the server to support +-- additional types not yet implemented in the library, or vice-versa. +-- data MessageType = MethodCall | MethodReturn @@ -3140,6 +3284,7 @@ to format them. <>= +<> formatRule :: MatchRule -> Text formatRule rule = TL.intercalate "," filters where filters = structureFilters ++ parameterFilters @@ -3180,10 +3325,11 @@ it's useful to have a message-building function pre-defined. <>= +<> addMatch :: MatchRule -> M.MethodCall addMatch rule = M.MethodCall C.dbusPath - (T.mkMemberName' "AddMatch") + "AddMatch" (Just C.dbusInterface) (Just C.dbusName) Set.empty @@ -3193,6 +3339,7 @@ an empty rule allows clients to set only the fields they care about. <>= +<> matchAll :: MatchRule matchAll = MatchRule { matchType = Nothing @@ -3208,6 +3355,7 @@ signals. <>= +<> matches :: MatchRule -> M.ReceivedMessage -> Bool matches rule msg = and . catMaybes . map ($ rule) $ [ fmap (typeMatches msg) . matchType @@ -3323,13 +3471,14 @@ {\tt ReleaseName}. <>= +<> requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall requestName name flags = M.MethodCall { M.methodCallPath = C.dbusPath , M.methodCallInterface = Just C.dbusInterface , M.methodCallDestination = Just C.dbusName , M.methodCallFlags = Set.empty - , M.methodCallMember = T.mkMemberName' "RequestName" + , M.methodCallMember = "RequestName" , M.methodCallBody = [ T.toVariant name , T.toVariant . encodeFlags $ flags] @@ -3359,13 +3508,14 @@ decodeRequestReply _ = Nothing <>= +<> releaseName :: T.BusName -> M.MethodCall releaseName name = M.MethodCall { M.methodCallPath = C.dbusPath , M.methodCallInterface = Just C.dbusInterface , M.methodCallDestination = Just C.dbusName , M.methodCallFlags = Set.empty - , M.methodCallMember = T.mkMemberName' "ReleaseName" + , M.methodCallMember = "ReleaseName" , M.methodCallBody = [T.toVariant name] } @@ -3414,153 +3564,192 @@ <>= dbusName :: T.BusName -dbusName = T.mkBusName' "org.freedesktop.DBus" +dbusName = "org.freedesktop.DBus" dbusPath :: T.ObjectPath -dbusPath = T.mkObjectPath' "/org/freedesktop/DBus" +dbusPath = "/org/freedesktop/DBus" dbusInterface :: T.InterfaceName -dbusInterface = T.mkInterfaceName' "org.freedesktop.DBus" +dbusInterface = "org.freedesktop.DBus" @ \subsection{Pre-defined interfaces} <>= interfaceIntrospectable :: T.InterfaceName -interfaceIntrospectable = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable" +interfaceIntrospectable = "org.freedesktop.DBus.Introspectable" interfaceProperties :: T.InterfaceName -interfaceProperties = T.mkInterfaceName' "org.freedesktop.DBus.Properties" +interfaceProperties = "org.freedesktop.DBus.Properties" interfacePeer :: T.InterfaceName -interfacePeer = T.mkInterfaceName' "org.freedesktop.DBus.Peer" +interfacePeer = "org.freedesktop.DBus.Peer" @ \subsection{Pre-defined error names} <>= errorFailed :: T.ErrorName -errorFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Failed" +errorFailed = "org.freedesktop.DBus.Error.Failed" errorNoMemory :: T.ErrorName -errorNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.NoMemory" +errorNoMemory = "org.freedesktop.DBus.Error.NoMemory" errorServiceUnknown :: T.ErrorName -errorServiceUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.ServiceUnknown" +errorServiceUnknown = "org.freedesktop.DBus.Error.ServiceUnknown" errorNameHasNoOwner :: T.ErrorName -errorNameHasNoOwner = T.mkErrorName' "org.freedesktop.DBus.Error.NameHasNoOwner" +errorNameHasNoOwner = "org.freedesktop.DBus.Error.NameHasNoOwner" errorNoReply :: T.ErrorName -errorNoReply = T.mkErrorName' "org.freedesktop.DBus.Error.NoReply" +errorNoReply = "org.freedesktop.DBus.Error.NoReply" errorIOError :: T.ErrorName -errorIOError = T.mkErrorName' "org.freedesktop.DBus.Error.IOError" +errorIOError = "org.freedesktop.DBus.Error.IOError" errorBadAddress :: T.ErrorName -errorBadAddress = T.mkErrorName' "org.freedesktop.DBus.Error.BadAddress" +errorBadAddress = "org.freedesktop.DBus.Error.BadAddress" errorNotSupported :: T.ErrorName -errorNotSupported = T.mkErrorName' "org.freedesktop.DBus.Error.NotSupported" +errorNotSupported = "org.freedesktop.DBus.Error.NotSupported" errorLimitsExceeded :: T.ErrorName -errorLimitsExceeded = T.mkErrorName' "org.freedesktop.DBus.Error.LimitsExceeded" +errorLimitsExceeded = "org.freedesktop.DBus.Error.LimitsExceeded" errorAccessDenied :: T.ErrorName -errorAccessDenied = T.mkErrorName' "org.freedesktop.DBus.Error.AccessDenied" +errorAccessDenied = "org.freedesktop.DBus.Error.AccessDenied" errorAuthFailed :: T.ErrorName -errorAuthFailed = T.mkErrorName' "org.freedesktop.DBus.Error.AuthFailed" +errorAuthFailed = "org.freedesktop.DBus.Error.AuthFailed" errorNoServer :: T.ErrorName -errorNoServer = T.mkErrorName' "org.freedesktop.DBus.Error.NoServer" +errorNoServer = "org.freedesktop.DBus.Error.NoServer" errorTimeout :: T.ErrorName -errorTimeout = T.mkErrorName' "org.freedesktop.DBus.Error.Timeout" +errorTimeout = "org.freedesktop.DBus.Error.Timeout" errorNoNetwork :: T.ErrorName -errorNoNetwork = T.mkErrorName' "org.freedesktop.DBus.Error.NoNetwork" +errorNoNetwork = "org.freedesktop.DBus.Error.NoNetwork" errorAddressInUse :: T.ErrorName -errorAddressInUse = T.mkErrorName' "org.freedesktop.DBus.Error.AddressInUse" +errorAddressInUse = "org.freedesktop.DBus.Error.AddressInUse" errorDisconnected :: T.ErrorName -errorDisconnected = T.mkErrorName' "org.freedesktop.DBus.Error.Disconnected" +errorDisconnected = "org.freedesktop.DBus.Error.Disconnected" errorInvalidArgs :: T.ErrorName -errorInvalidArgs = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidArgs" +errorInvalidArgs = "org.freedesktop.DBus.Error.InvalidArgs" errorFileNotFound :: T.ErrorName -errorFileNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.FileNotFound" +errorFileNotFound = "org.freedesktop.DBus.Error.FileNotFound" errorFileExists :: T.ErrorName -errorFileExists = T.mkErrorName' "org.freedesktop.DBus.Error.FileExists" +errorFileExists = "org.freedesktop.DBus.Error.FileExists" errorUnknownMethod :: T.ErrorName -errorUnknownMethod = T.mkErrorName' "org.freedesktop.DBus.Error.UnknownMethod" +errorUnknownMethod = "org.freedesktop.DBus.Error.UnknownMethod" errorTimedOut :: T.ErrorName -errorTimedOut = T.mkErrorName' "org.freedesktop.DBus.Error.TimedOut" +errorTimedOut = "org.freedesktop.DBus.Error.TimedOut" errorMatchRuleNotFound :: T.ErrorName -errorMatchRuleNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleNotFound" +errorMatchRuleNotFound = "org.freedesktop.DBus.Error.MatchRuleNotFound" errorMatchRuleInvalid :: T.ErrorName -errorMatchRuleInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleInvalid" +errorMatchRuleInvalid = "org.freedesktop.DBus.Error.MatchRuleInvalid" errorSpawnExecFailed :: T.ErrorName -errorSpawnExecFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ExecFailed" +errorSpawnExecFailed = "org.freedesktop.DBus.Error.Spawn.ExecFailed" errorSpawnForkFailed :: T.ErrorName -errorSpawnForkFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ForkFailed" +errorSpawnForkFailed = "org.freedesktop.DBus.Error.Spawn.ForkFailed" errorSpawnChildExited :: T.ErrorName -errorSpawnChildExited = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildExited" +errorSpawnChildExited = "org.freedesktop.DBus.Error.Spawn.ChildExited" errorSpawnChildSignaled :: T.ErrorName -errorSpawnChildSignaled = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildSignaled" +errorSpawnChildSignaled = "org.freedesktop.DBus.Error.Spawn.ChildSignaled" errorSpawnFailed :: T.ErrorName -errorSpawnFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.Failed" +errorSpawnFailed = "org.freedesktop.DBus.Error.Spawn.Failed" errorSpawnFailedToSetup :: T.ErrorName -errorSpawnFailedToSetup = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FailedToSetup" +errorSpawnFailedToSetup = "org.freedesktop.DBus.Error.Spawn.FailedToSetup" errorSpawnConfigInvalid :: T.ErrorName -errorSpawnConfigInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ConfigInvalid" +errorSpawnConfigInvalid = "org.freedesktop.DBus.Error.Spawn.ConfigInvalid" errorSpawnServiceNotValid :: T.ErrorName -errorSpawnServiceNotValid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotValid" +errorSpawnServiceNotValid = "org.freedesktop.DBus.Error.Spawn.ServiceNotValid" errorSpawnServiceNotFound :: T.ErrorName -errorSpawnServiceNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotFound" +errorSpawnServiceNotFound = "org.freedesktop.DBus.Error.Spawn.ServiceNotFound" errorSpawnPermissionsInvalid :: T.ErrorName -errorSpawnPermissionsInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid" +errorSpawnPermissionsInvalid = "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid" errorSpawnFileInvalid :: T.ErrorName -errorSpawnFileInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FileInvalid" +errorSpawnFileInvalid = "org.freedesktop.DBus.Error.Spawn.FileInvalid" errorSpawnNoMemory :: T.ErrorName -errorSpawnNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.NoMemory" +errorSpawnNoMemory = "org.freedesktop.DBus.Error.Spawn.NoMemory" errorUnixProcessIdUnknown :: T.ErrorName -errorUnixProcessIdUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.UnixProcessIdUnknown" +errorUnixProcessIdUnknown = "org.freedesktop.DBus.Error.UnixProcessIdUnknown" errorInvalidFileContent :: T.ErrorName -errorInvalidFileContent = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidFileContent" +errorInvalidFileContent = "org.freedesktop.DBus.Error.InvalidFileContent" errorSELinuxSecurityContextUnknown :: T.ErrorName -errorSELinuxSecurityContextUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown" +errorSELinuxSecurityContextUnknown = "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown" errorAdtAuditDataUnknown :: T.ErrorName -errorAdtAuditDataUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.AdtAuditDataUnknown" +errorAdtAuditDataUnknown = "org.freedesktop.DBus.Error.AdtAuditDataUnknown" errorObjectPathInUse :: T.ErrorName -errorObjectPathInUse = T.mkErrorName' "org.freedesktop.DBus.Error.ObjectPathInUse" +errorObjectPathInUse = "org.freedesktop.DBus.Error.ObjectPathInUse" errorInconsistentMessage :: T.ErrorName -errorInconsistentMessage = T.mkErrorName' "org.freedesktop.DBus.Error.InconsistentMessage" +errorInconsistentMessage = "org.freedesktop.DBus.Error.InconsistentMessage" @ +\section{UUIDs} + +D-Bus {\sc uuid}s are 128-bit unique identifiers, used for server instances +and machine {\sc id}s. They are not compatible with {\sc rfc4122}. + +<>= +<> +module DBus.UUID + ( UUID + , toHex + , fromHex + ) where +<> + +newtype UUID = UUID Text -- TODO: (Word64, Word64)? + deriving (Eq) + +instance Show UUID where + showsPrec d uuid = showParen (d > 10) $ + showString "UUID " . shows (toHex uuid) + +toHex :: UUID -> Text +toHex (UUID text) = text + +fromHex :: Text -> Maybe UUID +fromHex text = if validUUID text + then Just $ UUID text + else Nothing + +validUUID :: Text -> Bool +validUUID text = valid where + valid = and [TL.length text == 32, TL.all validChar text] + validChar c = or + [ c >= '0' && c <= '9' + , c >= 'a' && c <= 'f' + , c >= 'A' && c <= 'F' + ] + +@ \section{Misc. utility functions} <>= @@ -3568,6 +3757,7 @@ module DBus.Util where import Text.Parsec (Parsec, parse) import Data.Char (digitToInt) +import Data.List (isPrefixOf) checkLength :: Int -> String -> Maybe String checkLength length' s | length s <= length' = Just s @@ -3596,5 +3786,147 @@ maybeIndex (x:_ ) 0 = Just x maybeIndex (_:xs) n | n > 0 = maybeIndex xs (n - 1) maybeIndex _ _ = Nothing + +-- | Read values from a monad until a guard value is read; return all +-- values, including the guard. +-- +readUntil :: (Monad m, Eq a) => [a] -> m a -> m [a] +readUntil guard getx = readUntil' [] where + guard' = reverse guard + step xs | isPrefixOf guard' xs = return . reverse $ xs + | otherwise = readUntil' xs + readUntil' xs = do + x <- getx + step $ x:xs + +-- | Drop /n/ items from the end of a list +dropEnd :: Int -> [a] -> [a] +dropEnd n xs = take (length xs - n) xs + +@ +\section{Haddock API documentation} + +The \LaTeX{} documentation is great for somebody reading the source code +or trying to fix an error, but it's not useful for people who just want +to add D-Bus support to their applications. These documentation sections +will be included in Haddock output for public functions. + +There's no real order to this section; it exists only because Haddock +can't merge documentation from external files. + +<>= +-- | \"Atomic\" types are any which can't contain any other types. Only +-- atomic types may be used as dictionary keys. + +<>= +-- | Every type has an associated type code; a textual representation of +-- the type, useful for debugging. + +<>= +-- | 'Variant's may contain any other built-in D-Bus value. Besides +-- representing native @VARIANT@ values, they allow type-safe storage and +-- deconstruction of heterogeneous collections. + +<>= +-- | Every variant is strongly-typed; that is, the type of its contained +-- value is known at all times. This function retrieves that type, so that +-- the correct cast can be used to retrieve the value. + +<>= +-- | This is the type contained within the array, not the type of the array +-- itself. + +<>= +-- | A 'Connection' is an opaque handle to an open D-Bus channel, with an +-- internal state for maintaining the current message serial. + +<>= +-- | A 'Transport' is anything which can send and receive bytestrings, +-- typically via a socket. + +<>= +-- | Open a connection to some address, using a given authentication +-- mechanism. If the connection fails, a 'ConnectionError' will be thrown. + +<>= +-- | Try to open a connection to various addresses, returning the first +-- connection which could be successfully opened. + +<>= +-- | Send a single message, with a generated 'M.Serial'. The second parameter +-- exists to prevent race conditions when registering a reply handler; it +-- receives the serial the message /will/ be sent with, before it's actually +-- sent. +-- +-- Only one message may be sent at a time; if multiple threads attempt to +-- send messages in parallel, one will block until after the other has +-- finished. + +<>= +-- | Receive the next message from the connection, blocking until one is +-- available. +-- +-- Only one message may be received at a time; if multiple threads attempt +-- to receive messages in parallel, one will block until after the other has +-- finished. + +<>= +-- | Similar to 'C.connect', but additionally sends @Hello@ messages to the +-- central bus. + +<>= +-- | Similar to 'C.connectFirst', but additionally sends @Hello@ messages to +-- the central bus. + +<>= +-- | Connect to the bus specified in the environment variable +-- @DBUS_SYSTEM_BUS_ADDRESS@, or to +-- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@ +-- is not set. + +<>= +-- | Connect to the bus specified in the environment variable +-- @DBUS_SESSION_BUS_ADDRESS@, which must be set. + +<>= +-- | Connect to the bus specified in the environment variable +-- @DBUS_STARTER_ADDRESS@, which must be set. + +<>= +-- | Format a 'MatchRule' as the bus expects to receive in a call to +-- @AddMatch@. + +<>= +-- | Build a 'M.MethodCall' for adding a match rule to the bus. + +<>= +-- | An empty match rule, which matches everything. + +<>= +-- | Whether a 'M.ReceivedMessage' matches a given rule. This is useful +-- for implementing signal handlers. + +<>= +-- | Build a 'M.MethodCall' for requesting a registered bus name. + +<>= +-- | Build a 'M.MethodCall' for releasing a registered bus name. + +<>= +-- | A value used to uniquely identify a particular message within a session. +-- 'Serial's are 32-bit unsigned integers, and eventually wrap. + +<>= +-- | Not an actual message type, but a wrapper around messages received from +-- the bus. Each value contains the message's 'Serial' and possibly the +-- origin's 'T.BusName' + +<>= +-- | Convert a 'M.Message' into a 'L.ByteString'. Although unusual, it is +-- possible for marshaling to fail -- if this occurs, an appropriate error +-- will be returned instead. + +<>= +-- | Read bytes from a monad until a complete message has been received. @ \end{document} diff --git a/hs/DBus/Authentication.hs b/hs/DBus/Authentication.hs new file mode 100644 --- /dev/null +++ b/hs/DBus/Authentication.hs @@ -0,0 +1,100 @@ +{- + Copyright (C) 2009 John Millikin + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} + +{-# LANGUAGE OverloadedStrings #-} + +{-# LANGUAGE DeriveDataTypeable #-} +module DBus.Authentication + ( Command + , Mechanism (..) + + , AuthenticationError (..) + + , authenticate + + , realUserID + + ) where +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL + +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as ByteString +import qualified DBus.UUID as UUID + +import Data.Typeable (Typeable) +import qualified Control.Exception as E + +import Data.Word (Word8) + +import Control.Monad (liftM) +import Data.Char (chr) +import Data.Text.Lazy.Encoding (encodeUtf8) +import DBus.Util (readUntil, dropEnd) + +import System.Posix.User (getRealUserID) +import Data.Char (ord) +import Text.Printf (printf) + +import Data.Maybe (isJust) + + +type Command = Text +newtype Mechanism = Mechanism + { mechanismRun :: (Command -> IO Command) -> IO UUID.UUID + } + +data AuthenticationError + = AuthenticationError Text + deriving (Show, Typeable) + +instance E.Exception AuthenticationError + +authenticate :: Mechanism -> (ByteString -> IO ()) -> IO Word8 + -> IO UUID.UUID +authenticate mech put getByte = do + put $ ByteString.singleton 0 + uuid <- mechanismRun mech (putCommand put getByte) + put "BEGIN\r\n" + return uuid + +putCommand :: Monad m => (ByteString -> m ()) -> m Word8 -> Command -> m Command +putCommand put get cmd = do + let getC = liftM (chr . fromIntegral) get + put $ encodeUtf8 cmd + put "\r\n" + liftM (TL.pack . dropEnd 2) $ readUntil "\r\n" getC + +realUserID :: Mechanism +realUserID = Mechanism $ \sendCmd -> do + uid <- getRealUserID + let token = concatMap (printf "%02X" . ord) (show uid) + let cmd = "AUTH EXTERNAL " ++ token + eitherUUID <- checkOK `fmap` sendCmd (TL.pack cmd) + case eitherUUID of + Right uuid -> return uuid + Left err -> E.throwIO $ AuthenticationError err + +checkOK :: Command -> Either Text UUID.UUID +checkOK cmd = if validUUID then Right uuid else Left errorMsg where + validUUID = TL.isPrefixOf "OK " cmd && isJust maybeUUID + maybeUUID = UUID.fromHex $ TL.drop 3 cmd + Just uuid = maybeUUID + errorMsg = if TL.isPrefixOf "ERROR " cmd + then TL.drop 6 cmd + else TL.pack $ "Unexpected response: " ++ show cmd + diff --git a/hs/DBus/Bus.hs b/hs/DBus/Bus.hs --- a/hs/DBus/Bus.hs +++ b/hs/DBus/Bus.hs @@ -35,6 +35,7 @@ import System.Environment (getEnv) import qualified DBus.Address as A +import qualified DBus.Authentication as Auth import qualified DBus.Connection as C import DBus.Constants (dbusName, dbusPath, dbusInterface) import qualified DBus.Message as M @@ -44,21 +45,38 @@ busForConnection :: C.Connection -> IO (C.Connection, T.BusName) busForConnection c = sendHello c >>= return . (,) c -getBus :: A.Address -> IO (C.Connection, T.BusName) -getBus = (busForConnection =<<) . C.connect +-- | Similar to 'C.connect', but additionally sends @Hello@ messages to the +-- central bus. -getFirstBus :: [A.Address] -> IO (C.Connection, T.BusName) +getBus :: Auth.Mechanism -> A.Address -> IO (C.Connection, T.BusName) +getBus = ((busForConnection =<<) .) . C.connect + +-- | Similar to 'C.connectFirst', but additionally sends @Hello@ messages to +-- the central bus. + +getFirstBus :: [(Auth.Mechanism, A.Address)] -> IO (C.Connection, T.BusName) getFirstBus = (busForConnection =<<) . C.connectFirst +-- | Connect to the bus specified in the environment variable +-- @DBUS_SYSTEM_BUS_ADDRESS@, or to +-- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@ +-- is not set. + getSystemBus :: IO (C.Connection, T.BusName) getSystemBus = getBus' $ fromEnv `E.catch` noEnv where defaultAddr = "unix:path=/var/run/dbus/system_bus_socket" fromEnv = getEnv "DBUS_SYSTEM_BUS_ADDRESS" noEnv (E.SomeException _) = return defaultAddr +-- | Connect to the bus specified in the environment variable +-- @DBUS_SESSION_BUS_ADDRESS@, which must be set. + getSessionBus :: IO (C.Connection, T.BusName) getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS" +-- | Connect to the bus specified in the environment variable +-- @DBUS_STARTER_ADDRESS@, which must be set. + getStarterBus :: IO (C.Connection, T.BusName) getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS" @@ -66,13 +84,13 @@ getBus' io = do addr <- fmap TL.pack io case A.mkAddresses addr of - Just [x] -> getBus x - Just x -> getFirstBus x + Just [x] -> getBus Auth.realUserID x + Just xs -> getFirstBus [(Auth.realUserID,x) | x <- xs] _ -> E.throwIO $ C.InvalidAddress addr hello :: M.MethodCall hello = M.MethodCall dbusPath - (T.mkMemberName' "Hello") + "Hello" (Just dbusInterface) (Just dbusName) Set.empty diff --git a/hs/DBus/Connection.hs b/hs/DBus/Connection.hs --- a/hs/DBus/Connection.hs +++ b/hs/DBus/Connection.hs @@ -20,6 +20,8 @@ {-# LANGUAGE DeriveDataTypeable #-} module DBus.Connection ( Connection + , connectionAddress + , connectionUUID , ConnectionError (..) @@ -36,7 +38,8 @@ import qualified Control.Concurrent as C import qualified DBus.Address as A -import qualified DBus.Message.Internal as M +import qualified DBus.Message as M +import qualified DBus.UUID as UUID import qualified Data.ByteString.Lazy as L import Data.Word (Word32) @@ -56,24 +59,28 @@ import qualified Control.Exception as E import Data.Typeable (Typeable) -import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) - -import System.Posix.User (getRealUserID) -import Data.Char (ord) -import Text.Printf (printf) - -import Data.List (isPrefixOf) +import qualified DBus.Authentication as Auth import qualified DBus.Wire as W -data Connection = Connection A.Address Transport (C.MVar M.Serial) (C.MVar ()) +data Connection = Connection + { connectionAddress :: A.Address + , connectionTransport :: Transport + , connectionSerialMVar :: C.MVar M.Serial + , connectionReadMVar :: C.MVar () + , connectionUUID :: UUID.UUID + } instance Show Connection where - showsPrec d (Connection a _ _ _) = showParen (d > 10) $ - showString' [""] where - showString' = foldr (.) id . map showString + showsPrec d con = showParen (d > 10) strCon where + addr = A.strAddress $ connectionAddress con + strCon = s "" + s = showString +-- | A 'Transport' is anything which can send and receive bytestrings, +-- typically via a socket. + data Transport = Transport { transportSend :: L.ByteString -> IO () , transportRecv :: Word32 -> IO L.ByteString @@ -176,50 +183,40 @@ instance E.Exception ConnectionError -connect :: A.Address -> IO Connection -connect a = do +-- | Open a connection to some address, using a given authentication +-- mechanism. If the connection fails, a 'ConnectionError' will be thrown. + +connect :: Auth.Mechanism -> A.Address -> IO Connection +connect mechanism a = do t <- connectTransport a - let putS = transportSend t . encodeUtf8 . TL.pack - let getS = fmap (TL.unpack . decodeUtf8) . transportRecv t - authenticate putS getS + let getByte = L.head `fmap` transportRecv t 1 + uuid <- Auth.authenticate mechanism (transportSend t) getByte readLock <- C.newMVar () serialMVar <- C.newMVar M.firstSerial - return $ Connection a t serialMVar readLock + return $ Connection a t serialMVar readLock uuid -connectFirst :: [A.Address] -> IO Connection +-- | Try to open a connection to various addresses, returning the first +-- connection which could be successfully opened. + +connectFirst :: [(Auth.Mechanism, A.Address)] -> IO Connection connectFirst orig = connectFirst' orig where - connectFirst' [] = E.throwIO $ NoWorkingAddress orig - connectFirst' (a:as) = E.catch (connect a) $ + allAddrs = [a | (_, a) <- orig] + connectFirst' [] = E.throwIO $ NoWorkingAddress allAddrs + connectFirst' ((mech, a):as) = E.catch (connect mech a) $ \(E.SomeException _) -> connectFirst' as -authenticate :: (String -> IO ()) -> (Word32 -> IO String) - -> IO () -authenticate put get = do - put "\x00" - - uid <- getRealUserID - let authToken = concatMap (printf "%02X" . ord) (show uid) - put $ "AUTH EXTERNAL " ++ authToken ++ "\r\n" - - response <- readUntil '\n' get - if "OK" `isPrefixOf` response - then put "BEGIN\r\n" - else do - putStrLn $ "response = " ++ show response - error "Server rejected authentication token." - -readUntil :: Monad m => Char -> (Word32 -> m String) -> m String -readUntil = readUntil' "" where - readUntil' xs c f = do - [x] <- f 1 - let xs' = xs ++ [x] - if x == c - then return xs' - else readUntil' xs' c f +-- | Send a single message, with a generated 'M.Serial'. The second parameter +-- exists to prevent race conditions when registering a reply handler; it +-- receives the serial the message /will/ be sent with, before it's actually +-- sent. +-- +-- Only one message may be sent at a time; if multiple threads attempt to +-- send messages in parallel, one will block until after the other has +-- finished. send :: M.Message a => Connection -> (M.Serial -> IO b) -> a -> IO (Either W.MarshalError b) -send (Connection _ t mvar _) io msg = withSerial mvar $ \serial -> +send (Connection _ t mvar _ _) io msg = withSerial mvar $ \serial -> case W.marshalMessage W.LittleEndian serial msg of Right bytes -> do x <- io serial @@ -235,7 +232,14 @@ C.putMVar m s' return x +-- | Receive the next message from the connection, blocking until one is +-- available. +-- +-- Only one message may be received at a time; if multiple threads attempt +-- to receive messages in parallel, one will block until after the other has +-- finished. + receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage) -receive (Connection _ t _ lock) = C.withMVar lock $ \_ -> +receive (Connection _ t _ lock _) = C.withMVar lock $ \_ -> W.unmarshalMessage $ transportRecv t diff --git a/hs/DBus/Constants.hs b/hs/DBus/Constants.hs --- a/hs/DBus/Constants.hs +++ b/hs/DBus/Constants.hs @@ -30,143 +30,143 @@ arrayMaximumLength = 67108864 dbusName :: T.BusName -dbusName = T.mkBusName' "org.freedesktop.DBus" +dbusName = "org.freedesktop.DBus" dbusPath :: T.ObjectPath -dbusPath = T.mkObjectPath' "/org/freedesktop/DBus" +dbusPath = "/org/freedesktop/DBus" dbusInterface :: T.InterfaceName -dbusInterface = T.mkInterfaceName' "org.freedesktop.DBus" +dbusInterface = "org.freedesktop.DBus" interfaceIntrospectable :: T.InterfaceName -interfaceIntrospectable = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable" +interfaceIntrospectable = "org.freedesktop.DBus.Introspectable" interfaceProperties :: T.InterfaceName -interfaceProperties = T.mkInterfaceName' "org.freedesktop.DBus.Properties" +interfaceProperties = "org.freedesktop.DBus.Properties" interfacePeer :: T.InterfaceName -interfacePeer = T.mkInterfaceName' "org.freedesktop.DBus.Peer" +interfacePeer = "org.freedesktop.DBus.Peer" errorFailed :: T.ErrorName -errorFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Failed" +errorFailed = "org.freedesktop.DBus.Error.Failed" errorNoMemory :: T.ErrorName -errorNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.NoMemory" +errorNoMemory = "org.freedesktop.DBus.Error.NoMemory" errorServiceUnknown :: T.ErrorName -errorServiceUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.ServiceUnknown" +errorServiceUnknown = "org.freedesktop.DBus.Error.ServiceUnknown" errorNameHasNoOwner :: T.ErrorName -errorNameHasNoOwner = T.mkErrorName' "org.freedesktop.DBus.Error.NameHasNoOwner" +errorNameHasNoOwner = "org.freedesktop.DBus.Error.NameHasNoOwner" errorNoReply :: T.ErrorName -errorNoReply = T.mkErrorName' "org.freedesktop.DBus.Error.NoReply" +errorNoReply = "org.freedesktop.DBus.Error.NoReply" errorIOError :: T.ErrorName -errorIOError = T.mkErrorName' "org.freedesktop.DBus.Error.IOError" +errorIOError = "org.freedesktop.DBus.Error.IOError" errorBadAddress :: T.ErrorName -errorBadAddress = T.mkErrorName' "org.freedesktop.DBus.Error.BadAddress" +errorBadAddress = "org.freedesktop.DBus.Error.BadAddress" errorNotSupported :: T.ErrorName -errorNotSupported = T.mkErrorName' "org.freedesktop.DBus.Error.NotSupported" +errorNotSupported = "org.freedesktop.DBus.Error.NotSupported" errorLimitsExceeded :: T.ErrorName -errorLimitsExceeded = T.mkErrorName' "org.freedesktop.DBus.Error.LimitsExceeded" +errorLimitsExceeded = "org.freedesktop.DBus.Error.LimitsExceeded" errorAccessDenied :: T.ErrorName -errorAccessDenied = T.mkErrorName' "org.freedesktop.DBus.Error.AccessDenied" +errorAccessDenied = "org.freedesktop.DBus.Error.AccessDenied" errorAuthFailed :: T.ErrorName -errorAuthFailed = T.mkErrorName' "org.freedesktop.DBus.Error.AuthFailed" +errorAuthFailed = "org.freedesktop.DBus.Error.AuthFailed" errorNoServer :: T.ErrorName -errorNoServer = T.mkErrorName' "org.freedesktop.DBus.Error.NoServer" +errorNoServer = "org.freedesktop.DBus.Error.NoServer" errorTimeout :: T.ErrorName -errorTimeout = T.mkErrorName' "org.freedesktop.DBus.Error.Timeout" +errorTimeout = "org.freedesktop.DBus.Error.Timeout" errorNoNetwork :: T.ErrorName -errorNoNetwork = T.mkErrorName' "org.freedesktop.DBus.Error.NoNetwork" +errorNoNetwork = "org.freedesktop.DBus.Error.NoNetwork" errorAddressInUse :: T.ErrorName -errorAddressInUse = T.mkErrorName' "org.freedesktop.DBus.Error.AddressInUse" +errorAddressInUse = "org.freedesktop.DBus.Error.AddressInUse" errorDisconnected :: T.ErrorName -errorDisconnected = T.mkErrorName' "org.freedesktop.DBus.Error.Disconnected" +errorDisconnected = "org.freedesktop.DBus.Error.Disconnected" errorInvalidArgs :: T.ErrorName -errorInvalidArgs = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidArgs" +errorInvalidArgs = "org.freedesktop.DBus.Error.InvalidArgs" errorFileNotFound :: T.ErrorName -errorFileNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.FileNotFound" +errorFileNotFound = "org.freedesktop.DBus.Error.FileNotFound" errorFileExists :: T.ErrorName -errorFileExists = T.mkErrorName' "org.freedesktop.DBus.Error.FileExists" +errorFileExists = "org.freedesktop.DBus.Error.FileExists" errorUnknownMethod :: T.ErrorName -errorUnknownMethod = T.mkErrorName' "org.freedesktop.DBus.Error.UnknownMethod" +errorUnknownMethod = "org.freedesktop.DBus.Error.UnknownMethod" errorTimedOut :: T.ErrorName -errorTimedOut = T.mkErrorName' "org.freedesktop.DBus.Error.TimedOut" +errorTimedOut = "org.freedesktop.DBus.Error.TimedOut" errorMatchRuleNotFound :: T.ErrorName -errorMatchRuleNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleNotFound" +errorMatchRuleNotFound = "org.freedesktop.DBus.Error.MatchRuleNotFound" errorMatchRuleInvalid :: T.ErrorName -errorMatchRuleInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleInvalid" +errorMatchRuleInvalid = "org.freedesktop.DBus.Error.MatchRuleInvalid" errorSpawnExecFailed :: T.ErrorName -errorSpawnExecFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ExecFailed" +errorSpawnExecFailed = "org.freedesktop.DBus.Error.Spawn.ExecFailed" errorSpawnForkFailed :: T.ErrorName -errorSpawnForkFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ForkFailed" +errorSpawnForkFailed = "org.freedesktop.DBus.Error.Spawn.ForkFailed" errorSpawnChildExited :: T.ErrorName -errorSpawnChildExited = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildExited" +errorSpawnChildExited = "org.freedesktop.DBus.Error.Spawn.ChildExited" errorSpawnChildSignaled :: T.ErrorName -errorSpawnChildSignaled = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildSignaled" +errorSpawnChildSignaled = "org.freedesktop.DBus.Error.Spawn.ChildSignaled" errorSpawnFailed :: T.ErrorName -errorSpawnFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.Failed" +errorSpawnFailed = "org.freedesktop.DBus.Error.Spawn.Failed" errorSpawnFailedToSetup :: T.ErrorName -errorSpawnFailedToSetup = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FailedToSetup" +errorSpawnFailedToSetup = "org.freedesktop.DBus.Error.Spawn.FailedToSetup" errorSpawnConfigInvalid :: T.ErrorName -errorSpawnConfigInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ConfigInvalid" +errorSpawnConfigInvalid = "org.freedesktop.DBus.Error.Spawn.ConfigInvalid" errorSpawnServiceNotValid :: T.ErrorName -errorSpawnServiceNotValid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotValid" +errorSpawnServiceNotValid = "org.freedesktop.DBus.Error.Spawn.ServiceNotValid" errorSpawnServiceNotFound :: T.ErrorName -errorSpawnServiceNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotFound" +errorSpawnServiceNotFound = "org.freedesktop.DBus.Error.Spawn.ServiceNotFound" errorSpawnPermissionsInvalid :: T.ErrorName -errorSpawnPermissionsInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid" +errorSpawnPermissionsInvalid = "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid" errorSpawnFileInvalid :: T.ErrorName -errorSpawnFileInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FileInvalid" +errorSpawnFileInvalid = "org.freedesktop.DBus.Error.Spawn.FileInvalid" errorSpawnNoMemory :: T.ErrorName -errorSpawnNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.NoMemory" +errorSpawnNoMemory = "org.freedesktop.DBus.Error.Spawn.NoMemory" errorUnixProcessIdUnknown :: T.ErrorName -errorUnixProcessIdUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.UnixProcessIdUnknown" +errorUnixProcessIdUnknown = "org.freedesktop.DBus.Error.UnixProcessIdUnknown" errorInvalidFileContent :: T.ErrorName -errorInvalidFileContent = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidFileContent" +errorInvalidFileContent = "org.freedesktop.DBus.Error.InvalidFileContent" errorSELinuxSecurityContextUnknown :: T.ErrorName -errorSELinuxSecurityContextUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown" +errorSELinuxSecurityContextUnknown = "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown" errorAdtAuditDataUnknown :: T.ErrorName -errorAdtAuditDataUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.AdtAuditDataUnknown" +errorAdtAuditDataUnknown = "org.freedesktop.DBus.Error.AdtAuditDataUnknown" errorObjectPathInUse :: T.ErrorName -errorObjectPathInUse = T.mkErrorName' "org.freedesktop.DBus.Error.ObjectPathInUse" +errorObjectPathInUse = "org.freedesktop.DBus.Error.ObjectPathInUse" errorInconsistentMessage :: T.ErrorName -errorInconsistentMessage = T.mkErrorName' "org.freedesktop.DBus.Error.InconsistentMessage" +errorInconsistentMessage = "org.freedesktop.DBus.Error.InconsistentMessage" diff --git a/hs/DBus/MatchRule.hs b/hs/DBus/MatchRule.hs --- a/hs/DBus/MatchRule.hs +++ b/hs/DBus/MatchRule.hs @@ -37,6 +37,11 @@ import qualified DBus.Constants as C import DBus.Util (maybeIndex) + +-- | A match rule is a set of filters; most filters may have one possible +-- value assigned, such as a single message type. The exception are parameter +-- filters, which are limited in number only by the server implementation. +-- data MatchRule = MatchRule { matchType :: Maybe MessageType , matchSender :: Maybe T.BusName @@ -46,12 +51,24 @@ , matchDestination :: Maybe T.BusName , matchParameters :: [ParameterValue] } + deriving (Show) +-- | Parameters may match against two types, strings and object paths. It's +-- probably an error to have two values for the same parameter. +-- +-- The constructor @StringValue 3 \"hello\"@ means that the fourth parameter +-- in the message body must be the string @\"hello\"@. @PathValue@ is the +-- same, but its value must be an object path. +-- data ParameterValue = StringValue Word8 Text | PathValue Word8 T.ObjectPath deriving (Show, Eq) +-- | The set of allowed message types to filter on is separate from the set +-- supported for sending over the wire. This allows the server to support +-- additional types not yet implemented in the library, or vice-versa. +-- data MessageType = MethodCall | MethodReturn @@ -59,6 +76,9 @@ | Error deriving (Show, Eq) +-- | Format a 'MatchRule' as the bus expects to receive in a call to +-- @AddMatch@. + formatRule :: MatchRule -> Text formatRule rule = TL.intercalate "," filters where filters = structureFilters ++ parameterFilters @@ -89,15 +109,19 @@ formatType Signal = "signal" formatType Error = "error" +-- | Build a 'M.MethodCall' for adding a match rule to the bus. + addMatch :: MatchRule -> M.MethodCall addMatch rule = M.MethodCall C.dbusPath - (T.mkMemberName' "AddMatch") + "AddMatch" (Just C.dbusInterface) (Just C.dbusName) Set.empty [T.toVariant $ formatRule rule] +-- | An empty match rule, which matches everything. + matchAll :: MatchRule matchAll = MatchRule { matchType = Nothing @@ -108,6 +132,9 @@ , matchDestination = Nothing , matchParameters = [] } + +-- | Whether a 'M.ReceivedMessage' matches a given rule. This is useful +-- for implementing signal handlers. matches :: MatchRule -> M.ReceivedMessage -> Bool matches rule msg = and . catMaybes . map ($ rule) $ diff --git a/hs/DBus/Message.hs b/hs/DBus/Message.hs --- a/hs/DBus/Message.hs +++ b/hs/DBus/Message.hs @@ -24,6 +24,8 @@ , Serial , serialValue + , firstSerial + , nextSerial , MethodCall (..) diff --git a/hs/DBus/Message/Internal.hs b/hs/DBus/Message/Internal.hs --- a/hs/DBus/Message/Internal.hs +++ b/hs/DBus/Message/Internal.hs @@ -49,6 +49,9 @@ | Signature T.Signature deriving (Show, Eq) +-- | A value used to uniquely identify a particular message within a session. +-- 'Serial's are 32-bit unsigned integers, and eventually wrap. + newtype Serial = Serial { serialValue :: Word32 } deriving (Eq, Ord) @@ -161,6 +164,10 @@ , unknownBody :: [T.Variant] } deriving (Show, Eq) + +-- | Not an actual message type, but a wrapper around messages received from +-- the bus. Each value contains the message's 'Serial' and possibly the +-- origin's 'T.BusName' data ReceivedMessage = ReceivedMethodCall Serial (Maybe T.BusName) MethodCall diff --git a/hs/DBus/NameReservation.hs b/hs/DBus/NameReservation.hs --- a/hs/DBus/NameReservation.hs +++ b/hs/DBus/NameReservation.hs @@ -45,13 +45,15 @@ flagValue ReplaceExisting = 0x2 flagValue DoNotQueue = 0x4 +-- | Build a 'M.MethodCall' for requesting a registered bus name. + requestName :: T.BusName -> [RequestNameFlag] -> M.MethodCall requestName name flags = M.MethodCall { M.methodCallPath = C.dbusPath , M.methodCallInterface = Just C.dbusInterface , M.methodCallDestination = Just C.dbusName , M.methodCallFlags = Set.empty - , M.methodCallMember = T.mkMemberName' "RequestName" + , M.methodCallMember = "RequestName" , M.methodCallBody = [ T.toVariant name , T.toVariant . encodeFlags $ flags] @@ -77,13 +79,15 @@ decodeRequestReply 4 = Just AlreadyOwner decodeRequestReply _ = Nothing +-- | Build a 'M.MethodCall' for releasing a registered bus name. + releaseName :: T.BusName -> M.MethodCall releaseName name = M.MethodCall { M.methodCallPath = C.dbusPath , M.methodCallInterface = Just C.dbusInterface , M.methodCallDestination = Just C.dbusName , M.methodCallFlags = Set.empty - , M.methodCallMember = T.mkMemberName' "ReleaseName" + , M.methodCallMember = "ReleaseName" , M.methodCallBody = [T.toVariant name] } diff --git a/hs/DBus/Types.hs b/hs/DBus/Types.hs --- a/hs/DBus/Types.hs +++ b/hs/DBus/Types.hs @@ -38,13 +38,13 @@ , strSignature , mkSignature - , mkSignature' + , mkSignature_ -- * Object paths , ObjectPath , strObjectPath , mkObjectPath - , mkObjectPath' + , mkObjectPath_ -- * Arrays , Array @@ -80,25 +80,25 @@ , BusName , strBusName , mkBusName - , mkBusName' + , mkBusName_ -- ** Interface names , InterfaceName , strInterfaceName , mkInterfaceName - , mkInterfaceName' + , mkInterfaceName_ -- ** Error names , ErrorName , strErrorName , mkErrorName - , mkErrorName' + , mkErrorName_ -- ** Member names , MemberName , strMemberName , mkMemberName - , mkMemberName' + , mkMemberName_ ) where import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL @@ -116,6 +116,8 @@ import DBus.Util (mkUnsafe) +import qualified Data.String as String + import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as ByteString @@ -150,6 +152,9 @@ | DBusStructure [Type] deriving (Show, Eq) +-- | \"Atomic\" types are any which can't contain any other types. Only +-- atomic types may be used as dictionary keys. + isAtomicType :: Type -> Bool isAtomicType DBusBoolean = True isAtomicType DBusByte = True @@ -165,11 +170,39 @@ isAtomicType DBusObjectPath = True isAtomicType _ = False +-- | Every type has an associated type code; a textual representation of +-- the type, useful for debugging. + typeCode :: Type -> Text +typeCode DBusBoolean = "b" +typeCode DBusByte = "y" +typeCode DBusInt16 = "n" +typeCode DBusInt32 = "i" +typeCode DBusInt64 = "x" +typeCode DBusWord16 = "q" +typeCode DBusWord32 = "u" +typeCode DBusWord64 = "t" +typeCode DBusDouble = "d" +typeCode DBusString = "s" +typeCode DBusSignature = "g" +typeCode DBusObjectPath = "o" +typeCode DBusVariant = "v" +typeCode (DBusArray t) = TL.cons 'a' $ typeCode t + +typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"] + +typeCode (DBusStructure ts) = TL.concat $ + ["("] ++ map typeCode ts ++ [")"] + + class (Show a, Eq a) => Builtin a where builtinDBusType :: a -> Type +-- | 'Variant's may contain any other built-in D-Bus value. Besides +-- representing native @VARIANT@ values, they allow type-safe storage and +-- deconstruction of heterogeneous collections. + data Variant = forall a. (Variable a, Builtin a, Typeable a) => Variant a deriving (Typeable) @@ -186,6 +219,10 @@ instance Eq Variant where (Variant x) == (Variant y) = cast x == Just y +-- | Every variant is strongly-typed; that is, the type of its contained +-- value is known at all times. This function retrieves that type, so that +-- the correct cast can be used to retrieve the value. + variantType :: Variant -> Type variantType (Variant x) = builtinDBusType x @@ -238,27 +275,6 @@ instance Ord Signature where compare x y = compare (strSignature x) (strSignature y) -typeCode DBusBoolean = "b" -typeCode DBusByte = "y" -typeCode DBusInt16 = "n" -typeCode DBusInt32 = "i" -typeCode DBusInt64 = "x" -typeCode DBusWord16 = "q" -typeCode DBusWord32 = "u" -typeCode DBusWord64 = "t" -typeCode DBusDouble = "d" -typeCode DBusString = "s" -typeCode DBusSignature = "g" -typeCode DBusObjectPath = "o" -typeCode DBusVariant = "v" - -typeCode (DBusArray t) = TL.cons 'a' $ typeCode t - -typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"] - -typeCode (DBusStructure ts) = TL.concat $ - ["("] ++ map typeCode ts ++ [")"] - mkSignature :: Text -> Maybe Signature mkSignature = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack where sigParser = do @@ -300,23 +316,33 @@ P.char ')' return $ DBusStructure types -mkSignature' :: Text -> Signature -mkSignature' = mkUnsafe "signature" mkSignature +mkSignature_ :: Text -> Signature +mkSignature_ = mkUnsafe "signature" mkSignature +instance String.IsString Signature where + fromString = mkSignature_ . TL.pack + instance Builtin ObjectPath where { builtinDBusType _ = DBusObjectPath }; instance Variable ObjectPath where { toVariant = Variant ; fromVariant (Variant x) = cast x }; newtype ObjectPath = ObjectPath { strObjectPath :: Text } - deriving (Show, Eq, Ord, Typeable) + deriving (Eq, Ord, Typeable) +instance Show ObjectPath where + showsPrec d (ObjectPath x) = showParen (d > 10) $ + showString "ObjectPath " . shows x + +instance String.IsString ObjectPath where + fromString = mkObjectPath_ . TL.pack + mkObjectPath :: Text -> Maybe ObjectPath mkObjectPath s = parseMaybe path' (TL.unpack s) where c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char path' = path >> P.eof >> return (ObjectPath s) -mkObjectPath' :: Text -> ObjectPath -mkObjectPath' = mkUnsafe "object path" mkObjectPath +mkObjectPath_ :: Text -> ObjectPath +mkObjectPath_ = mkUnsafe "object path" mkObjectPath instance Variable Array where { toVariant = Variant ; fromVariant (Variant x) = cast x }; data Array @@ -327,6 +353,9 @@ instance Builtin Array where builtinDBusType = DBusArray . arrayType +-- | This is the type contained within the array, not the type of the array +-- itself. + arrayType :: Array -> Type arrayType (VariantArray t _) = t arrayType (ByteArray _) = DBusByte @@ -460,8 +489,16 @@ -newtype BusName = BusName {strBusName :: Text} deriving (Show, Eq, Ord); instance Variable BusName where { toVariant = toVariant . strBusName ; fromVariant = (mkBusName =<<) . fromVariant }; mkBusName' :: Text -> BusName; mkBusName' = mkUnsafe "bus name" mkBusName + + + + + + + +newtype BusName = BusName {strBusName :: Text} deriving (Eq, Ord); instance Show BusName where { showsPrec d (BusName x) = showParen (d > 10) $ showString "BusName " . shows x }; instance String.IsString BusName where { fromString = mkBusName_ . TL.pack }; instance Variable BusName where { toVariant = toVariant . strBusName ; fromVariant = (mkBusName =<<) . fromVariant }; mkBusName_ :: Text -> BusName; mkBusName_ = mkUnsafe "bus name" mkBusName + mkBusName :: Text -> Maybe BusName mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" @@ -472,7 +509,7 @@ elems start = elem' start >> P.many1 (P.char '.' >> elem' start) elem' start = P.oneOf start >> P.many (P.oneOf c') -newtype InterfaceName = InterfaceName {strInterfaceName :: Text} deriving (Show, Eq, Ord); instance Variable InterfaceName where { toVariant = toVariant . strInterfaceName ; fromVariant = (mkInterfaceName =<<) . fromVariant }; mkInterfaceName' :: Text -> InterfaceName; mkInterfaceName' = mkUnsafe "interface name" mkInterfaceName +newtype InterfaceName = InterfaceName {strInterfaceName :: Text} deriving (Eq, Ord); instance Show InterfaceName where { showsPrec d (InterfaceName x) = showParen (d > 10) $ showString "InterfaceName " . shows x }; instance String.IsString InterfaceName where { fromString = mkInterfaceName_ . TL.pack }; instance Variable InterfaceName where { toVariant = toVariant . strInterfaceName ; fromVariant = (mkInterfaceName =<<) . fromVariant }; mkInterfaceName_ :: Text -> InterfaceName; mkInterfaceName_ = mkUnsafe "interface name" mkInterfaceName mkInterfaceName :: Text -> Maybe InterfaceName mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where @@ -482,12 +519,12 @@ name = element >> P.many1 (P.char '.' >> element) parser = name >> P.eof >> return (InterfaceName s) -newtype ErrorName = ErrorName {strErrorName :: Text} deriving (Show, Eq, Ord); instance Variable ErrorName where { toVariant = toVariant . strErrorName ; fromVariant = (mkErrorName =<<) . fromVariant }; mkErrorName' :: Text -> ErrorName; mkErrorName' = mkUnsafe "error name" mkErrorName +newtype ErrorName = ErrorName {strErrorName :: Text} deriving (Eq, Ord); instance Show ErrorName where { showsPrec d (ErrorName x) = showParen (d > 10) $ showString "ErrorName " . shows x }; instance String.IsString ErrorName where { fromString = mkErrorName_ . TL.pack }; instance Variable ErrorName where { toVariant = toVariant . strErrorName ; fromVariant = (mkErrorName =<<) . fromVariant }; mkErrorName_ :: Text -> ErrorName; mkErrorName_ = mkUnsafe "error name" mkErrorName mkErrorName :: Text -> Maybe ErrorName mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName -newtype MemberName = MemberName {strMemberName :: Text} deriving (Show, Eq, Ord); instance Variable MemberName where { toVariant = toVariant . strMemberName ; fromVariant = (mkMemberName =<<) . fromVariant }; mkMemberName' :: Text -> MemberName; mkMemberName' = mkUnsafe "member name" mkMemberName +newtype MemberName = MemberName {strMemberName :: Text} deriving (Eq, Ord); instance Show MemberName where { showsPrec d (MemberName x) = showParen (d > 10) $ showString "MemberName " . shows x }; instance String.IsString MemberName where { fromString = mkMemberName_ . TL.pack }; instance Variable MemberName where { toVariant = toVariant . strMemberName ; fromVariant = (mkMemberName =<<) . fromVariant }; mkMemberName_ :: Text -> MemberName; mkMemberName_ = mkUnsafe "member name" mkMemberName mkMemberName :: Text -> Maybe MemberName mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where diff --git a/hs/DBus/UUID.hs b/hs/DBus/UUID.hs new file mode 100644 --- /dev/null +++ b/hs/DBus/UUID.hs @@ -0,0 +1,50 @@ +{- + Copyright (C) 2009 John Millikin + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} + +module DBus.UUID + ( UUID + , toHex + , fromHex + ) where +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL + + +newtype UUID = UUID Text -- TODO: (Word64, Word64)? + deriving (Eq) + +instance Show UUID where + showsPrec d uuid = showParen (d > 10) $ + showString "UUID " . shows (toHex uuid) + +toHex :: UUID -> Text +toHex (UUID text) = text + +fromHex :: Text -> Maybe UUID +fromHex text = if validUUID text + then Just $ UUID text + else Nothing + +validUUID :: Text -> Bool +validUUID text = valid where + valid = and [TL.length text == 32, TL.all validChar text] + validChar c = or + [ c >= '0' && c <= '9' + , c >= 'a' && c <= 'f' + , c >= 'A' && c <= 'F' + ] + diff --git a/hs/DBus/Util.hs b/hs/DBus/Util.hs --- a/hs/DBus/Util.hs +++ b/hs/DBus/Util.hs @@ -18,6 +18,7 @@ module DBus.Util where import Text.Parsec (Parsec, parse) import Data.Char (digitToInt) +import Data.List (isPrefixOf) checkLength :: Int -> String -> Maybe String checkLength length' s | length s <= length' = Just s @@ -46,4 +47,20 @@ maybeIndex (x:_ ) 0 = Just x maybeIndex (_:xs) n | n > 0 = maybeIndex xs (n - 1) maybeIndex _ _ = Nothing + +-- | Read values from a monad until a guard value is read; return all +-- values, including the guard. +-- +readUntil :: (Monad m, Eq a) => [a] -> m a -> m [a] +readUntil guard getx = readUntil' [] where + guard' = reverse guard + step xs | isPrefixOf guard' xs = return . reverse $ xs + | otherwise = readUntil' xs + readUntil' xs = do + x <- getx + step $ x:xs + +-- | Drop /n/ items from the end of a list +dropEnd :: Int -> [a] -> [a] +dropEnd n xs = take (length xs - n) xs diff --git a/hs/DBus/Wire/Internal.hs b/hs/DBus/Wire/Internal.hs --- a/hs/DBus/Wire/Internal.hs +++ b/hs/DBus/Wire/Internal.hs @@ -508,6 +508,10 @@ c' = fromJust . T.fromVariant $ c v' = fromJust . T.fromVariant $ v +-- | Convert a 'M.Message' into a 'L.ByteString'. Although unusual, it is +-- possible for marshaling to fail -- if this occurs, an appropriate error +-- will be returned instead. + marshalMessage :: M.Message a => Endianness -> M.Serial -> a -> Either MarshalError L.ByteString marshalMessage e serial msg = runMarshal marshaler e where @@ -556,12 +560,13 @@ when (messageLength > fromIntegral C.messageMaximumLength) (E.throwError $ MessageTooLong $ fromIntegral messageLength) +-- | Read bytes from a monad until a complete message has been received. unmarshalMessage :: Monad m => (Word32 -> m L.ByteString) -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do let getBytes = E.lift . getBytes' - let fixedSig = T.mkSignature' "yyyyuuu" + let fixedSig = "yyyyuuu" fixedBytes <- getBytes 16 let messageVersion = L.index fixedBytes 3 @@ -584,7 +589,7 @@ let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6 - let headerSig = T.mkSignature' "yyyyuua(yv)" + let headerSig = "yyyyuua(yv)" fieldBytes <- getBytes fieldByteCount let headerBytes = L.append fixedBytes fieldBytes header <- unmarshal' headerSig headerBytes @@ -602,18 +607,24 @@ body <- unmarshal' bodySig bodyBytes y <- case buildReceivedMessage typeCode fields of - Right x -> return x - Left x -> E.throwError $ MissingHeaderField x + EitherM (Right x) -> return x + EitherM (Left x) -> E.throwError $ MissingHeaderField x return $ y serial flags body findBodySignature :: [M.HeaderField] -> T.Signature -findBodySignature fields = fromMaybe empty signature where - empty = T.mkSignature' "" +findBodySignature fields = fromMaybe "" signature where signature = listToMaybe [x | M.Signature x <- fields] -buildReceivedMessage :: Word8 -> [M.HeaderField] -> Either Text +newtype EitherM a b = EitherM (Either a b) + +instance Monad (EitherM a) where + return = EitherM . Right + (EitherM (Left x)) >>= _ = EitherM (Left x) + (EitherM (Right x)) >>= k = k x + +buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text (M.Serial -> (Set.Set M.Flag) -> [T.Variant] -> M.ReceivedMessage) @@ -659,10 +670,7 @@ msg = M.Unknown typeCode flags body in M.ReceivedUnknown serial sender msg -require :: Text -> [a] -> Either Text a -require _ (x:_) = Right x -require label _ = Left label - -instance E.Error Text where - strMsg = TL.pack +require :: Text -> [a] -> EitherM Text a +require _ (x:_) = return x +require label _ = EitherM $ Left label