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 ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== Client
b.dbusClient.clientThreadID

instance Show Client where
  show :: Client -> String
show Client
c =
    String
"Client<" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> BusName -> String
forall a. Show a => a -> String
show Client
c.clientName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ThreadId -> String
forall a. Show a => a -> String
show Client
c.dbusClient.clientThreadID String -> ShowS
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 MVar (Either SomeException (Maybe a))
-> MVar (Either SomeException (Maybe a)) -> Bool
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=<"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Client -> String
forall a. Show a => a -> String
show Request a
request.client
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
">, methodCall="
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> MethodCall -> String
forall a. Show a => a -> String
show Request a
request.methodCall
      String -> ShowS
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 -> ClientError -> IO Client
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 {DBus.socketAuthenticator}
          clientOptions :: ClientOptions SocketTransport
clientOptions = ClientOptions SocketTransport
DBus.defaultClientOptions {DBus.clientSocketOptions}
      (Client
dbusClient, BusName
cName) <- ClientOptions SocketTransport -> Address -> IO (Client, BusName)
forall t.
TransportOpen t =>
ClientOptions t -> Address -> IO (Client, BusName)
DBus.connectWithName ClientOptions SocketTransport
clientOptions Address
addr
      Client -> IO Client
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client {Client
$sel:dbusClient:Client :: Client
dbusClient :: 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
  MVar (Either SomeException (Maybe a))
-> IO (Either SomeException (Maybe a))
forall a. MVar a -> IO a
readMVar Request a
request.result IO (Either SomeException (Maybe a))
-> (Either SomeException (Maybe a) -> IO (Maybe a)) -> IO (Maybe a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left SomeException
exn -> SomeException -> IO (Maybe a)
forall e a. Exception e => e -> IO a
throwIO SomeException
exn
    Right Maybe a
res -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
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 <- MVar (Either SomeException (Maybe a))
-> Either SomeException (Maybe a) -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar Request a
request.result (Maybe a -> Either SomeException (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
putSucceeded (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    MVar SignalHandler -> IO SignalHandler
forall a. MVar a -> IO a
readMVar Request a
request.signalHandler
      IO SignalHandler -> (SignalHandler -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
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 <- IO (MVar SignalHandler)
forall a. IO (MVar a)
newEmptyMVar
  MVar (Either SomeException (Maybe a))
resultVar <- IO (MVar (Either SomeException (Maybe a)))
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 = Just handle,
          matchInterface = Just "org.freedesktop.portal.Request",
          matchMember = Just "Response"
        }
      ( \Signal {[Variant]
signalBody :: [Variant]
signalBody :: Signal -> [Variant]
signalBody} -> do
          Either SomeException (Maybe a)
val <- case [Variant]
signalBody of
            [Variant
code, Variant
result]
              | Just (Word32
0 :: Word32) <- Variant -> Maybe Word32
forall a. IsVariant a => Variant -> Maybe a
DBus.fromVariant Variant
code,
                Just (Map Text Variant
resMap :: Map Text Variant) <- Variant -> Maybe (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'
                  IO (Either SomeException (Maybe a))
-> (SomeException -> IO (Either SomeException (Maybe a)))
-> IO (Either SomeException (Maybe a))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Maybe a -> Either SomeException (Maybe a)
forall a b. b -> Either a b
Right (Maybe a -> Either SomeException (Maybe a))
-> (a -> Maybe a) -> a -> Either SomeException (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just (a -> Either SomeException (Maybe a))
-> IO a -> IO (Either SomeException (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text Variant -> IO a
parseResponse Map Text Variant
resMap) (Either SomeException (Maybe a)
-> IO (Either SomeException (Maybe a))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException (Maybe a)
 -> IO (Either SomeException (Maybe a)))
-> (SomeException -> Either SomeException (Maybe a))
-> SomeException
-> IO (Either SomeException (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException (Maybe a)
forall a b. a -> Either a b
Left)
            [Variant]
_ -> do
              Either SomeException (Maybe a)
-> IO (Either SomeException (Maybe a))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Either SomeException (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing)
          SignalHandler
signalHandler <- MVar SignalHandler -> IO 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!)
          IO () -> (ClientError -> IO ()) -> IO ()
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) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
          -- need to try because cancel might have been called and populated the mvar with Nothing
          IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MVar (Either SomeException (Maybe a))
-> Either SomeException (Maybe a) -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar (Either SomeException (Maybe a))
resultVar Either SomeException (Maybe a)
val)
      )
  MVar SignalHandler -> SignalHandler -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar SignalHandler
signalHandlerVar SignalHandler
signalHandler

  let methodCall :: MethodCall
methodCall =
        (InterfaceName -> MemberName -> MethodCall
portalMethodCall InterfaceName
interface MemberName
memberName)
          { DBus.methodCallBody =
              parameters <> [DBus.toVariant (Map.insert "handle_token" (DBus.toVariant token) 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) <- Variant -> Maybe ObjectPath
forall a. IsVariant a => Variant -> Maybe a
DBus.fromVariant Variant
x ->
          if ObjectPath
objX ObjectPath -> ObjectPath -> Bool
forall a. Eq a => a -> a -> Bool
== ObjectPath
handle
            then Request a -> IO (Request a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client
-> MethodCall
-> MVar SignalHandler
-> MVar (Either SomeException (Maybe a))
-> Request a
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: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ObjectPath -> String
forall a. Show a => a -> String
show ObjectPath
objX String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" should be " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ObjectPath -> String
forall a. Show a => a -> String
show ObjectPath
handle String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
". Probably xdg-desktop-portal is too old."
               in ClientError -> IO (Request a)
forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
DBus.clientError String
msg)
    [Variant]
_ ->
      ClientError -> IO (Request a)
forall e a. Exception e => e -> IO a
throwIO (String -> ClientError
DBus.clientError (String
"Request reply in unexpected format: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> MethodReturn -> String
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) {DBus.methodCallBody}
  MethodReturn -> [Variant]
DBus.methodReturnBody (MethodReturn -> [Variant]) -> IO MethodReturn -> IO [Variant]
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)
          { DBus.methodCallDestination = Just busName,
            DBus.methodCallBody
          }
  MethodReturn -> [Variant]
DBus.methodReturnBody (MethodReturn -> [Variant]) -> IO MethodReturn -> IO [Variant]
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
  Client -> MethodCall -> IO (Either MethodError a)
forall a.
IsValue a =>
Client -> MethodCall -> IO (Either MethodError a)
DBus.getPropertyValue Client
client.dbusClient MethodCall
methodCall IO (Either MethodError a) -> (Either MethodError a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left MethodError
err ->
      ClientError -> IO a
forall e a. Exception e => e -> IO a
throwIO (ClientError -> IO a) -> (String -> ClientError) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ClientError
DBus.clientError (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"getPropertyValue failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> MethodError -> String
forall a. Show a => a -> String
show MethodError
err
    Right a
a ->
      a -> IO a
forall a. a -> IO 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 = Just interface,
          matchMember = Just memberName,
          matchDestination = Just client.clientName
        }
      (\Signal {[Variant]
signalBody :: Signal -> [Variant]
signalBody :: [Variant]
signalBody} -> [Variant] -> IO ()
handler [Variant]
signalBody)
  SignalHandler -> IO SignalHandler
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SignalHandler {SignalHandler
$sel:dbusSignalHandler:SignalHandler :: SignalHandler
dbusSignalHandler :: SignalHandler
dbusSignalHandler, Client
$sel:client:SignalHandler :: Client
client :: 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) <- AtomicGenM StdGen -> IO Word64
forall a g (m :: * -> *). (Uniform a, StatefulGen g m) => g -> m a
forall g (m :: * -> *). StatefulGen g m => g -> m Word64
R.uniformM AtomicGenM StdGen
R.globalStdGen
  Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"haskell_desktop_portal_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Word64 -> String
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
  (ObjectPath, Text) -> IO (ObjectPath, Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> ObjectPath
DBus.objectPath_ (String
"/org/freedesktop/portal/desktop/request/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> BusName -> String
escapeClientName BusName
cName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
token), Text
token)
  where
    escapeClientName :: BusName -> String
escapeClientName =
      (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\case Char
'.' -> Char
'_'; Char
c -> Char
c) ShowS -> (BusName -> String) -> BusName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 ShowS -> (BusName -> String) -> BusName -> String
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)
    { DBus.methodCallDestination = Just 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
(FileSpec -> FileSpec -> Bool)
-> (FileSpec -> FileSpec -> Bool) -> Eq FileSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileSpec -> FileSpec -> Bool
== :: FileSpec -> FileSpec -> Bool
$c/= :: FileSpec -> FileSpec -> Bool
/= :: FileSpec -> FileSpec -> Bool
Eq, Int -> FileSpec -> ShowS
[FileSpec] -> ShowS
FileSpec -> String
(Int -> FileSpec -> ShowS)
-> (FileSpec -> String) -> ([FileSpec] -> ShowS) -> Show FileSpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FileSpec -> ShowS
showsPrec :: Int -> FileSpec -> ShowS
$cshow :: FileSpec -> String
show :: FileSpec -> String
$cshowList :: [FileSpec] -> ShowS
showList :: [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 <- OsPath -> IO String
forall (m :: * -> *). MonadThrow m => OsPath -> m String
OsPath.decodeUtf OsPath
path
    IO Fd -> (Fd -> IO ()) -> (Fd -> IO a) -> IO a
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 ([Fd] -> [Fd]
forall a. [a] -> [a]
reverse [Fd]
fds)
      FileSpec
file : [FileSpec]
files' ->
        FileSpec -> (Fd -> IO a) -> IO a
forall a. FileSpec -> (Fd -> IO a) -> IO a
withFd FileSpec
file ((Fd -> IO a) -> IO a) -> (Fd -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Fd
fd -> do
          [Fd] -> [FileSpec] -> IO a
withFdsRec (Fd
fd Fd -> [Fd] -> [Fd]
forall a. a -> [a] -> [a]
: [Fd]
fds) [FileSpec]
files'