module Desktop.Portal.Internal
  ( Client,
    connect,
    disconnect,
    clientName,
    Request,
    sendRequest,
    await,
    cancel,
    callMethod,
    callMethod_,
    getPropertyValue,
    SignalHandler,
    handleSignal,
    cancelSignalHandler,
    FileSpec (..),
    withFd,
    withFds,
  )
where

import Control.Concurrent (MVar, putMVar, readMVar, tryPutMVar)
import Control.Concurrent.MVar (newEmptyMVar)
import Control.Exception (SomeException, bracket, catch, throwIO)
import Control.Monad (void, when)
import DBus (BusName, InterfaceName, IsValue, 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 DBus.Socket qualified as DBus
import Data.Map (Map)
import Data.Map.Strict qualified as Map
import Data.Text (Text, pack, unpack)
import Data.Word (Word32, Word64)
import System.OsPath (OsPath)
import System.OsPath qualified as OsPath
import System.Posix (Fd, OpenMode (..), closeFd, defaultFileFlags, openFd)
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
      let socketAuthenticator :: Authenticator SocketTransport
socketAuthenticator = Authenticator SocketTransport
DBus.authenticatorWithUnixFds
          clientSocketOptions :: SocketOptions SocketTransport
clientSocketOptions = SocketOptions SocketTransport
DBus.defaultSocketOptions {Authenticator SocketTransport
socketAuthenticator :: Authenticator SocketTransport
socketAuthenticator :: Authenticator SocketTransport
DBus.socketAuthenticator}
          clientOptions :: ClientOptions SocketTransport
clientOptions = ClientOptions SocketTransport
DBus.defaultClientOptions {SocketOptions SocketTransport
clientSocketOptions :: SocketOptions SocketTransport
clientSocketOptions :: SocketOptions SocketTransport
DBus.clientSocketOptions}
      (Client
dbusClient, BusName
cName) <- forall t.
TransportOpen t =>
ClientOptions t -> Address -> IO (Client, BusName)
DBus.connectWithName ClientOptions SocketTransport
clientOptions Address
addr
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Client {Client
dbusClient :: Client
$sel:dbusClient:Client :: Client
dbusClient, $sel:clientName:Client :: BusName
clientName = BusName
cName}

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 specified D-Bus object, and read the response directly
-- rather than asynchronously via a request object.
callMethod_ ::
  Client ->
  -- | The client that has the object.
  BusName ->
  -- | Which object to call.
  ObjectPath ->
  -- | Which 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
-> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> [Variant]
-> IO [Variant]
callMethod_ Client
client BusName
busName ObjectPath
object InterfaceName
interface MemberName
memberName [Variant]
methodCallBody = do
  let methodCall :: MethodCall
methodCall =
        (ObjectPath -> InterfaceName -> MemberName -> MethodCall
DBus.methodCall ObjectPath
object InterfaceName
interface MemberName
memberName)
          { methodCallDestination :: Maybe BusName
DBus.methodCallDestination = forall a. a -> Maybe a
Just BusName
busName,
            [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

getPropertyValue :: (IsValue a) => Client -> InterfaceName -> MemberName -> IO a
getPropertyValue :: forall a.
IsValue a =>
Client -> InterfaceName -> MemberName -> IO a
getPropertyValue Client
client InterfaceName
interface MemberName
memberName = do
  let methodCall :: MethodCall
methodCall = InterfaceName -> MemberName -> MethodCall
portalMethodCall InterfaceName
interface MemberName
memberName
  forall a.
IsValue a =>
Client -> MethodCall -> IO (Either MethodError a)
DBus.getPropertyValue Client
client.dbusClient MethodCall
methodCall forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left MethodError
err ->
      forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ClientError
DBus.clientError forall a b. (a -> b) -> a -> b
$ String
"getPropertyValue failed: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show MethodError
err
    Right a
a ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

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
cName = 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
cName 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
portalBusName
    }

portalBusName :: BusName
portalBusName :: BusName
portalBusName = BusName
"org.freedesktop.portal.Desktop"

-- | Specifies a file, either with a file descriptor or a path (which will be
-- resolved to a file descriptor before passing it to the portals API, since
-- the API typically requires file descriptors).
data FileSpec
  = FileSpecPath OsPath
  | FileSpecFd Fd
  deriving (FileSpec -> FileSpec -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileSpec -> FileSpec -> Bool
$c/= :: FileSpec -> FileSpec -> Bool
== :: FileSpec -> FileSpec -> Bool
$c== :: FileSpec -> FileSpec -> Bool
Eq, Int -> FileSpec -> ShowS
[FileSpec] -> ShowS
FileSpec -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FileSpec] -> ShowS
$cshowList :: [FileSpec] -> ShowS
show :: FileSpec -> String
$cshow :: FileSpec -> String
showsPrec :: Int -> FileSpec -> ShowS
$cshowsPrec :: Int -> FileSpec -> ShowS
Show)

withFd :: FileSpec -> (Fd -> IO a) -> IO a
withFd :: forall a. FileSpec -> (Fd -> IO a) -> IO a
withFd FileSpec
spec Fd -> IO a
cmd = case FileSpec
spec of
  FileSpecFd Fd
fd ->
    Fd -> IO a
cmd Fd
fd
  FileSpecPath OsPath
path -> do
    String
filePath <- forall (m :: * -> *). MonadThrow m => OsPath -> m String
OsPath.decodeUtf OsPath
path
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> OpenMode -> OpenFileFlags -> IO Fd
openFd String
filePath OpenMode
ReadOnly OpenFileFlags
defaultFileFlags) Fd -> IO ()
closeFd Fd -> IO a
cmd

withFds :: forall a. [FileSpec] -> ([Fd] -> IO a) -> IO a
withFds :: forall a. [FileSpec] -> ([Fd] -> IO a) -> IO a
withFds [FileSpec]
files [Fd] -> IO a
cmd = [Fd] -> [FileSpec] -> IO a
withFdsRec [] [FileSpec]
files
  where
    withFdsRec :: [Fd] -> [FileSpec] -> IO a
withFdsRec [Fd]
fds = \case
      [] ->
        [Fd] -> IO a
cmd (forall a. [a] -> [a]
reverse [Fd]
fds)
      FileSpec
file : [FileSpec]
files' ->
        forall a. FileSpec -> (Fd -> IO a) -> IO a
withFd FileSpec
file forall a b. (a -> b) -> a -> b
$ \Fd
fd -> do
          [Fd] -> [FileSpec] -> IO a
withFdsRec (Fd
fd forall a. a -> [a] -> [a]
: [Fd]
fds) [FileSpec]
files'