core, ui: markdown for hyperlinks, warn on unsanitized links, option to sanitize sent links (#6160)

* core: markdown for "hidden" links

* update, test

* api docs

* chatParseUri FFI function

* ios: hyperlinks, offer to open sanitized links, an option to send sanitized links (enabled by default)

* update markdown

* android, desktop: ditto

* ios: export localizations

* core: rename constructor, change Maybe semantics for web links

* rename

src/Simplex/Chat/Markdown.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -12,11 +14,13 @@
 module Simplex.Chat.Markdown where
 
 import Control.Applicative (optional, (<|>))
+import Control.Monad
 import Data.Aeson (FromJSON, ToJSON)
 import qualified Data.Aeson as J
 import qualified Data.Aeson.TH as JQ
 import Data.Attoparsec.Text (Parser)
 import qualified Data.Attoparsec.Text as A
+import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlpha, isAscii, isDigit, isPunctuation, isSpace)
 import Data.Either (fromRight)
 import Data.Functor (($>))
@@ -34,9 +38,10 @@ import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ConnReqUriData (.
 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)
+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
 
 data Markdown = Markdown (Maybe Format) Text | Markdown :|: Markdown
   deriving (Eq, Show)
@@ -49,7 +54,9 @@ data Format
   | Secret
   | Colored {color :: FormatColor}
   | Uri
-  | SimplexLink {linkType :: SimplexLinkType, simplexUri :: AConnectionLink, smpHosts :: NonEmpty Text}
+  -- 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}
   | Command {commandStr :: Text}
   | Mention {memberName :: Text}
   | Email
@@ -187,6 +194,7 @@ markdownP = mconcat <$> A.many' fragmentP
           '!' -> coloredP <|> wordP
           '@' -> mentionP <|> wordP
           '/' -> commandP <|> wordP
+          '[' -> sowLinkP <|> wordP
           _
             | isDigit c -> phoneP <|> wordP
             | otherwise -> wordP
@@ -224,6 +232,20 @@ markdownP = mconcat <$> A.many' fragmentP
       let origStr = if c == '\'' then '\'' `T.cons` str `T.snoc` '\'' else str
           res = markdown (format str) (pfx `T.cons` origStr)
       pure $ if T.null punct then res else res :|: unmarked punct
+    sowLinkP = do
+      t <- '[' `inParens` ']'
+      l <- '(' `inParens` ')'
+      let hasPunct = T.any (\c -> isPunctuation c && c /= '-' && c /= '_') t
+      when (hasPunct && t /= l && ("https://" <> t) /= l) $ fail "punctuation in hyperlink text"
+      f <- case strDecode $ encodeUtf8 l of
+        Right lnk@(ACL _ cLink) -> case cLink of
+          CLShort _ -> pure $ simplexUriFormat (Just t) lnk
+          CLFull _ -> fail "full SimpleX link in hyperlink"
+        Left _ -> case parseUri $ encodeUtf8 l of
+          Right _ -> pure $ HyperLink (Just t) l
+          Left e -> fail $ "not uri: " <> T.unpack e
+      pure $ markdown f $ T.concat ["[", t, "](", l, ")"]
+    inParens open close = A.char open *> A.takeWhile1 (/= close) <* A.char close
     colorP =
       A.anyChar >>= \case
         'r' -> optional "ed" $> Red
@@ -253,7 +275,11 @@ markdownP = mconcat <$> A.many' fragmentP
     wordMD :: Text -> Markdown
     wordMD s
       | T.null s = unmarked s
-      | isUri s' = res $ uriMarkdown s'
+      | isUri s' = case strDecode $ encodeUtf8 s of
+          Right cLink -> res $ markdown (simplexUriFormat Nothing cLink) s'
+          Left _ -> case parseUri $ encodeUtf8 s' of
+            Right _ -> res $ markdown Uri s'
+            Left _ -> unmarked s
       | isDomain s' = res $ markdown Uri s'
       | isEmail s' = res $ markdown Email s'
       | otherwise = unmarked s
@@ -265,9 +291,6 @@ markdownP = mconcat <$> A.many' fragmentP
       '/' -> False
       ')' -> False
       c -> isPunctuation c
-    uriMarkdown s = case strDecode $ encodeUtf8 s of
-      Right cLink -> markdown (simplexUriFormat cLink) s
-      _ -> markdown Uri s
     isUri s = T.length s >= 10 && any (`T.isPrefixOf` s) ["http://", "https://", "simplex:/"]
     -- matches what is likely to be a domain, not all valid domain names
     isDomain s = case T.splitOn "." s of
@@ -281,11 +304,11 @@ markdownP = mconcat <$> A.many' fragmentP
             && (let p c = isAscii c && isAlpha c in T.all p name && T.all p tld)
     isEmail s = T.any (== '@') s && Email.isValid (encodeUtf8 s)
     noFormat = pure . unmarked
-    simplexUriFormat :: AConnectionLink -> Format
-    simplexUriFormat = \case
+    simplexUriFormat :: Maybe Text -> AConnectionLink -> Format
+    simplexUriFormat showText = \case
       ACL m (CLFull cReq) -> case cReq of
-        CRContactUri crData -> SimplexLink (linkType' crData) cLink $ uriHosts crData
-        CRInvitationUri crData _ -> SimplexLink XLInvitation cLink $ uriHosts crData
+        CRContactUri crData -> SimplexLink showText (linkType' crData) cLink $ uriHosts crData
+        CRInvitationUri crData _ -> SimplexLink showText XLInvitation cLink $ uriHosts crData
         where
           cLink = ACL m $ CLFull $ simplexConnReqUri cReq
           uriHosts ConnReqUriData {crSmpQueues} = L.map strEncodeText $ sconcat $ L.map (host . qServer) crSmpQueues
@@ -293,8 +316,8 @@ markdownP = mconcat <$> A.many' fragmentP
             Just (CRDataGroup _) -> XLGroup
             Nothing -> XLContact
       ACL m (CLShort sLnk) -> case sLnk of
-        CSLContact _ ct srv _ -> SimplexLink (linkType' ct) cLink $ uriHosts srv
-        CSLInvitation _ srv _ _ -> SimplexLink XLInvitation cLink $ uriHosts srv
+        CSLContact _ ct srv _ -> SimplexLink showText (linkType' ct) cLink $ uriHosts srv
+        CSLInvitation _ srv _ _ -> SimplexLink showText XLInvitation cLink $ uriHosts srv
         where
           cLink = ACL m $ CLShort $ simplexShortLink sLnk
           uriHosts srv = L.map strEncodeText $ host srv
@@ -305,6 +328,24 @@ markdownP = mconcat <$> A.many' fragmentP
     strEncodeText :: StrEncoding a => a -> Text
     strEncodeText = safeDecodeUtf8 . strEncode
 
+parseUri :: B.ByteString -> Either Text U.URI
+parseUri s = case U.parseURI U.laxURIParserOptions s of
+  Left e -> Left $ "Invalid URI: " <> tshow e
+  Right uri@U.URI {uriScheme = U.Scheme sch, uriAuthority}
+    | sch /= "http" && sch /= "https" -> Left $ "Unsupported URI scheme: " <> safeDecodeUtf8 sch
+    | otherwise -> case uriAuthority of
+        Nothing -> Left "No URI host"
+        Just U.Authority {authorityHost = U.Host h}
+          | '.' `B.notElem` h -> Left $ "Invalid URI host: " <> safeDecodeUtf8 h
+          | otherwise -> Right uri
+
+sanitizeUri :: U.URI -> Maybe U.URI
+sanitizeUri uri@U.URI {uriQuery = U.Query originalQS} =
+  let sanitizedQS = filter (\(p, _) -> p == "q" || p == "search") originalQS
+   in if length sanitizedQS == length originalQS
+        then Nothing
+        else Just $ uri {U.uriQuery = U.Query sanitizedQS}
+
 markdownText :: FormattedText -> Text
 markdownText (FormattedText f_ t) = case f_ of
   Nothing -> t
@@ -316,6 +357,7 @@ markdownText (FormattedText f_ t) = case f_ of
     Secret -> around '#'
     Colored (FormatColor c) -> color c
     Uri -> t
+    HyperLink {} -> t
     SimplexLink {} -> t
     Mention _ -> t
     Command _ -> t