core: markdown for simplex invitation links (#1408)

* core: markdown for simplex invitation links

* update markdown for simplex links

* update markdown

* update

* stabilize test
This commit is contained in:
Evgeny Poberezkin
2022-11-24 13:13:26 +00:00
committed by GitHub
parent 388aaec80b
commit a7345ee4d9
3 changed files with 57 additions and 3 deletions
+38 -3
View File
@@ -1,5 +1,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
@@ -16,13 +18,21 @@ import Data.Char (isDigit)
import Data.Either (fromRight)
import Data.Functor (($>))
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe, isNothing)
import Data.Semigroup (sconcat)
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import GHC.Generics
import Simplex.Messaging.Parsers (fstToLower, sumTypeJSON)
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (AConnectionRequestUri (..), ConnReqScheme (..), ConnReqUriData (..), ConnectionRequestUri (..), SMPQueue (..))
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fstToLower, sumTypeJSON)
import Simplex.Messaging.Protocol (ProtocolServer (..))
import Simplex.Messaging.Util (safeDecodeUtf8)
import System.Console.ANSI.Types
import qualified Text.Email.Validate as Email
@@ -37,17 +47,27 @@ data Format
| Secret
| Colored {color :: FormatColor}
| Uri
| SimplexLink {linkType :: SimplexLinkType, simplexUri :: Text, smpHosts :: NonEmpty Text}
| Email
| Phone
deriving (Eq, Show, Generic)
data SimplexLinkType = XLContact | XLInvitation | XLGroup
deriving (Eq, Show, Generic)
instance ToJSON SimplexLinkType where
toJSON = J.genericToJSON . enumJSON $ dropPrefix "XL"
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "XL"
colored :: Color -> Format
colored = Colored . FormatColor
markdown :: Format -> Text -> Markdown
markdown = Markdown . Just
instance ToJSON Format where toEncoding = J.genericToEncoding $ sumTypeJSON fstToLower
instance ToJSON Format where
toJSON = J.genericToJSON $ sumTypeJSON fstToLower
toEncoding = J.genericToEncoding $ sumTypeJSON fstToLower
instance Semigroup Markdown where
m <> (Markdown _ "") = m
@@ -190,9 +210,24 @@ markdownP = mconcat <$> A.many' fragmentP
wordMD :: Text -> Markdown
wordMD s
| T.null s = unmarked s
| isUri s = markdown Uri s
| isUri s = case strDecode $ encodeUtf8 s of
Right cReq -> markdown (simplexUriFormat cReq) s
_ -> markdown Uri s
| isEmail s = markdown Email s
| otherwise = unmarked s
isUri s = T.length s >= 10 && any (`T.isPrefixOf` s) ["http://", "https://", "simplex:/"]
isEmail s = T.any (== '@') s && Email.isValid (encodeUtf8 s)
noFormat = pure . unmarked
simplexUriFormat :: AConnectionRequestUri -> Format
simplexUriFormat = \case
ACR _ (CRContactUri crData) ->
let uri = safeDecodeUtf8 . strEncode $ CRContactUri crData {crScheme = CRSSimplex}
in SimplexLink (linkType' crData) uri $ uriHosts crData
ACR _ (CRInvitationUri crData e2e) ->
let uri = safeDecodeUtf8 . strEncode $ CRInvitationUri crData {crScheme = CRSSimplex} e2e
in SimplexLink XLInvitation uri $ uriHosts crData
where
uriHosts ConnReqUriData {crSmpQueues} = L.map (safeDecodeUtf8 . strEncode) $ sconcat $ L.map (host . qServer) crSmpQueues
linkType' ConnReqUriData {crClientData} = case crClientData >>= decodeJSON of
Just (CRDataGroup _) -> XLGroup
Nothing -> XLContact
+6
View File
@@ -2237,6 +2237,7 @@ testUserContactLinkAutoAccept =
concurrently_
(bob <## "alice (Alice): contact is connected")
(alice <## "bob (Bob): contact is connected")
threadDelay 100000
alice @@@ [("@bob", "Voice messages: enabled")]
alice <##> bob
@@ -2249,6 +2250,7 @@ testUserContactLinkAutoAccept =
concurrently_
(cath <## "alice (Alice): contact is connected")
(alice <## "cath (Catherine): contact is connected")
threadDelay 100000
alice @@@ [("@cath", "Voice messages: enabled"), ("@bob", "hey")]
alice <##> cath
@@ -2263,6 +2265,7 @@ testUserContactLinkAutoAccept =
concurrently_
(dan <## "alice (Alice): contact is connected")
(alice <## "dan (Daniel): contact is connected")
threadDelay 100000
alice @@@ [("@dan", "Voice messages: enabled"), ("@cath", "hey"), ("@bob", "hey")]
alice <##> dan
@@ -2989,6 +2992,7 @@ testUpdateGroupPrefs =
bob <## "updated group preferences:"
bob <## "full message deletion enabled: on"
bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on")])
threadDelay 1000000
alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"off\"}}}"
alice <## "updated group preferences:"
alice <## "full message deletion enabled: off"
@@ -2999,6 +3003,7 @@ testUpdateGroupPrefs =
bob <## "full message deletion enabled: off"
bob <## "voice messages enabled: off"
bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on"), (0, "Full deletion: off"), (0, "Voice messages: off")])
threadDelay 1000000
alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"on\"}}}"
alice <## "updated group preferences:"
alice <## "voice messages enabled: on"
@@ -3007,6 +3012,7 @@ testUpdateGroupPrefs =
bob <## "updated group preferences:"
bob <## "voice messages enabled: on"
bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on"), (0, "Full deletion: off"), (0, "Voice messages: off"), (0, "Voice messages: on")])
threadDelay 1000000
alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"on\"}}}"
-- no update
alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Full deletion: on"), (1, "Full deletion: off"), (1, "Voice messages: off"), (1, "Voice messages: on")])
+13
View File
@@ -1,8 +1,11 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
module MarkdownTests where
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Simplex.Chat.Markdown
import System.Console.ANSI.Types
@@ -134,6 +137,9 @@ textColor = describe "text color (red)" do
uri :: Text -> Markdown
uri = Markdown $ Just Uri
simplexLink :: SimplexLinkType -> Text -> NonEmpty Text -> Text -> Markdown
simplexLink linkType simplexUri smpHosts = Markdown $ Just SimplexLink {linkType, simplexUri, smpHosts}
textWithUri :: Spec
textWithUri = describe "text with Uri" do
it "correct markdown" do
@@ -144,6 +150,13 @@ textWithUri = describe "text with Uri" do
it "ignored as markdown" do
parseMarkdown "_https://simplex.chat" `shouldBe` "_https://simplex.chat"
parseMarkdown "this is _https://simplex.chat" `shouldBe` "this is _https://simplex.chat"
it "SimpleX links" do
let inv = "/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
parseMarkdown ("https://simplex.chat" <> inv) `shouldBe` simplexLink XLInvitation ("simplex:" <> inv) ["smp.simplex.im"] ("https://simplex.chat" <> inv)
let ct = "/contact#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D"
parseMarkdown ("https://simplex.chat" <> ct) `shouldBe` simplexLink XLContact ("simplex:" <> ct) ["smp.simplex.im"] ("https://simplex.chat" <> ct)
let gr = "/contact#/?v=1-2&smp=smp%3A%2F%2Fu2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU%3D%40smp4.simplex.im%2FWHV0YU1sYlU7NqiEHkHDB6gxO1ofTync%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAWbebOqVYuBXaiqHcXYjEHCpYi6VzDlu6CVaijDTmsQU%253D%26srv%3Do5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion&data=%7B%22type%22%3A%22group%22%2C%22groupLinkId%22%3A%22mL-7Divb94GGmGmRBef5Dg%3D%3D%22%7D"
parseMarkdown ("https://simplex.chat" <> gr) `shouldBe` simplexLink XLGroup ("simplex:" <> gr) ["smp4.simplex.im", "o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion"] ("https://simplex.chat" <> gr)
email :: Text -> Markdown
email = Markdown $ Just Email