move Markdown from simplexmq (#56)

* move Markdown from simplexmq

* update simplexmq

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

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)

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_)

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

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

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

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

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

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!"

tests/Test.hs

@@ -0,0 +1,7 @@
+import MarkdownTests
+import Test.Hspec
+
+main :: IO ()
+main = do
+  hspec $ do
+    describe "SimpleX chat markdown" markdownTests