diff --git a/d-bus.cabal b/d-bus.cabal --- a/d-bus.cabal +++ b/d-bus.cabal @@ -1,5 +1,5 @@ name: d-bus -version: 0.1.3.4 +version: 0.1.4 synopsis: Permissively licensed D-Bus client library description: This library uses modern extensions to the Haskell type system (including GADTs, DataKinds and TypeFamilies) and the diff --git a/src/DBus.hs b/src/DBus.hs --- a/src/DBus.hs +++ b/src/DBus.hs @@ -4,6 +4,7 @@ DBusConnection , ConnectionType(..) , connectClient + , connectClientWithAuth , makeServer , connectBus , MethodCallHandler @@ -104,15 +105,9 @@ , def ) where --- $types --- --- DBus has it's own type system, described here --- --- --- Types are divided into basic types, represented in this library by --- 'DBusSimpleType', and composite types, represented by 'DBusType'. Only simple --- types can be the keys in a dictionary +import qualified Data.ByteString as BS +import DBus.Auth import DBus.Introspect import DBus.MainLoop import DBus.Message @@ -129,6 +124,20 @@ -- | Ignore all incoming messages/signals ignore _ _ _ = return () --- | Connect to a message bus as a client + +-- | Connect to a message bus as a client, using the @EXTERNAL@ auth mechanism. connectClient :: ConnectionType -> IO DBusConnection connectClient bus = connectBus bus ignore ignore + +-- | Connect to a message bus as a client with a custom auth mechanism. +connectClientWithAuth :: ConnectionType -> SASL BS.ByteString -> IO DBusConnection +connectClientWithAuth bus auth = connectBusWithAuth bus auth ignore ignore + +-- $types +-- +-- DBus has it's own type system, described here +-- +-- +-- Types are divided into basic types, represented in this library by +-- 'DBusSimpleType', and composite types, represented by 'DBusType'. Only simple +-- types can be the keys in a dictionary diff --git a/src/DBus/Auth.hs b/src/DBus/Auth.hs --- a/src/DBus/Auth.hs +++ b/src/DBus/Auth.hs @@ -187,3 +187,10 @@ ok <- expectOK saslSend CMBegin return ok + +anonymous :: SASL BS.ByteString +anonymous = do + saslSend (CMAuth "ANONYMOUS" "") + ok <- expectOK + saslSend CMBegin + return ok diff --git a/src/DBus/MainLoop.hs b/src/DBus/MainLoop.hs --- a/src/DBus/MainLoop.hs +++ b/src/DBus/MainLoop.hs @@ -222,28 +222,39 @@ -- DBUS_SESSION_BUS_ADDRESS | Address String -- ^ The bus at the give addresss -type MethodCallHandler = ( DBusConnection -- ^ Connection that the call was +type MethodCallHandler = DBusConnection -- ^ Connection that the call was -- received from. Should be used to -- return the result or error - -> MessageHeader - -> [SomeDBusValue] - -> IO ()) + -> MessageHeader + -> [SomeDBusValue] + -> IO () type SignalHandler = ( DBusConnection -> MessageHeader -> [SomeDBusValue] -> IO ()) --- | General way to connect to a message bus. Takes two callback functions: --- --- * A 'MethodCallHandler' that is invoked when a method call is received. +-- | General way to connect to a message bus, see 'connectBusWithAuth'. -- --- * A SignalHandler that is invoked when a Mesage is received: +-- Uses the @EXTERNAL@ authentication mechanism. connectBus :: ConnectionType -- ^ Bus to connect to -> MethodCallHandler -- ^ Handler for incoming method calls -> SignalHandler -- ^ Handler for incoming signals -> IO DBusConnection -connectBus transport handleCalls handleSignals = do +connectBus transport = connectBusWithAuth transport external + +-- | General way to connect to a message bus, with a custom authentication +-- method. Takes two callback functions: +-- +-- * A 'MethodCallHandler' that is invoked when a method call is received. +-- +-- * A SignalHandler that is invoked when a Mesage is received: +connectBusWithAuth :: ConnectionType -- ^ Bus to connect to + -> SASL BS.ByteString -- ^ The authentication mechanism + -> MethodCallHandler -- ^ Handler for incoming method calls + -> SignalHandler -- ^ Handler for incoming signals + -> IO DBusConnection +connectBusWithAuth transport auth handleCalls handleSignals = do addressString <- case transport of Session -> getEnv "DBUS_SESSION_BUS_ADDRESS" System -> do @@ -269,7 +280,7 @@ bs <- BS.hGetLine h debugM "DBus.Sasl" $ "S: " ++ show bs return bs) - external + auth serialCounter <- newTVarIO 1 let getSerial = do s <- readTVar serialCounter @@ -320,11 +331,18 @@ debugM "DBus" $ "Done" return conn{dBusConnectionName = connName} --- | Create a simple server that exports @Objects@ and ignores all incoming signals +-- | Create a simple server that exports @Objects@ and ignores all incoming signals. +-- +-- Use the default @EXTERNAL@ authentication mechanism (see 'makeServerWithAuth'). makeServer :: ConnectionType -> Objects -> IO DBusConnection -makeServer transport objs = do - connectBus transport (objectRoot (addIntrospectable objs)) - (\_ _ _ -> return ()) +makeServer transport = makeServerWithAuth transport external + +-- | Create a simple server with a custom bus authentication mechanism that +-- exports @Objects@ and ignores all incoming signals. +makeServerWithAuth :: ConnectionType -> SASL BS.ByteString -> Objects -> IO DBusConnection +makeServerWithAuth transport auth objs = do + connectBusWithAuth transport auth (objectRoot (addIntrospectable objs)) + (\_ _ _ -> return ()) type Handler = DBusConnection -> MessageHeader -> [SomeDBusValue] -> IO () diff --git a/src/DBus/Transport.hs b/src/DBus/Transport.hs --- a/src/DBus/Transport.hs +++ b/src/DBus/Transport.hs @@ -126,9 +126,9 @@ Nothing -> AF_UNSPEC Just TCPFamilyIPv4 -> AF_INET Just TCPFamilyIPv6 -> AF_INET6 - addrInfo <- getAddrInfo (Just $ defaultHints{ addrFamily = family} ) - (Just . Text.unpack . Text.decodeUtf8 $ host) - Nothing + addrInfo <- withPort port <$> getAddrInfo (Just $ defaultHints{ addrFamily = family} ) + (Just . Text.unpack . Text.decodeUtf8 $ host) + Nothing case addrInfo of (ai : _) -> Ex.catch (Ex.bracketOnError (socket (addrFamily ai) @@ -143,6 +143,14 @@ Ex.throwIO $ CouldNotConnect "Could not connect") _ -> Ex.throwIO $ CouldNotConnect "Host not found" + where + withPort p = fmap (addrInfoWithPort $ fromIntegral p) + addrInfoWithPort p ai = ai { addrAddress = sockAddrWithPort p (addrAddress ai) } + + sockAddrWithPort p (SockAddrInet _ addr) = SockAddrInet p addr + sockAddrWithPort p (SockAddrInet6 _ info addr sid) = SockAddrInet6 p info addr sid + sockAddrWithPort _ x = x + connectTcp _ = Ex.throwIO $ CouldNotConnect "TCP method does not specify necessary data" connectUnix :: UDS -> IO Socket