{-# 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
    , connectWithName

    , 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.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
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
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.
      forall t. 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'.
    , forall t. 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.
    , forall t. 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 :: 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 = forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PathInfo -> [Interface]
_pathInterfaces PathInfo
a) Bool -> Bool -> Bool
&&
           forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PathInfo -> [Interface]
_pathInterfaces PathInfo
b) Bool -> Bool -> Bool
&&
           forall k a. Map k a -> Bool
M.null (PathInfo -> Map String PathInfo
_pathChildren PathInfo
a) Bool -> Bool -> 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
  { _pathInterfaces :: [Interface]
_pathInterfaces = []
  , _pathChildren :: Map String PathInfo
_pathChildren = forall k a. Map k a
M.empty
  }

traverseElement
  :: Applicative f
  => (a -> Maybe PathInfo -> f (Maybe PathInfo))
  -> String
  -> a
  -> PathInfo
  -> f PathInfo
traverseElement :: forall (f :: * -> *) a.
Applicative f =>
(a -> Maybe PathInfo -> f (Maybe PathInfo))
-> String -> a -> PathInfo -> f PathInfo
traverseElement a -> Maybe PathInfo -> f (Maybe PathInfo)
nothingHandler String
pathElement =
  Lens' PathInfo (Map String PathInfo)
pathChildren forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at String
pathElement 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 :: forall a b.
(a -> Const (First PathInfo) b)
-> Maybe a -> Const (First PathInfo) (Maybe b)
lookupNothingHandler = 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 = 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 :: forall (f :: * -> *).
Applicative f =>
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 =
  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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) forall a. a -> a
id 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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' PathInfo [Interface]
pathInterfaces

addInterface :: ObjectPath -> Interface -> PathInfo -> PathInfo
addInterface :: ObjectPath -> Interface -> PathInfo -> PathInfo
addInterface ObjectPath
path Interface
interface =
  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 forall a. a -> [a] -> [a]
:)

findPath :: ObjectPath -> PathInfo -> Maybe PathInfo
findPath :: ObjectPath -> PathInfo -> Maybe PathInfo
findPath ObjectPath
path = forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (forall (f :: * -> *).
Applicative f =>
ObjectPath
-> ((PathInfo -> f PathInfo)
    -> Maybe PathInfo -> f (Maybe PathInfo))
-> (PathInfo -> f PathInfo)
-> PathInfo
-> f PathInfo
pathLens ObjectPath
path 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 :: forall a2 a1 (t :: * -> *) a3.
(Coercible a2 a1, Eq a1, Foldable t) =>
t a3 -> (a3 -> a2) -> a1 -> Maybe a3
findByGetterAndName t a3
options a3 -> a2
getter a1
name =
  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== a1
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce 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 =
  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 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 =
  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 =
  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 -> 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 -> 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 -> 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 = 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 :: forall t.
TransportOpen t =>
ClientOptions t -> Address -> IO Client
connectWith ClientOptions t
opts Address
addr = do
    Client
client <- forall t.
TransportOpen t =>
ClientOptions t -> Address -> IO Client
connectWith' ClientOptions t
opts Address
addr

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

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

-- | Connect to the bus at the specified address, with the given connection
-- options, and return the unique client bus name. Most users should use
-- 'connect' or 'connectWith' instead.
--
-- Throws a 'ClientError' on failure.
connectWithName :: TransportOpen t => ClientOptions t -> Address -> IO (Client, BusName)
connectWithName :: forall t.
TransportOpen t =>
ClientOptions t -> Address -> IO (Client, BusName)
connectWithName ClientOptions t
opts Address
addr = do
    Client
client <- forall t.
TransportOpen t =>
ClientOptions t -> Address -> IO Client
connectWith' ClientOptions t
opts Address
addr

    MethodReturn
reply <- Client -> MethodCall -> IO MethodReturn
call_ Client
client (ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCall ObjectPath
dbusPath InterfaceName
dbusInterface MemberName
"Hello")
        { methodCallDestination :: Maybe BusName
methodCallDestination = forall a. a -> Maybe a
Just BusName
dbusName
        }
    
    case MethodReturn -> [Variant]
methodReturnBody MethodReturn
reply of
      [Variant
name] | Just String
nameStr <- forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
name -> do
        BusName
busName <- forall (m :: * -> *). MonadThrow m => String -> m BusName
parseBusName String
nameStr
        forall (m :: * -> *) a. Monad m => a -> m a
return (Client
client, BusName
busName)
      [Variant]
_ ->
        forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
clientError String
"connectWithName: Hello response did not contain client name.")

connectWith' :: TransportOpen t => ClientOptions t -> Address -> IO Client
connectWith' :: forall t.
TransportOpen t =>
ClientOptions t -> Address -> IO Client
connectWith' ClientOptions t
opts Address
addr = do
    Socket
sock <- forall t.
TransportOpen t =>
SocketOptions t -> Address -> IO Socket
DBus.Socket.openWith (forall t. ClientOptions t -> SocketOptions t
clientSocketOptions ClientOptions t
opts) Address
addr

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

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

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

    let client :: Client
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 = forall t. ClientOptions t -> Client -> [Interface]
clientBuildInterfaces ClientOptions t
opts Client
client
            }
    forall a. MVar a -> a -> IO ()
putMVar MVar Client
clientMVar Client
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
        (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
propertyInterfaceName) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        (forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorUnknownMethod forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemberName -> Interface -> Maybe Property
findProperty (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        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 =
        forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ErrorName -> Reply
makeErrorReply forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (do
          Property
property <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ String -> String -> ObjectPath -> IO (Either ErrorName Property)
getPropertyObj String
propertyInterfaceName
                      String
memberName ObjectPath
path
          forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall a b. (a -> b) -> a -> b
$ forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorNotAuthorized 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 =
        forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ErrorName -> Reply
makeErrorReply forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (do
          Property
property <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ String -> String -> ObjectPath -> IO (Either ErrorName Property)
getPropertyObj String
propertyInterfaceName String
memberName ObjectPath
path
          Variant -> IO ()
setter <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorNotAuthorized forall a b. (a -> b) -> a -> b
$
                    Property -> Maybe (Variant -> IO ())
propertySetter Property
property
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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 =
        forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ErrorName -> Reply
makeErrorReply forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (do
          PathInfo
info <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (Client -> IORef PathInfo
clientObjects Client
client)
          Interface
propertyInterface <-
            forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Interface]
-> PathInfo
-> ObjectPath
-> Maybe InterfaceName
-> Either ErrorName Interface
findInterfaceAtPath [Interface]
alwaysPresent PathInfo
info ObjectPath
path forall a b. (a -> b) -> a -> b
$
                    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 = [ (coerce :: forall a b. Coercible a b => a -> b
coerce MemberName
name,) 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]
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 =
      [ forall fn.
AutoMethod fn =>
MemberName -> (MethodCall -> fn) -> Method
autoMethodWithMsg MemberName
"Get" MethodCall -> String -> String -> IO (Either Reply Variant)
callGet
      , forall fn.
AutoMethod fn =>
MemberName -> (MethodCall -> fn) -> Method
autoMethodWithMsg MemberName
"GetAll" MethodCall -> String -> IO (Either Reply (Map String Variant))
callGetAll
      , forall fn.
AutoMethod fn =>
MemberName -> (MethodCall -> fn) -> Method
autoMethodWithMsg MemberName
"Set" MethodCall -> String -> String -> Variant -> IO (Either Reply ())
callSet
      ]
    , interfaceSignals :: [Signal]
interfaceSignals =
      [ I.Signal
        { signalName :: MemberName
I.signalName = MemberName
"PropertiesChanged"
        , signalArgs :: [SignalArg]
I.signalArgs =
          [ I.SignalArg
            { signalArgName :: String
I.signalArgName = String
"interface_name"
            , signalArgType :: Type
I.signalArgType = Type
T.TypeString
            }
          , I.SignalArg
            { signalArgName :: String
I.signalArgName = String
"changed_properties"
            , signalArgType :: Type
I.signalArgType = Type -> Type -> Type
T.TypeDictionary Type
T.TypeString Type
T.TypeVariant
            }
          , 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 = [ 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 <- forall a. IORef a -> IO a
readIORef (Client -> IORef PathInfo
clientObjects Client
client)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ErrorName -> Reply
makeErrorReply forall a b. (a -> b) -> a -> b
$ do
      PathInfo
targetInfo <- forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorUnknownObject 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:
      forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorUnknownObject forall a b. (a -> b) -> a -> b
$ Object -> Maybe String
I.formatXML 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 = forall a b. (a -> b) -> [a] -> [b]
map Interface -> Interface
buildIntrospectionInterface 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
    { clientSocketOptions :: SocketOptions SocketTransport
clientSocketOptions = SocketOptions SocketTransport
DBus.Socket.defaultSocketOptions
    , clientThreadRunner :: IO () -> IO ()
clientThreadRunner = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever
    , clientBuildInterfaces :: Client -> [Interface]
clientBuildInterfaces =
      \Client
client -> forall a b. (a -> b) -> [a] -> [b]
map (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 <- 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 -> (forall k a. Map k a
M.empty, Map Serial (MVar (Either MethodError MethodReturn))
p))
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
M.toList Map Serial (MVar (Either MethodError MethodReturn))
pendingCalls) forall a b. (a -> b) -> a -> b
$ \(Serial
k, MVar (Either MethodError MethodReturn)
v) ->
        forall a. MVar a -> a -> IO ()
putMVar MVar (Either MethodError MethodReturn)
v (forall a b. a -> Either a b
Left (Serial -> ErrorName -> MethodError
methodError Serial
k ErrorName
errorDisconnected))

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

    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 <- 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
            forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
clientError (SocketError -> String
DBus.Socket.socketErrorMessage SocketError
err))
        Right ReceivedMessage
msg -> 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) (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) (forall a b. a -> Either a b
Left MethodError
msg)
    go (ReceivedSignal Serial
_ Signal
msg) = do
        Map Unique SignalHandler
handlers <- forall a. IORef a -> IO a
readIORef (Client -> IORef (Map Unique SignalHandler)
clientSignalHandlers Client
client)
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Signal -> IO ()
h Signal
msg)
    go (ReceivedMethodCall Serial
serial MethodCall
msg) = do
        PathInfo
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 -> 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
                ReplyError ErrorName
name [Variant]
vs -> 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
        ThreadId
_ <- IO () -> IO ThreadId
forkIO 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 } ->
              forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (MethodCall -> DBusR Reply
handler MethodCall
msg) Client
client forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Reply -> IO ()
sendResult
            Left ErrorName
errName -> 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
        forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go ReceivedMessage
_ = 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 <- 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 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, forall a. Maybe a
Nothing)
                Just MVar (Either MethodError MethodReturn)
mvar -> (forall k a. Ord k => k -> Map k a -> Map k a
M.delete Serial
serial Map Serial (MVar (Either MethodError MethodReturn))
p, 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 -> forall a. MVar a -> a -> IO ()
putMVar MVar (Either MethodError MethodReturn)
mvar Either MethodError MethodReturn
result
            Maybe (MVar (Either MethodError MethodReturn))
Nothing -> 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 =
  forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorUnknownObject (ObjectPath -> PathInfo -> Maybe PathInfo
findPath ObjectPath
path PathInfo
info) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  (forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorUnknownInterface forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                 forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> b -> a
const 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  (forall b a. b -> Maybe a -> Either b a
maybeToEither ErrorName
errorUnknownMethod 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
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
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
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
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
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
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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. Bits a => a -> a -> a
(.|.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Num a => RequestNameFlag -> a
flagValue) Word32
0  where
    flagValue :: RequestNameFlag -> a
flagValue RequestNameFlag
AllowReplacement = a
0x1
    flagValue RequestNameFlag
ReplaceExisting  = a
0x2
    flagValue RequestNameFlag
DoNotQueue       = a
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 = forall a. a -> Maybe a
Just BusName
dbusName
        , methodCallBody :: [Variant]
methodCallBody = [forall a. IsVariant a => a -> Variant
toVariant BusName
name, forall a. IsVariant a => a -> Variant
toVariant ([RequestNameFlag] -> Word32
encodeFlags [RequestNameFlag]
flags)]
        }
    Variant
var <- case forall a. [a] -> Maybe a
listToMaybe (MethodReturn -> [Variant]
methodReturnBody MethodReturn
reply) of
        Just Variant
x -> forall (m :: * -> *) a. Monad m => a -> m a
return Variant
x
        Maybe Variant
Nothing -> 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 forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
var of
        Just Word32
x -> forall (m :: * -> *) a. Monad m => a -> m a
return Word32
x
        Maybe Word32
Nothing -> forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
clientError (String
"requestName: received invalid response code " forall a. [a] -> [a] -> [a]
++ forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Variant
var String
""))
            { clientErrorFatal :: Bool
clientErrorFatal = Bool
False
            }
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a. a -> Maybe a
Just BusName
dbusName
        , methodCallBody :: [Variant]
methodCallBody = [forall a. IsVariant a => a -> Variant
toVariant BusName
name]
        }
    Variant
var <- case forall a. [a] -> Maybe a
listToMaybe (MethodReturn -> [Variant]
methodReturnBody MethodReturn
reply) of
        Just Variant
x -> forall (m :: * -> *) a. Monad m => a -> m a
return Variant
x
        Maybe Variant
Nothing -> 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 forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
var of
        Just Word32
x -> forall (m :: * -> *) a. Monad m => a -> m a
return Word32
x
        Maybe Word32
Nothing -> forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
clientError (String
"releaseName: received invalid response code " forall a. [a] -> [a] -> [a]
++ forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Variant
var String
""))
            { clientErrorFatal :: Bool
clientErrorFatal = Bool
False
            }
    forall (m :: * -> *) a. Monad m => a -> m a
return 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_ :: forall msg a.
Message msg =>
Client -> msg -> (Serial -> IO a) -> IO a
send_ Client
client msg
msg Serial -> IO a
io = do
    Either SocketError a
result <- forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        Left SocketError
err -> 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 <- 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 <- forall msg a.
Message msg =>
Client -> msg -> (Serial -> IO a) -> IO a
send_ Client
client MethodCall
safeMsg (\Serial
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 -> (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.
    forall a b. IO a -> IO b -> IO a
Control.Exception.onException
        (forall a. MVar a -> IO a
takeMVar MVar (Either MethodError MethodReturn)
mvar)
        (forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef (Map Serial (MVar (Either MethodError MethodReturn)))
ref (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 -> forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
clientError (String
"Call failed: " forall a. [a] -> [a] -> [a]
++ MethodError -> String
methodErrorMessage MethodError
err))
            { clientErrorFatal :: Bool
clientErrorFatal = MethodError -> ErrorName
methodErrorName MethodError
err forall a. Eq a => a -> a -> Bool
== ErrorName
errorDisconnected
            }
        Right MethodReturn
ret -> 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
            }
    forall msg a.
Message msg =>
Client -> msg -> (Serial -> IO a) -> IO a
send_ Client
client MethodCall
safeMsg (\Serial
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())

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

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

unpackVariant :: IsValue a => MethodCall -> Variant -> Either MethodError a
unpackVariant :: forall a.
IsValue a =>
MethodCall -> Variant -> Either MethodError a
unpackVariant MethodCall { methodCallSender :: MethodCall -> Maybe BusName
methodCallSender = Maybe BusName
sender } Variant
variant =
  forall b a. b -> Maybe a -> Either b a
maybeToEither MethodError
dummyMethodError { methodErrorBody :: [Variant]
methodErrorBody =
                                     [Variant
variant, forall a. IsVariant a => a -> Variant
toVariant forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Variant -> Type
variantType Variant
variant]
                                 , methodErrorSender :: Maybe BusName
methodErrorSender = Maybe BusName
sender
                                 } forall a b. (a -> b) -> a -> b
$ 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
                           } =
  (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a.
IsValue a =>
MethodCall -> Variant -> Either MethodError a
unpackVariant MethodCall
msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. MethodReturn -> [Variant]
methodReturnBody)) 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 = forall a. a -> Maybe a
Just InterfaceName
propertiesInterfaceName
                    , methodCallMember :: MemberName
methodCallMember = MemberName
getMemberName
                    , methodCallBody :: [Variant]
methodCallBody = [ forall a. IsVariant a => a -> Variant
toVariant (coerce :: forall a b. Coercible a b => a -> b
coerce (Maybe InterfaceName -> InterfaceName
orDefaultInterface Maybe InterfaceName
interface) :: String)
                                       , forall a. IsVariant a => a -> Variant
toVariant (coerce :: forall a b. Coercible a b => a -> b
coerce MemberName
member :: String)
                                       ]
                    }

getPropertyValue :: IsValue a => Client -> MethodCall -> IO (Either MethodError a)
getPropertyValue :: forall a.
IsValue a =>
Client -> MethodCall -> IO (Either MethodError a)
getPropertyValue Client
client MethodCall
msg =
  (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a.
IsValue a =>
MethodCall -> Variant -> Either MethodError a
unpackVariant MethodCall
msg) 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 = forall a. a -> Maybe a
Just InterfaceName
propertiesInterfaceName
                  , methodCallMember :: MemberName
methodCallMember = MemberName
setMemberName
                  , methodCallBody :: [Variant]
methodCallBody =
                    [ forall a. IsVariant a => a -> Variant
toVariant (coerce :: forall a b. Coercible a b => a -> b
coerce (Maybe InterfaceName -> InterfaceName
orDefaultInterface Maybe InterfaceName
interface) :: String)
                    , forall a. IsVariant a => a -> Variant
toVariant (coerce :: forall a b. Coercible a b => a -> b
coerce MemberName
member :: String)
                    , Variant
value
                    ]
                  }

setPropertyValue
  :: IsValue a
  => Client -> MethodCall -> a -> IO (Maybe MethodError)
setPropertyValue :: forall a.
IsValue a =>
Client -> MethodCall -> a -> IO (Maybe MethodError)
setPropertyValue Client
client MethodCall
msg a
v = forall {a} {b}. Either a b -> Maybe a
eitherToMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Client
-> MethodCall -> Variant -> IO (Either MethodError MethodReturn)
setProperty Client
client MethodCall
msg (forall a. IsVariant a => a -> Variant
toVariant a
v)
  where eitherToMaybe :: Either a b -> Maybe a
eitherToMaybe (Left a
a) = forall a. a -> Maybe a
Just a
a
        eitherToMaybe (Right b
_) = 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 = forall a. a -> Maybe a
Just InterfaceName
propertiesInterfaceName
                  , methodCallMember :: MemberName
methodCallMember = MemberName
getAllMemberName
                  , methodCallBody :: [Variant]
methodCallBody = [forall a. IsVariant a => a -> Variant
toVariant (coerce :: forall a b. Coercible a b => a -> b
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.
  (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall b a. b -> Maybe a -> Either b a
maybeToEither MethodError
dummyMethodError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsVariant a => Variant -> Maybe a
fromVariant forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. MethodReturn -> [Variant]
methodReturnBody))
  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'," forall a. [a] -> [a] -> [a]
++ String
x

    Unique
handlerId <- IO Unique
newUnique
    IORef Bool
registered <- 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 -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MatchRule -> Signal -> Bool
checkMatchRule MatchRule
rule Signal
msg) (Signal -> IO ()
io Signal
msg))

    forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (Client -> IORef (Map Unique SignalHandler)
clientSignalHandlers Client
client) (\Map Unique SignalHandler
hs -> (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 = forall a. a -> Maybe a
Just BusName
dbusName
        , methodCallBody :: [Variant]
methodCallBody = [forall a. IsVariant a => a -> Variant
toVariant String
formatted]
        }
    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 <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Bool
registered (\Bool
wasRegistered -> (Bool
False, Bool
wasRegistered))
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldUnregister forall a b. (a -> b) -> a -> b
$ do
        forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (Client -> IORef (Map Unique SignalHandler)
clientSignalHandlers Client
client) (\Map Unique SignalHandler
hs -> (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 = forall a. a -> Maybe a
Just BusName
dbusName
            , methodCallBody :: [Variant]
methodCallBody = [forall a. IsVariant a => a -> Variant
toVariant String
formatted]
            }
        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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void 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 = forall msg a.
Message msg =>
Client -> msg -> (Serial -> IO a) -> IO a
send_ Client
client Signal
msg (\Serial
_ -> 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 forall a. Ord a => a -> a -> Bool
> Int
10) (String -> ShowS
showString String
"MatchRule " forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
predicates where
    predicates :: [String]
predicates = forall a. [Maybe a] -> [a]
catMaybes
        [ forall a.
String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String
f String
"sender" MatchRule -> Maybe BusName
matchSender BusName -> String
formatBusName
        , forall a.
String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String
f String
"destination" MatchRule -> Maybe BusName
matchDestination BusName -> String
formatBusName
        , forall a.
String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String
f String
"path" MatchRule -> Maybe ObjectPath
matchPath ObjectPath -> String
formatObjectPath
        , forall a.
String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String
f String
"interface" MatchRule -> Maybe InterfaceName
matchInterface InterfaceName -> String
formatInterfaceName
        , forall a.
String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String
f String
"member" MatchRule -> Maybe MemberName
matchMember MemberName -> String
formatMemberName
        , 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 :: forall a.
String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String
f String
key MatchRule -> Maybe a
get a -> String
text = do
        String
val <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> String
text (MatchRule -> Maybe a
get MatchRule
rule)
        forall (m :: * -> *) a. Monad m => a -> m a
return (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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing

checkMatchRule :: MatchRule -> Signal -> Bool
checkMatchRule :: MatchRule -> Signal -> Bool
checkMatchRule MatchRule
rule Signal
msg = forall (t :: * -> *). Foldable t => t Bool -> Bool
and
    [ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\BusName
x -> Signal -> Maybe BusName
signalSender Signal
msg forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just BusName
x) (MatchRule -> Maybe BusName
matchSender MatchRule
rule)
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\BusName
x -> Signal -> Maybe BusName
signalDestination Signal
msg forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just BusName
x) (MatchRule -> Maybe BusName
matchDestination MatchRule
rule)
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Eq a => a -> a -> Bool
== Signal -> ObjectPath
signalPath Signal
msg) (MatchRule -> Maybe ObjectPath
matchPath MatchRule
rule)
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Eq a => a -> a -> Bool
== Signal -> InterfaceName
signalInterface Signal
msg) (MatchRule -> Maybe InterfaceName
matchInterface MatchRule
rule)
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Eq a => a -> a -> Bool
== Signal -> MemberName
signalMember Signal
msg) (MatchRule -> Maybe MemberName
matchMember MatchRule
rule)
    , 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 = forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf 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
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
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 :: forall a. ErrorName -> String -> [Variant] -> IO a
throwError ErrorName
name String
message [Variant]
extra = forall e a. Exception e => e -> IO a
Control.Exception.throwIO (ErrorName -> [Variant] -> MethodExc
MethodExc ErrorName
name (forall a. IsVariant a => a -> Variant
toVariant String
message forall a. a -> [a] -> [a]
: [Variant]
extra))


-- Method construction

returnInvalidParameters :: Monad m => m Reply
returnInvalidParameters :: forall (m :: * -> *). Monad m => m Reply
returnInvalidParameters = forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall a. IsVariant a => a -> [Variant]
handleTopLevelReturn a
value =
  case forall a. IsVariant a => a -> Variant
toVariant a
value of
    T.Variant (T.ValueStructure [Value]
xs) -> 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 = forall a. AutoMethod a => a -> ([Type], [Type])
funTypes (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 = forall a. AutoMethod a => a -> [Variant] -> DBusR Reply
apply (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 = forall a. IsValue a => Proxy a -> Type
typeOf' (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsVariant a => a -> [Variant]
handleTopLevelReturn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DBusR a
io
    apply DBusR a
_ [Variant]
_ = 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 = forall a. AutoMethod a => a -> ([Type], [Type])
funTypes (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 = forall a. AutoMethod a => a -> [Variant] -> DBusR Reply
apply (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 = forall a. IsValue a => Proxy a -> Type
typeOf' (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 [] = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id ([Variant] -> Reply
ReplyReturn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsVariant a => a -> [Variant]
handleTopLevelReturn) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DBusR (Either Reply a)
io
    apply DBusR (Either Reply a)
_ [Variant]
_ = 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 IsValue a => a -> (a, Type)
valueT forall a. HasCallStack => a
undefined of
            (a
a, Type
t) -> case forall a. AutoMethod a => a -> ([Type], [Type])
funTypes (a -> fn
fn a
a) of
                ([Type]
ts, [Type]
ts') -> (Type
t forall a. a -> [a] -> [a]
: [Type]
ts, [Type]
ts')

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

    apply :: (a -> fn) -> [Variant] -> DBusR Reply
apply a -> fn
_ [] = forall (m :: * -> *). Monad m => m Reply
returnInvalidParameters
    apply a -> fn
fn (Variant
v:[Variant]
vs) = case forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
v of
        Just a
v' -> forall a. AutoMethod a => a -> [Variant] -> DBusR Reply
apply (a -> fn
fn a
v') [Variant]
vs
        Maybe a
Nothing -> 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 :: forall fn. AutoMethod fn => MemberName -> fn -> Method
autoMethod MemberName
name fn
fun = forall fn.
AutoMethod fn =>
MemberName -> (MethodCall -> fn) -> Method
autoMethodWithMsg MemberName
name forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const fn
fun

autoMethodWithMsg :: (AutoMethod fn) => MemberName -> (MethodCall -> fn) -> Method
autoMethodWithMsg :: forall fn.
AutoMethod fn =>
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) = forall a. AutoMethod a => a -> ([Type], [Type])
funTypes (MethodCall -> fn
fun forall a. HasCallStack => a
undefined)
    inSig :: Signature
inSig = forall a. a -> Maybe a -> a
fromMaybe (String -> Signature
invalid String
"input") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => [Type] -> m Signature
signature [Type]
typesIn
    outSig :: Signature
outSig = forall a. a -> Maybe a -> a
fromMaybe (String -> Signature
invalid String
"output") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => [Type] -> m Signature
signature [Type]
typesOut
    io :: MethodCall -> DBusR Reply
io MethodCall
msg = 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 = forall a. HasCallStack => String -> a
error (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 :: forall v.
IsValue v =>
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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. IsVariant a => a -> Variant
toVariant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (IO v)
mgetter) (forall {m :: * -> *} {a}.
(Monad m, IsVariant a) =>
(a -> m ()) -> Variant -> m ()
variantSetter forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (v -> IO ())
msetter)
    where propType :: Type
propType = forall a. IsValue a => Proxy a -> Type
typeOf' (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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) a -> m ()
setter (forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
variant)
            in Variant -> m ()
newFun

readOnlyProperty :: (IsValue v) => MemberName -> IO v -> Property
readOnlyProperty :: forall v. IsValue v => MemberName -> IO v -> Property
readOnlyProperty MemberName
name IO v
getter = forall v.
IsValue v =>
MemberName -> Maybe (IO v) -> Maybe (v -> IO ()) -> Property
autoProperty MemberName
name (forall a. a -> Maybe a
Just IO v
getter) 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 <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
       forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch
        (forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch
            (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') -> forall (m :: * -> *) a. Monad m => a -> m a
return (ErrorName -> [Variant] -> Reply
ReplyError ErrorName
name' [Variant]
vs')))
        (\SomeException
exc -> forall (m :: * -> *) a. Monad m => a -> m a
return (ErrorName -> [Variant] -> Reply
ReplyError ErrorName
errorFailed
            [forall a. IsVariant a => a -> Variant
toVariant (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 =
  forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ (Client -> IORef PathInfo
clientObjects Client
client) 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 = forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ (Client -> IORef PathInfo
clientObjects Client
client) PathInfo -> PathInfo
clear
  where clear :: PathInfo -> PathInfo
clear = 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) forall a b. (a -> b) -> a -> b
$ 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 =
  I.Object
     { objectPath :: ObjectPath
I.objectPath = [String] -> ObjectPath
T.fromElements [String]
elems
     , objectInterfaces :: [Interface]
I.objectInterfaces =
       (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Interface]
interfaces then [] else [Interface]
defaultInterfaces) forall a. [a] -> [a] -> [a]
++
       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 = forall k a. Map k a -> [a]
M.elems forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ [String]
elems 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
  } =
  I.Interface
   { interfaceName :: InterfaceName
I.interfaceName = InterfaceName
name
   , interfaceMethods :: [Method]
I.interfaceMethods = forall a b. (a -> b) -> [a] -> [b]
map Method -> Method
buildIntrospectionMethod [Method]
methods
   , interfaceProperties :: [Property]
I.interfaceProperties = 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) =
  I.Property { propertyName :: String
I.propertyName = coerce :: forall a b. Coercible a b => a -> b
coerce MemberName
memberName
             , propertyType :: Type
I.propertyType = Type
ptype
             , propertyRead :: Bool
I.propertyRead = forall a. Maybe a -> Bool
isJust Maybe (IO Variant)
getter
             , propertyWrite :: Bool
I.propertyWrite = 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
  } = I.Method
    { methodName :: MemberName
I.methodName = MemberName
name
    , methodArgs :: [MethodArg]
I.methodArgs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Char -> (Type, Direction) -> MethodArg
makeMethodArg [Char
'a'..Char
'z'] forall a b. (a -> b) -> a -> b
$ [(Type, Direction)]
inTuples forall a. [a] -> [a] -> [a]
++ [(Type, Direction)]
outTuples
    }
  where inTuples :: [(Type, Direction)]
inTuples = forall a b. (a -> b) -> [a] -> [b]
map (, Direction
I.In) forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce Signature
inSig
        outTuples :: [(Type, Direction)]
outTuples = forall a b. (a -> b) -> [a] -> [b]
map (, Direction
I.Out) forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce Signature
outSig
        makeMethodArg :: Char -> (Type, Direction) -> MethodArg
makeMethodArg Char
nameChar (Type
t, Direction
dir) =
          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 = forall a. IsString a => String -> a
fromString String
"org.freedesktop.DBus.Properties"

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

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

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


-- Miscellaneous

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

atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ :: forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef a
ref a -> a
fn = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef a
ref (a -> a
fn forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& 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