module Desktop.Portal.DocumentsSpec (spec) where import Control.Monad (void) import DBus (BusName, InterfaceName, MemberName, ObjectPath, Type (..), Variant, fromVariant, toVariant, variantType) import Data.ByteString (ByteString) import Data.Text (Text) import Data.Word (Word32) import Desktop.Portal.Documents (AddFlag (..), ExtraResults (..), FileIdentifier (..), GrantPermission (..)) import Desktop.Portal.Documents qualified as Documents import Desktop.Portal.TestUtil import Desktop.Portal.TestUtil qualified as DBus import System.Posix (Fd) import Test.Hspec (Spec, around, describe, it, shouldBe, shouldReturn, shouldSatisfy) documentsInterface :: InterfaceName documentsInterface = "org.freedesktop.portal.Documents" documentsBusName :: BusName documentsBusName = "org.freedesktop.portal.Documents" documentsObject :: ObjectPath documentsObject = "/org/freedesktop/portal/documents" spec :: Spec spec = do around (withTestBus_ documentsBusName) $ do describe "getMountPoint" $ do it "should encode request" $ \handle -> do let responseBody = [toVariant ("/\0" :: ByteString)] body <- savingDocumentsMethodArguments handle "GetMountPoint" responseBody $ do void $ Documents.getMountPoint (client handle) body `shouldBe` [] it "should decode response" $ \handle -> do let responseBody = [toVariant ("/a/b/c\0" :: ByteString)] withDocumentsMethodResponse handle "GetMountPoint" responseBody $ do Documents.getMountPoint (client handle) `shouldReturn` "/a/b/c" describe "add" $ do it "should encode request with file descriptor" $ \handle -> do let responseBody = [toVariantText "docId"] withTempFd $ \fd -> do body <- savingDocumentsMethodArguments handle "Add" responseBody $ do void $ Documents.add (client handle) (DocumentFd fd) False True head body `shouldSatisfy` isDifferentUnixFd fd tail body `shouldBe` [DBus.toVariant False, DBus.toVariant True] it "should encode request with file path" $ \handle -> do let responseBody = [toVariantText "docId"] withTempFilePath $ \path -> do body <- savingDocumentsMethodArguments handle "Add" responseBody $ do void $ Documents.add (client handle) (DocumentFilePath path) False True head body `shouldSatisfy` isUnixFd tail body `shouldBe` [DBus.toVariant False, DBus.toVariant True] it "should decode response" $ \handle -> do let responseBody = [toVariantText "docId"] withTempFd $ \fd -> do withDocumentsMethodResponse handle "Add" responseBody $ do Documents.add (client handle) (DocumentFd fd) False False `shouldReturn` "docId" describe "addFull" $ do it "should encode request with file descriptors" $ \handle -> do withTempFds 7 $ \fds -> do let responseBody = [ DBus.toVariant ["docId" :: Text], toVariantMap [("mountpoint", DBus.toVariant ("/\0" :: ByteString))] ] body <- savingDocumentsMethodArguments handle "AddFull" responseBody $ do void $ Documents.addFull (client handle) (DocumentFd <$> fds) [AddReuseExisting, AddPersistent, AddAsNeededByApp, AddExportDirectory] (Just "appId") [GrantRead, GrantWrite, GrantGrantPermissions, GrantDelete] head body `shouldSatisfy` isDifferentUnixFds fds tail body `shouldBe` [ DBus.toVariant (0b1111 :: Word32), toVariantText "appId", DBus.toVariant ["read" :: Text, "write", "grant-permissions", "delete"] ] it "should encode request with file paths" $ \handle -> do withTempFilePaths 8 $ \paths -> do let responseBody = [ DBus.toVariant ["docId" :: Text], toVariantMap [("mountpoint", DBus.toVariant ("/\0" :: ByteString))] ] body <- savingDocumentsMethodArguments handle "AddFull" responseBody $ do void $ Documents.addFull (client handle) (DocumentFilePath <$> paths) [] Nothing [] head body `shouldSatisfy` isUnixFds 8 tail body `shouldBe` [DBus.toVariant (0 :: Word32), toVariantText "", DBus.toVariant ([] :: [Text])] it "should decode response" $ \handle -> do let responseBody = [ DBus.toVariant ["docId" :: Text], toVariantMap [("mountpoint", DBus.toVariant ("/a/b/c\0" :: ByteString))] ] withDocumentsMethodResponse handle "AddFull" responseBody $ do Documents.addFull (client handle) [] [] Nothing [] `shouldReturn` (["docId"], ExtraResults "/a/b/c") describe "addNamed" $ do it "should encode request with file descriptor" $ \handle -> do withTempDirectoryFd $ \fd -> do let responseBody = [toVariantText "docId"] body <- savingDocumentsMethodArguments handle "AddNamed" responseBody $ do void $ Documents.addNamed (client handle) (DocumentFd fd) "filename" False True head body `shouldSatisfy` isDifferentUnixFd fd tail body `shouldBe` [ DBus.toVariant ("filename\0" :: ByteString), DBus.toVariant False, DBus.toVariant True ] it "should encode request with file path" $ \handle -> do withTempDirectoryFilePath $ \path -> do let responseBody = [toVariantText "docId"] body <- savingDocumentsMethodArguments handle "AddNamed" responseBody $ do void $ Documents.addNamed (client handle) (DocumentFilePath path) "filename" False True head body `shouldSatisfy` isUnixFd tail body `shouldBe` [ DBus.toVariant ("filename\0" :: ByteString), DBus.toVariant False, DBus.toVariant True ] it "should decode response" $ \handle -> do withTempDirectoryFd $ \fd -> do let responseBody = [DBus.toVariantText "docId"] withDocumentsMethodResponse handle "AddNamed" responseBody $ do Documents.addNamed (client handle) (DocumentFd fd) "filename\0" False False `shouldReturn` "docId" describe "addNamedFull" $ do it "should encode request with file descriptor" $ \handle -> do withTempDirectoryFd $ \fd -> do let responseBody = [ DBus.toVariantText "docId", toVariantMap [("mountpoint", DBus.toVariant ("/\0" :: ByteString))] ] body <- savingDocumentsMethodArguments handle "AddNamedFull" responseBody $ do void $ Documents.addNamedFull (client handle) (DocumentFd fd) "filename" [AddReuseExisting, AddPersistent, AddAsNeededByApp, AddExportDirectory] (Just "appId") [GrantRead, GrantWrite, GrantGrantPermissions, GrantDelete] head body `shouldSatisfy` isDifferentUnixFd fd tail body `shouldBe` [ DBus.toVariant ("filename\0" :: ByteString), DBus.toVariant (0b1111 :: Word32), toVariantText "appId", DBus.toVariant ["read" :: Text, "write", "grant-permissions", "delete"] ] it "should encode request with file path" $ \handle -> do withTempDirectoryFilePath $ \path -> do let responseBody = [ DBus.toVariantText "docId", toVariantMap [("mountpoint", DBus.toVariant ("/\0" :: ByteString))] ] body <- savingDocumentsMethodArguments handle "AddNamedFull" responseBody $ do void $ Documents.addNamedFull (client handle) (DocumentFilePath path) "filename" [] Nothing [] head body `shouldSatisfy` isUnixFd tail body `shouldBe` [ DBus.toVariant ("filename\0" :: ByteString), DBus.toVariant (0 :: Word32), toVariantText "", DBus.toVariant ([] :: [Text]) ] it "should decode response" $ \handle -> do withTempDirectoryFd $ \fd -> do let responseBody = [ DBus.toVariantText "docId", toVariantMap [("mountpoint", DBus.toVariant ("/a/b/c\0" :: ByteString))] ] withDocumentsMethodResponse handle "AddNamedFull" responseBody $ do Documents.addNamedFull (client handle) (DocumentFd fd) "filename\0" [] Nothing [] `shouldReturn` ("docId", ExtraResults "/a/b/c") describe "grantPermissions" $ do it "should encode request" $ \handle -> do body <- savingDocumentsMethodArguments handle "GrantPermissions" [] $ do Documents.grantPermissions (client handle) "docId" "appId" [GrantRead, GrantWrite, GrantGrantPermissions, GrantDelete] body `shouldBe` [ toVariantText "docId", toVariantText "appId", DBus.toVariant ["read" :: Text, "write", "grant-permissions", "delete"] ] describe "revokePermissions" $ do it "should encode request" $ \handle -> do body <- savingDocumentsMethodArguments handle "RevokePermissions" [] $ do Documents.revokePermissions (client handle) "docId" "appId" [GrantRead, GrantWrite, GrantGrantPermissions, GrantDelete] body `shouldBe` [ toVariantText "docId", toVariantText "appId", DBus.toVariant ["read" :: Text, "write", "grant-permissions", "delete"] ] describe "delete" $ do it "should encode request" $ \handle -> do body <- savingDocumentsMethodArguments handle "Delete" [] $ do Documents.delete (client handle) "docId" body `shouldBe` [toVariantText "docId"] savingDocumentsMethodArguments :: TestHandle -> MemberName -> [Variant] -> IO () -> IO [Variant] savingDocumentsMethodArguments handle = savingMethodArguments_ handle documentsObject documentsInterface withDocumentsMethodResponse :: TestHandle -> MemberName -> [Variant] -> IO () -> IO () withDocumentsMethodResponse handle = withMethodResponse_ handle documentsObject documentsInterface -- We send a Fd to DBUS and check that the receiving test portal server end gets it, -- but the Fd actually received will be a different value, since it gets duplicated -- as it traverses the Unix sockets: test portal client -> DBUS -> test portal server isDifferentUnixFd :: Fd -> Variant -> Bool isDifferentUnixFd fd = \case (fromVariant -> Just fd') -> fd' /= fd _ -> False isDifferentUnixFds :: [Fd] -> Variant -> Bool isDifferentUnixFds fds = \case (fromVariant -> Just fds') -> length fds' == length fds && fds' /= fds _ -> False isUnixFd :: Variant -> Bool isUnixFd v = DBus.variantType v == TypeUnixFd isUnixFds :: Int -> Variant -> Bool isUnixFds n v | Just (fds :: [Fd]) <- fromVariant v, length fds == n = True | otherwise = False