module Desktop.Portal.Internal
( Client,
connect,
disconnect,
clientName,
Request,
sendRequest,
await,
cancel,
callMethod,
callMethod_,
SignalHandler,
handleSignal,
cancelSignalHandler,
)
where
import Control.Concurrent (MVar, putMVar, readMVar, tryPutMVar)
import Control.Concurrent.MVar (newEmptyMVar)
import Control.Exception (SomeException, catch, throwIO)
import Control.Monad (void, when)
import DBus (BusName, InterfaceName, MemberName, MethodCall, ObjectPath)
import DBus qualified
import DBus.Client (ClientError, MatchRule (..))
import DBus.Client qualified as DBus
import DBus.Internal.Message (Signal (..))
import DBus.Internal.Types (Variant)
import Data.Map (Map)
import Data.Map.Strict qualified as Map
import Data.Text (Text, pack, unpack)
import Data.Word (Word32, Word64)
import System.Random.Stateful qualified as R
data Client = Client
{ Client -> Client
dbusClient :: DBus.Client,
Client -> BusName
clientName :: BusName
}
instance Eq Client where
Client
a == :: Client -> Client -> Bool
== Client
b =
Client
a.dbusClient.clientThreadID forall a. Eq a => a -> a -> Bool
== Client
b.dbusClient.clientThreadID
instance Show Client where
show :: Client -> String
show Client
c =
String
"Client<" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Client
c.clientName forall a. Semigroup a => a -> a -> a
<> String
", " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Client
c.dbusClient.clientThreadID forall a. Semigroup a => a -> a -> a
<> String
">"
data Request a = Request
{ forall a. Request a -> Client
client :: Client,
forall a. Request a -> MethodCall
methodCall :: MethodCall,
forall a. Request a -> MVar SignalHandler
signalHandler :: MVar DBus.SignalHandler,
forall a. Request a -> MVar (Either SomeException (Maybe a))
result :: MVar (Either SomeException (Maybe a))
}
instance Eq (Request a) where
Request a
a == :: Request a -> Request a -> Bool
== Request a
b = Request a
a.result forall a. Eq a => a -> a -> Bool
== Request a
b.result
instance Show (Request a) where
show :: Request a -> String
show Request a
request =
String
"Request{client=<"
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Request a
request.client
forall a. Semigroup a => a -> a -> a
<> String
">, methodCall="
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Request a
request.methodCall
forall a. Semigroup a => a -> a -> a
<> String
", result=<MVar>}"
data SignalHandler = SignalHandler
{ SignalHandler -> Client
client :: Client,
SignalHandler -> SignalHandler
dbusSignalHandler :: DBus.SignalHandler
}
connect :: IO Client
connect :: IO Client
connect = do
Maybe Address
env <- IO (Maybe Address)
DBus.getSessionAddress
case Maybe Address
env of
Maybe Address
Nothing -> forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
DBus.clientError String
"connect: session address not found.")
Just Address
addr -> do
(Client
dbusClient, BusName
clientName) <- forall t.
TransportOpen t =>
ClientOptions t -> Address -> IO (Client, BusName)
DBus.connectWithName ClientOptions SocketTransport
DBus.defaultClientOptions Address
addr
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client {Client
dbusClient :: Client
$sel:dbusClient:Client :: Client
dbusClient, BusName
clientName :: BusName
$sel:clientName:Client :: BusName
clientName}
disconnect :: Client -> IO ()
disconnect :: Client -> IO ()
disconnect Client
client = do
Client -> IO ()
DBus.disconnect Client
client.dbusClient
clientName :: Client -> BusName
clientName :: Client -> BusName
clientName = (.clientName)
await :: Request a -> IO (Maybe a)
await :: forall a. Request a -> IO (Maybe a)
await Request a
request = do
forall a. MVar a -> IO a
readMVar Request a
request.result forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left SomeException
exn -> forall e a. Exception e => e -> IO a
throwIO SomeException
exn
Right Maybe a
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
res
cancel :: Request a -> IO ()
cancel :: forall a. Request a -> IO ()
cancel Request a
request = do
Bool
putSucceeded <- forall a. MVar a -> a -> IO Bool
tryPutMVar Request a
request.result (forall a b. b -> Either a b
Right forall a. Maybe a
Nothing)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
putSucceeded forall a b. (a -> b) -> a -> b
$ do
forall a. MVar a -> IO a
readMVar Request a
request.signalHandler
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Client -> SignalHandler -> IO ()
DBus.removeMatch Request a
request.client.dbusClient
sendRequest ::
Client ->
InterfaceName ->
MemberName ->
[Variant] ->
Map Text Variant ->
(Map Text Variant -> IO a) ->
IO (Request a)
sendRequest :: forall a.
Client
-> InterfaceName
-> MemberName
-> [Variant]
-> Map Text Variant
-> (Map Text Variant -> IO a)
-> IO (Request a)
sendRequest Client
client InterfaceName
interface MemberName
memberName [Variant]
parameters Map Text Variant
options Map Text Variant -> IO a
parseResponse = do
(ObjectPath
handle, Text
token) <- BusName -> IO (ObjectPath, Text)
requestHandle Client
client.clientName
MVar SignalHandler
signalHandlerVar <- forall a. IO (MVar a)
newEmptyMVar
MVar (Either SomeException (Maybe a))
resultVar <- forall a. IO (MVar a)
newEmptyMVar
SignalHandler
signalHandler <-
Client -> MatchRule -> (Signal -> IO ()) -> IO SignalHandler
DBus.addMatch
Client
client.dbusClient
MatchRule
DBus.matchAny
{ matchPath :: Maybe ObjectPath
matchPath = forall a. a -> Maybe a
Just ObjectPath
handle,
matchInterface :: Maybe InterfaceName
matchInterface = forall a. a -> Maybe a
Just InterfaceName
"org.freedesktop.portal.Request",
matchMember :: Maybe MemberName
matchMember = forall a. a -> Maybe a
Just MemberName
"Response"
}
( \Signal {[Variant]
signalBody :: Signal -> [Variant]
signalBody :: [Variant]
signalBody} -> do
Either SomeException (Maybe a)
val <- case [Variant]
signalBody of
[Variant
code, Variant
result]
| Just (Word32
0 :: Word32) <- forall a. IsVariant a => Variant -> Maybe a
DBus.fromVariant Variant
code,
Just (Map Text Variant
resMap :: Map Text Variant) <- forall a. IsVariant a => Variant -> Maybe a
DBus.fromVariant Variant
result -> do
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text Variant -> IO a
parseResponse Map Text Variant
resMap) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)
[Variant]
_ -> do
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right forall a. Maybe a
Nothing)
SignalHandler
signalHandler <- forall a. MVar a -> IO a
readMVar MVar SignalHandler
signalHandlerVar
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
(Client -> SignalHandler -> IO ()
DBus.removeMatch Client
client.dbusClient SignalHandler
signalHandler)
(\(ClientError
_ :: ClientError) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall a. MVar a -> a -> IO Bool
tryPutMVar MVar (Either SomeException (Maybe a))
resultVar Either SomeException (Maybe a)
val)
)
forall a. MVar a -> a -> IO ()
putMVar MVar SignalHandler
signalHandlerVar SignalHandler
signalHandler
let methodCall :: MethodCall
methodCall =
(InterfaceName -> MemberName -> MethodCall
portalMethodCall InterfaceName
interface MemberName
memberName)
{ methodCallBody :: [Variant]
DBus.methodCallBody =
[Variant]
parameters forall a. Semigroup a => a -> a -> a
<> [forall a. IsVariant a => a -> Variant
DBus.toVariant (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"handle_token" (forall a. IsVariant a => a -> Variant
DBus.toVariant Text
token) Map Text Variant
options)]
}
MethodReturn
reply <- Client -> MethodCall -> IO MethodReturn
DBus.call_ Client
client.dbusClient MethodCall
methodCall
case MethodReturn -> [Variant]
DBus.methodReturnBody MethodReturn
reply of
[Variant
x]
| Just (ObjectPath
objX :: ObjectPath) <- forall a. IsVariant a => Variant -> Maybe a
DBus.fromVariant Variant
x ->
if ObjectPath
objX forall a. Eq a => a -> a -> Bool
== ObjectPath
handle
then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a.
Client
-> MethodCall
-> MVar SignalHandler
-> MVar (Either SomeException (Maybe a))
-> Request a
Request Client
client MethodCall
methodCall MVar SignalHandler
signalHandlerVar MVar (Either SomeException (Maybe a))
resultVar)
else
let msg :: String
msg = String
"Unexpected handle: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ObjectPath
objX forall a. Semigroup a => a -> a -> a
<> String
" should be " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ObjectPath
handle forall a. Semigroup a => a -> a -> a
<> String
". Probably xdg-desktop-portal is too old."
in forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
DBus.clientError String
msg)
[Variant]
_ ->
forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
DBus.clientError (String
"Request reply in unexpected format: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show MethodReturn
reply))
callMethod ::
Client ->
InterfaceName ->
MemberName ->
[Variant] ->
IO [Variant]
callMethod :: Client -> InterfaceName -> MemberName -> [Variant] -> IO [Variant]
callMethod Client
client InterfaceName
interface MemberName
memberName [Variant]
methodCallBody = do
let methodCall :: MethodCall
methodCall = (InterfaceName -> MemberName -> MethodCall
portalMethodCall InterfaceName
interface MemberName
memberName) {[Variant]
methodCallBody :: [Variant]
methodCallBody :: [Variant]
DBus.methodCallBody}
MethodReturn -> [Variant]
DBus.methodReturnBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Client -> MethodCall -> IO MethodReturn
DBus.call_ Client
client.dbusClient MethodCall
methodCall
callMethod_ ::
Client ->
InterfaceName ->
MemberName ->
[Variant] ->
IO ()
callMethod_ :: Client -> InterfaceName -> MemberName -> [Variant] -> IO ()
callMethod_ Client
client InterfaceName
interface MemberName
memberName [Variant]
methodCallBody = do
let methodCall :: MethodCall
methodCall = (InterfaceName -> MemberName -> MethodCall
portalMethodCall InterfaceName
interface MemberName
memberName) {[Variant]
methodCallBody :: [Variant]
methodCallBody :: [Variant]
DBus.methodCallBody}
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Client -> MethodCall -> IO (Either MethodError MethodReturn)
DBus.call Client
client.dbusClient MethodCall
methodCall)
handleSignal :: Client -> InterfaceName -> MemberName -> ([Variant] -> IO ()) -> IO SignalHandler
handleSignal :: Client
-> InterfaceName
-> MemberName
-> ([Variant] -> IO ())
-> IO SignalHandler
handleSignal Client
client InterfaceName
interface MemberName
memberName [Variant] -> IO ()
handler = do
SignalHandler
dbusSignalHandler <-
Client -> MatchRule -> (Signal -> IO ()) -> IO SignalHandler
DBus.addMatch
Client
client.dbusClient
MatchRule
DBus.matchAny
{ matchInterface :: Maybe InterfaceName
matchInterface = forall a. a -> Maybe a
Just InterfaceName
interface,
matchMember :: Maybe MemberName
matchMember = forall a. a -> Maybe a
Just MemberName
memberName,
matchDestination :: Maybe BusName
matchDestination = forall a. a -> Maybe a
Just Client
client.clientName
}
(\Signal {[Variant]
signalBody :: [Variant]
signalBody :: Signal -> [Variant]
signalBody} -> [Variant] -> IO ()
handler [Variant]
signalBody)
forall (f :: * -> *) a. Applicative f => a -> f a
pure SignalHandler {SignalHandler
dbusSignalHandler :: SignalHandler
$sel:dbusSignalHandler:SignalHandler :: SignalHandler
dbusSignalHandler, Client
client :: Client
$sel:client:SignalHandler :: Client
client}
cancelSignalHandler :: SignalHandler -> IO ()
cancelSignalHandler :: SignalHandler -> IO ()
cancelSignalHandler SignalHandler
handler =
Client -> SignalHandler -> IO ()
DBus.removeMatch SignalHandler
handler.client.dbusClient SignalHandler
handler.dbusSignalHandler
requestToken :: IO Text
requestToken :: IO Text
requestToken = do
(Word64
rnd :: Word64) <- forall a g (m :: * -> *). (Uniform a, StatefulGen g m) => g -> m a
R.uniformM AtomicGenM StdGen
R.globalStdGen
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"haskell_desktop_portal_" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show Word64
rnd))
requestHandle :: BusName -> IO (ObjectPath, Text)
requestHandle :: BusName -> IO (ObjectPath, Text)
requestHandle BusName
clientName = do
Text
token <- IO Text
requestToken
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> ObjectPath
DBus.objectPath_ (String
"/org/freedesktop/portal/desktop/request/" forall a. Semigroup a => a -> a -> a
<> BusName -> String
escapeClientName BusName
clientName forall a. Semigroup a => a -> a -> a
<> String
"/" forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
token), Text
token)
where
escapeClientName :: BusName -> String
escapeClientName =
forall a b. (a -> b) -> [a] -> [b]
map (\case Char
'.' -> Char
'_'; Char
c -> Char
c) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. BusName -> String
DBus.formatBusName
portalMethodCall :: InterfaceName -> MemberName -> MethodCall
portalMethodCall :: InterfaceName -> MemberName -> MethodCall
portalMethodCall InterfaceName
interface MemberName
memberName =
(ObjectPath -> InterfaceName -> MemberName -> MethodCall
DBus.methodCall ObjectPath
"/org/freedesktop/portal/desktop" InterfaceName
interface MemberName
memberName)
{ methodCallDestination :: Maybe BusName
DBus.methodCallDestination = forall a. a -> Maybe a
Just BusName
"org.freedesktop.portal.Desktop"
}