core (pq): tests (#3882)

* core (pq): tests

* rename

* move

* test allow

* mute test output

* pq combinators

* refactor

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>

src/Simplex/Chat/Messages/CIContent.hs

@@ -270,7 +270,7 @@ ciContentToText = \case
 
 directE2EInfoToText :: E2EInfo -> Text
 directE2EInfoToText E2EInfo {pqEnabled} = case pqEnabled of
-  PQEncOn -> "This conversation is protected by quantum resistant end-to-end encryption. It has perfect forward secrecy, repudiation and quantum resistant break-in recovery."
+  PQEncOn -> e2eInfoPQText
   PQEncOff -> e2eInfoNoPQText
 
 groupE2EInfoToText :: E2EInfo -> Text
@@ -280,6 +280,10 @@ e2eInfoNoPQText :: Text
 e2eInfoNoPQText =
   "This conversation is protected by end-to-end encryption with perfect forward secrecy, repudiation and break-in recovery."
 
+e2eInfoPQText :: Text
+e2eInfoPQText =
+  "This conversation is protected by quantum resistant end-to-end encryption. It has perfect forward secrecy, repudiation and quantum resistant break-in recovery."
+
 ciGroupInvitationToText :: CIGroupInvitation -> GroupMemberRole -> Text
 ciGroupInvitationToText CIGroupInvitation {groupProfile = GroupProfile {displayName, fullName}} role =
   "invitation to join group " <> displayName <> optionalFullName displayName fullName <> " as " <> (decodeLatin1 . strEncode $ role)

src/Simplex/Chat/Types.hs

@@ -49,7 +49,7 @@ import Simplex.Chat.Types.Util
 import Simplex.FileTransfer.Description (FileDigest)
 import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, RcvFileId, SAEntity (..), SndFileId, UserId)
 import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
-import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport)
+import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport, pattern PQEncOff)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, sumTypeJSON, taggedObjectJSON)
 import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI)
@@ -214,8 +214,8 @@ contactDeleted Contact {contactStatus} = contactStatus == CSDeleted
 contactSecurityCode :: Contact -> Maybe SecurityCode
 contactSecurityCode Contact {activeConn} = connectionCode =<< activeConn
 
-contactPQEnabled :: Contact -> Bool
-contactPQEnabled Contact {activeConn} = maybe False connPQEnabled activeConn
+contactPQEnabled :: Contact -> PQEncryption
+contactPQEnabled Contact {activeConn} = maybe PQEncOff connPQEnabled activeConn
 
 data ContactStatus
   = CSActive
@@ -1342,9 +1342,9 @@ aConnId Connection {agentConnId = AgentConnId cId} = cId
 connIncognito :: Connection -> Bool
 connIncognito Connection {customUserProfileId} = isJust customUserProfileId
 
-connPQEnabled :: Connection -> Bool
-connPQEnabled Connection {pqSndEnabled = Just (PQEncryption s), pqRcvEnabled = Just (PQEncryption r)} = s && r
-connPQEnabled _ = False
+connPQEnabled :: Connection -> PQEncryption
+connPQEnabled Connection {pqSndEnabled = Just (PQEncryption s), pqRcvEnabled = Just (PQEncryption r)} = PQEncryption $ s && r
+connPQEnabled _ = PQEncOff
 
 data PendingContactConnection = PendingContactConnection
   { pccConnId :: Int64,

src/Simplex/Chat/View.hs

@@ -1177,7 +1177,7 @@ viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, conta
       incognitoProfile
     <> ["alias: " <> plain localAlias | localAlias /= ""]
     <> [viewConnectionVerified (contactSecurityCode ct)]
-    <> ["post-quantum encryption enabled" | contactPQEnabled ct]
+    <> ["post-quantum encryption enabled" | contactPQEnabled ct == CR.PQEncOn]
     <> maybe [] (\ac -> [viewPeerChatVRange (peerChatVRange ac)]) activeConn
 
 viewGroupInfo :: GroupInfo -> GroupSummary -> [StyledString]

tests/ChatClient.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 

tests/ChatTests/Direct.hs

@@ -10,7 +10,7 @@ import ChatClient
 import ChatTests.Utils
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async (concurrently_)
-import Control.Monad (forM_)
+import Control.Monad (forM_, when)
 import Data.Aeson (ToJSON)
 import qualified Data.Aeson as J
 import qualified Data.ByteString.Char8 as B
@@ -25,7 +25,7 @@ import Simplex.Chat.Protocol (supportedChatVRange)
 import Simplex.Chat.Store (agentStoreFile, chatStoreFile)
 import Simplex.Chat.Types (VersionRangeChat, authErrDisableCount, sameVerificationCode, verificationCode, pattern VersionChat)
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOff)
+import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), pattern PQSupportOff, pattern PQEncOn, pattern PQEncOff)
 import Simplex.Messaging.Util (safeDecodeUtf8)
 import Simplex.Messaging.Version
 import System.Directory (copyFile, doesDirectoryExist, doesFileExist)
@@ -128,6 +128,10 @@ chatDirectTests = do
     it "update peer version range on received messages" testUpdatePeerChatVRange
   describe "network statuses" $ do
     it "should get network statuses" testGetNetworkStatuses
+  describe "PQ tests" $ do
+    describe "enable PQ before connection, connect via invitation link" $ pqMatrix2 runTestPQConnectViaLink
+    describe "enable PQ before connection, connect via contact address" $ pqMatrix2 runTestPQConnectViaAddress
+    it "should enable PQ after several messages in connection without PQ" testPQAllowContact
   where
     testInvVRange vr1 vr2 = it (vRangeStr vr1 <> " - " <> vRangeStr vr2) $ testConnInvChatVRange vr1 vr2
     testReqVRange vr1 vr2 = it (vRangeStr vr1 <> " - " <> vRangeStr vr2) $ testConnReqChatVRange vr1 vr2
@@ -2753,3 +2757,145 @@ contactInfoChatVRange cc (VersionRange minVer maxVer) = do
   cc <## "you've shared main profile with this contact"
   cc <## "connection not verified, use /code command to see security code"
   cc <## ("peer chat protocol version range: (" <> show minVer <> ", " <> show maxVer <> ")")
+
+runTestPQConnectViaLink :: HasCallStack => (TestCC, PQEnabled) -> (TestCC, PQEnabled) -> IO ()
+runTestPQConnectViaLink (alice, aPQ) (bob, bPQ) = do
+  when aPQ $ pqOn alice
+  when bPQ $ pqOn bob
+
+  connectUsers alice bob
+
+  (alice, "hi") `pqSend` bob
+  (bob, "hey") `pqSend` alice
+
+  alice ##> "/_get chat @2 count=100"
+  ra <- chat <$> getTermLine alice
+  ra `shouldContain` [(0, e2eeInfo)]
+  alice `pqForContact` 2 `shouldReturn` PQEncryption pqEnabled
+
+  bob ##> "/_get chat @2 count=100"
+  rb <- chat <$> getTermLine bob
+  rb `shouldContain` [(0, e2eeInfo)]
+  bob `pqForContact` 2 `shouldReturn` PQEncryption pqEnabled
+  where
+    pqEnabled = aPQ && bPQ
+    pqSend = if pqEnabled then (+#>) else (\#>)
+    e2eeInfo = if pqEnabled then e2eeInfoPQStr else e2eeInfoNoPQStr
+
+pqOn :: TestCC -> IO ()
+pqOn cc = do
+  cc ##> "/_pq on"
+  cc <## "ok"
+
+runTestPQConnectViaAddress :: HasCallStack => (TestCC, PQEnabled) -> (TestCC, PQEnabled) -> IO ()
+runTestPQConnectViaAddress (alice, aPQ) (bob, bPQ) = do
+  when aPQ $ pqOn alice
+  when bPQ $ pqOn bob
+
+  alice ##> "/ad"
+  cLink <- getContactLink alice True
+  bob ##> ("/c " <> cLink)
+  alice <#? bob
+  alice @@@ [("<@bob", "")]
+  alice ##> "/ac bob"
+  alice <## "bob (Bob): accepting contact request..."
+  concurrently_
+    (bob <## "alice (Alice): contact is connected")
+    (alice <## "bob (Bob): contact is connected")
+
+  (alice, "hi") `pqSend` bob
+  (bob, "hey") `pqSend` alice
+
+  alice ##> "/_get chat @2 count=100"
+  ra <- chat <$> getTermLine alice
+  ra `shouldContain` [(0, e2eeInfo)]
+  alice `pqForContact` 2 `shouldReturn` PQEncryption pqEnabled
+
+  bob ##> "/_get chat @2 count=100"
+  rb <- chat <$> getTermLine bob
+  rb `shouldContain` [(0, e2eeInfo)]
+  bob `pqForContact` 2 `shouldReturn` PQEncryption pqEnabled
+  where
+    pqEnabled = aPQ && bPQ
+    pqSend = if pqEnabled then (+#>) else (\#>)
+    e2eeInfo = if pqEnabled then e2eeInfoPQStr else e2eeInfoNoPQStr
+
+testPQAllowContact :: HasCallStack => FilePath -> IO ()
+testPQAllowContact =
+  testChat2 aliceProfile bobProfile $ \alice bob -> do
+    connectUsers alice bob
+    (alice, "hi") \#> bob
+    (bob, "hey") \#> alice
+
+    alice ##> "/_get chat @2 count=100"
+    ra <- chat <$> getTermLine alice
+    ra `shouldContain` [(0, e2eeInfoNoPQStr)]
+    PQEncOff <- alice `pqForContact` 2
+
+    bob ##> "/_get chat @2 count=100"
+    rb <- chat <$> getTermLine bob
+    rb `shouldContain` [(0, e2eeInfoNoPQStr)]
+    PQEncOff <- bob `pqForContact` 2
+
+    sendMany PQEncOff alice bob
+    PQEncOff <- alice `pqForContact` 2
+    PQEncOff <- bob `pqForContact` 2
+
+    -- enabling experimental flags doesn't enable PQ in previously created connection
+    pqOn alice
+    sendMany PQEncOff alice bob
+    PQEncOff <- alice `pqForContact` 2
+    PQEncOff <- bob `pqForContact` 2
+
+    pqOn bob
+    sendMany PQEncOff alice bob
+    PQEncOff <- alice `pqForContact` 2
+    PQEncOff <- bob `pqForContact` 2
+
+    -- if only one contact allows PQ, it's not enabled
+    alice ##> "/_pq allow 2"
+    alice <## "bob: post-quantum encryption allowed"
+    sendMany PQEncOff alice bob
+    PQEncOff <- alice `pqForContact` 2
+    PQEncOff <- bob `pqForContact` 2
+
+    -- both contacts have to allow PQ to enable it
+    bob ##> "/_pq allow 2"
+    bob <## "alice: post-quantum encryption allowed"
+
+    (alice, "1") \#> bob
+    (bob, "2") \#> alice
+    (alice, "3") \#> bob
+    (bob, "4") \#> alice
+    (alice, "5") +#> bob
+
+    PQEncOff <- alice `pqForContact` 2
+    PQEncOff <- bob `pqForContact` 2
+
+    (bob, "6") ++#> alice
+    -- equivalent to:
+    -- bob `send` "@alice 6"
+    -- bob <## "alice: post-quantum encryption enabled"
+    -- bob <# "@alice 6"
+    -- alice <## "bob: post-quantum encryption enabled"
+    -- alice <# "bob> 6"
+
+    PQEncOn <- alice `pqForContact` 2
+    alice #$> ("/_get chat @2 count=2", chat, [(0, "post-quantum encryption enabled"), (0, "6")])
+
+    PQEncOn <- bob `pqForContact` 2
+    bob #$> ("/_get chat @2 count=2", chat, [(1, "post-quantum encryption enabled"), (1, "6")])
+
+    (alice, "6") +#> bob
+    (bob, "7") +#> alice
+
+    sendMany PQEncOn alice bob
+
+    PQEncOn <- alice `pqForContact` 2
+    PQEncOn <- bob `pqForContact` 2
+    pure ()
+  where
+    sendMany pqEnc alice bob =
+      forM_ [(1 :: Int) .. 10] $ \i -> do
+        sndRcv pqEnc False (alice, show i) bob
+        sndRcv pqEnc False (bob, show i) alice

tests/ChatTests/Utils.hs

@@ -21,8 +21,9 @@ import Data.String
 import qualified Data.Text as T
 import Database.SQLite.Simple (Only (..))
 import Simplex.Chat.Controller (ChatConfig (..), ChatController (..))
-import Simplex.Chat.Messages.CIContent (e2eInfoNoPQText)
+import Simplex.Chat.Messages.CIContent (e2eInfoNoPQText, e2eInfoPQText)
 import Simplex.Chat.Protocol
+import Simplex.Chat.Store.Direct (getContact)
 import Simplex.Chat.Store.NoteFolders (createNoteFolder)
 import Simplex.Chat.Store.Profiles (getUserContactProfiles)
 import Simplex.Chat.Types
@@ -30,7 +31,7 @@ import Simplex.Chat.Types.Preferences
 import Simplex.FileTransfer.Client.Main (xftpClientCLI)
 import Simplex.Messaging.Agent.Store.SQLite (maybeFirstRow, withTransaction)
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
-import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOff)
+import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Version
 import System.Directory (doesFileExist)
@@ -114,6 +115,17 @@ runTestCfg3 aliceCfg bobCfg cathCfg runTest tmp =
       withNewTestChatCfg tmp cathCfg "cath" cathProfile $ \cath ->
         runTest alice bob cath
 
+type PQEnabled = Bool
+
+pqMatrix2 :: (HasCallStack => (TestCC, PQEnabled) -> (TestCC, PQEnabled) -> IO ()) -> SpecWith FilePath
+pqMatrix2 runTest = do
+  it "PQ: off, off" $ test False False
+  it "PQ: on, off" $ test False True
+  it "PQ: off, on" $ test True False
+  it "PQ: on, on" $ test True True
+  where
+    test aPQ bPQ = testChat2 aliceProfile bobProfile $ \a b -> runTest (a, aPQ) (b, bPQ)
+
 withTestChatGroup3Connected :: HasCallStack => FilePath -> String -> (HasCallStack => TestCC -> IO a) -> IO a
 withTestChatGroup3Connected tmp dbPrefix action = do
   withTestChat tmp dbPrefix $ \cc -> do
@@ -172,6 +184,32 @@ cc #$> (cmd, f, res) = do
   cc ##> cmd
   (f <$> getTermLine cc) `shouldReturn` res
 
+-- / PQ combinators
+
+(\#>) :: HasCallStack => (TestCC, String) -> TestCC -> IO ()
+(\#>) = sndRcv PQEncOff False
+
+(+#>) :: HasCallStack => (TestCC, String) -> TestCC -> IO ()
+(+#>) = sndRcv PQEncOn False
+
+(++#>) :: HasCallStack => (TestCC, String) -> TestCC -> IO ()
+(++#>) = sndRcv PQEncOn True
+
+sndRcv :: HasCallStack => PQEncryption -> Bool -> (TestCC, String) -> TestCC -> IO ()
+sndRcv pqEnc enabled (cc1, msg) cc2 = do
+  name1 <- userName cc1
+  name2 <- userName cc2
+  let cmd = "@" <> name2 <> " " <> msg
+  cc1 `send` cmd
+  when enabled $ cc1 <## (name2 <> ": post-quantum encryption enabled")
+  cc1 <# cmd
+  cc1 `pqSndForContact` 2 `shouldReturn` pqEnc
+  when enabled $ cc2 <## (name1 <> ": post-quantum encryption enabled")
+  cc2 <# (name1 <> "> " <> msg)
+  cc2 `pqRcvForContact` 2 `shouldReturn` pqEnc
+
+-- PQ combinators /
+
 chat :: String -> [(Int, String)]
 chat = map (\(a, _, _) -> a) . chat''
 
@@ -206,6 +244,9 @@ chatFeatures'' =
 e2eeInfoNoPQStr :: String
 e2eeInfoNoPQStr = T.unpack e2eInfoNoPQText
 
+e2eeInfoPQStr :: String
+e2eeInfoPQStr = T.unpack e2eInfoPQText
+
 lastChatFeature :: String
 lastChatFeature = snd $ last chatFeatures
 
@@ -476,6 +517,27 @@ getProfilePictureByName cc displayName =
     maybeFirstRow fromOnly $
       DB.query db "SELECT image FROM contact_profiles WHERE display_name = ? LIMIT 1" (Only displayName)
 
+pqSndForContact :: TestCC -> ContactId -> IO PQEncryption
+pqSndForContact = pqForContact_ pqSndEnabled
+
+pqRcvForContact :: TestCC -> ContactId -> IO PQEncryption
+pqRcvForContact = pqForContact_ pqRcvEnabled
+
+pqForContact :: TestCC -> ContactId -> IO PQEncryption
+pqForContact = pqForContact_ (Just . connPQEnabled)
+
+pqForContact_ :: (Connection -> Maybe PQEncryption) -> TestCC -> ContactId -> IO PQEncryption
+pqForContact_ pqSel cc contactId =
+  getTestCCContact cc contactId >>= \ct -> case contactConn ct of
+    Just conn -> pure $ fromMaybe PQEncOff $ pqSel conn
+    Nothing -> fail "no connection"
+
+getTestCCContact :: TestCC -> ContactId -> IO Contact
+getTestCCContact cc contactId =
+  withCCTransaction cc $ \db ->
+    withCCUser cc $ \user ->
+      runExceptT (getContact db user contactId) >>= either (fail . show) pure
+
 lastItemId :: HasCallStack => TestCC -> IO String
 lastItemId cc = do
   cc ##> "/last_item_id"