SimpleX-Chat/tests/ChatTests/Utils.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}

module ChatTests.Utils where

import ChatClient
import ChatTests.DBUtils
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_, mapConcurrently_)
import Control.Concurrent.STM
import Control.Monad (unless, when)
import Control.Monad.Except (runExceptT)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as B
import Data.Char (isDigit)
import Data.List (isPrefixOf, isSuffixOf)
import Data.Maybe (fromMaybe)
import Data.String
import qualified Data.Text as T
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..))
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
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.FileTransfer.Client.Main (xftpClientCLI)
import Simplex.Messaging.Agent.Client (agentClientStore)
import Simplex.Messaging.Agent.Store.AgentStore (maybeFirstRow, withTransaction)
import qualified Simplex.Messaging.Agent.Store.DB as DB
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Version
import System.Directory (doesFileExist)
import System.Environment (lookupEnv, withArgs)
import System.IO.Silently (capture_)
import System.Info (os)
import Test.Hspec hiding (it)
import qualified Test.Hspec as Hspec
import UnliftIO (timeout)
#if defined(dbPostgres)
import Database.PostgreSQL.Simple (Only (..))
#else
import Database.SQLite.Simple (Only (..))
#endif

defaultPrefs :: Maybe Preferences
defaultPrefs = Just $ toChatPrefs defaultChatPrefs

aliceDesktopProfile :: Profile
aliceDesktopProfile = Profile {displayName = "alice_desktop", fullName = "Alice Desktop", image = Nothing, contactLink = Nothing, preferences = defaultPrefs}

aliceProfile :: Profile
aliceProfile = Profile {displayName = "alice", fullName = "Alice", image = Nothing, contactLink = Nothing, preferences = defaultPrefs}

bobProfile :: Profile
bobProfile = Profile {displayName = "bob", fullName = "Bob", image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABgAAAAYCAYAAADgdz34AAAKHGlDQ1BJQ0MgUHJvZmlsZQAASImFVgdUVNcWve9Nb7QZeu9NehtAem/Sq6gMQ28OQxWxgAQjEFFEREARNFQFg1KjiIhiIQgoYA9IEFBisCAq6OQNJNH4//r/zDpz9ttzz7n73ffWmg0A6QCDxYqD+QCIT0hmezlYywQEBsngngEYCAIy0AC6DGYSy8rDwxUg8Xf9d7wbAxC33tHgzvrP3/9nCISFJzEBgIIRTGey2MkILkawT1oyi4tnEUxjI6IQvMLFkauYqxjQQtewwuoaHy8bBNMBwJMZDHYkAERbhJdJZUYic4hhCNZOCItOQDB3vjkzioFwxLsIXhcRl5IOAImrRzs+fivCk7QRrIL0shAcwNUW+tX8yH/tFfrPXgxG5D84Pi6F+dc9ck+HHJ7g641UMSQlQATQBHEgBaQDGcACbLAVYaIRJhx5Dv+9j77aZ4OsZIFtSEc0iARRIBnpt/9qlvfqpGSQBhjImnCEcUU+NtxnujZy4fbqVEiU/wuXdQyA9S0cDqfzC+e2F4DzyLkSB79wyi0A8KoBcL2GmcJOXePQ3C8MIAJeQAOiQArIAxXuWwMMgSmwBHbAGbgDHxAINgMmojceUZUGMkEWyAX54AA4DMpAJTgJ6sAZ0ALawQVwGVwDt8AQGAUPwQSYBi/AAngHliEIwkEUiAqJQtKQIqQO6UJ0yByyg1whLygQCoEioQQoBcqE9kD5UBFUBlVB9dBPUCd0GboBDUP3oUloDnoNfYRRMBmmwZKwEqwF02Er2AX2gTfBkXAinAHnwPvhUrgaPg23wZfhW/AoPAG/gBdRAEVCCaFkURooOsoG5Y4KQkWg2KidqDxUCaoa1YTqQvWj7qAmUPOoD2gsmoqWQWugTdGOaF80E52I3okuQJeh69Bt6D70HfQkegH9GUPBSGDUMSYYJ0wAJhKThsnFlGBqMK2Yq5hRzDTmHRaLFcIqY42wjthAbAx2O7YAewzbjO3BDmOnsIs4HE4Up44zw7njGLhkXC7uKO407hJuBDeNe48n4aXxunh7fBA+AZ+NL8E34LvxI/gZ/DKBj6BIMCG4E8II2wiFhFOELsJtwjRhmchPVCaaEX2IMcQsYimxiXiV+Ij4hkQiyZGMSZ6kaNJuUinpLOk6aZL0gSxAViPbkIPJKeT95FpyD/k++Q2FQlGiWFKCKMmU/ZR6yhXKE8p7HiqPJo8TTxjPLp5ynjaeEZ6XvAReRV4r3s28GbwlvOd4b/PO8xH4lPhs+Bh8O/nK+Tr5xvkW+an8Ovzu/PH8BfwN/Df4ZwVwAkoCdgJhAjkCJwWuCExRUVR5qg2VSd1DPUW9Sp2mYWnKNCdaDC2fdoY2SFsQFBDUF/QTTBcsF7woOCGEElISchKKEyoUahEaE/ooLClsJRwuvE+4SXhEeElEXMRSJFwkT6RZZFTko6iMqJ1orOhB0XbRx2JoMTUxT7E0seNiV8XmxWnipuJM8TzxFvEHErCEmoSXxHaJkxIDEouSUpIOkizJo5JXJOelhKQspWKkiqW6peakqdLm0tHSxdKXpJ/LCMpYycTJlMr0ySzISsg6yqbIVskOyi7LKcv5ymXLNcs9lifK0+Uj5Ivle+UXFKQV3BQyFRoVHigSFOmKUYpHFPsVl5SUlfyV9iq1K80qiyg7KWcoNyo/UqGoWKgkqlSr3FXFqtJVY1WPqQ6pwWoGalFq5Wq31WF1Q/Vo9WPqw+sw64zXJayrXjeuQdaw0kjVaNSY1BTSdNXM1mzXfKmloBWkdVCrX+uztoF2nPYp7Yc6AjrOOtk6XTqvddV0mbrlunf1KHr2erv0OvRe6avrh+sf179nQDVwM9hr0GvwydDIkG3YZDhnpGAUYlRhNE6n0T3oBfTrxhhja+NdxheMP5gYmiSbtJj8YaphGmvaYDq7Xnl9+PpT66fM5MwYZlVmE+Yy5iHmJ8wnLGQtGBbVFk8t5S3DLGssZ6xUrWKsTlu9tNa2Zlu3Wi/ZmNjssOmxRdk62ObZDtoJ2Pnaldk9sZezj7RvtF9wMHDY7tDjiHF0cTzoOO4k6cR0qndacDZy3uHc50J28XYpc3nqqubKdu1yg92c3Q65PdqguCFhQ7s7cHdyP+T+2EPZI9HjZ0+sp4dnueczLx2vTK9+b6r3Fu8G73c+1j6FPg99VXxTfHv9eP2C/er9lvxt/Yv8JwK0AnYE3AoUC4wO7AjCBfkF1QQtbrTbeHjjdLBBcG7w2CblTembbmwW2xy3+eIW3i2MLedCMCH+IQ0hKwx3RjVjMdQptCJ0gWnDPMJ8EWYZVhw2F24WXhQ+E2EWURQxG2kWeShyLsoiqiRqPtomuiz6VYxjTGXMUqx7bG0sJ84/rjkeHx8S35kgkBCb0LdVamv61mGWOiuXNZFokng4cYHtwq5JgpI2JXUk05A/0oEUlZTvUiZTzVPLU9+n+aWdS+dPT0gf2Ka2bd+2mQz7jB+3o7czt/dmymZmZU7usNpRtRPaGbqzd5f8rpxd07sddtdlEbNis37J1s4uyn67x39PV45kzu6cqe8cvmvM5cll547vNd1b+T36++jvB/fp7Tu673NeWN7NfO38kvyVAmbBzR90fij9gbM/Yv9goWHh8QPYAwkHxg5aHKwr4i/KKJo65HaorVimOK/47eEth2+U6JdUHiEeSTkyUepa2nFU4eiBoytlUWWj5dblzRUSFfsqlo6FHRs5bnm8qVKyMr/y44noE/eqHKraqpWqS05iT6aefHbK71T/j/Qf62vEavJrPtUm1E7UedX11RvV1zdINBQ2wo0pjXOng08PnbE909Gk0VTVLNScfxacTTn7/KeQn8ZaXFp6z9HPNZ1XPF/RSm3Na4PatrUttEe1T3QEdgx3Onf2dpl2tf6s+XPtBdkL5RcFLxZ2E7tzujmXMi4t9rB65i9HXp7q3dL78ErAlbt9nn2DV12uXr9mf+1Kv1X/petm1y/cMLnReZN+s/2W4a22AYOB1l8MfmkdNBxsu210u2PIeKhreP1w94jFyOU7tneu3XW6e2t0w+jwmO/YvfHg8Yl7Yfdm78fdf/Ug9cHyw92PMI/yHvM9Lnki8aT6V9VfmycMJy5O2k4OPPV++nCKOfXit6TfVqZznlGelcxIz9TP6s5emLOfG3q+8fn0C9aL5fnc3/l/r3ip8vL8H5Z/DCwELEy/Yr/ivC54I/qm9q3+295Fj8Un7+LfLS/lvRd9X/eB/qH/o//HmeW0FdxK6SfVT12fXT4/4sRzOCwGm7FqBVBIwhERALyuBYASCAB1CPEPG9f8119+BvrK2fyNwVndL5jhvubRVsMQgCakeCFp04OsQ1LJEgAe5NodqT6WANbT+yf/iqQIPd21PXgaAcDJcjivtwJAQHLFgcNZ9uBwPlUgYhHf1z37f7V9g9e8ITewiP88wfWIYET6HPg21nzjV2fybQVcxfrg2/onng/F50lD/ccAAAA4ZVhJZk1NACoAAAAIAAGHaQAEAAAAAQAAABoAAAAAAAKgAgAEAAAAAQAAABigAwAEAAAAAQAAABgAAAAAwf1XlwAAAaNJREFUSA3FlT1LA0EQQBN/gYUYRTksJZVgEbCR/D+7QMr8ABtttBBCsLGzsLG2sxaxED/ie4d77u0dyaE5HHjczn7MzO7M7nU6/yXz+bwLhzCCjTQO+rZhDH3opuNLdRYN4RHe4RIKJ7R34Ro+4AEGSw2mE1iUwT18gpI74WvkGlccu4XNdH0jnYU7cAUacidn37qR23cOxc4aGU0nYUAn7iSWEHkz46w0ocdQu1X6B/AMQZ5o7KfBqNOfwRH8JB7FajGhnmcpKvQe3MEbvILiDm5gPXaCHnZr4vvFGMoEKudKn8YvQIOOe+YzCPop7dwJ3zRfJ7GDuso4YJGRa0yZgg4tUaNXdGrbuZWKKxzYYEJc2xp9AUUjGt8KC2j

cathProfile :: Profile
cathProfile = Profile {displayName = "cath", fullName = "Catherine", image = Nothing, contactLink = Nothing, preferences = defaultPrefs}

danProfile :: Profile
danProfile = Profile {displayName = "dan", fullName = "Daniel", image = Nothing, contactLink = Nothing, preferences = defaultPrefs}

businessProfile :: Profile
businessProfile = Profile {displayName = "biz", fullName = "Biz Inc", image = Nothing, contactLink = Nothing, preferences = defaultPrefs}

it :: HasCallStack => String -> (TestParams -> Expectation) -> SpecWith (Arg (TestParams -> Expectation))
it name test =
  Hspec.it name $ \tmp -> timeout t (test tmp) >>= maybe (error "test timed out") pure
  where
    t = 90 * 1000000

xit' :: HasCallStack => String -> (TestParams -> Expectation) -> SpecWith (Arg (TestParams -> Expectation))
xit' = if os == "linux" then xit else it

xit'' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
xit'' = ifCI xit Hspec.it

xdescribe'' :: HasCallStack => String -> SpecWith a -> SpecWith a
xdescribe'' = ifCI xdescribe describe

ifCI :: HasCallStack => (HasCallStack => String -> a -> SpecWith b) -> (HasCallStack => String -> a -> SpecWith b) -> String -> a -> SpecWith b
ifCI xrun run d t = do
  ci <- runIO $ lookupEnv "CI"
  (if ci == Just "true" then xrun else run) d t

skip :: String -> SpecWith a -> SpecWith a
skip = before_ . pendingWith

-- Bool is pqExpected - see testAddContact
versionTestMatrix2 :: (HasCallStack => Bool -> TestCC -> TestCC -> IO ()) -> SpecWith TestParams
versionTestMatrix2 runTest = do
  it "current" $ testChat2 aliceProfile bobProfile (runTest True)
  it "prev" $ testChatCfg2 testCfgVPrev aliceProfile bobProfile (runTest False)
  it "prev to curr" $ runTestCfg2 testCfg testCfgVPrev (runTest False)
  it "curr to prev" $ runTestCfg2 testCfgVPrev testCfg (runTest False)
  it "old (1st supported)" $ testChatCfg2 testCfgV1 aliceProfile bobProfile (runTest False)
  it "old to curr" $ runTestCfg2 testCfg testCfgV1 (runTest False)
  it "curr to old" $ runTestCfg2 testCfgV1 testCfg (runTest False)

versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith TestParams
versionTestMatrix3 runTest = do
  it "current" $ testChat3 aliceProfile bobProfile cathProfile runTest
  it "prev" $ testChatCfg3 testCfgVPrev aliceProfile bobProfile cathProfile runTest
  it "prev to curr" $ runTestCfg3 testCfg testCfgVPrev testCfgVPrev runTest
  it "curr+prev to curr" $ runTestCfg3 testCfg testCfg testCfgVPrev runTest
  it "curr to prev" $ runTestCfg3 testCfgVPrev testCfg testCfg runTest
  it "curr+prev to prev" $ runTestCfg3 testCfgVPrev testCfg testCfgVPrev runTest

runTestCfg2 :: ChatConfig -> ChatConfig -> (HasCallStack => TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
runTestCfg2 aliceCfg bobCfg runTest ps =
  withNewTestChatCfg ps aliceCfg "alice" aliceProfile $ \alice ->
    withNewTestChatCfg ps bobCfg "bob" bobProfile $ \bob ->
      runTest alice bob

runTestCfg3 :: ChatConfig -> ChatConfig -> ChatConfig -> (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> TestParams -> IO ()
runTestCfg3 aliceCfg bobCfg cathCfg runTest ps =
  withNewTestChatCfg ps aliceCfg "alice" aliceProfile $ \alice ->
    withNewTestChatCfg ps bobCfg "bob" bobProfile $ \bob ->
      withNewTestChatCfg ps cathCfg "cath" cathProfile $ \cath ->
        runTest alice bob cath

withTestChatGroup3Connected :: HasCallStack => TestParams -> String -> (HasCallStack => TestCC -> IO a) -> IO a
withTestChatGroup3Connected ps dbPrefix action = do
  withTestChat ps dbPrefix $ \cc -> do
    cc <## "2 contacts connected (use /cs for the list)"
    cc <## "#team: connected to server(s)"
    action cc

withTestChatGroup3Connected' :: HasCallStack => TestParams -> String -> IO ()
withTestChatGroup3Connected' ps dbPrefix = withTestChatGroup3Connected ps dbPrefix $ \_ -> pure ()

withTestChatContactConnected :: HasCallStack => TestParams -> String -> (HasCallStack => TestCC -> IO a) -> IO a
withTestChatContactConnected ps dbPrefix action =
  withTestChat ps dbPrefix $ \cc -> do
    cc <## "1 contacts connected (use /cs for the list)"
    action cc

withTestChatContactConnected' :: HasCallStack => TestParams -> String -> IO ()
withTestChatContactConnected' ps dbPrefix = withTestChatContactConnected ps dbPrefix $ \_ -> pure ()

withTestChatContactConnectedV1 :: HasCallStack => TestParams -> String -> (HasCallStack => TestCC -> IO a) -> IO a
withTestChatContactConnectedV1 ps dbPrefix action =
  withTestChatV1 ps dbPrefix $ \cc -> do
    cc <## "1 contacts connected (use /cs for the list)"
    action cc

withTestChatContactConnectedV1' :: HasCallStack => TestParams -> String -> IO ()
withTestChatContactConnectedV1' ps dbPrefix = withTestChatContactConnectedV1 ps dbPrefix $ \_ -> pure ()

-- | test sending direct messages
(<##>) :: HasCallStack => TestCC -> TestCC -> IO ()
cc1 <##> cc2 = do
  name1 <- userName cc1
  name2 <- userName cc2
  cc1 #> ("@" <> name2 <> " hi")
  cc2 <# (name1 <> "> hi")
  cc2 #> ("@" <> name1 <> " hey")
  cc1 <# (name2 <> "> hey")

(##>) :: HasCallStack => TestCC -> String -> IO ()
cc ##> cmd = do
  cc `send` cmd
  cc <## cmd

(#>) :: HasCallStack => TestCC -> String -> IO ()
cc #> cmd = do
  cc `send` cmd
  cc <# cmd

(?#>) :: HasCallStack => TestCC -> String -> IO ()
cc ?#> cmd = do
  cc `send` cmd
  cc <# ("i " <> cmd)

(#$>) :: (Eq a, Show a, HasCallStack) => TestCC -> (String, String -> a, a) -> Expectation
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 <> ": quantum resistant end-to-end encryption enabled")
  cc1 <# cmd
  cc1 `pqSndForContact` 2 `shouldReturn` pqEnc
  when enabled $ cc2 <## (name1 <> ": quantum resistant end-to-end encryption enabled")
  cc2 <# (name1 <> "> " <> msg)
  cc2 `pqRcvForContact` 2 `shouldReturn` pqEnc

(\:#>) :: HasCallStack => (TestCC, String, VersionChat) -> (TestCC, VersionChat) -> IO ()
(\:#>) = sndRcvImg PQEncOff False

(+:#>) :: HasCallStack => (TestCC, String, VersionChat) -> (TestCC, VersionChat) -> IO ()
(+:#>) = sndRcvImg PQEncOn False

(++:#>) :: HasCallStack => (TestCC, String, VersionChat) -> (TestCC, VersionChat) -> IO ()
(++:#>) = sndRcvImg PQEncOn True

sndRcvImg :: HasCallStack => PQEncryption -> Bool -> (TestCC, String, VersionChat) -> (TestCC, VersionChat) -> IO ()
sndRcvImg pqEnc enabled (cc1, msg, v1) (cc2, v2) = do
  name1 <- userName cc1
  name2 <- userName cc2
  g <- C.newRandom
  img <- atomically $ B64.encode <$> C.randomBytes lrgLen g
  cc1 `send` ("/_send @2 json {\"msgContent\":{\"type\":\"image\",\"text\":\"" <> msg <> "\",\"image\":\"" <> B.unpack img <> "\"}}")
  cc1 .<## "}}"
  cc1 <### ([ConsoleString (name2 <> ": quantum resistant end-to-end encryption enabled") | enabled] <> [WithTime ("@" <> name2 <> " " <> msg)])
  cc1 `pqSndForContact` 2 `shouldReturn` pqEnc
  cc1 `pqVerForContact` 2 `shouldReturn` v1
  cc2 <### ([ConsoleString (name1 <> ": quantum resistant end-to-end encryption enabled") | enabled] <> [WithTime (name1 <> "> " <> msg)])
  cc2 `pqRcvForContact` 2 `shouldReturn` pqEnc
  cc2 `pqVerForContact` 2 `shouldReturn` v2
  where
    lrgLen = maxEncodedMsgLength * 3 `div` 4 - 110 -- 98 is ~ max size for binary image preview given the rest of the message

genProfileImg :: IO ByteString
genProfileImg = do
  g <- C.newRandom
  atomically $ B64.encode <$> C.randomBytes lrgLen g
  where
    lrgLen = maxEncodedInfoLength * 3 `div` 4 - 420

-- PQ combinators /

chat :: String -> [(Int, String)]
chat = map (\(a, _, _) -> a) . chat''

chat' :: String -> [((Int, String), Maybe (Int, String))]
chat' = map (\(a, b, _) -> (a, b)) . chat''

chatF :: String -> [((Int, String), Maybe String)]
chatF = map (\(a, _, c) -> (a, c)) . chat''

chat'' :: String -> [((Int, String), Maybe (Int, String), Maybe String)]
chat'' = read

chatFeatures :: [(Int, String)]
chatFeatures = map (\(a, _, _) -> a) chatFeatures''

chatFeatures' :: [((Int, String), Maybe (Int, String))]
chatFeatures' = map (\(a, b, _) -> (a, b)) chatFeatures''

chatFeaturesF :: [((Int, String), Maybe String)]
chatFeaturesF = map (\(a, _, c) -> (a, c)) chatFeatures''

chatFeatures'' :: [((Int, String), Maybe (Int, String), Maybe String)]
chatFeatures'' =
  [ ((0, e2eeInfoPQStr), Nothing, Nothing),
    ((0, "Disappearing messages: allowed"), Nothing, Nothing),
    ((0, "Full deletion: off"), Nothing, Nothing),
    ((0, "Message reactions: enabled"), Nothing, Nothing),
    ((0, "Voice messages: enabled"), Nothing, Nothing),
    ((0, "Audio/video calls: enabled"), Nothing, Nothing)
  ]

e2eeInfoNoPQStr :: String
e2eeInfoNoPQStr = T.unpack e2eInfoNoPQText

e2eeInfoPQStr :: String
e2eeInfoPQStr = T.unpack e2eInfoPQText

lastChatFeature :: String
lastChatFeature = snd $ last chatFeatures

groupFeatures :: [(Int, String)]
groupFeatures = map (\(a, _, _) -> a) $ groupFeatures'' 0

sndGroupFeatures :: [(Int, String)]
sndGroupFeatures = map (\(a, _, _) -> a) $ groupFeatures'' 1

groupFeatureStrs :: [String]
groupFeatureStrs = map (\(a, _, _) -> snd a) $ groupFeatures'' 0

groupFeatures'' :: Int -> [((Int, String), Maybe (Int, String), Maybe String)]
groupFeatures'' dir =
  [ ((dir, e2eeInfoNoPQStr), Nothing, Nothing),
    ((dir, "Disappearing messages: off"), Nothing, Nothing),
    ((dir, "Direct messages: on"), Nothing, Nothing),
    ((dir, "Full deletion: off"), Nothing, Nothing),
    ((dir, "Message reactions: on"), Nothing, Nothing),
    ((dir, "Voice messages: on"), Nothing, Nothing),
    ((dir, "Files and media: on"), Nothing, Nothing),
    ((dir, "SimpleX links: on"), Nothing, Nothing),
    ((dir, "Member reports: on"), Nothing, Nothing),
    ((dir, "Recent history: on"), Nothing, Nothing)
  ]

itemId :: Int -> String
itemId i = show $ length chatFeatures + i

(@@@) :: HasCallStack => TestCC -> [(String, String)] -> Expectation
(@@@) cc res = do
  threadDelay 100000
  getChats mapChats cc res

mapChats :: [(String, String, Maybe ConnStatus)] -> [(String, String)]
mapChats = map $ \(ldn, msg, _) -> (ldn, msg)

chats :: String -> [(String, String)]
chats = mapChats . read

(@@@!) :: HasCallStack => TestCC -> [(String, String, Maybe ConnStatus)] -> Expectation
(@@@!) = getChats id

getChats :: HasCallStack => (Eq a, Show a) => ([(String, String, Maybe ConnStatus)] -> [a]) -> TestCC -> [a] -> Expectation
getChats f cc res = do
  cc ##> "/_get chats 1 pcc=on"
  line <- getTermLine cc
  f (read line) `shouldMatchList` res

send :: TestCC -> String -> IO ()
send TestCC {chatController = cc} cmd = atomically $ writeTBQueue (inputQ cc) cmd

(<##) :: HasCallStack => TestCC -> String -> Expectation
cc <## line = do
  l <- getTermLine cc
  when (l /= line) $ print ("expected: " <> line, ", got: " <> l)
  l `shouldBe` line

(<##.) :: HasCallStack => TestCC -> String -> Expectation
cc <##. line = do
  l <- getTermLine cc
  let prefix = line `isPrefixOf` l
  unless prefix $ print ("expected to start from: " <> line, ", got: " <> l)
  prefix `shouldBe` True

(.<##) :: HasCallStack => TestCC -> String -> Expectation
cc .<## line = do
  l <- getTermLine cc
  let suffix = line `isSuffixOf` l
  unless suffix $ print ("expected to end with: " <> line, ", got: " <> l)
  suffix `shouldBe` True

(<#.) :: HasCallStack => TestCC -> String -> Expectation
cc <#. line = do
  l <- dropTime <$> getTermLine cc
  let prefix = line `isPrefixOf` l
  unless prefix $ print ("expected to start from: " <> line, ", got: " <> l)
  prefix `shouldBe` True

(.<#) :: HasCallStack => TestCC -> String -> Expectation
cc .<# line = do
  l <- dropTime <$> getTermLine cc
  let suffix = line `isSuffixOf` l
  unless suffix $ print ("expected to end with: " <> line, ", got: " <> l)
  suffix `shouldBe` True

(<##..) :: HasCallStack => TestCC -> [String] -> Expectation
cc <##.. ls = do
  l <- getTermLine cc
  let prefix = any (`isPrefixOf` l) ls
  unless prefix $ print ("expected to start from one of: " <> show ls, ", got: " <> l)
  prefix `shouldBe` True

(>*) :: HasCallStack => TestCC -> String -> IO ()
cc >* note = do
  cc `send` ("/* " <> note)
  (dropTime <$> getTermLine cc) `shouldReturn` ("* " <> note)

data ConsoleResponse
  = ConsoleString String
  | WithTime String
  | EndsWith String
  | StartsWith String
  | Predicate (String -> Bool)

instance IsString ConsoleResponse where fromString = ConsoleString

-- this assumes that the string can only match one option
getInAnyOrder :: HasCallStack => (String -> String) -> TestCC -> [ConsoleResponse] -> Expectation
getInAnyOrder _ _ [] = pure ()
getInAnyOrder f cc ls = do
  line <- f <$> getTermLine cc
  let rest = filterFirst (expected line) ls
  if length rest < length ls
    then getInAnyOrder f cc rest
    else error $ "unexpected output: " <> line
  where
    expected :: String -> ConsoleResponse -> Bool
    expected l = \case
      ConsoleString s -> l == s
      WithTime s -> dropTime_ l == Just s
      EndsWith s -> s `isSuffixOf` l
      StartsWith s -> s `isPrefixOf` l
      Predicate p -> p l
    filterFirst :: (a -> Bool) -> [a] -> [a]
    filterFirst _ [] = []
    filterFirst p (x : xs)
      | p x = xs
      | otherwise = x : filterFirst p xs

(<###) :: HasCallStack => TestCC -> [ConsoleResponse] -> Expectation
(<###) = getInAnyOrder id

(<##?) :: HasCallStack => TestCC -> [ConsoleResponse] -> Expectation
(<##?) = getInAnyOrder dropTime

(<#) :: HasCallStack => TestCC -> String -> Expectation
cc <# line = (dropTime <$> getTermLine cc) `shouldReturn` line

(*<#) :: HasCallStack => [TestCC] -> String -> Expectation
ccs *<# line = mapConcurrently_ (<# line) ccs

(?<#) :: HasCallStack => TestCC -> String -> Expectation
cc ?<# line = (dropTime <$> getTermLine cc) `shouldReturn` "i " <> line

($<#) :: HasCallStack => (TestCC, String) -> String -> Expectation
(cc, uName) $<# line = (dropTime . dropUser uName <$> getTermLine cc) `shouldReturn` line

(^<#) :: HasCallStack => (TestCC, String) -> String -> Expectation
(cc, p) ^<# line = (dropTime . dropStrPrefix p <$> getTermLine cc) `shouldReturn` line

(⩗) :: HasCallStack => TestCC -> String -> Expectation
cc ⩗ line = (dropTime . dropReceipt <$> getTermLine cc) `shouldReturn` line

(%) :: HasCallStack => TestCC -> String -> Expectation
cc % line = (dropTime . dropPartialReceipt <$> getTermLine cc) `shouldReturn` line

(</) :: HasCallStack => TestCC -> Expectation
(</) = (<// 500000)

(<#?) :: HasCallStack => TestCC -> TestCC -> Expectation
cc1 <#? cc2 = do
  name <- userName cc2
  sName <- showName cc2
  cc2 <## "connection request sent!"
  cc1 <## (sName <> " wants to connect to you!")
  cc1 <## ("to accept: /ac " <> name)
  cc1 <## ("to reject: /rc " <> name <> " (the sender will NOT be notified)")

dropUser :: HasCallStack => String -> String -> String
dropUser uName msg = fromMaybe err $ dropUser_ uName msg
  where
    err = error $ "invalid user: " <> msg

dropUser_ :: String -> String -> Maybe String
dropUser_ uName msg = do
  let userPrefix = "[user: " <> uName <> "] "
  if userPrefix `isPrefixOf` msg
    then Just $ drop (length userPrefix) msg
    else Nothing

dropTime :: HasCallStack => String -> String
dropTime msg = fromMaybe err $ dropTime_ msg
  where
    err = error $ "invalid time: " <> msg

dropTime_ :: String -> Maybe String
dropTime_ msg = case splitAt 6 msg of
  ([m, m', ':', s, s', ' '], text) ->
    if all isDigit [m, m', s, s'] then Just text else Nothing
  _ -> Nothing

dropStrPrefix :: HasCallStack => String -> String -> String
dropStrPrefix pfx s =
  let (p, rest) = splitAt (length pfx) s
   in if p == pfx then rest else error $ "no prefix " <> pfx <> " in string : " <> s

dropReceipt :: HasCallStack => String -> String
dropReceipt msg = fromMaybe err $ dropReceipt_ msg
  where
    err = error $ "invalid receipt: " <> msg

dropReceipt_ :: String -> Maybe String
dropReceipt_ msg = case splitAt 2 msg of
  ("⩗ ", text) -> Just text
  _ -> Nothing

dropPartialReceipt :: HasCallStack => String -> String
dropPartialReceipt msg = fromMaybe err $ dropPartialReceipt_ msg
  where
    err = error $ "invalid partial receipt: " <> msg

dropPartialReceipt_ :: String -> Maybe String
dropPartialReceipt_ msg = case splitAt 2 msg of
  ("% ", text) -> Just text
  _ -> Nothing

getInvitation :: HasCallStack => TestCC -> IO String
getInvitation = getInvitation_ False

getShortInvitation :: HasCallStack => TestCC -> IO String
getShortInvitation = getInvitation_ True

getInvitation_ :: HasCallStack => Bool -> TestCC -> IO String
getInvitation_ short cc = do
  cc <## "pass this invitation link to your contact (via another channel):"
  cc <## ""
  inv <- getTermLine cc
  cc <## ""
  cc <## "and ask them to connect: /c <invitation_link_above>"
  when short $ cc <##. "The invitation link for old clients: https://simplex.chat/invitation#"
  pure inv

getShortContactLink :: HasCallStack => TestCC -> Bool -> IO (String, String)
getShortContactLink cc created = do
  shortLink <- getContactLink cc created
  fullLink <- dropLinePrefix "The contact link for old clients: " =<< getTermLine cc
  pure (shortLink, fullLink)

getContactLink :: HasCallStack => TestCC -> Bool -> IO String
getContactLink cc created = do
  cc <## if created then "Your new chat address is created!" else "Your chat address:"
  cc <## ""
  link <- getTermLine cc
  cc <## ""
  cc <## "Anybody can send you contact requests with: /c <contact_link_above>"
  cc <## "to show it again: /sa"
  cc <## "to share with your contacts: /profile_address on"
  cc <## "to delete it: /da (accepted contacts will remain connected)"
  pure link

dropLinePrefix :: String -> String -> IO String
dropLinePrefix line s
  | line `isPrefixOf` s = pure $ drop (length line) s
  | otherwise = error $ "expected to start from: " <> line <> ", got: " <> s

getShortGroupLink :: HasCallStack => TestCC -> String -> GroupMemberRole -> Bool -> IO (String, String)
getShortGroupLink cc gName mRole created = do
  shortLink <- getGroupLink cc gName mRole created
  fullLink <- dropLinePrefix "The group link for old clients: " =<< getTermLine cc
  pure (shortLink, fullLink)

getGroupLink :: HasCallStack => TestCC -> String -> GroupMemberRole -> Bool -> IO String
getGroupLink cc gName mRole created = do
  cc <## if created then "Group link is created!" else "Group link:"
  cc <## ""
  link <- getTermLine cc
  cc <## ""
  cc <## ("Anybody can connect to you and join group as " <> B.unpack (strEncode mRole) <> " with: /c <group_link_above>")
  cc <## ("to show it again: /show link #" <> gName)
  cc <## ("to delete it: /delete link #" <> gName <> " (joined members will remain connected to you)")
  pure link

hasContactProfiles :: HasCallStack => TestCC -> [ContactName] -> Expectation
hasContactProfiles cc names =
  getContactProfiles cc >>= \ps -> ps `shouldMatchList` names

getContactProfiles :: TestCC -> IO [ContactName]
getContactProfiles cc = do
  user_ <- readTVarIO (currentUser $ chatController cc)
  case user_ of
    Nothing -> pure []
    Just user -> do
      profiles <- withTransaction (chatStore $ chatController cc) $ \db -> getUserContactProfiles db user
      pure $ map (\Profile {displayName} -> displayName) profiles

withCCUser :: TestCC -> (User -> IO a) -> IO a
withCCUser cc action = do
  user_ <- readTVarIO (currentUser $ chatController cc)
  case user_ of
    Nothing -> error "no user"
    Just user -> action user

withCCTransaction :: TestCC -> (DB.Connection -> IO a) -> IO a
withCCTransaction cc action =
  withTransaction (chatStore $ chatController cc) $ \db -> action db

withCCAgentTransaction :: TestCC -> (DB.Connection -> IO a) -> IO a
withCCAgentTransaction TestCC {chatController = ChatController {smpAgent}} action =
  withTransaction (agentClientStore smpAgent) $ \db -> action db

createCCNoteFolder :: TestCC -> IO ()
createCCNoteFolder cc =
  withCCTransaction cc $ \db ->
    withCCUser cc $ \user ->
      runExceptT (createNoteFolder db user) >>= either (fail . show) pure

getProfilePictureByName :: TestCC -> String -> IO (Maybe String)
getProfilePictureByName cc displayName =
  withTransaction (chatStore $ chatController cc) $ \db ->
    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 PQEncOff

pqRcvForContact :: TestCC -> ContactId -> IO PQEncryption
pqRcvForContact = pqForContact_ pqRcvEnabled PQEncOff

pqForContact :: TestCC -> ContactId -> IO PQEncryption
pqForContact = pqForContact_ (Just . connPQEnabled) (error "impossible")

pqSupportForCt :: TestCC -> ContactId -> IO PQSupport
pqSupportForCt = pqForContact_ (\Connection {pqSupport} -> Just pqSupport) PQSupportOff

pqVerForContact :: TestCC -> ContactId -> IO VersionChat
pqVerForContact = pqForContact_ (Just . connChatVersion) (error "impossible")

pqForContact_ :: (Connection -> Maybe a) -> a -> TestCC -> ContactId -> IO a
pqForContact_ pqSel def cc contactId = (fromMaybe def . pqSel) <$> getCtConn cc contactId

getCtConn :: TestCC -> ContactId -> IO Connection
getCtConn cc contactId = getTestCCContact cc contactId >>= maybe (fail "no connection") pure . contactConn

getTestCCContact :: TestCC -> ContactId -> IO Contact
getTestCCContact cc contactId = do
  let TestCC {chatController = ChatController {config = ChatConfig {chatVRange = vr}}} = cc
  withCCTransaction cc $ \db ->
    withCCUser cc $ \user ->
      runExceptT (getContact db vr user contactId) >>= either (fail . show) pure

lastItemId :: HasCallStack => TestCC -> IO String
lastItemId cc = do
  cc ##> "/last_item_id"
  getTermLine cc

showActiveUser :: HasCallStack => TestCC -> String -> Expectation
showActiveUser cc name = do
  cc <## ("user profile: " <> name)
  cc <## "use /p <display name> to change it"
  cc <## "(the updated profile will be sent to all your contacts)"

connectUsers :: HasCallStack => TestCC -> TestCC -> IO ()
connectUsers cc1 cc2 = do
  name1 <- showName cc1
  name2 <- showName cc2
  cc1 ##> "/c"
  inv <- getInvitation cc1
  cc2 ##> ("/c " <> inv)
  cc2 <## "confirmation sent!"
  concurrently_
    (cc2 <## (name1 <> ": contact is connected"))
    (cc1 <## (name2 <> ": contact is connected"))

showName :: TestCC -> IO String
showName (TestCC ChatController {currentUser} _ _ _ _ _) = do
  Just User {localDisplayName, profile = LocalProfile {fullName}} <- readTVarIO currentUser
  pure . T.unpack $ localDisplayName <> optionalFullName localDisplayName fullName

createGroup2 :: HasCallStack => String -> TestCC -> TestCC -> IO ()
createGroup2 gName cc1 cc2 = createGroup2' gName cc1 cc2 True

createGroup2' :: HasCallStack => String -> TestCC -> TestCC -> Bool -> IO ()
createGroup2' gName cc1 cc2 doConnectUsers = do
  when doConnectUsers $ connectUsers cc1 cc2
  name2 <- userName cc2
  cc1 ##> ("/g " <> gName)
  cc1 <## ("group #" <> gName <> " is created")
  cc1 <## ("to add members use /a " <> gName <> " <name> or /create link #" <> gName)
  addMember gName cc1 cc2 GRAdmin
  cc2 ##> ("/j " <> gName)
  concurrently_
    (cc1 <## ("#" <> gName <> ": " <> name2 <> " joined the group"))
    (cc2 <## ("#" <> gName <> ": you joined the group"))

disableFullDeletion2 :: HasCallStack => String -> TestCC -> TestCC -> IO ()
disableFullDeletion2 gName cc1 cc2 = do
  cc1 ##> ("/set delete #" <> gName <> " off")
  cc1 <## "updated group preferences:"
  cc1 <## "Full deletion: off"
  name1 <- userName cc1
  cc2 <## (name1 <> " updated group #" <> gName <> ":")
  cc2 <## "updated group preferences:"
  cc2 <## "Full deletion: off"

createGroup3 :: HasCallStack => String -> TestCC -> TestCC -> TestCC -> IO ()
createGroup3 gName cc1 cc2 cc3 = do
  createGroup2 gName cc1 cc2
  connectUsers cc1 cc3
  name1 <- userName cc1
  name3 <- userName cc3
  sName2 <- showName cc2
  sName3 <- showName cc3
  addMember gName cc1 cc3 GRAdmin
  cc3 ##> ("/j " <> gName)
  concurrentlyN_
    [ cc1 <## ("#" <> gName <> ": " <> name3 <> " joined the group"),
      do
        cc3 <## ("#" <> gName <> ": you joined the group")
        cc3 <## ("#" <> gName <> ": member " <> sName2 <> " is connected"),
      do
        cc2 <## ("#" <> gName <> ": " <> name1 <> " added " <> sName3 <> " to the group (connecting...)")
        cc2 <## ("#" <> gName <> ": new member " <> name3 <> " is connected")
    ]

disableFullDeletion3 :: HasCallStack => String -> TestCC -> TestCC -> TestCC -> IO ()
disableFullDeletion3 gName cc1 cc2 cc3 = do
  disableFullDeletion2 gName cc1 cc2
  name1 <- userName cc1
  cc3 <## (name1 <> " updated group #" <> gName <> ":")
  cc3 <## "updated group preferences:"
  cc3 <## "Full deletion: off"

create2Groups3 :: HasCallStack => String -> String -> TestCC -> TestCC -> TestCC -> IO ()
create2Groups3 gName1 gName2 cc1 cc2 cc3 = do
  createGroup3 gName1 cc1 cc2 cc3
  createGroup2' gName2 cc1 cc2 False
  name1 <- userName cc1
  name3 <- userName cc3
  addMember gName2 cc1 cc3 GRAdmin
  cc3 ##> ("/j " <> gName2)
  concurrentlyN_
    [ cc1 <## ("#" <> gName2 <> ": " <> name3 <> " joined the group"),
      do
        cc3 <## ("#" <> gName2 <> ": you joined the group")
        cc3 <##. ("#" <> gName2 <> ": member "), -- "#gName2: member sName2 is connected"
      do
        cc2 <##. ("#" <> gName2 <> ": " <> name1 <> " added ") -- "#gName2: name1 added sName3 to the group (connecting...)"
        cc2 <##. ("#" <> gName2 <> ": new member ") -- "#gName2: new member name3 is connected"
    ]

addMember :: HasCallStack => String -> TestCC -> TestCC -> GroupMemberRole -> IO ()
addMember gName = fullAddMember gName ""

fullAddMember :: HasCallStack => String -> String -> TestCC -> TestCC -> GroupMemberRole -> IO ()
fullAddMember gName fullName inviting invitee role = do
  name1 <- userName inviting
  memName <- userName invitee
  inviting ##> ("/a " <> gName <> " " <> memName <> " " <> B.unpack (strEncode role))
  let fullName' = if null fullName || fullName == gName then "" else " (" <> fullName <> ")"
  concurrentlyN_
    [ inviting <## ("invitation to join the group #" <> gName <> " sent to " <> memName),
      do
        invitee <## ("#" <> gName <> fullName' <> ": " <> name1 <> " invites you to join the group as " <> B.unpack (strEncode role))
        invitee <## ("use /j " <> gName <> " to accept")
    ]

checkActionDeletesFile :: HasCallStack => FilePath -> IO () -> IO ()
checkActionDeletesFile file action = do
  fileExistsBefore <- doesFileExist file
  fileExistsBefore `shouldBe` True
  action
  fileExistsAfter <- doesFileExist file
  fileExistsAfter `shouldBe` False

currentChatVRangeInfo :: String
currentChatVRangeInfo =
  "peer chat protocol version range: " <> vRangeStr supportedChatVRange

vRangeStr :: VersionRange v -> String
vRangeStr (VersionRange minVer maxVer) = "(" <> show minVer <> ", " <> show maxVer <> ")"

linkAnotherSchema :: String -> String
linkAnotherSchema link
  | "https://simplex.chat/" `isPrefixOf` link =
      T.unpack $ T.replace "https://simplex.chat/" "simplex:/" $ T.pack link
  | "simplex:/" `isPrefixOf` link =
      T.unpack $ T.replace "simplex:/" "https://simplex.chat/" $ T.pack link
  | otherwise = error "link starts with neither https://simplex.chat/ nor simplex:/"

xftpCLI :: [String] -> IO [String]
xftpCLI params = lines <$> capture_ (withArgs params xftpClientCLI)

setRelativePaths :: HasCallStack => TestCC -> String -> String -> IO ()
setRelativePaths cc filesFolder tempFolder = do
  cc ##> "/_stop"
  cc <## "chat stopped"
  cc #$> ("/_files_folder " <> filesFolder, id, "ok")
  cc #$> ("/_temp_folder " <> tempFolder, id, "ok")
  cc ##> "/_start"
  cc <## "chat started"