From a7345ee4d96eb7a881d60e4c30d9a1b9927fdd31 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Thu, 24 Nov 2022 13:13:26 +0000 Subject: [PATCH] core: markdown for simplex invitation links (#1408) * core: markdown for simplex invitation links * update markdown for simplex links * update markdown * update * stabilize test --- src/Simplex/Chat/Markdown.hs | 41 +++++++++++++++++++++++++++++++++--- tests/ChatTests.hs | 6 ++++++ tests/MarkdownTests.hs | 13 ++++++++++++ 3 files changed, 57 insertions(+), 3 deletions(-) diff --git a/src/Simplex/Chat/Markdown.hs b/src/Simplex/Chat/Markdown.hs index 6436bc17d9..cfd665c971 100644 --- a/src/Simplex/Chat/Markdown.hs +++ b/src/Simplex/Chat/Markdown.hs @@ -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 diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 2b4cea580d..26db562f0c 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -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")]) diff --git a/tests/MarkdownTests.hs b/tests/MarkdownTests.hs index 1782d74a3f..10fa67a178 100644 --- a/tests/MarkdownTests.hs +++ b/tests/MarkdownTests.hs @@ -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