android-apps-mirrors/SimpleX-Chat
0
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-06-29 04:39:53 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

core: profile names with spaces (#3105)

Browse source 
* core: profile names with spaces

* test

* more test

* update name validation, export C API

* refactor

* validate name when creating profile in CLI

* validate display name in all APIs when it is changed
This commit is contained in:
Evgeny Poberezkin 2023-10-02 21:56:11 +01:00 • committed by GitHub
parent da2a94578a
commit 38be27271f
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
10 changed files with 237 additions and 82 deletions
Download patch file Download diff file Expand all files Collapse all files

1
simplex-chat.cabal
View file

@ -456,6 +456,7 @@ test-suite simplex-chat-test
MobileTests MobileTests
ProtocolTests ProtocolTests
SchemaDump SchemaDump
ValidNames
ViewTests ViewTests
WebRTCTests WebRTCTests
Broadcast.Bot Broadcast.Bot

52
src/Simplex/Chat.hs
View file

@ -32,7 +32,7 @@ import Data.Bifunctor (bimap, first)
import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import Data.Char (isSpace, toLower) import Data.Char
import Data.Constraint (Dict (..)) import Data.Constraint (Dict (..))
import Data.Either (fromRight, rights) import Data.Either (fromRight, rights)
import Data.Fixed (div') import Data.Fixed (div')
@ -359,6 +359,7 @@ processChatCommand :: forall m. ChatMonad m => ChatCommand -> m ChatResponse
processChatCommand = \case processChatCommand = \case
ShowActiveUser -> withUser' $ pure . CRActiveUser ShowActiveUser -> withUser' $ pure . CRActiveUser
CreateActiveUser NewUser {profile, sameServers, pastTimestamp} -> do CreateActiveUser NewUser {profile, sameServers, pastTimestamp} -> do
forM_ profile $ \Profile {displayName} -> checkValidName displayName
p@Profile {displayName} <- liftIO $ maybe generateRandomProfile pure profile p@Profile {displayName} <- liftIO $ maybe generateRandomProfile pure profile
u <- asks currentUser u <- asks currentUser
(smp, smpServers) <- chooseServers SPSMP (smp, smpServers) <- chooseServers SPSMP
@ -1457,7 +1458,8 @@ processChatCommand = \case
chatRef <- getChatRef user chatName chatRef <- getChatRef user chatName
chatItemId <- getChatItemIdByText user chatRef msg chatItemId <- getChatItemIdByText user chatRef msg
processChatCommand $ APIChatItemReaction chatRef chatItemId add reaction processChatCommand $ APIChatItemReaction chatRef chatItemId add reaction
APINewGroup userId gProfile -> withUserId userId $ \user -> do APINewGroup userId gProfile@GroupProfile {displayName} -> withUserId userId $ \user -> do
checkValidName displayName
gVar <- asks idsDrg gVar <- asks idsDrg
groupInfo <- withStore $ \db -> createNewGroup db gVar user gProfile groupInfo <- withStore $ \db -> createNewGroup db gVar user gProfile
pure $ CRGroupCreated user groupInfo pure $ CRGroupCreated user groupInfo
@ -1962,9 +1964,10 @@ processChatCommand = \case
updateProfile :: User -> Profile -> m ChatResponse updateProfile :: User -> Profile -> m ChatResponse
updateProfile user p' = updateProfile_ user p' $ withStore $ \db -> updateUserProfile db user p' updateProfile user p' = updateProfile_ user p' $ withStore $ \db -> updateUserProfile db user p'
updateProfile_ :: User -> Profile -> m User -> m ChatResponse updateProfile_ :: User -> Profile -> m User -> m ChatResponse
updateProfile_ user@User {profile = p} p' updateUser updateProfile_ user@User {profile = p@LocalProfile {displayName = n}} p'@Profile {displayName = n'} updateUser
| p' == fromLocalProfile p = pure $ CRUserProfileNoChange user | p' == fromLocalProfile p = pure $ CRUserProfileNoChange user
| otherwise = do | otherwise = do
when (n /= n') $ checkValidName n'
-- read contacts before user update to correctly merge preferences -- read contacts before user update to correctly merge preferences
-- [incognito] filter out contacts with whom user has incognito connections -- [incognito] filter out contacts with whom user has incognito connections
contacts <- contacts <-
@ -2006,8 +2009,9 @@ processChatCommand = \case
when (directOrUsed ct') $ createSndFeatureItems user ct ct' when (directOrUsed ct') $ createSndFeatureItems user ct ct'
pure $ CRContactPrefsUpdated user ct ct' pure $ CRContactPrefsUpdated user ct ct'
runUpdateGroupProfile :: User -> Group -> GroupProfile -> m ChatResponse runUpdateGroupProfile :: User -> Group -> GroupProfile -> m ChatResponse
runUpdateGroupProfile user (Group g@GroupInfo {groupProfile = p} ms) p' = do runUpdateGroupProfile user (Group g@GroupInfo {groupProfile = p@GroupProfile {displayName = n}} ms) p'@GroupProfile {displayName = n'} = do
assertUserGroupRole g GROwner assertUserGroupRole g GROwner
when (n /= n') $ checkValidName n'
g' <- withStore $ \db -> updateGroupProfile db user g p' g' <- withStore $ \db -> updateGroupProfile db user g p'
(msg, _) <- sendGroupMessage user g' ms (XGrpInfo p') (msg, _) <- sendGroupMessage user g' ms (XGrpInfo p')
let cd = CDGroupSnd g' let cd = CDGroupSnd g'
@ -2016,6 +2020,10 @@ processChatCommand = \case
toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat g') ci) toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat g') ci)
createGroupFeatureChangedItems user cd CISndGroupFeature g g' createGroupFeatureChangedItems user cd CISndGroupFeature g g'
pure $ CRGroupUpdated user g g' Nothing pure $ CRGroupUpdated user g g' Nothing
checkValidName :: GroupName -> m ()
checkValidName displayName = do
let validName = T.pack $ mkValidName $ T.unpack displayName
when (displayName /= validName) $ throwChatError CEInvalidDisplayName {displayName, validName}
assertUserGroupRole :: GroupInfo -> GroupMemberRole -> m () assertUserGroupRole :: GroupInfo -> GroupMemberRole -> m ()
assertUserGroupRole g@GroupInfo {membership} requiredRole = do assertUserGroupRole g@GroupInfo {membership} requiredRole = do
when (membership.memberRole < requiredRole) $ throwChatError $ CEGroupUserRole g requiredRole when (membership.memberRole < requiredRole) $ throwChatError $ CEGroupUserRole g requiredRole
@ -5245,8 +5253,7 @@ getCreateActiveUser st testView = do
where where
loop = do loop = do
displayName <- getContactName displayName <- getContactName
fullName <- T.pack <$> getWithPrompt "full name (optional)" withTransaction st (\db -> runExceptT $ createUserRecord db (AgentUserId 1) Profile {displayName, fullName = "", image = Nothing, contactLink = Nothing, preferences = Nothing} True) >>= \case
withTransaction st (\db -> runExceptT $ createUserRecord db (AgentUserId 1) Profile {displayName, fullName, image = Nothing, contactLink = Nothing, preferences = Nothing} True) >>= \case
Left SEDuplicateName -> do Left SEDuplicateName -> do
putStrLn "chosen display name is already used by another profile on this device, choose another one" putStrLn "chosen display name is already used by another profile on this device, choose another one"
loop loop
@ -5276,10 +5283,13 @@ getCreateActiveUser st testView = do
T.unpack $ localDisplayName <> if T.null fullName || localDisplayName == fullName then "" else " (" <> fullName <> ")" T.unpack $ localDisplayName <> if T.null fullName || localDisplayName == fullName then "" else " (" <> fullName <> ")"
getContactName :: IO ContactName getContactName :: IO ContactName
getContactName = do getContactName = do
displayName <- getWithPrompt "display name (no spaces)" displayName <- getWithPrompt "display name"
if null displayName || isJust (find (== ' ') displayName) let validName = mkValidName displayName
then putStrLn "display name has space(s), choose another one" >> getContactName if
else pure $ T.pack displayName | null displayName -> putStrLn "display name can't be empty" >> getContactName
| null validName -> putStrLn "display name is invalid, please choose another" >> getContactName
| displayName /= validName -> putStrLn ("display name is invalid, you could use this one: " <> validName) >> getContactName
| otherwise -> pure $ T.pack displayName
getWithPrompt :: String -> IO String getWithPrompt :: String -> IO String
getWithPrompt s = putStr (s <> ": ") >> hFlush stdout >> getLine getWithPrompt s = putStr (s <> ": ") >> hFlush stdout >> getLine
@ -5610,7 +5620,13 @@ chatCommandP =
mcTextP = MCText . safeDecodeUtf8 <$> A.takeByteString mcTextP = MCText . safeDecodeUtf8 <$> A.takeByteString
msgContentP = "text " *> mcTextP <|> "json " *> jsonP msgContentP = "text " *> mcTextP <|> "json " *> jsonP
ciDeleteMode = "broadcast" $> CIDMBroadcast <|> "internal" $> CIDMInternal ciDeleteMode = "broadcast" $> CIDMBroadcast <|> "internal" $> CIDMInternal
displayName = safeDecodeUtf8 <$> (B.cons <$> A.satisfy refChar <*> A.takeTill (== ' ')) displayName = safeDecodeUtf8 <$> (quoted "'\"" <|> takeNameTill isSpace)
where
takeNameTill p =
A.peekChar' >>= \c ->
if refChar c then A.takeTill p else fail "invalid first character in display name"
quoted cs = A.choice [A.char c *> takeNameTill (== c) <* A.char c | c <- cs]
refChar c = c > ' ' && c /= '#' && c /= '@'
sendMsgQuote msgDir = SendMessageQuote <$> displayName <* A.space <*> pure msgDir <*> quotedMsg <*> msgTextP sendMsgQuote msgDir = SendMessageQuote <$> displayName <* A.space <*> pure msgDir <*> quotedMsg <*> msgTextP
quotedMsg = safeDecodeUtf8 <$> (A.char '(' *> A.takeTill (== ')') <* A.char ')') <* optional A.space quotedMsg = safeDecodeUtf8 <$> (A.char '(' *> A.takeTill (== ')') <* A.char ')') <* optional A.space
reactionP = MREmoji <$> (mrEmojiChar <$?> (toEmoji <$> A.anyChar)) reactionP = MREmoji <$> (mrEmojiChar <$?> (toEmoji <$> A.anyChar))
@ -5623,7 +5639,6 @@ chatCommandP =
'*' -> head "❤️" '*' -> head "❤️"
'^' -> '🚀' '^' -> '🚀'
c -> c c -> c
refChar c = c > ' ' && c /= '#' && c /= '@'
liveMessageP = " live=" *> onOffP <|> pure False liveMessageP = " live=" *> onOffP <|> pure False
sendMessageTTLP = " ttl=" *> ((Just <$> A.decimal) <|> ("default" $> Nothing)) <|> pure Nothing sendMessageTTLP = " ttl=" *> ((Just <$> A.decimal) <|> ("default" $> Nothing)) <|> pure Nothing
receiptSettings = do receiptSettings = do
@ -5718,3 +5733,16 @@ timeItToView s action = do
let diff = diffToMilliseconds $ diffUTCTime t2 t1 let diff = diffToMilliseconds $ diffUTCTime t2 t1
toView $ CRTimedAction s diff toView $ CRTimedAction s diff
pure a pure a
mkValidName :: String -> String
mkValidName = reverse . dropWhile isSpace . fst . foldl' addChar ("", '\NUL')
where
addChar (r, prev) c = if notProhibited && validChar then (c' : r, c') else (r, prev)
where
c' = if isSpace c then ' ' else c
validChar
| prev == '\NUL' || isSpace prev = validFirstChar
| isPunctuation prev = validFirstChar || isSpace c
| otherwise = validFirstChar || isSpace c || isMark c || isPunctuation c
validFirstChar = isLetter c || isNumber c || isSymbol c
notProhibited = c `notElem` ("@#'\"`" :: String)

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

@ -882,6 +882,7 @@ data ChatErrorType
| CEEmptyUserPassword {userId :: UserId} | CEEmptyUserPassword {userId :: UserId}
| CEUserAlreadyHidden {userId :: UserId} | CEUserAlreadyHidden {userId :: UserId}
| CEUserNotHidden {userId :: UserId} | CEUserNotHidden {userId :: UserId}
| CEInvalidDisplayName {displayName :: Text, validName :: Text}
| CEChatNotStarted | CEChatNotStarted
| CEChatNotStopped | CEChatNotStopped
| CEChatStoreChanged | CEChatStoreChanged

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

@ -65,6 +65,8 @@ foreign export ccall "chat_parse_server" cChatParseServer :: CString -> IO CJSON
foreign export ccall "chat_password_hash" cChatPasswordHash :: CString -> CString -> IO CString foreign export ccall "chat_password_hash" cChatPasswordHash :: CString -> CString -> IO CString
foreign export ccall "chat_valid_name" cChatValidName :: CString -> IO CString
foreign export ccall "chat_encrypt_media" cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString foreign export ccall "chat_encrypt_media" cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
foreign export ccall "chat_decrypt_media" cChatDecryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString foreign export ccall "chat_decrypt_media" cChatDecryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
@ -124,6 +126,10 @@ cChatPasswordHash cPwd cSalt = do
salt <- B.packCString cSalt salt <- B.packCString cSalt
newCStringFromBS $ chatPasswordHash pwd salt newCStringFromBS $ chatPasswordHash pwd salt
-- This function supports utf8 strings
cChatValidName :: CString -> IO CString
cChatValidName cName = newCString . mkValidName =<< peekCString cName
mobileChatOpts :: String -> String -> ChatOpts mobileChatOpts :: String -> String -> ChatOpts
mobileChatOpts dbFilePrefix dbKey = mobileChatOpts dbFilePrefix dbKey =
ChatOpts ChatOpts

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

@ -15,7 +15,7 @@ import Data.Aeson (ToJSON)
import qualified Data.Aeson as J import qualified Data.Aeson as J
import qualified Data.ByteString.Char8 as B 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 (toUpper) import Data.Char (isSpace, toUpper)
import Data.Function (on) import Data.Function (on)
import Data.Int (Int64) import Data.Int (Int64)
import Data.List (groupBy, intercalate, intersperse, partition, sortOn) import Data.List (groupBy, intercalate, intersperse, partition, sortOn)
@ -224,7 +224,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
CRLeftMember u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " left the group"] CRLeftMember u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " left the group"]
CRGroupEmpty u g -> ttyUser u [ttyFullGroup g <> ": group is empty"] CRGroupEmpty u g -> ttyUser u [ttyFullGroup g <> ": group is empty"]
CRGroupRemoved u g -> ttyUser u [ttyFullGroup g <> ": you are no longer a member or group deleted"] CRGroupRemoved u g -> ttyUser u [ttyFullGroup g <> ": you are no longer a member or group deleted"]
CRGroupDeleted u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> groupName' g) <> " to delete the local copy of the group"] CRGroupDeleted u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the local copy of the group"]
CRGroupUpdated u g g' m -> ttyUser u $ viewGroupUpdated g g' m CRGroupUpdated u g g' m -> ttyUser u $ viewGroupUpdated g g' m
CRGroupProfile u g -> ttyUser u $ viewGroupProfile g CRGroupProfile u g -> ttyUser u $ viewGroupProfile g
CRGroupDescription u g -> ttyUser u $ viewGroupDescription g CRGroupDescription u g -> ttyUser u $ viewGroupDescription g
@ -674,10 +674,7 @@ viewContactNotFound cName suspectedMember =
["no contact " <> ttyContact cName <> useMessageMember] ["no contact " <> ttyContact cName <> useMessageMember]
where where
useMessageMember = case suspectedMember of useMessageMember = case suspectedMember of
Just (g, m) -> do Just (g, m) -> ", use " <> highlight ("@#" <> viewGroupName g <> " " <> viewMemberName m <> " <your message>")
let GroupInfo {localDisplayName = gName} = g
GroupMember {localDisplayName = mName} = m
", use " <> highlight' ("@#" <> T.unpack gName <> " " <> T.unpack mName <> " <your message>")
_ -> "" _ -> ""
viewChatCleared :: AChatInfo -> [StyledString] viewChatCleared :: AChatInfo -> [StyledString]
@ -732,14 +729,14 @@ groupLink_ intro g cReq mRole =
(plain . strEncode) cReq, (plain . strEncode) cReq,
"", "",
"Anybody can connect to you and join group as " <> showRole mRole <> " with: " <> highlight' "/c <group_link_above>", "Anybody can connect to you and join group as " <> showRole mRole <> " with: " <> highlight' "/c <group_link_above>",
"to show it again: " <> highlight ("/show link #" <> groupName' g), "to show it again: " <> highlight ("/show link #" <> viewGroupName g),
"to delete it: " <> highlight ("/delete link #" <> groupName' g) <> " (joined members will remain connected to you)" "to delete it: " <> highlight ("/delete link #" <> viewGroupName g) <> " (joined members will remain connected to you)"
] ]
viewGroupLinkDeleted :: GroupInfo -> [StyledString] viewGroupLinkDeleted :: GroupInfo -> [StyledString]
viewGroupLinkDeleted g = viewGroupLinkDeleted g =
[ "Group link is deleted - joined members will remain connected.", [ "Group link is deleted - joined members will remain connected.",
"To create a new group link use " <> highlight ("/create link #" <> groupName' g) "To create a new group link use " <> highlight ("/create link #" <> viewGroupName g)
] ]
viewSentInvitation :: Maybe Profile -> Bool -> [StyledString] viewSentInvitation :: Maybe Profile -> Bool -> [StyledString]
@ -756,20 +753,20 @@ viewSentInvitation incognitoProfile testView =
viewReceivedContactRequest :: ContactName -> Profile -> [StyledString] viewReceivedContactRequest :: ContactName -> Profile -> [StyledString]
viewReceivedContactRequest c Profile {fullName} = viewReceivedContactRequest c Profile {fullName} =
[ ttyFullName c fullName <> " wants to connect to you!", [ ttyFullName c fullName <> " wants to connect to you!",
"to accept: " <> highlight ("/ac " <> c), "to accept: " <> highlight ("/ac " <> viewName c),
"to reject: " <> highlight ("/rc " <> c) <> " (the sender will NOT be notified)" "to reject: " <> highlight ("/rc " <> viewName c) <> " (the sender will NOT be notified)"
] ]
viewGroupCreated :: GroupInfo -> [StyledString] viewGroupCreated :: GroupInfo -> [StyledString]
viewGroupCreated g@GroupInfo {localDisplayName = n} = viewGroupCreated g =
[ "group " <> ttyFullGroup g <> " is created", [ "group " <> ttyFullGroup g <> " is created",
"to add members use " <> highlight ("/a " <> n <> " <name>") <> " or " <> highlight ("/create link #" <> n) "to add members use " <> highlight ("/a " <> viewGroupName g <> " <name>") <> " or " <> highlight ("/create link #" <> viewGroupName g)
] ]
viewCannotResendInvitation :: GroupInfo -> ContactName -> [StyledString] viewCannotResendInvitation :: GroupInfo -> ContactName -> [StyledString]
viewCannotResendInvitation GroupInfo {localDisplayName = gn} c = viewCannotResendInvitation g c =
[ ttyContact c <> " is already invited to group " <> ttyGroup gn, [ ttyContact c <> " is already invited to group " <> ttyGroup' g,
"to re-send invitation: " <> highlight ("/rm " <> gn <> " " <> c) <> ", " <> highlight ("/a " <> gn <> " " <> c) "to re-send invitation: " <> highlight ("/rm " <> viewGroupName g <> " " <> c) <> ", " <> highlight ("/a " <> viewGroupName g <> " " <> viewName c)
] ]
viewDirectMessagesProhibited :: MsgDirection -> Contact -> [StyledString] viewDirectMessagesProhibited :: MsgDirection -> Contact -> [StyledString]
@ -790,11 +787,11 @@ viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [Style
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 " <> groupName' 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 " <> groupName' g) <> " to accept"] Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"]
groupPreserved :: GroupInfo -> [StyledString] groupPreserved :: GroupInfo -> [StyledString]
groupPreserved g = ["use " <> highlight ("/d #" <> groupName' g) <> " to delete the group"] groupPreserved g = ["use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the group"]
connectedMember :: GroupMember -> StyledString connectedMember :: GroupMember -> StyledString
connectedMember m = case memberCategory m of connectedMember m = case memberCategory m of
@ -845,7 +842,7 @@ viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filt
_ -> "" _ -> ""
viewContactConnected :: Contact -> Maybe Profile -> Bool -> [StyledString] viewContactConnected :: Contact -> Maybe Profile -> Bool -> [StyledString]
viewContactConnected ct@Contact {localDisplayName} userIncognitoProfile testView = viewContactConnected ct userIncognitoProfile testView =
case userIncognitoProfile of case userIncognitoProfile of
Just profile -> Just profile ->
if testView if testView
@ -854,7 +851,7 @@ viewContactConnected ct@Contact {localDisplayName} userIncognitoProfile testView
where where
message = message =
[ ttyFullContact ct <> ": contact is connected, your incognito profile for this contact is " <> incognitoProfile' profile, [ ttyFullContact ct <> ": contact is connected, your incognito profile for this contact is " <> incognitoProfile' profile,
"use " <> highlight ("/i " <> localDisplayName) <> " to print out this incognito profile again" "use " <> highlight ("/i " <> viewContactName ct) <> " to print out this incognito profile again"
] ]
Nothing -> Nothing ->
[ttyFullContact ct <> ": contact is connected"] [ttyFullContact ct <> ": contact is connected"]
@ -865,10 +862,10 @@ viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs
where where
ldn_ :: GroupInfo -> Text ldn_ :: GroupInfo -> Text
ldn_ g = T.toLower g.localDisplayName ldn_ g = T.toLower g.localDisplayName
groupSS (g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership, chatSettings}, GroupSummary {currentMembers}) = groupSS (g@GroupInfo {membership, chatSettings}, GroupSummary {currentMembers}) =
case memberStatus membership of case memberStatus membership of
GSMemInvited -> groupInvitation' g GSMemInvited -> groupInvitation' g
s -> membershipIncognito g <> ttyGroup ldn <> optFullName ldn fullName <> viewMemberStatus s s -> membershipIncognito g <> ttyFullGroup g <> viewMemberStatus s
where where
viewMemberStatus = \case viewMemberStatus = \case
GSMemRemoved -> delete "you are removed" GSMemRemoved -> delete "you are removed"
@ -876,18 +873,18 @@ viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs
GSMemGroupDeleted -> delete "group deleted" GSMemGroupDeleted -> delete "group deleted"
_ _
| enableNtfs chatSettings -> " (" <> memberCount <> ")" | enableNtfs chatSettings -> " (" <> memberCount <> ")"
| otherwise -> " (" <> memberCount <> ", muted, you can " <> highlight ("/unmute #" <> ldn) <> ")" | otherwise -> " (" <> memberCount <> ", muted, you can " <> highlight ("/unmute #" <> viewGroupName g) <> ")"
delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> ldn) <> ")" 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"
groupInvitation' :: GroupInfo -> StyledString groupInvitation' :: GroupInfo -> StyledString
groupInvitation' g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}} = groupInvitation' g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}} =
highlight ("#" <> ldn) highlight ("#" <> viewName ldn)
<> optFullName ldn fullName <> optFullName ldn fullName
<> " - you are invited (" <> " - you are invited ("
<> highlight ("/j " <> ldn) <> highlight ("/j " <> viewName ldn)
<> joinText <> joinText
<> highlight ("/d #" <> ldn) <> highlight ("/d #" <> viewName ldn)
<> " to delete invitation)" <> " to delete invitation)"
where where
joinText = case incognitoMembershipProfile g of joinText = case incognitoMembershipProfile g of
@ -895,21 +892,21 @@ groupInvitation' g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfil
Nothing -> " to join, " Nothing -> " to join, "
viewContactsMerged :: Contact -> Contact -> [StyledString] viewContactsMerged :: Contact -> Contact -> [StyledString]
viewContactsMerged _into@Contact {localDisplayName = c1} _merged@Contact {localDisplayName = c2} = viewContactsMerged c1 c2 =
[ "contact " <> ttyContact c2 <> " is merged into " <> ttyContact c1, [ "contact " <> ttyContact' c2 <> " is merged into " <> ttyContact' c1,
"use " <> ttyToContact c1 <> highlight' "<message>" <> " to send messages" "use " <> ttyToContact' c1 <> highlight' "<message>" <> " to send messages"
] ]
viewUserProfile :: Profile -> [StyledString] viewUserProfile :: Profile -> [StyledString]
viewUserProfile Profile {displayName, fullName} = viewUserProfile Profile {displayName, fullName} =
[ "user profile: " <> ttyFullName displayName fullName, [ "user profile: " <> ttyFullName displayName fullName,
"use " <> highlight' "/p <display name> [<full name>]" <> " to change it", "use " <> highlight' "/p <display name>" <> " to change it",
"(the updated profile will be sent to all your contacts)" "(the updated profile will be sent to all your contacts)"
] ]
viewUserPrivacy :: User -> User -> [StyledString] viewUserPrivacy :: User -> User -> [StyledString]
viewUserPrivacy User {userId} User {userId = userId', localDisplayName = n', showNtfs, viewPwdHash} = viewUserPrivacy User {userId} User {userId = userId', localDisplayName = n', showNtfs, viewPwdHash} =
[ (if userId == userId' then "current " else "") <> "user " <> plain n' <> ":", [ plain $ (if userId == userId' then "current " else "") <> "user " <> viewName n' <> ":",
"messages are " <> if showNtfs then "shown" else "hidden (use /tail to view)", "messages are " <> if showNtfs then "shown" else "hidden (use /tail to view)",
"profile is " <> if isJust viewPwdHash then "hidden" else "visible" "profile is " <> if isJust viewPwdHash then "hidden" else "visible"
] ]
@ -1055,18 +1052,18 @@ viewGroupMemberSwitch g m (SwitchProgress qd phase _) = case qd of
QDSnd -> [ttyGroup' g <> ": " <> ttyMember m <> " " <> viewSwitchPhase phase <> " for you"] QDSnd -> [ttyGroup' g <> ": " <> ttyMember m <> " " <> viewSwitchPhase phase <> " for you"]
viewContactRatchetSync :: Contact -> RatchetSyncProgress -> [StyledString] viewContactRatchetSync :: Contact -> RatchetSyncProgress -> [StyledString]
viewContactRatchetSync ct@Contact {localDisplayName = c} RatchetSyncProgress {ratchetSyncStatus = rss} = viewContactRatchetSync ct RatchetSyncProgress {ratchetSyncStatus = rss} =
[ttyContact' ct <> ": " <> (plain . ratchetSyncStatusToText) rss] [ttyContact' ct <> ": " <> (plain . ratchetSyncStatusToText) rss]
<> help <> help
where where
help = ["use " <> highlight ("/sync " <> c) <> " to synchronize" | rss `elem` [RSAllowed, RSRequired]] help = ["use " <> highlight ("/sync " <> viewContactName ct) <> " to synchronize" | rss `elem` [RSAllowed, RSRequired]]
viewGroupMemberRatchetSync :: GroupInfo -> GroupMember -> RatchetSyncProgress -> [StyledString] viewGroupMemberRatchetSync :: GroupInfo -> GroupMember -> RatchetSyncProgress -> [StyledString]
viewGroupMemberRatchetSync g m@GroupMember {localDisplayName = n} RatchetSyncProgress {ratchetSyncStatus = rss} = viewGroupMemberRatchetSync g m RatchetSyncProgress {ratchetSyncStatus = rss} =
[ttyGroup' g <> " " <> ttyMember m <> ": " <> (plain . ratchetSyncStatusToText) rss] [ttyGroup' g <> " " <> ttyMember m <> ": " <> (plain . ratchetSyncStatusToText) rss]
<> help <> help
where where
help = ["use " <> highlight ("/sync #" <> groupName' g <> " " <> n) <> " to synchronize" | rss `elem` [RSAllowed, RSRequired]] help = ["use " <> highlight ("/sync #" <> viewGroupName g <> " " <> viewMemberName m) <> " to synchronize" | rss `elem` [RSAllowed, RSRequired]]
viewContactVerificationReset :: Contact -> [StyledString] viewContactVerificationReset :: Contact -> [StyledString]
viewContactVerificationReset ct = viewContactVerificationReset ct =
@ -1077,10 +1074,10 @@ viewGroupMemberVerificationReset g m =
[ttyGroup' g <> " " <> ttyMember m <> ": security code changed"] [ttyGroup' g <> " " <> ttyMember m <> ": security code changed"]
viewContactCode :: Contact -> Text -> Bool -> [StyledString] viewContactCode :: Contact -> Text -> Bool -> [StyledString]
viewContactCode ct@Contact {localDisplayName = c} = viewSecurityCode (ttyContact' ct) ("/verify " <> c <> " <code from your contact>") viewContactCode ct = viewSecurityCode (ttyContact' ct) ("/verify " <> viewContactName ct <> " <code from your contact>")
viewGroupMemberCode :: GroupInfo -> GroupMember -> Text -> Bool -> [StyledString] viewGroupMemberCode :: GroupInfo -> GroupMember -> Text -> Bool -> [StyledString]
viewGroupMemberCode g m@GroupMember {localDisplayName = n} = viewSecurityCode (ttyGroup' g <> " " <> ttyMember m) ("/verify #" <> groupName' g <> " " <> n <> " <code from your contact>") viewGroupMemberCode g m = viewSecurityCode (ttyGroup' g <> " " <> ttyMember m) ("/verify #" <> viewGroupName g <> " " <> viewMemberName m <> " <code from your contact>")
viewSecurityCode :: StyledString -> Text -> Text -> Bool -> [StyledString] viewSecurityCode :: StyledString -> Text -> Text -> Bool -> [StyledString]
viewSecurityCode name cmd code testView viewSecurityCode name cmd code testView
@ -1206,9 +1203,9 @@ bold' :: String -> StyledString
bold' = styled Bold bold' = styled Bold
viewContactAliasUpdated :: Contact -> [StyledString] viewContactAliasUpdated :: Contact -> [StyledString]
viewContactAliasUpdated Contact {localDisplayName = n, profile = LocalProfile {localAlias}} viewContactAliasUpdated ct@Contact {profile = LocalProfile {localAlias}}
| localAlias == "" = ["contact " <> ttyContact n <> " alias removed"] | localAlias == "" = ["contact " <> ttyContact' ct <> " alias removed"]
| otherwise = ["contact " <> ttyContact n <> " alias updated: " <> plain localAlias] | otherwise = ["contact " <> ttyContact' ct <> " alias updated: " <> plain localAlias]
viewConnectionAliasUpdated :: PendingContactConnection -> [StyledString] viewConnectionAliasUpdated :: PendingContactConnection -> [StyledString]
viewConnectionAliasUpdated PendingContactConnection {pccConnId, localAlias} viewConnectionAliasUpdated PendingContactConnection {pccConnId, localAlias}
@ -1385,10 +1382,10 @@ savingFile' testView (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, f
savingFile' _ _ = ["saving file"] -- shouldn't happen savingFile' _ _ = ["saving file"] -- shouldn't happen
receivingFile_' :: StyledString -> AChatItem -> [StyledString] receivingFile_' :: StyledString -> AChatItem -> [StyledString]
receivingFile_' status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectRcv}) = receivingFile_' status (AChatItem _ _ (DirectChat c) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectRcv}) =
[status <> " receiving " <> fileTransferStr fileId fileName <> " from " <> ttyContact c] [status <> " receiving " <> fileTransferStr fileId fileName <> " from " <> ttyContact' c]
receivingFile_' status (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupRcv GroupMember {localDisplayName = m}}) = receivingFile_' status (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupRcv m}) =
[status <> " receiving " <> fileTransferStr fileId fileName <> " from " <> ttyContact m] [status <> " receiving " <> fileTransferStr fileId fileName <> " from " <> ttyMember m]
receivingFile_' status _ = [status <> " receiving file"] -- shouldn't happen receivingFile_' status _ = [status <> " receiving file"] -- shouldn't happen
receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString] receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString]
@ -1556,6 +1553,9 @@ viewChatError logLevel = \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 $
["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"]
@ -1568,8 +1568,8 @@ viewChatError logLevel = \case
] ]
CEContactNotFound cName m_ -> viewContactNotFound cName m_ CEContactNotFound cName m_ -> viewContactNotFound cName m_
CEContactNotReady c -> [ttyContact' c <> ": not ready"] CEContactNotReady c -> [ttyContact' c <> ": not ready"]
CEContactDisabled ct -> [ttyContact' ct <> ": disabled, to enable: " <> highlight ("/enable " <> viewContactName ct) <> ", to delete: " <> highlight ("/d " <> viewContactName ct)]
CEContactNotActive c -> [ttyContact' c <> ": not active"] CEContactNotActive c -> [ttyContact' c <> ": not active"]
CEContactDisabled Contact {localDisplayName = c} -> [ttyContact c <> ": disabled, to enable: " <> highlight ("/enable " <> c) <> ", to delete: " <> highlight ("/d " <> c)]
CEConnectionDisabled Connection {connId, connType} -> [plain $ "connection " <> textEncode connType <> " (" <> tshow connId <> ") is disabled" | logLevel <= CLLWarning] CEConnectionDisabled Connection {connId, connType} -> [plain $ "connection " <> textEncode connType <> " (" <> tshow connId <> ") is disabled" | logLevel <= CLLWarning]
CEGroupDuplicateMember c -> ["contact " <> ttyContact c <> " is already in the group"] CEGroupDuplicateMember c -> ["contact " <> ttyContact c <> " is already in the group"]
CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"] CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"]
@ -1581,7 +1581,7 @@ viewChatError logLevel = \case
CEContactIncognitoCantInvite -> ["you're using your main profile for this group - prohibited to invite contacts to whom you are connected incognito"] CEContactIncognitoCantInvite -> ["you're using your main profile for this group - prohibited to invite contacts to whom you are connected incognito"]
CEGroupIncognitoCantInvite -> ["you've connected to this group using an incognito profile - prohibited to invite contacts"] CEGroupIncognitoCantInvite -> ["you've connected to this group using an incognito profile - prohibited to invite contacts"]
CEGroupContactRole c -> ["contact " <> ttyContact c <> " has insufficient permissions for this group action"] CEGroupContactRole c -> ["contact " <> ttyContact c <> " has insufficient permissions for this group action"]
CEGroupNotJoined g -> ["you did not join this group, use " <> highlight ("/join #" <> groupName' g)] CEGroupNotJoined g -> ["you did not join this group, use " <> highlight ("/join #" <> viewGroupName g)]
CEGroupMemberNotActive -> ["your group connection is not active yet, try later"] CEGroupMemberNotActive -> ["your group connection is not active yet, try later"]
CEGroupMemberUserRemoved -> ["you are no longer a member of the group"] CEGroupMemberUserRemoved -> ["you are no longer a member of the group"]
CEGroupMemberNotFound -> ["group doesn't have this member"] CEGroupMemberNotFound -> ["group doesn't have this member"]
@ -1641,8 +1641,8 @@ viewChatError logLevel = \case
SEFileIdNotFoundBySharedMsgId _ -> [] -- recipient tried to accept cancelled file SEFileIdNotFoundBySharedMsgId _ -> [] -- recipient tried to accept cancelled file
SEConnectionNotFound agentConnId -> ["event connection not found, agent ID: " <> sShow agentConnId | logLevel <= CLLWarning] -- mutes delete group error SEConnectionNotFound agentConnId -> ["event connection not found, agent ID: " <> sShow agentConnId | logLevel <= CLLWarning] -- mutes delete group error
SEChatItemNotFoundByText text -> ["message not found by text: " <> plain text] SEChatItemNotFoundByText text -> ["message not found by text: " <> plain text]
SEDuplicateGroupLink g -> ["you already have link for this group, to show: " <> highlight ("/show link #" <> groupName' g)] SEDuplicateGroupLink g -> ["you already have link for this group, to show: " <> highlight ("/show link #" <> viewGroupName g)]
SEGroupLinkNotFound g -> ["no group link, to create: " <> highlight ("/create link #" <> groupName' g)] SEGroupLinkNotFound g -> ["no group link, to create: " <> highlight ("/create link #" <> viewGroupName g)]
e -> ["chat db error: " <> sShow e] e -> ["chat db error: " <> sShow e]
ChatErrorDatabase err -> case err of ChatErrorDatabase err -> case err of
DBErrorEncrypted -> ["error: chat database is already encrypted"] DBErrorEncrypted -> ["error: chat database is already encrypted"]
@ -1687,8 +1687,8 @@ viewChatError logLevel = \case
viewConnectionEntityDisabled :: ConnectionEntity -> [StyledString] viewConnectionEntityDisabled :: ConnectionEntity -> [StyledString]
viewConnectionEntityDisabled entity = case entity of viewConnectionEntityDisabled entity = case entity of
RcvDirectMsgConnection _ (Just Contact {localDisplayName = c}) -> ["[" <> entityLabel <> "] connection is disabled, to enable: " <> highlight ("/enable " <> c) <> ", to delete: " <> highlight ("/d " <> c)] RcvDirectMsgConnection _ (Just c) -> ["[" <> entityLabel <> "] connection is disabled, to enable: " <> highlight ("/enable " <> viewContactName c) <> ", to delete: " <> highlight ("/d " <> viewContactName c)]
RcvGroupMsgConnection _ GroupInfo {localDisplayName = g} GroupMember {localDisplayName = m} -> ["[" <> entityLabel <> "] connection is disabled, to enable: " <> highlight ("/enable #" <> g <> " " <> m)] RcvGroupMsgConnection _ g m -> ["[" <> entityLabel <> "] connection is disabled, to enable: " <> highlight ("/enable #" <> viewGroupName g <> " " <> viewMemberName m)]
_ -> ["[" <> entityLabel <> "] connection is disabled"] _ -> ["[" <> entityLabel <> "] connection is disabled"]
where where
entityLabel = connEntityLabel entity entityLabel = connEntityLabel entity
@ -1703,7 +1703,7 @@ connEntityLabel = \case
UserContactConnection _ UserContact {} -> "contact address" UserContactConnection _ UserContact {} -> "contact address"
ttyContact :: ContactName -> StyledString ttyContact :: ContactName -> StyledString
ttyContact = styled $ colored Green ttyContact = styled (colored Green) . viewName
ttyContact' :: Contact -> StyledString ttyContact' :: Contact -> StyledString
ttyContact' Contact {localDisplayName = c} = ttyContact c ttyContact' Contact {localDisplayName = c} = ttyContact c
@ -1723,37 +1723,46 @@ ttyFullName :: ContactName -> Text -> StyledString
ttyFullName c fullName = ttyContact c <> optFullName c fullName ttyFullName c fullName = ttyContact c <> optFullName c fullName
ttyToContact :: ContactName -> StyledString ttyToContact :: ContactName -> StyledString
ttyToContact c = ttyTo $ "@" <> c <> " " ttyToContact c = ttyTo $ "@" <> viewName c <> " "
ttyToContact' :: Contact -> StyledString ttyToContact' :: Contact -> StyledString
ttyToContact' ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyToContact c ttyToContact' ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyToContact c
ttyToContactEdited' :: Contact -> StyledString ttyToContactEdited' :: Contact -> StyledString
ttyToContactEdited' ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyTo ("@" <> c <> " [edited] ") ttyToContactEdited' ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyTo ("@" <> viewName c <> " [edited] ")
ttyQuotedContact :: Contact -> StyledString ttyQuotedContact :: Contact -> StyledString
ttyQuotedContact Contact {localDisplayName = c} = ttyFrom $ c <> ">" ttyQuotedContact Contact {localDisplayName = c} = ttyFrom $ viewName c <> ">"
ttyQuotedMember :: Maybe GroupMember -> StyledString ttyQuotedMember :: Maybe GroupMember -> StyledString
ttyQuotedMember (Just GroupMember {localDisplayName = c}) = "> " <> ttyFrom c ttyQuotedMember (Just GroupMember {localDisplayName = c}) = "> " <> ttyFrom (viewName c)
ttyQuotedMember _ = "> " <> ttyFrom "?" ttyQuotedMember _ = "> " <> ttyFrom "?"
ttyFromContact :: Contact -> StyledString ttyFromContact :: Contact -> StyledString
ttyFromContact ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (c <> "> ") ttyFromContact ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (viewName c <> "> ")
ttyFromContactEdited :: Contact -> StyledString ttyFromContactEdited :: Contact -> StyledString
ttyFromContactEdited ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (c <> "> [edited] ") ttyFromContactEdited ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (viewName c <> "> [edited] ")
ttyFromContactDeleted :: Contact -> Maybe Text -> StyledString ttyFromContactDeleted :: Contact -> Maybe Text -> StyledString
ttyFromContactDeleted ct@Contact {localDisplayName = c} deletedText_ = ttyFromContactDeleted ct@Contact {localDisplayName = c} deletedText_ =
ctIncognito ct <> ttyFrom (c <> "> " <> maybe "" (\t -> "[" <> t <> "] ") deletedText_) ctIncognito ct <> ttyFrom (viewName c <> "> " <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
ttyGroup :: GroupName -> StyledString ttyGroup :: GroupName -> StyledString
ttyGroup g = styled (colored Blue) $ "#" <> g ttyGroup g = styled (colored Blue) $ "#" <> viewName g
ttyGroup' :: GroupInfo -> StyledString ttyGroup' :: GroupInfo -> StyledString
ttyGroup' = ttyGroup . groupName' ttyGroup' = ttyGroup . groupName'
viewContactName :: Contact -> Text
viewContactName = viewName . localDisplayName'
viewGroupName :: GroupInfo -> Text
viewGroupName = viewName . groupName'
viewMemberName :: GroupMember -> Text
viewMemberName GroupMember {localDisplayName = n} = viewName n
ttyGroups :: [GroupName] -> StyledString ttyGroups :: [GroupName] -> StyledString
ttyGroups [] = "" ttyGroups [] = ""
ttyGroups [g] = ttyGroup g ttyGroups [g] = ttyGroup g
@ -1774,8 +1783,7 @@ ttyFromGroupDeleted g m deletedText_ =
membershipIncognito g <> ttyFrom (fromGroup_ g m <> maybe "" (\t -> "[" <> t <> "] ") deletedText_) membershipIncognito g <> ttyFrom (fromGroup_ g m <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
fromGroup_ :: GroupInfo -> GroupMember -> Text fromGroup_ :: GroupInfo -> GroupMember -> Text
fromGroup_ GroupInfo {localDisplayName = g} GroupMember {localDisplayName = m} = fromGroup_ g m = "#" <> viewGroupName g <> " " <> viewMemberName m <> "> "
"#" <> g <> " " <> m <> "> "
ttyFrom :: Text -> StyledString ttyFrom :: Text -> StyledString
ttyFrom = styled $ colored Yellow ttyFrom = styled $ colored Yellow
@ -1784,12 +1792,13 @@ ttyTo :: Text -> StyledString
ttyTo = styled $ colored Cyan ttyTo = styled $ colored Cyan
ttyToGroup :: GroupInfo -> StyledString ttyToGroup :: GroupInfo -> StyledString
ttyToGroup g@GroupInfo {localDisplayName = n} = ttyToGroup g = membershipIncognito g <> ttyTo ("#" <> viewGroupName g <> " ")
membershipIncognito g <> ttyTo ("#" <> n <> " ")
ttyToGroupEdited :: GroupInfo -> StyledString ttyToGroupEdited :: GroupInfo -> StyledString
ttyToGroupEdited g@GroupInfo {localDisplayName = n} = ttyToGroupEdited g = membershipIncognito g <> ttyTo ("#" <> viewGroupName g <> " [edited] ")
membershipIncognito g <> ttyTo ("#" <> n <> " [edited] ")
viewName :: Text -> Text
viewName s = if T.any isSpace s then "'" <> s <> "'" else s
ttyFilePath :: FilePath -> StyledString ttyFilePath :: FilePath -> StyledString
ttyFilePath = plain ttyFilePath = plain

75
tests/ChatTests/Profiles.hs
View file

@ -8,7 +8,7 @@ import ChatTests.Utils
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_) import Control.Concurrent.Async (concurrently_)
import qualified Data.Text as T import qualified Data.Text as T
import Simplex.Chat.Types (ConnStatus (..), GroupMemberRole (..)) import Simplex.Chat.Types (ConnStatus (..), GroupMemberRole (..), Profile (..))
import System.Directory (copyFile, createDirectoryIfMissing) import System.Directory (copyFile, createDirectoryIfMissing)
import Test.Hspec import Test.Hspec
@ -17,6 +17,7 @@ chatProfileTests = do
describe "user profiles" $ do describe "user profiles" $ do
it "update user profile and notify contacts" testUpdateProfile it "update user profile and notify contacts" testUpdateProfile
it "update user profile with image" testUpdateProfileImage it "update user profile with image" testUpdateProfileImage
it "use multiword profile names" testMultiWordProfileNames
describe "user contact link" $ do describe "user contact link" $ do
it "create and connect via contact link" testUserContactLink it "create and connect via contact link" testUserContactLink
it "add contact link to profile" testProfileLink it "add contact link to profile" testProfileLink
@ -62,7 +63,7 @@ testUpdateProfile =
createGroup3 "team" alice bob cath createGroup3 "team" alice bob cath
alice ##> "/p" alice ##> "/p"
alice <## "user profile: alice (Alice)" alice <## "user profile: alice (Alice)"
alice <## "use /p <display name> [<full name>] to change it" alice <## "use /p <display name> to change it"
alice <## "(the updated profile will be sent to all your contacts)" alice <## "(the updated profile will be sent to all your contacts)"
alice ##> "/p alice" alice ##> "/p alice"
concurrentlyN_ concurrentlyN_
@ -117,6 +118,76 @@ testUpdateProfileImage =
bob <## "use @alice2 <message> to send messages" bob <## "use @alice2 <message> to send messages"
(bob </) (bob </)
testMultiWordProfileNames :: HasCallStack => FilePath -> IO ()
testMultiWordProfileNames =
testChat3 aliceProfile' bobProfile' cathProfile' $
\alice bob cath -> do
alice ##> "/c"
inv <- getInvitation alice
bob ##> ("/c " <> inv)
bob <## "confirmation sent!"
concurrently_
(bob <## "'Alice Jones': contact is connected")
(alice <## "'Bob James': contact is connected")
alice #> "@'Bob James' hi"
bob <# "'Alice Jones'> hi"
alice ##> "/g 'Our Team'"
alice <## "group #'Our Team' is created"
alice <## "to add members use /a 'Our Team' <name> or /create link #'Our Team'"
alice ##> "/a 'Our Team' 'Bob James' admin"
alice <## "invitation to join the group #'Our Team' sent to 'Bob James'"
bob <## "#'Our Team': 'Alice Jones' invites you to join the group as admin"
bob <## "use /j 'Our Team' to accept"
bob ##> "/j 'Our Team'"
bob <## "#'Our Team': you joined the group"
alice <## "#'Our Team': 'Bob James' joined the group"
bob ##> "/c"
inv' <- getInvitation bob
cath ##> ("/c " <> inv')
cath <## "confirmation sent!"
concurrently_
(cath <## "'Bob James': contact is connected")
(bob <## "'Cath Johnson': contact is connected")
bob ##> "/a 'Our Team' 'Cath Johnson'"
bob <## "invitation to join the group #'Our Team' sent to 'Cath Johnson'"
cath <## "#'Our Team': 'Bob James' invites you to join the group as member"
cath <## "use /j 'Our Team' to accept"
cath ##> "/j 'Our Team'"
concurrentlyN_
[ bob <## "#'Our Team': 'Cath Johnson' joined the group",
do
cath <## "#'Our Team': you joined the group"
cath <## "#'Our Team': member 'Alice Jones' is connected",
do
alice <## "#'Our Team': 'Bob James' added 'Cath Johnson' to the group (connecting...)"
alice <## "#'Our Team': new member 'Cath Johnson' is connected"
]
bob #> "#'Our Team' hi"
alice <# "#'Our Team' 'Bob James'> hi"
cath <# "#'Our Team' 'Bob James'> hi"
alice `send` "@'Cath Johnson' hello"
alice <## "member #'Our Team' 'Cath Johnson' does not have direct connection, creating"
alice <## "contact for member #'Our Team' 'Cath Johnson' is created"
alice <## "sent invitation to connect directly to member #'Our Team' 'Cath Johnson'"
alice <# "@'Cath Johnson' hello"
cath <## "#'Our Team' 'Alice Jones' is creating direct contact 'Alice Jones' with you"
cath <# "'Alice Jones'> hello"
cath <## "'Alice Jones': contact is connected"
alice <## "'Cath Johnson': contact is connected"
cath ##> "/p 'Cath J'"
cath <## "user profile is changed to 'Cath J' (your 2 contacts are notified)"
alice <## "contact 'Cath Johnson' changed to 'Cath J'"
alice <## "use @'Cath J' <message> to send messages"
bob <## "contact 'Cath Johnson' changed to 'Cath J'"
bob <## "use @'Cath J' <message> to send messages"
alice #> "@'Cath J' hi"
cath <# "'Alice Jones'> hi"
where
aliceProfile' = baseProfile {displayName = "Alice Jones"}
bobProfile' = baseProfile {displayName = "Bob James"}
cathProfile' = baseProfile {displayName = "Cath Johnson"}
baseProfile = Profile {displayName = "", fullName = "", image = Nothing, contactLink = Nothing, preferences = defaultPrefs}
testUserContactLink :: HasCallStack => FilePath -> IO () testUserContactLink :: HasCallStack => FilePath -> IO ()
testUserContactLink = testUserContactLink =
testChat3 aliceProfile bobProfile cathProfile $ testChat3 aliceProfile bobProfile cathProfile $

2
tests/ChatTests/Utils.hs
View file

@ -435,7 +435,7 @@ lastItemId cc = do
showActiveUser :: HasCallStack => TestCC -> String -> Expectation showActiveUser :: HasCallStack => TestCC -> String -> Expectation
showActiveUser cc name = do showActiveUser cc name = do
cc <## ("user profile: " <> name) cc <## ("user profile: " <> name)
cc <## "use /p <display name> [<full name>] to change it" cc <## "use /p <display name> to change it"
cc <## "(the updated profile will be sent to all your contacts)" cc <## "(the updated profile will be sent to all your contacts)"
connectUsers :: HasCallStack => TestCC -> TestCC -> IO () connectUsers :: HasCallStack => TestCC -> TestCC -> IO ()

10
tests/MobileTests.hs
View file

@ -61,6 +61,8 @@ mobileTests = do
it "utf8 name 1" $ testFileEncryptionCApi "тест" it "utf8 name 1" $ testFileEncryptionCApi "тест"
it "utf8 name 2" $ testFileEncryptionCApi "👍" it "utf8 name 2" $ testFileEncryptionCApi "👍"
it "no exception on missing file" testMissingFileEncryptionCApi it "no exception on missing file" testMissingFileEncryptionCApi
describe "validate name" $ do
it "should convert invalid name to a valid name" testValidNameCApi
noActiveUser :: LB.ByteString noActiveUser :: LB.ByteString
#if defined(darwin_HOST_OS) && defined(swiftJSON) #if defined(darwin_HOST_OS) && defined(swiftJSON)
@ -266,6 +268,14 @@ testMissingFileEncryptionCApi tmp = do
err' <- peekCAString =<< cChatDecryptFile cToPath cKey cNonce cToPath' err' <- peekCAString =<< cChatDecryptFile cToPath cKey cNonce cToPath'
err' `shouldContain` toPath err' `shouldContain` toPath
testValidNameCApi :: FilePath -> IO ()
testValidNameCApi _ = do
let goodName = "Джон Доу 👍"
cName1 <- cChatValidName =<< newCString goodName
peekCString cName1 `shouldReturn` goodName
cName2 <- cChatValidName =<< newCString " @'Джон' Доу 👍 "
peekCString cName2 `shouldReturn` goodName
jDecode :: FromJSON a => String -> IO (Maybe a) jDecode :: FromJSON a => String -> IO (Maybe a)
jDecode = pure . J.decode . LB.pack jDecode = pure . J.decode . LB.pack

2
tests/Test.hs
View file

@ -12,6 +12,7 @@ import SchemaDump
import Test.Hspec import Test.Hspec
import UnliftIO.Temporary (withTempDirectory) import UnliftIO.Temporary (withTempDirectory)
import ViewTests import ViewTests
import ValidNames
import WebRTCTests import WebRTCTests
main :: IO () main :: IO ()
@ -23,6 +24,7 @@ main = do
describe "SimpleX chat view" viewTests describe "SimpleX chat view" viewTests
describe "SimpleX chat protocol" protocolTests describe "SimpleX chat protocol" protocolTests
describe "WebRTC encryption" webRTCTests describe "WebRTC encryption" webRTCTests
describe "Valid names" validNameTests
around testBracket $ do around testBracket $ do
describe "Mobile API Tests" mobileTests describe "Mobile API Tests" mobileTests
describe "SimpleX chat client" chatTests describe "SimpleX chat client" chatTests

27
tests/ValidNames.hs Normal file
View file

@ -0,0 +1,27 @@
module ValidNames where
import Simplex.Chat
import Test.Hspec
validNameTests :: Spec
validNameTests = describe "valid chat names" $ do
it "should keep valid and fix invalid names" testMkValidName
testMkValidName :: IO ()
testMkValidName = do
mkValidName "alice" `shouldBe` "alice"
mkValidName "алиса" `shouldBe` "алиса"
mkValidName "John Doe" `shouldBe` "John Doe"
mkValidName "J.Doe" `shouldBe` "J.Doe"
mkValidName "J. Doe" `shouldBe` "J. Doe"
mkValidName "J..Doe" `shouldBe` "J.Doe"
mkValidName "J ..Doe" `shouldBe` "J Doe"
mkValidName "J . . Doe" `shouldBe` "J Doe"
mkValidName "@alice" `shouldBe` "alice"
mkValidName "#alice" `shouldBe` "alice"
mkValidName " alice" `shouldBe` "alice"
mkValidName "alice " `shouldBe` "alice"
mkValidName "John Doe" `shouldBe` "John Doe"
mkValidName "'John Doe'" `shouldBe` "John Doe"
mkValidName "\"John Doe\"" `shouldBe` "John Doe"
mkValidName "`John Doe`" `shouldBe` "John Doe"