From c4ac5a784f7d64219abedeea8197302ff9ed406c Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 30 Sep 2023 17:49:43 +0100 Subject: [PATCH] use functions from simplexmq, fix tests --- cabal.project | 2 +- scripts/nix/sha256map.nix | 2 +- src/Simplex/Chat/Archive.hs | 31 +++++++++++++++---------------- src/Simplex/Chat/Mobile.hs | 32 ++++++++++++++++++++++++++++++-- stack.yaml | 2 +- tests/ChatClient.hs | 2 ++ tests/MobileTests.hs | 5 ++++- 7 files changed, 54 insertions(+), 22 deletions(-) diff --git a/cabal.project b/cabal.project index be7bc74396..7c64b9790a 100644 --- a/cabal.project +++ b/cabal.project @@ -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 diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 39c37c1b80..6747023040 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -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"; diff --git a/src/Simplex/Chat/Archive.hs b/src/Simplex/Chat/Archive.hs index 51d788dc08..3314b4d44a 100644 --- a/src/Simplex/Chat/Archive.hs +++ b/src/Simplex/Chat/Archive.hs @@ -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 diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 700548bb12..6f3c779624 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -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 diff --git a/stack.yaml b/stack.yaml index d3702db65a..1bebb17049 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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 diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 7da5263253..c0b839fb6b 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -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 diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index 26d6d61c6f..ad3753a61f 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -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