{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use newtype instead of data" #-}

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 Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isAlpha, isAscii, isDigit, isPunctuation, isSpace)
import Data.Either (fromRight)
import Data.Functor (($>))
import Data.List (foldl', intercalate)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe, isNothing, mapMaybe)
import Data.Semigroup (sconcat)
import Data.String
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.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fstToLower, sumTypeJSON)
import Simplex.Messaging.Protocol (ProtocolServer (..))
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 (Markdown -> Markdown -> Bool
(Markdown -> Markdown -> Bool)
-> (Markdown -> Markdown -> Bool) -> Eq Markdown
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Markdown -> Markdown -> Bool
== :: Markdown -> Markdown -> Bool
$c/= :: Markdown -> Markdown -> Bool
/= :: Markdown -> Markdown -> Bool
Eq, Int -> Markdown -> ShowS
[Markdown] -> ShowS
Markdown -> String
(Int -> Markdown -> ShowS)
-> (Markdown -> String) -> ([Markdown] -> ShowS) -> Show Markdown
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Markdown -> ShowS
showsPrec :: Int -> Markdown -> ShowS
$cshow :: Markdown -> String
show :: Markdown -> String
$cshowList :: [Markdown] -> ShowS
showList :: [Markdown] -> ShowS
Show)

data Format
  = Bold
  | Italic
  | StrikeThrough
  | Snippet
  | Secret
  | Colored {Format -> FormatColor
color :: FormatColor}
  | Uri
  -- showText is Nothing for the usual Uri without text
  | HyperLink {Format -> Maybe Text
showText :: Maybe Text, Format -> Text
linkUri :: Text}
  | SimplexLink {showText :: Maybe Text, Format -> SimplexLinkType
linkType :: SimplexLinkType, Format -> AConnectionLink
simplexUri :: AConnectionLink, Format -> NonEmpty Text
smpHosts :: NonEmpty Text}
  | Command {Format -> Text
commandStr :: Text}
  | Mention {Format -> Text
memberName :: Text}
  | Email
  | Phone
  | Unknown {Format -> Value
json :: J.Value}
  deriving (Format -> Format -> Bool
(Format -> Format -> Bool)
-> (Format -> Format -> Bool) -> Eq Format
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Format -> Format -> Bool
== :: Format -> Format -> Bool
$c/= :: Format -> Format -> Bool
/= :: Format -> Format -> Bool
Eq, Int -> Format -> ShowS
[Format] -> ShowS
Format -> String
(Int -> Format -> ShowS)
-> (Format -> String) -> ([Format] -> ShowS) -> Show Format
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Format -> ShowS
showsPrec :: Int -> Format -> ShowS
$cshow :: Format -> String
show :: Format -> String
$cshowList :: [Format] -> ShowS
showList :: [Format] -> ShowS
Show)

mentionedNames :: MarkdownList -> [Text]
mentionedNames :: MarkdownList -> [Text]
mentionedNames = (FormattedText -> Maybe Text) -> MarkdownList -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(FormattedText Maybe Format
f Text
_) -> Format -> Maybe Text
mentionedName (Format -> Maybe Text) -> Maybe Format -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Format
f)
  where
    mentionedName :: Format -> Maybe Text
mentionedName = \case
      Mention Text
name -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name
      Format
_ -> Maybe Text
forall a. Maybe a
Nothing

data SimplexLinkType = XLContact | XLInvitation | XLGroup | XLChannel | XLRelay
  deriving (SimplexLinkType -> SimplexLinkType -> Bool
(SimplexLinkType -> SimplexLinkType -> Bool)
-> (SimplexLinkType -> SimplexLinkType -> Bool)
-> Eq SimplexLinkType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SimplexLinkType -> SimplexLinkType -> Bool
== :: SimplexLinkType -> SimplexLinkType -> Bool
$c/= :: SimplexLinkType -> SimplexLinkType -> Bool
/= :: SimplexLinkType -> SimplexLinkType -> Bool
Eq, Int -> SimplexLinkType -> ShowS
[SimplexLinkType] -> ShowS
SimplexLinkType -> String
(Int -> SimplexLinkType -> ShowS)
-> (SimplexLinkType -> String)
-> ([SimplexLinkType] -> ShowS)
-> Show SimplexLinkType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SimplexLinkType -> ShowS
showsPrec :: Int -> SimplexLinkType -> ShowS
$cshow :: SimplexLinkType -> String
show :: SimplexLinkType -> String
$cshowList :: [SimplexLinkType] -> ShowS
showList :: [SimplexLinkType] -> ShowS
Show)

colored :: Color -> Format
colored :: Color -> Format
colored = FormatColor -> Format
Colored (FormatColor -> Format)
-> (Color -> FormatColor) -> Color -> Format
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> FormatColor
FormatColor
{-# INLINE colored #-}

markdown :: Format -> Text -> Markdown
markdown :: Format -> Text -> Markdown
markdown = Maybe Format -> Text -> Markdown
Markdown (Maybe Format -> Text -> Markdown)
-> (Format -> Maybe Format) -> Format -> Text -> Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format -> Maybe Format
forall a. a -> Maybe a
Just
{-# INLINE markdown #-}

instance Semigroup Markdown where
  Markdown
m <> :: Markdown -> Markdown -> Markdown
<> (Markdown Maybe Format
_ Text
"") = Markdown
m
  (Markdown Maybe Format
_ Text
"") <> Markdown
m = Markdown
m
  m1 :: Markdown
m1@(Markdown Maybe Format
f1 Text
s1) <> m2 :: Markdown
m2@(Markdown Maybe Format
f2 Text
s2)
    | Maybe Format
f1 Maybe Format -> Maybe Format -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Format
f2 = Maybe Format -> Text -> Markdown
Markdown Maybe Format
f1 (Text -> Markdown) -> Text -> Markdown
forall a b. (a -> b) -> a -> b
$ Text
s1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s2
    | Bool
otherwise = Markdown
m1 Markdown -> Markdown -> Markdown
:|: Markdown
m2
  m1 :: Markdown
m1@(Markdown Maybe Format
f1 Text
s1) <> ms :: Markdown
ms@(Markdown Maybe Format
f2 Text
s2 :|: Markdown
m3)
    | Maybe Format
f1 Maybe Format -> Maybe Format -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Format
f2 = Maybe Format -> Text -> Markdown
Markdown Maybe Format
f1 (Text
s1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s2) Markdown -> Markdown -> Markdown
:|: Markdown
m3
    | Bool
otherwise = Markdown
m1 Markdown -> Markdown -> Markdown
:|: Markdown
ms
  ms :: Markdown
ms@(Markdown
m1 :|: Markdown Maybe Format
f2 Text
s2) <> m3 :: Markdown
m3@(Markdown Maybe Format
f3 Text
s3)
    | Maybe Format
f2 Maybe Format -> Maybe Format -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Format
f3 = Markdown
m1 Markdown -> Markdown -> Markdown
:|: Maybe Format -> Text -> Markdown
Markdown Maybe Format
f2 (Text
s2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s3)
    | Bool
otherwise = Markdown
ms Markdown -> Markdown -> Markdown
:|: Markdown
m3
  Markdown
m1 <> Markdown
m2 = Markdown
m1 Markdown -> Markdown -> Markdown
:|: Markdown
m2

instance Monoid Markdown where mempty :: Markdown
mempty = Text -> Markdown
unmarked Text
""

instance IsString Markdown where fromString :: String -> Markdown
fromString = Text -> Markdown
unmarked (Text -> Markdown) -> (String -> Text) -> String -> Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

newtype FormatColor = FormatColor Color
  deriving (FormatColor -> FormatColor -> Bool
(FormatColor -> FormatColor -> Bool)
-> (FormatColor -> FormatColor -> Bool) -> Eq FormatColor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FormatColor -> FormatColor -> Bool
== :: FormatColor -> FormatColor -> Bool
$c/= :: FormatColor -> FormatColor -> Bool
/= :: FormatColor -> FormatColor -> Bool
Eq, Int -> FormatColor -> ShowS
[FormatColor] -> ShowS
FormatColor -> String
(Int -> FormatColor -> ShowS)
-> (FormatColor -> String)
-> ([FormatColor] -> ShowS)
-> Show FormatColor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FormatColor -> ShowS
showsPrec :: Int -> FormatColor -> ShowS
$cshow :: FormatColor -> String
show :: FormatColor -> String
$cshowList :: [FormatColor] -> ShowS
showList :: [FormatColor] -> ShowS
Show)

instance FromJSON FormatColor where
  parseJSON :: Value -> Parser FormatColor
parseJSON =
    String
-> (Text -> Parser FormatColor) -> Value -> Parser FormatColor
forall a. String -> (Text -> Parser a) -> Value -> Parser a
J.withText String
"FormatColor" ((Text -> Parser FormatColor) -> Value -> Parser FormatColor)
-> (Text -> Parser FormatColor) -> Value -> Parser FormatColor
forall a b. (a -> b) -> a -> b
$
      (Color -> FormatColor) -> Parser Color -> Parser FormatColor
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Color -> FormatColor
FormatColor (Parser Color -> Parser FormatColor)
-> (Text -> Parser Color) -> Text -> Parser FormatColor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
        Text
"red" -> Color -> Parser Color
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color
Red
        Text
"green" -> Color -> Parser Color
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color
Green
        Text
"blue" -> Color -> Parser Color
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color
Blue
        Text
"yellow" -> Color -> Parser Color
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color
Yellow
        Text
"cyan" -> Color -> Parser Color
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color
Cyan
        Text
"magenta" -> Color -> Parser Color
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color
Magenta
        Text
"black" -> Color -> Parser Color
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color
Black
        Text
"white" -> Color -> Parser Color
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color
White
        Text
unexpected -> String -> Parser Color
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Color) -> String -> Parser Color
forall a b. (a -> b) -> a -> b
$ String
"unexpected FormatColor: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
unexpected

instance ToJSON FormatColor where
  toJSON :: FormatColor -> Value
toJSON (FormatColor Color
c) = case Color
c of
    Color
Red -> Value
"red"
    Color
Green -> Value
"green"
    Color
Blue -> Value
"blue"
    Color
Yellow -> Value
"yellow"
    Color
Cyan -> Value
"cyan"
    Color
Magenta -> Value
"magenta"
    Color
Black -> Value
"black"
    Color
White -> Value
"white"

data FormattedText = FormattedText {FormattedText -> Maybe Format
format :: Maybe Format, FormattedText -> Text
text :: Text}
  deriving (FormattedText -> FormattedText -> Bool
(FormattedText -> FormattedText -> Bool)
-> (FormattedText -> FormattedText -> Bool) -> Eq FormattedText
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FormattedText -> FormattedText -> Bool
== :: FormattedText -> FormattedText -> Bool
$c/= :: FormattedText -> FormattedText -> Bool
/= :: FormattedText -> FormattedText -> Bool
Eq, Int -> FormattedText -> ShowS
MarkdownList -> ShowS
FormattedText -> String
(Int -> FormattedText -> ShowS)
-> (FormattedText -> String)
-> (MarkdownList -> ShowS)
-> Show FormattedText
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FormattedText -> ShowS
showsPrec :: Int -> FormattedText -> ShowS
$cshow :: FormattedText -> String
show :: FormattedText -> String
$cshowList :: MarkdownList -> ShowS
showList :: MarkdownList -> ShowS
Show)

instance IsString FormattedText where
  fromString :: String -> FormattedText
fromString = Maybe Format -> Text -> FormattedText
FormattedText Maybe Format
forall a. Maybe a
Nothing (Text -> FormattedText)
-> (String -> Text) -> String -> FormattedText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

type MarkdownList = [FormattedText]

data ParsedMarkdown = ParsedMarkdown {ParsedMarkdown -> Maybe MarkdownList
formattedText :: Maybe MarkdownList}

unmarked :: Text -> Markdown
unmarked :: Text -> Markdown
unmarked = Maybe Format -> Text -> Markdown
Markdown Maybe Format
forall a. Maybe a
Nothing

parseMaybeMarkdownList :: Text -> Maybe MarkdownList
parseMaybeMarkdownList :: Text -> Maybe MarkdownList
parseMaybeMarkdownList Text
s = case [Text]
ls of
  [] -> Maybe MarkdownList
forall a. Maybe a
Nothing
  [Text
l]
    | Text -> Bool
T.null Text
cmd -> Maybe MarkdownList
forall a. Maybe a
Nothing
    | Bool
isCmd -> MarkdownList -> Maybe MarkdownList
forall a. a -> Maybe a
Just [Maybe Format -> Text -> FormattedText
FormattedText (Format -> Maybe Format
forall a. a -> Maybe a
Just (Format -> Maybe Format) -> Format -> Maybe Format
forall a b. (a -> b) -> a -> b
$ Text -> Format
Command Text
cmd) Text
l]
    where
      (Bool
isCmd, Text
cmd) = case Text -> Maybe (Char, Text)
T.uncons (Text -> Maybe (Char, Text)) -> Text -> Maybe (Char, Text)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Text
l of
        Just (Char
c, Text
rest) -> (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/', Text
rest)
        Maybe (Char, Text)
Nothing -> (Bool
False, Text
"")
  [Text]
_
    | (FormattedText -> Bool) -> MarkdownList -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe Format -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Format -> Bool)
-> (FormattedText -> Maybe Format) -> FormattedText -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormattedText -> Maybe Format
format) MarkdownList
ml -> Maybe MarkdownList
forall a. Maybe a
Nothing
    | Bool
otherwise -> MarkdownList -> Maybe MarkdownList
forall a. a -> Maybe a
Just (MarkdownList -> Maybe MarkdownList)
-> (MarkdownList -> MarkdownList)
-> MarkdownList
-> Maybe MarkdownList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarkdownList -> MarkdownList
forall a. [a] -> [a]
reverse (MarkdownList -> Maybe MarkdownList)
-> MarkdownList -> Maybe MarkdownList
forall a b. (a -> b) -> a -> b
$ (MarkdownList -> FormattedText -> MarkdownList)
-> MarkdownList -> MarkdownList -> MarkdownList
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' MarkdownList -> FormattedText -> MarkdownList
acc [] MarkdownList
ml
  where
    ls :: [Text]
ls = Text -> [Text]
T.lines Text
s
    ml :: MarkdownList
ml = MarkdownList -> [MarkdownList] -> MarkdownList
forall a. [a] -> [[a]] -> [a]
intercalate [FormattedText
"\n"] ([MarkdownList] -> MarkdownList) -> [MarkdownList] -> MarkdownList
forall a b. (a -> b) -> a -> b
$ (Text -> MarkdownList) -> [Text] -> [MarkdownList]
forall a b. (a -> b) -> [a] -> [b]
map (Markdown -> MarkdownList
markdownToList (Markdown -> MarkdownList)
-> (Text -> Markdown) -> Text -> MarkdownList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Markdown
parseMarkdown) [Text]
ls
    acc :: MarkdownList -> FormattedText -> MarkdownList
acc [] FormattedText
m = [FormattedText
m]
    acc ms :: MarkdownList
ms@(FormattedText Maybe Format
f Text
t : MarkdownList
ms') ft :: FormattedText
ft@(FormattedText Maybe Format
f' Text
t')
      | Maybe Format
f Maybe Format -> Maybe Format -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Format
f' = Maybe Format -> Text -> FormattedText
FormattedText Maybe Format
f (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t') FormattedText -> MarkdownList -> MarkdownList
forall a. a -> [a] -> [a]
: MarkdownList
ms'
      | Bool
otherwise = FormattedText
ft FormattedText -> MarkdownList -> MarkdownList
forall a. a -> [a] -> [a]
: MarkdownList
ms

parseMarkdownList :: Text -> MarkdownList
parseMarkdownList :: Text -> MarkdownList
parseMarkdownList = Markdown -> MarkdownList
markdownToList (Markdown -> MarkdownList)
-> (Text -> Markdown) -> Text -> MarkdownList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Markdown
parseMarkdown

markdownToList :: Markdown -> MarkdownList
markdownToList :: Markdown -> MarkdownList
markdownToList (Markdown Maybe Format
f Text
s) = [Maybe Format -> Text -> FormattedText
FormattedText Maybe Format
f Text
s]
markdownToList (Markdown
m1 :|: Markdown
m2) = Markdown -> MarkdownList
markdownToList Markdown
m1 MarkdownList -> MarkdownList -> MarkdownList
forall a. Semigroup a => a -> a -> a
<> Markdown -> MarkdownList
markdownToList Markdown
m2

parseMarkdown :: Text -> Markdown
parseMarkdown :: Text -> Markdown
parseMarkdown Text
s = Markdown -> Either String Markdown -> Markdown
forall b a. b -> Either a b -> b
fromRight (Text -> Markdown
unmarked Text
s) (Either String Markdown -> Markdown)
-> Either String Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ Parser Markdown -> Text -> Either String Markdown
forall a. Parser a -> Text -> Either String a
A.parseOnly (Parser Markdown
markdownP Parser Markdown -> Parser Text () -> Parser Markdown
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
A.endOfInput) Text
s

isSimplexLink :: Format -> Bool
isSimplexLink :: Format -> Bool
isSimplexLink = \case
  SimplexLink {} -> Bool
True
  Format
_ -> Bool
False

markdownP :: Parser Markdown
markdownP :: Parser Markdown
markdownP = [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat ([Markdown] -> Markdown)
-> Parser Text [Markdown] -> Parser Markdown
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Markdown -> Parser Text [Markdown]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
A.many' Parser Markdown
fragmentP
  where
    fragmentP :: Parser Markdown
    fragmentP :: Parser Markdown
fragmentP =
      Parser (Maybe Char)
A.peekChar Parser (Maybe Char)
-> (Maybe Char -> Parser Markdown) -> Parser Markdown
forall a b. Parser Text a -> (a -> Parser Text b) -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Char
c -> case Char
c of
          Char
' ' -> Text -> Markdown
unmarked (Text -> Markdown) -> Parser Text Text -> Parser Markdown
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
A.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
          Char
'+' -> Parser Markdown
phoneP Parser Markdown -> Parser Markdown -> Parser Markdown
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Markdown
wordP
          Char
'*' -> Char -> Format -> Parser Markdown
formattedP Char
'*' Format
Bold
          Char
'_' -> Char -> Format -> Parser Markdown
formattedP Char
'_' Format
Italic
          Char
'~' -> Char -> Format -> Parser Markdown
formattedP Char
'~' Format
StrikeThrough
          Char
'`' -> Char -> Format -> Parser Markdown
formattedP Char
'`' Format
Snippet
          Char
'#' -> Char -> Parser Char
A.char Char
'#' Parser Char -> Parser Markdown -> Parser Markdown
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Markdown
secretP
          Char
'!' -> Parser Markdown
coloredP Parser Markdown -> Parser Markdown -> Parser Markdown
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Markdown
wordP
          Char
'@' -> Parser Markdown
mentionP Parser Markdown -> Parser Markdown -> Parser Markdown
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Markdown
wordP
          Char
'/' -> Parser Markdown
commandP Parser Markdown -> Parser Markdown -> Parser Markdown
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Markdown
wordP
          Char
'[' -> Parser Markdown
sowLinkP Parser Markdown -> Parser Markdown -> Parser Markdown
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Markdown
wordP
          Char
_
            | Char -> Bool
isDigit Char
c -> Parser Markdown
phoneP Parser Markdown -> Parser Markdown -> Parser Markdown
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Markdown
wordP
            | Bool
otherwise -> Parser Markdown
wordP
        Maybe Char
Nothing -> String -> Parser Markdown
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
""
    formattedP :: Char -> Format -> Parser Markdown
    formattedP :: Char -> Format -> Parser Markdown
formattedP Char
c Format
f = do
      Text
s <- Char -> Parser Char
A.char Char
c Parser Char -> Parser Text Text -> Parser Text Text
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text Text
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
      (Char -> Parser Char
A.char Char
c Parser Char -> Markdown -> Parser Markdown
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char -> Format -> Text -> Markdown
md Char
c Format
f Text
s) Parser Markdown -> Parser Markdown -> Parser Markdown
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Markdown
noFormat (Char
c Char -> Text -> Text
`T.cons` Text
s)
    md :: Char -> Format -> Text -> Markdown
    md :: Char -> Format -> Text -> Markdown
md Char
c Format
f Text
s
      | Text -> Bool
T.null Text
s Bool -> Bool -> Bool
|| HasCallStack => Text -> Char
Text -> Char
T.head Text
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| HasCallStack => Text -> Char
Text -> Char
T.last Text
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' =
          Text -> Markdown
unmarked (Text -> Markdown) -> Text -> Markdown
forall a b. (a -> b) -> a -> b
$ Char
c Char -> Text -> Text
`T.cons` Text
s Text -> Char -> Text
`T.snoc` Char
c
      | Bool
otherwise = Format -> Text -> Markdown
markdown Format
f Text
s
    secretP :: Parser Markdown
    secretP :: Parser Markdown
secretP = Text -> Text -> Text -> Markdown
secret (Text -> Text -> Text -> Markdown)
-> Parser Text Text -> Parser Text (Text -> Text -> Markdown)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
A.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#') Parser Text (Text -> Text -> Markdown)
-> Parser Text Text -> Parser Text (Text -> Markdown)
forall a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Bool) -> Parser Text Text
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#') Parser Text (Text -> Markdown)
-> Parser Text Text -> Parser Markdown
forall a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Bool) -> Parser Text Text
A.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#')
    secret :: Text -> Text -> Text -> Markdown
    secret :: Text -> Text -> Text -> Markdown
secret Text
b Text
s Text
a
      | Text -> Bool
T.null Text
a Bool -> Bool -> Bool
|| Text -> Bool
T.null Text
s Bool -> Bool -> Bool
|| HasCallStack => Text -> Char
Text -> Char
T.head Text
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| HasCallStack => Text -> Char
Text -> Char
T.last Text
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' =
          Text -> Markdown
unmarked (Text -> Markdown) -> Text -> Markdown
forall a b. (a -> b) -> a -> b
$ Char
'#' Char -> Text -> Text
`T.cons` Text
ss
      | Bool
otherwise = Format -> Text -> Markdown
markdown Format
Secret (Text -> Markdown) -> Text -> Markdown
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text
Text -> Text
T.init Text
ss
      where
        ss :: Text
ss = Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a
    coloredP :: Parser Markdown
    coloredP :: Parser Markdown
coloredP = do
      Color
clr <- Char -> Parser Char
A.char Char
'!' Parser Char -> Parser Text Color -> Parser Text Color
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Color
colorP Parser Text Color -> Parser Char -> Parser Text Color
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char
A.space
      Text
s <- (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) (Text -> Text -> Text)
-> Parser Text Text -> Parser Text (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
A.takeWhile1 (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'!') Parser Text (Text -> Text) -> Parser Text Text -> Parser Text Text
forall a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Bool) -> Parser Text Text
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'!')) Parser Text Text -> Parser Char -> Parser Text Text
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
A.char Char
'!'
      if Text -> Bool
T.null Text
s Bool -> Bool -> Bool
|| HasCallStack => Text -> Char
Text -> Char
T.last Text
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
        then String -> Parser Markdown
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not colored"
        else Markdown -> Parser Markdown
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Markdown -> Parser Markdown) -> Markdown -> Parser Markdown
forall a b. (a -> b) -> a -> b
$ Format -> Text -> Markdown
markdown (Color -> Format
colored Color
clr) Text
s
    mentionP :: Parser Markdown
mentionP = Char
-> Parser Text (Text, Text) -> (Text -> Format) -> Parser Markdown
prefixedStringP Char
'@' Parser Text (Text, Text)
displayNameTextP_ Text -> Format
Mention
    commandP :: Parser Markdown
commandP = Char
-> Parser Text (Text, Text) -> (Text -> Format) -> Parser Markdown
prefixedStringP Char
'/' Parser Text (Text, Text)
commandTextP Text -> Format
Command
    prefixedStringP :: Char
-> Parser Text (Text, Text) -> (Text -> Format) -> Parser Markdown
prefixedStringP Char
pfx Parser Text (Text, Text)
parser Text -> Format
format = do
      Char
c <- Char -> Parser Char
A.char Char
pfx Parser Char -> Parser Char -> Parser Char
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char
A.peekChar'
      (Text
str, Text
punct) <- Parser Text (Text, Text)
parser
      let origStr :: Text
origStr = if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' then Char
'\'' Char -> Text -> Text
`T.cons` Text
str Text -> Char -> Text
`T.snoc` Char
'\'' else Text
str
          res :: Markdown
res = Format -> Text -> Markdown
markdown (Text -> Format
format Text
str) (Char
pfx Char -> Text -> Text
`T.cons` Text
origStr)
      Markdown -> Parser Markdown
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Markdown -> Parser Markdown) -> Markdown -> Parser Markdown
forall a b. (a -> b) -> a -> b
$ if Text -> Bool
T.null Text
punct then Markdown
res else Markdown
res Markdown -> Markdown -> Markdown
:|: Text -> Markdown
unmarked Text
punct
    sowLinkP :: Parser Markdown
sowLinkP = do
      Text
t <- Char
'[' Char -> Char -> Parser Text Text
`inParens` Char
']'
      Text
l <- Char
'(' Char -> Char -> Parser Text Text
`inParens` Char
')'
      let hasPunct :: Bool
hasPunct = (Char -> Bool) -> Text -> Bool
T.any (\Char
c -> Char -> Bool
isPunctuation Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') Text
t
      Bool -> Parser Text () -> Parser Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasPunct Bool -> Bool -> Bool
&& Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
l Bool -> Bool -> Bool
&& (Text
"https://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
l) (Parser Text () -> Parser Text ())
-> Parser Text () -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ String -> Parser Text ()
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"punctuation in hyperlink text"
      Format
f <- case ByteString -> Either String AConnectionLink
forall a. StrEncoding a => ByteString -> Either String a
strDecode (ByteString -> Either String AConnectionLink)
-> ByteString -> Either String AConnectionLink
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
l of
        Right lnk :: AConnectionLink
lnk@(ACL SConnectionMode m
_ ConnectionLink m
cLink) -> case ConnectionLink m
cLink of
          CLShort ConnShortLink m
_ -> Format -> Parser Text Format
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Format -> Parser Text Format) -> Format -> Parser Text Format
forall a b. (a -> b) -> a -> b
$ Maybe Text -> AConnectionLink -> Format
simplexUriFormat (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t) AConnectionLink
lnk
          CLFull ConnectionRequestUri m
_ -> String -> Parser Text Format
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"full SimpleX link in hyperlink"
        Left String
_ -> case ByteString -> Either Text URI
parseUri (ByteString -> Either Text URI) -> ByteString -> Either Text URI
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
l of
          Right URI
_ -> Format -> Parser Text Format
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Format -> Parser Text Format) -> Format -> Parser Text Format
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Text -> Format
HyperLink (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t) Text
l
          Left Text
e -> String -> Parser Text Format
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Text Format) -> String -> Parser Text Format
forall a b. (a -> b) -> a -> b
$ String
"not uri: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
e
      Markdown -> Parser Markdown
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Markdown -> Parser Markdown) -> Markdown -> Parser Markdown
forall a b. (a -> b) -> a -> b
$ Format -> Text -> Markdown
markdown Format
f (Text -> Markdown) -> Text -> Markdown
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"[", Text
t, Text
"](", Text
l, Text
")"]
    inParens :: Char -> Char -> Parser Text Text
inParens Char
open Char
close = Char -> Parser Char
A.char Char
open Parser Char -> Parser Text Text -> Parser Text Text
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text Text
A.takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
close) Parser Text Text -> Parser Char -> Parser Text Text
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
A.char Char
close
    colorP :: Parser Text Color
colorP =
      Parser Char
A.anyChar Parser Char -> (Char -> Parser Text Color) -> Parser Text Color
forall a b. Parser Text a -> (a -> Parser Text b) -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Char
'r' -> Parser Text Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text Text
"ed" Parser Text (Maybe Text) -> Color -> Parser Text Color
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Color
Red
        Char
'g' -> Parser Text Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text Text
"reen" Parser Text (Maybe Text) -> Color -> Parser Text Color
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Color
Green
        Char
'b' -> Parser Text Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text Text
"lue" Parser Text (Maybe Text) -> Color -> Parser Text Color
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Color
Blue
        Char
'y' -> Parser Text Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text Text
"ellow" Parser Text (Maybe Text) -> Color -> Parser Text Color
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Color
Yellow
        Char
'c' -> Parser Text Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text Text
"yan" Parser Text (Maybe Text) -> Color -> Parser Text Color
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Color
Cyan
        Char
'm' -> Parser Text Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text Text
"agenta" Parser Text (Maybe Text) -> Color -> Parser Text Color
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Color
Magenta
        Char
'1' -> Color -> Parser Text Color
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color
Red
        Char
'2' -> Color -> Parser Text Color
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color
Green
        Char
'3' -> Color -> Parser Text Color
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color
Blue
        Char
'4' -> Color -> Parser Text Color
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color
Yellow
        Char
'5' -> Color -> Parser Text Color
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color
Cyan
        Char
'6' -> Color -> Parser Text Color
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color
Magenta
        Char
_ -> String -> Parser Text Color
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not color"
    phoneP :: Parser Markdown
phoneP = do
      Maybe Text
country <- Parser Text Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Text Text -> Parser Text (Maybe Text))
-> Parser Text Text -> Parser Text (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
T.cons (Char -> Text -> Text) -> Parser Char -> Parser Text (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Char
A.char Char
'+' Parser Text (Text -> Text) -> Parser Text Text -> Parser Text Text
forall a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Bool) -> Parser Text Text
A.takeWhile1 Char -> Bool
isDigit
      Maybe Text
code <- Parser Text Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Text Text -> Parser Text (Maybe Text))
-> Parser Text Text -> Parser Text (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text -> Text
forall {a}. Semigroup a => a -> a -> a -> a -> a
conc4 (Text -> Text -> Text -> Text -> Text)
-> Parser Text Text -> Parser Text (Text -> Text -> Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text
phoneSep Parser Text (Text -> Text -> Text -> Text)
-> Parser Text Text -> Parser Text (Text -> Text -> Text)
forall a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Text
"(" Parser Text (Text -> Text -> Text)
-> Parser Text Text -> Parser Text (Text -> Text)
forall a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Bool) -> Parser Text Text
A.takeWhile1 Char -> Bool
isDigit Parser Text (Text -> Text) -> Parser Text Text -> Parser Text Text
forall a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Text
")"
      Text
segments <- [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> Parser Text [Text] -> Parser Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text -> Parser Text [Text]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
A.many' (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) (Text -> Text -> Text)
-> Parser Text Text -> Parser Text (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text
phoneSep Parser Text (Text -> Text) -> Parser Text Text -> Parser Text Text
forall a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Bool) -> Parser Text Text
A.takeWhile1 Char -> Bool
isDigit)
      let s :: Text
s = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
country Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
code Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
segments
          len :: Int
len = Text -> Int
T.length Text
s
      if Int
7 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len Bool -> Bool -> Bool
&& Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
22 then Markdown -> Parser Markdown
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Markdown -> Parser Markdown) -> Markdown -> Parser Markdown
forall a b. (a -> b) -> a -> b
$ Format -> Text -> Markdown
markdown Format
Phone Text
s else String -> Parser Markdown
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not phone"
    conc4 :: a -> a -> a -> a -> a
conc4 a
s1 a
s2 a
s3 a
s4 = a
s1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s2 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s3 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s4
    phoneSep :: Parser Text Text
phoneSep = Parser Text Text
" " Parser Text Text -> Parser Text Text -> Parser Text Text
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Text
"-" Parser Text Text -> Parser Text Text -> Parser Text Text
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Text
"." Parser Text Text -> Parser Text Text -> Parser Text Text
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Text
""
    wordP :: Parser Markdown
    wordP :: Parser Markdown
wordP = Text -> Markdown
wordMD (Text -> Markdown) -> Parser Text Text -> Parser Markdown
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
    wordMD :: Text -> Markdown
    wordMD :: Text -> Markdown
wordMD Text
s
      | Text -> Bool
T.null Text
s = Text -> Markdown
unmarked Text
s
      | Text -> Bool
isUri Text
s' = case ByteString -> Either String AConnectionLink
forall a. StrEncoding a => ByteString -> Either String a
strDecode (ByteString -> Either String AConnectionLink)
-> ByteString -> Either String AConnectionLink
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
s of
          Right AConnectionLink
cLink -> Markdown -> Markdown
res (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ Format -> Text -> Markdown
markdown (Maybe Text -> AConnectionLink -> Format
simplexUriFormat Maybe Text
forall a. Maybe a
Nothing AConnectionLink
cLink) Text
s'
          Left String
_ -> case ByteString -> Either Text URI
parseUri (ByteString -> Either Text URI) -> ByteString -> Either Text URI
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
s' of
            Right URI
_ -> Markdown -> Markdown
res (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ Format -> Text -> Markdown
markdown Format
Uri Text
s'
            Left Text
_ -> Text -> Markdown
unmarked Text
s
      | Text -> Bool
isDomain Text
s' = Markdown -> Markdown
res (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ Format -> Text -> Markdown
markdown Format
Uri Text
s'
      | Text -> Bool
isEmail Text
s' = Markdown -> Markdown
res (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ Format -> Text -> Markdown
markdown Format
Email Text
s'
      | Bool
otherwise = Text -> Markdown
unmarked Text
s
      where
        punct :: Text
punct = (Char -> Bool) -> Text -> Text
T.takeWhileEnd Char -> Bool
isPunctuation' Text
s
        s' :: Text
s' = (Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isPunctuation' Text
s
        res :: Markdown -> Markdown
res Markdown
md' = if Text -> Bool
T.null Text
punct then Markdown
md' else Markdown
md' Markdown -> Markdown -> Markdown
:|: Text -> Markdown
unmarked Text
punct
    isPunctuation' :: Char -> Bool
isPunctuation' = \case
      Char
'/' -> Bool
False
      Char
')' -> Bool
False
      Char
c -> Char -> Bool
isPunctuation Char
c
    isUri :: Text -> Bool
isUri Text
s = Text -> Int
T.length Text
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10 Bool -> Bool -> Bool
&& (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text
s) [Text
"http://", Text
"https://", Text
"simplex:/"]
    -- matches what is likely to be a domain, not all valid domain names
    isDomain :: Text -> Bool
isDomain Text
s = case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
s of
      [Text
name, Text
tld] -> Text -> Text -> Bool
isDomain_ Text
name Text
tld
      [Text
sub, Text
name, Text
tld] -> Text -> Int
T.length Text
sub Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3 Bool -> Bool -> Bool
&& Text -> Int
T.length Text
sub Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8 Bool -> Bool -> Bool
&& Text -> Text -> Bool
isDomain_ Text
name Text
tld
      [Text]
_ -> Bool
False
      where
        isDomain_ :: Text -> Text -> Bool
isDomain_ Text
name Text
tld =
          (let n :: Int
n = Text -> Int
T.length Text
name in Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
24)
            Bool -> Bool -> Bool
&& (let n :: Int
n = Text -> Int
T.length Text
tld in Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8)
            Bool -> Bool -> Bool
&& (let p :: Char -> Bool
p Char
c = Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isAlpha Char
c in (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
p Text
name Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
p Text
tld)
    isEmail :: Text -> Bool
isEmail Text
s = (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'@') Text
s Bool -> Bool -> Bool
&& ByteString -> Bool
Email.isValid (Text -> ByteString
encodeUtf8 Text
s)
    noFormat :: Text -> Parser Markdown
noFormat = Markdown -> Parser Markdown
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Markdown -> Parser Markdown)
-> (Text -> Markdown) -> Text -> Parser Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Markdown
unmarked
    simplexUriFormat :: Maybe Text -> AConnectionLink -> Format
    simplexUriFormat :: Maybe Text -> AConnectionLink -> Format
simplexUriFormat Maybe Text
showText = \case
      ACL SConnectionMode m
m (CLFull ConnectionRequestUri m
cReq) -> case ConnectionRequestUri m
cReq of
        CRContactUri ConnReqUriData
crData -> Maybe Text
-> SimplexLinkType -> AConnectionLink -> NonEmpty Text -> Format
SimplexLink Maybe Text
showText (ConnReqUriData -> SimplexLinkType
linkType' ConnReqUriData
crData) AConnectionLink
cLink (NonEmpty Text -> Format) -> NonEmpty Text -> Format
forall a b. (a -> b) -> a -> b
$ ConnReqUriData -> NonEmpty Text
uriHosts ConnReqUriData
crData
        CRInvitationUri ConnReqUriData
crData RcvE2ERatchetParamsUri 'X448
_ -> Maybe Text
-> SimplexLinkType -> AConnectionLink -> NonEmpty Text -> Format
SimplexLink Maybe Text
showText SimplexLinkType
XLInvitation AConnectionLink
cLink (NonEmpty Text -> Format) -> NonEmpty Text -> Format
forall a b. (a -> b) -> a -> b
$ ConnReqUriData -> NonEmpty Text
uriHosts ConnReqUriData
crData
        where
          cLink :: AConnectionLink
cLink = SConnectionMode m -> ConnectionLink m -> AConnectionLink
forall (m :: ConnectionMode).
ConnectionModeI m =>
SConnectionMode m -> ConnectionLink m -> AConnectionLink
ACL SConnectionMode m
m (ConnectionLink m -> AConnectionLink)
-> ConnectionLink m -> AConnectionLink
forall a b. (a -> b) -> a -> b
$ ConnectionRequestUri m -> ConnectionLink m
forall (m :: ConnectionMode).
ConnectionRequestUri m -> ConnectionLink m
CLFull (ConnectionRequestUri m -> ConnectionLink m)
-> ConnectionRequestUri m -> ConnectionLink m
forall a b. (a -> b) -> a -> b
$ ConnectionRequestUri m -> ConnectionRequestUri m
forall (m :: ConnectionMode).
ConnectionRequestUri m -> ConnectionRequestUri m
simplexConnReqUri ConnectionRequestUri m
cReq
          uriHosts :: ConnReqUriData -> NonEmpty Text
uriHosts ConnReqUriData {NonEmpty SMPQueueUri
crSmpQueues :: NonEmpty SMPQueueUri
crSmpQueues :: ConnReqUriData -> NonEmpty SMPQueueUri
crSmpQueues} = (TransportHost -> Text) -> NonEmpty TransportHost -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map TransportHost -> Text
forall a. StrEncoding a => a -> Text
strEncodeText (NonEmpty TransportHost -> NonEmpty Text)
-> NonEmpty TransportHost -> NonEmpty Text
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty TransportHost) -> NonEmpty TransportHost
forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty (NonEmpty TransportHost) -> NonEmpty TransportHost)
-> NonEmpty (NonEmpty TransportHost) -> NonEmpty TransportHost
forall a b. (a -> b) -> a -> b
$ (SMPQueueUri -> NonEmpty TransportHost)
-> NonEmpty SMPQueueUri -> NonEmpty (NonEmpty TransportHost)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (ProtocolServer 'PSMP -> NonEmpty TransportHost
forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host (ProtocolServer 'PSMP -> NonEmpty TransportHost)
-> (SMPQueueUri -> ProtocolServer 'PSMP)
-> SMPQueueUri
-> NonEmpty TransportHost
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPQueueUri -> ProtocolServer 'PSMP
forall q. SMPQueue q => q -> ProtocolServer 'PSMP
qServer) NonEmpty SMPQueueUri
crSmpQueues
          linkType' :: ConnReqUriData -> SimplexLinkType
linkType' ConnReqUriData {Maybe Text
crClientData :: Maybe Text
crClientData :: ConnReqUriData -> Maybe Text
crClientData} = case Maybe Text
crClientData Maybe Text
-> (Text -> Maybe CReqClientData) -> Maybe CReqClientData
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe CReqClientData
forall a. FromJSON a => Text -> Maybe a
decodeJSON of
            Just (CRDataGroup GroupLinkId
_) -> SimplexLinkType
XLGroup
            Maybe CReqClientData
Nothing -> SimplexLinkType
XLContact
      ACL SConnectionMode m
m (CLShort ConnShortLink m
sLnk) -> case ConnShortLink m
sLnk of
        CSLContact ShortLinkScheme
_ ContactConnType
ct ProtocolServer 'PSMP
srv LinkKey
_ -> Maybe Text
-> SimplexLinkType -> AConnectionLink -> NonEmpty Text -> Format
SimplexLink Maybe Text
showText (ContactConnType -> SimplexLinkType
linkType' ContactConnType
ct) AConnectionLink
cLink (NonEmpty Text -> Format) -> NonEmpty Text -> Format
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PSMP -> NonEmpty Text
forall {p :: ProtocolType}. ProtocolServer p -> NonEmpty Text
uriHosts ProtocolServer 'PSMP
srv
        CSLInvitation ShortLinkScheme
_ ProtocolServer 'PSMP
srv LinkId
_ LinkKey
_ -> Maybe Text
-> SimplexLinkType -> AConnectionLink -> NonEmpty Text -> Format
SimplexLink Maybe Text
showText SimplexLinkType
XLInvitation AConnectionLink
cLink (NonEmpty Text -> Format) -> NonEmpty Text -> Format
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PSMP -> NonEmpty Text
forall {p :: ProtocolType}. ProtocolServer p -> NonEmpty Text
uriHosts ProtocolServer 'PSMP
srv
        where
          cLink :: AConnectionLink
cLink = SConnectionMode m -> ConnectionLink m -> AConnectionLink
forall (m :: ConnectionMode).
ConnectionModeI m =>
SConnectionMode m -> ConnectionLink m -> AConnectionLink
ACL SConnectionMode m
m (ConnectionLink m -> AConnectionLink)
-> ConnectionLink m -> AConnectionLink
forall a b. (a -> b) -> a -> b
$ ConnShortLink m -> ConnectionLink m
forall (m :: ConnectionMode). ConnShortLink m -> ConnectionLink m
CLShort (ConnShortLink m -> ConnectionLink m)
-> ConnShortLink m -> ConnectionLink m
forall a b. (a -> b) -> a -> b
$ ConnShortLink m -> ConnShortLink m
forall (m :: ConnectionMode). ConnShortLink m -> ConnShortLink m
simplexShortLink ConnShortLink m
sLnk
          uriHosts :: ProtocolServer p -> NonEmpty Text
uriHosts ProtocolServer p
srv = (TransportHost -> Text) -> NonEmpty TransportHost -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map TransportHost -> Text
forall a. StrEncoding a => a -> Text
strEncodeText (NonEmpty TransportHost -> NonEmpty Text)
-> NonEmpty TransportHost -> NonEmpty Text
forall a b. (a -> b) -> a -> b
$ ProtocolServer p -> NonEmpty TransportHost
forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host ProtocolServer p
srv
          linkType' :: ContactConnType -> SimplexLinkType
linkType' = \case
            ContactConnType
CCTGroup -> SimplexLinkType
XLGroup
            ContactConnType
CCTChannel -> SimplexLinkType
XLChannel
            ContactConnType
CCTContact -> SimplexLinkType
XLContact
            ContactConnType
CCTRelay -> SimplexLinkType
XLRelay
    strEncodeText :: StrEncoding a => a -> Text
    strEncodeText :: forall a. StrEncoding a => a -> Text
strEncodeText = ByteString -> Text
safeDecodeUtf8 (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode

parseUri :: ByteString -> Either Text U.URI
parseUri :: ByteString -> Either Text URI
parseUri ByteString
s = case URIParserOptions -> ByteString -> Either URIParseError URI
U.parseURI URIParserOptions
U.laxURIParserOptions ByteString
s of
  Left URIParseError
e -> Text -> Either Text URI
forall a b. a -> Either a b
Left (Text -> Either Text URI) -> Text -> Either Text URI
forall a b. (a -> b) -> a -> b
$ Text
"Invalid URI: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> URIParseError -> Text
forall a. Show a => a -> Text
tshow URIParseError
e
  Right uri :: URI
uri@U.URI {uriScheme :: URI -> Scheme
uriScheme = U.Scheme ByteString
sch, Maybe Authority
uriAuthority :: Maybe Authority
uriAuthority :: URI -> Maybe Authority
uriAuthority}
    | ByteString
sch ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"http" Bool -> Bool -> Bool
&& ByteString
sch ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"https" -> Text -> Either Text URI
forall a b. a -> Either a b
Left (Text -> Either Text URI) -> Text -> Either Text URI
forall a b. (a -> b) -> a -> b
$ Text
"Unsupported URI scheme: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
safeDecodeUtf8 ByteString
sch
    | Bool
otherwise -> case Maybe Authority
uriAuthority of
        Maybe Authority
Nothing -> Text -> Either Text URI
forall a b. a -> Either a b
Left Text
"No URI host"
        Just U.Authority {authorityHost :: Authority -> Host
authorityHost = U.Host ByteString
h}
          | Char
'.' Char -> ByteString -> Bool
`B.notElem` ByteString
h -> Text -> Either Text URI
forall a b. a -> Either a b
Left (Text -> Either Text URI) -> Text -> Either Text URI
forall a b. (a -> b) -> a -> b
$ Text
"Invalid URI host: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
safeDecodeUtf8 ByteString
h
          | Bool
otherwise -> URI -> Either Text URI
forall a b. b -> Either a b
Right URI
uri

-- the heuristic for removing tracking parameters is the following:
-- 1) if the URI path looks like page name* rather than an identifier, allow the first parameter, as long as it is not blacklisted,
-- 2) also allow whitelisted parameters,
-- 3) remove all other parameters.
-- *page name: lowercase latin in snake-case or hyphen-case, allowing for sinlge leading or trailing hyphen or underscore.
sanitizeUri :: Bool -> U.URI -> Maybe U.URI
sanitizeUri :: Bool -> URI -> Maybe URI
sanitizeUri Bool
safe uri :: URI
uri@U.URI {Maybe Authority
uriAuthority :: URI -> Maybe Authority
uriAuthority :: Maybe Authority
uriAuthority, ByteString
uriPath :: ByteString
uriPath :: URI -> ByteString
uriPath, uriQuery :: URI -> Query
uriQuery = U.Query [(ByteString, ByteString)]
originalQS} =
  let sanitizedQS :: [(ByteString, ByteString)]
sanitizedQS
        | Bool
safe = ((ByteString, ByteString) -> Bool)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((ByteString, ByteString) -> Bool)
-> (ByteString, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
isSafeBlacklisted (ByteString -> Bool)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst) [(ByteString, ByteString)]
originalQS
        | Bool
isNamePath = case [(ByteString, ByteString)]
originalQS of
            p :: (ByteString, ByteString)
p@(ByteString
n, ByteString
_) : [(ByteString, ByteString)]
ps -> (if ByteString -> Bool
isWhitelisted ByteString
n Bool -> Bool -> Bool
|| Bool -> Bool
not (ByteString -> Bool
isBlacklisted ByteString
n) then ((ByteString, ByteString)
p (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
:) else [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> a
id) ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> Bool)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString -> Bool
isWhitelisted (ByteString -> Bool)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst) [(ByteString, ByteString)]
ps
            [] -> []
        | Bool
otherwise = ((ByteString, ByteString) -> Bool)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString -> Bool
isWhitelisted (ByteString -> Bool)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst) [(ByteString, ByteString)]
originalQS
   in if [(ByteString, ByteString)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ByteString, ByteString)]
sanitizedQS Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(ByteString, ByteString)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ByteString, ByteString)]
originalQS
        then Maybe URI
forall a. Maybe a
Nothing
        else URI -> Maybe URI
forall a. a -> Maybe a
Just (URI -> Maybe URI) -> URI -> Maybe URI
forall a b. (a -> b) -> a -> b
$ URI
uri {U.uriQuery = U.Query sanitizedQS}
  where
    isSafeBlacklisted :: ByteString -> Bool
isSafeBlacklisted ByteString
p = (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
p) [ByteString]
qsSafeBlacklist
    isBlacklisted :: ByteString -> Bool
isBlacklisted ByteString
p = ByteString -> Bool
isSafeBlacklisted ByteString
p Bool -> Bool -> Bool
|| ((ByteString -> Bool) -> Bool) -> [ByteString -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((ByteString -> Bool) -> ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString
p) [ByteString -> Bool]
qsBlacklist
    isWhitelisted :: ByteString -> Bool
isWhitelisted ByteString
p = ((ByteString -> Bool, [ByteString]) -> Bool)
-> [(ByteString -> Bool, [ByteString])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(ByteString -> Bool
f, [ByteString]
ps) -> ByteString -> Bool
f ByteString
host Bool -> Bool -> Bool
&& ByteString
p ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
ps) [(ByteString -> Bool, [ByteString])]
qsWhitelist
    host :: ByteString
host = ByteString
-> (Authority -> ByteString) -> Maybe Authority -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (\U.Authority {authorityHost :: Authority -> Host
authorityHost = U.Host ByteString
h} -> ByteString
h) Maybe Authority
uriAuthority
    isNamePath :: Bool
isNamePath = (Char -> Bool) -> ByteString -> Bool
B.all (\Char
c -> (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z') Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') ByteString
uriPath
    qsWhitelist :: [(ByteString -> Bool, [ByteString])]
    qsWhitelist :: [(ByteString -> Bool, [ByteString])]
qsWhitelist =
      [ (Bool -> ByteString -> Bool
forall a b. a -> b -> a
const Bool
True, [ByteString
"q", ByteString
"search", ByteString
"search_query", ByteString
"lang", ByteString
"list", ByteString
"page", ByteString
"text", ByteString
"type"]),
        (ByteString -> ByteString -> Bool
dom ByteString
"aliexpress.com", [ByteString
"SearchText", ByteString
"catId", ByteString
"minPrice", ByteString
"maxPrice"]),
        (ByteString -> ByteString -> Bool
dom ByteString
"amazon.com", [ByteString
"i", ByteString
"rh", ByteString
"k"]), -- department, filter, keyword
        (ByteString -> ByteString -> Bool
dom ByteString
"baidu.com", [ByteString
"wd"]), -- search string
        (ByteString -> ByteString -> Bool
dom ByteString
"bing.com", [ByteString
"mkt"]), -- localized results
        (ByteString -> ByteString -> Bool
dom ByteString
"github.com", [ByteString
"author", ByteString
"diff", ByteString
"ref", ByteString
"w"]), -- author in search result, PR parameters
        (ByteString -> ByteString -> Bool
dom ByteString
"play.google.com", [ByteString
"id"]),
        (ByteString -> ByteString -> Bool
dom ByteString
"reddit.com", [ByteString
"t"]), -- search type, time range
        (ByteString -> ByteString -> Bool
dom ByteString
"wikipedia.com", [ByteString
"oldid", ByteString
"uselang"]), -- to show old page revision and chosen user language
        (ByteString -> ByteString -> Bool
dom ByteString
"x.com", [ByteString
"f"]), -- feed type
        (ByteString -> ByteString -> Bool
dom ByteString
"yahoo.com", [ByteString
"p"]), -- search string
        (ByteString -> ByteString -> Bool
dom ByteString
"youtube.com", [ByteString
"v", ByteString
"t"]), -- video ID and timestamp
        (ByteString -> ByteString -> Bool
dom ByteString
"youtu.be", [ByteString
"t"])
      ]
    dom :: ByteString -> ByteString -> Bool
dom ByteString
d ByteString
h = ByteString
d ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
h Bool -> Bool -> Bool
|| ((Char
'.' Char -> ByteString -> ByteString
`B.cons` ByteString
d) ByteString -> ByteString -> Bool
`B.isSuffixOf` ByteString
h)
    qsBlacklist :: [ByteString -> Bool]
    qsBlacklist :: [ByteString -> Bool]
qsBlacklist =
      [ ((Char -> Bool) -> ByteString -> Bool
B.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')),
        (ByteString
"id" ByteString -> ByteString -> Bool
`B.isSuffixOf`),
        (ByteString
"source" ByteString -> ByteString -> Bool
`B.isPrefixOf`)
      ]
    qsSafeBlacklist :: [ByteString]
    qsSafeBlacklist :: [ByteString]
qsSafeBlacklist =
      [ ByteString
"ad",
        ByteString
"af",
        ByteString
"camp",
        ByteString
"cmp",
        ByteString
"dc",
        ByteString
"dev",
        ByteString
"ef_",
        ByteString
"fb",
        ByteString
"gad_",
        ByteString
"gc",
        ByteString
"gdf",
        ByteString
"hsa_",
        ByteString
"igsh",
        ByteString
"li",
        ByteString
"matomo_",
        ByteString
"mc_",
        ByteString
"mkwid",
        ByteString
"msc",
        ByteString
"mtm_",
        ByteString
"pcrid",
        ByteString
"piwik_",
        ByteString
"pk_",
        ByteString
"prom",
        ByteString
"ref",
        ByteString
"s_kw",
        ByteString
"si",
        ByteString
"src",
        ByteString
"srs",
        ByteString
"trk_",
        ByteString
"tw",
        ByteString
"utm",
        ByteString
"ycl"
      ]

markdownText :: FormattedText -> Text
markdownText :: FormattedText -> Text
markdownText (FormattedText Maybe Format
f_ Text
t) = case Maybe Format
f_ of
  Maybe Format
Nothing -> Text
t
  Just Format
f -> case Format
f of
    Format
Bold -> Char -> Text
around Char
'*'
    Format
Italic -> Char -> Text
around Char
'_'
    Format
StrikeThrough -> Char -> Text
around Char
'~'
    Format
Snippet -> Char -> Text
around Char
'`'
    Format
Secret -> Char -> Text
around Char
'#'
    Colored (FormatColor Color
c) -> Color -> Text
color Color
c
    Format
Uri -> Text
t
    HyperLink {} -> Text
t
    SimplexLink {} -> Text
t
    Mention Text
_ -> Text
t
    Command Text
_ -> Text
t
    Format
Email -> Text
t
    Format
Phone -> Text
t
    Unknown Value
_ -> Text
t
    where
      around :: Char -> Text
around Char
c = Char
c Char -> Text -> Text
`T.cons` Text
t Text -> Char -> Text
`T.snoc` Char
c
      color :: Color -> Text
color Color
c = case Color -> Maybe Text
colorStr Color
c of
        Just Text
cStr -> Text
cStr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Char -> Text
`T.snoc` Char
'!'
        Maybe Text
Nothing -> Text
t
      colorStr :: Color -> Maybe Text
colorStr = \case
        Color
Red -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"!1 "
        Color
Green -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"!2 "
        Color
Blue -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"!3 "
        Color
Yellow -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"!4 "
        Color
Cyan -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"!5 "
        Color
Magenta -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"!6 "
        Color
Black -> Maybe Text
forall a. Maybe a
Nothing
        Color
White -> Maybe Text
forall a. Maybe a
Nothing

displayNameTextP :: Parser Text
displayNameTextP :: Parser Text Text
displayNameTextP = Parser Text (Text, Text)
displayNameTextP_ Parser Text (Text, Text)
-> ((Text, Text) -> Parser Text Text) -> Parser Text Text
forall a b. Parser Text a -> (a -> Parser Text b) -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Text
t, Text
sfx) -> if Text -> Bool
T.null Text
sfx then Text -> Parser Text Text
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t else String -> Parser Text Text
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Name ends with punctuation"
{-# INLINE displayNameTextP #-}

displayNameTextP_ :: Parser (Text, Text)
displayNameTextP_ :: Parser Text (Text, Text)
displayNameTextP_ = (,Text
"") (Text -> (Text, Text))
-> Parser Text Text -> Parser Text (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Text Text
quoted Char
'\'' Parser Text (Text, Text)
-> Parser Text (Text, Text) -> Parser Text (Text, Text)
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> (Text, Text)
splitPunctuation (Text -> (Text, Text))
-> Parser Text Text -> Parser Text (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
takeNameTill Char -> Bool
isSpace
  where
    takeNameTill :: (Char -> Bool) -> Parser Text Text
takeNameTill Char -> Bool
p =
      Parser Char
A.peekChar' Parser Char -> (Char -> Parser Text Text) -> Parser Text Text
forall a b. Parser Text a -> (a -> Parser Text b) -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Char
c ->
        if Char -> Bool
refChar Char
c then (Char -> Bool) -> Parser Text Text
A.takeTill Char -> Bool
p else String -> Parser Text Text
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid first character in display name"
    splitPunctuation :: Text -> (Text, Text)
splitPunctuation Text
s = ((Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isPunctuation Text
s, (Char -> Bool) -> Text -> Text
T.takeWhileEnd Char -> Bool
isPunctuation Text
s)
    quoted :: Char -> Parser Text Text
quoted Char
c = Char -> Parser Char
A.char Char
c Parser Char -> Parser Text Text -> Parser Text Text
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text Text
takeNameTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) Parser Text Text -> Parser Char -> Parser Text Text
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
A.char Char
c
    refChar :: Char -> Bool
refChar Char
c = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
> Char
' ' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'@' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\''

commandTextP :: Parser (Text, Text)
commandTextP :: Parser Text (Text, Text)
commandTextP = do
  (Text
cmd, Text
punct) <- Parser Text (Text, Text)
displayNameTextP_
  case Text -> [Text]
T.words Text
cmd of
    (Text
keyword : [Text]
_) | (Char -> Bool) -> Text -> Bool
T.all (\Char
c -> Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') Text
keyword -> (Text, Text) -> Parser Text (Text, Text)
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
cmd, Text
punct)
    [Text]
_ -> String -> Parser Text (Text, Text)
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid command keyword"

-- quotes names that contain spaces or end on punctuation
viewName :: Text -> Text
viewName :: Text -> Text
viewName Text
s = if (Char -> Bool) -> Text -> Bool
T.any Char -> Bool
isSpace Text
s Bool -> Bool -> Bool
|| Bool -> ((Text, Char) -> Bool) -> Maybe (Text, Char) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Char -> Bool
isPunctuation (Char -> Bool) -> ((Text, Char) -> Char) -> (Text, Char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Char) -> Char
forall a b. (a, b) -> b
snd) (Text -> Maybe (Text, Char)
T.unsnoc Text
s) then Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'" else Text
s

$(JQ.deriveJSON (enumJSON $ dropPrefix "XL") ''SimplexLinkType)

$(JQ.deriveToJSON (sumTypeJSON fstToLower) ''Format)

instance FromJSON Format where
  parseJSON :: Value -> Parser Format
parseJSON Value
v = $(JQ.mkParseJSON (sumTypeJSON fstToLower) ''Format) Value
v Parser Format -> Parser Format -> Parser Format
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Format -> Parser Format
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Format
Unknown Value
v)

$(JQ.deriveJSON defaultJSON ''FormattedText)

$(JQ.deriveToJSON defaultJSON ''ParsedMarkdown)