core (pq): global flag only affects new connections; api to allow PQ in old contacts (#3869)

src/Simplex/Chat.hs

@@ -601,6 +601,18 @@ processChatCommand' vr = \case
   APISetPQEnabled onOff -> do
     asks pqExperimentalEnabled >>= atomically . (`writeTVar` onOff)
     ok_
+  APIAllowContactPQ contactId -> withUser $ \user -> do
+    ct@Contact {activeConn} <- withStore $ \db -> getContact db user contactId
+    -- TODO PQ check different flag?
+    case activeConn of
+      Just conn@Connection {connId, enablePQ}
+        | enablePQ -> pure $ chatCmdError (Just user) "already allowed"
+        | otherwise -> do
+          withStore' $ \db -> allowConnEnablePQ db connId
+          let conn' = conn {enablePQ = True} :: Connection
+              ct' = ct {activeConn = Just conn'} :: Contact
+          pure $ CRContactPQAllowed user ct'
+      Nothing -> throwChatError $ CEContactNotActive ct
   APIExportArchive cfg -> checkChatStopped $ exportArchive cfg >> ok_
   ExportArchive -> do
     ts <- liftIO getCurrentTime
@@ -1294,9 +1306,8 @@ processChatCommand' vr = \case
   APISyncContactRatchet contactId force -> withUser $ \user -> withChatLock "syncContactRatchet" $ do
     ct <- withStore $ \db -> getContact db user contactId
     case contactConn ct of
-      Just conn -> do
-        enablePQ <- contactPQEnc conn
-        cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a (aConnId conn) enablePQ force
+      Just conn@Connection {enablePQ} -> do
+        cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a (aConnId conn) (CR.PQEncryption enablePQ) force
         createInternalChatItem user (CDDirectSnd ct) (CISndConnEvent $ SCERatchetSync rss Nothing) Nothing
         pure $ CRContactRatchetSyncStarted user ct cStats
       Nothing -> throwChatError $ CEContactNotActive ct
@@ -2201,8 +2212,7 @@ processChatCommand' vr = \case
               Nothing -> pure $ UserProfileUpdateSummary 0 0 []
               Just changedCts -> do
                 let idsEvts = L.map ctSndMsg changedCts
-                enablePQ <- readTVarIO =<< asks pqExperimentalEnabled
-                msgReqs_ <- L.zipWith (ctMsgReq enablePQ) changedCts <$> createSndMessages idsEvts
+                msgReqs_ <- L.zipWith ctMsgReq changedCts <$> createSndMessages idsEvts
                 (errs, cts) <- partitionEithers . L.toList . L.zipWith (second . const) changedCts <$> deliverMessagesB msgReqs_
                 unless (null errs) $ toView $ CRChatErrors (Just user) errs
                 let changedCts' = filter (\ChangedProfileContact {ct, ct'} -> directOrUsed ct' && mergedPreferences ct' /= mergedPreferences ct) cts
@@ -2227,11 +2237,11 @@ processChatCommand' vr = \case
             ct' = updateMergedPreferences user' ct
             mergedProfile' = userProfileToSend user' Nothing (Just ct') False
         ctSndMsg :: ChangedProfileContact -> (ConnOrGroupId, PQEncryption, ChatMsgEvent 'Json)
-        ctSndMsg ChangedProfileContact {mergedProfile', conn = Connection {connId, enablePQ = enablePQConn}} = (ConnectionId connId, CR.PQEncryption enablePQConn, XInfo mergedProfile')
-        ctMsgReq :: PQFlag -> ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError MsgReq
-        ctMsgReq enablePQ ChangedProfileContact {conn = conn@Connection {enablePQ = enablePQConn}} =
+        ctSndMsg ChangedProfileContact {mergedProfile', conn = Connection {connId, enablePQ}} = (ConnectionId connId, CR.PQEncryption enablePQ, XInfo mergedProfile')
+        ctMsgReq :: ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError MsgReq
+        ctMsgReq ChangedProfileContact {conn = conn@Connection {enablePQ}} =
           fmap $ \SndMessage {msgId, msgBody} ->
-            (conn, CR.PQEncryption $ enablePQ && enablePQConn, MsgFlags {notification = hasNotification XInfo_}, msgBody, msgId)
+            (conn, CR.PQEncryption enablePQ, MsgFlags {notification = hasNotification XInfo_}, msgBody, msgId)
     updateContactPrefs :: User -> Contact -> Preferences -> m ChatResponse
     updateContactPrefs _ ct@Contact {activeConn = Nothing} _ = throwChatError $ CEContactNotActive ct
     updateContactPrefs user@User {userId} ct@Contact {activeConn = Just Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs'
@@ -6007,9 +6017,8 @@ deleteOrUpdateMemberRecord user@User {userId} member =
 
 sendDirectContactMessage :: (MsgEncodingI e, ChatMonad m) => User -> Contact -> ChatMsgEvent e -> m (SndMessage, Int64)
 sendDirectContactMessage user ct chatMsgEvent = do
-  conn@Connection {connId} <- liftEither $ contactSendConn_ ct
-  pqEnc <- contactPQEnc conn
-  r <- sendDirectMessage conn pqEnc chatMsgEvent (ConnectionId connId)
+  conn@Connection {connId, enablePQ} <- liftEither $ contactSendConn_ ct
+  r <- sendDirectMessage conn (CR.PQEncryption enablePQ) chatMsgEvent (ConnectionId connId)
   let (sndMessage, msgDeliveryId, CR.PQEncryption pqEnabled') = r
   -- TODO PQ use updated ct' and conn'? check downstream if it may affect something, maybe it's not necessary
   (_ct', _conn') <- createContactPQSndItem user ct conn pqEnabled'
@@ -6120,11 +6129,6 @@ deliverMessage' conn pqEnc msgFlags msgBody msgId =
 
 type MsgReq = (Connection, CR.PQEncryption, MsgFlags, MsgBody, MessageId)
 
-contactPQEnc :: ChatMonad m => Connection -> m CR.PQEncryption
-contactPQEnc Connection {enablePQ = enablePQConn} = do
-  enablePQ <- readTVarIO =<< asks pqExperimentalEnabled
-  pure $ CR.PQEncryption $ enablePQ && enablePQConn
-
 deliverMessages :: ChatMonad' m => NonEmpty MsgReq -> m (NonEmpty (Either ChatError (Int64, CR.PQEncryption)))
 deliverMessages msgs = deliverMessagesB $ L.map Right msgs
 
@@ -6708,6 +6712,7 @@ chatCommandP =
       "/_files_encrypt " *> (APISetEncryptLocalFiles <$> onOffP),
       "/contact_merge " *> (SetContactMergeEnabled <$> onOffP),
       "/_pq " *> (APISetPQEnabled <$> onOffP),
+      "/_pq allow " *> (APIAllowContactPQ <$> A.decimal),
       "/_db export " *> (APIExportArchive <$> jsonP),
       "/db export" $> ExportArchive,
       "/_db import " *> (APIImportArchive <$> jsonP),

src/Simplex/Chat/Controller.hs

@@ -245,6 +245,7 @@ data ChatCommand
   | APISetEncryptLocalFiles Bool
   | SetContactMergeEnabled Bool
   | APISetPQEnabled Bool
+  | APIAllowContactPQ ContactId
   | APIExportArchive ArchiveConfig
   | ExportArchive
   | APIImportArchive ArchiveConfig
@@ -699,6 +700,7 @@ data ChatResponse
   | CRRemoteCtrlSessionCode {remoteCtrl_ :: Maybe RemoteCtrlInfo, sessionCode :: Text}
   | CRRemoteCtrlConnected {remoteCtrl :: RemoteCtrlInfo}
   | CRRemoteCtrlStopped {rcsState :: RemoteCtrlSessionState, rcStopReason :: RemoteCtrlStopReason}
+  | CRContactPQAllowed {user :: User, contact :: Contact}
   | CRContactPQEnabled {user :: User, contact :: Contact, pqEnabled :: Bool}
   | CRSQLResult {rows :: [Text]}
   | CRSlowSQLQueries {chatQueries :: [SlowSQLQuery], agentQueries :: [SlowSQLQuery]}

src/Simplex/Chat/Store/Shared.hs

@@ -245,6 +245,17 @@ createIncognitoProfile_ db userId createdAt Profile {displayName, fullName, imag
     (displayName, fullName, image, userId, Just True, createdAt, createdAt)
   insertedRowId db
 
+allowConnEnablePQ :: DB.Connection -> Int64 -> IO ()
+allowConnEnablePQ db connId =
+  DB.execute
+    db
+    [sql|
+      UPDATE connections
+      SET enable_pq = 1
+      WHERE connection_id = ?
+    |]
+    (Only connId)
+
 updateConnPQSndEnabled :: DB.Connection -> Int64 -> PQFlag -> IO ()
 updateConnPQSndEnabled db connId pqSndEnabled =
   DB.execute

src/Simplex/Chat/View.hs

@@ -341,6 +341,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
     ["remote controller " <> sShow rcId <> " session started with " <> plain ctrlDeviceName]
   CRRemoteCtrlStopped {} -> ["remote controller stopped"]
   CRContactPQEnabled u c pqOn -> ttyUser u [ttyContact' c <> ": post-quantum encryption " <> (if pqOn then "enabled" else "disabled")]
+  CRContactPQAllowed u c -> ttyUser u [ttyContact' c <> ": post-quantum encryption allowed"]
   CRSQLResult rows -> map plain rows
   CRSlowSQLQueries {chatQueries, agentQueries} ->
     let viewQuery SlowSQLQuery {query, queryStats = SlowQueryStats {count, timeMax, timeAvg}} =