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

-- | A handle for an active desktop portal session. Can send requests and listen for signals.
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
">"

-- | A portal request that may be in-progress, finished, or cancelled.
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>}"

-- | A listener for a particular signal. Can be cancelled with 'cancelSignalHandler'.
data SignalHandler = SignalHandler
  { SignalHandler -> Client
client :: Client,
    SignalHandler -> SignalHandler
dbusSignalHandler :: DBus.SignalHandler
  }

-- | Open a new client connection. This can be used to send requests and listen for signals
-- and finally can be closed using 'disconnect'.
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

-- | Get the unique name given to the client by D-BUS.
clientName :: Client -> BusName
clientName :: Client -> BusName
clientName = (.clientName)

-- | Wait for a request to be finished, and return the result if it succeeded. If the
-- request is cancelled, either by the user interface or by calling 'cancel', then
-- 'Nothing' will be returned.
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 a request. This will cause any threads blocked on 'await' to receive 'Nothing'.
-- Has no effect if the client is already cancelled or finished successfully.
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

-- | Send a request to the desktop portal D-Bus object and return a handle to the response data.
sendRequest ::
  Client ->
  -- | Which portal interface to invoke.
  InterfaceName ->
  -- | Which method to invoke on that interface.
  MemberName ->
  -- | Positional arguments to pass to the method.
  [Variant] ->
  -- | Named arguments to pass to the method.
  Map Text Variant ->
  -- | A function to parse the method response.
  (Map Text Variant -> IO a) ->
  -- | A handle to the in-progress method call.
  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

  -- listen before sending the request, to avoid a race condition where the
  -- response happens before we get a chance to register the listener for it
  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
                  -- catch here: it will be re-thrown in the thread that calls 'await'
                  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
          -- removing match can fail because the client is already disconnected, since this happens
          -- asynchronously, so we have to ignore that (happens all the time during unit tests!)
          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 ())
          -- need to try because cancel might have been called and populated the mvar with Nothing
          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))

-- | Call a method on the desktop portal D-Bus object, and read the response directly
-- rather than asynchronously via a request object.
callMethod ::
  Client ->
  -- | Which portal interface to invoke.
  InterfaceName ->
  -- | Which method to invoke on that interface.
  MemberName ->
  -- | Arguments to pass to the method.
  [Variant] ->
  -- | The response from the method call.
  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

-- | Call a method on the desktop portal D-Bus object, but ignore the response.
callMethod_ ::
  Client ->
  -- | Which portal interface to invoke.
  InterfaceName ->
  -- | Which method to invoke on that interface.
  MemberName ->
  -- | Arguments to pass to the method.
  [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}

-- | Prevent any future invocations of the given signal handler.
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"
    }