fix, debug

src/Simplex/Chat/Library/Internal.hs

@@ -1803,7 +1803,6 @@ metaBrokerTs MsgMeta {broker = (_, brokerTs)} = brokerTs
 
 createContactPQSndItem :: User -> Contact -> Connection -> PQEncryption -> CM (Contact, Connection)
 createContactPQSndItem user ct conn@Connection {pqSndEnabled} pqSndEnabled' =
-  (liftIO (putStrLn $ "PQ-DEBUG snd " <> show (localDisplayName' ct) <> " " <> show pqSndEnabled <> " -> " <> show pqSndEnabled') >>) $
   flip catchAllErrors (const $ pure (ct, conn)) $ case (pqSndEnabled, pqSndEnabled') of
     (Just b, b') | b' /= b -> createPQItem $ CISndConnEvent (SCEPqEnabled pqSndEnabled')
     (Nothing, PQEncOn) -> createPQItem $ CISndDirectE2EEInfo (e2eInfoEncrypted $ Just pqSndEnabled')
@@ -1819,7 +1818,6 @@ createContactPQSndItem user ct conn@Connection {pqSndEnabled} pqSndEnabled' =
 
 updateContactPQRcv :: User -> Contact -> Connection -> PQEncryption -> CM (Contact, Connection)
 updateContactPQRcv user ct conn@Connection {connId, pqRcvEnabled} pqRcvEnabled' =
-  (liftIO (putStrLn $ "PQ-DEBUG rcv " <> show (localDisplayName' ct) <> " " <> show pqRcvEnabled <> " -> " <> show pqRcvEnabled') >>) $
   flip catchAllErrors (const $ pure (ct, conn)) $ case (pqRcvEnabled, pqRcvEnabled') of
     (Just b, b') | b' /= b -> updatePQ $ CIRcvConnEvent (RCEPqEnabled pqRcvEnabled')
     (Nothing, PQEncOn) -> updatePQ $ CIRcvDirectE2EEInfo (e2eInfoEncrypted $ Just pqRcvEnabled')

src/Simplex/Chat/Library/Subscriber.hs

@@ -664,7 +664,6 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
             XOk -> pure ()
             _ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok"
         CON pqEnc -> do
-          liftIO $ putStrLn $ "PQ-DEBUG con " <> show (localDisplayName' ct) <> " " <> show pqEnc
           when (pqEnc == PQEncOn) $ withStore' $ \db -> updateConnPQEnabledCON db connId pqEnc
           let conn' = conn {pqSndEnabled = Just pqEnc, pqRcvEnabled = Just pqEnc} :: Connection
               ct' = ct {activeConn = Just conn'} :: Contact

tests/Bots/BadgeService/WebTests.hs

@@ -53,7 +53,9 @@ import Data.Time.Calendar (fromGregorian)
 import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, picosecondsToDiffTime, secondsToDiffTime)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 import Data.Word (Word32, Word8)
-import GHC.IO.Handle (hDuplicate, hDuplicateTo)
+import qualified GHC.IO.Device as IODevice
+import qualified GHC.IO.FD as FD
+import GHC.IO.Handle.FD (handleToFd)
 import Network.HTTP.Client (Manager, Request (..), RequestBody (..), Response, defaultManagerSettings, httpLbs, newManager, parseRequest, responseBody, responseHeaders, responseStatus, responseTimeoutMicro)
 import Network.HTTP.Types (Header, HeaderName, hCacheControl, hContentType)
 import Network.HTTP.Types.Status (statusCode)
@@ -72,7 +74,7 @@ import Simplex.Messaging.Encoding.String (textDecode, textEncode)
 import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
 import System.Directory (createDirectoryIfMissing, createFileLink, doesFileExist, listDirectory)
 import System.FilePath ((</>))
-import System.IO (IOMode (..), hClose, hGetBuffering, hSetBuffering, stderr, withFile)
+import System.IO (IOMode (..), hFlush, stderr, withFile)
 import System.IO.Unsafe (unsafePerformIO)
 import System.Timeout (timeout)
 import Test.Hspec
@@ -2675,16 +2677,16 @@ stderrCaptureLock :: MVar ()
 stderrCaptureLock = unsafePerformIO $ newMVar ()
 {-# NOINLINE stderrCaptureLock #-}
 
--- hDuplicateTo changes stderr's buffering, so put the original setting back.
 capturingStderr :: IO () -> IO Text
 capturingStderr action = withMVar stderrCaptureLock $ \_ -> do
   createDirectoryIfMissing True "tests/tmp"
   withTempDirectory "tests/tmp" "badge-stderr" $ \dir -> do
     let path = dir </> "stderr.log"
     withFile path WriteMode $ \h -> do
-      buffering <- hGetBuffering stderr
-      saved <- hDuplicate stderr
-      (hDuplicateTo h stderr >> action) `E.finally` (hDuplicateTo saved stderr >> hClose saved >> hSetBuffering stderr buffering)
+      fd <- handleToFd h
+      hFlush stderr
+      saved <- IODevice.dup FD.stderr
+      (IODevice.dup2 fd FD.stderr >> action) `E.finally` (hFlush stderr >> IODevice.dup2 saved FD.stderr >> IODevice.close saved)
     T.readFile path
 
 loggedError :: Text -> Text -> Bool

tests/ChatTests/Profiles.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -14,7 +15,7 @@ import ChatClient
 import ChatTests.DBUtils
 import ChatTests.Utils
 import Control.Concurrent (threadDelay)
-import Control.Concurrent.Async (concurrently_)
+import Control.Concurrent.Async (concurrently, concurrently_)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader (runReaderT)
@@ -5148,14 +5149,24 @@ testShortLinkInvitationChangeUser = testChat2 aliceProfile bobProfile test
         <### [ "alisa: connection started",
                WithTime "@alisa hello"
              ]
-      concurrently_
-        (bob <## "alisa: contact is connected")
-        ( alice
-            <### [ WithTime "bob> hello",
-                   "bob (Bob): contact is connected"
-                 ]
-        )
-      alice <##> bob
+      (_, connectedFirst) <-
+        concurrently
+          (bob <## "alisa: contact is connected")
+          ( getTermLine alice >>= \case
+              "bob (Bob): contact is connected" -> do
+                alice <## "bob: standard end-to-end encryption enabled"
+                alice <# "bob> hello"
+                pure True
+              l -> do
+                dropTime l `shouldBe` "bob> hello"
+                alice <## "bob (Bob): contact is connected"
+                pure False
+          )
+      alice #> "@bob hi"
+      bob <# "alisa> hi"
+      bob #> "@alisa hey"
+      when connectedFirst $ alice <## "bob: quantum resistant end-to-end encryption enabled"
+      alice <# "bob> hey"
 
 testShortLinkAddressChangeProfile :: HasCallStack => TestParams -> IO ()
 testShortLinkAddressChangeProfile = testChat2 aliceProfile bobProfile test