{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

-- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

-- | D-Bus clients are an abstraction over the lower-level messaging
-- system. When combined with an external daemon called the \"bus\", clients
-- can perform remote procedure calls to other clients on the bus.
--
-- Clients may also listen for or emit /signals/, which are asynchronous
-- broadcast notifications.
--
-- Example: connect to the session bus, and get a list of active names.
--
-- @
--{-\# LANGUAGE OverloadedStrings \#-}
--
--import Data.List (sort)
--import DBus
--import DBus.Client
--
--main = do
--    client <- 'connectSession'
--    //
--    \-- Request a list of connected clients from the bus
--    reply <- 'call_' client ('methodCall' \"\/org\/freedesktop\/DBus\" \"org.freedesktop.DBus\" \"ListNames\")
--        { 'methodCallDestination' = Just \"org.freedesktop.DBus\"
--        }
--    //
--    \-- org.freedesktop.DBus.ListNames() returns a single value, which is
--    \-- a list of names (here represented as [String])
--    let Just names = 'fromVariant' ('methodReturnBody' reply !! 0)
--    //
--    \-- Print each name on a line, sorted so reserved names are below
--    \-- temporary names.
--    mapM_ putStrLn (sort names)
-- @
--
module DBus.Client
    (
    -- * Clients
      Client(..)
    , DBusR

    -- * Path/Interface storage
    , PathInfo(..)
    , pathInterfaces
    , pathChildren
    , pathLens
    , findPath
    , Interface(..)
    , defaultInterface

    -- * Connecting to a bus
    , connect
    , connectSystem
    , connectSession
    , connectStarter
    , disconnect

    -- * Sending method calls
    , call
    , call_
    , callNoReply
    , getProperty
    , getPropertyValue
    , setProperty
    , setPropertyValue
    , getAllProperties
    , getAllPropertiesMap
    , buildPropertiesInterface

    -- * Receiving method calls
    , export
    , unexport
    , Method(..)
    , makeMethod
    , AutoMethod
    , autoMethod
    , autoMethodWithMsg
    , Property(..)
    , autoProperty
    , readOnlyProperty
    , Reply(..)
    , throwError

    -- * Signals
    , SignalHandler
    , addMatch
    , removeMatch
    , emit
    , listen

    -- ** Match rules
    , MatchRule
    , formatMatchRule
    , matchAny
    , matchSender
    , matchDestination
    , matchPath
    , matchInterface
    , matchMember
    , matchPathNamespace

    -- * Introspection
    , buildIntrospectionObject
    , buildIntrospectionInterface
    , buildIntrospectionMethod
    , buildIntrospectionProperty
    , buildIntrospectableInterface

    -- * Name reservation
    , requestName
    , releaseName

    , RequestNameFlag
    , nameAllowReplacement
    , nameReplaceExisting
    , nameDoNotQueue

    , RequestNameReply(..)
    , ReleaseNameReply(..)

    -- * Client errors
    , ClientError
    , clientError
    , clientErrorMessage
    , clientErrorFatal

    -- * Advanced connection options
    , ClientOptions
    , clientSocketOptions
    , clientThreadRunner
    , defaultClientOptions
    , connectWith

    , dbusName
    , dbusPath

    , ErrorName
    , errorFailed
    , errorInvalidParameters
    , errorUnknownMethod
    ) where

import Control.Applicative
import Control.Arrow
import Control.Concurrent
import qualified Control.Exception
import Control.Exception (SomeException, throwIO)
import Control.Lens
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Except
import Data.Bits ((.|.))
import Data.Coerce
import Data.Foldable hiding (forM_, and)
import Data.Function
import Data.Functor ((<$>))
import Data.IORef
import Data.List (intercalate, isPrefixOf)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
import Data.String
import qualified Data.Traversable as T
import Data.Typeable (Typeable, Proxy(..))
import Data.Unique
import Data.Word (Word32)
import Prelude hiding (foldl, foldr, concat)

import DBus
import DBus.Internal.Message
import qualified DBus.Internal.Types as T
import qualified DBus.Introspection.Types as I
import qualified DBus.Introspection.Render as I
import qualified DBus.Socket
import DBus.Transport (TransportOpen, SocketTransport)

data ClientError = ClientError
    { ClientError -> String
clientErrorMessage :: String
    , ClientError -> Bool
clientErrorFatal :: Bool
    }
    deriving (ClientError -> ClientError -> Bool
(ClientError -> ClientError -> Bool)
-> (ClientError -> ClientError -> Bool) -> Eq ClientError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClientError -> ClientError -> Bool
$c/= :: ClientError -> ClientError -> Bool
== :: ClientError -> ClientError -> Bool
$c== :: ClientError -> ClientError -> Bool
Eq, Int -> ClientError -> ShowS
[ClientError] -> ShowS
ClientError -> String
(Int -> ClientError -> ShowS)
-> (ClientError -> String)
-> ([ClientError] -> ShowS)
-> Show ClientError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientError] -> ShowS
$cshowList :: [ClientError] -> ShowS
show :: ClientError -> String
$cshow :: ClientError -> String
showsPrec :: Int -> ClientError -> ShowS
$cshowsPrec :: Int -> ClientError -> ShowS
Show, Typeable)

instance Control.Exception.Exception ClientError

clientError :: String -> ClientError
clientError :: String -> ClientError
clientError String
msg = String -> Bool -> ClientError
ClientError String
msg Bool
True

-- | An active client session to a message bus. Clients may send or receive
-- method calls, and listen for or emit signals.
data Client = Client
    { Client -> Socket
clientSocket :: DBus.Socket.Socket
    , Client
-> IORef (Map Serial (MVar (Either MethodError MethodReturn)))
clientPendingCalls :: IORef (Map Serial (MVar (Either MethodError MethodReturn)))
    , Client -> IORef (Map Unique SignalHandler)
clientSignalHandlers :: IORef (Map Unique SignalHandler)
    , Client -> IORef PathInfo
clientObjects :: IORef PathInfo
    , Client -> ThreadId
clientThreadID :: ThreadId
    , Client -> [Interface]
clientInterfaces :: [Interface]
    }

type DBusR a = ReaderT Client IO a

data ClientOptions t = ClientOptions
    {
    -- | Options for the underlying socket, for advanced use cases. See
    -- the "DBus.Socket" module.
      ClientOptions t -> SocketOptions t
clientSocketOptions :: DBus.Socket.SocketOptions t

    -- | A function to run the client thread. The provided IO computation
    -- should be called repeatedly; each time it is called, it will process
    -- one incoming message.
    --
    -- The provided computation will throw a 'ClientError' if it fails to
    -- process an incoming message, or if the connection is lost.
    --
    -- The default implementation is 'forever'.
    , ClientOptions t -> IO () -> IO ()
clientThreadRunner :: IO () -> IO ()
    -- | A function to build the interfaces that should be present at every
    -- point where there is an object present. The default value builds the
    -- property and introspection interfaces.
    , ClientOptions t -> Client -> [Interface]
clientBuildInterfaces :: Client -> [Interface]
    }

type FormattedMatchRule = String
data SignalHandler =
  SignalHandler Unique FormattedMatchRule (IORef Bool) (Signal -> IO ())

data Method = Method
  { Method -> MemberName
methodName :: MemberName
  , Method -> Signature
inSignature :: Signature
  , Method -> Signature
outSignature :: Signature
  , Method -> MethodCall -> DBusR Reply
methodHandler :: MethodCall -> DBusR Reply
  }

data Property = Property
  { Property -> MemberName
propertyName :: MemberName
  , Property -> Type
propertyType :: Type
  , Property -> Maybe (IO Variant)
propertyGetter :: Maybe (IO Variant)
  , Property -> Maybe (Variant -> IO ())
propertySetter :: Maybe (Variant -> IO ())
  }

data Reply
    = ReplyReturn [Variant]
    | ReplyError ErrorName [Variant]

data Interface = Interface
  { Interface -> InterfaceName
interfaceName :: InterfaceName
  , Interface -> [Method]
interfaceMethods :: [Method]
  , Interface -> [Property]
interfaceProperties :: [Property]
  , Interface -> [Signal]
interfaceSignals :: [I.Signal]
  }

defaultInterface :: Interface
defaultInterface :: Interface
defaultInterface =
  Interface :: InterfaceName -> [Method] -> [Property] -> [Signal] -> Interface
Interface { interfaceName :: InterfaceName
interfaceName = InterfaceName
""
            , interfaceMethods :: [Method]
interfaceMethods = []
            , interfaceProperties :: [Property]
interfaceProperties = []
            , interfaceSignals :: [Signal]
interfaceSignals = []
            }

data PathInfo = PathInfo
  { PathInfo -> [Interface]
_pathInterfaces :: [Interface]
  , PathInfo -> Map String PathInfo
_pathChildren :: Map String PathInfo
  }

-- NOTE: This instance is needed to make modifyNothingHandler work, but it
-- shouldn't really be used for much else. A more complete implementation can't
-- be provided because PathInfo > Interface > Method conatain functions which
-- can't/don't have an eq instance.
instance Eq PathInfo where
  PathInfo
a == :: PathInfo -> PathInfo -> Bool
== PathInfo
b = [Interface] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PathInfo -> [Interface]
_pathInterfaces PathInfo
a) Bool -> Bool -> Bool
&&
           [Interface] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PathInfo -> [Interface]
_pathInterfaces PathInfo
b) Bool -> Bool -> Bool
&&
           Map String PathInfo -> Bool
forall k a. Map k a -> Bool
M.null (PathInfo -> Map String PathInfo
_pathChildren PathInfo
a) Bool -> Bool -> Bool
&&
           Map String PathInfo -> Bool
forall k a. Map k a -> Bool
M.null (PathInfo -> Map String PathInfo
_pathChildren PathInfo
b)

makeLenses ''PathInfo

emptyPathInfo :: PathInfo
emptyPathInfo :: PathInfo
emptyPathInfo = PathInfo :: [Interface] -> Map String PathInfo -> PathInfo
PathInfo
  { _pathInterfaces :: [Interface]
_pathInterfaces = []
  , _pathChildren :: Map String PathInfo
_pathChildren = Map String PathInfo
forall k a. Map k a
M.empty
  }

traverseElement
  :: Applicative f
  => (a -> Maybe PathInfo -> f (Maybe PathInfo))
  -> String
  -> a
  -> PathInfo
  -> f PathInfo
traverseElement :: (a -> Maybe PathInfo -> f (Maybe PathInfo))
-> String -> a -> PathInfo -> f PathInfo
traverseElement a -> Maybe PathInfo -> f (Maybe PathInfo)
nothingHandler String
pathElement =
  (Map String PathInfo -> f (Map String PathInfo))
-> PathInfo -> f PathInfo
Lens' PathInfo (Map String PathInfo)
pathChildren ((Map String PathInfo -> f (Map String PathInfo))
 -> PathInfo -> f PathInfo)
-> (a -> Map String PathInfo -> f (Map String PathInfo))
-> a
-> PathInfo
-> f PathInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map String PathInfo)
-> Lens'
     (Map String PathInfo) (Maybe (IxValue (Map String PathInfo)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at String
Index (Map String PathInfo)
pathElement ((Maybe PathInfo -> f (Maybe PathInfo))
 -> Map String PathInfo -> f (Map String PathInfo))
-> (a -> Maybe PathInfo -> f (Maybe PathInfo))
-> a
-> Map String PathInfo
-> f (Map String PathInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe PathInfo -> f (Maybe PathInfo)
nothingHandler

lookupNothingHandler
  :: (a -> Const (Data.Monoid.First PathInfo) b)
  -> Maybe a
  -> Const (Data.Monoid.First PathInfo) (Maybe b)
lookupNothingHandler :: (a -> Const (First PathInfo) b)
-> Maybe a -> Const (First PathInfo) (Maybe b)
lookupNothingHandler = (a -> Const (First PathInfo) b)
-> Maybe a -> Const (First PathInfo) (Maybe b)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just

modifyNothingHandler ::
  (PathInfo -> Identity PathInfo)
    -> Maybe PathInfo
    -> Identity (Maybe PathInfo)
modifyNothingHandler :: (PathInfo -> Identity PathInfo)
-> Maybe PathInfo -> Identity (Maybe PathInfo)
modifyNothingHandler = PathInfo -> Iso' (Maybe PathInfo) PathInfo
forall a. Eq a => a -> Iso' (Maybe a) a
non PathInfo
emptyPathInfo

pathLens ::
  Applicative f =>
  ObjectPath
  -> ((PathInfo -> f PathInfo) -> Maybe PathInfo -> f (Maybe PathInfo))
  -> (PathInfo -> f PathInfo)
  -> PathInfo
  -> f PathInfo
pathLens :: ObjectPath
-> ((PathInfo -> f PathInfo)
    -> Maybe PathInfo -> f (Maybe PathInfo))
-> (PathInfo -> f PathInfo)
-> PathInfo
-> f PathInfo
pathLens ObjectPath
path (PathInfo -> f PathInfo) -> Maybe PathInfo -> f (Maybe PathInfo)
nothingHandler =
  (((PathInfo -> f PathInfo) -> PathInfo -> f PathInfo)
 -> String -> (PathInfo -> f PathInfo) -> PathInfo -> f PathInfo)
-> ((PathInfo -> f PathInfo) -> PathInfo -> f PathInfo)
-> [String]
-> (PathInfo -> f PathInfo)
-> PathInfo
-> f PathInfo
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\(PathInfo -> f PathInfo) -> PathInfo -> f PathInfo
f String
pathElem -> (PathInfo -> f PathInfo) -> PathInfo -> f PathInfo
f ((PathInfo -> f PathInfo) -> PathInfo -> f PathInfo)
-> ((PathInfo -> f PathInfo) -> PathInfo -> f PathInfo)
-> (PathInfo -> f PathInfo)
-> PathInfo
-> f PathInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PathInfo -> f PathInfo) -> Maybe PathInfo -> f (Maybe PathInfo))
-> String -> (PathInfo -> f PathInfo) -> PathInfo -> f PathInfo
forall (f :: * -> *) a.
Applicative f =>
(a -> Maybe PathInfo -> f (Maybe PathInfo))
-> String -> a -> PathInfo -> f PathInfo
traverseElement (PathInfo -> f PathInfo) -> Maybe PathInfo -> f (Maybe PathInfo)
nothingHandler String
pathElem) (PathInfo -> f PathInfo) -> PathInfo -> f PathInfo
forall a. a -> a
id ([String] -> (PathInfo -> f PathInfo) -> PathInfo -> f PathInfo)
-> [String] -> (PathInfo -> f PathInfo) -> PathInfo -> f PathInfo
forall a b. (a -> b) -> a -> b
$
  ObjectPath -> [String]
T.pathElements ObjectPath
path

modifyPathInfoLens
  :: ObjectPath
     -> (PathInfo -> Identity PathInfo) -> PathInfo -> Identity PathInfo
modifyPathInfoLens :: ObjectPath
-> (PathInfo -> Identity PathInfo) -> PathInfo -> Identity PathInfo
modifyPathInfoLens ObjectPath
path = ObjectPath
-> ((PathInfo -> Identity PathInfo)
    -> Maybe PathInfo -> Identity (Maybe PathInfo))
-> (PathInfo -> Identity PathInfo)
-> PathInfo
-> Identity PathInfo
forall (f :: * -> *).
Applicative f =>
ObjectPath
-> ((PathInfo -> f PathInfo)
    -> Maybe PathInfo -> f (Maybe PathInfo))
-> (PathInfo -> f PathInfo)
-> PathInfo
-> f PathInfo
pathLens ObjectPath
path (PathInfo -> Identity PathInfo)
-> Maybe PathInfo -> Identity (Maybe PathInfo)
modifyNothingHandler

modifyPathInterfacesLens
  :: ObjectPath
     -> ([Interface] -> Identity [Interface])
     -> PathInfo
     -> Identity PathInfo
modifyPathInterfacesLens :: ObjectPath
-> ([Interface] -> Identity [Interface])
-> PathInfo
-> Identity PathInfo
modifyPathInterfacesLens ObjectPath
path = ObjectPath
-> (PathInfo -> Identity PathInfo) -> PathInfo -> Identity PathInfo
modifyPathInfoLens ObjectPath
path ((PathInfo -> Identity PathInfo) -> PathInfo -> Identity PathInfo)
-> (([Interface] -> Identity [Interface])
    -> PathInfo -> Identity PathInfo)
-> ([Interface] -> Identity [Interface])
-> PathInfo
-> Identity PathInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Interface] -> Identity [Interface])
-> PathInfo -> Identity PathInfo
Lens' PathInfo [Interface]
pathInterfaces

addInterface :: ObjectPath -> Interface -> PathInfo -> PathInfo
addInterface :: ObjectPath -> Interface -> PathInfo -> PathInfo
addInterface ObjectPath
path Interface
interface =
  (([Interface] -> Identity [Interface])
 -> PathInfo -> Identity PathInfo)
-> ([Interface] -> [Interface]) -> PathInfo -> PathInfo
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (ObjectPath
-> ([Interface] -> Identity [Interface])
-> PathInfo
-> Identity PathInfo
modifyPathInterfacesLens ObjectPath
path) (Interface
interface Interface -> [Interface] -> [Interface]
forall a. a -> [a] -> [a]
:)

findPath :: ObjectPath -> PathInfo -> Maybe PathInfo
findPath :: ObjectPath -> PathInfo -> Maybe PathInfo
findPath ObjectPath
path = Getting (First PathInfo) PathInfo PathInfo
-> PathInfo -> Maybe PathInfo
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (ObjectPath
-> ((PathInfo -> Const (First PathInfo) PathInfo)
    -> Maybe PathInfo -> Const (First PathInfo) (Maybe PathInfo))
-> Getting (First PathInfo) PathInfo PathInfo
forall (f :: * -> *).
Applicative f =>
ObjectPath
-> ((PathInfo -> f PathInfo)
    -> Maybe PathInfo -> f (Maybe PathInfo))
-> (PathInfo -> f PathInfo)
-> PathInfo
-> f PathInfo
pathLens ObjectPath
path (PathInfo -> Const (First PathInfo) PathInfo)
-> Maybe PathInfo -> Const (First PathInfo) (Maybe PathInfo)
forall a b.
(a -> Const (First PathInfo) b)
-> Maybe a -> Const (First PathInfo) (Maybe b)
lookupNothingHandler)

findByGetterAndName ::
  (Coercible a2 a1, Eq a1, Foldable t) =>
  t a3 -> (a3 -> a2) -> a1 -> Maybe a3
findByGetterAndName :: t a3 -> (a3 -> a2) -> a1 -> Maybe a3
findByGetterAndName t a3
options a3 -> a2
getter a1
name =
  (a3 -> Bool) -> t a3 -> Maybe a3
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((a1 -> a1 -> Bool
forall a. Eq a => a -> a -> Bool
== a1
name) (a1 -> Bool) -> (a3 -> a1) -> a3 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a2 -> a1
coerce (a2 -> a1) -> (a3 -> a2) -> a3 -> a1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a3 -> a2
getter) t a3
options

findInterface :: [Interface] -> InterfaceName -> PathInfo -> Maybe Interface
findInterface :: [Interface] -> InterfaceName -> PathInfo -> Maybe Interface
findInterface [Interface]
alwaysPresent (T.InterfaceName String
name) PathInfo
info =
  [Interface]
-> (Interface -> InterfaceName) -> String -> Maybe Interface
forall a2 a1 (t :: * -> *) a3.
(Coercible a2 a1, Eq a1, Foldable t) =>
t a3 -> (a3 -> a2) -> a1 -> Maybe a3
findByGetterAndName (PathInfo -> [Interface]
_pathInterfaces PathInfo
info [Interface] -> [Interface] -> [Interface]
forall a. [a] -> [a] -> [a]
++ [Interface]
alwaysPresent) Interface -> InterfaceName
interfaceName String
name

findMethod :: MemberName -> Interface -> Maybe Method
findMethod :: MemberName -> Interface -> Maybe Method
findMethod (T.MemberName String
name) Interface
interface =
  [Method] -> (Method -> MemberName) -> String -> Maybe Method
forall a2 a1 (t :: * -> *) a3.
(Coercible a2 a1, Eq a1, Foldable t) =>
t a3 -> (a3 -> a2) -> a1 -> Maybe a3
findByGetterAndName (Interface -> [Method]
interfaceMethods Interface
interface) Method -> MemberName
methodName String
name

findProperty :: MemberName -> Interface -> Maybe Property
findProperty :: MemberName -> Interface -> Maybe Property
findProperty (T.MemberName String
name) Interface
interface =
  [Property] -> (Property -> MemberName) -> String -> Maybe Property
forall a2 a1 (t :: * -> *) a3.
(Coercible a2 a1, Eq a1, Foldable t) =>
t a3 -> (a3 -> a2) -> a1 -> Maybe a3
findByGetterAndName (Interface -> [Property]
interfaceProperties Interface
interface) Property -> MemberName
propertyName String
name

-- | 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.
--
-- Throws a 'ClientError' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid
-- address, or if connecting to the bus failed.
connectSystem :: IO Client
connectSystem :: IO Client
connectSystem = do
    Maybe Address
env <- IO (Maybe Address)
getSystemAddress
    case Maybe Address
env of
        Maybe Address
Nothing -> ClientError -> IO Client
forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
clientError String
"connectSystem: DBUS_SYSTEM_BUS_ADDRESS is invalid.")
        Just Address
addr -> Address -> IO Client
connect Address
addr

-- | Connect to the bus specified in the environment variable
-- @DBUS_SESSION_BUS_ADDRESS@, which must be set.
--
-- Throws a 'ClientError' if @DBUS_SESSION_BUS_ADDRESS@ is unset, contains an
-- invalid address, or if connecting to the bus failed.
connectSession :: IO Client
connectSession :: IO Client
connectSession = do
    Maybe Address
env <- IO (Maybe Address)
getSessionAddress
    case Maybe Address
env of
        Maybe Address
Nothing -> ClientError -> IO Client
forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
clientError String
"connectSession: DBUS_SESSION_BUS_ADDRESS is invalid.")
        Just Address
addr -> Address -> IO Client
connect Address
addr

-- | Connect to the bus specified in the environment variable
-- @DBUS_STARTER_ADDRESS@, which must be set.
--
-- Throws a 'ClientError' if @DBUS_STARTER_ADDRESS@ is unset, contains an
-- invalid address, or if connecting to the bus failed.
connectStarter :: IO Client
connectStarter :: IO Client
connectStarter = do
    Maybe Address
env <- IO (Maybe Address)
getStarterAddress
    case Maybe Address
env of
        Maybe Address
Nothing -> ClientError -> IO Client
forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
clientError String
"connectStarter: DBUS_STARTER_ADDRESS is missing or invalid.")
        Just Address
addr -> Address -> IO Client
connect Address
addr

-- | Connect to the bus at the specified address.
--
-- Throws a 'ClientError' on failure.
connect :: Address -> IO Client
connect :: Address -> IO Client
connect = ClientOptions SocketTransport -> Address -> IO Client
forall t.
TransportOpen t =>
ClientOptions t -> Address -> IO Client
connectWith ClientOptions SocketTransport
defaultClientOptions

-- | Connect to the bus at the specified address, with the given connection
-- options. Most users should use 'connect' instead.
--
-- Throws a 'ClientError' on failure.
connectWith :: TransportOpen t => ClientOptions t -> Address -> IO Client
connectWith :: ClientOptions t -> Address -> IO Client
connectWith ClientOptions t
opts Address
addr = do
    Socket
sock <- SocketOptions t -> Address -> IO Socket
forall t.
TransportOpen t =>
SocketOptions t -> Address -> IO Socket
DBus.Socket.openWith (ClientOptions t -> SocketOptions t
forall t. ClientOptions t -> SocketOptions t
clientSocketOptions ClientOptions t
opts) Address
addr

    IORef (Map Serial (MVar (Either MethodError MethodReturn)))
pendingCalls <- Map Serial (MVar (Either MethodError MethodReturn))
-> IO (IORef (Map Serial (MVar (Either MethodError MethodReturn))))
forall a. a -> IO (IORef a)
newIORef Map Serial (MVar (Either MethodError MethodReturn))
forall k a. Map k a
M.empty
    IORef (Map Unique SignalHandler)
signalHandlers <- Map Unique SignalHandler -> IO (IORef (Map Unique SignalHandler))
forall a. a -> IO (IORef a)
newIORef Map Unique SignalHandler
forall k a. Map k a
M.empty
    IORef PathInfo
objects <- PathInfo -> IO (IORef PathInfo)
forall a. a -> IO (IORef a)
newIORef (PathInfo -> IO (IORef PathInfo))
-> PathInfo -> IO (IORef PathInfo)
forall a b. (a -> b) -> a -> b
$ [Interface] -> Map String PathInfo -> PathInfo
PathInfo [] Map String PathInfo
forall k a. Map k a
M.empty

    let threadRunner :: IO () -> IO ()
threadRunner = ClientOptions t -> IO () -> IO ()
forall t. ClientOptions t -> IO () -> IO ()
clientThreadRunner ClientOptions t
opts

    MVar Client
clientMVar <- IO (MVar Client)
forall a. IO (MVar a)
newEmptyMVar
    ThreadId
threadID <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
        Client
client <- MVar Client -> IO Client
forall a. MVar a -> IO a
readMVar MVar Client
clientMVar
        IO () -> IO ()
threadRunner (Client -> IO ()
mainLoop Client
client)

    let client :: Client
client = Client :: Socket
-> IORef (Map Serial (MVar (Either MethodError MethodReturn)))
-> IORef (Map Unique SignalHandler)
-> IORef PathInfo
-> ThreadId
-> [Interface]
-> Client
Client
            { clientSocket :: Socket
clientSocket = Socket
sock
            , clientPendingCalls :: IORef (Map Serial (MVar (Either MethodError MethodReturn)))
clientPendingCalls = IORef (Map Serial (MVar (Either MethodError MethodReturn)))
pendingCalls
            , clientSignalHandlers :: IORef (Map Unique SignalHandler)
clientSignalHandlers = IORef (Map Unique SignalHandler)
signalHandlers
            , clientObjects :: IORef PathInfo
clientObjects = IORef PathInfo
objects
            , clientThreadID :: ThreadId
clientThreadID = ThreadId
threadID
            , clientInterfaces :: [Interface]
clientInterfaces = ClientOptions t -> Client -> [Interface]
forall t. ClientOptions t -> Client -> [Interface]
clientBuildInterfaces ClientOptions t
opts Client
client
            }
    MVar Client -> Client -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Client
clientMVar Client
client

    Client -> MethodCall -> IO ()
callNoReply Client
client (ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCall ObjectPath
dbusPath InterfaceName
dbusInterface MemberName
"Hello")
        { methodCallDestination :: Maybe BusName
methodCallDestination = BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
dbusName
        }

    Client -> IO Client
forall (m :: * -> *) a. Monad m => a -> m a
return Client
client

makeErrorReply :: ErrorName -> Reply
makeErrorReply :: ErrorName -> Reply
makeErrorReply ErrorName
errorName = ErrorName -> [Variant] -> Reply
ReplyError ErrorName
errorName []

buildPropertiesInterface :: Client -> Interface
buildPropertiesInterface :: Client -> Interface
buildPropertiesInterface Client
client =
  let alwaysPresent :: [Interface]
alwaysPresent = Client -> [Interface]
clientInterfaces Client
client
      getPropertyObjF :: String
-> String -> ObjectPath -> PathInfo -> Either ErrorName Property
getPropertyObjF String
propertyInterfaceName String
memberName ObjectPath
path PathInfo
info =
        [Interface]
-> PathInfo
-> ObjectPath
-> Maybe InterfaceName
-> Either ErrorName Interface
findInterfaceAtPath [Interface]
alwaysPresent PathInfo
info ObjectPath
path
        (InterfaceName -> Maybe InterfaceName
forall a. a -> Maybe a
Just (InterfaceName -> Maybe InterfaceName)
-> InterfaceName -> Maybe InterfaceName
forall a b. (a -> b) -> a -> b
$ String -> InterfaceName
forall a. IsString a => String -> a
fromString String
propertyInterfaceName) Either ErrorName Interface
-> (Interface -> Either ErrorName Property)
-> Either ErrorName Property
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        (ErrorName -> Maybe Property -> Either ErrorName Property
forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorUnknownMethod (Maybe Property -> Either ErrorName Property)
-> (Interface -> Maybe Property)
-> Interface
-> Either ErrorName Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemberName -> Interface -> Maybe Property
findProperty (String -> MemberName
forall a. IsString a => String -> a
fromString String
memberName))
      getPropertyObj :: String -> String -> ObjectPath -> IO (Either ErrorName Property)
getPropertyObj String
propertyInterfaceName String
memberName ObjectPath
path =
        String
-> String -> ObjectPath -> PathInfo -> Either ErrorName Property
getPropertyObjF String
propertyInterfaceName String
memberName ObjectPath
path (PathInfo -> Either ErrorName Property)
-> IO PathInfo -> IO (Either ErrorName Property)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        IORef PathInfo -> IO PathInfo
forall a. IORef a -> IO a
readIORef (Client -> IORef PathInfo
clientObjects Client
client)
      callGet :: MethodCall -> String -> String -> IO (Either Reply Variant)
callGet MethodCall { methodCallPath :: MethodCall -> ObjectPath
methodCallPath = ObjectPath
path }
              String
propertyInterfaceName String
memberName =
        (ErrorName -> Reply)
-> Either ErrorName Variant -> Either Reply Variant
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ErrorName -> Reply
makeErrorReply (Either ErrorName Variant -> Either Reply Variant)
-> IO (Either ErrorName Variant) -> IO (Either Reply Variant)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ExceptT ErrorName IO Variant -> IO (Either ErrorName Variant)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (do
          Property
property <- IO (Either ErrorName Property) -> ExceptT ErrorName IO Property
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrorName Property) -> ExceptT ErrorName IO Property)
-> IO (Either ErrorName Property) -> ExceptT ErrorName IO Property
forall a b. (a -> b) -> a -> b
$ String -> String -> ObjectPath -> IO (Either ErrorName Property)
getPropertyObj String
propertyInterfaceName
                      String
memberName ObjectPath
path
          IO (Either ErrorName Variant) -> ExceptT ErrorName IO Variant
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrorName Variant) -> ExceptT ErrorName IO Variant)
-> IO (Either ErrorName Variant) -> ExceptT ErrorName IO Variant
forall a b. (a -> b) -> a -> b
$ Either ErrorName (IO Variant) -> IO (Either ErrorName Variant)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (Either ErrorName (IO Variant) -> IO (Either ErrorName Variant))
-> Either ErrorName (IO Variant) -> IO (Either ErrorName Variant)
forall a b. (a -> b) -> a -> b
$ ErrorName -> Maybe (IO Variant) -> Either ErrorName (IO Variant)
forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorNotAuthorized (Maybe (IO Variant) -> Either ErrorName (IO Variant))
-> Maybe (IO Variant) -> Either ErrorName (IO Variant)
forall a b. (a -> b) -> a -> b
$
                  Property -> Maybe (IO Variant)
propertyGetter Property
property)
      callSet :: MethodCall -> String -> String -> Variant -> IO (Either Reply ())
callSet MethodCall { methodCallPath :: MethodCall -> ObjectPath
methodCallPath = ObjectPath
path }
              String
propertyInterfaceName String
memberName Variant
value =
        (ErrorName -> Reply) -> Either ErrorName () -> Either Reply ()
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ErrorName -> Reply
makeErrorReply (Either ErrorName () -> Either Reply ())
-> IO (Either ErrorName ()) -> IO (Either Reply ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ExceptT ErrorName IO () -> IO (Either ErrorName ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (do
          Property
property <- IO (Either ErrorName Property) -> ExceptT ErrorName IO Property
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrorName Property) -> ExceptT ErrorName IO Property)
-> IO (Either ErrorName Property) -> ExceptT ErrorName IO Property
forall a b. (a -> b) -> a -> b
$ String -> String -> ObjectPath -> IO (Either ErrorName Property)
getPropertyObj String
propertyInterfaceName String
memberName ObjectPath
path
          Variant -> IO ()
setter <- IO (Either ErrorName (Variant -> IO ()))
-> ExceptT ErrorName IO (Variant -> IO ())
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrorName (Variant -> IO ()))
 -> ExceptT ErrorName IO (Variant -> IO ()))
-> IO (Either ErrorName (Variant -> IO ()))
-> ExceptT ErrorName IO (Variant -> IO ())
forall a b. (a -> b) -> a -> b
$ Either ErrorName (Variant -> IO ())
-> IO (Either ErrorName (Variant -> IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorName (Variant -> IO ())
 -> IO (Either ErrorName (Variant -> IO ())))
-> Either ErrorName (Variant -> IO ())
-> IO (Either ErrorName (Variant -> IO ()))
forall a b. (a -> b) -> a -> b
$ ErrorName
-> Maybe (Variant -> IO ()) -> Either ErrorName (Variant -> IO ())
forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorNotAuthorized (Maybe (Variant -> IO ()) -> Either ErrorName (Variant -> IO ()))
-> Maybe (Variant -> IO ()) -> Either ErrorName (Variant -> IO ())
forall a b. (a -> b) -> a -> b
$
                    Property -> Maybe (Variant -> IO ())
propertySetter Property
property
          IO () -> ExceptT ErrorName IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT ErrorName IO ())
-> IO () -> ExceptT ErrorName IO ()
forall a b. (a -> b) -> a -> b
$ Variant -> IO ()
setter Variant
value)
      callGetAll :: MethodCall -> String -> IO (Either Reply (Map String Variant))
callGetAll MethodCall { methodCallPath :: MethodCall -> ObjectPath
methodCallPath = ObjectPath
path } String
propertyInterfaceName =
        (ErrorName -> Reply)
-> Either ErrorName (Map String Variant)
-> Either Reply (Map String Variant)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ErrorName -> Reply
makeErrorReply (Either ErrorName (Map String Variant)
 -> Either Reply (Map String Variant))
-> IO (Either ErrorName (Map String Variant))
-> IO (Either Reply (Map String Variant))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ExceptT ErrorName IO (Map String Variant)
-> IO (Either ErrorName (Map String Variant))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (do
          PathInfo
info <- IO PathInfo -> ExceptT ErrorName IO PathInfo
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO PathInfo -> ExceptT ErrorName IO PathInfo)
-> IO PathInfo -> ExceptT ErrorName IO PathInfo
forall a b. (a -> b) -> a -> b
$ IORef PathInfo -> IO PathInfo
forall a. IORef a -> IO a
readIORef (Client -> IORef PathInfo
clientObjects Client
client)
          Interface
propertyInterface <-
            IO (Either ErrorName Interface) -> ExceptT ErrorName IO Interface
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrorName Interface) -> ExceptT ErrorName IO Interface)
-> IO (Either ErrorName Interface)
-> ExceptT ErrorName IO Interface
forall a b. (a -> b) -> a -> b
$ Either ErrorName Interface -> IO (Either ErrorName Interface)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorName Interface -> IO (Either ErrorName Interface))
-> Either ErrorName Interface -> IO (Either ErrorName Interface)
forall a b. (a -> b) -> a -> b
$ [Interface]
-> PathInfo
-> ObjectPath
-> Maybe InterfaceName
-> Either ErrorName Interface
findInterfaceAtPath [Interface]
alwaysPresent PathInfo
info ObjectPath
path (Maybe InterfaceName -> Either ErrorName Interface)
-> Maybe InterfaceName -> Either ErrorName Interface
forall a b. (a -> b) -> a -> b
$
                    InterfaceName -> Maybe InterfaceName
forall a. a -> Maybe a
Just (InterfaceName -> Maybe InterfaceName)
-> InterfaceName -> Maybe InterfaceName
forall a b. (a -> b) -> a -> b
$ String -> InterfaceName
forall a. IsString a => String -> a
fromString String
propertyInterfaceName
          let properties :: [Property]
properties = Interface -> [Property]
interfaceProperties Interface
propertyInterface
              nameGetters :: [IO (String, Variant)]
              nameGetters :: [IO (String, Variant)]
nameGetters = [ (MemberName -> String
coerce MemberName
name,) (Variant -> (String, Variant))
-> IO Variant -> IO (String, Variant)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Variant
getter |
                              Property { propertyName :: Property -> MemberName
propertyName = MemberName
name
                                       , propertyGetter :: Property -> Maybe (IO Variant)
propertyGetter = Just IO Variant
getter
                                       } <- [Property]
properties]
          IO (Map String Variant)
-> ExceptT ErrorName IO (Map String Variant)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Map String Variant)
 -> ExceptT ErrorName IO (Map String Variant))
-> IO (Map String Variant)
-> ExceptT ErrorName IO (Map String Variant)
forall a b. (a -> b) -> a -> b
$ [(String, Variant)] -> Map String Variant
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, Variant)] -> Map String Variant)
-> IO [(String, Variant)] -> IO (Map String Variant)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO (String, Variant)] -> IO [(String, Variant)]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA [IO (String, Variant)]
nameGetters)
  in
    Interface
defaultInterface
    { interfaceName :: InterfaceName
interfaceName = InterfaceName
propertiesInterfaceName
    , interfaceMethods :: [Method]
interfaceMethods =
      [ MemberName
-> (MethodCall -> String -> String -> IO (Either Reply Variant))
-> Method
forall fn.
AutoMethod fn =>
MemberName -> (MethodCall -> fn) -> Method
autoMethodWithMsg MemberName
"Get" MethodCall -> String -> String -> IO (Either Reply Variant)
callGet
      , MemberName
-> (MethodCall -> String -> IO (Either Reply (Map String Variant)))
-> Method
forall fn.
AutoMethod fn =>
MemberName -> (MethodCall -> fn) -> Method
autoMethodWithMsg MemberName
"GetAll" MethodCall -> String -> IO (Either Reply (Map String Variant))
callGetAll
      , MemberName
-> (MethodCall
    -> String -> String -> Variant -> IO (Either Reply ()))
-> Method
forall fn.
AutoMethod fn =>
MemberName -> (MethodCall -> fn) -> Method
autoMethodWithMsg MemberName
"Set" MethodCall -> String -> String -> Variant -> IO (Either Reply ())
callSet
      ]
    , interfaceSignals :: [Signal]
interfaceSignals =
      [ Signal :: MemberName -> [SignalArg] -> Signal
I.Signal
        { signalName :: MemberName
I.signalName = MemberName
"PropertiesChanged"
        , signalArgs :: [SignalArg]
I.signalArgs =
          [ SignalArg :: String -> Type -> SignalArg
I.SignalArg
            { signalArgName :: String
I.signalArgName = String
"interface_name"
            , signalArgType :: Type
I.signalArgType = Type
T.TypeString
            }
          , SignalArg :: String -> Type -> SignalArg
I.SignalArg
            { signalArgName :: String
I.signalArgName = String
"changed_properties"
            , signalArgType :: Type
I.signalArgType = Type -> Type -> Type
T.TypeDictionary Type
T.TypeString Type
T.TypeVariant
            }
          , SignalArg :: String -> Type -> SignalArg
I.SignalArg
            { signalArgName :: String
I.signalArgName = String
"invalidated_properties"
            , signalArgType :: Type
I.signalArgType = Type -> Type
T.TypeArray Type
T.TypeString
            }
          ]
        }
      ]
    }

buildIntrospectableInterface :: Client -> Interface
buildIntrospectableInterface :: Client -> Interface
buildIntrospectableInterface Client
client =
  Interface
defaultInterface
  { interfaceName :: InterfaceName
interfaceName = InterfaceName
introspectableInterfaceName
  , interfaceMethods :: [Method]
interfaceMethods = [ MemberName -> (MethodCall -> IO (Either Reply String)) -> Method
forall fn.
AutoMethod fn =>
MemberName -> (MethodCall -> fn) -> Method
autoMethodWithMsg MemberName
"Introspect" MethodCall -> IO (Either Reply String)
callIntrospect ]
  } where
  callIntrospect :: MethodCall -> IO (Either Reply String)
callIntrospect MethodCall { methodCallPath :: MethodCall -> ObjectPath
methodCallPath = ObjectPath
path } = do
    PathInfo
info <- IORef PathInfo -> IO PathInfo
forall a. IORef a -> IO a
readIORef (Client -> IORef PathInfo
clientObjects Client
client)
    Either Reply String -> IO (Either Reply String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Reply String -> IO (Either Reply String))
-> Either Reply String -> IO (Either Reply String)
forall a b. (a -> b) -> a -> b
$ (ErrorName -> Reply)
-> Either ErrorName String -> Either Reply String
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ErrorName -> Reply
makeErrorReply (Either ErrorName String -> Either Reply String)
-> Either ErrorName String -> Either Reply String
forall a b. (a -> b) -> a -> b
$ do
      PathInfo
targetInfo <- ErrorName -> Maybe PathInfo -> Either ErrorName PathInfo
forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorUnknownObject (Maybe PathInfo -> Either ErrorName PathInfo)
-> Maybe PathInfo -> Either ErrorName PathInfo
forall a b. (a -> b) -> a -> b
$ ObjectPath -> PathInfo -> Maybe PathInfo
findPath ObjectPath
path PathInfo
info
      -- TODO: We should probably return a better error here:
      ErrorName -> Maybe String -> Either ErrorName String
forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorUnknownObject (Maybe String -> Either ErrorName String)
-> Maybe String -> Either ErrorName String
forall a b. (a -> b) -> a -> b
$ Object -> Maybe String
I.formatXML (Object -> Maybe String) -> Object -> Maybe String
forall a b. (a -> b) -> a -> b
$
                    [Interface] -> PathInfo -> [String] -> Object
buildIntrospectionObject [Interface]
defaultInterfaces
                    PathInfo
targetInfo (ObjectPath -> [String]
T.pathElements ObjectPath
path)
  defaultInterfaces :: [Interface]
defaultInterfaces = (Interface -> Interface) -> [Interface] -> [Interface]
forall a b. (a -> b) -> [a] -> [b]
map Interface -> Interface
buildIntrospectionInterface ([Interface] -> [Interface]) -> [Interface] -> [Interface]
forall a b. (a -> b) -> a -> b
$ Client -> [Interface]
clientInterfaces Client
client

-- | Default client options. Uses the built-in Socket-based transport, which
-- supports the @tcp:@ and @unix:@ methods.
defaultClientOptions :: ClientOptions SocketTransport
defaultClientOptions :: ClientOptions SocketTransport
defaultClientOptions = ClientOptions :: forall t.
SocketOptions t
-> (IO () -> IO ()) -> (Client -> [Interface]) -> ClientOptions t
ClientOptions
    { clientSocketOptions :: SocketOptions SocketTransport
clientSocketOptions = SocketOptions SocketTransport
DBus.Socket.defaultSocketOptions
    , clientThreadRunner :: IO () -> IO ()
clientThreadRunner = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever
    , clientBuildInterfaces :: Client -> [Interface]
clientBuildInterfaces =
      \Client
client -> ((Client -> Interface) -> Interface)
-> [Client -> Interface] -> [Interface]
forall a b. (a -> b) -> [a] -> [b]
map ((Client -> Interface) -> Client -> Interface
forall a b. (a -> b) -> a -> b
$ Client
client) [Client -> Interface
buildPropertiesInterface, Client -> Interface
buildIntrospectableInterface]
    }

-- | Stop a 'Client''s callback thread and close its underlying socket.
disconnect :: Client -> IO ()
disconnect :: Client -> IO ()
disconnect Client
client = do
    ThreadId -> IO ()
killThread (Client -> ThreadId
clientThreadID Client
client)
    Client -> IO ()
disconnect' Client
client

disconnect' :: Client -> IO ()
disconnect' :: Client -> IO ()
disconnect' Client
client = do
    Map Serial (MVar (Either MethodError MethodReturn))
pendingCalls <- IORef (Map Serial (MVar (Either MethodError MethodReturn)))
-> (Map Serial (MVar (Either MethodError MethodReturn))
    -> (Map Serial (MVar (Either MethodError MethodReturn)),
        Map Serial (MVar (Either MethodError MethodReturn))))
-> IO (Map Serial (MVar (Either MethodError MethodReturn)))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (Client
-> IORef (Map Serial (MVar (Either MethodError MethodReturn)))
clientPendingCalls Client
client) (\Map Serial (MVar (Either MethodError MethodReturn))
p -> (Map Serial (MVar (Either MethodError MethodReturn))
forall k a. Map k a
M.empty, Map Serial (MVar (Either MethodError MethodReturn))
p))
    [(Serial, MVar (Either MethodError MethodReturn))]
-> ((Serial, MVar (Either MethodError MethodReturn)) -> IO ())
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Serial (MVar (Either MethodError MethodReturn))
-> [(Serial, MVar (Either MethodError MethodReturn))]
forall k a. Map k a -> [(k, a)]
M.toList Map Serial (MVar (Either MethodError MethodReturn))
pendingCalls) (((Serial, MVar (Either MethodError MethodReturn)) -> IO ())
 -> IO ())
-> ((Serial, MVar (Either MethodError MethodReturn)) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Serial
k, MVar (Either MethodError MethodReturn)
v) ->
        MVar (Either MethodError MethodReturn)
-> Either MethodError MethodReturn -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either MethodError MethodReturn)
v (MethodError -> Either MethodError MethodReturn
forall a b. a -> Either a b
Left (Serial -> ErrorName -> MethodError
methodError Serial
k ErrorName
errorDisconnected))

    IORef (Map Unique SignalHandler)
-> Map Unique SignalHandler -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef (Client -> IORef (Map Unique SignalHandler)
clientSignalHandlers Client
client) Map Unique SignalHandler
forall k a. Map k a
M.empty

    IORef PathInfo -> PathInfo -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef (Client -> IORef PathInfo
clientObjects Client
client) PathInfo
emptyPathInfo

    Socket -> IO ()
DBus.Socket.close (Client -> Socket
clientSocket Client
client)

mainLoop :: Client -> IO ()
mainLoop :: Client -> IO ()
mainLoop Client
client = do
    let sock :: Socket
sock = Client -> Socket
clientSocket Client
client

    Either SocketError ReceivedMessage
received <- IO ReceivedMessage -> IO (Either SocketError ReceivedMessage)
forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try (Socket -> IO ReceivedMessage
DBus.Socket.receive Socket
sock)
    ReceivedMessage
msg <- case Either SocketError ReceivedMessage
received of
        Left SocketError
err -> do
            Client -> IO ()
disconnect' Client
client
            ClientError -> IO ReceivedMessage
forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
clientError (SocketError -> String
DBus.Socket.socketErrorMessage SocketError
err))
        Right ReceivedMessage
msg -> ReceivedMessage -> IO ReceivedMessage
forall (m :: * -> *) a. Monad m => a -> m a
return ReceivedMessage
msg

    Client -> ReceivedMessage -> IO ()
dispatch Client
client ReceivedMessage
msg


-- Dispatch

dispatch :: Client -> ReceivedMessage -> IO ()
dispatch :: Client -> ReceivedMessage -> IO ()
dispatch Client
client = ReceivedMessage -> IO ()
go where
    go :: ReceivedMessage -> IO ()
go (ReceivedMethodReturn Serial
_ MethodReturn
msg) = Serial -> Either MethodError MethodReturn -> IO ()
dispatchReply (MethodReturn -> Serial
methodReturnSerial MethodReturn
msg) (MethodReturn -> Either MethodError MethodReturn
forall a b. b -> Either a b
Right MethodReturn
msg)
    go (ReceivedMethodError Serial
_ MethodError
msg) = Serial -> Either MethodError MethodReturn -> IO ()
dispatchReply (MethodError -> Serial
methodErrorSerial MethodError
msg) (MethodError -> Either MethodError MethodReturn
forall a b. a -> Either a b
Left MethodError
msg)
    go (ReceivedSignal Serial
_ Signal
msg) = do
        Map Unique SignalHandler
handlers <- IORef (Map Unique SignalHandler) -> IO (Map Unique SignalHandler)
forall a. IORef a -> IO a
readIORef (Client -> IORef (Map Unique SignalHandler)
clientSignalHandlers Client
client)
        [(Unique, SignalHandler)]
-> ((Unique, SignalHandler) -> IO ThreadId) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Unique SignalHandler -> [(Unique, SignalHandler)]
forall k a. Map k a -> [(k, a)]
M.toAscList Map Unique SignalHandler
handlers) (\(Unique
_, SignalHandler Unique
_ String
_ IORef Bool
_ Signal -> IO ()
h) -> IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Signal -> IO ()
h Signal
msg)
    go (ReceivedMethodCall Serial
serial MethodCall
msg) = do
        PathInfo
pathInfo <- IORef PathInfo -> IO PathInfo
forall a. IORef a -> IO a
readIORef (Client -> IORef PathInfo
clientObjects Client
client)
        let sender :: Maybe BusName
sender = MethodCall -> Maybe BusName
methodCallSender MethodCall
msg
            sendResult :: Reply -> IO ()
sendResult Reply
reply =
              case Reply
reply of
                ReplyReturn [Variant]
vs -> Client -> MethodReturn -> (Serial -> IO ()) -> IO ()
forall msg a.
Message msg =>
Client -> msg -> (Serial -> IO a) -> IO a
send_ Client
client (Serial -> MethodReturn
methodReturn Serial
serial)
                                  { methodReturnDestination :: Maybe BusName
methodReturnDestination = Maybe BusName
sender
                                  , methodReturnBody :: [Variant]
methodReturnBody = [Variant]
vs
                                  } (\Serial
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                ReplyError ErrorName
name [Variant]
vs -> Client -> MethodError -> (Serial -> IO ()) -> IO ()
forall msg a.
Message msg =>
Client -> msg -> (Serial -> IO a) -> IO a
send_ Client
client (Serial -> ErrorName -> MethodError
methodError Serial
serial ErrorName
name)
                                      { methodErrorDestination :: Maybe BusName
methodErrorDestination = Maybe BusName
sender
                                      , methodErrorBody :: [Variant]
methodErrorBody = [Variant]
vs
                                      } (\Serial
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ case [Interface] -> PathInfo -> MethodCall -> Either ErrorName Method
findMethodForCall (Client -> [Interface]
clientInterfaces Client
client) PathInfo
pathInfo MethodCall
msg of
            Right Method { methodHandler :: Method -> MethodCall -> DBusR Reply
methodHandler = MethodCall -> DBusR Reply
handler } ->
              DBusR Reply -> Client -> IO Reply
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (MethodCall -> DBusR Reply
handler MethodCall
msg) Client
client IO Reply -> (Reply -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Reply -> IO ()
sendResult
            Left ErrorName
errName -> Client -> MethodError -> (Serial -> IO ()) -> IO ()
forall msg a.
Message msg =>
Client -> msg -> (Serial -> IO a) -> IO a
send_ Client
client
                (Serial -> ErrorName -> MethodError
methodError Serial
serial ErrorName
errName) { methodErrorDestination :: Maybe BusName
methodErrorDestination = Maybe BusName
sender }
                (\Serial
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go ReceivedMessage
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    dispatchReply :: Serial -> Either MethodError MethodReturn -> IO ()
dispatchReply Serial
serial Either MethodError MethodReturn
result = do
        Maybe (MVar (Either MethodError MethodReturn))
pending <- IORef (Map Serial (MVar (Either MethodError MethodReturn)))
-> (Map Serial (MVar (Either MethodError MethodReturn))
    -> (Map Serial (MVar (Either MethodError MethodReturn)),
        Maybe (MVar (Either MethodError MethodReturn))))
-> IO (Maybe (MVar (Either MethodError MethodReturn)))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef
            (Client
-> IORef (Map Serial (MVar (Either MethodError MethodReturn)))
clientPendingCalls Client
client)
            (\Map Serial (MVar (Either MethodError MethodReturn))
p -> case Serial
-> Map Serial (MVar (Either MethodError MethodReturn))
-> Maybe (MVar (Either MethodError MethodReturn))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Serial
serial Map Serial (MVar (Either MethodError MethodReturn))
p of
                Maybe (MVar (Either MethodError MethodReturn))
Nothing -> (Map Serial (MVar (Either MethodError MethodReturn))
p, Maybe (MVar (Either MethodError MethodReturn))
forall a. Maybe a
Nothing)
                Just MVar (Either MethodError MethodReturn)
mvar -> (Serial
-> Map Serial (MVar (Either MethodError MethodReturn))
-> Map Serial (MVar (Either MethodError MethodReturn))
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Serial
serial Map Serial (MVar (Either MethodError MethodReturn))
p, MVar (Either MethodError MethodReturn)
-> Maybe (MVar (Either MethodError MethodReturn))
forall a. a -> Maybe a
Just MVar (Either MethodError MethodReturn)
mvar))
        case Maybe (MVar (Either MethodError MethodReturn))
pending of
            Just MVar (Either MethodError MethodReturn)
mvar -> MVar (Either MethodError MethodReturn)
-> Either MethodError MethodReturn -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either MethodError MethodReturn)
mvar Either MethodError MethodReturn
result
            Maybe (MVar (Either MethodError MethodReturn))
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

findInterfaceAtPath
  :: [Interface]
  -> PathInfo
  -> ObjectPath
  -> Maybe InterfaceName
  -> Either ErrorName Interface
findInterfaceAtPath :: [Interface]
-> PathInfo
-> ObjectPath
-> Maybe InterfaceName
-> Either ErrorName Interface
findInterfaceAtPath [Interface]
defaultInterfaces PathInfo
info ObjectPath
path Maybe InterfaceName
name =
  ErrorName -> Maybe PathInfo -> Either ErrorName PathInfo
forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorUnknownObject (ObjectPath -> PathInfo -> Maybe PathInfo
findPath ObjectPath
path PathInfo
info) Either ErrorName PathInfo
-> (PathInfo -> Either ErrorName Interface)
-> Either ErrorName Interface
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  (ErrorName -> Maybe Interface -> Either ErrorName Interface
forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorUnknownInterface (Maybe Interface -> Either ErrorName Interface)
-> (PathInfo -> Maybe Interface)
-> PathInfo
-> Either ErrorName Interface
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                 (PathInfo -> Maybe Interface)
-> (InterfaceName -> PathInfo -> Maybe Interface)
-> Maybe InterfaceName
-> PathInfo
-> Maybe Interface
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Interface -> PathInfo -> Maybe Interface
forall a b. a -> b -> a
const Maybe Interface
forall a. Maybe a
Nothing) ([Interface] -> InterfaceName -> PathInfo -> Maybe Interface
findInterface [Interface]
defaultInterfaces) Maybe InterfaceName
name)

findMethodForCall ::
  [Interface] -> PathInfo -> MethodCall -> Either ErrorName Method
findMethodForCall :: [Interface] -> PathInfo -> MethodCall -> Either ErrorName Method
findMethodForCall [Interface]
defaultInterfaces PathInfo
info
                  MethodCall { methodCallInterface :: MethodCall -> Maybe InterfaceName
methodCallInterface = Maybe InterfaceName
interface
                             , methodCallMember :: MethodCall -> MemberName
methodCallMember = MemberName
member
                             , methodCallPath :: MethodCall -> ObjectPath
methodCallPath = ObjectPath
path
                             } =
  [Interface]
-> PathInfo
-> ObjectPath
-> Maybe InterfaceName
-> Either ErrorName Interface
findInterfaceAtPath [Interface]
defaultInterfaces PathInfo
info ObjectPath
path Maybe InterfaceName
interface Either ErrorName Interface
-> (Interface -> Either ErrorName Method)
-> Either ErrorName Method
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  (ErrorName -> Maybe Method -> Either ErrorName Method
forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorUnknownMethod (Maybe Method -> Either ErrorName Method)
-> (Interface -> Maybe Method)
-> Interface
-> Either ErrorName Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemberName -> Interface -> Maybe Method
findMethod MemberName
member)


-- Request name

data RequestNameFlag
    = AllowReplacement
    | ReplaceExisting
    | DoNotQueue
    deriving (RequestNameFlag -> RequestNameFlag -> Bool
(RequestNameFlag -> RequestNameFlag -> Bool)
-> (RequestNameFlag -> RequestNameFlag -> Bool)
-> Eq RequestNameFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RequestNameFlag -> RequestNameFlag -> Bool
$c/= :: RequestNameFlag -> RequestNameFlag -> Bool
== :: RequestNameFlag -> RequestNameFlag -> Bool
$c== :: RequestNameFlag -> RequestNameFlag -> Bool
Eq, Int -> RequestNameFlag -> ShowS
[RequestNameFlag] -> ShowS
RequestNameFlag -> String
(Int -> RequestNameFlag -> ShowS)
-> (RequestNameFlag -> String)
-> ([RequestNameFlag] -> ShowS)
-> Show RequestNameFlag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestNameFlag] -> ShowS
$cshowList :: [RequestNameFlag] -> ShowS
show :: RequestNameFlag -> String
$cshow :: RequestNameFlag -> String
showsPrec :: Int -> RequestNameFlag -> ShowS
$cshowsPrec :: Int -> RequestNameFlag -> ShowS
Show)

-- | Allow this client's reservation to be replaced, if another client
-- requests it with the 'nameReplaceExisting' flag.
--
-- If this client's reservation is replaced, this client will be added to the
-- wait queue unless the request also included the 'nameDoNotQueue' flag.
nameAllowReplacement :: RequestNameFlag
nameAllowReplacement :: RequestNameFlag
nameAllowReplacement = RequestNameFlag
AllowReplacement

-- | If the name being requested is already reserved, attempt to replace it.
-- This only works if the current owner provided the 'nameAllowReplacement'
-- flag.
nameReplaceExisting :: RequestNameFlag
nameReplaceExisting :: RequestNameFlag
nameReplaceExisting = RequestNameFlag
ReplaceExisting

-- | If the name is already in use, do not add this client to the queue, just
-- return an error.
nameDoNotQueue :: RequestNameFlag
nameDoNotQueue :: RequestNameFlag
nameDoNotQueue = RequestNameFlag
DoNotQueue

data RequestNameReply
    -- | This client is now the primary owner of the requested name.
    = NamePrimaryOwner

    -- | The name was already reserved by another client, and replacement
    -- was either not attempted or not successful.
    | NameInQueue

    -- | The name was already reserved by another client, 'DoNotQueue'
    -- was set, and replacement was either not attempted or not
    -- successful.
    | NameExists

    -- | This client is already the primary owner of the requested name.
    | NameAlreadyOwner

    -- | Not exported; exists to generate a compiler warning if users
    -- case on the reply and forget to include a default case.
    | UnknownRequestNameReply Word32
    deriving (RequestNameReply -> RequestNameReply -> Bool
(RequestNameReply -> RequestNameReply -> Bool)
-> (RequestNameReply -> RequestNameReply -> Bool)
-> Eq RequestNameReply
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RequestNameReply -> RequestNameReply -> Bool
$c/= :: RequestNameReply -> RequestNameReply -> Bool
== :: RequestNameReply -> RequestNameReply -> Bool
$c== :: RequestNameReply -> RequestNameReply -> Bool
Eq, Int -> RequestNameReply -> ShowS
[RequestNameReply] -> ShowS
RequestNameReply -> String
(Int -> RequestNameReply -> ShowS)
-> (RequestNameReply -> String)
-> ([RequestNameReply] -> ShowS)
-> Show RequestNameReply
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestNameReply] -> ShowS
$cshowList :: [RequestNameReply] -> ShowS
show :: RequestNameReply -> String
$cshow :: RequestNameReply -> String
showsPrec :: Int -> RequestNameReply -> ShowS
$cshowsPrec :: Int -> RequestNameReply -> ShowS
Show)

data ReleaseNameReply
    -- | This client has released the provided name.
    = NameReleased

    -- | The provided name is not assigned to any client on the bus.
    | NameNonExistent

    -- | The provided name is not assigned to this client.
    | NameNotOwner

    -- | Not exported; exists to generate a compiler warning if users
    -- case on the reply and forget to include a default case.
    | UnknownReleaseNameReply Word32
    deriving (ReleaseNameReply -> ReleaseNameReply -> Bool
(ReleaseNameReply -> ReleaseNameReply -> Bool)
-> (ReleaseNameReply -> ReleaseNameReply -> Bool)
-> Eq ReleaseNameReply
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReleaseNameReply -> ReleaseNameReply -> Bool
$c/= :: ReleaseNameReply -> ReleaseNameReply -> Bool
== :: ReleaseNameReply -> ReleaseNameReply -> Bool
$c== :: ReleaseNameReply -> ReleaseNameReply -> Bool
Eq, Int -> ReleaseNameReply -> ShowS
[ReleaseNameReply] -> ShowS
ReleaseNameReply -> String
(Int -> ReleaseNameReply -> ShowS)
-> (ReleaseNameReply -> String)
-> ([ReleaseNameReply] -> ShowS)
-> Show ReleaseNameReply
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReleaseNameReply] -> ShowS
$cshowList :: [ReleaseNameReply] -> ShowS
show :: ReleaseNameReply -> String
$cshow :: ReleaseNameReply -> String
showsPrec :: Int -> ReleaseNameReply -> ShowS
$cshowsPrec :: Int -> ReleaseNameReply -> ShowS
Show)

encodeFlags :: [RequestNameFlag] -> Word32
encodeFlags :: [RequestNameFlag] -> Word32
encodeFlags = (RequestNameFlag -> Word32 -> Word32)
-> Word32 -> [RequestNameFlag] -> Word32
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
(.|.) (Word32 -> Word32 -> Word32)
-> (RequestNameFlag -> Word32)
-> RequestNameFlag
-> Word32
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestNameFlag -> Word32
forall p. Num p => RequestNameFlag -> p
flagValue) Word32
0  where
    flagValue :: RequestNameFlag -> p
flagValue RequestNameFlag
AllowReplacement = p
0x1
    flagValue RequestNameFlag
ReplaceExisting  = p
0x2
    flagValue RequestNameFlag
DoNotQueue       = p
0x4

-- | Asks the message bus to assign the given name to this client. The bus
-- maintains a queue of possible owners, where the head of the queue is the
-- current (\"primary\") owner.
--
-- There are several uses for name reservation:
--
-- * Clients which export methods reserve a name so users and applications
--   can send them messages. For example, the GNOME Keyring reserves the name
--   @\"org.gnome.keyring\"@ on the user's session bus, and NetworkManager
--   reserves @\"org.freedesktop.NetworkManager\"@ on the system bus.
--
-- * When there are multiple implementations of a particular service, the
--   service standard will ususally include a generic bus name for the
--   service. This allows other clients to avoid depending on any particular
--   implementation's name. For example, both the GNOME Keyring and KDE
--   KWallet services request the @\"org.freedesktop.secrets\"@ name on the
--   user's session bus.
--
-- * A process with \"single instance\" behavior can use name assignment to
--   check whether the instance is already running, and invoke some method
--   on it (e.g. opening a new window).
--
-- Throws a 'ClientError' if the call failed.
requestName :: Client -> BusName -> [RequestNameFlag] -> IO RequestNameReply
requestName :: Client -> BusName -> [RequestNameFlag] -> IO RequestNameReply
requestName Client
client BusName
name [RequestNameFlag]
flags = do
    MethodReturn
reply <- Client -> MethodCall -> IO MethodReturn
call_ Client
client (ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCall ObjectPath
dbusPath InterfaceName
dbusInterface MemberName
"RequestName")
        { methodCallDestination :: Maybe BusName
methodCallDestination = BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
dbusName
        , methodCallBody :: [Variant]
methodCallBody = [BusName -> Variant
forall a. IsVariant a => a -> Variant
toVariant BusName
name, Word32 -> Variant
forall a. IsVariant a => a -> Variant
toVariant ([RequestNameFlag] -> Word32
encodeFlags [RequestNameFlag]
flags)]
        }
    Variant
var <- case [Variant] -> Maybe Variant
forall a. [a] -> Maybe a
listToMaybe (MethodReturn -> [Variant]
methodReturnBody MethodReturn
reply) of
        Just Variant
x -> Variant -> IO Variant
forall (m :: * -> *) a. Monad m => a -> m a
return Variant
x
        Maybe Variant
Nothing -> ClientError -> IO Variant
forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
clientError String
"requestName: received empty response")
            { clientErrorFatal :: Bool
clientErrorFatal = Bool
False
            }
    Word32
code <- case Variant -> Maybe Word32
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
var of
        Just Word32
x -> Word32 -> IO Word32
forall (m :: * -> *) a. Monad m => a -> m a
return Word32
x
        Maybe Word32
Nothing -> ClientError -> IO Word32
forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
clientError (String
"requestName: received invalid response code " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Variant -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Variant
var String
""))
            { clientErrorFatal :: Bool
clientErrorFatal = Bool
False
            }
    RequestNameReply -> IO RequestNameReply
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestNameReply -> IO RequestNameReply)
-> RequestNameReply -> IO RequestNameReply
forall a b. (a -> b) -> a -> b
$ case Word32
code :: Word32 of
        Word32
1 -> RequestNameReply
NamePrimaryOwner
        Word32
2 -> RequestNameReply
NameInQueue
        Word32
3 -> RequestNameReply
NameExists
        Word32
4 -> RequestNameReply
NameAlreadyOwner
        Word32
_ -> Word32 -> RequestNameReply
UnknownRequestNameReply Word32
code

-- | Release a name that this client previously requested. See 'requestName'
-- for an explanation of name reservation.
--
-- Throws a 'ClientError' if the call failed.
releaseName :: Client -> BusName -> IO ReleaseNameReply
releaseName :: Client -> BusName -> IO ReleaseNameReply
releaseName Client
client BusName
name = do
    MethodReturn
reply <- Client -> MethodCall -> IO MethodReturn
call_ Client
client (ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCall ObjectPath
dbusPath InterfaceName
dbusInterface MemberName
"ReleaseName")
        { methodCallDestination :: Maybe BusName
methodCallDestination = BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
dbusName
        , methodCallBody :: [Variant]
methodCallBody = [BusName -> Variant
forall a. IsVariant a => a -> Variant
toVariant BusName
name]
        }
    Variant
var <- case [Variant] -> Maybe Variant
forall a. [a] -> Maybe a
listToMaybe (MethodReturn -> [Variant]
methodReturnBody MethodReturn
reply) of
        Just Variant
x -> Variant -> IO Variant
forall (m :: * -> *) a. Monad m => a -> m a
return Variant
x
        Maybe Variant
Nothing -> ClientError -> IO Variant
forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
clientError String
"releaseName: received empty response")
            { clientErrorFatal :: Bool
clientErrorFatal = Bool
False
            }
    Word32
code <- case Variant -> Maybe Word32
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
var of
        Just Word32
x -> Word32 -> IO Word32
forall (m :: * -> *) a. Monad m => a -> m a
return Word32
x
        Maybe Word32
Nothing -> ClientError -> IO Word32
forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
clientError (String
"releaseName: received invalid response code " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Variant -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Variant
var String
""))
            { clientErrorFatal :: Bool
clientErrorFatal = Bool
False
            }
    ReleaseNameReply -> IO ReleaseNameReply
forall (m :: * -> *) a. Monad m => a -> m a
return (ReleaseNameReply -> IO ReleaseNameReply)
-> ReleaseNameReply -> IO ReleaseNameReply
forall a b. (a -> b) -> a -> b
$ case Word32
code :: Word32 of
        Word32
1 -> ReleaseNameReply
NameReleased
        Word32
2 -> ReleaseNameReply
NameNonExistent
        Word32
3 -> ReleaseNameReply
NameNotOwner
        Word32
_ -> Word32 -> ReleaseNameReply
UnknownReleaseNameReply Word32
code


-- Requests

send_ :: Message msg => Client -> msg -> (Serial -> IO a) -> IO a
send_ :: Client -> msg -> (Serial -> IO a) -> IO a
send_ Client
client msg
msg Serial -> IO a
io = do
    Either SocketError a
result <- IO a -> IO (Either SocketError a)
forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try (Socket -> msg -> (Serial -> IO a) -> IO a
forall msg a.
Message msg =>
Socket -> msg -> (Serial -> IO a) -> IO a
DBus.Socket.send (Client -> Socket
clientSocket Client
client) msg
msg Serial -> IO a
io)
    case Either SocketError a
result of
        Right a
x -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        Left SocketError
err -> ClientError -> IO a
forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
clientError (SocketError -> String
DBus.Socket.socketErrorMessage SocketError
err))
            { clientErrorFatal :: Bool
clientErrorFatal = SocketError -> Bool
DBus.Socket.socketErrorFatal SocketError
err
            }

-- | Send a method call to the bus, and wait for the response.
--
-- Throws a 'ClientError' if the method call couldn't be sent, or if the reply
-- couldn't be parsed.
call :: Client -> MethodCall -> IO (Either MethodError MethodReturn)
call :: Client -> MethodCall -> IO (Either MethodError MethodReturn)
call Client
client MethodCall
msg = do
    -- If ReplyExpected is False, this function would block indefinitely
    -- if the remote side honors it.
    let safeMsg :: MethodCall
safeMsg = MethodCall
msg
            { methodCallReplyExpected :: Bool
methodCallReplyExpected = Bool
True
            }
    MVar (Either MethodError MethodReturn)
mvar <- IO (MVar (Either MethodError MethodReturn))
forall a. IO (MVar a)
newEmptyMVar
    let ref :: IORef (Map Serial (MVar (Either MethodError MethodReturn)))
ref = Client
-> IORef (Map Serial (MVar (Either MethodError MethodReturn)))
clientPendingCalls Client
client
    Serial
serial <- Client -> MethodCall -> (Serial -> IO Serial) -> IO Serial
forall msg a.
Message msg =>
Client -> msg -> (Serial -> IO a) -> IO a
send_ Client
client MethodCall
safeMsg (\Serial
serial -> IORef (Map Serial (MVar (Either MethodError MethodReturn)))
-> (Map Serial (MVar (Either MethodError MethodReturn))
    -> (Map Serial (MVar (Either MethodError MethodReturn)), Serial))
-> IO Serial
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Map Serial (MVar (Either MethodError MethodReturn)))
ref (\Map Serial (MVar (Either MethodError MethodReturn))
p -> (Serial
-> MVar (Either MethodError MethodReturn)
-> Map Serial (MVar (Either MethodError MethodReturn))
-> Map Serial (MVar (Either MethodError MethodReturn))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Serial
serial MVar (Either MethodError MethodReturn)
mvar Map Serial (MVar (Either MethodError MethodReturn))
p, Serial
serial)))

    -- At this point, we wait for the reply to arrive. The user may cancel
    -- a pending call by sending this thread an exception via something
    -- like 'timeout'; in that case, we want to clean up the pending call.
    IO (Either MethodError MethodReturn)
-> IO () -> IO (Either MethodError MethodReturn)
forall a b. IO a -> IO b -> IO a
Control.Exception.onException
        (MVar (Either MethodError MethodReturn)
-> IO (Either MethodError MethodReturn)
forall a. MVar a -> IO a
takeMVar MVar (Either MethodError MethodReturn)
mvar)
        (IORef (Map Serial (MVar (Either MethodError MethodReturn)))
-> (Map Serial (MVar (Either MethodError MethodReturn))
    -> Map Serial (MVar (Either MethodError MethodReturn)))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef (Map Serial (MVar (Either MethodError MethodReturn)))
ref (Serial
-> Map Serial (MVar (Either MethodError MethodReturn))
-> Map Serial (MVar (Either MethodError MethodReturn))
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Serial
serial))

-- | Send a method call to the bus, and wait for the response.
--
-- Unsets the 'noReplyExpected' message flag before sending.
--
-- Throws a 'ClientError' if the method call couldn't sent, if the reply
-- couldn't be parsed, or if the reply was a 'MethodError'.
call_ :: Client -> MethodCall -> IO MethodReturn
call_ :: Client -> MethodCall -> IO MethodReturn
call_ Client
client MethodCall
msg = do
    Either MethodError MethodReturn
result <- Client -> MethodCall -> IO (Either MethodError MethodReturn)
call Client
client MethodCall
msg
    case Either MethodError MethodReturn
result of
        Left MethodError
err -> ClientError -> IO MethodReturn
forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
clientError (String
"Call failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MethodError -> String
methodErrorMessage MethodError
err))
            { clientErrorFatal :: Bool
clientErrorFatal = MethodError -> ErrorName
methodErrorName MethodError
err ErrorName -> ErrorName -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorName
errorDisconnected
            }
        Right MethodReturn
ret -> MethodReturn -> IO MethodReturn
forall (m :: * -> *) a. Monad m => a -> m a
return MethodReturn
ret

-- | Send a method call to the bus, and do not wait for a response.
--
-- Sets the 'noReplyExpected' message flag before sending.
--
-- Throws a 'ClientError' if the method call couldn't be sent.
callNoReply :: Client -> MethodCall -> IO ()
callNoReply :: Client -> MethodCall -> IO ()
callNoReply Client
client MethodCall
msg = do
    -- Ensure that noReplyExpected is always set.
    let safeMsg :: MethodCall
safeMsg = MethodCall
msg
            { methodCallReplyExpected :: Bool
methodCallReplyExpected = Bool
False
            }
    Client -> MethodCall -> (Serial -> IO ()) -> IO ()
forall msg a.
Message msg =>
Client -> msg -> (Serial -> IO a) -> IO a
send_ Client
client MethodCall
safeMsg (\Serial
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

orDefaultInterface :: Maybe InterfaceName -> InterfaceName
orDefaultInterface :: Maybe InterfaceName -> InterfaceName
orDefaultInterface = InterfaceName -> Maybe InterfaceName -> InterfaceName
forall a. a -> Maybe a -> a
fromMaybe InterfaceName
"org.freedesktop.DBus"

dummyMethodError :: MethodError
dummyMethodError :: MethodError
dummyMethodError =
  MethodError :: ErrorName
-> Serial
-> Maybe BusName
-> Maybe BusName
-> [Variant]
-> MethodError
MethodError { methodErrorName :: ErrorName
methodErrorName = String -> ErrorName
errorName_ String
"org.ClientTypeMismatch"
              , methodErrorSerial :: Serial
methodErrorSerial = Word32 -> Serial
T.Serial Word32
1
              , methodErrorSender :: Maybe BusName
methodErrorSender = Maybe BusName
forall a. Maybe a
Nothing
              , methodErrorDestination :: Maybe BusName
methodErrorDestination = Maybe BusName
forall a. Maybe a
Nothing
              , methodErrorBody :: [Variant]
methodErrorBody = []
              }

unpackVariant :: IsValue a => MethodCall -> Variant -> Either MethodError a
unpackVariant :: MethodCall -> Variant -> Either MethodError a
unpackVariant MethodCall { methodCallSender :: MethodCall -> Maybe BusName
methodCallSender = Maybe BusName
sender } Variant
variant =
  MethodError -> Maybe a -> Either MethodError a
forall b a. b -> Maybe a -> Either b a
maybeToEither MethodError
dummyMethodError { methodErrorBody :: [Variant]
methodErrorBody =
                                     [Variant
variant, String -> Variant
forall a. IsVariant a => a -> Variant
toVariant (String -> Variant) -> String -> Variant
forall a b. (a -> b) -> a -> b
$ Type -> String
forall a. Show a => a -> String
show (Type -> String) -> Type -> String
forall a b. (a -> b) -> a -> b
$ Variant -> Type
variantType Variant
variant]
                                 , methodErrorSender :: Maybe BusName
methodErrorSender = Maybe BusName
sender
                                 } (Maybe a -> Either MethodError a)
-> Maybe a -> Either MethodError a
forall a b. (a -> b) -> a -> b
$ Variant -> Maybe a
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
variant

-- | Retrieve a property using the method call parameters that were provided.
--
-- Throws a 'ClientError' if the property request couldn't be sent.
getProperty :: Client -> MethodCall -> IO (Either MethodError Variant)
getProperty :: Client -> MethodCall -> IO (Either MethodError Variant)
getProperty Client
client
            msg :: MethodCall
msg@MethodCall { methodCallInterface :: MethodCall -> Maybe InterfaceName
methodCallInterface = Maybe InterfaceName
interface
                           , methodCallMember :: MethodCall -> MemberName
methodCallMember = MemberName
member
                           } =
  (Either MethodError MethodReturn
-> (MethodReturn -> Either MethodError Variant)
-> Either MethodError Variant
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (MethodCall -> Variant -> Either MethodError Variant
forall a.
IsValue a =>
MethodCall -> Variant -> Either MethodError a
unpackVariant MethodCall
msg (Variant -> Either MethodError Variant)
-> (MethodReturn -> Variant)
-> MethodReturn
-> Either MethodError Variant
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Variant] -> Variant
forall a. [a] -> a
head ([Variant] -> Variant)
-> (MethodReturn -> [Variant]) -> MethodReturn -> Variant
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MethodReturn -> [Variant]
methodReturnBody)) (Either MethodError MethodReturn -> Either MethodError Variant)
-> IO (Either MethodError MethodReturn)
-> IO (Either MethodError Variant)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Client -> MethodCall -> IO (Either MethodError MethodReturn)
call Client
client MethodCall
msg { methodCallInterface :: Maybe InterfaceName
methodCallInterface = InterfaceName -> Maybe InterfaceName
forall a. a -> Maybe a
Just InterfaceName
propertiesInterfaceName
                    , methodCallMember :: MemberName
methodCallMember = MemberName
getMemberName
                    , methodCallBody :: [Variant]
methodCallBody = [ String -> Variant
forall a. IsVariant a => a -> Variant
toVariant (InterfaceName -> String
coerce (Maybe InterfaceName -> InterfaceName
orDefaultInterface Maybe InterfaceName
interface) :: String)
                                       , String -> Variant
forall a. IsVariant a => a -> Variant
toVariant (MemberName -> String
coerce MemberName
member :: String)
                                       ]
                    }

getPropertyValue :: IsValue a => Client -> MethodCall -> IO (Either MethodError a)
getPropertyValue :: Client -> MethodCall -> IO (Either MethodError a)
getPropertyValue Client
client MethodCall
msg =
  (Either MethodError Variant
-> (Variant -> Either MethodError a) -> Either MethodError a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MethodCall -> Variant -> Either MethodError a
forall a.
IsValue a =>
MethodCall -> Variant -> Either MethodError a
unpackVariant MethodCall
msg) (Either MethodError Variant -> Either MethodError a)
-> IO (Either MethodError Variant) -> IO (Either MethodError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Client -> MethodCall -> IO (Either MethodError Variant)
getProperty Client
client MethodCall
msg

setProperty :: Client -> MethodCall -> Variant -> IO (Either MethodError MethodReturn)
setProperty :: Client
-> MethodCall -> Variant -> IO (Either MethodError MethodReturn)
setProperty Client
client
            msg :: MethodCall
msg@MethodCall { methodCallInterface :: MethodCall -> Maybe InterfaceName
methodCallInterface = Maybe InterfaceName
interface
                           , methodCallMember :: MethodCall -> MemberName
methodCallMember = MemberName
member
                           } Variant
value =
  Client -> MethodCall -> IO (Either MethodError MethodReturn)
call Client
client MethodCall
msg { methodCallInterface :: Maybe InterfaceName
methodCallInterface = InterfaceName -> Maybe InterfaceName
forall a. a -> Maybe a
Just InterfaceName
propertiesInterfaceName
                  , methodCallMember :: MemberName
methodCallMember = MemberName
setMemberName
                  , methodCallBody :: [Variant]
methodCallBody =
                    [ String -> Variant
forall a. IsVariant a => a -> Variant
toVariant (InterfaceName -> String
coerce (Maybe InterfaceName -> InterfaceName
orDefaultInterface Maybe InterfaceName
interface) :: String)
                    , String -> Variant
forall a. IsVariant a => a -> Variant
toVariant (MemberName -> String
coerce MemberName
member :: String)
                    , Variant
value
                    ]
                  }

setPropertyValue
  :: IsValue a
  => Client -> MethodCall -> a -> IO (Maybe MethodError)
setPropertyValue :: Client -> MethodCall -> a -> IO (Maybe MethodError)
setPropertyValue Client
client MethodCall
msg a
v = Either MethodError MethodReturn -> Maybe MethodError
forall a b. Either a b -> Maybe a
eitherToMaybe (Either MethodError MethodReturn -> Maybe MethodError)
-> IO (Either MethodError MethodReturn) -> IO (Maybe MethodError)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Client
-> MethodCall -> Variant -> IO (Either MethodError MethodReturn)
setProperty Client
client MethodCall
msg (a -> Variant
forall a. IsVariant a => a -> Variant
toVariant a
v)
  where eitherToMaybe :: Either a b -> Maybe a
eitherToMaybe (Left a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
        eitherToMaybe (Right b
_) = Maybe a
forall a. Maybe a
Nothing

getAllProperties :: Client -> MethodCall -> IO (Either MethodError MethodReturn)
getAllProperties :: Client -> MethodCall -> IO (Either MethodError MethodReturn)
getAllProperties Client
client
               msg :: MethodCall
msg@MethodCall { methodCallInterface :: MethodCall -> Maybe InterfaceName
methodCallInterface = Maybe InterfaceName
interface } =
  Client -> MethodCall -> IO (Either MethodError MethodReturn)
call Client
client MethodCall
msg { methodCallInterface :: Maybe InterfaceName
methodCallInterface = InterfaceName -> Maybe InterfaceName
forall a. a -> Maybe a
Just InterfaceName
propertiesInterfaceName
                  , methodCallMember :: MemberName
methodCallMember = MemberName
getAllMemberName
                  , methodCallBody :: [Variant]
methodCallBody = [String -> Variant
forall a. IsVariant a => a -> Variant
toVariant (InterfaceName -> String
coerce (Maybe InterfaceName -> InterfaceName
orDefaultInterface Maybe InterfaceName
interface) :: String)]
                  }

getAllPropertiesMap :: Client -> MethodCall -> IO (Either MethodError (M.Map String Variant))
getAllPropertiesMap :: Client
-> MethodCall -> IO (Either MethodError (Map String Variant))
getAllPropertiesMap Client
client MethodCall
msg =
  -- NOTE: We should never hit the error case here really unless the client
  -- returns the wrong type of object.
  (Either MethodError MethodReturn
-> (MethodReturn -> Either MethodError (Map String Variant))
-> Either MethodError (Map String Variant)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (MethodError
-> Maybe (Map String Variant)
-> Either MethodError (Map String Variant)
forall b a. b -> Maybe a -> Either b a
maybeToEither MethodError
dummyMethodError (Maybe (Map String Variant)
 -> Either MethodError (Map String Variant))
-> (MethodReturn -> Maybe (Map String Variant))
-> MethodReturn
-> Either MethodError (Map String Variant)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variant -> Maybe (Map String Variant)
forall a. IsVariant a => Variant -> Maybe a
fromVariant (Variant -> Maybe (Map String Variant))
-> (MethodReturn -> Variant)
-> MethodReturn
-> Maybe (Map String Variant)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Variant] -> Variant
forall a. [a] -> a
head ([Variant] -> Variant)
-> (MethodReturn -> [Variant]) -> MethodReturn -> Variant
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MethodReturn -> [Variant]
methodReturnBody))
  (Either MethodError MethodReturn
 -> Either MethodError (Map String Variant))
-> IO (Either MethodError MethodReturn)
-> IO (Either MethodError (Map String Variant))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Client -> MethodCall -> IO (Either MethodError MethodReturn)
getAllProperties Client
client MethodCall
msg


-- Signals

-- | Request that the bus forward signals matching the given rule to this
-- client, and process them in a callback.
--
-- A received signal might be processed by more than one callback at a time.
-- Callbacks each run in their own thread.
--
-- The returned 'SignalHandler' can be passed to 'removeMatch'
-- to stop handling this signal.
--
-- Throws a 'ClientError' if the match rule couldn't be added to the bus.
addMatch :: Client -> MatchRule -> (Signal -> IO ()) -> IO SignalHandler
addMatch :: Client -> MatchRule -> (Signal -> IO ()) -> IO SignalHandler
addMatch Client
client MatchRule
rule Signal -> IO ()
io = do
    let formatted :: String
formatted = case MatchRule -> String
formatMatchRule MatchRule
rule of
            String
"" -> String
"type='signal'"
            String
x -> String
"type='signal'," String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x

    Unique
handlerId <- IO Unique
newUnique
    IORef Bool
registered <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
    let handler :: SignalHandler
handler = Unique
-> String -> IORef Bool -> (Signal -> IO ()) -> SignalHandler
SignalHandler Unique
handlerId String
formatted IORef Bool
registered (\Signal
msg -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MatchRule -> Signal -> Bool
checkMatchRule MatchRule
rule Signal
msg) (Signal -> IO ()
io Signal
msg))

    IORef (Map Unique SignalHandler)
-> (Map Unique SignalHandler -> (Map Unique SignalHandler, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (Client -> IORef (Map Unique SignalHandler)
clientSignalHandlers Client
client) (\Map Unique SignalHandler
hs -> (Unique
-> SignalHandler
-> Map Unique SignalHandler
-> Map Unique SignalHandler
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Unique
handlerId SignalHandler
handler Map Unique SignalHandler
hs, ()))
    MethodReturn
_ <- Client -> MethodCall -> IO MethodReturn
call_ Client
client (ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCall ObjectPath
dbusPath InterfaceName
dbusInterface MemberName
"AddMatch")
        { methodCallDestination :: Maybe BusName
methodCallDestination = BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
dbusName
        , methodCallBody :: [Variant]
methodCallBody = [String -> Variant
forall a. IsVariant a => a -> Variant
toVariant String
formatted]
        }
    SignalHandler -> IO SignalHandler
forall (m :: * -> *) a. Monad m => a -> m a
return SignalHandler
handler

-- | Request that the bus stop forwarding signals for the given handler.
--
-- Throws a 'ClientError' if the match rule couldn't be removed from the bus.
removeMatch :: Client -> SignalHandler -> IO ()
removeMatch :: Client -> SignalHandler -> IO ()
removeMatch Client
client (SignalHandler Unique
handlerId String
formatted IORef Bool
registered Signal -> IO ()
_) = do
    Bool
shouldUnregister <- IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Bool
registered (\Bool
wasRegistered -> (Bool
False, Bool
wasRegistered))
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldUnregister (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        IORef (Map Unique SignalHandler)
-> (Map Unique SignalHandler -> (Map Unique SignalHandler, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (Client -> IORef (Map Unique SignalHandler)
clientSignalHandlers Client
client) (\Map Unique SignalHandler
hs -> (Unique -> Map Unique SignalHandler -> Map Unique SignalHandler
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Unique
handlerId Map Unique SignalHandler
hs, ()))
        MethodReturn
_ <- Client -> MethodCall -> IO MethodReturn
call_ Client
client (ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCall ObjectPath
dbusPath InterfaceName
dbusInterface MemberName
"RemoveMatch")
            { methodCallDestination :: Maybe BusName
methodCallDestination = BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
dbusName
            , methodCallBody :: [Variant]
methodCallBody = [String -> Variant
forall a. IsVariant a => a -> Variant
toVariant String
formatted]
            }
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Equivalent to 'addMatch', but does not return the added 'SignalHandler'.
listen :: Client -> MatchRule -> (Signal -> IO ()) -> IO ()
listen :: Client -> MatchRule -> (Signal -> IO ()) -> IO ()
listen Client
client MatchRule
rule Signal -> IO ()
io = IO SignalHandler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandler -> IO ()) -> IO SignalHandler -> IO ()
forall a b. (a -> b) -> a -> b
$ Client -> MatchRule -> (Signal -> IO ()) -> IO SignalHandler
addMatch Client
client MatchRule
rule Signal -> IO ()
io
{-# DEPRECATED listen "Prefer DBus.Client.addMatch in new code." #-}

-- | Emit the signal on the bus.
--
-- Throws a 'ClientError' if the signal message couldn't be sent.
emit :: Client -> Signal -> IO ()
emit :: Client -> Signal -> IO ()
emit Client
client Signal
msg = Client -> Signal -> (Serial -> IO ()) -> IO ()
forall msg a.
Message msg =>
Client -> msg -> (Serial -> IO a) -> IO a
send_ Client
client Signal
msg (\Serial
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | A match rule describes which signals a particular callback is interested
-- in. Use 'matchAny' to construct match rules.
--
-- Example: a match rule which matches signals sent by the root object.
--
-- @
--matchFromRoot :: MatchRule
--matchFromRoot = 'matchAny' { 'matchPath' = Just \"/\" }
-- @
data MatchRule = MatchRule
    {
    -- | If set, only receives signals sent from the given bus name.
    --
    -- The standard D-Bus implementation from <http://dbus.freedesktop.org/>
    -- almost always sets signal senders to the unique name of the sending
    -- client. If 'matchSender' is a requested name like
    -- @\"com.example.Foo\"@, it will not match any signals.
    --
    -- The exception is for signals sent by the bus itself, which always
    -- have a sender of @\"org.freedesktop.DBus\"@.
      MatchRule -> Maybe BusName
matchSender :: Maybe BusName

    -- | If set, only receives signals sent to the given bus name.
    , MatchRule -> Maybe BusName
matchDestination :: Maybe BusName

    -- | If set, only receives signals sent with the given path.
    , MatchRule -> Maybe ObjectPath
matchPath  :: Maybe ObjectPath

    -- | If set, only receives signals sent with the given interface name.
    , MatchRule -> Maybe InterfaceName
matchInterface :: Maybe InterfaceName

    -- | If set, only receives signals sent with the given member name.
    , MatchRule -> Maybe MemberName
matchMember :: Maybe MemberName

    -- | If set, only receives signals sent with the given path or any of
    -- its children.
    , MatchRule -> Maybe ObjectPath
matchPathNamespace :: Maybe ObjectPath
    }

instance Show MatchRule where
    showsPrec :: Int -> MatchRule -> ShowS
showsPrec Int
d MatchRule
rule = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (String -> ShowS
showString String
"MatchRule " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Show a => a -> ShowS
shows (MatchRule -> String
formatMatchRule MatchRule
rule))

-- | Convert a match rule into the textual format accepted by the bus.
formatMatchRule :: MatchRule -> String
formatMatchRule :: MatchRule -> String
formatMatchRule MatchRule
rule = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
predicates where
    predicates :: [String]
predicates = [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes
        [ String
-> (MatchRule -> Maybe BusName)
-> (BusName -> String)
-> Maybe String
forall a.
String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String
f String
"sender" MatchRule -> Maybe BusName
matchSender BusName -> String
formatBusName
        , String
-> (MatchRule -> Maybe BusName)
-> (BusName -> String)
-> Maybe String
forall a.
String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String
f String
"destination" MatchRule -> Maybe BusName
matchDestination BusName -> String
formatBusName
        , String
-> (MatchRule -> Maybe ObjectPath)
-> (ObjectPath -> String)
-> Maybe String
forall a.
String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String
f String
"path" MatchRule -> Maybe ObjectPath
matchPath ObjectPath -> String
formatObjectPath
        , String
-> (MatchRule -> Maybe InterfaceName)
-> (InterfaceName -> String)
-> Maybe String
forall a.
String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String
f String
"interface" MatchRule -> Maybe InterfaceName
matchInterface InterfaceName -> String
formatInterfaceName
        , String
-> (MatchRule -> Maybe MemberName)
-> (MemberName -> String)
-> Maybe String
forall a.
String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String
f String
"member" MatchRule -> Maybe MemberName
matchMember MemberName -> String
formatMemberName
        , String
-> (MatchRule -> Maybe ObjectPath)
-> (ObjectPath -> String)
-> Maybe String
forall a.
String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String
f String
"path_namespace" MatchRule -> Maybe ObjectPath
matchPathNamespace ObjectPath -> String
formatObjectPath
        ]

    f :: String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String
    f :: String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String
f String
key MatchRule -> Maybe a
get a -> String
text = do
        String
val <- (a -> String) -> Maybe a -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> String
text (MatchRule -> Maybe a
get MatchRule
rule)
        String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
key, String
"='", String
val, String
"'"])

-- | Match any signal.
matchAny :: MatchRule
matchAny :: MatchRule
matchAny = Maybe BusName
-> Maybe BusName
-> Maybe ObjectPath
-> Maybe InterfaceName
-> Maybe MemberName
-> Maybe ObjectPath
-> MatchRule
MatchRule Maybe BusName
forall a. Maybe a
Nothing Maybe BusName
forall a. Maybe a
Nothing Maybe ObjectPath
forall a. Maybe a
Nothing Maybe InterfaceName
forall a. Maybe a
Nothing Maybe MemberName
forall a. Maybe a
Nothing Maybe ObjectPath
forall a. Maybe a
Nothing

checkMatchRule :: MatchRule -> Signal -> Bool
checkMatchRule :: MatchRule -> Signal -> Bool
checkMatchRule MatchRule
rule Signal
msg = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
    [ Bool -> (BusName -> Bool) -> Maybe BusName -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\BusName
x -> Signal -> Maybe BusName
signalSender Signal
msg Maybe BusName -> Maybe BusName -> Bool
forall a. Eq a => a -> a -> Bool
== BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
x) (MatchRule -> Maybe BusName
matchSender MatchRule
rule)
    , Bool -> (BusName -> Bool) -> Maybe BusName -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\BusName
x -> Signal -> Maybe BusName
signalDestination Signal
msg Maybe BusName -> Maybe BusName -> Bool
forall a. Eq a => a -> a -> Bool
== BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
x) (MatchRule -> Maybe BusName
matchDestination MatchRule
rule)
    , Bool -> (ObjectPath -> Bool) -> Maybe ObjectPath -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (ObjectPath -> ObjectPath -> Bool
forall a. Eq a => a -> a -> Bool
== Signal -> ObjectPath
signalPath Signal
msg) (MatchRule -> Maybe ObjectPath
matchPath MatchRule
rule)
    , Bool -> (InterfaceName -> Bool) -> Maybe InterfaceName -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (InterfaceName -> InterfaceName -> Bool
forall a. Eq a => a -> a -> Bool
== Signal -> InterfaceName
signalInterface Signal
msg) (MatchRule -> Maybe InterfaceName
matchInterface MatchRule
rule)
    , Bool -> (MemberName -> Bool) -> Maybe MemberName -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (MemberName -> MemberName -> Bool
forall a. Eq a => a -> a -> Bool
== Signal -> MemberName
signalMember Signal
msg) (MatchRule -> Maybe MemberName
matchMember MatchRule
rule)
    , Bool -> (ObjectPath -> Bool) -> Maybe ObjectPath -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (ObjectPath -> ObjectPath -> Bool
`pathPrefix` Signal -> ObjectPath
signalPath Signal
msg) (MatchRule -> Maybe ObjectPath
matchPathNamespace MatchRule
rule)
    ] where
  pathPrefix :: ObjectPath -> ObjectPath -> Bool
pathPrefix = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (String -> String -> Bool)
-> (ObjectPath -> String) -> ObjectPath -> ObjectPath -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ObjectPath -> String
formatObjectPath

data MethodExc = MethodExc ErrorName [Variant]
    deriving (Int -> MethodExc -> ShowS
[MethodExc] -> ShowS
MethodExc -> String
(Int -> MethodExc -> ShowS)
-> (MethodExc -> String)
-> ([MethodExc] -> ShowS)
-> Show MethodExc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MethodExc] -> ShowS
$cshowList :: [MethodExc] -> ShowS
show :: MethodExc -> String
$cshow :: MethodExc -> String
showsPrec :: Int -> MethodExc -> ShowS
$cshowsPrec :: Int -> MethodExc -> ShowS
Show, MethodExc -> MethodExc -> Bool
(MethodExc -> MethodExc -> Bool)
-> (MethodExc -> MethodExc -> Bool) -> Eq MethodExc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MethodExc -> MethodExc -> Bool
$c/= :: MethodExc -> MethodExc -> Bool
== :: MethodExc -> MethodExc -> Bool
$c== :: MethodExc -> MethodExc -> Bool
Eq, Typeable)

instance Control.Exception.Exception MethodExc

-- | Normally, any exceptions raised while executing a method will be
-- given the generic @\"org.freedesktop.DBus.Error.Failed\"@ name.
-- 'throwError' allows the programmer to specify an error name, and provide
-- additional information to the remote application. You may use this instead
-- of 'Control.Exception.throwIO' to abort a method call.
throwError :: ErrorName
           -> String -- ^ Error message
           -> [Variant] -- ^ Additional items of the error body
           -> IO a
throwError :: ErrorName -> String -> [Variant] -> IO a
throwError ErrorName
name String
message [Variant]
extra = MethodExc -> IO a
forall e a. Exception e => e -> IO a
Control.Exception.throwIO (ErrorName -> [Variant] -> MethodExc
MethodExc ErrorName
name (String -> Variant
forall a. IsVariant a => a -> Variant
toVariant String
message Variant -> [Variant] -> [Variant]
forall a. a -> [a] -> [a]
: [Variant]
extra))


-- Method construction

returnInvalidParameters :: Monad m => m Reply
returnInvalidParameters :: m Reply
returnInvalidParameters = Reply -> m Reply
forall (m :: * -> *) a. Monad m => a -> m a
return (Reply -> m Reply) -> Reply -> m Reply
forall a b. (a -> b) -> a -> b
$ ErrorName -> [Variant] -> Reply
ReplyError ErrorName
errorInvalidParameters []

-- | Used to automatically generate method signatures for introspection
-- documents. To support automatic signatures, a method's parameters and
-- return value must all be instances of 'IsValue'.
--
-- This class maps Haskell idioms to D-Bus; it is therefore unable to
-- generate some signatures. In particular, it does not support methods
-- which accept/return a single structure, or single-element structures.
-- It also cannot generate signatures for methods with parameters or return
-- values which are only instances of 'IsVariant'. For these cases, please
-- use 'DBus.Client.method'.
--
-- To match common Haskell use, if the return value is a tuple, it will be
-- converted to a list of return values.
class AutoMethod a where
    funTypes :: a -> ([Type], [Type])
    apply :: a -> [Variant] -> DBusR Reply

handleTopLevelReturn :: IsVariant a => a -> [Variant]
handleTopLevelReturn :: a -> [Variant]
handleTopLevelReturn a
value =
  case a -> Variant
forall a. IsVariant a => a -> Variant
toVariant a
value of
    T.Variant (T.ValueStructure [Value]
xs) -> (Value -> Variant) -> [Value] -> [Variant]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Variant
T.Variant [Value]
xs
    Variant
v -> [Variant
v]

instance IsValue a => AutoMethod (IO a) where
  funTypes :: IO a -> ([Type], [Type])
funTypes IO a
io = DBusR a -> ([Type], [Type])
forall a. AutoMethod a => a -> ([Type], [Type])
funTypes (IO a -> DBusR a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO a
io :: DBusR a)
  apply :: IO a -> [Variant] -> DBusR Reply
apply IO a
io = DBusR a -> [Variant] -> DBusR Reply
forall a. AutoMethod a => a -> [Variant] -> DBusR Reply
apply (IO a -> DBusR a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO a
io :: DBusR a)

instance IsValue a => AutoMethod (DBusR a) where
    funTypes :: DBusR a -> ([Type], [Type])
funTypes DBusR a
_ = ([], [Type]
outTypes) where
      aType :: Type
      aType :: Type
aType = Proxy a -> Type
forall a. IsValue a => Proxy a -> Type
typeOf' (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
      outTypes :: [Type]
outTypes =
        case Type
aType of
          TypeStructure [Type]
ts -> [Type]
ts
          Type
_ -> [Type
aType]

    apply :: DBusR a -> [Variant] -> DBusR Reply
apply DBusR a
io [] = [Variant] -> Reply
ReplyReturn ([Variant] -> Reply) -> (a -> [Variant]) -> a -> Reply
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Variant]
forall a. IsVariant a => a -> [Variant]
handleTopLevelReturn (a -> Reply) -> DBusR a -> DBusR Reply
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DBusR a
io
    apply DBusR a
_ [Variant]
_ = DBusR Reply
forall (m :: * -> *). Monad m => m Reply
returnInvalidParameters

instance IsValue a => AutoMethod (IO (Either Reply a)) where
  funTypes :: IO (Either Reply a) -> ([Type], [Type])
funTypes IO (Either Reply a)
io = DBusR (Either Reply a) -> ([Type], [Type])
forall a. AutoMethod a => a -> ([Type], [Type])
funTypes (IO (Either Reply a) -> DBusR (Either Reply a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (Either Reply a)
io :: DBusR (Either Reply a))
  apply :: IO (Either Reply a) -> [Variant] -> DBusR Reply
apply IO (Either Reply a)
io = DBusR (Either Reply a) -> [Variant] -> DBusR Reply
forall a. AutoMethod a => a -> [Variant] -> DBusR Reply
apply (IO (Either Reply a) -> DBusR (Either Reply a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (Either Reply a)
io :: DBusR (Either Reply a))

instance IsValue a => AutoMethod (DBusR (Either Reply a)) where
    funTypes :: DBusR (Either Reply a) -> ([Type], [Type])
funTypes DBusR (Either Reply a)
_ = ([], [Type]
outTypes) where
      aType :: Type
      aType :: Type
aType = Proxy a -> Type
forall a. IsValue a => Proxy a -> Type
typeOf' (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
      outTypes :: [Type]
outTypes =
        case Type
aType of
          TypeStructure [Type]
ts -> [Type]
ts
          Type
_ -> [Type
aType]

    apply :: DBusR (Either Reply a) -> [Variant] -> DBusR Reply
apply DBusR (Either Reply a)
io [] = (Reply -> Reply) -> (a -> Reply) -> Either Reply a -> Reply
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Reply -> Reply
forall a. a -> a
id ([Variant] -> Reply
ReplyReturn ([Variant] -> Reply) -> (a -> [Variant]) -> a -> Reply
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Variant]
forall a. IsVariant a => a -> [Variant]
handleTopLevelReturn) (Either Reply a -> Reply) -> DBusR (Either Reply a) -> DBusR Reply
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DBusR (Either Reply a)
io
    apply DBusR (Either Reply a)
_ [Variant]
_ = DBusR Reply
forall (m :: * -> *). Monad m => m Reply
returnInvalidParameters

instance (IsValue a, AutoMethod fn) => AutoMethod (a -> fn) where
    funTypes :: (a -> fn) -> ([Type], [Type])
funTypes a -> fn
fn = ([Type], [Type])
cased where
        cased :: ([Type], [Type])
cased = case a -> (a, Type)
IsValue a => a -> (a, Type)
valueT a
forall a. HasCallStack => a
undefined of
            (a
a, Type
t) -> case fn -> ([Type], [Type])
forall a. AutoMethod a => a -> ([Type], [Type])
funTypes (a -> fn
fn a
a) of
                ([Type]
ts, [Type]
ts') -> (Type
t Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
ts, [Type]
ts')

        valueT :: IsValue a => a -> (a, Type)
        valueT :: a -> (a, Type)
valueT a
a = (a
a, a -> Type
forall a. IsValue a => a -> Type
typeOf a
a)

    apply :: (a -> fn) -> [Variant] -> DBusR Reply
apply a -> fn
_ [] = DBusR Reply
forall (m :: * -> *). Monad m => m Reply
returnInvalidParameters
    apply a -> fn
fn (Variant
v:[Variant]
vs) = case Variant -> Maybe a
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
v of
        Just a
v' -> fn -> [Variant] -> DBusR Reply
forall a. AutoMethod a => a -> [Variant] -> DBusR Reply
apply (a -> fn
fn a
v') [Variant]
vs
        Maybe a
Nothing -> DBusR Reply
forall (m :: * -> *). Monad m => m Reply
returnInvalidParameters

-- | Prepare a Haskell function for export, automatically detecting the
-- function's type signature.
--
-- See 'AutoMethod' for details on the limitations of this function.
--
-- See 'method' for exporting functions with user-defined types.
autoMethod :: (AutoMethod fn) => MemberName -> fn -> Method
autoMethod :: MemberName -> fn -> Method
autoMethod MemberName
name fn
fun = MemberName -> (MethodCall -> fn) -> Method
forall fn.
AutoMethod fn =>
MemberName -> (MethodCall -> fn) -> Method
autoMethodWithMsg MemberName
name ((MethodCall -> fn) -> Method) -> (MethodCall -> fn) -> Method
forall a b. (a -> b) -> a -> b
$ fn -> MethodCall -> fn
forall a b. a -> b -> a
const fn
fun

autoMethodWithMsg :: (AutoMethod fn) => MemberName -> (MethodCall -> fn) -> Method
autoMethodWithMsg :: MemberName -> (MethodCall -> fn) -> Method
autoMethodWithMsg MemberName
name MethodCall -> fn
fun = MemberName
-> Signature -> Signature -> (MethodCall -> DBusR Reply) -> Method
makeMethod MemberName
name Signature
inSig Signature
outSig MethodCall -> DBusR Reply
io where
    ([Type]
typesIn, [Type]
typesOut) = fn -> ([Type], [Type])
forall a. AutoMethod a => a -> ([Type], [Type])
funTypes (MethodCall -> fn
fun MethodCall
forall a. HasCallStack => a
undefined)
    inSig :: Signature
inSig = Signature -> Maybe Signature -> Signature
forall a. a -> Maybe a -> a
fromMaybe (String -> Signature
invalid String
"input") (Maybe Signature -> Signature) -> Maybe Signature -> Signature
forall a b. (a -> b) -> a -> b
$ [Type] -> Maybe Signature
forall (m :: * -> *). MonadThrow m => [Type] -> m Signature
signature [Type]
typesIn
    outSig :: Signature
outSig = Signature -> Maybe Signature -> Signature
forall a. a -> Maybe a -> a
fromMaybe (String -> Signature
invalid String
"output") (Maybe Signature -> Signature) -> Maybe Signature -> Signature
forall a b. (a -> b) -> a -> b
$ [Type] -> Maybe Signature
forall (m :: * -> *). MonadThrow m => [Type] -> m Signature
signature [Type]
typesOut
    io :: MethodCall -> DBusR Reply
io MethodCall
msg = fn -> [Variant] -> DBusR Reply
forall a. AutoMethod a => a -> [Variant] -> DBusR Reply
apply (MethodCall -> fn
fun MethodCall
msg) (MethodCall -> [Variant]
methodCallBody MethodCall
msg)

    invalid :: String -> Signature
invalid String
label = String -> Signature
forall a. HasCallStack => String -> a
error ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Method "
        , String
"."
        , MemberName -> String
formatMemberName MemberName
name
        , String
" has an invalid "
        , String
label
        , String
" signature."])

autoProperty
  :: forall v. (IsValue v)
  => MemberName -> Maybe (IO v) -> Maybe (v -> IO ()) -> Property
autoProperty :: MemberName -> Maybe (IO v) -> Maybe (v -> IO ()) -> Property
autoProperty MemberName
name Maybe (IO v)
mgetter Maybe (v -> IO ())
msetter =
  MemberName
-> Type
-> Maybe (IO Variant)
-> Maybe (Variant -> IO ())
-> Property
Property MemberName
name Type
propType ((v -> Variant) -> IO v -> IO Variant
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> Variant
forall a. IsVariant a => a -> Variant
toVariant (IO v -> IO Variant) -> Maybe (IO v) -> Maybe (IO Variant)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (IO v)
mgetter) ((v -> IO ()) -> Variant -> IO ()
forall (m :: * -> *) a.
(Monad m, IsVariant a) =>
(a -> m ()) -> Variant -> m ()
variantSetter ((v -> IO ()) -> Variant -> IO ())
-> Maybe (v -> IO ()) -> Maybe (Variant -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (v -> IO ())
msetter)
    where propType :: Type
propType = Proxy v -> Type
forall a. IsValue a => Proxy a -> Type
typeOf' (Proxy v
forall k (t :: k). Proxy t
Proxy :: Proxy v)
          variantSetter :: (a -> m ()) -> Variant -> m ()
variantSetter a -> m ()
setter =
            let newFun :: Variant -> m ()
newFun Variant
variant = m () -> (a -> m ()) -> Maybe a -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) a -> m ()
setter (Variant -> Maybe a
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
variant)
            in Variant -> m ()
newFun

readOnlyProperty :: (IsValue v) => MemberName -> IO v -> Property
readOnlyProperty :: MemberName -> IO v -> Property
readOnlyProperty MemberName
name IO v
getter = MemberName -> Maybe (IO v) -> Maybe (v -> IO ()) -> Property
forall v.
IsValue v =>
MemberName -> Maybe (IO v) -> Maybe (v -> IO ()) -> Property
autoProperty MemberName
name (IO v -> Maybe (IO v)
forall a. a -> Maybe a
Just IO v
getter) Maybe (v -> IO ())
forall a. Maybe a
Nothing

-- | Define a method handler, which will accept method calls with the given
-- interface and member name.
--
-- Note that the input and output parameter signatures are used for
-- introspection, but are not checked when executing a method.
--
-- See 'autoMethod' for an easier way to export functions with simple
-- parameter and return types.
makeMethod
  :: MemberName
  -> Signature -- ^ Input parameter signature
  -> Signature -- ^ Output parameter signature
  -> (MethodCall -> DBusR Reply)
  -> Method
makeMethod :: MemberName
-> Signature -> Signature -> (MethodCall -> DBusR Reply) -> Method
makeMethod MemberName
name Signature
inSig Signature
outSig MethodCall -> DBusR Reply
io = MemberName
-> Signature -> Signature -> (MethodCall -> DBusR Reply) -> Method
Method MemberName
name Signature
inSig Signature
outSig
    (\MethodCall
msg -> do
       Client
fromReader <- ReaderT Client IO Client
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
       IO Reply -> DBusR Reply
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Reply -> DBusR Reply) -> IO Reply -> DBusR Reply
forall a b. (a -> b) -> a -> b
$ IO Reply -> (SomeException -> IO Reply) -> IO Reply
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch
        (IO Reply -> (MethodExc -> IO Reply) -> IO Reply
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch
            (DBusR Reply -> Client -> IO Reply
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (MethodCall -> DBusR Reply
io MethodCall
msg) Client
fromReader)
            (\(MethodExc ErrorName
name' [Variant]
vs') -> Reply -> IO Reply
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrorName -> [Variant] -> Reply
ReplyError ErrorName
name' [Variant]
vs')))
        (\SomeException
exc -> Reply -> IO Reply
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrorName -> [Variant] -> Reply
ReplyError ErrorName
errorFailed
            [String -> Variant
forall a. IsVariant a => a -> Variant
toVariant (SomeException -> String
forall a. Show a => a -> String
show (SomeException
exc :: SomeException))])))

-- | Export the given 'Interface' at the given 'ObjectPath'
--
-- Use 'autoMethod' to construct a 'Method' from a function that accepts and
-- returns simple types.
--
-- Use 'method' to construct a 'Method' from a function that handles parameter
-- conversion manually.
--
-- @
--ping :: MethodCall -> IO 'Reply'
--ping _ = ReplyReturn []
--
--sayHello :: String -> IO String
--sayHello name = return (\"Hello \" ++ name ++ \"!\")
--
-- export client \"/hello_world\"
--   defaultInterface { interfaceName = \"com.example.HelloWorld\"
--                    , interfaceMethods =
--                      [ 'method' \"com.example.HelloWorld\" \"Ping\" ping
--                      , 'autoMethod' \"com.example.HelloWorld\" \"Hello\" sayHello
--                      ]
--                    }
-- @
export :: Client -> ObjectPath -> Interface -> IO ()
export :: Client -> ObjectPath -> Interface -> IO ()
export Client
client ObjectPath
path Interface
interface =
  IORef PathInfo -> (PathInfo -> PathInfo) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ (Client -> IORef PathInfo
clientObjects Client
client) ((PathInfo -> PathInfo) -> IO ())
-> (PathInfo -> PathInfo) -> IO ()
forall a b. (a -> b) -> a -> b
$ ObjectPath -> Interface -> PathInfo -> PathInfo
addInterface ObjectPath
path Interface
interface

-- | Revokes the export of the given 'ObjectPath'. This will remove all
-- interfaces and methods associated with the path.
unexport :: Client -> ObjectPath -> IO ()
unexport :: Client -> ObjectPath -> IO ()
unexport Client
client ObjectPath
path = IORef PathInfo -> (PathInfo -> PathInfo) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ (Client -> IORef PathInfo
clientObjects Client
client) PathInfo -> PathInfo
clear
  where clear :: PathInfo -> PathInfo
clear = (([Interface] -> Identity [Interface])
 -> PathInfo -> Identity PathInfo)
-> ([Interface] -> [Interface]) -> PathInfo -> PathInfo
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (ObjectPath
-> ([Interface] -> Identity [Interface])
-> PathInfo
-> Identity PathInfo
modifyPathInterfacesLens ObjectPath
path) (([Interface] -> [Interface]) -> PathInfo -> PathInfo)
-> ([Interface] -> [Interface]) -> PathInfo -> PathInfo
forall a b. (a -> b) -> a -> b
$ [Interface] -> [Interface] -> [Interface]
forall a b. a -> b -> a
const []


-- Introspection

buildIntrospectionObject :: [I.Interface] -> PathInfo -> [String] -> I.Object
buildIntrospectionObject :: [Interface] -> PathInfo -> [String] -> Object
buildIntrospectionObject [Interface]
defaultInterfaces
                         PathInfo
                         { _pathInterfaces :: PathInfo -> [Interface]
_pathInterfaces = [Interface]
interfaces
                         , _pathChildren :: PathInfo -> Map String PathInfo
_pathChildren = Map String PathInfo
infoChildren
                         } [String]
elems =
  Object :: ObjectPath -> [Interface] -> [Object] -> Object
I.Object
     { objectPath :: ObjectPath
I.objectPath = [String] -> ObjectPath
T.fromElements [String]
elems
     , objectInterfaces :: [Interface]
I.objectInterfaces =
       (if [Interface] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Interface]
interfaces then [] else [Interface]
defaultInterfaces) [Interface] -> [Interface] -> [Interface]
forall a. [a] -> [a] -> [a]
++
       (Interface -> Interface) -> [Interface] -> [Interface]
forall a b. (a -> b) -> [a] -> [b]
map Interface -> Interface
buildIntrospectionInterface [Interface]
interfaces
     -- TODO: Eventually we should support not outputting everything if there is
     -- a lot of stuff.
     , objectChildren :: [Object]
I.objectChildren = Map String Object -> [Object]
forall k a. Map k a -> [a]
M.elems (Map String Object -> [Object]) -> Map String Object -> [Object]
forall a b. (a -> b) -> a -> b
$ (String -> PathInfo -> Object)
-> Map String PathInfo -> Map String Object
forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey String -> PathInfo -> Object
recurseFromString Map String PathInfo
infoChildren
     }
    where recurseFromString :: String -> PathInfo -> Object
recurseFromString String
stringNode PathInfo
nodeInfo =
            [Interface] -> PathInfo -> [String] -> Object
buildIntrospectionObject [Interface]
defaultInterfaces PathInfo
nodeInfo ([String] -> Object) -> [String] -> Object
forall a b. (a -> b) -> a -> b
$ [String]
elems [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
stringNode]

buildIntrospectionInterface :: Interface -> I.Interface
buildIntrospectionInterface :: Interface -> Interface
buildIntrospectionInterface Interface
  { interfaceName :: Interface -> InterfaceName
interfaceName = InterfaceName
name
  , interfaceMethods :: Interface -> [Method]
interfaceMethods = [Method]
methods
  , interfaceProperties :: Interface -> [Property]
interfaceProperties = [Property]
properties
  , interfaceSignals :: Interface -> [Signal]
interfaceSignals = [Signal]
signals
  } =
  Interface :: InterfaceName -> [Method] -> [Signal] -> [Property] -> Interface
I.Interface
   { interfaceName :: InterfaceName
I.interfaceName = InterfaceName
name
   , interfaceMethods :: [Method]
I.interfaceMethods = (Method -> Method) -> [Method] -> [Method]
forall a b. (a -> b) -> [a] -> [b]
map Method -> Method
buildIntrospectionMethod [Method]
methods
   , interfaceProperties :: [Property]
I.interfaceProperties = (Property -> Property) -> [Property] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map Property -> Property
buildIntrospectionProperty [Property]
properties
   , interfaceSignals :: [Signal]
I.interfaceSignals = [Signal]
signals
   }

buildIntrospectionProperty :: Property -> I.Property
buildIntrospectionProperty :: Property -> Property
buildIntrospectionProperty (Property MemberName
memberName Type
ptype Maybe (IO Variant)
getter Maybe (Variant -> IO ())
setter) =
  Property :: String -> Type -> Bool -> Bool -> Property
I.Property { propertyName :: String
I.propertyName = MemberName -> String
coerce MemberName
memberName
             , propertyType :: Type
I.propertyType = Type
ptype
             , propertyRead :: Bool
I.propertyRead = Maybe (IO Variant) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (IO Variant)
getter
             , propertyWrite :: Bool
I.propertyWrite = Maybe (Variant -> IO ()) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Variant -> IO ())
setter
             }

buildIntrospectionMethod :: Method -> I.Method
buildIntrospectionMethod :: Method -> Method
buildIntrospectionMethod Method
  { methodName :: Method -> MemberName
methodName = MemberName
name
  , inSignature :: Method -> Signature
inSignature = Signature
inSig
  , outSignature :: Method -> Signature
outSignature = Signature
outSig
  } = Method :: MemberName -> [MethodArg] -> Method
I.Method
    { methodName :: MemberName
I.methodName = MemberName
name
    , methodArgs :: [MethodArg]
I.methodArgs = (Char -> (Type, Direction) -> MethodArg)
-> String -> [(Type, Direction)] -> [MethodArg]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Char -> (Type, Direction) -> MethodArg
makeMethodArg [Char
'a'..Char
'z'] ([(Type, Direction)] -> [MethodArg])
-> [(Type, Direction)] -> [MethodArg]
forall a b. (a -> b) -> a -> b
$ [(Type, Direction)]
inTuples [(Type, Direction)] -> [(Type, Direction)] -> [(Type, Direction)]
forall a. [a] -> [a] -> [a]
++ [(Type, Direction)]
outTuples
    }
  where inTuples :: [(Type, Direction)]
inTuples = (Type -> (Type, Direction)) -> [Type] -> [(Type, Direction)]
forall a b. (a -> b) -> [a] -> [b]
map (, Direction
I.In) ([Type] -> [(Type, Direction)]) -> [Type] -> [(Type, Direction)]
forall a b. (a -> b) -> a -> b
$ Signature -> [Type]
coerce Signature
inSig
        outTuples :: [(Type, Direction)]
outTuples = (Type -> (Type, Direction)) -> [Type] -> [(Type, Direction)]
forall a b. (a -> b) -> [a] -> [b]
map (, Direction
I.Out) ([Type] -> [(Type, Direction)]) -> [Type] -> [(Type, Direction)]
forall a b. (a -> b) -> a -> b
$ Signature -> [Type]
coerce Signature
outSig
        makeMethodArg :: Char -> (Type, Direction) -> MethodArg
makeMethodArg Char
nameChar (Type
t, Direction
dir) =
          MethodArg :: String -> Type -> Direction -> MethodArg
I.MethodArg { methodArgName :: String
I.methodArgName = [Char
nameChar]
                      , methodArgType :: Type
I.methodArgType = Type
t
                      , methodArgDirection :: Direction
I.methodArgDirection = Direction
dir
                      }


-- Constants

errorFailed :: ErrorName
errorFailed :: ErrorName
errorFailed = String -> ErrorName
errorName_ String
"org.freedesktop.DBus.Error.Failed"

errorDisconnected :: ErrorName
errorDisconnected :: ErrorName
errorDisconnected = String -> ErrorName
errorName_ String
"org.freedesktop.DBus.Error.Disconnected"

errorUnknownObject :: ErrorName
errorUnknownObject :: ErrorName
errorUnknownObject = String -> ErrorName
errorName_ String
"org.freedesktop.DBus.Error.UnknownObject"

errorUnknownInterface :: ErrorName
errorUnknownInterface :: ErrorName
errorUnknownInterface = String -> ErrorName
errorName_ String
"org.freedesktop.DBus.Error.UnknownInterface"

errorUnknownMethod :: ErrorName
errorUnknownMethod :: ErrorName
errorUnknownMethod = String -> ErrorName
errorName_ String
"org.freedesktop.DBus.Error.UnknownMethod"

errorInvalidParameters :: ErrorName
errorInvalidParameters :: ErrorName
errorInvalidParameters = String -> ErrorName
errorName_ String
"org.freedesktop.DBus.Error.InvalidParameters"

errorNotAuthorized :: ErrorName
errorNotAuthorized :: ErrorName
errorNotAuthorized = String -> ErrorName
errorName_ String
"org.freedesktop.DBus.Error.NotAuthorized"

dbusName :: BusName
dbusName :: BusName
dbusName = String -> BusName
busName_ String
"org.freedesktop.DBus"

dbusPath :: ObjectPath
dbusPath :: ObjectPath
dbusPath = String -> ObjectPath
objectPath_ String
"/org/freedesktop/DBus"

dbusInterface :: InterfaceName
dbusInterface :: InterfaceName
dbusInterface = String -> InterfaceName
interfaceName_ String
"org.freedesktop.DBus"

introspectableInterfaceName :: InterfaceName
introspectableInterfaceName :: InterfaceName
introspectableInterfaceName = String -> InterfaceName
interfaceName_ String
"org.freedesktop.DBus.Introspectable"

propertiesInterfaceName :: InterfaceName
propertiesInterfaceName :: InterfaceName
propertiesInterfaceName = String -> InterfaceName
forall a. IsString a => String -> a
fromString String
"org.freedesktop.DBus.Properties"

getAllMemberName :: MemberName
getAllMemberName :: MemberName
getAllMemberName = String -> MemberName
forall a. IsString a => String -> a
fromString String
"GetAll"

getMemberName :: MemberName
getMemberName :: MemberName
getMemberName = String -> MemberName
forall a. IsString a => String -> a
fromString String
"Get"

setMemberName :: MemberName
setMemberName :: MemberName
setMemberName = String -> MemberName
forall a. IsString a => String -> a
fromString String
"Set"


-- Miscellaneous

maybeToEither :: b -> Maybe a -> Either b a
maybeToEither :: b -> Maybe a -> Either b a
maybeToEither = (Either b a -> (a -> Either b a) -> Maybe a -> Either b a)
-> (a -> Either b a) -> Either b a -> Maybe a -> Either b a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Either b a -> (a -> Either b a) -> Maybe a -> Either b a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a -> Either b a
forall a b. b -> Either a b
Right (Either b a -> Maybe a -> Either b a)
-> (b -> Either b a) -> b -> Maybe a -> Either b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either b a
forall a b. a -> Either a b
Left

atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef a
ref a -> a
fn = IORef a -> (a -> (a, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef a
ref (a -> a
fn (a -> a) -> (a -> ()) -> a -> (a, ())
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& () -> a -> ()
forall a b. a -> b -> a
const ())

#if !MIN_VERSION_base(4,6,0)
atomicWriteIORef :: IORef a -> a -> IO ()
atomicWriteIORef ref x = atomicModifyIORef ref $ const x &&& const ()
#endif