mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-03-31 03:16:05 +00:00
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:
committed by
GitHub
parent
2f7632a70f
commit
d3059afc99
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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}
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -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,
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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")
|
||||
|
||||
@@ -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"
|
||||
|
||||
Reference in New Issue
Block a user