Merge branch 'stable'

This commit is contained in:
Evgeny Poberezkin
2026-05-28 23:19:54 +01:00
35 changed files with 1023 additions and 222 deletions
+2
View File
@@ -1053,6 +1053,7 @@ data GroupLinkPlan
| GLPConnectingProhibit {groupInfo_ :: Maybe GroupInfo}
| GLPKnown {groupInfo :: GroupInfo, groupUpdated :: BoolDef, ownerVerification :: Maybe OwnerVerification, linkOwners :: ListDef GroupLinkOwner}
| GLPNoRelays {groupSLinkData_ :: Maybe GroupShortLinkData}
| GLPUpdateRequired {groupSLinkData_ :: Maybe GroupShortLinkData}
deriving (Show)
data GroupLinkOwner = GroupLinkOwner
@@ -1098,6 +1099,7 @@ connectionPlanProceed = \case
GLPOwnLink _ -> True
GLPConnectingConfirmReconnect -> True
GLPNoRelays _ -> False
GLPUpdateRequired _ -> False
_ -> False
CPError _ -> True
+36 -24
View File
@@ -4132,21 +4132,25 @@ processChatCommand vr nm = \case
Nothing -> do
(fd, cData@(ContactLinkData _ UserContactData {direct, owners, relays})) <- getShortLinkConnReq' nm user l'
groupSLinkData_ <- liftIO $ decodeLinkUserData cData
if not direct && null relays
then pure (con (linkConnReq fd), CPGroupLink (GLPNoRelays groupSLinkData_))
else do
let FixedLinkData {linkConnReq = cReq, linkEntityId, rootKey} = fd
linkInfo = GroupShortLinkInfo {direct, groupRelays = relays, publicGroupId = B64UrlByteString <$> linkEntityId}
let profilePGId = groupSLinkData_ >>= \GroupShortLinkData {groupProfile = GroupProfile {publicGroup}} ->
fmap (\PublicGroupProfile {publicGroupId} -> publicGroupId) publicGroup
case (B64UrlByteString <$> linkEntityId, profilePGId) of
(Just entityId, Just publicGroupId) | entityId == publicGroupId -> pure ()
(Nothing, Nothing) -> pure ()
_ -> throwChatError CEInvalidConnReq
let ov = verifyLinkOwner rootKey owners l' sig_
plan <- groupJoinRequestPlan user cReq (Just linkInfo) groupSLinkData_ ov
pure (con cReq, plan)
if
| not direct && unsupportedGroupType groupSLinkData_ -> pure (con (linkConnReq fd), CPGroupLink (GLPUpdateRequired groupSLinkData_))
| not direct && null relays -> pure (con (linkConnReq fd), CPGroupLink (GLPNoRelays groupSLinkData_))
| otherwise -> do
let FixedLinkData {linkConnReq = cReq, linkEntityId, rootKey} = fd
linkInfo = GroupShortLinkInfo {direct, groupRelays = relays, publicGroupId = B64UrlByteString <$> linkEntityId}
let profilePGId = groupSLinkData_ >>= \GroupShortLinkData {groupProfile = GroupProfile {publicGroup}} ->
fmap (\PublicGroupProfile {publicGroupId} -> publicGroupId) publicGroup
case (B64UrlByteString <$> linkEntityId, profilePGId) of
(Just entityId, Just publicGroupId) | entityId == publicGroupId -> pure ()
(Nothing, Nothing) -> pure ()
_ -> throwChatError CEInvalidConnReq
let ov = verifyLinkOwner rootKey owners l' sig_
plan <- groupJoinRequestPlan user cReq (Just linkInfo) groupSLinkData_ ov
pure (con cReq, plan)
where
unsupportedGroupType = \case
Just GroupShortLinkData {groupProfile = GroupProfile {publicGroup = Just PublicGroupProfile {groupType}}} -> groupType /= GTChannel
_ -> False
knownLinkPlans = withFastStore $ \db ->
liftIO (getGroupInfoViaUserShortLink db vr user l') >>= \case
Just (cReq, g) -> pure $ Just (con cReq, CPGroupLink (GLPOwnLink g))
@@ -5567,17 +5571,25 @@ mkValidName :: String -> String
mkValidName = dropWhileEnd isSpace . take 50 . reverse . fst3 . foldl' addChar ("", '\NUL', 0 :: Int)
where
fst3 (x, _, _) = x
addChar (r, prev, punct) c = if validChar then (c' : r, c', punct') else (r, prev, punct)
addChar (r, prev, punct) c' = if validChar then (c : r, c, punct') else (r, prev, punct)
where
c' = if isSpace c then ' ' else c
c = if isSpace c' then ' ' else c'
cat = generalCategory c
isPunct = case cat of
ConnectorPunctuation -> True
DashPunctuation -> True
OtherPunctuation -> True
_ -> False
punct'
| isPunctuation c = punct + 1
| isSpace c = punct
| isPunct = punct + 1
| c == ' ' = punct
| otherwise = 0
validChar
| c == '\'' = False
| prev == '\NUL' = c > ' ' && c /= '#' && c /= '@' && validFirstChar
| isSpace prev = validFirstChar || (punct == 0 && isPunctuation c)
| isPunctuation prev = validFirstChar || isSpace c || (punct < 3 && isPunctuation c)
| otherwise = validFirstChar || isSpace c || isMark c || isPunctuation c
validFirstChar = isLetter c || isNumber c || isSymbol c
| c `elem` prohibited = False
| prev == '\NUL' = c > ' ' && validFirstNameChar
| prev == ' ' = validFirstChar || (punct == 0 && isPunct)
| punct > 0 = validFirstChar || c == ' '
| otherwise = validFirstChar || c == ' ' || isMark c || isPunct
validFirstNameChar = isLetter c || cat == DecimalNumber || cat == OtherSymbol
validFirstChar = validFirstNameChar || cat == CurrencySymbol || cat == MathSymbol
prohibited = ".,;/\\#@'\"`~" :: String
+31 -11
View File
@@ -35,11 +35,11 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ConnReqUriData (..), ConnShortLink (..), ConnectionLink (..), ConnectionRequestUri (..), ContactConnType (..), SMPQueue (..), simplexConnReqUri, simplexShortLink)
import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ConnReqUriData (..), ConnShortLink (..), ConnectionLink (..), ConnectionRequestUri (..), ContactConnType (..), SMPQueue (..), SimplexNameInfo (..), simplexConnReqUri, simplexShortLink)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fstToLower, sumTypeJSON)
import Simplex.Messaging.Protocol (ProtocolServer (..))
import Simplex.Messaging.Util (decodeJSON, safeDecodeUtf8, tshow)
import Simplex.Messaging.Util (decodeJSON, safeDecodeUtf8, tshow, (<$?>))
import System.Console.ANSI.Types
import qualified Text.Email.Validate as Email
import qualified URI.ByteString as U
@@ -59,6 +59,7 @@ data Format
-- showText is Nothing for the usual Uri without text
| HyperLink {showText :: Maybe Text, linkUri :: Text}
| SimplexLink {showText :: Maybe Text, linkType :: SimplexLinkType, simplexUri :: AConnectionLink, smpHosts :: NonEmpty Text}
| SimplexName {nameInfo :: SimplexNameInfo}
| Command {commandStr :: Text}
| Mention {memberName :: Text}
| Email
@@ -184,6 +185,7 @@ isLink = \case
Uri -> True
HyperLink {} -> True
SimplexLink {} -> True
SimplexName {} -> True
_ -> False
hasLinks :: MarkdownList -> Bool
@@ -202,9 +204,9 @@ markdownP = mconcat <$> A.many' fragmentP
'_' -> formattedP '_' Italic
'~' -> formattedP '~' StrikeThrough
'`' -> formattedP '`' Snippet
'#' -> A.char '#' *> secretP
'#' -> A.char '#' *> (secretP <|> nameRefP '#' <|> secretFallback)
'!' -> styledP <|> wordP
'@' -> mentionP <|> wordP
'@' -> (A.char '@' *> nameRefP '@') <|> mentionP <|> wordP
'/' -> commandP <|> wordP
'[' -> sowLinkP <|> wordP
_
@@ -221,14 +223,29 @@ markdownP = mconcat <$> A.many' fragmentP
unmarked $ c `T.cons` s `T.snoc` c
| otherwise = markdown f s
secretP :: Parser Markdown
secretP = secret <$> A.takeWhile (== '#') <*> A.takeTill (== '#') <*> A.takeWhile (== '#')
secret :: Text -> Text -> Text -> Markdown
secret b s a
| T.null a || T.null s || T.head s == ' ' || T.last s == ' ' =
unmarked $ '#' `T.cons` ss
| otherwise = markdown Secret $ T.init ss
secretP = secret <$?> ((,,) <$> A.takeWhile (== '#') <*> A.takeTill (== '#') <*> A.takeWhile1 (== '#'))
secret :: (Text, Text, Text) -> Either String Markdown
secret (b, s, a)
| T.null s || T.head s == ' ' || T.last s == ' ' = Left "not secret"
| otherwise = Right $ markdown Secret $ T.init ss
where
ss = b <> s <> a
secretFallback :: Parser Markdown
secretFallback = unmarked . ('#' `T.cons`) <$> A.takeTill (== ' ')
nameRefP :: Char -> Parser Markdown
nameRefP pfx = nameRef <$?> A.takeTill (== ' ')
where
nameRef word
| pfx == '@' && T.all (/= '.') name = Left "not a name"
| otherwise = mkMd <$> strDecode (encodeUtf8 full)
where
(name, punct) = splitPunctuation word
full = pfx `T.cons` name
mkMd ni
| T.null punct = md'
| otherwise = md' :|: unmarked punct
where
md' = markdown (SimplexName ni) full
styledP :: Parser Markdown
styledP = do
f <- A.char '!' *> ((A.char '-' $> Small) <|> (colored <$> colorP)) <* A.space
@@ -449,6 +466,7 @@ markdownText (FormattedText f_ t) = case f_ of
Uri -> t
HyperLink {} -> t
SimplexLink {} -> t
SimplexName {} -> t
Mention _ -> t
Command _ -> t
Email -> t
@@ -479,7 +497,6 @@ displayNameTextP_ = (,"") <$> quoted '\'' <|> splitPunctuation <$> takeNameTill
takeNameTill p =
A.peekChar' >>= \c ->
if refChar c then A.takeTill p else fail "invalid first character in display name"
splitPunctuation s = (T.dropWhileEnd isPunctuation s, T.takeWhileEnd isPunctuation s)
quoted c = A.char c *> takeNameTill (== c) <* A.char c
refChar c = c > ' ' && c /= '#' && c /= '@' && c /= '\''
@@ -490,6 +507,9 @@ commandTextP = do
(keyword : _) | T.all (\c -> isAlpha c || isDigit c || c == '_') keyword -> pure (cmd, punct)
_ -> fail "invalid command keyword"
splitPunctuation :: Text -> (Text, Text)
splitPunctuation s = (T.dropWhileEnd isPunctuation s, T.takeWhileEnd isPunctuation s)
-- quotes names that contain spaces or end on punctuation
viewName :: Text -> Text
viewName s = if T.any isSpace s || maybe False (isPunctuation . snd) (T.unsnoc s) then "'" <> s <> "'" else s
+1
View File
@@ -2150,6 +2150,7 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case
]
knownGroup prepared = grpOrBizLink g <> ": known " <> prepared <> grpOrBiz g <> " " <> ttyGroup' g
GLPNoRelays _ -> [grpLink "channel has no active relays, please try to join later"]
GLPUpdateRequired _ -> [grpLink "this group requires a newer version of the app, please upgrade"]
where
connecting g = [grpOrBizLink g <> ": connecting to " <> grpOrBiz g <> " " <> ttyGroup' g]
grpLink = ("group link: " <>)