Merge branch 'master' into master-ghc8107

src/Simplex/Chat.hs

@@ -30,7 +30,6 @@ import qualified Data.ByteString.Base64 as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isSpace, toLower)
-import Data.Composition ((.:))
 import Data.Constraint (Dict (..))
 import Data.Either (fromRight, rights)
 import Data.Fixed (div')
@@ -80,7 +79,7 @@ import Simplex.Messaging.Agent.Client (AgentStatsKey (..), SubInfo (..), agentCl
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore, defaultAgentConfig)
 import Simplex.Messaging.Agent.Lock
 import Simplex.Messaging.Agent.Protocol
-import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError, SQLiteStore (dbNew), execSQL, upMigration, withConnection, closeSQLiteStore, openSQLiteStore)
+import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError, SQLiteStore (dbNew), execSQL, upMigration, withConnection)
 import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
@@ -248,7 +247,7 @@ cfgServers = \case
 
 startChatController :: forall m. ChatMonad' m => Bool -> Bool -> Bool -> m (Async ())
 startChatController subConns enableExpireCIs startXFTPWorkers = do
-  resumeAgentClient =<< asks smpAgent
+  asks smpAgent >>= resumeAgentClient
   unless subConns $
     chatWriteVar subscriptionMode SMOnlyCreate
   users <- fromRight [] <$> runExceptT (withStoreCtx' (Just "startChatController, getUsers") getUsers)
@@ -320,8 +319,8 @@ restoreCalls = do
   calls <- asks currentCalls
   atomically $ writeTVar calls callsMap
 
-stopChatController :: forall m. MonadUnliftIO m => ChatController -> Bool -> m ()
-stopChatController ChatController {chatStore, smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags} closeStore = do
+stopChatController :: forall m. MonadUnliftIO m => ChatController -> m ()
+stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags} = do
   disconnectAgentClient smpAgent
   readTVarIO s >>= mapM_ (\(a1, a2) -> uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2)
   closeFiles sndFiles
@@ -330,9 +329,6 @@ stopChatController ChatController {chatStore, smpAgent, agentAsync = s, sndFiles
     keys <- M.keys <$> readTVar expireCIFlags
     forM_ keys $ \k -> TM.insert k False expireCIFlags
     writeTVar s Nothing
-  when closeStore $ liftIO $ do
-    closeSQLiteStore chatStore
-    closeSQLiteStore $ agentClientStore smpAgent
   where
     closeFiles :: TVar (Map Int64 Handle) -> m ()
     closeFiles files = do
@@ -462,19 +458,12 @@ processChatCommand = \case
     checkDeleteChatUser user'
     withChatLock "deleteUser" . procCmd $ deleteChatUser user' delSMPQueues
   DeleteUser uName delSMPQueues viewPwd_ -> withUserName uName $ \userId -> APIDeleteUser userId delSMPQueues viewPwd_
-  APIStartChat ChatCtrlCfg {subConns, enableExpireCIs, startXFTPWorkers, openDBWithKey} -> withUser' $ \_ ->
+  StartChat subConns enableExpireCIs startXFTPWorkers -> withUser' $ \_ ->
     asks agentAsync >>= readTVarIO >>= \case
       Just _ -> pure CRChatRunning
-      _ -> checkStoreNotChanged $ do
-        forM_ openDBWithKey $ \(DBEncryptionKey dbKey) -> do
-          ChatController {chatStore, smpAgent} <- ask
-          open chatStore dbKey
-          open (agentClientStore smpAgent) dbKey
-        startChatController subConns enableExpireCIs startXFTPWorkers $> CRChatStarted
-        where
-          open = handleDBError DBErrorOpen .: openSQLiteStore
-  APIStopChat closeStore -> do
-    ask >>= (`stopChatController` closeStore)
+      _ -> checkStoreNotChanged $ startChatController subConns enableExpireCIs startXFTPWorkers $> CRChatStarted
+  APIStopChat -> do
+    ask >>= stopChatController
     pure CRChatStopped
   APIActivateChat -> withUser $ \_ -> do
     restoreCalls
@@ -2562,7 +2551,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
     getContactConns :: m ([ConnId], Map ConnId Contact)
     getContactConns = do
       cts <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserContacts") getUserContacts
-      let connIds = map contactConnId cts
+      let connIds = map contactConnId (filter contactActive cts)
       pure (connIds, M.fromList $ zip connIds cts)
     getUserContactLinkConns :: m ([ConnId], Map ConnId UserContact)
     getUserContactLinkConns = do
@@ -2572,7 +2561,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
     getGroupMemberConns :: m ([Group], [ConnId], Map ConnId GroupMember)
     getGroupMemberConns = do
       gs <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserGroups") getUserGroups
-      let mPairs = concatMap (\(Group _ ms) -> mapMaybe (\m -> (,m) <$> memberConnId m) ms) gs
+      let mPairs = concatMap (\(Group _ ms) -> mapMaybe (\m -> (,m) <$> memberConnId m) (filter (not . memberRemoved) ms)) gs
       pure (gs, map fst mPairs, M.fromList mPairs)
     getSndFileTransferConns :: m ([ConnId], Map ConnId SndFileTransfer)
     getSndFileTransferConns = do
@@ -4243,16 +4232,22 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
     xInfo c p' = void $ processContactProfileUpdate c p' True
 
     xDirectDel :: Contact -> RcvMessage -> MsgMeta -> m ()
-    xDirectDel c msg msgMeta = do
-      checkIntegrityCreateItem (CDDirectRcv c) msgMeta
-      ct' <- withStore' $ \db -> updateContactStatus db user c CSDeleted
-      contactConns <- withStore $ \db -> getContactConnections db userId ct'
-      deleteAgentConnectionsAsync user $ map aConnId contactConns
-      forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
-      let ct'' = ct' {activeConn = (contactConn ct') {connStatus = ConnDeleted}} :: Contact
-      ci <- saveRcvChatItem user (CDDirectRcv ct'') msg msgMeta (CIRcvDirectEvent RDEContactDeleted)
-      toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct'') ci)
-      toView $ CRContactDeletedByContact user ct''
+    xDirectDel c msg msgMeta =
+      if directOrUsed c
+        then do
+          checkIntegrityCreateItem (CDDirectRcv c) msgMeta
+          ct' <- withStore' $ \db -> updateContactStatus db user c CSDeleted
+          contactConns <- withStore $ \db -> getContactConnections db userId ct'
+          deleteAgentConnectionsAsync user $ map aConnId contactConns
+          forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
+          let ct'' = ct' {activeConn = (contactConn ct') {connStatus = ConnDeleted}} :: Contact
+          ci <- saveRcvChatItem user (CDDirectRcv ct'') msg msgMeta (CIRcvDirectEvent RDEContactDeleted)
+          toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct'') ci)
+          toView $ CRContactDeletedByContact user ct''
+        else do
+          contactConns <- withStore $ \db -> getContactConnections db userId c
+          deleteAgentConnectionsAsync user $ map aConnId contactConns
+          withStore' $ \db -> deleteContact db user c
 
     processContactProfileUpdate :: Contact -> Profile -> Bool -> m Contact
     processContactProfileUpdate c@Contact {profile = p} p' createItems
@@ -5396,9 +5391,9 @@ chatCommandP =
       "/_delete user " *> (APIDeleteUser <$> A.decimal <* " del_smp=" <*> onOffP <*> optional (A.space *> jsonP)),
       "/delete user " *> (DeleteUser <$> displayName <*> pure True <*> optional (A.space *> pwdP)),
       ("/user" <|> "/u") $> ShowActiveUser,
-      "/_start" *> (APIStartChat <$> ((A.space *> jsonP) <|> chatCtrlCfgP)),
-      "/_stop close" $> APIStopChat {closeStore = True},
-      "/_stop" $> APIStopChat False,
+      "/_start subscribe=" *> (StartChat <$> onOffP <* " expire=" <*> onOffP <* " xftp=" <*> onOffP),
+      "/_start" $> StartChat True True True,
+      "/_stop" $> APIStopChat,
       "/_app activate" $> APIActivateChat,
       "/_app suspend " *> (APISuspendChat <$> A.decimal),
       "/_resubscribe all" $> ResubscribeAllConnections,
@@ -5626,12 +5621,6 @@ chatCommandP =
     ]
   where
     choice = A.choice . map (\p -> p <* A.takeWhile (== ' ') <* A.endOfInput)
-    chatCtrlCfgP = do
-      subConns <- (" subscribe=" *> onOffP) <|> pure True
-      enableExpireCIs <- (" expire=" *> onOffP) <|> pure True
-      startXFTPWorkers <- (" xftp=" *> onOffP) <|> pure True
-      openDBWithKey <- optional $ " key=" *> dbKeyP
-      pure ChatCtrlCfg {subConns, enableExpireCIs, startXFTPWorkers, openDBWithKey}
     incognitoP = (A.space *> ("incognito" <|> "i")) $> True <|> pure False
     incognitoOnOffP = (A.space *> "incognito=" *> onOffP) <|> pure False
     imagePrefix = (<>) <$> "data:" <*> ("image/png;base64," <|> "image/jpg;base64,")