diff --git a/apps/dog-food/ChatOptions.hs b/apps/dog-food/ChatOptions.hs index 7c94bff992..935dd55709 100644 --- a/apps/dog-food/ChatOptions.hs +++ b/apps/dog-food/ChatOptions.hs @@ -8,7 +8,7 @@ import qualified Data.ByteString.Char8 as B import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Options.Applicative -import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP) +import Simplex.Messaging.Agent.Protocol (SMPServer (..), smpServerP) import Simplex.Messaging.Parsers (parseAll) import System.FilePath (combine) import Types diff --git a/apps/dog-food/ChatTerminal/Core.hs b/apps/dog-food/ChatTerminal/Core.hs index 8e5632a312..653b5c3f84 100644 --- a/apps/dog-food/ChatTerminal/Core.hs +++ b/apps/dog-food/ChatTerminal/Core.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -11,7 +10,7 @@ import Data.List (dropWhileEnd) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding -import Simplex.Markdown +import Simplex.Chat.Markdown import Styled import System.Console.ANSI.Types import System.Terminal hiding (insertChars) diff --git a/apps/dog-food/Main.hs b/apps/dog-food/Main.hs index e3871afab1..f872a5c0ff 100644 --- a/apps/dog-food/Main.hs +++ b/apps/dog-food/Main.hs @@ -28,11 +28,11 @@ import Data.Time.Clock (DiffTime, UTCTime) import Data.Time.Format (defaultTimeLocale, formatTime) import Data.Time.LocalTime import Numeric.Natural -import Simplex.Markdown +import Simplex.Chat.Markdown import Simplex.Messaging.Agent (getSMPAgentClient, runSMPAgentClient) import Simplex.Messaging.Agent.Client (AgentClient (..)) import Simplex.Messaging.Agent.Env.SQLite -import Simplex.Messaging.Agent.Transmission +import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Client (smpDefaultConfig) import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Util (raceAny_) diff --git a/apps/dog-food/Styled.hs b/apps/dog-food/Styled.hs index 397b8c973a..90341b5e9e 100644 --- a/apps/dog-food/Styled.hs +++ b/apps/dog-food/Styled.hs @@ -17,7 +17,7 @@ import qualified Data.ByteString.Char8 as B import Data.String import Data.Text (Text) import qualified Data.Text as T -import Simplex.Markdown +import Simplex.Chat.Markdown import System.Console.ANSI.Types data StyledString = Styled [SGR] String | StyledString :<>: StyledString diff --git a/package.yaml b/package.yaml index 94c2416407..39a8cf55ad 100644 --- a/package.yaml +++ b/package.yaml @@ -11,15 +11,23 @@ category: Web, System, Services, Cryptography extra-source-files: - README.md +dependencies: + - ansi-terminal == 0.10.* + - attoparsec == 0.13.* + - base == 4.13.* + - containers == 0.6.* + - text == 1.2.* + +library: + source-dirs: src + executables: dog-food: source-dirs: apps/dog-food main: Main.hs dependencies: - - base == 4.13.* - - ansi-terminal == 0.10.* + - simplex-chat - async == 2.2.* - - attoparsec == 0.13.* - bytestring == 0.10.* - directory == 1.3.* - filepath == 1.4.* @@ -29,12 +37,19 @@ executables: - simplexmq == 0.3.* - stm == 2.5.* - terminal == 0.2.* - - text == 1.2.* - time == 1.9.* - unliftio == 0.2.* ghc-options: - -threaded +tests: + simplex-chat-test: + source-dirs: tests + main: Test.hs + dependencies: + - simplex-chat + - hspec == 2.7.* + ghc-options: # - -haddock - -Wall diff --git a/src/Simplex/Chat/Markdown.hs b/src/Simplex/Chat/Markdown.hs new file mode 100644 index 0000000000..82aa84c631 --- /dev/null +++ b/src/Simplex/Chat/Markdown.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.Chat.Markdown where + +import Control.Applicative ((<|>)) +import Data.Attoparsec.Text (Parser) +import qualified Data.Attoparsec.Text as A +import Data.Either (fromRight) +import Data.Functor (($>)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import System.Console.ANSI.Types + +data Markdown = Markdown Format Text | Markdown :|: Markdown + deriving (Eq, Show) + +data Format + = Bold + | Italic + | Underline + | StrikeThrough + | Snippet + | Secret + | Colored Color + | NoFormat + deriving (Eq, Show) + +instance Semigroup Markdown where (<>) = (:|:) + +instance Monoid Markdown where mempty = unmarked "" + +instance IsString Markdown where fromString = unmarked . T.pack + +unmarked :: Text -> Markdown +unmarked = Markdown NoFormat + +colorMD :: Char +colorMD = '!' + +secretMD :: Char +secretMD = '#' + +formats :: Map Char Format +formats = + M.fromList + [ ('*', Bold), + ('_', Italic), + ('+', Underline), + ('~', StrikeThrough), + ('`', Snippet), + (secretMD, Secret), + (colorMD, Colored White) + ] + +colors :: Map Text Color +colors = + M.fromList + [ ("red", Red), + ("green", Green), + ("blue", Blue), + ("yellow", Yellow), + ("cyan", Cyan), + ("magenta", Magenta), + ("r", Red), + ("g", Green), + ("b", Blue), + ("y", Yellow), + ("c", Cyan), + ("m", Magenta), + ("1", Red), + ("2", Green), + ("3", Blue), + ("4", Yellow), + ("5", Cyan), + ("6", Magenta) + ] + +parseMarkdown :: Text -> Markdown +parseMarkdown s = fromRight (unmarked s) $ A.parseOnly (markdownP <* A.endOfInput) s + +markdownP :: Parser Markdown +markdownP = merge <$> A.many' fragmentP + where + merge :: [Markdown] -> Markdown + merge [] = "" + merge fs = foldr1 (:|:) fs + fragmentP :: Parser Markdown + fragmentP = + A.anyChar >>= \case + ' ' -> unmarked . T.cons ' ' <$> A.takeWhile (== ' ') + c -> case M.lookup c formats of + Just Secret -> secretP + Just (Colored White) -> coloredP + Just f -> formattedP c "" f + Nothing -> unformattedP c + formattedP :: Char -> Text -> Format -> Parser Markdown + formattedP c p f = do + s <- A.takeTill (== c) + (A.char c $> markdown c p f s) <|> noFormat (c `T.cons` p <> s) + markdown :: Char -> Text -> Format -> Text -> Markdown + markdown c p f s + | T.null s || T.head s == ' ' || T.last s == ' ' = + unmarked $ c `T.cons` p <> s `T.snoc` c + | otherwise = Markdown f s + secretP :: Parser Markdown + secretP = secret <$> A.takeWhile (== secretMD) <*> A.takeTill (== secretMD) <*> A.takeWhile (== secretMD) + secret :: Text -> Text -> Text -> Markdown + secret b s a + | T.null a || T.null s || T.head s == ' ' || T.last s == ' ' = + unmarked $ secretMD `T.cons` ss + | otherwise = Markdown Secret $ T.init ss + where + ss = b <> s <> a + coloredP :: Parser Markdown + coloredP = do + color <- A.takeWhile (\c -> c /= ' ' && c /= colorMD) + case M.lookup color colors of + Just c -> + let f = Colored c + in (A.char ' ' *> formattedP colorMD (color `T.snoc` ' ') f) + <|> noFormat (colorMD `T.cons` color) + _ -> noFormat (colorMD `T.cons` color) + unformattedP :: Char -> Parser Markdown + unformattedP c = unmarked . T.cons c <$> wordsP + wordsP :: Parser Text + wordsP = do + s <- (<>) <$> A.takeTill (== ' ') <*> A.takeWhile (== ' ') + A.peekChar >>= \case + Nothing -> pure s + Just c -> case M.lookup c formats of + Just _ -> pure s + Nothing -> (s <>) <$> wordsP + noFormat :: Text -> Parser Markdown + noFormat = pure . unmarked diff --git a/src/Simplex/Chat/Protocol._hs b/src/Simplex/Chat/Protocol._hs new file mode 100644 index 0000000000..c635702f5e --- /dev/null +++ b/src/Simplex/Chat/Protocol._hs @@ -0,0 +1,13 @@ +module Simplex.Chat.Protocol where + +data Profile = Profile + { displayName :: Text, + fullName :: Text + } + +data Contact = Contact + { profile :: Profile, + connection :: ConnAlias + } + +data ChatMessage = ContentMessage | ReadNotification | FileTransfer diff --git a/stack.yaml b/stack.yaml index 2931364f9b..bc6163eb97 100644 --- a/stack.yaml +++ b/stack.yaml @@ -42,7 +42,7 @@ extra-deps: - terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977 # - ../simplexmq - github: simplex-chat/simplexmq - commit: 4b9ebbbab2fb8912cf08a289fa73050ec86ddf51 + commit: fa5a8cb5cd9aed374906c92e641968f8e5883ca5 # - network-run-0.2.4@sha256:7dbb06def522dab413bce4a46af476820bffdff2071974736b06f52f4ab57c96,885 # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a diff --git a/tests/MarkdownTests.hs b/tests/MarkdownTests.hs new file mode 100644 index 0000000000..e236307b81 --- /dev/null +++ b/tests/MarkdownTests.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} + +module MarkdownTests where + +import Data.Text (Text) +import Simplex.Chat.Markdown +import System.Console.ANSI.Types +import Test.Hspec + +markdownTests :: Spec +markdownTests = do + textFormat + secretText + textColor + +textFormat :: Spec +textFormat = describe "text format (bold)" do + it "correct markdown" do + parseMarkdown "this is *bold formatted* text" + `shouldBe` "this is " <> Markdown Bold "bold formatted" <> " " <> "text" + parseMarkdown "*bold formatted* text" + `shouldBe` Markdown Bold "bold formatted" <> " " <> "text" + parseMarkdown "this is *bold*" + `shouldBe` "this is " <> Markdown Bold "bold" + parseMarkdown " *bold* text" + `shouldBe` " " <> Markdown Bold "bold" <> " " <> "text" + parseMarkdown " *bold* text" + `shouldBe` " " <> Markdown Bold "bold" <> " " <> "text" + parseMarkdown "this is *bold* " + `shouldBe` "this is " <> Markdown Bold "bold" <> " " + parseMarkdown "this is *bold* " + `shouldBe` "this is " <> Markdown Bold "bold" <> " " + it "ignored as markdown" do + parseMarkdown "this is * unformatted * text" + `shouldBe` "this is " <> "* unformatted *" <> " " <> "text" + parseMarkdown "this is *unformatted * text" + `shouldBe` "this is " <> "*unformatted *" <> " " <> "text" + parseMarkdown "this is * unformatted* text" + `shouldBe` "this is " <> "* unformatted*" <> " " <> "text" + parseMarkdown "this is **unformatted** text" + `shouldBe` "this is " <> "**" <> "unformatted** text" + parseMarkdown "this is*unformatted* text" + `shouldBe` "this is*unformatted* text" + parseMarkdown "this is *unformatted text" + `shouldBe` "this is " <> "*unformatted text" + it "ignored internal markdown" do + parseMarkdown "this is *long _bold_ (not italic)* text" + `shouldBe` "this is " <> Markdown Bold "long _bold_ (not italic)" <> " " <> "text" + parseMarkdown "snippet: `this is *bold text*`" + `shouldBe` "snippet: " <> Markdown Snippet "this is *bold text*" + +secretText :: Spec +secretText = describe "secret text" do + it "correct markdown" do + parseMarkdown "this is #black_secret# text" + `shouldBe` "this is " <> Markdown Secret "black_secret" <> " " <> "text" + parseMarkdown "##black_secret### text" + `shouldBe` Markdown Secret "#black_secret##" <> " " <> "text" + parseMarkdown "this is #black secret# text" + `shouldBe` "this is " <> Markdown Secret "black secret" <> " " <> "text" + parseMarkdown "##black secret### text" + `shouldBe` Markdown Secret "#black secret##" <> " " <> "text" + parseMarkdown "this is #secret#" + `shouldBe` "this is " <> Markdown Secret "secret" + parseMarkdown " #secret# text" + `shouldBe` " " <> Markdown Secret "secret" <> " " <> "text" + parseMarkdown " #secret# text" + `shouldBe` " " <> Markdown Secret "secret" <> " " <> "text" + parseMarkdown "this is #secret# " + `shouldBe` "this is " <> Markdown Secret "secret" <> " " + parseMarkdown "this is #secret# " + `shouldBe` "this is " <> Markdown Secret "secret" <> " " + it "ignored as markdown" do + parseMarkdown "this is # unformatted # text" + `shouldBe` "this is " <> "# unformatted #" <> " " <> "text" + parseMarkdown "this is #unformatted # text" + `shouldBe` "this is " <> "#unformatted #" <> " " <> "text" + parseMarkdown "this is # unformatted# text" + `shouldBe` "this is " <> "# unformatted#" <> " " <> "text" + parseMarkdown "this is ## unformatted ## text" + `shouldBe` "this is " <> "## unformatted ##" <> " " <> "text" + parseMarkdown "this is#unformatted# text" + `shouldBe` "this is#unformatted# text" + parseMarkdown "this is #unformatted text" + `shouldBe` "this is " <> "#unformatted text" + it "ignored internal markdown" do + parseMarkdown "snippet: `this is #secret_text#`" + `shouldBe` "snippet: " <> Markdown Snippet "this is #secret_text#" + +red :: Text -> Markdown +red = Markdown (Colored Red) + +textColor :: Spec +textColor = describe "text color (red)" do + it "correct markdown" do + parseMarkdown "this is !1 red color! text" + `shouldBe` "this is " <> red "red color" <> " " <> "text" + parseMarkdown "!1 red! text" + `shouldBe` red "red" <> " " <> "text" + parseMarkdown "this is !1 red!" + `shouldBe` "this is " <> red "red" + parseMarkdown " !1 red! text" + `shouldBe` " " <> red "red" <> " " <> "text" + parseMarkdown " !1 red! text" + `shouldBe` " " <> red "red" <> " " <> "text" + parseMarkdown "this is !1 red! " + `shouldBe` "this is " <> red "red" <> " " + parseMarkdown "this is !1 red! " + `shouldBe` "this is " <> red "red" <> " " + it "ignored as markdown" do + parseMarkdown "this is !1 unformatted ! text" + `shouldBe` "this is " <> "!1 unformatted !" <> " " <> "text" + parseMarkdown "this is !1 unformatted ! text" + `shouldBe` "this is " <> "!1 unformatted !" <> " " <> "text" + parseMarkdown "this is !1 unformatted! text" + `shouldBe` "this is " <> "!1 unformatted!" <> " " <> "text" + -- parseMarkdown "this is !!1 unformatted!! text" + -- `shouldBe` "this is " <> "!!1" <> "unformatted!! text" + parseMarkdown "this is!1 unformatted! text" + `shouldBe` "this is!1 unformatted! text" + parseMarkdown "this is !1 unformatted text" + `shouldBe` "this is " <> "!1 unformatted text" + it "ignored internal markdown" do + parseMarkdown "this is !1 long *red* (not bold)! text" + `shouldBe` "this is " <> red "long *red* (not bold)" <> " " <> "text" + parseMarkdown "snippet: `this is !1 red text!`" + `shouldBe` "snippet: " <> Markdown Snippet "this is !1 red text!" diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 index 0000000000..b4d6ff9275 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,7 @@ +import MarkdownTests +import Test.Hspec + +main :: IO () +main = do + hspec $ do + describe "SimpleX chat markdown" markdownTests