ios, core: better notifications processing to avoid contention for database (#3485)

* core: forward notifications about message processing (for iOS notifications)

* simplexmq

* the option to keep database key, to allow re-opening the database

* export new init with keepKey and reopen DB api

* stop remote ctrl when suspending chat

* ios: close/re-open db on suspend/activate

* allow activating chat without restoring (for NSE)

* update NSE to suspend/activate (does not work)

* simplexmq

* suspend chat and close database when last notification in the process is processed

* stop reading notifications on message markers

* replace async stream with cancellable concurrent queue

* better synchronization of app and NSE

* remove outside of task

* remove unused var

* whitespace

* more debug logging, handle cancelled read after dequeue

* comments

* more comments
This commit is contained in:
Evgeny Poberezkin
2023-12-09 21:59:40 +00:00
committed by GitHub
parent 2f7632a70f
commit d3059afc99
29 changed files with 661 additions and 224 deletions

View File

@@ -9,7 +9,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
@@ -28,6 +27,8 @@ import qualified Data.Aeson as J
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (bimap, first)
import Data.ByteArray (ScrubbedBytes)
import qualified Data.ByteArray as BA
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
@@ -50,7 +51,7 @@ import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime)
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDay, nominalDiffTimeToSeconds)
import Data.Time.Clock.System (SystemTime, systemToUTCTime)
import Data.Time.Clock.System (systemToUTCTime)
import Data.Word (Word16, Word32)
import qualified Database.SQLite.Simple as SQL
import Simplex.Chat.Archive
@@ -191,10 +192,10 @@ smallGroupsRcptsMemLimit = 20
logCfg :: LogConfig
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
createChatDatabase :: FilePath -> String -> MigrationConfirmation -> IO (Either MigrationError ChatDatabase)
createChatDatabase filePrefix key confirmMigrations = runExceptT $ do
chatStore <- ExceptT $ createChatStore (chatStoreFile filePrefix) key confirmMigrations
agentStore <- ExceptT $ createAgentStore (agentStoreFile filePrefix) key confirmMigrations
createChatDatabase :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError ChatDatabase)
createChatDatabase filePrefix key keepKey confirmMigrations = runExceptT $ do
chatStore <- ExceptT $ createChatStore (chatStoreFile filePrefix) key keepKey confirmMigrations
agentStore <- ExceptT $ createAgentStore (agentStoreFile filePrefix) key keepKey confirmMigrations
pure ChatDatabase {chatStore, agentStore}
newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> IO ChatController
@@ -538,16 +539,18 @@ processChatCommand = \case
APIStopChat -> do
ask >>= stopChatController
pure CRChatStopped
APIActivateChat -> withUser $ \_ -> do
restoreCalls
APIActivateChat restoreChat -> withUser $ \_ -> do
when restoreChat restoreCalls
withAgent foregroundAgent
users <- withStoreCtx' (Just "APIActivateChat, getUsers") getUsers
void . forkIO $ subscribeUsers True users
void . forkIO $ startFilesToReceive users
setAllExpireCIFlags True
when restoreChat $ do
users <- withStoreCtx' (Just "APIActivateChat, getUsers") getUsers
void . forkIO $ subscribeUsers True users
void . forkIO $ startFilesToReceive users
setAllExpireCIFlags True
ok_
APISuspendChat t -> do
setAllExpireCIFlags False
stopRemoteCtrl
withAgent (`suspendAgent` t)
ok_
ResubscribeAllConnections -> withStoreCtx' (Just "ResubscribeAllConnections, getUsers") getUsers >>= subscribeUsers False >> ok_
@@ -1172,16 +1175,13 @@ processChatCommand = \case
APIDeleteToken token -> withUser $ \_ -> withAgent (`deleteNtfToken` token) >> ok_
APIGetNtfMessage nonce encNtfInfo -> withUser $ \_ -> do
(NotificationInfo {ntfConnId, ntfMsgMeta}, msgs) <- withAgent $ \a -> getNotificationMessage a nonce encNtfInfo
let ntfMessages = map (\SMP.SMPMsgMeta {msgTs, msgFlags} -> NtfMsgInfo {msgTs = systemToUTCTime msgTs, msgFlags}) msgs
getMsgTs :: SMP.NMsgMeta -> SystemTime
getMsgTs SMP.NMsgMeta {msgTs} = msgTs
msgTs' = systemToUTCTime . getMsgTs <$> ntfMsgMeta
let msgTs' = systemToUTCTime . (\SMP.NMsgMeta {msgTs} -> msgTs) <$> ntfMsgMeta
agentConnId = AgentConnId ntfConnId
user_ <- withStore' (`getUserByAConnId` agentConnId)
connEntity <-
connEntity_ <-
pure user_ $>>= \user ->
withStore (\db -> Just <$> getConnectionEntity db user agentConnId) `catchChatError` (\e -> toView (CRChatError (Just user) e) $> Nothing)
pure CRNtfMessages {user_, connEntity, msgTs = msgTs', ntfMessages}
pure CRNtfMessages {user_, connEntity_, msgTs = msgTs', ntfMessages = map ntfMsgInfo msgs}
APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do
ChatConfig {defaultServers} <- asks config
servers <- withStore' (`getProtocolServers` user)
@@ -3227,23 +3227,24 @@ processAgentMsgRcvFile _corrId aFileId msg =
toView $ CRRcvFileError user ci e
processAgentMessageConn :: forall m. ChatMonad m => User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m ()
processAgentMessageConn user _ agentConnId END =
withStore (\db -> getConnectionEntity db user $ AgentConnId agentConnId) >>= \case
RcvDirectMsgConnection _ (Just ct) -> toView $ CRContactAnotherClient user ct
entity -> toView $ CRSubscriptionEnd user entity
processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
entity <- withStore (\db -> getConnectionEntity db user $ AgentConnId agentConnId) >>= updateConnStatus
case entity of
RcvDirectMsgConnection conn contact_ ->
processDirectMessage agentMessage entity conn contact_
RcvGroupMsgConnection conn gInfo m ->
processGroupMessage agentMessage entity conn gInfo m
RcvFileConnection conn ft ->
processRcvFileConn agentMessage entity conn ft
SndFileConnection conn ft ->
processSndFileConn agentMessage entity conn ft
UserContactConnection conn uc ->
processUserContactRequest agentMessage entity conn uc
case agentMessage of
END -> case entity of
RcvDirectMsgConnection _ (Just ct) -> toView $ CRContactAnotherClient user ct
_ -> toView $ CRSubscriptionEnd user entity
MSGNTF smpMsgInfo -> toView $ CRNtfMessage user entity $ ntfMsgInfo smpMsgInfo
_ -> case entity of
RcvDirectMsgConnection conn contact_ ->
processDirectMessage agentMessage entity conn contact_
RcvGroupMsgConnection conn gInfo m ->
processGroupMessage agentMessage entity conn gInfo m
RcvFileConnection conn ft ->
processRcvFileConn agentMessage entity conn ft
SndFileConnection conn ft ->
processSndFileConn agentMessage entity conn ft
UserContactConnection conn uc ->
processUserContactRequest agentMessage entity conn uc
where
updateConnStatus :: ConnectionEntity -> m ConnectionEntity
updateConnStatus acEntity = case agentMsgConnStatus agentMessage of
@@ -5959,7 +5960,8 @@ chatCommandP =
"/_start subscribe=" *> (StartChat <$> onOffP <* " expire=" <*> onOffP <* " xftp=" <*> onOffP),
"/_start" $> StartChat True True True,
"/_stop" $> APIStopChat,
"/_app activate" $> APIActivateChat,
"/_app activate restore=" *> (APIActivateChat <$> onOffP),
"/_app activate" $> APIActivateChat True,
"/_app suspend " *> (APISuspendChat <$> A.decimal),
"/_resubscribe all" $> ResubscribeAllConnections,
"/_temp_folder " *> (SetTempFolder <$> filePath),
@@ -5974,9 +5976,9 @@ chatCommandP =
"/_db import " *> (APIImportArchive <$> jsonP),
"/_db delete" $> APIDeleteStorage,
"/_db encryption " *> (APIStorageEncryption <$> jsonP),
"/db encrypt " *> (APIStorageEncryption . DBEncryptionConfig "" <$> dbKeyP),
"/db key " *> (APIStorageEncryption <$> (DBEncryptionConfig <$> dbKeyP <* A.space <*> dbKeyP)),
"/db decrypt " *> (APIStorageEncryption . (`DBEncryptionConfig` "") <$> dbKeyP),
"/db encrypt " *> (APIStorageEncryption . dbEncryptionConfig "" <$> dbKeyP),
"/db key " *> (APIStorageEncryption <$> (dbEncryptionConfig <$> dbKeyP <* A.space <*> dbKeyP)),
"/db decrypt " *> (APIStorageEncryption . (`dbEncryptionConfig` "") <$> dbKeyP),
"/sql chat " *> (ExecChatStoreSQL <$> textP),
"/sql agent " *> (ExecAgentStoreSQL <$> textP),
"/sql slow" $> SlowSQLQueries,
@@ -6317,7 +6319,8 @@ chatCommandP =
A.decimal
]
dbKeyP = nonEmptyKey <$?> strP
nonEmptyKey k@(DBEncryptionKey s) = if null s then Left "empty key" else Right k
nonEmptyKey k@(DBEncryptionKey s) = if BA.null s then Left "empty key" else Right k
dbEncryptionConfig currentKey newKey = DBEncryptionConfig {currentKey, newKey, keepKey = Just False}
autoAcceptP =
ifM
onOffP

View File

@@ -17,12 +17,14 @@ import qualified Codec.Archive.Zip as Z
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import qualified Data.ByteArray as BA
import Data.Functor (($>))
import Data.Maybe (fromMaybe)
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, sqlString)
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), closeSQLiteStore, keyString, sqlString, storeKey)
import Simplex.Messaging.Util
import System.FilePath
import UnliftIO.Directory
@@ -118,7 +120,7 @@ storageFiles = do
pure StorageFiles {chatStore, agentStore, filesPath}
sqlCipherExport :: forall m. ChatMonad m => DBEncryptionConfig -> m ()
sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = DBEncryptionKey key'} =
sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = DBEncryptionKey key', keepKey} =
when (key /= key') $ do
fs <- storageFiles
checkFile `withDBs` fs
@@ -134,15 +136,15 @@ sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = D
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
when (enc && null key) $ throwDBError DBErrorEncrypted
when (not enc && not (null key)) $ throwDBError DBErrorPlaintext
checkEncryption SQLiteStore {dbKey} = do
enc <- maybe True (not . BA.null) <$> readTVarIO dbKey
when (enc && BA.null key) $ throwDBError DBErrorEncrypted
when (not enc && not (BA.null key)) $ throwDBError DBErrorPlaintext
exported = (<> ".exported")
removeExported f = whenM (doesFileExist $ exported f) $ removeFile (exported f)
moveExported SQLiteStore {dbFilePath = f, dbEncrypted} = do
moveExported SQLiteStore {dbFilePath = f, dbKey} = do
renameFile (exported f) f
atomically $ writeTVar dbEncrypted $ not (null key')
atomically $ writeTVar dbKey $ storeKey key' (fromMaybe False keepKey)
export f = do
withDB f (`SQL.exec` exportSQL) DBErrorExport
withDB (exported f) (`SQL.exec` testSQL) DBErrorOpen
@@ -161,7 +163,7 @@ sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = D
exportSQL =
T.unlines $
keySQL key
<> [ "ATTACH DATABASE " <> sqlString (f <> ".exported") <> " AS exported KEY " <> sqlString key' <> ";",
<> [ "ATTACH DATABASE " <> sqlString (T.pack f <> ".exported") <> " AS exported KEY " <> keyString key' <> ";",
"SELECT sqlcipher_export('exported');",
"DETACH DATABASE exported;"
]
@@ -172,7 +174,7 @@ sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = D
"PRAGMA secure_delete = ON;",
"SELECT count(*) FROM sqlite_master;"
]
keySQL k = ["PRAGMA key = " <> sqlString k <> ";" | not (null k)]
keySQL k = ["PRAGMA key = " <> keyString k <> ";" | not (BA.null k)]
withDBs :: Monad m => (FilePath -> m b) -> StorageFiles -> m b
action `withDBs` StorageFiles {chatStore, agentStore} = action (dbFilePath chatStore) >> action (dbFilePath agentStore)

View File

@@ -29,6 +29,8 @@ import qualified Data.Aeson.TH as JQ
import qualified Data.Aeson.Types as JT
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (first)
import Data.ByteArray (ScrubbedBytes)
import qualified Data.ByteArray as BA
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (ord)
@@ -39,7 +41,9 @@ import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.String
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1)
import Data.Time (NominalDiffTime, UTCTime)
import Data.Time.Clock.System (systemToUTCTime)
import Data.Version (showVersion)
import Data.Word (Word16)
import Language.Haskell.TH (Exp, Q, runIO)
@@ -69,7 +73,7 @@ import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus)
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON)
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgFlags, NtfServer, ProtoServerWithAuth, ProtocolTypeI, QueueId, SProtocolType, SubscriptionMode (..), UserProtocol, XFTPServerWithAuth, userProtocol)
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, NtfServer, ProtoServerWithAuth, ProtocolTypeI, QueueId, SMPMsgMeta (..), SProtocolType, SubscriptionMode (..), UserProtocol, XFTPServerWithAuth, userProtocol)
import Simplex.Messaging.TMap (TMap)
import Simplex.Messaging.Transport (TLS, simplexMQVersion)
import Simplex.Messaging.Transport.Client (TransportHost)
@@ -230,7 +234,7 @@ data ChatCommand
| DeleteUser UserName Bool (Maybe UserPwd)
| StartChat {subscribeConnections :: Bool, enableExpireChatItems :: Bool, startXFTPWorkers :: Bool}
| APIStopChat
| APIActivateChat
| APIActivateChat {restoreChat :: Bool}
| APISuspendChat {suspendTimeout :: Int}
| ResubscribeAllConnections
| SetTempFolder FilePath
@@ -453,7 +457,7 @@ allowRemoteCommand :: ChatCommand -> Bool -- XXX: consider using Relay/Block/For
allowRemoteCommand = \case
StartChat {} -> False
APIStopChat -> False
APIActivateChat -> False
APIActivateChat _ -> False
APISuspendChat _ -> False
QuitChat -> False
SetTempFolder _ -> False
@@ -654,7 +658,8 @@ data ChatResponse
| CRUserContactLinkSubError {chatError :: ChatError} -- TODO delete
| CRNtfTokenStatus {status :: NtfTknStatus}
| CRNtfToken {token :: DeviceToken, status :: NtfTknStatus, ntfMode :: NotificationsMode}
| CRNtfMessages {user_ :: Maybe User, connEntity :: Maybe ConnectionEntity, msgTs :: Maybe UTCTime, ntfMessages :: [NtfMsgInfo]}
| CRNtfMessages {user_ :: Maybe User, connEntity_ :: Maybe ConnectionEntity, msgTs :: Maybe UTCTime, ntfMessages :: [NtfMsgInfo]}
| CRNtfMessage {user :: User, connEntity :: ConnectionEntity, ntfMessage :: NtfMsgInfo}
| CRContactConnectionDeleted {user :: User, connection :: PendingContactConnection}
| CRRemoteHostList {remoteHosts :: [RemoteHostInfo]}
| CRCurrentRemoteHost {remoteHost_ :: Maybe RemoteHostInfo}
@@ -825,17 +830,17 @@ deriving instance Show AUserProtoServers
data ArchiveConfig = ArchiveConfig {archivePath :: FilePath, disableCompression :: Maybe Bool, parentTempDirectory :: Maybe FilePath}
deriving (Show)
data DBEncryptionConfig = DBEncryptionConfig {currentKey :: DBEncryptionKey, newKey :: DBEncryptionKey}
data DBEncryptionConfig = DBEncryptionConfig {currentKey :: DBEncryptionKey, newKey :: DBEncryptionKey, keepKey :: Maybe Bool}
deriving (Show)
newtype DBEncryptionKey = DBEncryptionKey String
newtype DBEncryptionKey = DBEncryptionKey ScrubbedBytes
deriving (Show)
instance IsString DBEncryptionKey where fromString = parseString $ parseAll strP
instance StrEncoding DBEncryptionKey where
strEncode (DBEncryptionKey s) = B.pack s
strP = DBEncryptionKey . B.unpack <$> A.takeWhile (\c -> c /= ' ' && ord c >= 0x21 && ord c <= 0x7E)
strEncode (DBEncryptionKey s) = BA.convert s
strP = DBEncryptionKey . BA.convert <$> A.takeWhile (\c -> c /= ' ' && ord c >= 0x21 && ord c <= 0x7E)
instance FromJSON DBEncryptionKey where
parseJSON = strParseJSON "DBEncryptionKey"
@@ -900,9 +905,12 @@ data XFTPFileConfig = XFTPFileConfig
defaultXFTPFileConfig :: XFTPFileConfig
defaultXFTPFileConfig = XFTPFileConfig {minFileSize = 0}
data NtfMsgInfo = NtfMsgInfo {msgTs :: UTCTime, msgFlags :: MsgFlags}
data NtfMsgInfo = NtfMsgInfo {msgId :: Text, msgTs :: UTCTime}
deriving (Show)
ntfMsgInfo :: SMPMsgMeta -> NtfMsgInfo
ntfMsgInfo SMPMsgMeta {msgId, msgTs} = NtfMsgInfo {msgId = decodeLatin1 $ strEncode msgId, msgTs = systemToUTCTime msgTs}
crNtfToken :: (DeviceToken, NtfTknStatus, NotificationsMode) -> ChatResponse
crNtfToken (token, status, ntfMode) = CRNtfToken {token, status, ntfMode}

View File

@@ -22,7 +22,7 @@ simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {core
withGlobalLogging logCfg initRun
_ -> initRun
where
initRun = createChatDatabase dbFilePrefix dbKey confirmMigrations >>= either exit run
initRun = createChatDatabase dbFilePrefix dbKey False confirmMigrations >>= either exit run
exit e = do
putStrLn $ "Error opening database: " <> show e
exitFailure

View File

@@ -15,6 +15,8 @@ import Control.Monad.Reader
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import Data.Bifunctor (first)
import Data.ByteArray (ScrubbedBytes)
import qualified Data.ByteArray as BA
import qualified Data.ByteString.Base64.URL as U
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
@@ -44,7 +46,7 @@ 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, closeSQLiteStore)
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError, closeSQLiteStore, reopenSQLiteStore)
import Simplex.Messaging.Client (defaultNetworkConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
@@ -70,8 +72,12 @@ $(JQ.deriveToJSON defaultJSON ''APIResponse)
foreign export ccall "chat_migrate_init" cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
foreign export ccall "chat_migrate_init_key" cChatMigrateInitKey :: CString -> CString -> CInt -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
foreign export ccall "chat_close_store" cChatCloseStore :: StablePtr ChatController -> IO CString
foreign export ccall "chat_reopen_store" cChatReopenStore :: StablePtr ChatController -> IO CString
foreign export ccall "chat_send_cmd" cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString
foreign export ccall "chat_send_remote_cmd" cChatSendRemoteCmd :: StablePtr ChatController -> CInt -> CString -> IO CJSONString
@@ -102,7 +108,10 @@ foreign export ccall "chat_decrypt_file" cChatDecryptFile :: CString -> CString
-- | check / migrate database and initialize chat controller on success
cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
cChatMigrateInit fp key conf ctrl = do
cChatMigrateInit fp key = cChatMigrateInitKey fp key 0
cChatMigrateInitKey :: CString -> CString -> CInt -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
cChatMigrateInitKey fp key keepKey conf ctrl = do
-- ensure we are set to UTF-8; iOS does not have locale, and will default to
-- US-ASCII all the time.
setLocaleEncoding utf8
@@ -110,10 +119,10 @@ cChatMigrateInit fp key conf ctrl = do
setForeignEncoding utf8
dbPath <- peekCAString fp
dbKey <- peekCAString key
dbKey <- BA.convert <$> B.packCString key
confirm <- peekCAString conf
r <-
chatMigrateInit dbPath dbKey confirm >>= \case
chatMigrateInitKey dbPath dbKey (keepKey /= 0) confirm >>= \case
Right cc -> (newStablePtr cc >>= poke ctrl) $> DBMOk
Left e -> pure e
newCStringFromLazyBS $ J.encode r
@@ -121,6 +130,11 @@ cChatMigrateInit fp key conf ctrl = do
cChatCloseStore :: StablePtr ChatController -> IO CString
cChatCloseStore cPtr = deRefStablePtr cPtr >>= chatCloseStore >>= newCAString
cChatReopenStore :: StablePtr ChatController -> IO CString
cChatReopenStore cPtr = do
c <- deRefStablePtr cPtr
newCAString =<< chatReopenStore c
-- | send command to chat (same syntax as in terminal for now)
cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString
cChatSendCmd cPtr cCmd = do
@@ -162,13 +176,13 @@ cChatPasswordHash cPwd cSalt = do
cChatValidName :: CString -> IO CString
cChatValidName cName = newCString . mkValidName =<< peekCString cName
mobileChatOpts :: String -> String -> ChatOpts
mobileChatOpts dbFilePrefix dbKey =
mobileChatOpts :: String -> ChatOpts
mobileChatOpts dbFilePrefix =
ChatOpts
{ coreOptions =
CoreChatOpts
{ dbFilePrefix,
dbKey,
dbKey = "", -- for API database is already opened, and the key in options is not used
smpServers = [],
xftpServers = [],
networkConfig = defaultNetworkConfig,
@@ -205,8 +219,11 @@ defaultMobileConfig =
getActiveUser_ :: SQLiteStore -> IO (Maybe User)
getActiveUser_ st = find activeUser <$> withTransaction st getUsers
chatMigrateInit :: String -> String -> String -> IO (Either DBMigrationResult ChatController)
chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do
chatMigrateInit :: String -> ScrubbedBytes -> String -> IO (Either DBMigrationResult ChatController)
chatMigrateInit dbFilePrefix dbKey = chatMigrateInitKey dbFilePrefix dbKey False
chatMigrateInitKey :: String -> ScrubbedBytes -> Bool -> String -> IO (Either DBMigrationResult ChatController)
chatMigrateInitKey dbFilePrefix dbKey keepKey confirm = runExceptT $ do
confirmMigrations <- liftEitherWith (const DBMInvalidConfirmation) $ strDecode $ B.pack confirm
chatStore <- migrate createChatStore (chatStoreFile dbFilePrefix) confirmMigrations
agentStore <- migrate createAgentStore (agentStoreFile dbFilePrefix) confirmMigrations
@@ -214,10 +231,10 @@ chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do
where
initialize st db = do
user_ <- getActiveUser_ st
newChatController db user_ defaultMobileConfig (mobileChatOpts dbFilePrefix dbKey)
newChatController db user_ defaultMobileConfig (mobileChatOpts dbFilePrefix)
migrate createStore dbFile confirmMigrations =
ExceptT $
(first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey confirmMigrations)
(first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey keepKey confirmMigrations)
`catch` (pure . checkDBError)
`catchAll` (pure . dbError)
where
@@ -231,6 +248,11 @@ chatCloseStore ChatController {chatStore, smpAgent} = handleErr $ do
closeSQLiteStore chatStore
closeSQLiteStore $ agentClientStore smpAgent
chatReopenStore :: ChatController -> IO String
chatReopenStore ChatController {chatStore, smpAgent} = handleErr $ do
reopenSQLiteStore chatStore
reopenSQLiteStore (agentClientStore smpAgent)
handleErr :: IO () -> IO String
handleErr a = (a $> "") `catch` (pure . show @SomeException)

View File

@@ -18,6 +18,7 @@ where
import Control.Logger.Simple (LogLevel (..))
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteArray (ScrubbedBytes)
import qualified Data.ByteString.Char8 as B
import Data.Text (Text)
import Numeric.Natural (Natural)
@@ -48,7 +49,7 @@ data ChatOpts = ChatOpts
data CoreChatOpts = CoreChatOpts
{ dbFilePrefix :: String,
dbKey :: String,
dbKey :: ScrubbedBytes,
smpServers :: [SMPServerWithAuth],
xftpServers :: [XFTPServerWithAuth],
networkConfig :: NetworkConfig,

View File

@@ -189,7 +189,7 @@ startRemoteHost rh_ rcAddrPrefs_ port_ = do
RHSessionConnecting _inv rhs' -> Right ((), RHSessionPendingConfirmation sessionCode tls rhs')
_ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
let rh_' = (\rh -> (rh :: RemoteHostInfo) {sessionState = Just RHSPendingConfirmation {sessionCode}}) <$> remoteHost_
toView $ CRRemoteHostSessionCode {remoteHost_ = rh_', sessionCode}
toView CRRemoteHostSessionCode {remoteHost_ = rh_', sessionCode}
(RCHostSession {sessionKeys}, rhHello, pairing') <- timeoutThrow (ChatErrorRemoteHost rhKey RHETimeout) 60000000 $ takeRCStep vars'
hostInfo@HostAppInfo {deviceName = hostDeviceName} <-
liftError (ChatErrorRemoteHost rhKey) $ parseHostAppInfo rhHello
@@ -260,7 +260,7 @@ cancelRemoteHostSession handlerInfo_ rhKey = do
atomically $
TM.lookup rhKey sessions >>= \case
Nothing -> pure Nothing
Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler
Just (sessSeq, _) | maybe False ((sessSeq /=) . fst) handlerInfo_ -> pure Nothing -- ignore cancel from a ghost session handler
Just (_, rhs) -> do
TM.delete rhKey sessions
modifyTVar' crh $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH
@@ -268,7 +268,7 @@ cancelRemoteHostSession handlerInfo_ rhKey = do
forM_ deregistered $ \session -> do
liftIO $ cancelRemoteHost handlingError session `catchAny` (logError . tshow)
forM_ (snd <$> handlerInfo_) $ \rhStopReason ->
toView $ CRRemoteHostStopped {remoteHostId_, rhsState = rhsSessionState session, rhStopReason}
toView CRRemoteHostStopped {remoteHostId_, rhsState = rhsSessionState session, rhStopReason}
where
handlingError = isJust handlerInfo_
remoteHostId_ = case rhKey of

View File

@@ -12,13 +12,14 @@ module Simplex.Chat.Store
)
where
import Data.ByteArray (ScrubbedBytes)
import Simplex.Chat.Store.Migrations
import Simplex.Chat.Store.Profiles
import Simplex.Chat.Store.Shared
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, MigrationError, SQLiteStore (..), createSQLiteStore, withTransaction)
createChatStore :: FilePath -> String -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore)
createChatStore dbPath dbKey = createSQLiteStore dbPath dbKey migrations
createChatStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore)
createChatStore dbPath key keepKey = createSQLiteStore dbPath key keepKey migrations
chatStoreFile :: FilePath -> FilePath
chatStoreFile = (<> "_chat.db")

View File

@@ -279,6 +279,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
CRNtfTokenStatus status -> ["device token status: " <> plain (smpEncode status)]
CRNtfToken _ status mode -> ["device token status: " <> plain (smpEncode status) <> ", notifications mode: " <> plain (strEncode mode)]
CRNtfMessages {} -> []
CRNtfMessage {} -> []
CRCurrentRemoteHost rhi_ ->
[ maybe
"Using local profile"