lovely-projects/simplex-chat
lovely-projects/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-03-14 09:45:42 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

core: use fourmolu styles (#3470)

Browse source
This commit is contained in:
Evgeny Poberezkin 2023-11-26 18:16:37 +00:00 • committed by GitHub
parent 75c2de8a12
commit d29f1bb0cf
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
43 changed files with 902 additions and 865 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
fourmolu.yaml Normal file
View file

@ -0,0 +1,30 @@
indentation: 2
column-limit: none
function-arrows: trailing
comma-style: trailing
import-export-style: trailing
indent-wheres: true
record-brace-space: true
newlines-between-decls: 1
haddock-style: single-line
haddock-style-module: null
let-style: inline
in-style: right-align
single-constraint-parens: never
unicode: never
respectful: true
fixities:
- infixr 9 .
- infixr 8 .:, .:., .=
- infixr 6 <>
- infixr 5 ++
- infixl 4 <$>, <$, $>, <$$>, <$?>
- infixl 4 <*>, <*, *>, <**>
- infix 4 ==, /=
- infixr 3 &&
- infixl 3 <|>
- infixr 2 ||
- infixl 1 >>, >>=
- infixr 1 =<<, >=>, <=<
- infixr 0 $, $!
reexports: []

596
src/Simplex/Chat.hs
View file

File diff suppressed because one or more lines are too long

2
src/Simplex/Chat/Archive.hs
View file

@ -22,7 +22,7 @@ import qualified Data.Text as T
import qualified Database.SQLite3 as SQL import qualified Database.SQLite3 as SQL
import Simplex.Chat.Controller import Simplex.Chat.Controller
import Simplex.Messaging.Agent.Client (agentClientStore) import Simplex.Messaging.Agent.Client (agentClientStore)
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), sqlString, closeSQLiteStore) import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), closeSQLiteStore, sqlString)
import Simplex.Messaging.Util import Simplex.Messaging.Util
import System.FilePath import System.FilePath
import UnliftIO.Directory import UnliftIO.Directory

2
src/Simplex/Chat/Bot/KnownContacts.hs
View file

@ -6,8 +6,8 @@ module Simplex.Chat.Bot.KnownContacts where
import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Int (Int64) import Data.Int (Int64)
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Options.Applicative import Options.Applicative
import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Util (safeDecodeUtf8) import Simplex.Messaging.Util (safeDecodeUtf8)

1
src/Simplex/Chat/Call.hs
View file

@ -225,4 +225,3 @@ instance FromField CallState where
fromField = fromTextField_ decodeJSON fromField = fromTextField_ decodeJSON
$(J.deriveJSON defaultJSON ''RcvCallInvitation) $(J.deriveJSON defaultJSON ''RcvCallInvitation)

49
src/Simplex/Chat/Controller.hs
View file

@ -1,5 +1,5 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
@ -426,19 +426,19 @@ data ChatCommand
| SetGroupTimedMessages GroupName (Maybe Int) | SetGroupTimedMessages GroupName (Maybe Int)
| SetLocalDeviceName Text | SetLocalDeviceName Text
| ListRemoteHosts | ListRemoteHosts
| StartRemoteHost (Maybe (RemoteHostId, Bool)) -- ^ Start new or known remote host with optional multicast for known host | StartRemoteHost (Maybe (RemoteHostId, Bool)) -- Start new or known remote host with optional multicast for known host
| SwitchRemoteHost (Maybe RemoteHostId) -- ^ Switch current remote host | SwitchRemoteHost (Maybe RemoteHostId) -- Switch current remote host
| StopRemoteHost RHKey -- ^ Shut down a running session | StopRemoteHost RHKey -- Shut down a running session
| DeleteRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data | DeleteRemoteHost RemoteHostId -- Unregister remote host and remove its data
| StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath} | StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath}
| GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile} | GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile}
| ConnectRemoteCtrl RCSignedInvitation -- ^ Connect new or existing controller via OOB data | ConnectRemoteCtrl RCSignedInvitation -- Connect new or existing controller via OOB data
| FindKnownRemoteCtrl -- ^ Start listening for announcements from all existing controllers | FindKnownRemoteCtrl -- Start listening for announcements from all existing controllers
| ConfirmRemoteCtrl RemoteCtrlId -- ^ Confirm the connection with found controller | ConfirmRemoteCtrl RemoteCtrlId -- Confirm the connection with found controller
| VerifyRemoteCtrlSession Text -- ^ Verify remote controller session | VerifyRemoteCtrlSession Text -- Verify remote controller session
| ListRemoteCtrls | ListRemoteCtrls
| StopRemoteCtrl -- ^ Stop listening for announcements or terminate an active session | StopRemoteCtrl -- Stop listening for announcements or terminate an active session
| DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a remote controller session | DeleteRemoteCtrl RemoteCtrlId -- Remove all local data associated with a remote controller session
| QuitChat | QuitChat
| ShowVersion | ShowVersion
| DebugLocks | DebugLocks
@ -1072,13 +1072,13 @@ throwDBError = throwError . ChatErrorDatabase
-- TODO review errors, some of it can be covered by HTTP2 errors -- TODO review errors, some of it can be covered by HTTP2 errors
data RemoteHostError data RemoteHostError
= RHEMissing -- ^ No remote session matches this identifier = RHEMissing -- No remote session matches this identifier
| RHEInactive -- ^ A session exists, but not active | RHEInactive -- A session exists, but not active
| RHEBusy -- ^ A session is already running | RHEBusy -- A session is already running
| RHETimeout | RHETimeout
| RHEBadState -- ^ Illegal state transition | RHEBadState -- Illegal state transition
| RHEBadVersion {appVersion :: AppVersion} | RHEBadVersion {appVersion :: AppVersion}
| RHELocalCommand -- ^ Command not allowed for remote execution | RHELocalCommand -- Command not allowed for remote execution
| RHEDisconnected {reason :: Text} -- TODO should be sent when disconnected? | RHEDisconnected {reason :: Text} -- TODO should be sent when disconnected?
| RHEProtocolError RemoteProtocolError | RHEProtocolError RemoteProtocolError
deriving (Show, Exception) deriving (Show, Exception)
@ -1091,13 +1091,14 @@ data RemoteHostStopReason
-- TODO review errors, some of it can be covered by HTTP2 errors -- TODO review errors, some of it can be covered by HTTP2 errors
data RemoteCtrlError data RemoteCtrlError
= RCEInactive -- ^ No session is running = RCEInactive -- No session is running
| RCEBadState -- ^ A session is in a wrong state for the current operation | RCEBadState -- A session is in a wrong state for the current operation
| RCEBusy -- ^ A session is already running | RCEBusy -- A session is already running
| RCETimeout | RCETimeout
| RCENoKnownControllers -- ^ No previously-contacted controllers to discover | RCENoKnownControllers -- No previously-contacted controllers to discover
| RCEBadController -- ^ Attempting to confirm a found controller with another ID | RCEBadController -- Attempting to confirm a found controller with another ID
| RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text} -- ^ A session disconnected by a controller | -- | A session disconnected by a controller
RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text}
| RCEBadInvitation | RCEBadInvitation
| RCEBadVersion {appVersion :: AppVersion} | RCEBadVersion {appVersion :: AppVersion}
| RCEHTTP2Error {http2Error :: Text} -- TODO currently not used | RCEHTTP2Error {http2Error :: Text} -- TODO currently not used
@ -1223,8 +1224,8 @@ toView event = do
session <- asks remoteCtrlSession session <- asks remoteCtrlSession
atomically $ atomically $
readTVar session >>= \case readTVar session >>= \case
Just (_, RCSessionConnected {remoteOutputQ}) | allowRemoteEvent event -> Just (_, RCSessionConnected {remoteOutputQ})
writeTBQueue remoteOutputQ event | allowRemoteEvent event -> writeTBQueue remoteOutputQ event
-- TODO potentially, it should hold some events while connecting -- TODO potentially, it should hold some events while connecting
_ -> writeTBQueue localQ (Nothing, Nothing, event) _ -> writeTBQueue localQ (Nothing, Nothing, event)

6
src/Simplex/Chat/Core.hs
View file

@ -35,9 +35,9 @@ runSimplexChat :: ChatOpts -> User -> ChatController -> (User -> ChatController
runSimplexChat ChatOpts {maintenance} u cc chat runSimplexChat ChatOpts {maintenance} u cc chat
| maintenance = wait =<< async (chat u cc) | maintenance = wait =<< async (chat u cc)
| otherwise = do | otherwise = do
a1 <- runReaderT (startChatController True True True) cc a1 <- runReaderT (startChatController True True True) cc
a2 <- async $ chat u cc a2 <- async $ chat u cc
waitEither_ a1 a2 waitEither_ a1 a2
sendChatCmdStr :: ChatController -> String -> IO ChatResponse sendChatCmdStr :: ChatController -> String -> IO ChatResponse
sendChatCmdStr cc s = runReaderT (execChatCommand Nothing . encodeUtf8 $ T.pack s) cc sendChatCmdStr cc s = runReaderT (execChatCommand Nothing . encodeUtf8 $ T.pack s) cc

4
src/Simplex/Chat/Files.hs
View file

@ -6,8 +6,8 @@ module Simplex.Chat.Files where
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Simplex.Chat.Controller import Simplex.Chat.Controller
import Simplex.Messaging.Util (ifM) import Simplex.Messaging.Util (ifM)
import System.FilePath (splitExtensions, combine) import System.FilePath (combine, splitExtensions)
import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, getHomeDirectory, doesDirectoryExist) import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getHomeDirectory, getTemporaryDirectory)
uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath
uniqueCombine fPath fName = tryCombine (0 :: Int) uniqueCombine fPath fName = tryCombine (0 :: Int)

34
src/Simplex/Chat/Markdown.hs
View file

@ -19,7 +19,7 @@ import qualified Data.Attoparsec.Text as A
import Data.Char (isDigit, isPunctuation) import Data.Char (isDigit, isPunctuation)
import Data.Either (fromRight) import Data.Either (fromRight)
import Data.Functor (($>)) import Data.Functor (($>))
import Data.List (intercalate, foldl') import Data.List (foldl', intercalate)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe, isNothing) import Data.Maybe (fromMaybe, isNothing)
@ -85,16 +85,18 @@ newtype FormatColor = FormatColor Color
deriving (Eq, Show) deriving (Eq, Show)
instance FromJSON FormatColor where instance FromJSON FormatColor where
parseJSON = J.withText "FormatColor" $ fmap FormatColor . \case parseJSON =
"red" -> pure Red J.withText "FormatColor" $
"green" -> pure Green fmap FormatColor . \case
"blue" -> pure Blue "red" -> pure Red
"yellow" -> pure Yellow "green" -> pure Green
"cyan" -> pure Cyan "blue" -> pure Blue
"magenta" -> pure Magenta "yellow" -> pure Yellow
"black" -> pure Black "cyan" -> pure Cyan
"white" -> pure White "magenta" -> pure Magenta
unexpected -> fail $ "unexpected FormatColor: " <> show unexpected "black" -> pure Black
"white" -> pure White
unexpected -> fail $ "unexpected FormatColor: " <> show unexpected
instance ToJSON FormatColor where instance ToJSON FormatColor where
toJSON (FormatColor c) = case c of toJSON (FormatColor c) = case c of
@ -167,14 +169,14 @@ markdownP = mconcat <$> A.many' fragmentP
md :: Char -> Format -> Text -> Markdown md :: Char -> Format -> Text -> Markdown
md c f s md c f s
| T.null s || T.head s == ' ' || T.last s == ' ' = | T.null s || T.head s == ' ' || T.last s == ' ' =
unmarked $ c `T.cons` s `T.snoc` c unmarked $ c `T.cons` s `T.snoc` c
| otherwise = markdown f s | otherwise = markdown f s
secretP :: Parser Markdown secretP :: Parser Markdown
secretP = secret <$> A.takeWhile (== '#') <*> A.takeTill (== '#') <*> A.takeWhile (== '#') secretP = secret <$> A.takeWhile (== '#') <*> A.takeTill (== '#') <*> A.takeWhile (== '#')
secret :: Text -> Text -> Text -> Markdown secret :: Text -> Text -> Text -> Markdown
secret b s a secret b s a
| T.null a || T.null s || T.head s == ' ' || T.last s == ' ' = | T.null a || T.null s || T.head s == ' ' || T.last s == ' ' =
unmarked $ '#' `T.cons` ss unmarked $ '#' `T.cons` ss
| otherwise = markdown Secret $ T.init ss | otherwise = markdown Secret $ T.init ss
where where
ss = b <> s <> a ss = b <> s <> a
@ -215,9 +217,9 @@ markdownP = mconcat <$> A.many' fragmentP
wordMD s wordMD s
| T.null s = unmarked s | T.null s = unmarked s
| isUri s = | isUri s =
let t = T.takeWhileEnd isPunctuation s let t = T.takeWhileEnd isPunctuation s
uri = uriMarkdown $ T.dropWhileEnd isPunctuation s uri = uriMarkdown $ T.dropWhileEnd isPunctuation s
in if T.null t then uri else uri :|: unmarked t in if T.null t then uri else uri :|: unmarked t
| isEmail s = markdown Email s | isEmail s = markdown Email s
| otherwise = unmarked s | otherwise = unmarked s
uriMarkdown s = case strDecode $ encodeUtf8 s of uriMarkdown s = case strDecode $ encodeUtf8 s of

5
src/Simplex/Chat/Messages.hs
View file

@ -11,7 +11,6 @@
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Messages where module Simplex.Chat.Messages where
@ -44,7 +43,7 @@ import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptSta
import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Crypto.File (CryptoFile (..))
import qualified Simplex.Messaging.Crypto.File as CF import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, parseAll, enumJSON, sumTypeJSON) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, parseAll, sumTypeJSON)
import Simplex.Messaging.Protocol (MsgBody) import Simplex.Messaging.Protocol (MsgBody)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>)) import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
@ -345,7 +344,7 @@ contactTimedTTL Contact {mergedPreferences = ContactUserPreferences {timedMessag
| forUser enabled && forContact enabled = Just ttl | forUser enabled && forContact enabled = Just ttl
| otherwise = Nothing | otherwise = Nothing
where where
TimedMessagesPreference {ttl} = userPreference.preference TimedMessagesPreference {ttl} = userPreference.preference
groupTimedTTL :: GroupInfo -> Maybe (Maybe Int) groupTimedTTL :: GroupInfo -> Maybe (Maybe Int)
groupTimedTTL GroupInfo {fullGroupPreferences = FullGroupPreferences {timedMessages = TimedMessagesGroupPreference {enable, ttl}}} groupTimedTTL GroupInfo {fullGroupPreferences = FullGroupPreferences {timedMessages = TimedMessagesGroupPreference {enable, ttl}}}

2
src/Simplex/Chat/Messages/CIContent.hs
View file

@ -311,7 +311,7 @@ profileToText Profile {displayName, fullName} = displayName <> optionalFullName
msgIntegrityError :: MsgErrorType -> Text msgIntegrityError :: MsgErrorType -> Text
msgIntegrityError = \case msgIntegrityError = \case
MsgSkipped fromId toId -> MsgSkipped fromId toId ->
"skipped message ID " <> tshow fromId ("skipped message ID " <> tshow fromId)
<> if fromId == toId then "" else ".." <> tshow toId <> if fromId == toId then "" else ".." <> tshow toId
MsgBadId msgId -> "unexpected message ID " <> tshow msgId MsgBadId msgId -> "unexpected message ID " <> tshow msgId
MsgBadHash -> "incorrect message hash" MsgBadHash -> "incorrect message hash"

6
src/Simplex/Chat/Messages/CIContent/Events.hs
View file

@ -46,9 +46,9 @@ data SndConnEvent
| SCERatchetSync {syncStatus :: RatchetSyncState, member :: Maybe GroupMemberRef} | SCERatchetSync {syncStatus :: RatchetSyncState, member :: Maybe GroupMemberRef}
deriving (Show) deriving (Show)
data RcvDirectEvent = data RcvDirectEvent
-- RDEProfileChanged {...} = -- RDEProfileChanged {...}
RDEContactDeleted RDEContactDeleted
deriving (Show) deriving (Show)
-- platform-specific JSON encoding (used in API) -- platform-specific JSON encoding (used in API)

9
src/Simplex/Chat/Mobile.hs
View file

@ -4,13 +4,12 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fobject-code #-} {-# OPTIONS_GHC -fobject-code #-}
module Simplex.Chat.Mobile where module Simplex.Chat.Mobile where
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Exception (catch, SomeException) import Control.Exception (SomeException, catch)
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.Reader import Control.Monad.Reader
import qualified Data.Aeson as J import qualified Data.Aeson as J
@ -31,7 +30,7 @@ import Foreign.C.Types (CInt (..))
import Foreign.Ptr import Foreign.Ptr
import Foreign.StablePtr import Foreign.StablePtr
import Foreign.Storable (poke) import Foreign.Storable (poke)
import GHC.IO.Encoding (setLocaleEncoding, setFileSystemEncoding, setForeignEncoding) import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEncoding)
import Simplex.Chat import Simplex.Chat
import Simplex.Chat.Controller import Simplex.Chat.Controller
import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList) import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
@ -219,7 +218,7 @@ chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do
ExceptT $ ExceptT $
(first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey confirmMigrations) (first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey confirmMigrations)
`catch` (pure . checkDBError) `catch` (pure . checkDBError)
`catchAll` (pure . dbError) `catchAll` (pure . dbError)
where where
checkDBError e = case sqlError e of checkDBError e = case sqlError e of
DB.ErrorNotADatabase -> Left $ DBMErrorNotADatabase dbFile DB.ErrorNotADatabase -> Left $ DBMErrorNotADatabase dbFile
@ -233,7 +232,7 @@ chatCloseStore ChatController {chatStore, smpAgent} = handleErr $ do
handleErr :: IO () -> IO String handleErr :: IO () -> IO String
handleErr a = (a $> "") `catch` (pure . show @SomeException) handleErr a = (a $> "") `catch` (pure . show @SomeException)
chatSendCmd :: ChatController -> B.ByteString -> IO JSONByteString chatSendCmd :: ChatController -> B.ByteString -> IO JSONByteString
chatSendCmd cc = chatSendRemoteCmd cc Nothing chatSendCmd cc = chatSendRemoteCmd cc Nothing

2
src/Simplex/Chat/Mobile/Shared.hs
View file

@ -6,8 +6,8 @@ import qualified Data.ByteString as B
import Data.ByteString.Internal (ByteString (..), memcpy) import Data.ByteString.Internal (ByteString (..), memcpy)
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Internal as LB import qualified Data.ByteString.Lazy.Internal as LB
import Foreign.C (CInt, CString)
import Foreign import Foreign
import Foreign.C (CInt, CString)
type CJSONString = CString type CJSONString = CString

16
src/Simplex/Chat/Mobile/WebRTC.hs
View file

@ -1,12 +1,12 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
module Simplex.Chat.Mobile.WebRTC ( module Simplex.Chat.Mobile.WebRTC
cChatEncryptMedia, ( cChatEncryptMedia,
cChatDecryptMedia, cChatDecryptMedia,
chatEncryptMedia, chatEncryptMedia,
chatDecryptMedia, chatDecryptMedia,
reservedSize, reservedSize,
) where ) where
import Control.Monad import Control.Monad
import Control.Monad.Except import Control.Monad.Except
@ -21,8 +21,8 @@ import Data.Either (fromLeft)
import Data.Word (Word8) import Data.Word (Word8)
import Foreign.C (CInt, CString, newCAString) import Foreign.C (CInt, CString, newCAString)
import Foreign.Ptr (Ptr) import Foreign.Ptr (Ptr)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Chat.Mobile.Shared import Simplex.Chat.Mobile.Shared
import qualified Simplex.Messaging.Crypto as C
cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
cChatEncryptMedia = cTransformMedia chatEncryptMedia cChatEncryptMedia = cTransformMedia chatEncryptMedia

8
src/Simplex/Chat/ProfileGenerator.hs
View file

@ -18,10 +18,10 @@ generateRandomProfile = do
pickNoun adjective n pickNoun adjective n
| n == 0 = pick nouns | n == 0 = pick nouns
| otherwise = do | otherwise = do
noun <- pick nouns noun <- pick nouns
if noun == adjective if noun == adjective
then pickNoun adjective (n - 1) then pickNoun adjective (n - 1)
else pure noun else pure noun
adjectives :: [Text] adjectives :: [Text]
adjectives = adjectives =

1
src/Simplex/Chat/Protocol.hs
View file

@ -13,7 +13,6 @@
{-# LANGUAGE StrictData #-} {-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Protocol where module Simplex.Chat.Protocol where

78
src/Simplex/Chat/Remote.hs
View file

@ -97,24 +97,26 @@ discoveryTimeout = 60000000
getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient
getRemoteHostClient rhId = do getRemoteHostClient rhId = do
sessions <- asks remoteHostSessions sessions <- asks remoteHostSessions
liftIOEither . atomically $ TM.lookup rhKey sessions >>= \case liftIOEither . atomically $
Just (_, RHSessionConnected {rhClient}) -> pure $ Right rhClient TM.lookup rhKey sessions >>= \case
Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState Just (_, RHSessionConnected {rhClient}) -> pure $ Right rhClient
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
where where
rhKey = RHId rhId rhKey = RHId rhId
withRemoteHostSession :: ChatMonad m => RHKey -> SessionSeq -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> m a withRemoteHostSession :: ChatMonad m => RHKey -> SessionSeq -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> m a
withRemoteHostSession rhKey sseq f = do withRemoteHostSession rhKey sseq f = do
sessions <- asks remoteHostSessions sessions <- asks remoteHostSessions
r <- atomically $ r <-
TM.lookup rhKey sessions >>= \case atomically $
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing TM.lookup rhKey sessions >>= \case
Just (stateSeq, state) Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
| stateSeq /= sseq -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState Just (stateSeq, state)
| otherwise -> case f state of | stateSeq /= sseq -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState
Right (r, newState) -> Right r <$ TM.insert rhKey (sseq, newState) sessions | otherwise -> case f state of
Left ce -> pure $ Left ce Right (r, newState) -> Right r <$ TM.insert rhKey (sseq, newState) sessions
Left ce -> pure $ Left ce
liftEither r liftEither r
-- | Transition session state with a 'RHNew' ID to an assigned 'RemoteHostId' -- | Transition session state with a 'RHNew' ID to an assigned 'RemoteHostId'
@ -167,14 +169,16 @@ startRemoteHost rh_ = do
when (encoding == PEKotlin && localEncoding == PESwift) $ throwError $ RHEProtocolError RPEIncompatibleEncoding when (encoding == PEKotlin && localEncoding == PESwift) $ throwError $ RHEProtocolError RPEIncompatibleEncoding
pure hostInfo pure hostInfo
handleConnectError :: ChatMonad m => RHKey -> SessionSeq -> m a -> m a handleConnectError :: ChatMonad m => RHKey -> SessionSeq -> m a -> m a
handleConnectError rhKey sessSeq action = action `catchChatError` \err -> do handleConnectError rhKey sessSeq action =
logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err action `catchChatError` \err -> do
cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err
throwError err cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey
throwError err
handleHostError :: ChatMonad m => SessionSeq -> TVar RHKey -> m () -> m () handleHostError :: ChatMonad m => SessionSeq -> TVar RHKey -> m () -> m ()
handleHostError sessSeq rhKeyVar action = action `catchChatError` \err -> do handleHostError sessSeq rhKeyVar action =
logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err action `catchChatError` \err -> do
readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err)) logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err
readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err))
waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> SessionSeq -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m () waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> SessionSeq -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m ()
waitForHostSession remoteHost_ rhKey sseq rhKeyVar vars = do waitForHostSession remoteHost_ rhKey sseq rhKeyVar vars = do
(sessId, tls, vars') <- timeoutThrow (ChatErrorRemoteHost rhKey RHETimeout) 60000000 $ takeRCStep vars (sessId, tls, vars') <- timeoutThrow (ChatErrorRemoteHost rhKey RHETimeout) 60000000 $ takeRCStep vars
@ -250,14 +254,15 @@ cancelRemoteHostSession :: ChatMonad m => Maybe (SessionSeq, RemoteHostStopReaso
cancelRemoteHostSession handlerInfo_ rhKey = do cancelRemoteHostSession handlerInfo_ rhKey = do
sessions <- asks remoteHostSessions sessions <- asks remoteHostSessions
crh <- asks currentRemoteHost crh <- asks currentRemoteHost
deregistered <- atomically $ deregistered <-
TM.lookup rhKey sessions >>= \case atomically $
Nothing -> pure Nothing TM.lookup rhKey sessions >>= \case
Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler Nothing -> pure Nothing
Just (_, rhs) -> do Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler
TM.delete rhKey sessions Just (_, rhs) -> do
modifyTVar' crh $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH TM.delete rhKey sessions
pure $ Just rhs modifyTVar' crh $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH
pure $ Just rhs
forM_ deregistered $ \session -> do forM_ deregistered $ \session -> do
liftIO $ cancelRemoteHost handlingError session `catchAny` (logError . tshow) liftIO $ cancelRemoteHost handlingError session `catchAny` (logError . tshow)
forM_ (snd <$> handlerInfo_) $ \rhStopReason -> forM_ (snd <$> handlerInfo_) $ \rhStopReason ->
@ -401,9 +406,10 @@ findKnownRemoteCtrl = do
(RCCtrlPairing {ctrlFingerprint}, inv@(RCVerifiedInvitation RCInvitation {app})) <- (RCCtrlPairing {ctrlFingerprint}, inv@(RCVerifiedInvitation RCInvitation {app})) <-
timeoutThrow (ChatErrorRemoteCtrl RCETimeout) discoveryTimeout . withAgent $ \a -> rcDiscoverCtrl a pairings timeoutThrow (ChatErrorRemoteCtrl RCETimeout) discoveryTimeout . withAgent $ \a -> rcDiscoverCtrl a pairings
ctrlAppInfo_ <- (Just <$> parseCtrlAppInfo app) `catchChatError` const (pure Nothing) ctrlAppInfo_ <- (Just <$> parseCtrlAppInfo app) `catchChatError` const (pure Nothing)
rc <- withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case rc <-
Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl" withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case
Just rc -> pure rc Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl"
Just rc -> pure rc
atomically $ putTMVar foundCtrl (rc, inv) atomically $ putTMVar foundCtrl (rc, inv)
let compatible = isJust $ compatibleAppVersion hostAppVersionRange . appVersionRange =<< ctrlAppInfo_ let compatible = isJust $ compatibleAppVersion hostAppVersionRange . appVersionRange =<< ctrlAppInfo_
toView CRRemoteCtrlFound {remoteCtrl = remoteCtrlInfo rc (Just RCSSearching), ctrlAppInfo_, appVersion = currentAppVersion, compatible} toView CRRemoteCtrlFound {remoteCtrl = remoteCtrlInfo rc (Just RCSSearching), ctrlAppInfo_, appVersion = currentAppVersion, compatible}
@ -422,7 +428,7 @@ confirmRemoteCtrl rcId = do
pure $ Right (sseq, action, foundCtrl) pure $ Right (sseq, action, foundCtrl)
_ -> pure . Left $ ChatErrorRemoteCtrl RCEBadState _ -> pure . Left $ ChatErrorRemoteCtrl RCEBadState
uninterruptibleCancel listener uninterruptibleCancel listener
(RemoteCtrl{remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found (RemoteCtrl {remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found
unless (rcId == foundRcId) $ throwError $ ChatErrorRemoteCtrl RCEBadController unless (rcId == foundRcId) $ throwError $ ChatErrorRemoteCtrl RCEBadController
connectRemoteCtrl verifiedInv sseq >>= \case connectRemoteCtrl verifiedInv sseq >>= \case
(Nothing, _) -> throwChatError $ CEInternalError "connecting with a stored ctrl" (Nothing, _) -> throwChatError $ CEInternalError "connecting with a stored ctrl"
@ -647,10 +653,12 @@ handleCtrlError sseq mkReason name action =
cancelActiveRemoteCtrl :: ChatMonad m => Maybe (SessionSeq, RemoteCtrlStopReason) -> m () cancelActiveRemoteCtrl :: ChatMonad m => Maybe (SessionSeq, RemoteCtrlStopReason) -> m ()
cancelActiveRemoteCtrl handlerInfo_ = handleAny (logError . tshow) $ do cancelActiveRemoteCtrl handlerInfo_ = handleAny (logError . tshow) $ do
var <- asks remoteCtrlSession var <- asks remoteCtrlSession
session_ <- atomically $ readTVar var >>= \case session_ <-
Nothing -> pure Nothing atomically $
Just (oldSeq, _) | maybe False (/= oldSeq) (fst <$> handlerInfo_) -> pure Nothing readTVar var >>= \case
Just (_, s) -> Just s <$ writeTVar var Nothing Nothing -> pure Nothing
Just (oldSeq, _) | (maybe False ((oldSeq /=) . fst) handlerInfo_) -> pure Nothing
Just (_, s) -> Just s <$ writeTVar var Nothing
forM_ session_ $ \session -> do forM_ session_ $ \session -> do
liftIO $ cancelRemoteCtrl handlingError session liftIO $ cancelRemoteCtrl handlingError session
forM_ (snd <$> handlerInfo_) $ \rcStopReason -> forM_ (snd <$> handlerInfo_) $ \rcStopReason ->

2
src/Simplex/Chat/Remote/AppVersion.hs
View file

@ -11,7 +11,7 @@ module Simplex.Chat.Remote.AppVersion
compatibleAppVersion, compatibleAppVersion,
isAppCompatible, isAppCompatible,
) )
where where
import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J import qualified Data.Aeson as J

6
src/Simplex/Chat/Remote/Multicast.hsc
View file

@ -6,10 +6,8 @@ import Network.Socket
#include <HsNet.h> #include <HsNet.h>
{- | Toggle multicast group membership. -- | Toggle multicast group membership.
-- NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups.
NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups.
-}
setMembership :: Socket -> HostAddress -> Bool -> IO (Either CInt ()) setMembership :: Socket -> HostAddress -> Bool -> IO (Either CInt ())
setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do
#{poke struct ip_mreq, imr_multiaddr} mReqPtr group #{poke struct ip_mreq, imr_multiaddr} mReqPtr group

14
src/Simplex/Chat/Remote/Protocol.hs
View file

@ -6,8 +6,8 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Chat.Remote.Protocol where module Simplex.Chat.Remote.Protocol where
@ -41,16 +41,16 @@ import Simplex.FileTransfer.Description (FileDigest (..))
import Simplex.Messaging.Agent.Client (agentDRG) import Simplex.Messaging.Agent.Client (agentDRG)
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Crypto.Lazy (LazyByteString) import Simplex.Messaging.Crypto.Lazy (LazyByteString)
import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding
import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON, pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag) import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON, pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag)
import Simplex.Messaging.Transport.Buffer (getBuffered) import Simplex.Messaging.Transport.Buffer (getBuffered)
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk) import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk)
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect)
import Simplex.Messaging.Util (liftEitherError, liftEitherWith, liftError, tshow) import Simplex.Messaging.Util (liftEitherError, liftEitherWith, liftError, tshow)
import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode)
import Simplex.RemoteControl.Client (xrcpBlockSize) import Simplex.RemoteControl.Client (xrcpBlockSize)
import qualified Simplex.RemoteControl.Client as RC import qualified Simplex.RemoteControl.Client as RC
import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode)
import System.FilePath (takeFileName, (</>)) import System.FilePath (takeFileName, (</>))
import UnliftIO import UnliftIO
@ -64,10 +64,10 @@ data RemoteCommand
data RemoteResponse data RemoteResponse
= RRChatResponse {chatResponse :: ChatResponse} = RRChatResponse {chatResponse :: ChatResponse}
| RRChatEvent {chatEvent :: Maybe ChatResponse} -- ^ 'Nothing' on poll timeout | RRChatEvent {chatEvent :: Maybe ChatResponse} -- 'Nothing' on poll timeout
| RRFileStored {filePath :: String} | RRFileStored {filePath :: String}
| RRFile {fileSize :: Word32, fileDigest :: FileDigest} -- provides attachment , fileDigest :: FileDigest | RRFile {fileSize :: Word32, fileDigest :: FileDigest} -- provides attachment , fileDigest :: FileDigest
| RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- ^ The protocol error happened on the server side | RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- The protocol error happened on the server side
deriving (Show) deriving (Show)
-- Force platform-independent encoding as the types aren't UI-visible -- Force platform-independent encoding as the types aren't UI-visible
@ -126,7 +126,7 @@ remoteStoreFile c localPath fileName = do
r -> badResponse r r -> badResponse r
remoteGetFile :: RemoteHostClient -> FilePath -> RemoteFile -> ExceptT RemoteProtocolError IO () remoteGetFile :: RemoteHostClient -> FilePath -> RemoteFile -> ExceptT RemoteProtocolError IO ()
remoteGetFile c@RemoteHostClient{encryption} destDir rf@RemoteFile {fileSource = CryptoFile {filePath}} = remoteGetFile c@RemoteHostClient {encryption} destDir rf@RemoteFile {fileSource = CryptoFile {filePath}} =
sendRemoteCommand c Nothing RCGetFile {file = rf} >>= \case sendRemoteCommand c Nothing RCGetFile {file = rf} >>= \case
(getChunk, RRFile {fileSize, fileDigest}) -> do (getChunk, RRFile {fileSize, fileDigest}) -> do
-- TODO we could optimize by checking size and hash before receiving the file -- TODO we could optimize by checking size and hash before receiving the file
@ -140,7 +140,7 @@ sendRemoteCommand' c attachment_ rc = snd <$> sendRemoteCommand c attachment_ rc
sendRemoteCommand :: RemoteHostClient -> Maybe (Handle, Word32) -> RemoteCommand -> ExceptT RemoteProtocolError IO (Int -> IO ByteString, RemoteResponse) sendRemoteCommand :: RemoteHostClient -> Maybe (Handle, Word32) -> RemoteCommand -> ExceptT RemoteProtocolError IO (Int -> IO ByteString, RemoteResponse)
sendRemoteCommand RemoteHostClient {httpClient, hostEncoding, encryption} file_ cmd = do sendRemoteCommand RemoteHostClient {httpClient, hostEncoding, encryption} file_ cmd = do
encFile_ <- mapM (prepareEncryptedFile encryption) file_ encFile_ <- mapM (prepareEncryptedFile encryption) file_
req <- httpRequest encFile_ <$> encryptEncodeHTTP2Body encryption (J.encode cmd) req <- httpRequest encFile_ <$> encryptEncodeHTTP2Body encryption (J.encode cmd)
HTTP2Response {response, respBody} <- liftEitherError (RPEHTTP2 . tshow) $ sendRequestDirect httpClient req Nothing HTTP2Response {response, respBody} <- liftEitherError (RPEHTTP2 . tshow) $ sendRequestDirect httpClient req Nothing
(header, getNext) <- parseDecryptHTTP2Body encryption response respBody (header, getNext) <- parseDecryptHTTP2Body encryption response respBody

6
src/Simplex/Chat/Remote/Transport.hs
View file

@ -5,15 +5,15 @@ module Simplex.Chat.Remote.Transport where
import Control.Monad import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Data.ByteString.Builder (Builder, byteString)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.ByteString.Builder (Builder, byteString)
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy as LB
import Data.Word (Word32) import Data.Word (Word32)
import Simplex.FileTransfer.Description (FileDigest (..))
import Simplex.Chat.Remote.Types import Simplex.Chat.Remote.Types
import Simplex.FileTransfer.Description (FileDigest (..))
import Simplex.FileTransfer.Transport (ReceiveFileError (..), receiveSbFile, sendEncFile)
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Lazy as LC import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.FileTransfer.Transport (ReceiveFileError (..), receiveSbFile, sendEncFile)
import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding
import Simplex.Messaging.Util (liftEitherError, liftEitherWith) import Simplex.Messaging.Util (liftEitherError, liftEitherWith)
import Simplex.RemoteControl.Types (RCErrorType (..)) import Simplex.RemoteControl.Types (RCErrorType (..))

28
src/Simplex/Chat/Remote/Types.hs
View file

@ -21,13 +21,13 @@ import Data.Text (Text)
import Simplex.Chat.Remote.AppVersion import Simplex.Chat.Remote.AppVersion
import Simplex.Chat.Types (verificationCode) import Simplex.Chat.Types (verificationCode)
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile)
import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret) import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret)
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
import Simplex.Messaging.Transport (TLS (..))
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
import Simplex.RemoteControl.Client import Simplex.RemoteControl.Client
import Simplex.RemoteControl.Types import Simplex.RemoteControl.Types
import Simplex.Messaging.Crypto.File (CryptoFile)
import Simplex.Messaging.Transport (TLS (..))
data RemoteHostClient = RemoteHostClient data RemoteHostClient = RemoteHostClient
{ hostEncoding :: PlatformEncoding, { hostEncoding :: PlatformEncoding,
@ -48,13 +48,13 @@ data RemoteCrypto = RemoteCrypto
data RemoteSignatures data RemoteSignatures
= RSSign = RSSign
{ idPrivKey :: C.PrivateKeyEd25519, { idPrivKey :: C.PrivateKeyEd25519,
sessPrivKey :: C.PrivateKeyEd25519 sessPrivKey :: C.PrivateKeyEd25519
} }
| RSVerify | RSVerify
{ idPubKey :: C.PublicKeyEd25519, { idPubKey :: C.PublicKeyEd25519,
sessPubKey :: C.PublicKeyEd25519 sessPubKey :: C.PublicKeyEd25519
} }
type SessionSeq = Int type SessionSeq = Int
@ -71,12 +71,12 @@ data RemoteHostSession
| RHSessionPendingConfirmation {sessionCode :: Text, tls :: TLS, rhPendingSession :: RHPendingSession} | RHSessionPendingConfirmation {sessionCode :: Text, tls :: TLS, rhPendingSession :: RHPendingSession}
| RHSessionConfirmed {tls :: TLS, rhPendingSession :: RHPendingSession} | RHSessionConfirmed {tls :: TLS, rhPendingSession :: RHPendingSession}
| RHSessionConnected | RHSessionConnected
{ rchClient :: RCHostClient, { rchClient :: RCHostClient,
tls :: TLS, tls :: TLS,
rhClient :: RemoteHostClient, rhClient :: RemoteHostClient,
pollAction :: Async (), pollAction :: Async (),
storePath :: FilePath storePath :: FilePath
} }
data RemoteHostSessionState data RemoteHostSessionState
= RHSStarting = RHSStarting

39
src/Simplex/Chat/Store/Connections.hs
View file

@ -4,7 +4,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Connections module Simplex.Chat.Store.Connections
@ -25,11 +24,11 @@ import Data.Text (Text)
import Data.Time.Clock (UTCTime (..)) import Data.Time.Clock (UTCTime (..))
import Database.SQLite.Simple (Only (..), (:.) (..)) import Database.SQLite.Simple (Only (..), (:.) (..))
import Database.SQLite.Simple.QQ (sql) import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Protocol
import Simplex.Chat.Store.Files import Simplex.Chat.Store.Files
import Simplex.Chat.Store.Groups import Simplex.Chat.Store.Groups
import Simplex.Chat.Store.Profiles import Simplex.Chat.Store.Profiles
import Simplex.Chat.Store.Shared import Simplex.Chat.Store.Shared
import Simplex.Chat.Protocol
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Preferences
import Simplex.Messaging.Agent.Protocol (ConnId) import Simplex.Messaging.Agent.Protocol (ConnId)
@ -157,8 +156,9 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity) getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
connId_ <- maybeFirstRow fromOnly $ connId_ <-
DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2) maybeFirstRow fromOnly $
DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_ maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
-- search connection for connection plan: -- search connection for connection plan:
@ -167,21 +167,22 @@ getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) =
-- deleted connections are filtered out to allow re-connecting via same contact address -- deleted connections are filtered out to allow re-connecting via same contact address
getContactConnEntityByConnReqHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity) getContactConnEntityByConnReqHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) = do getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) = do
connId_ <- maybeFirstRow fromOnly $ connId_ <-
DB.query maybeFirstRow fromOnly $
db DB.query
[sql| db
SELECT agent_conn_id FROM ( [sql|
SELECT SELECT agent_conn_id FROM (
agent_conn_id, SELECT
(CASE WHEN contact_id IS NOT NULL THEN 1 ELSE 0 END) AS conn_ord agent_conn_id,
FROM connections (CASE WHEN contact_id IS NOT NULL THEN 1 ELSE 0 END) AS conn_ord
WHERE user_id = ? AND via_contact_uri_hash IN (?,?) AND conn_status != ? FROM connections
ORDER BY conn_ord DESC, created_at DESC WHERE user_id = ? AND via_contact_uri_hash IN (?,?) AND conn_status != ?
LIMIT 1 ORDER BY conn_ord DESC, created_at DESC
) LIMIT 1
|] )
(userId, cReqHash1, cReqHash2, ConnDeleted) |]
(userId, cReqHash1, cReqHash2, ConnDeleted)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_ maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
getConnectionsToSubscribe :: DB.Connection -> IO ([ConnId], [ConnectionEntity]) getConnectionsToSubscribe :: DB.Connection -> IO ([ConnId], [ConnectionEntity])

24
src/Simplex/Chat/Store/Direct.hs
View file

@ -1,13 +1,12 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Direct module Simplex.Chat.Store.Direct
@ -310,14 +309,14 @@ deleteUnusedProfile_ db userId profileId =
updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact
updateContactProfile db user@User {userId} c p' updateContactProfile db user@User {userId} c p'
| displayName == newName = do | displayName == newName = do
liftIO $ updateContactProfile_ db userId profileId p' liftIO $ updateContactProfile_ db userId profileId p'
pure c {profile, mergedPreferences} pure c {profile, mergedPreferences}
| otherwise = | otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime currentTs <- getCurrentTime
updateContactProfile_' db userId profileId p' currentTs updateContactProfile_' db userId profileId p' currentTs
updateContact_ db userId contactId localDisplayName ldn currentTs updateContact_ db userId contactId localDisplayName ldn currentTs
pure $ Right c {localDisplayName = ldn, profile, mergedPreferences} pure $ Right c {localDisplayName = ldn, profile, mergedPreferences}
where where
Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, userPreferences} = c Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, userPreferences} = c
Profile {displayName = newName, preferences} = p' Profile {displayName = newName, preferences} = p'
@ -784,10 +783,8 @@ updateConnectionStatus :: DB.Connection -> Connection -> ConnStatus -> IO ()
updateConnectionStatus db Connection {connId} connStatus = do updateConnectionStatus db Connection {connId} connStatus = do
currentTs <- getCurrentTime currentTs <- getCurrentTime
if connStatus == ConnReady if connStatus == ConnReady
then then DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ?, conn_req_inv = NULL WHERE connection_id = ?" (connStatus, currentTs, connId)
DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ?, conn_req_inv = NULL WHERE connection_id = ?" (connStatus, currentTs, connId) else DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId)
else
DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId)
updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO () updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO ()
updateContactSettings db User {userId} contactId ChatSettings {enableNtfs, sendRcpts, favorite} = updateContactSettings db User {userId} contactId ChatSettings {enableNtfs, sendRcpts, favorite} =
@ -816,4 +813,3 @@ resetContactConnInitiated db User {userId} Connection {connId} = do
WHERE user_id = ? AND connection_id = ? WHERE user_id = ? AND connection_id = ?
|] |]
(updatedAt, userId, connId) (updatedAt, userId, connId)

37
src/Simplex/Chat/Store/Files.hs
View file

@ -109,7 +109,7 @@ import Simplex.Messaging.Protocol (SubscriptionMode (..))
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer] getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
getLiveSndFileTransfers db User {userId} = do getLiveSndFileTransfers db User {userId} = do
cutoffTs <- addUTCTime (- week) <$> getCurrentTime cutoffTs <- addUTCTime (-week) <$> getCurrentTime
fileIds :: [Int64] <- fileIds :: [Int64] <-
map fromOnly map fromOnly
<$> DB.query <$> DB.query
@ -132,7 +132,7 @@ getLiveSndFileTransfers db User {userId} = do
getLiveRcvFileTransfers :: DB.Connection -> User -> IO [RcvFileTransfer] getLiveRcvFileTransfers :: DB.Connection -> User -> IO [RcvFileTransfer]
getLiveRcvFileTransfers db user@User {userId} = do getLiveRcvFileTransfers db user@User {userId} = do
cutoffTs <- addUTCTime (- week) <$> getCurrentTime cutoffTs <- addUTCTime (-week) <$> getCurrentTime
fileIds :: [Int64] <- fileIds :: [Int64] <-
map fromOnly map fromOnly
<$> DB.query <$> DB.query
@ -234,11 +234,12 @@ createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Conn
updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> ExceptT StoreError IO () updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> ExceptT StoreError IO ()
updateSndDirectFTDelivery _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName updateSndDirectFTDelivery _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = liftIO $ updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId =
DB.execute liftIO $
db DB.execute
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL" db
(msgDeliveryId, connId, fileId) "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
(msgDeliveryId, connId, fileId)
updateSndGroupFTDelivery :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> Int64 -> IO () updateSndGroupFTDelivery :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> Int64 -> IO ()
updateSndGroupFTDelivery db GroupMember {groupMemberId} Connection {connId} FileTransferMeta {fileId} msgDeliveryId = updateSndGroupFTDelivery db GroupMember {groupMemberId} Connection {connId} FileTransferMeta {fileId} msgDeliveryId =
@ -724,7 +725,7 @@ removeFileCryptoArgs db fileId = do
getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer] getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer]
getRcvFilesToReceive db user@User {userId} = do getRcvFilesToReceive db user@User {userId} = do
cutoffTs <- addUTCTime (- (2 * nominalDay)) <$> getCurrentTime cutoffTs <- addUTCTime (-(2 * nominalDay)) <$> getCurrentTime
fileIds :: [Int64] <- fileIds :: [Int64] <-
map fromOnly map fromOnly
<$> DB.query <$> DB.query
@ -768,20 +769,20 @@ createRcvFileChunk db RcvFileTransfer {fileId, fileInvitation = FileInvitation {
pure $ case map fromOnly ns of pure $ case map fromOnly ns of
[] []
| chunkNo == 1 -> | chunkNo == 1 ->
if chunkSize >= fileSize if chunkSize >= fileSize
then RcvChunkFinal then RcvChunkFinal
else RcvChunkOk else RcvChunkOk
| otherwise -> RcvChunkError | otherwise -> RcvChunkError
n : _ n : _
| chunkNo == n -> RcvChunkDuplicate | chunkNo == n -> RcvChunkDuplicate
| chunkNo == n + 1 -> | chunkNo == n + 1 ->
let prevSize = n * chunkSize let prevSize = n * chunkSize
in if prevSize >= fileSize in if prevSize >= fileSize
then RcvChunkError then RcvChunkError
else else
if prevSize + chunkSize >= fileSize if prevSize + chunkSize >= fileSize
then RcvChunkFinal then RcvChunkFinal
else RcvChunkOk else RcvChunkOk
| otherwise -> RcvChunkError | otherwise -> RcvChunkError
updatedRcvFileChunkStored :: DB.Connection -> RcvFileTransfer -> Integer -> IO () updatedRcvFileChunkStored :: DB.Connection -> RcvFileTransfer -> Integer -> IO ()

278
src/Simplex/Chat/Store/Groups.hs
View file

@ -2,14 +2,13 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Groups module Simplex.Chat.Store.Groups
@ -122,7 +121,7 @@ import Crypto.Random (ChaChaDRG)
import Data.Either (rights) import Data.Either (rights)
import Data.Int (Int64) import Data.Int (Int64)
import Data.List (partition, sortOn) import Data.List (partition, sortOn)
import Data.Maybe (fromMaybe, isNothing, catMaybes, isJust) import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
import Data.Ord (Down (..)) import Data.Ord (Down (..))
import Data.Text (Text) import Data.Text (Text)
import Data.Time.Clock (UTCTime (..), getCurrentTime) import Data.Time.Clock (UTCTime (..), getCurrentTime)
@ -446,39 +445,39 @@ createGroupInvitedViaLink
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember GSMemAccepted IBUnknown customUserProfileId currentTs supportedChatVRange void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember GSMemAccepted IBUnknown customUserProfileId currentTs supportedChatVRange
liftIO $ setViaGroupLinkHash db groupId connId liftIO $ setViaGroupLinkHash db groupId connId
(,) <$> getGroupInfo db user groupId <*> getGroupMemberById db user hostMemberId (,) <$> getGroupInfo db user groupId <*> getGroupMemberById db user hostMemberId
where where
insertGroup_ currentTs = ExceptT $ do insertGroup_ currentTs = ExceptT $ do
let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile
withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do
liftIO $ do liftIO $ do
DB.execute DB.execute
db db
"INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" "INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs) (displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs)
profileId <- insertedRowId db profileId <- insertedRowId db
DB.execute DB.execute
db db
"INSERT INTO groups (group_profile_id, local_display_name, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?)" "INSERT INTO groups (group_profile_id, local_display_name, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?)"
(profileId, localDisplayName, customUserProfileId, userId, True, currentTs, currentTs, currentTs) (profileId, localDisplayName, customUserProfileId, userId, True, currentTs, currentTs, currentTs)
insertedRowId db insertedRowId db
insertHost_ currentTs groupId = ExceptT $ do insertHost_ currentTs groupId = ExceptT $ do
let fromMemberProfile = profileFromName fromMemberName let fromMemberProfile = profileFromName fromMemberName
withLocalDisplayName db userId fromMemberName $ \localDisplayName -> runExceptT $ do withLocalDisplayName db userId fromMemberName $ \localDisplayName -> runExceptT $ do
(_, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs (_, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs
let MemberIdRole {memberId, memberRole} = fromMember let MemberIdRole {memberId, memberRole} = fromMember
liftIO $ do liftIO $ do
DB.execute DB.execute
db db
[sql| [sql|
INSERT INTO group_members INSERT INTO group_members
( group_id, member_id, member_role, member_category, member_status, invited_by, ( group_id, member_id, member_role, member_category, member_status, invited_by,
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|] |]
( (groupId, memberId, memberRole, GCHostMember, GSMemAccepted, fromInvitedBy userContactId IBUnknown) ( (groupId, memberId, memberRole, GCHostMember, GSMemAccepted, fromInvitedBy userContactId IBUnknown)
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, currentTs, currentTs) :. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, currentTs, currentTs)
) )
insertedRowId db insertedRowId db
setViaGroupLinkHash :: DB.Connection -> GroupId -> Int64 -> IO () setViaGroupLinkHash :: DB.Connection -> GroupId -> Int64 -> IO ()
setViaGroupLinkHash db groupId connId = setViaGroupLinkHash db groupId connId =
@ -814,22 +813,22 @@ createAcceptedMember
insertMember_ (MemberId memId) createdAt insertMember_ (MemberId memId) createdAt
groupMemberId <- liftIO $ insertedRowId db groupMemberId <- liftIO $ insertedRowId db
pure (groupMemberId, MemberId memId) pure (groupMemberId, MemberId memId)
where where
JVersionRange (VersionRange minV maxV) = cReqChatVRange JVersionRange (VersionRange minV maxV) = cReqChatVRange
insertMember_ memberId createdAt = insertMember_ memberId createdAt =
DB.execute DB.execute
db db
[sql| [sql|
INSERT INTO group_members INSERT INTO group_members
( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id, ( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id,
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at, user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at,
peer_chat_min_version, peer_chat_max_version) peer_chat_min_version, peer_chat_max_version)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|] |]
( (groupId, memberId, memberRole, GCInviteeMember, GSMemAccepted, fromInvitedBy userContactId IBUser, groupMemberId' membership) ( (groupId, memberId, memberRole, GCInviteeMember, GSMemAccepted, fromInvitedBy userContactId IBUser, groupMemberId' membership)
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, createdAt, createdAt) :. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, createdAt, createdAt)
:. (minV, maxV) :. (minV, maxV)
) )
createAcceptedMemberConnection :: DB.Connection -> User -> (CommandId, ConnId) -> UserContactRequest -> GroupMemberId -> SubscriptionMode -> IO () createAcceptedMemberConnection :: DB.Connection -> User -> (CommandId, ConnId) -> UserContactRequest -> GroupMemberId -> SubscriptionMode -> IO ()
createAcceptedMemberConnection createAcceptedMemberConnection
@ -957,23 +956,24 @@ createNewMember_
:. (minV, maxV) :. (minV, maxV)
) )
groupMemberId <- insertedRowId db groupMemberId <- insertedRowId db
pure GroupMember { pure
groupMemberId, GroupMember
groupId, { groupMemberId,
memberId, groupId,
memberRole, memberId,
memberCategory, memberRole,
memberStatus, memberCategory,
memberSettings = defaultMemberSettings, memberStatus,
invitedBy, memberSettings = defaultMemberSettings,
invitedByGroupMemberId = memInvitedByGroupMemberId, invitedBy,
localDisplayName, invitedByGroupMemberId = memInvitedByGroupMemberId,
memberProfile = toLocalProfile memberContactProfileId memberProfile "", localDisplayName,
memberContactId, memberProfile = toLocalProfile memberContactProfileId memberProfile "",
memberContactProfileId, memberContactId,
activeConn, memberContactProfileId,
memberChatVRange = JVersionRange mcvr activeConn,
} memberChatVRange = JVersionRange mcvr
}
checkGroupMemberHasItems :: DB.Connection -> User -> GroupMember -> IO (Maybe ChatItemId) checkGroupMemberHasItems :: DB.Connection -> User -> GroupMember -> IO (Maybe ChatItemId)
checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} = checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} =
@ -1104,41 +1104,41 @@ getForwardIntroducedMembers :: DB.Connection -> User -> GroupMember -> Bool -> I
getForwardIntroducedMembers db user invitee highlyAvailable = do getForwardIntroducedMembers db user invitee highlyAvailable = do
memberIds <- map fromOnly <$> query memberIds <- map fromOnly <$> query
filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds
where where
mId = groupMemberId' invitee mId = groupMemberId' invitee
query query
| highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected) | highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected)
| otherwise = | otherwise =
DB.query DB.query
db db
(q <> " AND intro_chat_protocol_version >= ?") (q <> " AND intro_chat_protocol_version >= ?")
(mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange) (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange)
q = q =
[sql| [sql|
SELECT re_group_member_id SELECT re_group_member_id
FROM group_member_intros FROM group_member_intros
WHERE to_group_member_id = ? AND intro_status NOT IN (?,?,?) WHERE to_group_member_id = ? AND intro_status NOT IN (?,?,?)
|] |]
getForwardInvitedMembers :: DB.Connection -> User -> GroupMember -> Bool -> IO [GroupMember] getForwardInvitedMembers :: DB.Connection -> User -> GroupMember -> Bool -> IO [GroupMember]
getForwardInvitedMembers db user forwardMember highlyAvailable = do getForwardInvitedMembers db user forwardMember highlyAvailable = do
memberIds <- map fromOnly <$> query memberIds <- map fromOnly <$> query
filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds
where where
mId = groupMemberId' forwardMember mId = groupMemberId' forwardMember
query query
| highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected) | highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected)
| otherwise = | otherwise =
DB.query DB.query
db db
(q <> " AND intro_chat_protocol_version >= ?") (q <> " AND intro_chat_protocol_version >= ?")
(mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange) (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange)
q = q =
[sql| [sql|
SELECT to_group_member_id SELECT to_group_member_id
FROM group_member_intros FROM group_member_intros
WHERE re_group_member_id = ? AND intro_status NOT IN (?,?,?) WHERE re_group_member_id = ? AND intro_status NOT IN (?,?,?)
|] |]
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember
createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do
@ -1263,15 +1263,15 @@ getViaGroupContact db user@User {userId} GroupMember {groupMemberId} = do
updateGroupProfile :: DB.Connection -> User -> GroupInfo -> GroupProfile -> ExceptT StoreError IO GroupInfo updateGroupProfile :: DB.Connection -> User -> GroupInfo -> GroupProfile -> ExceptT StoreError IO GroupInfo
updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName}} p'@GroupProfile {displayName = newName, fullName, description, image, groupPreferences} updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName}} p'@GroupProfile {displayName = newName, fullName, description, image, groupPreferences}
| displayName == newName = liftIO $ do | displayName == newName = liftIO $ do
currentTs <- getCurrentTime
updateGroupProfile_ currentTs
pure (g :: GroupInfo) {groupProfile = p', fullGroupPreferences}
| otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime currentTs <- getCurrentTime
updateGroupProfile_ currentTs updateGroupProfile_ currentTs
updateGroup_ ldn currentTs pure (g :: GroupInfo) {groupProfile = p', fullGroupPreferences}
pure $ Right (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences} | otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime
updateGroupProfile_ currentTs
updateGroup_ ldn currentTs
pure $ Right (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences}
where where
fullGroupPreferences = mergeGroupPreferences groupPreferences fullGroupPreferences = mergeGroupPreferences groupPreferences
updateGroupProfile_ currentTs = updateGroupProfile_ currentTs =
@ -1317,31 +1317,33 @@ getGroupInfo db User {userId, userContactId} groupId =
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo) getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
groupId_ <- maybeFirstRow fromOnly $ groupId_ <-
DB.query maybeFirstRow fromOnly $
db DB.query
[sql| db
SELECT group_id [sql|
FROM user_contact_links SELECT group_id
WHERE user_id = ? AND conn_req_contact IN (?,?) FROM user_contact_links
|] WHERE user_id = ? AND conn_req_contact IN (?,?)
(userId, cReqSchema1, cReqSchema2) |]
(userId, cReqSchema1, cReqSchema2)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_ maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
getGroupInfoByGroupLinkHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo) getGroupInfoByGroupLinkHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
groupId_ <- maybeFirstRow fromOnly $ groupId_ <-
DB.query maybeFirstRow fromOnly $
db DB.query
[sql| db
SELECT g.group_id [sql|
FROM groups g SELECT g.group_id
JOIN group_members mu ON mu.group_id = g.group_id FROM groups g
WHERE g.user_id = ? AND g.via_group_link_uri_hash IN (?,?) JOIN group_members mu ON mu.group_id = g.group_id
AND mu.contact_id = ? AND mu.member_status NOT IN (?,?,?) WHERE g.user_id = ? AND g.via_group_link_uri_hash IN (?,?)
LIMIT 1 AND mu.contact_id = ? AND mu.member_status NOT IN (?,?,?)
|] LIMIT 1
(userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) |]
(userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_ maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId
@ -1935,18 +1937,18 @@ createMemberContactConn_
updateMemberProfile :: DB.Connection -> User -> GroupMember -> Profile -> ExceptT StoreError IO GroupMember updateMemberProfile :: DB.Connection -> User -> GroupMember -> Profile -> ExceptT StoreError IO GroupMember
updateMemberProfile db User {userId} m p' updateMemberProfile db User {userId} m p'
| displayName == newName = do | displayName == newName = do
liftIO $ updateContactProfile_ db userId profileId p' liftIO $ updateContactProfile_ db userId profileId p'
pure m {memberProfile = profile} pure m {memberProfile = profile}
| otherwise = | otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime currentTs <- getCurrentTime
updateContactProfile_' db userId profileId p' currentTs updateContactProfile_' db userId profileId p' currentTs
DB.execute DB.execute
db db
"UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?" "UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?"
(ldn, currentTs, userId, groupMemberId) (ldn, currentTs, userId, groupMemberId)
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId)
pure $ Right m {localDisplayName = ldn, memberProfile = profile} pure $ Right m {localDisplayName = ldn, memberProfile = profile}
where where
GroupMember {groupMemberId, localDisplayName, memberProfile = LocalProfile {profileId, displayName, localAlias}} = m GroupMember {groupMemberId, localDisplayName, memberProfile = LocalProfile {profileId, displayName, localAlias}} = m
Profile {displayName = newName} = p' Profile {displayName = newName} = p'

116
src/Simplex/Chat/Store/Messages.hs
View file

@ -10,7 +10,6 @@
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Messages module Simplex.Chat.Store.Messages
@ -199,40 +198,41 @@ createNewMessageAndRcvMsgDelivery db connOrGroupId newMessage sharedMsgId_ RcvMs
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs
pure msg pure msg
createNewRcvMessage :: forall e. (MsgEncodingI e) => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
createNewRcvMessage db connOrGroupId NewMessage{chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember = createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember =
case connOrGroupId of case connOrGroupId of
ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing
GroupId groupId -> case sharedMsgId_ of GroupId groupId -> case sharedMsgId_ of
Just sharedMsgId -> liftIO (duplicateGroupMsgMemberIds groupId sharedMsgId) >>= \case Just sharedMsgId ->
Just (duplAuthorId, duplFwdMemberId) -> liftIO (duplicateGroupMsgMemberIds groupId sharedMsgId) >>= \case
throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId Just (duplAuthorId, duplFwdMemberId) ->
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
where where
duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO (Maybe (Maybe GroupMemberId, Maybe GroupMemberId)) duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO (Maybe (Maybe GroupMemberId, Maybe GroupMemberId))
duplicateGroupMsgMemberIds groupId sharedMsgId = duplicateGroupMsgMemberIds groupId sharedMsgId =
maybeFirstRow id maybeFirstRow id $
$ DB.query DB.query
db
[sql|
SELECT author_group_member_id, forwarded_by_group_member_id
FROM messages
WHERE group_id = ? AND shared_msg_id = ? LIMIT 1
|]
(groupId, sharedMsgId)
insertRcvMsg connId_ groupId_ = do
currentTs <- getCurrentTime
DB.execute
db db
[sql| [sql|
SELECT author_group_member_id, forwarded_by_group_member_id INSERT INTO messages
FROM messages (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id)
WHERE group_id = ? AND shared_msg_id = ? LIMIT 1 VALUES (?,?,?,?,?,?,?,?,?,?)
|] |]
(groupId, sharedMsgId) (MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember)
insertRcvMsg connId_ groupId_ = do msgId <- insertedRowId db
currentTs <- getCurrentTime pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember}
DB.execute
db
[sql|
INSERT INTO messages
(msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id)
VALUES (?,?,?,?,?,?,?,?,?,?)
|]
(MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember)
msgId <- insertedRowId db
pure RcvMessage{msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember}
createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO () createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO ()
createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do
@ -1802,22 +1802,22 @@ getDirectReactions db ct itemSharedMId sent =
setDirectReaction :: DB.Connection -> Contact -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO () setDirectReaction :: DB.Connection -> Contact -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO ()
setDirectReaction db ct itemSharedMId sent reaction add msgId reactionTs setDirectReaction db ct itemSharedMId sent reaction add msgId reactionTs
| add = | add =
DB.execute DB.execute
db db
[sql| [sql|
INSERT INTO chat_item_reactions INSERT INTO chat_item_reactions
(contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) (contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts)
VALUES (?,?,?,?,?,?) VALUES (?,?,?,?,?,?)
|] |]
(contactId' ct, itemSharedMId, sent, reaction, msgId, reactionTs) (contactId' ct, itemSharedMId, sent, reaction, msgId, reactionTs)
| otherwise = | otherwise =
DB.execute DB.execute
db db
[sql| [sql|
DELETE FROM chat_item_reactions DELETE FROM chat_item_reactions
WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? AND reaction = ? WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? AND reaction = ?
|] |]
(contactId' ct, itemSharedMId, sent, reaction) (contactId' ct, itemSharedMId, sent, reaction)
getGroupReactions :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> IO [MsgReaction] getGroupReactions :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> IO [MsgReaction]
getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent = getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent =
@ -1834,22 +1834,22 @@ getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent =
setGroupReaction :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO () setGroupReaction :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO ()
setGroupReaction db GroupInfo {groupId} m itemMemberId itemSharedMId sent reaction add msgId reactionTs setGroupReaction db GroupInfo {groupId} m itemMemberId itemSharedMId sent reaction add msgId reactionTs
| add = | add =
DB.execute DB.execute
db db
[sql| [sql|
INSERT INTO chat_item_reactions INSERT INTO chat_item_reactions
(group_id, group_member_id, item_member_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) (group_id, group_member_id, item_member_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts)
VALUES (?,?,?,?,?,?,?,?) VALUES (?,?,?,?,?,?,?,?)
|] |]
(groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent, reaction, msgId, reactionTs) (groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent, reaction, msgId, reactionTs)
| otherwise = | otherwise =
DB.execute DB.execute
db db
[sql| [sql|
DELETE FROM chat_item_reactions DELETE FROM chat_item_reactions
WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ? WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ?
|] |]
(groupId, groupMemberId' m, itemSharedMId, itemMemberId, sent, reaction) (groupId, groupMemberId' m, itemSharedMId, itemMemberId, sent, reaction)
getTimedItems :: DB.Connection -> User -> UTCTime -> IO [((ChatRef, ChatItemId), UTCTime)] getTimedItems :: DB.Connection -> User -> UTCTime -> IO [((ChatRef, ChatItemId), UTCTime)]
getTimedItems db User {userId} startTimedThreadCutoff = getTimedItems db User {userId} startTimedThreadCutoff =

52
src/Simplex/Chat/Store/Profiles.hs
View file

@ -8,7 +8,6 @@
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Profiles module Simplex.Chat.Store.Profiles
@ -66,9 +65,9 @@ import Control.Monad.IO.Class
import qualified Data.Aeson.TH as J import qualified Data.Aeson.TH as J
import Data.Functor (($>)) import Data.Functor (($>))
import Data.Int (Int64) import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime (..), getCurrentTime) import Data.Time.Clock (UTCTime (..), getCurrentTime)
@ -89,7 +88,7 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Parsers (defaultJSON)
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode) import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode)
import Simplex.Messaging.Transport.Client (TransportHost) import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (safeDecodeUtf8, eitherToMaybe) import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User
createUserRecord db auId p activeUser = createUserRecordAt db auId p activeUser =<< liftIO getCurrentTime createUserRecord db auId p activeUser = createUserRecordAt db auId p activeUser =<< liftIO getCurrentTime
@ -248,19 +247,19 @@ updateUserGroupReceipts db User {userId} UserMsgReceiptSettings {enable, clearOv
updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User
updateUserProfile db user p' updateUserProfile db user p'
| displayName == newName = do | displayName == newName = do
liftIO $ updateContactProfile_ db userId profileId p' liftIO $ updateContactProfile_ db userId profileId p'
pure user {profile, fullPreferences} pure user {profile, fullPreferences}
| otherwise = | otherwise =
checkConstraint SEDuplicateName . liftIO $ do checkConstraint SEDuplicateName . liftIO $ do
currentTs <- getCurrentTime currentTs <- getCurrentTime
DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId) DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId)
DB.execute DB.execute
db db
"INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" "INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(newName, newName, userId, currentTs, currentTs) (newName, newName, userId, currentTs, currentTs)
updateContactProfile_' db userId profileId p' currentTs updateContactProfile_' db userId profileId p' currentTs
updateContact_ db userId userContactId localDisplayName newName currentTs updateContact_ db userId userContactId localDisplayName newName currentTs
pure user {localDisplayName = newName, profile, fullPreferences} pure user {localDisplayName = newName, profile, fullPreferences}
where where
User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}} = user User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}} = user
Profile {displayName = newName, preferences} = p' Profile {displayName = newName, preferences} = p'
@ -457,17 +456,18 @@ getUserContactLinkByConnReq db User {userId} (cReqSchema1, cReqSchema2) =
getContactWithoutConnViaAddress :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact) getContactWithoutConnViaAddress :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact)
getContactWithoutConnViaAddress db user@User {userId} (cReqSchema1, cReqSchema2) = do getContactWithoutConnViaAddress db user@User {userId} (cReqSchema1, cReqSchema2) = do
ctId_ <- maybeFirstRow fromOnly $ ctId_ <-
DB.query maybeFirstRow fromOnly $
db DB.query
[sql| db
SELECT ct.contact_id [sql|
FROM contacts ct SELECT ct.contact_id
JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id FROM contacts ct
LEFT JOIN connections c ON c.contact_id = ct.contact_id JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
WHERE cp.user_id = ? AND cp.contact_link IN (?,?) AND c.connection_id IS NULL LEFT JOIN connections c ON c.contact_id = ct.contact_id
|] WHERE cp.user_id = ? AND cp.contact_link IN (?,?) AND c.connection_id IS NULL
(userId, cReqSchema1, cReqSchema2) |]
(userId, cReqSchema1, cReqSchema2)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db user) ctId_ maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db user) ctId_
updateUserAddressAutoAccept :: DB.Connection -> User -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink updateUserAddressAutoAccept :: DB.Connection -> User -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink

2
src/Simplex/Chat/Store/Shared.hs
View file

@ -101,7 +101,7 @@ data StoreError
| SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId} | SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId}
| SEDuplicateGroupMessage {groupId :: Int64, sharedMsgId :: SharedMsgId, authorGroupMemberId :: Maybe GroupMemberId, forwardedByGroupMemberId :: Maybe GroupMemberId} | SEDuplicateGroupMessage {groupId :: Int64, sharedMsgId :: SharedMsgId, authorGroupMemberId :: Maybe GroupMemberId, forwardedByGroupMemberId :: Maybe GroupMemberId}
| SERemoteHostNotFound {remoteHostId :: RemoteHostId} | SERemoteHostNotFound {remoteHostId :: RemoteHostId}
| SERemoteHostUnknown -- ^ attempting to store KnownHost without a known fingerprint | SERemoteHostUnknown -- attempting to store KnownHost without a known fingerprint
| SERemoteHostDuplicateCA | SERemoteHostDuplicateCA
| SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId} | SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
| SERemoteCtrlDuplicateCA | SERemoteCtrlDuplicateCA

30
src/Simplex/Chat/Terminal/Input.hs
View file

@ -194,19 +194,19 @@ receiveFromTTY cc@ChatController {inputQ, currentUser, currentRemoteHost, chatSt
case lm_ of case lm_ of
Just LiveMessage {chatName} Just LiveMessage {chatName}
| live -> do | live -> do
writeTVar termState ts' {previousInput} writeTVar termState ts' {previousInput}
writeTBQueue inputQ $ "/live " <> chatNameStr chatName writeTBQueue inputQ $ "/live " <> chatNameStr chatName
| otherwise -> | otherwise ->
writeTVar termState ts' {inputPrompt = "> ", previousInput} writeTVar termState ts' {inputPrompt = "> ", previousInput}
where where
previousInput = chatNameStr chatName <> " " <> s previousInput = chatNameStr chatName <> " " <> s
_ _
| live -> when (isSend s) $ do | live -> when (isSend s) $ do
writeTVar termState ts' {previousInput = s} writeTVar termState ts' {previousInput = s}
writeTBQueue inputQ $ "/live " <> s writeTBQueue inputQ $ "/live " <> s
| otherwise -> do | otherwise -> do
writeTVar termState ts' {inputPrompt = "> ", previousInput = s} writeTVar termState ts' {inputPrompt = "> ", previousInput = s}
writeTBQueue inputQ s writeTBQueue inputQ s
pure $ (s,) <$> lm_ pure $ (s,) <$> lm_
where where
isSend s = length s > 1 && (head s == '@' || head s == '#') isSend s = length s > 1 && (head s == '@' || head s == '#')
@ -343,9 +343,9 @@ updateTermState user_ st chatPrefix live tw (key, ms) ts@TerminalState {inputStr
charsWithContact cs charsWithContact cs
| live = cs | live = cs
| null s && cs /= "@" && cs /= "#" && cs /= "/" && cs /= ">" && cs /= "\\" && cs /= "!" && cs /= "+" && cs /= "-" = | null s && cs /= "@" && cs /= "#" && cs /= "/" && cs /= ">" && cs /= "\\" && cs /= "!" && cs /= "+" && cs /= "-" =
chatPrefix <> cs chatPrefix <> cs
| (s == ">" || s == "\\" || s == "!") && cs == " " = | (s == ">" || s == "\\" || s == "!") && cs == " " =
cs <> chatPrefix cs <> chatPrefix
| otherwise = cs | otherwise = cs
insertChars = ts' . if p >= length s then append else insert insertChars = ts' . if p >= length s then append else insert
append cs = let s' = s <> cs in (s', length s') append cs = let s' = s <> cs in (s', length s')
@ -381,13 +381,13 @@ updateTermState user_ st chatPrefix live tw (key, ms) ts@TerminalState {inputStr
prevWordPos prevWordPos
| p == 0 || null s = p | p == 0 || null s = p
| otherwise = | otherwise =
let before = take p s let before = take p s
beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before
in max 0 $ p - length before + length beforeWord in max 0 $ p - length before + length beforeWord
nextWordPos nextWordPos
| p >= length s || null s = p | p >= length s || null s = p
| otherwise = | otherwise =
let after = drop p s let after = drop p s
afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after
in min (length s) $ p + length after - length afterWord in min (length s) $ p + length after - length afterWord
ts' (s', p') = ts {inputString = s', inputPosition = p', autoComplete = acp {acTabPressed = False}} ts' (s', p') = ts {inputString = s', inputPosition = p', autoComplete = acp {acTabPressed = False}}

15
src/Simplex/Chat/Terminal/Output.hs
View file

@ -24,7 +24,7 @@ import Simplex.Chat (execChatCommand, processChatCommand)
import Simplex.Chat.Controller import Simplex.Chat.Controller
import Simplex.Chat.Markdown import Simplex.Chat.Markdown
import Simplex.Chat.Messages import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent (CIContent(..), SMsgDirection (..)) import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..))
import Simplex.Chat.Options import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..), msgContentText) import Simplex.Chat.Protocol (MsgContent (..), msgContentText)
import Simplex.Chat.Remote.Types (RHKey (..), RemoteHostId, RemoteHostInfo (..), RemoteHostSession (..)) import Simplex.Chat.Remote.Types (RHKey (..), RemoteHostId, RemoteHostInfo (..), RemoteHostSession (..))
@ -167,9 +167,10 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc
_ -> pure () _ -> pure ()
logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s
getRemoteUser rhId = runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case getRemoteUser rhId =
CRActiveUser {user} -> updateRemoteUser ct user rhId runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case
cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr CRActiveUser {user} -> updateRemoteUser ct user rhId
cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr
removeRemoteUser rhId = atomically $ TM.delete rhId (currentRemoteUsers ct) removeRemoteUser rhId = atomically $ TM.delete rhId (currentRemoteUsers ct)
responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO () responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO ()
@ -326,9 +327,9 @@ updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessag
clearLines from till clearLines from till
| from >= till = return () | from >= till = return ()
| otherwise = do | otherwise = do
setCursorPosition $ Position {row = from, col = 0} setCursorPosition $ Position {row = from, col = 0}
eraseInLine EraseForward eraseInLine EraseForward
clearLines (from + 1) till clearLines (from + 1) till
inputHeight :: TerminalState -> Int inputHeight :: TerminalState -> Int
inputHeight ts = length (autoCompletePrefix ts <> inputPrompt ts <> inputString ts) `div` width + 1 inputHeight ts = length (autoCompletePrefix ts <> inputPrompt ts <> inputString ts) `div` width + 1
autoCompletePrefix :: TerminalState -> String autoCompletePrefix :: TerminalState -> String

7
src/Simplex/Chat/Types.hs
View file

@ -17,7 +17,6 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use newtype instead of data" #-} {-# HLINT ignore "Use newtype instead of data" #-}
@ -40,7 +39,7 @@ import qualified Data.Text as T
import Data.Time.Clock (UTCTime) import Data.Time.Clock (UTCTime)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Database.SQLite.Simple (ResultError (..), SQLData (..)) import Database.SQLite.Simple (ResultError (..), SQLData (..))
import Database.SQLite.Simple.FromField (returnError, FromField(..)) import Database.SQLite.Simple.FromField (FromField (..), returnError)
import Database.SQLite.Simple.Internal (Field (..)) import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok import Database.SQLite.Simple.Ok
import Database.SQLite.Simple.ToField (ToField (..)) import Database.SQLite.Simple.ToField (ToField (..))
@ -50,7 +49,7 @@ import Simplex.FileTransfer.Description (FileDigest)
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId) import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId)
import Simplex.Messaging.Crypto.File (CryptoFileArgs (..)) import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON, enumJSON) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, sumTypeJSON, taggedObjectJSON)
import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI) import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI)
import Simplex.Messaging.Util ((<$?>)) import Simplex.Messaging.Util ((<$?>))
import Simplex.Messaging.Version import Simplex.Messaging.Version
@ -498,7 +497,7 @@ data LocalProfile = LocalProfile
deriving (Eq, Show) deriving (Eq, Show)
localProfileId :: LocalProfile -> ProfileId localProfileId :: LocalProfile -> ProfileId
localProfileId LocalProfile{profileId} = profileId localProfileId LocalProfile {profileId} = profileId
toLocalProfile :: ProfileId -> Profile -> LocalAlias -> LocalProfile toLocalProfile :: ProfileId -> Profile -> LocalAlias -> LocalProfile
toLocalProfile profileId Profile {displayName, fullName, image, contactLink, preferences} localAlias = toLocalProfile profileId Profile {displayName, fullName, image, contactLink, preferences} localAlias =

1
src/Simplex/Chat/Types/Preferences.hs
View file

@ -14,7 +14,6 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeFamilyDependencies #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}

2
src/Simplex/Chat/Types/Util.hs
View file

@ -2,7 +2,7 @@
module Simplex.Chat.Types.Util where module Simplex.Chat.Types.Util where
import Data.Aeson (ToJSON, FromJSON) import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as J import qualified Data.Aeson as J
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.ByteString.Lazy.Char8 as LB

175
src/Simplex/Chat/View.hs
View file

@ -14,8 +14,8 @@ module Simplex.Chat.View where
import qualified Data.Aeson as J import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ import qualified Data.Aeson.TH as JQ
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (isSpace, toUpper) import Data.Char (isSpace, toUpper)
import Data.Function (on) import Data.Function (on)
@ -44,8 +44,8 @@ import Simplex.Chat.Markdown
import Simplex.Chat.Messages hiding (NewChatItem (..)) import Simplex.Chat.Messages hiding (NewChatItem (..))
import Simplex.Chat.Messages.CIContent import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Protocol import Simplex.Chat.Protocol
import Simplex.Chat.Remote.AppVersion (AppVersion (..), pattern AppVersionRange)
import Simplex.Chat.Remote.Types import Simplex.Chat.Remote.Types
import Simplex.Chat.Remote.AppVersion (pattern AppVersionRange, AppVersion (..))
import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..)) import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..))
import Simplex.Chat.Styled import Simplex.Chat.Styled
import Simplex.Chat.Types import Simplex.Chat.Types
@ -308,10 +308,10 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
<> maybe [] ((: []) . plain . cryptoFileArgsStr testView) cfArgs_ <> maybe [] ((: []) . plain . cryptoFileArgsStr testView) cfArgs_
CRRemoteCtrlList cs -> viewRemoteCtrls cs CRRemoteCtrlList cs -> viewRemoteCtrls cs
CRRemoteCtrlFound {remoteCtrl = RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName}, ctrlAppInfo_, appVersion, compatible} -> CRRemoteCtrlFound {remoteCtrl = RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName}, ctrlAppInfo_, appVersion, compatible} ->
[ "remote controller " <> sShow remoteCtrlId <> " found: " [ ("remote controller " <> sShow remoteCtrlId <> " found: ")
<> maybe (deviceName <> "not compatible") (\info -> viewRemoteCtrl info appVersion compatible) ctrlAppInfo_ <> maybe (deviceName <> "not compatible") (\info -> viewRemoteCtrl info appVersion compatible) ctrlAppInfo_
] ]
<> [ "use " <> highlight ("/confirm remote ctrl " <> show remoteCtrlId) <> " to connect" | isJust ctrlAppInfo_ && compatible] <> ["use " <> highlight ("/confirm remote ctrl " <> show remoteCtrlId) <> " to connect" | isJust ctrlAppInfo_ && compatible]
where where
deviceName = if T.null ctrlDeviceName then "" else plain ctrlDeviceName <> ", " deviceName = if T.null ctrlDeviceName then "" else plain ctrlDeviceName <> ", "
CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion} -> CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion} ->
@ -511,42 +511,43 @@ viewChats ts tz = concatMap chatPreview . reverse
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString] viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember}, content, quotedItem, file} doShow ts tz = viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember}, content, quotedItem, file} doShow ts tz =
withGroupMsgForwarded . withItemDeleted <$> (case chat of withGroupMsgForwarded . withItemDeleted <$> viewCI
DirectChat c -> case chatDir of
CIDirectSnd -> case content of
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
CISndGroupEvent {} -> showSndItemProhibited to
_ -> showSndItem to
where
to = ttyToContact' c
CIDirectRcv -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
CIRcvGroupEvent {} -> showRcvItemProhibited from
_ -> showRcvItem from
where
from = ttyFromContact c
where
quote = maybe [] (directQuote chatDir) quotedItem
GroupChat g -> case chatDir of
CIGroupSnd -> case content of
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
CISndGroupInvitation {} -> showSndItemProhibited to
_ -> showSndItem to
where
to = ttyToGroup g
CIGroupRcv m -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
CIRcvGroupInvitation {} -> showRcvItemProhibited from
CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False
_ -> showRcvItem from
where
from = ttyFromGroup g m
where
quote = maybe [] (groupQuote g) quotedItem
_ -> [])
where where
viewCI = case chat of
DirectChat c -> case chatDir of
CIDirectSnd -> case content of
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
CISndGroupEvent {} -> showSndItemProhibited to
_ -> showSndItem to
where
to = ttyToContact' c
CIDirectRcv -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
CIRcvGroupEvent {} -> showRcvItemProhibited from
_ -> showRcvItem from
where
from = ttyFromContact c
where
quote = maybe [] (directQuote chatDir) quotedItem
GroupChat g -> case chatDir of
CIGroupSnd -> case content of
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
CISndGroupInvitation {} -> showSndItemProhibited to
_ -> showSndItem to
where
to = ttyToGroup g
CIGroupRcv m -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
CIRcvGroupInvitation {} -> showRcvItemProhibited from
CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False
_ -> showRcvItem from
where
from = ttyFromGroup g m
where
quote = maybe [] (groupQuote g) quotedItem
_ -> []
withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of
Nothing -> item Nothing -> item
Just t -> item <> styled (colored Red) (" [" <> t <> "]") Just t -> item <> styled (colored Red) (" [" <> t <> "]")
@ -667,15 +668,15 @@ viewItemDelete chat ci@ChatItem {chatDir, meta, content = deletedContent} toItem
| timed = [plain ("timed message deleted: " <> T.unpack (ciContentToText deletedContent)) | testView] | timed = [plain ("timed message deleted: " <> T.unpack (ciContentToText deletedContent)) | testView]
| byUser = [plain $ "message " <> T.unpack (fromMaybe "deleted" deletedText_)] -- deletedText_ Nothing should be impossible here | byUser = [plain $ "message " <> T.unpack (fromMaybe "deleted" deletedText_)] -- deletedText_ Nothing should be impossible here
| otherwise = case chat of | otherwise = case chat of
DirectChat c -> case (chatDir, deletedContent) of DirectChat c -> case (chatDir, deletedContent) of
(CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c deletedText_) [] mc ts tz meta (CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c deletedText_) [] mc ts tz meta
_ -> prohibited
GroupChat g -> case ciMsgContent deletedContent of
Just mc ->
let m = chatItemMember g ci
in viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts tz meta
_ -> prohibited
_ -> prohibited _ -> prohibited
GroupChat g -> case ciMsgContent deletedContent of
Just mc ->
let m = chatItemMember g ci
in viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts tz meta
_ -> prohibited
_ -> prohibited
where where
deletedText_ :: Maybe Text deletedText_ :: Maybe Text
deletedText_ = case toItem of deletedText_ = case toItem of
@ -788,7 +789,7 @@ viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of
viewContactsList :: [Contact] -> [StyledString] viewContactsList :: [Contact] -> [StyledString]
viewContactsList = viewContactsList =
let getLDN :: Contact -> ContactName let getLDN :: Contact -> ContactName
getLDN Contact{localDisplayName} = localDisplayName getLDN Contact {localDisplayName} = localDisplayName
ldn = T.toLower . getLDN ldn = T.toLower . getLDN
in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn
where where
@ -823,8 +824,8 @@ simplexChatContact (CRContactUri crData) = CRContactUri crData {crScheme = simpl
autoAcceptStatus_ :: Maybe AutoAccept -> [StyledString] autoAcceptStatus_ :: Maybe AutoAccept -> [StyledString]
autoAcceptStatus_ = \case autoAcceptStatus_ = \case
Just AutoAccept {acceptIncognito, autoReply} -> Just AutoAccept {acceptIncognito, autoReply} ->
("auto_accept on" <> if acceptIncognito then ", incognito" else "") : ("auto_accept on" <> if acceptIncognito then ", incognito" else "")
maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply : maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply
_ -> ["auto_accept off"] _ -> ["auto_accept off"]
groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> GroupMemberRole -> [StyledString] groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> GroupMemberRole -> [StyledString]
@ -907,10 +908,10 @@ viewJoinedGroupMember g m =
viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString] viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString]
viewReceivedGroupInvitation g c role = viewReceivedGroupInvitation g c role =
ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role) : ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role)
case incognitoMembershipProfile g of : case incognitoMembershipProfile g of
Just mp -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to join incognito as " <> incognitoProfile' (fromLocalProfile mp)] Just mp -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to join incognito as " <> incognitoProfile' (fromLocalProfile mp)]
Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"] Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"]
groupPreserved :: GroupInfo -> [StyledString] groupPreserved :: GroupInfo -> [StyledString]
groupPreserved g = ["use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the group"] groupPreserved g = ["use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the group"]
@ -996,13 +997,13 @@ viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs
GSMemRemoved -> delete "you are removed" GSMemRemoved -> delete "you are removed"
GSMemLeft -> delete "you left" GSMemLeft -> delete "you left"
GSMemGroupDeleted -> delete "group deleted" GSMemGroupDeleted -> delete "group deleted"
_ -> " (" <> memberCount <> _ -> " (" <> memberCount <> viewNtf <> ")"
case enableNtfs of
MFAll -> ")"
MFNone -> ", muted, " <> unmute
MFMentions -> ", mentions only, " <> unmute
where where
unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g) <> ")" viewNtf = case enableNtfs of
MFAll -> ""
MFNone -> ", muted, " <> unmute
MFMentions -> ", mentions only, " <> unmute
unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g)
delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> viewGroupName g) <> ")" delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> viewGroupName g) <> ")"
memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s" memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s"
@ -1028,9 +1029,9 @@ viewContactsMerged c1 c2 ct' =
viewContactAndMemberAssociated :: Contact -> GroupInfo -> GroupMember -> Contact -> [StyledString] viewContactAndMemberAssociated :: Contact -> GroupInfo -> GroupMember -> Contact -> [StyledString]
viewContactAndMemberAssociated ct g m ct' = viewContactAndMemberAssociated ct g m ct' =
[ "contact and member are merged: " <> ttyContact' ct <> ", " <> ttyGroup' g <> " " <> ttyMember m, [ "contact and member are merged: " <> ttyContact' ct <> ", " <> ttyGroup' g <> " " <> ttyMember m,
"use " <> ttyToContact' ct' <> highlight' "<message>" <> " to send messages" "use " <> ttyToContact' ct' <> highlight' "<message>" <> " to send messages"
] ]
viewUserProfile :: Profile -> [StyledString] viewUserProfile :: Profile -> [StyledString]
viewUserProfile Profile {displayName, fullName} = viewUserProfile Profile {displayName, fullName} =
@ -1396,14 +1397,14 @@ viewContactUpdated
Contact {localDisplayName = n', profile = LocalProfile {fullName = fullName', contactLink = contactLink'}} Contact {localDisplayName = n', profile = LocalProfile {fullName = fullName', contactLink = contactLink'}}
| n == n' && fullName == fullName' && contactLink == contactLink' = [] | n == n' && fullName == fullName' && contactLink == contactLink' = []
| n == n' && fullName == fullName' = | n == n' && fullName == fullName' =
if isNothing contactLink' if isNothing contactLink'
then [ttyContact n <> " removed contact address"] then [ttyContact n <> " removed contact address"]
else [ttyContact n <> " set new contact address, use " <> highlight ("/info " <> n) <> " to view"] else [ttyContact n <> " set new contact address, use " <> highlight ("/info " <> n) <> " to view"]
| n == n' = ["contact " <> ttyContact n <> fullNameUpdate] | n == n' = ["contact " <> ttyContact n <> fullNameUpdate]
| otherwise = | otherwise =
[ "contact " <> ttyContact n <> " changed to " <> ttyFullName n' fullName', [ "contact " <> ttyContact n <> " changed to " <> ttyFullName n' fullName',
"use " <> ttyToContact n' <> highlight' "<message>" <> " to send messages" "use " <> ttyToContact n' <> highlight' "<message>" <> " to send messages"
] ]
where where
fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName' fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName'
@ -1428,11 +1429,11 @@ receivedWithTime_ ts tz from quote CIMeta {itemId, itemTs, itemEdited, itemDelet
live live
| itemEdited || isJust itemDeleted = "" | itemEdited || isJust itemDeleted = ""
| otherwise = case itemLive of | otherwise = case itemLive of
Just True Just True
| updated -> ttyFrom "[LIVE] " | updated -> ttyFrom "[LIVE] "
| otherwise -> ttyFrom "[LIVE started]" <> " use " <> highlight' ("/show [on/off/" <> show itemId <> "] ") | otherwise -> ttyFrom "[LIVE started]" <> " use " <> highlight' ("/show [on/off/" <> show itemId <> "] ")
Just False -> ttyFrom "[LIVE ended] " Just False -> ttyFrom "[LIVE ended] "
_ -> "" _ -> ""
ttyMsgTime :: CurrentTime -> TimeZone -> UTCTime -> StyledString ttyMsgTime :: CurrentTime -> TimeZone -> UTCTime -> StyledString
ttyMsgTime now tz time = ttyMsgTime now tz time =
@ -1458,9 +1459,9 @@ viewSentMessage to quote mc ts tz meta@CIMeta {itemEdited, itemDeleted, itemLive
live live
| itemEdited || isJust itemDeleted = "" | itemEdited || isJust itemDeleted = ""
| otherwise = case itemLive of | otherwise = case itemLive of
Just True -> ttyTo "[LIVE started] " Just True -> ttyTo "[LIVE started] "
Just False -> ttyTo "[LIVE] " Just False -> ttyTo "[LIVE] "
_ -> "" _ -> ""
viewSentBroadcast :: MsgContent -> Int -> Int -> CurrentTime -> TimeZone -> UTCTime -> [StyledString] viewSentBroadcast :: MsgContent -> Int -> Int -> CurrentTime -> TimeZone -> UTCTime -> [StyledString]
viewSentBroadcast mc s f ts tz time = prependFirst (highlight' "/feed" <> " (" <> sShow s <> failures <> ") " <> ttyMsgTime ts tz time <> " ") (ttyMsgContent mc) viewSentBroadcast mc s f ts tz time = prependFirst (highlight' "/feed" <> " (" <> sShow s <> failures <> ") " <> ttyMsgTime ts tz time <> " ") (ttyMsgContent mc)
@ -1551,11 +1552,12 @@ receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = Just CIF
cfArgsStr (Just cfArgs) = [plain (cryptoFileArgsStr testView cfArgs) | status == "completed"] cfArgsStr (Just cfArgs) = [plain (cryptoFileArgsStr testView cfArgs) | status == "completed"]
cfArgsStr _ = [] cfArgsStr _ = []
getRemoteFileStr = case hu of getRemoteFileStr = case hu of
(Just rhId, Just User {userId}) | status == "completed" -> (Just rhId, Just User {userId})
[ "File received to connected remote host " <> sShow rhId, | status == "completed" ->
"To download to this device use:", [ "File received to connected remote host " <> sShow rhId,
highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f})) "To download to this device use:",
] highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f}))
]
_ -> [] _ -> []
receivingFile_' _ _ status _ = [plain status <> " receiving file"] -- shouldn't happen receivingFile_' _ _ status _ = [plain status <> " receiving file"] -- shouldn't happen
@ -1591,7 +1593,7 @@ viewFileTransferStatus (FTSnd FileTransferMeta {cancelled} fts@(ft : _), chunksN
[recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus] [recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus]
recipientsStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) recipientsStatuses recipientsStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) recipientsStatuses
fs :: SndFileTransfer -> FileStatus fs :: SndFileTransfer -> FileStatus
fs SndFileTransfer{fileStatus} = fileStatus fs SndFileTransfer {fileStatus} = fileStatus
recipientsTransferStatus [] = [] recipientsTransferStatus [] = []
recipientsTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listRecipients ts] recipientsTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listRecipients ts]
where where
@ -1763,9 +1765,10 @@ viewChatError logLevel testView = \case
CEEmptyUserPassword _ -> ["user password is required"] CEEmptyUserPassword _ -> ["user password is required"]
CEUserAlreadyHidden _ -> ["user is already hidden"] CEUserAlreadyHidden _ -> ["user is already hidden"]
CEUserNotHidden _ -> ["user is not hidden"] CEUserNotHidden _ -> ["user is not hidden"]
CEInvalidDisplayName {displayName, validName} -> map plain $ CEInvalidDisplayName {displayName, validName} ->
["invalid display name: " <> viewName displayName] map plain $
<> ["you could use this one: " <> viewName validName | not (T.null validName)] ["invalid display name: " <> viewName displayName]
<> ["you could use this one: " <> viewName validName | not (T.null validName)]
CEChatNotStarted -> ["error: chat not started"] CEChatNotStarted -> ["error: chat not started"]
CEChatNotStopped -> ["error: chat not stopped"] CEChatNotStopped -> ["error: chat not stopped"]
CEChatStoreChanged -> ["error: chat store changed, please restart chat"] CEChatStoreChanged -> ["error: chat store changed, please restart chat"]

3
tests/ChatClient.hs
View file

@ -5,7 +5,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module ChatClient where module ChatClient where
@ -276,7 +275,7 @@ getTermLine cc =
Just s -> do Just s -> do
-- remove condition to always echo virtual terminal -- remove condition to always echo virtual terminal
when (printOutput cc) $ do when (printOutput cc) $ do
-- when True $ do -- when True $ do
name <- userName cc name <- userName cc
putStrLn $ name <> ": " <> s putStrLn $ name <> ": " <> s
pure s pure s

39
tests/ChatTests/Direct.hs
View file

@ -259,7 +259,6 @@ testPlanInvitationLinkOk =
bob ##> ("/_connect plan 1 " <> inv) bob ##> ("/_connect plan 1 " <> inv)
bob <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection bob <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
alice <##> bob alice <##> bob
testPlanInvitationLinkOwn :: HasCallStack => FilePath -> IO () testPlanInvitationLinkOwn :: HasCallStack => FilePath -> IO ()
@ -283,7 +282,6 @@ testPlanInvitationLinkOwn tmp =
alice ##> ("/_connect plan 1 " <> inv) alice ##> ("/_connect plan 1 " <> inv)
alice <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection alice <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
alice @@@ [("@alice_1", lastChatFeature), ("@alice_2", lastChatFeature)] alice @@@ [("@alice_1", lastChatFeature), ("@alice_2", lastChatFeature)]
alice `send` "@alice_2 hi" alice `send` "@alice_2 hi"
alice alice
@ -1213,31 +1211,34 @@ testMuteGroup =
cath `send` "> #team (hello) hello too!" cath `send` "> #team (hello) hello too!"
cath <# "#team > bob hello" cath <# "#team > bob hello"
cath <## " hello too!" cath <## " hello too!"
concurrently_ concurrentlyN_
(bob </) [ (bob </),
( do alice <# "#team cath> > bob hello" do
alice <## " hello too!" alice <# "#team cath> > bob hello"
) alice <## " hello too!"
]
bob ##> "/unmute mentions #team" bob ##> "/unmute mentions #team"
bob <## "ok" bob <## "ok"
alice `send` "> #team @bob (hello) hey bob!" alice `send` "> #team @bob (hello) hey bob!"
alice <# "#team > bob hello" alice <# "#team > bob hello"
alice <## " hey bob!" alice <## " hey bob!"
concurrently_ concurrentlyN_
( do bob <# "#team alice> > bob hello" [ do
bob <## " hey bob!" bob <# "#team alice> > bob hello"
) bob <## " hey bob!",
( do cath <# "#team alice> > bob hello" do
cath <## " hey bob!" cath <# "#team alice> > bob hello"
) cath <## " hey bob!"
]
alice `send` "> #team @cath (hello) hey cath!" alice `send` "> #team @cath (hello) hey cath!"
alice <# "#team > cath hello too!" alice <# "#team > cath hello too!"
alice <## " hey cath!" alice <## " hey cath!"
concurrently_ concurrentlyN_
(bob </) [ (bob </),
( do cath <# "#team alice> > cath hello too!" do
cath <## " hey cath!" cath <# "#team alice> > cath hello too!"
) cath <## " hey cath!"
]
bob ##> "/gs" bob ##> "/gs"
bob <## "#team (3 members, mentions only, you can /unmute #team)" bob <## "#team (3 members, mentions only, you can /unmute #team)"
bob ##> "/unmute #team" bob ##> "/unmute #team"

1
tests/ChatTests/Files.hs
View file

@ -1,7 +1,6 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PostfixOperators #-} {-# LANGUAGE PostfixOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module ChatTests.Files where module ChatTests.Files where

23
tests/ChatTests/Groups.hs
View file

@ -7,7 +7,7 @@ import ChatClient
import ChatTests.Utils import ChatTests.Utils
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_) import Control.Concurrent.Async (concurrently_)
import Control.Monad (when, void) import Control.Monad (void, when)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import Data.List (isInfixOf) import Data.List (isInfixOf)
import qualified Data.Text as T import qualified Data.Text as T
@ -122,7 +122,8 @@ chatGroupTests = do
-- because host uses current code and sends version in MemberInfo -- because host uses current code and sends version in MemberInfo
testNoDirect vrMem2 vrMem3 noConns = testNoDirect vrMem2 vrMem3 noConns =
it it
( "host " <> vRangeStr supportedChatVRange ( "host "
<> vRangeStr supportedChatVRange
<> (", 2nd mem " <> vRangeStr vrMem2) <> (", 2nd mem " <> vRangeStr vrMem2)
<> (", 3rd mem " <> vRangeStr vrMem3) <> (", 3rd mem " <> vRangeStr vrMem3)
<> (if noConns then " : 2 <!!> 3" else " : 2 <##> 3") <> (if noConns then " : 2 <!!> 3" else " : 2 <##> 3")
@ -3859,11 +3860,9 @@ testMemberContactProfileUpdate =
bob #> "#team hello too" bob #> "#team hello too"
alice <# "#team rob> hello too" alice <# "#team rob> hello too"
cath <# "#team bob> hello too" -- not updated profile cath <# "#team bob> hello too" -- not updated profile
cath #> "#team hello there" cath #> "#team hello there"
alice <# "#team kate> hello there" alice <# "#team kate> hello there"
bob <# "#team cath> hello there" -- not updated profile bob <# "#team cath> hello there" -- not updated profile
bob `send` "@cath hi" bob `send` "@cath hi"
bob bob
<### [ "member #team cath does not have direct connection, creating", <### [ "member #team cath does not have direct connection, creating",
@ -3903,7 +3902,6 @@ testMemberContactProfileUpdate =
bob #> "#team hello too" bob #> "#team hello too"
alice <# "#team rob> hello too" alice <# "#team rob> hello too"
cath <# "#team rob> hello too" -- updated profile cath <# "#team rob> hello too" -- updated profile
cath #> "#team hello there" cath #> "#team hello there"
alice <# "#team kate> hello there" alice <# "#team kate> hello there"
bob <# "#team kate> hello there" -- updated profile bob <# "#team kate> hello there" -- updated profile
@ -3911,7 +3909,7 @@ testMemberContactProfileUpdate =
testGroupMsgForward :: HasCallStack => FilePath -> IO () testGroupMsgForward :: HasCallStack => FilePath -> IO ()
testGroupMsgForward = testGroupMsgForward =
testChat3 aliceProfile bobProfile cathProfile $ testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do \alice bob cath -> do
setupGroupForwarding3 "team" alice bob cath setupGroupForwarding3 "team" alice bob cath
bob #> "#team hi there" bob #> "#team hi there"
@ -3941,7 +3939,6 @@ setupGroupForwarding3 gName alice bob cath = do
createGroup3 gName alice bob cath createGroup3 gName alice bob cath
threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected
void $ withCCTransaction bob $ \db -> void $ withCCTransaction bob $ \db ->
DB.execute_ db "UPDATE connections SET conn_status='deleted' WHERE group_member_id = 3" DB.execute_ db "UPDATE connections SET conn_status='deleted' WHERE group_member_id = 3"
void $ withCCTransaction cath $ \db -> void $ withCCTransaction cath $ \db ->
@ -3956,7 +3953,6 @@ testGroupMsgForwardDeduplicate =
createGroup3 "team" alice bob cath createGroup3 "team" alice bob cath
threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected
void $ withCCTransaction alice $ \db -> void $ withCCTransaction alice $ \db ->
DB.execute_ db "UPDATE group_member_intros SET intro_status='fwd'" DB.execute_ db "UPDATE group_member_intros SET intro_status='fwd'"
@ -3990,7 +3986,7 @@ testGroupMsgForwardDeduplicate =
testGroupMsgForwardEdit :: HasCallStack => FilePath -> IO () testGroupMsgForwardEdit :: HasCallStack => FilePath -> IO ()
testGroupMsgForwardEdit = testGroupMsgForwardEdit =
testChat3 aliceProfile bobProfile cathProfile $ testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do \alice bob cath -> do
setupGroupForwarding3 "team" alice bob cath setupGroupForwarding3 "team" alice bob cath
bob #> "#team hi there" bob #> "#team hi there"
@ -4001,7 +3997,6 @@ testGroupMsgForwardEdit =
bob <# "#team [edited] hello there" bob <# "#team [edited] hello there"
alice <# "#team bob> [edited] hello there" alice <# "#team bob> [edited] hello there"
cath <# "#team bob> [edited] hello there" -- TODO show as forwarded cath <# "#team bob> [edited] hello there" -- TODO show as forwarded
alice ##> "/tail #team 1" alice ##> "/tail #team 1"
alice <# "#team bob> hello there" alice <# "#team bob> hello there"
@ -4014,7 +4009,7 @@ testGroupMsgForwardEdit =
testGroupMsgForwardReaction :: HasCallStack => FilePath -> IO () testGroupMsgForwardReaction :: HasCallStack => FilePath -> IO ()
testGroupMsgForwardReaction = testGroupMsgForwardReaction =
testChat3 aliceProfile bobProfile cathProfile $ testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do \alice bob cath -> do
setupGroupForwarding3 "team" alice bob cath setupGroupForwarding3 "team" alice bob cath
bob #> "#team hi there" bob #> "#team hi there"
@ -4031,7 +4026,7 @@ testGroupMsgForwardReaction =
testGroupMsgForwardDeletion :: HasCallStack => FilePath -> IO () testGroupMsgForwardDeletion :: HasCallStack => FilePath -> IO ()
testGroupMsgForwardDeletion = testGroupMsgForwardDeletion =
testChat3 aliceProfile bobProfile cathProfile $ testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do \alice bob cath -> do
setupGroupForwarding3 "team" alice bob cath setupGroupForwarding3 "team" alice bob cath
bob #> "#team hi there" bob #> "#team hi there"
@ -4073,7 +4068,7 @@ testGroupMsgForwardFile =
testGroupMsgForwardChangeRole :: HasCallStack => FilePath -> IO () testGroupMsgForwardChangeRole :: HasCallStack => FilePath -> IO ()
testGroupMsgForwardChangeRole = testGroupMsgForwardChangeRole =
testChat3 aliceProfile bobProfile cathProfile $ testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do \alice bob cath -> do
setupGroupForwarding3 "team" alice bob cath setupGroupForwarding3 "team" alice bob cath
cath ##> "/mr #team bob member" cath ##> "/mr #team bob member"
@ -4084,7 +4079,7 @@ testGroupMsgForwardChangeRole =
testGroupMsgForwardNewMember :: HasCallStack => FilePath -> IO () testGroupMsgForwardNewMember :: HasCallStack => FilePath -> IO ()
testGroupMsgForwardNewMember = testGroupMsgForwardNewMember =
testChat4 aliceProfile bobProfile cathProfile danProfile $ testChat4 aliceProfile bobProfile cathProfile danProfile $
\alice bob cath dan -> do \alice bob cath dan -> do
setupGroupForwarding3 "team" alice bob cath setupGroupForwarding3 "team" alice bob cath
connectUsers cath dan connectUsers cath dan

8
tests/ChatTests/Profiles.hs
View file

@ -7,16 +7,16 @@ import ChatClient
import ChatTests.Utils import ChatTests.Utils
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_) import Control.Concurrent.Async (concurrently_)
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T import qualified Data.Text as T
import Simplex.Chat.Store.Shared (createContact)
import Simplex.Chat.Types (ConnStatus (..), GroupMemberRole (..), Profile (..)) import Simplex.Chat.Types (ConnStatus (..), GroupMemberRole (..), Profile (..))
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import System.Directory (copyFile, createDirectoryIfMissing) import System.Directory (copyFile, createDirectoryIfMissing)
import Test.Hspec import Test.Hspec
import Simplex.Chat.Store.Shared (createContact)
import Control.Monad
import Simplex.Messaging.Encoding.String (StrEncoding(..))
chatProfileTests :: SpecWith FilePath chatProfileTests :: SpecWith FilePath
chatProfileTests = do chatProfileTests = do
@ -633,7 +633,7 @@ testPlanAddressOwn tmp =
alice <## "alice_1 (Alice) wants to connect to you!" alice <## "alice_1 (Alice) wants to connect to you!"
alice <## "to accept: /ac alice_1" alice <## "to accept: /ac alice_1"
alice <## "to reject: /rc alice_1 (the sender will NOT be notified)" alice <## "to reject: /rc alice_1 (the sender will NOT be notified)"
alice @@@ [("<@alice_1", ""), (":2","")] alice @@@ [("<@alice_1", ""), (":2", "")]
alice ##> "/ac alice_1" alice ##> "/ac alice_1"
alice <## "alice_1 (Alice): accepting contact request..." alice <## "alice_1 (Alice): accepting contact request..."
alice alice

6
tests/ChatTests/Utils.hs
View file

@ -310,7 +310,7 @@ getInAnyOrder f cc ls = do
Predicate p -> p l Predicate p -> p l
filterFirst :: (a -> Bool) -> [a] -> [a] filterFirst :: (a -> Bool) -> [a] -> [a]
filterFirst _ [] = [] filterFirst _ [] = []
filterFirst p (x:xs) filterFirst p (x : xs)
| p x = xs | p x = xs
| otherwise = x : filterFirst p xs | otherwise = x : filterFirst p xs
@ -593,7 +593,7 @@ vRangeStr (VersionRange minVer maxVer) = "(" <> show minVer <> ", " <> show maxV
linkAnotherSchema :: String -> String linkAnotherSchema :: String -> String
linkAnotherSchema link linkAnotherSchema link
| "https://simplex.chat/" `isPrefixOf` link = | "https://simplex.chat/" `isPrefixOf` link =
T.unpack $ T.replace "https://simplex.chat/" "simplex:/" $ T.pack link T.unpack $ T.replace "https://simplex.chat/" "simplex:/" $ T.pack link
| "simplex:/" `isPrefixOf` link = | "simplex:/" `isPrefixOf` link =
T.unpack $ T.replace "simplex:/" "https://simplex.chat/" $ T.pack link T.unpack $ T.replace "simplex:/" "https://simplex.chat/" $ T.pack link
| otherwise = error "link starts with neither https://simplex.chat/ nor simplex:/" | otherwise = error "link starts with neither https://simplex.chat/ nor simplex:/"

2
tests/Test.hs
View file

@ -13,8 +13,8 @@ import RemoteTests
import SchemaDump import SchemaDump
import Test.Hspec import Test.Hspec
import UnliftIO.Temporary (withTempDirectory) import UnliftIO.Temporary (withTempDirectory)
import ViewTests
import ValidNames import ValidNames
import ViewTests
import WebRTCTests import WebRTCTests
main :: IO () main :: IO ()