module DBus.Client.Simple
(
Client
, connectSystem
, connectSession
, connectStarter
, disconnect
, emit
, Proxy
, proxy
, call
, DBus.Client.Simple.listen
, RequestNameFlag(..)
, RequestNameReply(..)
, ReleaseNameReply(..)
, requestName
, releaseName
, Method
, AutoSignature
, AutoReply
, method
, export
, throwError
, module DBus.Types
) where
import qualified Control.Exception
import Data.Bits ((.|.))
import qualified Data.Text
import qualified Data.Set
import Data.Word (Word32)
import DBus.Address
import DBus.Client hiding (call, method, emit, export)
import qualified DBus.Client
import DBus.Connection.Error
import DBus.Constants (errorInvalidParameters)
import DBus.Message hiding (errorName)
import DBus.Types
import DBus.Types.Internal (checkSignature)
import DBus.Util (maybeIndex)
connectFirst :: [Address] -> IO Client
connectFirst addrs = loop addrs where
loop [] = connectionError (concat
[ "connectFirst: no usable"
, " addresses in "
, show addrs])
loop (a:as) = Control.Exception.catch
(DBus.Client.connect a)
(\(ConnectionError _) -> loop as)
connectSession :: IO Client
connectSession = do
env <- DBus.Address.getSession
case env of
Nothing -> connectionError (concat
[ "connectSession: DBUS_SESSION_BUS_ADDRESS is"
, " missing or invalid."
])
Just addrs -> connectFirst addrs
connectSystem :: IO Client
connectSystem = do
env <- DBus.Address.getSystem
case env of
Nothing -> connectionError (concat
[ "connectSession: DBUS_SYSTEM_BUS_ADDRESS is"
, " invalid."
])
Just addrs -> connectFirst addrs
connectStarter :: IO Client
connectStarter = do
env <- DBus.Address.getStarter
case env of
Nothing -> connectionError (concat
[ "connectSession: DBUS_STARTER_BUS_ADDRESS is"
, " missing or invalid."
])
Just addrs -> connectFirst addrs
data Proxy = Proxy Client BusName ObjectPath
proxy :: Client -> BusName -> ObjectPath -> IO Proxy
proxy client dest path = return (Proxy client dest path)
call :: Proxy -> InterfaceName -> MemberName -> [Variant] -> IO [Variant]
call (Proxy client dest path) iface member body = do
reply <- DBus.Client.call_ client $ MethodCall
{ methodCallDestination = Just dest
, methodCallMember = member
, methodCallInterface = Just iface
, methodCallPath = path
, methodCallFlags = Data.Set.empty
, methodCallBody = body
}
return (methodReturnBody reply)
emit :: Client -> ObjectPath -> InterfaceName -> MemberName -> [Variant] -> IO ()
emit client path iface member body = DBus.Client.emit client $ Signal
{ signalDestination = Nothing
, signalPath = path
, signalInterface = iface
, signalMember = member
, signalBody = body
}
listen :: Proxy -> InterfaceName -> MemberName -> (BusName -> Signal -> IO ()) -> IO ()
listen (Proxy client dest path) iface member = DBus.Client.listen client (MatchRule
{ matchSender = Just dest
, matchInterface = Just iface
, matchMember = Just member
, matchPath = Just path
, matchDestination = Nothing
})
data RequestNameFlag
= AllowReplacement
| ReplaceExisting
| DoNotQueue
deriving (Show)
data RequestNameReply
= PrimaryOwner
| InQueue
| Exists
| AlreadyOwner
deriving (Show)
data ReleaseNameReply
= Released
| NonExistent
| NotOwner
deriving (Show)
encodeFlags :: [RequestNameFlag] -> Word32
encodeFlags = foldr (.|.) 0 . map flagValue where
flagValue AllowReplacement = 0x1
flagValue ReplaceExisting = 0x2
flagValue DoNotQueue = 0x4
requestName :: Client -> BusName -> [RequestNameFlag] -> IO RequestNameReply
requestName client name flags = do
bus <- proxy client "org.freedesktop.DBus" "/org/freedesktop/DBus"
reply <- call bus "org.freedesktop.DBus" "RequestName"
[ toVariant name
, toVariant (encodeFlags flags)
]
case (maybeIndex reply 0 >>= fromVariant :: Maybe Word32) of
Just 1 -> return PrimaryOwner
Just 2 -> return InQueue
Just 3 -> return Exists
Just 4 -> return AlreadyOwner
_ -> connectionError "Call failed: received invalid reply"
releaseName :: Client -> BusName -> IO ReleaseNameReply
releaseName client name = do
bus <- proxy client "org.freedesktop.DBus" "/org/freedesktop/DBus"
reply <- call bus "org.freedesktop.DBus" "ReleaseName"
[ toVariant name
]
case (maybeIndex reply 0 >>= fromVariant :: Maybe Word32) of
Just 1 -> return Released
Just 2 -> return NonExistent
Just 3 -> return NotOwner
_ -> connectionError "Call failed: received invalid reply"
class AutoSignature a where
funTypes :: a -> ([Type], [Type])
instance AutoSignature (IO ()) where
funTypes _ = ([], [])
instance IsValue a => AutoSignature (IO a) where
funTypes io = ([], case ioT io undefined of
(_, t) -> case t of
TypeStructure ts -> ts
_ -> [t])
ioT :: IsValue a => IO a -> a -> (a, Type)
ioT _ a = (a, typeOf a)
instance (IsValue a, AutoSignature fun) => AutoSignature (a -> fun) where
funTypes fn = case valueT undefined of
(a, t) -> case funTypes (fn a) of
(ts, ts') -> (t : ts, ts')
valueT :: IsValue a => a -> (a, Type)
valueT a = (a, typeOf a)
class AutoReply fun where
apply :: fun -> [Variant] -> Maybe (IO [Variant])
instance AutoReply (IO ()) where
apply io [] = Just (io >> return [])
apply _ _ = Nothing
instance IsVariant a => AutoReply (IO a) where
apply io [] = Just (do
var <- fmap toVariant io
case fromVariant var of
Just struct -> return (structureItems struct)
Nothing -> return [var])
apply _ _ = Nothing
instance (IsVariant a, AutoReply fun) => AutoReply (a -> fun) where
apply _ [] = Nothing
apply fn (v:vs) = case fromVariant v of
Just v' -> apply (fn v') vs
Nothing -> Nothing
method :: (AutoSignature fun, AutoReply fun) => InterfaceName -> MemberName -> fun -> Method
method iface name fun = DBus.Client.method iface name inSig outSig io where
(typesIn, typesOut) = funTypes fun
inSig = case checkSignature typesIn of
Just sig -> sig
Nothing -> invalid "input"
outSig = case checkSignature typesOut of
Just sig -> sig
Nothing -> invalid "output"
io vs = case apply fun vs of
Nothing -> return (ReplyError errorInvalidParameters [])
Just io' -> fmap ReplyReturn io'
invalid label = error (concat
[ "Method "
, Data.Text.unpack (interfaceNameText iface)
, "."
, Data.Text.unpack (memberNameText name)
, " has an invalid "
, label
, " signature."])
export :: Client -> ObjectPath -> [Method] -> IO ()
export = DBus.Client.export