{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module SignalDBus.Interface (
withConn,
withConnNum,
withReceiveMessages,
callSC,
callSC_,
callControl,
callControl_,
getGroupProp,
setGroupProp,
callGroup_,
) where
import Data.String (fromString)
import DBus hiding (ReceivedMessage(..))
import DBus.Client
import UnliftIO.Chan
import UnliftIO.Exception (bracket, catch)
import UnliftIO (MonadIO, MonadUnliftIO, liftIO, toIO, throwIO)
import SignalDBus.Types
withConnS :: MonadUnliftIO m => String -> (SignalConn -> m a) -> m a
withConnS :: String -> (SignalConn -> m a) -> m a
withConnS String
s = m SignalConn -> (SignalConn -> m ()) -> (SignalConn -> m a) -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
(ObjectPath -> Client -> SignalConn
SignalConn (String -> ObjectPath
forall a. IsString a => String -> a
fromString (String -> ObjectPath) -> String -> ObjectPath
forall a b. (a -> b) -> a -> b
$ String
"/org/asamk/Signal" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) (Client -> SignalConn) -> m Client -> m SignalConn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Client -> m Client
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Client
connectSession)
((SignalConn -> m ()) -> (SignalConn -> m a) -> m a)
-> (SignalConn -> m ()) -> (SignalConn -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \(SignalConn ObjectPath
_ Client
c) -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Client -> IO ()
disconnect Client
c
withConn :: MonadUnliftIO m => (SignalConn -> m a) -> m a
withConn :: (SignalConn -> m a) -> m a
withConn = String -> (SignalConn -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (SignalConn -> m a) -> m a
withConnS String
""
withConnNum :: MonadUnliftIO m => String -> (SignalConn -> m a) -> m a
withConnNum :: String -> (SignalConn -> m a) -> m a
withConnNum String
n = String -> (SignalConn -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (SignalConn -> m a) -> m a
withConnS (String -> (SignalConn -> m a) -> m a)
-> String -> (SignalConn -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. IsString a => String -> a
fromString String
"/_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
tail String
n
withReceiveMessages :: MonadUnliftIO m
=> SignalConn
-> (m ReceivedMessage -> m a)
-> m a
withReceiveMessages :: SignalConn -> (m ReceivedMessage -> m a) -> m a
withReceiveMessages sc :: SignalConn
sc@(SignalConn ObjectPath
_ Client
c) m ReceivedMessage -> m a
cb = do
Chan ReceivedMessage
ch <- m (Chan ReceivedMessage)
forall (m :: * -> *) a. MonadIO m => m (Chan a)
newChan
IO a
action <- m a -> m (IO a)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (m a -> m (IO a)) -> m a -> m (IO a)
forall a b. (a -> b) -> a -> b
$ m ReceivedMessage -> m a
cb (m ReceivedMessage -> m a) -> m ReceivedMessage -> m a
forall a b. (a -> b) -> a -> b
$ Chan ReceivedMessage -> m ReceivedMessage
forall (m :: * -> *) a. MonadIO m => Chan a -> m a
readChan Chan ReceivedMessage
ch
IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ IO SignalHandler
-> (SignalHandler -> IO ()) -> (SignalHandler -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
(Client -> MatchRule -> (Signal -> IO ()) -> IO SignalHandler
addMatch Client
c MatchRule
match ((Signal -> IO ()) -> IO SignalHandler)
-> (Signal -> IO ()) -> IO SignalHandler
forall a b. (a -> b) -> a -> b
$ (ReceivedMessage -> IO ()) -> Signal -> IO ()
forall (m :: * -> *).
MonadUnliftIO m =>
(ReceivedMessage -> m ()) -> Signal -> m ()
processSig ((ReceivedMessage -> IO ()) -> Signal -> IO ())
-> (ReceivedMessage -> IO ()) -> Signal -> IO ()
forall a b. (a -> b) -> a -> b
$ Chan ReceivedMessage -> ReceivedMessage -> IO ()
forall (m :: * -> *) a. MonadIO m => Chan a -> a -> m ()
writeChan Chan ReceivedMessage
ch)
(Client -> SignalHandler -> IO ()
removeMatch Client
c)
((SignalHandler -> IO a) -> IO a)
-> (SignalHandler -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> SignalHandler -> IO a
forall a b. a -> b -> a
const IO a
action
where match :: MatchRule
match = MatchRule
matchAny { matchInterface :: Maybe InterfaceName
matchInterface = InterfaceName -> Maybe InterfaceName
forall a. a -> Maybe a
Just InterfaceName
"org.asamk.Signal" }
getGroup :: MonadUnliftIO m => Variant -> m (Maybe Group)
getGroup :: Variant -> m (Maybe Group)
getGroup Variant
g = (Group -> Maybe Group) -> m Group -> m (Maybe Group)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Group -> Maybe Group
forall a. a -> Maybe a
Just (MemberName -> [Variant] -> SignalConn -> m Group
forall (m :: * -> *) a.
(MonadIO m, IsVariant a) =>
MemberName -> [Variant] -> SignalConn -> m a
callSC MemberName
"getGroup" [Variant
g] SignalConn
sc)
m (Maybe Group)
-> (ClientError -> m (Maybe Group)) -> m (Maybe Group)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \ClientError
e -> m (Maybe Group) -> ClientError -> m (Maybe Group)
forall a b. a -> b -> a
const (Maybe Group -> m (Maybe Group)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Group
forall a. Maybe a
Nothing) (ClientError
e :: ClientError)
processSig :: (ReceivedMessage -> m ()) -> Signal -> m ()
processSig ReceivedMessage -> m ()
fwd Signal
s = do
let memb :: MemberName
memb = Signal -> MemberName
signalMember Signal
s
body :: [Variant]
body = Signal -> [Variant]
signalBody Signal
s
Maybe ReceivedMessage
m <- case (MemberName
memb, [Variant]
body) of
(MemberName
"SyncMessageReceived", [Variant
ts, Variant
n, Variant
_, Variant
g, Variant
msg, Variant
as]) -> do
Maybe Group
may_g <- Variant -> m (Maybe Group)
forall (m :: * -> *). MonadUnliftIO m => Variant -> m (Maybe Group)
getGroup Variant
g
Maybe ReceivedMessage -> m (Maybe ReceivedMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReceivedMessage -> m (Maybe ReceivedMessage))
-> Maybe ReceivedMessage -> m (Maybe ReceivedMessage)
forall a b. (a -> b) -> a -> b
$! Timestamp
-> String -> Maybe Group -> String -> [String] -> ReceivedMessage
SyncMessage (Timestamp
-> String -> Maybe Group -> String -> [String] -> ReceivedMessage)
-> Maybe Timestamp
-> Maybe
(String -> Maybe Group -> String -> [String] -> ReceivedMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Variant -> Maybe Timestamp
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
ts Maybe
(String -> Maybe Group -> String -> [String] -> ReceivedMessage)
-> Maybe String
-> Maybe (Maybe Group -> String -> [String] -> ReceivedMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Variant -> Maybe String
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
n
Maybe (Maybe Group -> String -> [String] -> ReceivedMessage)
-> Maybe (Maybe Group)
-> Maybe (String -> [String] -> ReceivedMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Group -> Maybe (Maybe Group)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Group
may_g Maybe (String -> [String] -> ReceivedMessage)
-> Maybe String -> Maybe ([String] -> ReceivedMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Variant -> Maybe String
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
msg Maybe ([String] -> ReceivedMessage)
-> Maybe [String] -> Maybe ReceivedMessage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Variant -> Maybe [String]
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
as
(MemberName
"ReceiptReceived", [Variant
ts, Variant
n]) ->
Maybe ReceivedMessage -> m (Maybe ReceivedMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReceivedMessage -> m (Maybe ReceivedMessage))
-> Maybe ReceivedMessage -> m (Maybe ReceivedMessage)
forall a b. (a -> b) -> a -> b
$! Timestamp -> String -> ReceivedMessage
Receipt (Timestamp -> String -> ReceivedMessage)
-> Maybe Timestamp -> Maybe (String -> ReceivedMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Variant -> Maybe Timestamp
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
ts Maybe (String -> ReceivedMessage)
-> Maybe String -> Maybe ReceivedMessage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Variant -> Maybe String
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
n
(MemberName
"MessageReceived", [Variant
ts, Variant
n, Variant
g, Variant
msg, Variant
as]) -> do
Maybe Group
may_g <- Variant -> m (Maybe Group)
forall (m :: * -> *). MonadUnliftIO m => Variant -> m (Maybe Group)
getGroup Variant
g
Maybe ReceivedMessage -> m (Maybe ReceivedMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReceivedMessage -> m (Maybe ReceivedMessage))
-> Maybe ReceivedMessage -> m (Maybe ReceivedMessage)
forall a b. (a -> b) -> a -> b
$! Timestamp
-> String -> Maybe Group -> String -> [String] -> ReceivedMessage
Message (Timestamp
-> String -> Maybe Group -> String -> [String] -> ReceivedMessage)
-> Maybe Timestamp
-> Maybe
(String -> Maybe Group -> String -> [String] -> ReceivedMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Variant -> Maybe Timestamp
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
ts Maybe
(String -> Maybe Group -> String -> [String] -> ReceivedMessage)
-> Maybe String
-> Maybe (Maybe Group -> String -> [String] -> ReceivedMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Variant -> Maybe String
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
n
Maybe (Maybe Group -> String -> [String] -> ReceivedMessage)
-> Maybe (Maybe Group)
-> Maybe (String -> [String] -> ReceivedMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Group -> Maybe (Maybe Group)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Group
may_g Maybe (String -> [String] -> ReceivedMessage)
-> Maybe String -> Maybe ([String] -> ReceivedMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Variant -> Maybe String
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
msg Maybe ([String] -> ReceivedMessage)
-> Maybe [String] -> Maybe ReceivedMessage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Variant -> Maybe [String]
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
as
(MemberName, [Variant])
_ -> Maybe ReceivedMessage -> m (Maybe ReceivedMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReceivedMessage -> m (Maybe ReceivedMessage))
-> Maybe ReceivedMessage -> m (Maybe ReceivedMessage)
forall a b. (a -> b) -> a -> b
$! Maybe ReceivedMessage
forall a. Maybe a
Nothing
case Maybe ReceivedMessage
m of
Just ReceivedMessage
x -> ReceivedMessage -> m ()
fwd ReceivedMessage
x
Maybe ReceivedMessage
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
callControl :: (MonadIO m, IsVariant a) => MemberName -> [Variant] -> SignalConn -> m a
callControl :: MemberName -> [Variant] -> SignalConn -> m a
callControl MemberName
meth [Variant]
args (SignalConn ObjectPath
_ Client
c) = MemberName -> [Variant] -> SignalConn -> m a
forall (m :: * -> *) a.
(MonadIO m, IsVariant a) =>
MemberName -> [Variant] -> SignalConn -> m a
callSC MemberName
meth [Variant]
args
(SignalConn -> m a) -> SignalConn -> m a
forall a b. (a -> b) -> a -> b
$ ObjectPath -> Client -> SignalConn
SignalConn ObjectPath
"/org/asamk/Signal" Client
c
callControl_ :: MonadIO m => MemberName -> [Variant] -> SignalConn -> m ()
callControl_ :: MemberName -> [Variant] -> SignalConn -> m ()
callControl_ MemberName
meth [Variant]
args (SignalConn ObjectPath
_ Client
c) = MemberName -> [Variant] -> SignalConn -> m ()
forall (m :: * -> *).
MonadIO m =>
MemberName -> [Variant] -> SignalConn -> m ()
callSC_ MemberName
meth [Variant]
args
(SignalConn -> m ()) -> SignalConn -> m ()
forall a b. (a -> b) -> a -> b
$ ObjectPath -> Client -> SignalConn
SignalConn ObjectPath
"/org/asamk/Signal" Client
c
callSC :: (MonadIO m, IsVariant a) => MemberName -> [Variant] -> SignalConn -> m a
callSC :: MemberName -> [Variant] -> SignalConn -> m a
callSC MemberName
meth [Variant]
args (SignalConn ObjectPath
p Client
c) = do
MethodReturn
r <- IO MethodReturn -> m MethodReturn
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MethodReturn -> m MethodReturn)
-> IO MethodReturn -> m MethodReturn
forall a b. (a -> b) -> a -> b
$ Client -> MethodCall -> IO MethodReturn
call_ Client
c
(ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCall ObjectPath
p InterfaceName
"org.asamk.Signal" MemberName
meth)
{ methodCallDestination :: Maybe BusName
methodCallDestination = BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
"org.asamk.Signal",
methodCallBody :: [Variant]
methodCallBody = [Variant]
args }
case (Variant -> Maybe a) -> [Variant] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map Variant -> Maybe a
forall a. IsVariant a => Variant -> Maybe a
fromVariant ([Variant] -> [Maybe a]) -> [Variant] -> [Maybe a]
forall a b. (a -> b) -> a -> b
$ MethodReturn -> [Variant]
methodReturnBody MethodReturn
r of
[Just a
x] -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
[Maybe a]
_ -> ClientError -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ClientError -> m a) -> ClientError -> m a
forall a b. (a -> b) -> a -> b
$ String -> ClientError
clientError (String -> ClientError) -> String -> ClientError
forall a b. (a -> b) -> a -> b
$ String
"Unexpected reply: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MethodReturn -> String
forall a. Show a => a -> String
show MethodReturn
r
callSC_ :: MonadIO m => MemberName -> [Variant] -> SignalConn -> m ()
callSC_ :: MemberName -> [Variant] -> SignalConn -> m ()
callSC_ MemberName
meth [Variant]
args (SignalConn ObjectPath
p Client
c) = do
MethodReturn
_ <- IO MethodReturn -> m MethodReturn
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MethodReturn -> m MethodReturn)
-> IO MethodReturn -> m MethodReturn
forall a b. (a -> b) -> a -> b
$ Client -> MethodCall -> IO MethodReturn
call_ Client
c
(ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCall ObjectPath
p InterfaceName
"org.asamk.Signal" MemberName
meth)
{ methodCallDestination :: Maybe BusName
methodCallDestination = BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
"org.asamk.Signal",
methodCallBody :: [Variant]
methodCallBody = [Variant]
args }
() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
getGroupProp :: (MonadIO m, IsValue a) => MemberName -> Group -> SignalConn -> m a
getGroupProp :: MemberName -> Group -> SignalConn -> m a
getGroupProp MemberName
prop (Group ObjectPath
p) (SignalConn ObjectPath
_ Client
c) = do
Either MethodError a
r <- IO (Either MethodError a) -> m (Either MethodError a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either MethodError a) -> m (Either MethodError a))
-> IO (Either MethodError a) -> m (Either MethodError a)
forall a b. (a -> b) -> a -> b
$ Client -> MethodCall -> IO (Either MethodError a)
forall a.
IsValue a =>
Client -> MethodCall -> IO (Either MethodError a)
getPropertyValue Client
c
(ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCall ObjectPath
p InterfaceName
"org.asamk.Signal.Group" MemberName
prop)
{ methodCallDestination :: Maybe BusName
methodCallDestination = BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
"org.asamk.Signal" }
case Either MethodError a
r of
Right a
x -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
Left MethodError
e -> ClientError -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ClientError -> m a) -> ClientError -> m a
forall a b. (a -> b) -> a -> b
$ String -> ClientError
clientError (String -> ClientError) -> String -> ClientError
forall a b. (a -> b) -> a -> b
$ String
"Error getting property: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MethodError -> String
forall a. Show a => a -> String
show MethodError
e
setGroupProp :: (MonadIO m, IsValue a) => MemberName -> a -> Group -> SignalConn -> m ()
setGroupProp :: MemberName -> a -> Group -> SignalConn -> m ()
setGroupProp MemberName
prop a
x (Group ObjectPath
p) (SignalConn ObjectPath
_ Client
c) = do
Maybe MethodError
r <- IO (Maybe MethodError) -> m (Maybe MethodError)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe MethodError) -> m (Maybe MethodError))
-> IO (Maybe MethodError) -> m (Maybe MethodError)
forall a b. (a -> b) -> a -> b
$ Client -> MethodCall -> Variant -> IO (Maybe MethodError)
forall a.
IsValue a =>
Client -> MethodCall -> a -> IO (Maybe MethodError)
setPropertyValue Client
c
(ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCall ObjectPath
p InterfaceName
"org.asamk.Signal.Group" MemberName
prop)
{ methodCallDestination :: Maybe BusName
methodCallDestination = BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
"org.asamk.Signal" }
(Variant -> IO (Maybe MethodError))
-> Variant -> IO (Maybe MethodError)
forall a b. (a -> b) -> a -> b
$ a -> Variant
forall a. IsVariant a => a -> Variant
toVariant a
x
case Maybe MethodError
r of
Maybe MethodError
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just MethodError
e -> ClientError -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ClientError -> m ()) -> ClientError -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ClientError
clientError (String -> ClientError) -> String -> ClientError
forall a b. (a -> b) -> a -> b
$ String
"Error setting property: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MethodError -> String
forall a. Show a => a -> String
show MethodError
e
callGroup_ :: MonadIO m => MemberName -> [Variant] -> Group -> SignalConn -> m ()
callGroup_ :: MemberName -> [Variant] -> Group -> SignalConn -> m ()
callGroup_ MemberName
meth [Variant]
args (Group ObjectPath
p) (SignalConn ObjectPath
_ Client
c) = do
MethodReturn
_ <- IO MethodReturn -> m MethodReturn
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MethodReturn -> m MethodReturn)
-> IO MethodReturn -> m MethodReturn
forall a b. (a -> b) -> a -> b
$ Client -> MethodCall -> IO MethodReturn
call_ Client
c
(ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCall ObjectPath
p InterfaceName
"org.asamk.Signal.Group" MemberName
meth)
{ methodCallDestination :: Maybe BusName
methodCallDestination = BusName -> Maybe BusName
forall a. a -> Maybe a
Just BusName
"org.asamk.Signal",
methodCallBody :: [Variant]
methodCallBody = [Variant]
args }
() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()