use functions from simplexmq, fix tests

2024-12-17 17:20:21 +01:00 · 2023-09-30 17:49:43 +01:00
parent d32adf6f6c
commit c4ac5a784f
7 changed files with 54 additions and 22 deletions
@@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd
 source-repository-package
    type: git
    location: https://github.com/simplex-chat/simplexmq.git
-    tag: caf7d05eb2a08af44f77530656ba900d0e29959a
+    tag: f097c24e6b1aa6a58411c6fc1a3f4120c77c8eec

 source-repository-package
    type: git
@@ -1,5 +1,5 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."caf7d05eb2a08af44f77530656ba900d0e29959a" = "0ji36fjl2mzrdm9j6280c1xpbnc7al607cmpksfi2qvipcmxypiz";
+  "https://github.com/simplex-chat/simplexmq.git"."f097c24e6b1aa6a58411c6fc1a3f4120c77c8eec" = "19rfi8hmjz028vyn54g9gndzzh08jxdqsn0vw7zrfv3cbb6kq2kp";
  "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
  "https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb";
  "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "0kiwhvml42g9anw4d2v0zd1fpc790pj9syg5x3ik4l97fnkbbwpp";
@@ -3,6 +3,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}

 module Simplex.Chat.Archive
  ( exportArchive,
@@ -21,7 +22,7 @@ import qualified Data.Text as T
 import qualified Database.SQLite3 as SQL
 import Simplex.Chat.Controller
 import Simplex.Messaging.Agent.Client (agentClientStore)
-import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), closeSQLiteStore, setSQLiteModeWAL, sqlString)
+import Simplex.Messaging.Agent.Store.SQLite
 import Simplex.Messaging.Util
 import System.FilePath
 import UnliftIO.Directory
@@ -41,7 +42,7 @@ archiveFilesFolder = "simplex_v1_files"

 exportArchive :: ChatMonad m => ArchiveConfig -> m ()
 exportArchive cfg@ArchiveConfig {archivePath, disableCompression} =
-  withTempDir cfg "simplex-chat." $ \dir -> do
+  handleErr $ withTempDir cfg "simplex-chat." $ \dir -> do
    fs@StorageFiles {chatStore, agentStore, filesPath} <- storageFiles
    setWALMode False `withStores` fs
    copyFile (dbFilePath chatStore) $ dir </> archiveChatDbFile
@@ -56,17 +57,16 @@ exportArchive cfg@ArchiveConfig {archivePath, disableCompression} =

 importArchive :: ChatMonad m => ArchiveConfig -> m [ArchiveError]
 importArchive cfg@ArchiveConfig {archivePath} =
-  withTempDir cfg "simplex-chat." $ \dir -> do
+  handleErr $ withTempDir cfg "simplex-chat." $ \dir -> do
    Z.withArchive archivePath $ Z.unpackInto dir
    fs@StorageFiles {chatStore, agentStore, filesPath} <- storageFiles
-    liftIO $ closeSQLiteStore `withStores` fs
-    backup `withDBs` fs
+    liftIO $ (closeSQLiteStore `withStores` fs) `catch` print @SomeException
+    liftIO $ backupSQLiteStore `withStores` fs
    copyFile (dir </> archiveChatDbFile) $ dbFilePath chatStore
    copyFile (dir </> archiveAgentDbFile) $ dbFilePath agentStore
    copyFiles dir filesPath
      `E.catch` \(e :: E.SomeException) -> pure [AEImport . ChatError . CEException $ show e]
  where
-    backup f = whenM (doesFileExist f) $ copyFile f $ f <> ".bak"
    copyFiles dir filesPath = do
      let filesDir = dir </> archiveFilesFolder
      case filesPath of
@@ -97,16 +97,18 @@ copyDirectoryFiles fromDir toDir = do
      whenM (doesFileExist f') $ copyFile f' $ toDir </> fn

 deleteStorage :: ChatMonad m => m ()
-deleteStorage = do
+deleteStorage = handleErr $ do
  fs <- storageFiles
  liftIO $ closeSQLiteStore `withStores` fs
-  remove `withDBs` fs
+  liftIO $ removeSQLiteStore `withStores` fs
  mapM_ removeDir $ filesPath fs
  mapM_ removeDir =<< chatReadVar tempDirectory
  where
-    remove f = whenM (doesFileExist f) $ removeFile f
    removeDir d = whenM (doesDirectoryExist d) $ removePathForcibly d

+handleErr :: ChatMonad m => m a -> m a
+handleErr = E.handle (throwError . mkChatError)
+
 data StorageFiles = StorageFiles
  { chatStore :: SQLiteStore,
    agentStore :: SQLiteStore,
@@ -125,17 +127,15 @@ sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = D
  when (key /= key') $ do
    fs <- storageFiles
    checkFile `withDBs` fs
-    backup `withDBs` fs
+    liftIO $ backupSQLiteStore `withStores` fs
    checkEncryption `withStores` fs
    removeExported `withDBs` fs
    export `withDBs` fs
    -- closing after encryption prevents closing in case wrong encryption key was passed
    liftIO $ closeSQLiteStore `withStores` fs
    (moveExported `withStores` fs)
-      `catchChatError` \e -> (restore `withDBs` fs) >> throwError e
+      `catchChatError` \e -> liftIO (restoreSQLiteStore `withStores` fs) >> throwError e
  where
-    backup f = copyFile f (f <> ".bak")
-    restore f = copyFile (f <> ".bak") f
    checkFile f = unlessM (doesFileExist f) $ throwDBError $ DBErrorNoFile f
    checkEncryption SQLiteStore {dbEncrypted} = do
      enc <- readTVarIO dbEncrypted
@@ -167,7 +167,6 @@ sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = D
              <> [ "ATTACH DATABASE " <> sqlString (f <> ".exported") <> " AS exported KEY " <> sqlString key' <> ";",
                   "PRAGMA wal_checkpoint(TRUNCATE);",
                   "SELECT sqlcipher_export('exported');",
-                   "PRAGMA exported.wal_checkpoint(TRUNCATE);",
                   "DETACH DATABASE exported;"
                 ]
        testSQL =
@@ -179,8 +178,8 @@ sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = D
                 ]
        keySQL k = ["PRAGMA key = " <> sqlString k <> ";" | not (null k)]

-withDBs :: Monad m => (FilePath -> m b) -> StorageFiles -> m b
+withDBs :: Monad m => (FilePath -> m a) -> StorageFiles -> m a
 action `withDBs` StorageFiles {chatStore, agentStore} = action (dbFilePath chatStore) >> action (dbFilePath agentStore)

-withStores :: Monad m => (SQLiteStore -> m b) -> StorageFiles -> m b
+withStores :: Monad m => (SQLiteStore -> m a) -> StorageFiles -> m a
 action `withStores` StorageFiles {chatStore, agentStore} = action chatStore >> action agentStore
@@ -3,11 +3,12 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}

 module Simplex.Chat.Mobile where

 import Control.Concurrent.STM
-import Control.Exception (catch)
+import Control.Exception (catch, SomeException)
 import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Aeson (ToJSON (..))
@@ -40,8 +41,9 @@ import Simplex.Chat.Options
 import Simplex.Chat.Store
 import Simplex.Chat.Store.Profiles
 import Simplex.Chat.Types
+import Simplex.Messaging.Agent.Client (agentClientStore)
 import Simplex.Messaging.Agent.Env.SQLite (createAgentStore)
-import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError)
+import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError, closeSQLiteStore, openSQLiteStore)
 import Simplex.Messaging.Client (defaultNetworkConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
@@ -53,6 +55,10 @@ import System.Timeout (timeout)

 foreign export ccall "chat_migrate_init" cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString

+foreign export ccall "chat_close_store" cChatCloseStore :: StablePtr ChatController -> IO CJSONString
+
+foreign export ccall "chat_open_store" cChatOpenStore :: StablePtr ChatController -> CString -> IO CJSONString
+
 foreign export ccall "chat_send_cmd" cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString

 foreign export ccall "chat_recv_msg" cChatRecvMsg :: StablePtr ChatController -> IO CJSONString
@@ -95,6 +101,15 @@ cChatMigrateInit fp key conf ctrl = do
      Left e -> pure e
  newCStringFromLazyBS $ J.encode r

+cChatCloseStore :: StablePtr ChatController -> IO CString
+cChatCloseStore cPtr = deRefStablePtr cPtr >>= chatCloseStore >>= newCAString
+
+cChatOpenStore :: StablePtr ChatController -> CString -> IO CString
+cChatOpenStore cPtr cKey = do
+  c <- deRefStablePtr cPtr
+  key <- peekCAString cKey
+  newCAString =<< chatOpenStore c key
+
 -- | send command to chat (same syntax as in terminal for now)
 cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString
 cChatSendCmd cPtr cCmd = do
@@ -195,6 +210,19 @@ chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do
          _ -> dbError e
        dbError e = Left . DBMErrorSQL dbFile $ show e

+chatCloseStore :: ChatController -> IO String
+chatCloseStore ChatController {chatStore, smpAgent} = handleErr $ do
+  closeSQLiteStore chatStore
+  closeSQLiteStore $ agentClientStore smpAgent
+
+chatOpenStore :: ChatController -> String -> IO String
+chatOpenStore ChatController {chatStore, smpAgent} key = handleErr $ do
+  openSQLiteStore chatStore key
+  openSQLiteStore (agentClientStore smpAgent) key
+
+handleErr :: IO () -> IO String
+handleErr a = (a $> "") `catch` (pure . show @SomeException)
+
 chatSendCmd :: ChatController -> ByteString -> IO JSONByteString
 chatSendCmd cc s = J.encode . APIResponse Nothing <$> runReaderT (execChatCommand s) cc

@@ -49,7 +49,7 @@ extra-deps:
  # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
  # - ../simplexmq
  - github: simplex-chat/simplexmq
-    commit: caf7d05eb2a08af44f77530656ba900d0e29959a
+    commit: f097c24e6b1aa6a58411c6fc1a3f4120c77c8eec
  - github: kazu-yamamoto/http2
    commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
  # - ../direct-sqlcipher
@@ -24,6 +24,7 @@ import Network.Socket
 import Simplex.Chat
 import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..))
 import Simplex.Chat.Core
+import Simplex.Chat.Mobile (chatCloseStore)
 import Simplex.Chat.Options
 import Simplex.Chat.Store
 import Simplex.Chat.Store.Profiles
@@ -174,6 +175,7 @@ stopTestChat TestCC {chatController = cc, chatAsync, termAsync} = do
  stopChatController cc
  uninterruptibleCancel termAsync
  uninterruptibleCancel chatAsync
+  chatCloseStore cc `shouldReturn` ""
  threadDelay 200000

 withNewTestChat :: HasCallStack => FilePath -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
@@ -39,7 +39,6 @@ import System.Directory (copyFile)
 import System.FilePath ((</>))
 import System.IO (utf8)
 import Test.Hspec
-import Control.Concurrent (threadDelay)

 mobileTests :: HasCallStack => SpecWith FilePath
 mobileTests = do
@@ -149,6 +148,10 @@ testChatApi tmp = do
  Right cc <- chatMigrateInit dbPrefix "myKey" "yesUp"
  Left (DBMErrorNotADatabase _) <- chatMigrateInit dbPrefix "" "yesUp"
  Left (DBMErrorNotADatabase _) <- chatMigrateInit dbPrefix "anotherKey" "yesUp"
+  chatCloseStore cc `shouldReturn` ""
+  chatOpenStore cc "" >>= (`shouldContain` "file is not a database")
+  chatOpenStore cc "anotherKey" >>= (`shouldContain` "file is not a database")
+  chatOpenStore cc "myKey" `shouldReturn` ""
  chatSendCmd cc "/u" `shouldReturn` activeUser
  chatSendCmd cc "/create user alice Alice" `shouldReturn` activeUserExists
  chatSendCmd cc "/_start" `shouldReturn` chatStarted