{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module: SignalDBus.Interface
Description: Low-Level IO with DBus
Copyright: (c) Lia Lenckowski, 2022
License: AGPL
Maintainer: lialenck@protonmail.com
Stability: experimental
Portability: GNU/Linux, MacOS
Except for things reexported elsewhere, this module is mainly meant for internal usage.
However, if you require APIs not implemented by the main module, you may use these functions
to implement them.
-}
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 s = bracket
(SignalConn (fromString $ "/org/asamk/Signal" ++ s) <$> liftIO connectSession)
$ \(SignalConn _ c) -> liftIO $ disconnect c
-- |Run an action that requires a signal connection, and return its result
withConn :: MonadUnliftIO m => (SignalConn -> m a) -> m a
withConn = withConnS ""
-- |Like 'withConn', but you have to manually specify a phone number to use, which is
-- useful if the signal daemon doesn't have a default number.
-- This may not be used with a signal-cli daemon that has a default number configured.
withConnNum :: MonadUnliftIO m => String -> (SignalConn -> m a) -> m a
withConnNum n = withConnS $ fromString "/_" ++ tail n
-- above usage of 'tail' because signal-cli doesn't want a '+' in front
-- |Run an action that receives a callback to receive new messages, and return its
-- result. This will /not/ yield messages that were received prior to calling this.
withReceiveMessages :: MonadUnliftIO m
=> SignalConn
-> (m ReceivedMessage -> m a)
-> m a
withReceiveMessages sc@(SignalConn _ c) cb = do
ch <- newChan
action <- toIO $ cb $ readChan ch
liftIO $ bracket
(addMatch c match $ processSig $ writeChan ch)
(removeMatch c)
$ const action
where match = matchAny { matchInterface = Just "org.asamk.Signal" }
getGroup :: MonadUnliftIO m => Variant -> m (Maybe Group)
getGroup g = fmap Just (callSC "getGroup" [g] sc)
`catch` \e -> const (return Nothing) (e :: ClientError)
processSig fwd s = do
let memb = signalMember s
body = signalBody s
m <- case (memb, body) of
("SyncMessageReceived", [ts, n, _, g, msg, as]) -> do
may_g <- getGroup g
return $! SyncMessage <$> fromVariant ts <*> fromVariant n
<*> return may_g <*> fromVariant msg <*> fromVariant as
("ReceiptReceived", [ts, n]) ->
return $! Receipt <$> fromVariant ts <*> fromVariant n
("MessageReceived", [ts, n, g, msg, as]) -> do
may_g <- getGroup g
return $! Message <$> fromVariant ts <*> fromVariant n
<*> return may_g <*> fromVariant msg <*> fromVariant as
_ -> return $! Nothing
case m of
Just x -> fwd x
Nothing -> return ()
-- |INTERNAL. Call method from the Signal.Control interface, and return its result.
callControl :: (MonadIO m, IsVariant a) => MemberName -> [Variant] -> SignalConn -> m a
callControl meth args (SignalConn _ c) = callSC meth args
$ SignalConn "/org/asamk/Signal" c
-- |INTERNAL. Call method from the Signal.Control interface, expecting no return value.
callControl_ :: MonadIO m => MemberName -> [Variant] -> SignalConn -> m ()
callControl_ meth args (SignalConn _ c) = callSC_ meth args
$ SignalConn "/org/asamk/Signal" c
-- |INTERNAL. Call method from the main Signal interface, and return its result.
callSC :: (MonadIO m, IsVariant a) => MemberName -> [Variant] -> SignalConn -> m a
callSC meth args (SignalConn p c) = do
r <- liftIO $ call_ c
(methodCall p "org.asamk.Signal" meth)
{ methodCallDestination = Just "org.asamk.Signal",
methodCallBody = args }
case map fromVariant $ methodReturnBody r of
[Just x] -> return x
_ -> throwIO $ clientError $ "Unexpected reply: " ++ show r
-- |INTERNAL. Call method from the main Signal interface, expecting no return value.
callSC_ :: MonadIO m => MemberName -> [Variant] -> SignalConn -> m ()
callSC_ meth args (SignalConn p c) = do
_ <- liftIO $ call_ c
(methodCall p "org.asamk.Signal" meth)
{ methodCallDestination = Just "org.asamk.Signal",
methodCallBody = args }
return ()
-- |INTERNAL. Get group proptery
getGroupProp :: (MonadIO m, IsValue a) => MemberName -> Group -> SignalConn -> m a
getGroupProp prop (Group p) (SignalConn _ c) = do
r <- liftIO $ getPropertyValue c
(methodCall p "org.asamk.Signal.Group" prop)
{ methodCallDestination = Just "org.asamk.Signal" }
case r of
Right x -> return x
Left e -> throwIO $ clientError $ "Error getting property: " ++ show e
-- |INTERNAL. Set group proptery
setGroupProp :: (MonadIO m, IsValue a) => MemberName -> a -> Group -> SignalConn -> m ()
setGroupProp prop x (Group p) (SignalConn _ c) = do
r <- liftIO $ setPropertyValue c
(methodCall p "org.asamk.Signal.Group" prop)
{ methodCallDestination = Just "org.asamk.Signal" }
$ toVariant x
case r of
Nothing -> return ()
Just e -> throwIO $ clientError $ "Error setting property: " ++ show e
-- |INTERNAL. Call method from the Signal.Group interface, expecting no return value.
callGroup_ :: MonadIO m => MemberName -> [Variant] -> Group -> SignalConn -> m ()
callGroup_ meth args (Group p) (SignalConn _ c) = do
_ <- liftIO $ call_ c
(methodCall p "org.asamk.Signal.Group" meth)
{ methodCallDestination = Just "org.asamk.Signal",
methodCallBody = args }
return ()