deploy: 5d8e11c3a2

.well-known/README.md

@@ -0,0 +1,17 @@
+# .well-known
+
+This website files allow opening SimpleX Chat links (1-time invitations, contact addresses and groups) directly in the app.
+
+## Android
+
+File `assetlinks.json` includes certificate hashes for:
+
+- Play Store (5E:3E:DC:C2:00:FB:A8:D5:F4:88:F3:CA:4C:32:5B:05:78:C5:6A:9C:03:A1:CC:B5:92:9C:D7:5C:7E:57:E2:4D)
+- APK in GitHub releases (3C:52:C4:FD:3C:AD:1C:07:C9:B0:0A:70:80:E3:58:FA:B9:FE:FC:B8:AF:5A:EC:14:77:65:F1:6D:0F:21:AD:85)
+- F-Droid (AE:C1:95:DC:FD:46:14:BD:3A:91:EC:26:D1:D5:14:C8:75:71:C5:CC:8D:CF:48:08:3F:92:83:14:3C:A2:B9:A6)
+
+## iOS
+
+`apple-app-site-association` needs to be served with `Content-type: application/json; charset=utf-8` and GitHub pages do not support adding this header to files without JSON extension.
+
+To workaround this (thanks to [StackOverflow - Serve json data from github pages](https://stackoverflow.com/questions/39199042/serve-json-data-from-github-pages)) we're creating directory named `apple-app-site-association` with `index.json` file that contains all the necessary configs.

.well-known/README/index.html

@@ -0,0 +1,12 @@
+<h1 id="well-known" tabindex="-1">.well-known</h1>
+<p>This website files allow opening SimpleX Chat links (1-time invitations, contact addresses and groups) directly in the app.</p>
+<h2 id="android" tabindex="-1">Android</h2>
+<p>File <code>assetlinks.json</code> includes certificate hashes for:</p>
+<ul>
+<li>Play Store (5E:3E:DC:C2:00:FB:A8:D5:F4:88:F3:CA:4C:32:5B:05:78:C5:6A:9C:03:A1:CC:B5:92:9C:D7:5C:7E:57:E2:4D)</li>
+<li>APK in GitHub releases (3C:52:C4:FD:3C:AD:1C:07:C9:B0:0A:70:80:E3:58:FA:B9:FE:FC:B8:AF:5A:EC:14:77:65:F1:6D:0F:21:AD:85)</li>
+<li>F-Droid (AE:C1:95:DC:FD:46:14:BD:3A:91:EC:26:D1:D5:14:C8:75:71:C5:CC:8D:CF:48:08:3F:92:83:14:3C:A2:B9:A6)</li>
+</ul>
+<h2 id="ios" tabindex="-1">iOS</h2>
+<p><code>apple-app-site-association</code> needs to be served with <code>Content-type: application/json; charset=utf-8</code> and GitHub pages do not support adding this header to files without JSON extension.</p>
+<p>To workaround this (thanks to <a href="https://stackoverflow.com/questions/39199042/serve-json-data-from-github-pages">StackOverflow - Serve json data from github pages</a>) we're creating directory named <code>apple-app-site-association</code> with <code>index.json</code> file that contains all the necessary configs.</p>

.well-known/apple-app-site-association/index.json

@@ -0,0 +1,25 @@
+{
+  "applinks": {
+    "details": [
+      {
+        "appIDs": [
+          "5NN7GUYB6T.chat.simplex.app"
+        ],
+        "components": [
+          {
+            "/": "/contact/*"
+          },
+          {
+            "/": "/contact"
+          },
+          {
+            "/": "/invitation/*"
+          },
+          {
+            "/": "/invitation"
+          }
+        ]
+      }
+    ]
+  }
+}

.well-known/assetlinks.json

@@ -0,0 +1,16 @@
+[
+    {
+        "relation": [
+            "delegate_permission/common.handle_all_urls"
+        ],
+        "target": {
+            "namespace": "android_app",
+            "package_name": "chat.simplex.app",
+            "sha256_cert_fingerprints": [
+                "5E:3E:DC:C2:00:FB:A8:D5:F4:88:F3:CA:4C:32:5B:05:78:C5:6A:9C:03:A1:CC:B5:92:9C:D7:5C:7E:57:E2:4D",
+                "3C:52:C4:FD:3C:AD:1C:07:C9:B0:0A:70:80:E3:58:FA:B9:FE:FC:B8:AF:5A:EC:14:77:65:F1:6D:0F:21:AD:85",
+                "AE:C1:95:DC:FD:46:14:BD:3A:91:EC:26:D1:D5:14:C8:75:71:C5:CC:8D:CF:48:08:3F:92:83:14:3C:A2:B9:A6"
+            ]
+        }
+    }
+]

.well-known/nostr.json

@@ -0,0 +1,18 @@
+{
+  "names": {
+    "_": "c998a5739f04f7fff202c54962aa5782b34ecb10d6f915bdfdd7582963bf9171"
+  },
+  "relays": {
+    "c998a5739f04f7fff202c54962aa5782b34ecb10d6f915bdfdd7582963bf9171": [
+      "wss://nostr.orangepill.dev",
+      "wss://eden.nostr.land",
+      "wss://relay.damus.io",
+      "wss://relay.snort.social",
+      "wss://relay.current.fyi",
+      "wss://nos.lol",
+      "wss://relay.nostr.bg",
+      "wss://nostr-verified.wellorder.net",
+      "wss://nostr.milou.lol"
+    ]
+  }
+}

.well-known/org.flathub.VerifiedApps.txt

@@ -0,0 +1 @@
+ae8b5b2e-76c9-4a31-a044-bcbda1cdf264

CNAME

@@ -0,0 +1 @@
+simplex.chat

ChatOptions.hs

@@ -1,79 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
-module ChatOptions (getChatOpts, ChatOpts (..)) where
-
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Options.Applicative
-import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP)
-import System.FilePath (combine)
-import System.Info (os)
-import Types
-
-data ChatOpts = ChatOpts
-  { name :: Maybe ByteString,
-    dbFileName :: String,
-    smpServer :: SMPServer,
-    termMode :: TermMode
-  }
-
-chatOpts :: FilePath -> Parser ChatOpts
-chatOpts appDir =
-  ChatOpts
-    <$> option
-      (Just <$> str)
-      ( long "name"
-          <> short 'n'
-          <> metavar "NAME"
-          <> help "optional name to use for invitations"
-          <> value Nothing
-      )
-    <*> strOption
-      ( long "database"
-          <> short 'd'
-          <> metavar "DB_FILE"
-          <> help ("sqlite database file path (" <> defaultDbFilePath <> ")")
-          <> value defaultDbFilePath
-      )
-    <*> option
-      parseSMPServer
-      ( long "server"
-          <> short 's'
-          <> metavar "SERVER"
-          <> help "SMP server to use (smp.simplex.im:5223)"
-          <> value (SMPServer "smp.simplex.im" (Just "5223") Nothing)
-      )
-    <*> option
-      parseTermMode
-      ( long "term"
-          <> short 't'
-          <> metavar "TERM"
-          <> help ("terminal mode: editor or basic (" <> termModeName deafultTermMode <> ")")
-          <> value deafultTermMode
-      )
-  where
-    defaultDbFilePath = combine appDir "smp-chat.db"
-    deafultTermMode
-      | os == "mingw32" = TermModeBasic
-      | otherwise = TermModeEditor
-
-parseSMPServer :: ReadM SMPServer
-parseSMPServer = eitherReader $ A.parseOnly (smpServerP <* A.endOfInput) . B.pack
-
-parseTermMode :: ReadM TermMode
-parseTermMode = maybeReader $ \case
-  "basic" -> Just TermModeBasic
-  "editor" -> Just TermModeEditor
-  _ -> Nothing
-
-getChatOpts :: FilePath -> IO ChatOpts
-getChatOpts appDir = execParser opts
-  where
-    opts =
-      info
-        (chatOpts appDir <**> helper)
-        ( fullDesc
-            <> header "Chat prototype using Simplex Messaging Protocol (SMP)"
-            <> progDesc "Start chat with DB_FILE file and use SERVER as SMP server"
-        )

ChatTerminal.hs

@@ -1,105 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module ChatTerminal
-  ( ChatTerminal (..),
-    newChatTerminal,
-    chatTerminal,
-    updateUsername,
-    ttyContact,
-    ttyFromContact,
-  )
-where
-
-import ChatTerminal.Basic (getLn, putLn)
-import ChatTerminal.Core
-import ChatTerminal.POSIX
-import Control.Concurrent (threadDelay)
-import Control.Concurrent.Async (race_)
-import Control.Concurrent.STM
-import Control.Monad
-import Data.Maybe (fromMaybe)
-import Numeric.Natural
-import Styled
-import qualified System.Console.ANSI as C
-import Types
-
-newChatTerminal :: Natural -> Maybe Contact -> TermMode -> IO ChatTerminal
-newChatTerminal qSize user termMode = do
-  inputQ <- newTBQueueIO qSize
-  outputQ <- newTBQueueIO qSize
-  activeContact <- newTVarIO Nothing
-  username <- newTVarIO user
-  termSize <- fromMaybe (0, 0) <$> C.getTerminalSize
-  let lastRow = fst termSize - 1
-  termState <- newTVarIO $ newTermState user
-  termLock <- newTMVarIO ()
-  nextMessageRow <- newTVarIO lastRow
-  threadDelay 500000 -- this delay is the same as timeout in getTerminalSize
-  return ChatTerminal {inputQ, outputQ, activeContact, username, termMode, termState, termSize, nextMessageRow, termLock}
-
-newTermState :: Maybe Contact -> TerminalState
-newTermState user =
-  TerminalState
-    { inputString = "",
-      inputPosition = 0,
-      inputPrompt = promptString user
-    }
-
-chatTerminal :: ChatTerminal -> IO ()
-chatTerminal ct
-  | termSize ct == (0, 0) || termMode ct == TermModeBasic =
-    run basicReceiveFromTTY basicSendToTTY
-  | otherwise = do
-    initTTY
-    updateInput ct
-    run receiveFromTTY sendToTTY
-  where
-    run receive send = race_ (receive ct) (send ct)
-
-basicReceiveFromTTY :: ChatTerminal -> IO ()
-basicReceiveFromTTY ct =
-  forever $ getLn >>= atomically . writeTBQueue (inputQ ct)
-
-basicSendToTTY :: ChatTerminal -> IO ()
-basicSendToTTY ct = forever $ readOutputQ ct >>= putLn
-
-withTermLock :: ChatTerminal -> IO () -> IO ()
-withTermLock ChatTerminal {termLock} action = do
-  _ <- atomically $ takeTMVar termLock
-  action
-  atomically $ putTMVar termLock ()
-
-receiveFromTTY :: ChatTerminal -> IO ()
-receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} =
-  forever $
-    getKey >>= processKey >> withTermLock ct (updateInput ct)
-  where
-    processKey :: Key -> IO ()
-    processKey = \case
-      KeyEnter -> submitInput
-      key -> atomically $ do
-        ac <- readTVar activeContact
-        modifyTVar termState $ updateTermState ac (snd termSize) key
-
-    submitInput :: IO ()
-    submitInput = do
-      msg <- atomically $ do
-        ts <- readTVar termState
-        writeTVar termState $ ts {inputString = "", inputPosition = 0}
-        let s = inputString ts
-        writeTBQueue inputQ s
-        return s
-      withTermLock ct . printMessage ct $ styleMessage msg
-
-sendToTTY :: ChatTerminal -> IO ()
-sendToTTY ct = forever $ do
-  msg <- readOutputQ ct
-  withTermLock ct $ do
-    printMessage ct msg
-    updateInput ct
-
-readOutputQ :: ChatTerminal -> IO StyledString
-readOutputQ = atomically . readTBQueue . outputQ

ChatTerminal/Basic.hs

@@ -1,81 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
-module ChatTerminal.Basic where
-
-import Control.Monad.IO.Class (liftIO)
-import Styled
-import System.Console.ANSI.Types
-import System.Exit (exitSuccess)
-import System.Terminal as C
-
-getLn :: IO String
-getLn = withTerminal $ runTerminalT getTermLine
-
-putLn :: StyledString -> IO ()
-putLn s =
-  withTerminal . runTerminalT $
-    putStyled s >> C.putLn >> flush
-
-putStyled :: MonadTerminal m => StyledString -> m ()
-putStyled (s1 :<>: s2) = putStyled s1 >> putStyled s2
-putStyled (Styled [] s) = putString s
-putStyled (Styled sgr s) = setSGR sgr >> putString s >> resetAttributes
-
-setSGR :: MonadTerminal m => [SGR] -> m ()
-setSGR = mapM_ $ \case
-  Reset -> resetAttributes
-  SetConsoleIntensity BoldIntensity -> setAttribute bold
-  SetConsoleIntensity _ -> resetAttribute bold
-  SetItalicized True -> setAttribute italic
-  SetItalicized _ -> resetAttribute italic
-  SetUnderlining NoUnderline -> resetAttribute underlined
-  SetUnderlining _ -> setAttribute underlined
-  SetSwapForegroundBackground True -> setAttribute inverted
-  SetSwapForegroundBackground _ -> resetAttribute inverted
-  SetColor l i c -> setAttribute . layer l . intensity i $ color c
-  SetBlinkSpeed _ -> pure ()
-  SetVisible _ -> pure ()
-  SetRGBColor _ _ -> pure ()
-  SetPaletteColor _ _ -> pure ()
-  SetDefaultColor _ -> pure ()
-  where
-    layer = \case
-      Foreground -> foreground
-      Background -> background
-    intensity = \case
-      Dull -> id
-      Vivid -> bright
-    color = \case
-      Black -> black
-      Red -> red
-      Green -> green
-      Yellow -> yellow
-      Blue -> blue
-      Magenta -> magenta
-      Cyan -> cyan
-      White -> white
-
-getTermLine :: MonadTerminal m => m String
-getTermLine = getChars ""
-  where
-    getChars s = awaitEvent >>= processKey s
-    processKey s = \case
-      Right (KeyEvent key ms) -> case key of
-        CharKey c
-          | ms == mempty || ms == shiftKey -> do
-            C.putChar c
-            flush
-            getChars (c : s)
-          | otherwise -> getChars s
-        EnterKey -> do
-          C.putLn
-          flush
-          pure $ reverse s
-        BackspaceKey -> do
-          moveCursorBackward 1
-          eraseChars 1
-          flush
-          getChars $ if null s then s else tail s
-        _ -> getChars s
-      Left Interrupt -> liftIO exitSuccess
-      _ -> getChars s

ChatTerminal/Core.hs

@@ -1,130 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module ChatTerminal.Core where
-
-import Control.Concurrent.STM
-import qualified Data.ByteString.Char8 as B
-import Data.List (dropWhileEnd)
-import qualified Data.Text as T
-import SimplexMarkdown
-import Styled
-import System.Console.ANSI.Types
-import Types
-
-data ChatTerminal = ChatTerminal
-  { inputQ :: TBQueue String,
-    outputQ :: TBQueue StyledString,
-    activeContact :: TVar (Maybe Contact),
-    username :: TVar (Maybe Contact),
-    termMode :: TermMode,
-    termState :: TVar TerminalState,
-    termSize :: (Int, Int),
-    nextMessageRow :: TVar Int,
-    termLock :: TMVar ()
-  }
-
-data TerminalState = TerminalState
-  { inputPrompt :: String,
-    inputString :: String,
-    inputPosition :: Int
-  }
-
-data Key
-  = KeyLeft
-  | KeyRight
-  | KeyUp
-  | KeyDown
-  | KeyAltLeft
-  | KeyAltRight
-  | KeyCtrlLeft
-  | KeyCtrlRight
-  | KeyShiftLeft
-  | KeyShiftRight
-  | KeyEnter
-  | KeyBack
-  | KeyTab
-  | KeyEsc
-  | KeyChars String
-  | KeyUnsupported
-  deriving (Eq)
-
-inputHeight :: TerminalState -> ChatTerminal -> Int
-inputHeight ts ct = length (inputPrompt ts <> inputString ts) `div` snd (termSize ct) + 1
-
-updateTermState :: Maybe Contact -> Int -> Key -> TerminalState -> TerminalState
-updateTermState ac tw key ts@TerminalState {inputString = s, inputPosition = p} = case key of
-  KeyChars cs -> insertCharsWithContact cs
-  KeyTab -> insertChars "    "
-  KeyBack -> backDeleteChar
-  KeyLeft -> setPosition $ max 0 (p - 1)
-  KeyRight -> setPosition $ min (length s) (p + 1)
-  KeyUp -> setPosition $ let p' = p - tw in if p' > 0 then p' else p
-  KeyDown -> setPosition $ let p' = p + tw in if p' <= length s then p' else p
-  KeyAltLeft -> setPosition prevWordPos
-  KeyAltRight -> setPosition nextWordPos
-  KeyCtrlLeft -> setPosition prevWordPos
-  KeyCtrlRight -> setPosition nextWordPos
-  KeyShiftLeft -> setPosition 0
-  KeyShiftRight -> setPosition $ length s
-  _ -> ts
-  where
-    insertCharsWithContact cs
-      | null s && cs /= "@" && cs /= "/" =
-        insertChars $ contactPrefix <> cs
-      | otherwise = insertChars cs
-    insertChars = ts' . if p >= length s then append else insert
-    append cs = let s' = s <> cs in (s', length s')
-    insert cs = let (b, a) = splitAt p s in (b <> cs <> a, p + length cs)
-    contactPrefix = case ac of
-      Just (Contact c) -> "@" <> B.unpack c <> " "
-      Nothing -> ""
-    backDeleteChar
-      | p == 0 || null s = ts
-      | p >= length s = ts' backDeleteLast
-      | otherwise = ts' backDelete
-    backDeleteLast = if null s then (s, 0) else let s' = init s in (s', length s')
-    backDelete = let (b, a) = splitAt p s in (init b <> a, p - 1)
-    setPosition p' = ts' (s, p')
-    prevWordPos
-      | p == 0 || null s = p
-      | otherwise =
-        let before = take p s
-            beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before
-         in max 0 $ p - length before + length beforeWord
-    nextWordPos
-      | p >= length s || null s = p
-      | otherwise =
-        let after = drop p s
-            afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after
-         in min (length s) $ p + length after - length afterWord
-    ts' (s', p') = ts {inputString = s', inputPosition = p'}
-
-styleMessage :: String -> StyledString
-styleMessage = \case
-  "" -> ""
-  s@('@' : _) -> let (c, rest) = span (/= ' ') s in Styled selfSGR c <> markdown rest
-  s -> markdown s
-  where
-    markdown :: String -> StyledString
-    markdown = styleMarkdown . parseMarkdown . T.pack
-
-updateUsername :: ChatTerminal -> Maybe Contact -> STM ()
-updateUsername ct a = do
-  writeTVar (username ct) a
-  modifyTVar (termState ct) $ \ts -> ts {inputPrompt = promptString a}
-
-promptString :: Maybe Contact -> String
-promptString a = maybe "" (B.unpack . toBs) a <> "> "
-
-ttyContact :: Contact -> StyledString
-ttyContact (Contact a) = Styled contactSGR $ B.unpack a
-
-ttyFromContact :: Contact -> StyledString
-ttyFromContact (Contact a) = Styled contactSGR $ B.unpack a <> ">"
-
-contactSGR :: [SGR]
-contactSGR = [SetColor Foreground Vivid Yellow]
-
-selfSGR :: [SGR]
-selfSGR = [SetColor Foreground Vivid Cyan]

ChatTerminal/POSIX.hs

@@ -1,102 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-
-module ChatTerminal.POSIX where
-
-import ChatTerminal.Core
-import Control.Concurrent.STM
-import Styled
-import qualified System.Console.ANSI as C
-import System.IO
-
-initTTY :: IO ()
-initTTY = do
-  hSetEcho stdin False
-  hSetBuffering stdin NoBuffering
-  hSetBuffering stdout NoBuffering
-
-updateInput :: ChatTerminal -> IO ()
-updateInput ct@ChatTerminal {termSize, termState, nextMessageRow} = do
-  C.hideCursor
-  ts <- readTVarIO termState
-  nmr <- readTVarIO nextMessageRow
-  let (th, tw) = termSize
-      ih = inputHeight ts ct
-      iStart = th - ih
-      prompt = inputPrompt ts
-      (cRow, cCol) = relativeCursorPosition tw $ length prompt + inputPosition ts
-  if nmr >= iStart
-    then atomically $ writeTVar nextMessageRow iStart
-    else clearLines nmr iStart
-  C.setCursorPosition (max nmr iStart) 0
-  putStr $ prompt <> inputString ts <> " "
-  C.clearFromCursorToLineEnd
-  C.setCursorPosition (iStart + cRow) cCol
-  C.showCursor
-  where
-    clearLines :: Int -> Int -> IO ()
-    clearLines from till
-      | from >= till = return ()
-      | otherwise = do
-        C.setCursorPosition from 0
-        C.clearFromCursorToLineEnd
-        clearLines (from + 1) till
-
-    relativeCursorPosition :: Int -> Int -> (Int, Int)
-    relativeCursorPosition width pos =
-      let row = pos `div` width
-          col = pos - row * width
-       in (row, col)
-
-printMessage :: ChatTerminal -> StyledString -> IO ()
-printMessage ChatTerminal {termSize, nextMessageRow} msg = do
-  nmr <- readTVarIO nextMessageRow
-  C.setCursorPosition nmr 0
-  let (th, tw) = termSize
-  lc <- printLines tw msg
-  atomically . writeTVar nextMessageRow $ min (th - 1) (nmr + lc)
-  where
-    printLines :: Int -> StyledString -> IO Int
-    printLines tw ss = do
-      let s = styledToANSITerm ss
-          ls
-            | null s = [""]
-            | otherwise = lines s <> ["" | last s == '\n']
-      print_ ls
-      return $ foldl (\lc l -> lc + (length l `div` tw) + 1) 0 ls
-
-    print_ :: [String] -> IO ()
-    print_ [] = return ()
-    print_ (l : ls) = do
-      putStr l
-      C.clearFromCursorToLineEnd
-      putStr "\n"
-      print_ ls
-
-getKey :: IO Key
-getKey = charsToKey . reverse <$> keyChars ""
-  where
-    charsToKey = \case
-      "\ESC" -> KeyEsc
-      "\ESC[A" -> KeyUp
-      "\ESC[B" -> KeyDown
-      "\ESC[D" -> KeyLeft
-      "\ESC[C" -> KeyRight
-      "\ESCb" -> KeyAltLeft
-      "\ESCf" -> KeyAltRight
-      "\ESC[1;5D" -> KeyCtrlLeft
-      "\ESC[1;5C" -> KeyCtrlRight
-      "\ESC[1;2D" -> KeyShiftLeft
-      "\ESC[1;2C" -> KeyShiftRight
-      "\n" -> KeyEnter
-      "\DEL" -> KeyBack
-      "\t" -> KeyTab
-      '\ESC' : _ -> KeyUnsupported
-      cs -> KeyChars cs
-
-    keyChars cs = do
-      c <- getChar
-      more <- hReady stdin
-      -- for debugging - uncomment this, comment line after:
-      -- (if more then keyChars else \c' -> print (reverse c') >> return c') (c : cs)
-      (if more then keyChars else return) (c : cs)

Main.hs

@@ -1,250 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Main where
-
-import ChatOptions
-import ChatTerminal
-import Control.Applicative ((<|>))
-import Control.Concurrent.STM
-import Control.Logger.Simple
-import Control.Monad.Reader
-import Data.Attoparsec.ByteString.Char8 (Parser)
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.Functor (($>))
-import qualified Data.Text as T
-import Data.Text.Encoding
-import Numeric.Natural
-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.Client (smpDefaultConfig)
-import Simplex.Messaging.Util (raceAny_)
-import SimplexMarkdown
-import Styled
-import System.Directory (getAppUserDataDirectory)
-import System.Exit (exitFailure)
-import System.Info (os)
-import Types
-
-cfg :: AgentConfig
-cfg =
-  AgentConfig
-    { tcpPort = undefined, -- TODO maybe take it out of config
-      rsaKeySize = 2048 `div` 8,
-      connIdBytes = 12,
-      tbqSize = 16,
-      dbFile = "smp-chat.db",
-      smpCfg = smpDefaultConfig
-    }
-
-logCfg :: LogConfig
-logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
-
-data ChatClient = ChatClient
-  { inQ :: TBQueue ChatCommand,
-    outQ :: TBQueue ChatResponse,
-    smpServer :: SMPServer,
-    username :: TVar (Maybe Contact)
-  }
-
--- | GroupMessage ChatGroup ByteString
--- | AddToGroup Contact
-data ChatCommand
-  = ChatHelp
-  | AddContact Contact
-  | AcceptContact Contact SMPQueueInfo
-  | ChatWith Contact
-  | SetName Contact
-  | SendMessage Contact ByteString
-
-chatCommandP :: Parser ChatCommand
-chatCommandP =
-  "/help" $> ChatHelp
-    <|> "/add " *> (AddContact <$> contact)
-    <|> "/accept " *> acceptContact
-    <|> "/chat " *> chatWith
-    <|> "/name " *> setName
-    <|> "@" *> sendMessage
-  where
-    acceptContact = AcceptContact <$> contact <* A.space <*> smpQueueInfoP
-    chatWith = ChatWith <$> contact
-    setName = SetName <$> contact
-    sendMessage = SendMessage <$> contact <* A.space <*> A.takeByteString
-    contact = Contact <$> A.takeTill (== ' ')
-
-data ChatResponse
-  = ChatHelpInfo
-  | Invitation SMPQueueInfo
-  | Connected Contact
-  | ReceivedMessage Contact ByteString
-  | Disconnected Contact
-  | YesYes
-  | ErrorInput ByteString
-  | ChatError AgentErrorType
-  | NoChatResponse
-
-serializeChatResponse :: Maybe Contact -> ChatResponse -> StyledString
-serializeChatResponse name = \case
-  ChatHelpInfo -> chatHelpInfo
-  Invitation qInfo -> "ask your contact to enter: /accept " <> showName name <> " " <> (bPlain . serializeSmpQueueInfo) qInfo
-  Connected c -> ttyContact c <> " connected"
-  ReceivedMessage c t -> ttyFromContact c <> " " <> msgPlain t
-  Disconnected c -> "disconnected from " <> ttyContact c <> " - try \"/chat " <> bPlain (toBs c) <> "\""
-  YesYes -> "you got it!"
-  ErrorInput t -> "invalid input: " <> bPlain t
-  ChatError e -> "chat error: " <> plain (show e)
-  NoChatResponse -> ""
-  where
-    showName Nothing = "<your name>"
-    showName (Just (Contact a)) = bPlain a
-    msgPlain = styleMarkdown . parseMarkdown . decodeUtf8With onError
-    onError _ _ = Just '?'
-
-chatHelpInfo :: StyledString
-chatHelpInfo =
-  "Using chat:\n\
-  \/add <name>       - create invitation to send out-of-band\n\
-  \                    to your contact <name>\n\
-  \                    (any unique string without spaces)\n\
-  \/accept <name> <invitation> - accept <invitation>\n\
-  \                    (a string that starts from \"smp::\")\n\
-  \                    from your contact <name>\n\
-  \/name <name>      - set <name> to use in invitations\n\
-  \@<name> <message> - send <message> (any string) to contact <name>\n\
-  \                    @<name> can be omitted to send to previous"
-
-main :: IO ()
-main = do
-  ChatOpts {dbFileName, smpServer, name, termMode} <- welcomeGetOpts
-  let user = Contact <$> name
-  t <- getChatClient smpServer user
-  ct <- newChatTerminal (tbqSize cfg) user termMode
-  -- setLogLevel LogInfo -- LogError
-  -- withGlobalLogging logCfg $
-  env <- newSMPAgentEnv cfg {dbFile = dbFileName}
-  dogFoodChat t ct env
-
-welcomeGetOpts :: IO ChatOpts
-welcomeGetOpts = do
-  appDir <- getAppUserDataDirectory "simplex"
-  opts@ChatOpts {dbFileName, termMode} <- getChatOpts appDir
-  putStrLn "simpleX chat prototype"
-  putStrLn $ "db: " <> dbFileName
-  when (os == "mingw32") $ windowsWarning termMode
-  putStrLn "type \"/help\" for usage information"
-  pure opts
-
-windowsWarning :: TermMode -> IO ()
-windowsWarning = \case
-  m@TermModeBasic -> do
-    putStrLn $ "running in Windows (terminal mode is " <> termModeName m <> ", no utf8 support)"
-    putStrLn "it is recommended to use Windows Subsystem for Linux (WSL)"
-  m -> do
-    putStrLn $ "running in Windows, terminal mode " <> termModeName m <> " is not supported"
-    exitFailure
-
-dogFoodChat :: ChatClient -> ChatTerminal -> Env -> IO ()
-dogFoodChat t ct env = do
-  c <- runReaderT getSMPAgentClient env
-  raceAny_
-    [ runReaderT (runSMPAgentClient c) env,
-      sendToAgent t ct c,
-      sendToChatTerm t ct,
-      receiveFromAgent t ct c,
-      receiveFromChatTerm t ct,
-      chatTerminal ct
-    ]
-
-getChatClient :: SMPServer -> Maybe Contact -> IO ChatClient
-getChatClient srv name = atomically $ newChatClient (tbqSize cfg) srv name
-
-newChatClient :: Natural -> SMPServer -> Maybe Contact -> STM ChatClient
-newChatClient qSize smpServer name = do
-  inQ <- newTBQueue qSize
-  outQ <- newTBQueue qSize
-  username <- newTVar name
-  return ChatClient {inQ, outQ, smpServer, username}
-
-receiveFromChatTerm :: ChatClient -> ChatTerminal -> IO ()
-receiveFromChatTerm t ct = forever $ do
-  atomically (readTBQueue $ inputQ ct)
-    >>= processOrError . A.parseOnly (chatCommandP <* A.endOfInput) . encodeUtf8 . T.pack
-  where
-    processOrError = \case
-      Left err -> atomically . writeTBQueue (outQ t) . ErrorInput $ B.pack err
-      Right ChatHelp -> atomically . writeTBQueue (outQ t) $ ChatHelpInfo
-      Right (SetName a) -> atomically $ do
-        let user = Just a
-        writeTVar (username (t :: ChatClient)) user
-        updateUsername ct user
-        writeTBQueue (outQ t) YesYes
-      Right cmd -> atomically $ writeTBQueue (inQ t) cmd
-
-sendToChatTerm :: ChatClient -> ChatTerminal -> IO ()
-sendToChatTerm ChatClient {outQ, username} ChatTerminal {outputQ} = forever $ do
-  atomically (readTBQueue outQ) >>= \case
-    NoChatResponse -> return ()
-    resp -> do
-      name <- readTVarIO username
-      atomically . writeTBQueue outputQ $ serializeChatResponse name resp
-
-sendToAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO ()
-sendToAgent ChatClient {inQ, smpServer} ct AgentClient {rcvQ} = do
-  atomically $ writeTBQueue rcvQ ("1", "", SUBALL) -- hack for subscribing to all
-  forever . atomically $ do
-    cmd <- readTBQueue inQ
-    writeTBQueue rcvQ `mapM_` agentTransmission cmd
-    setActiveContact cmd
-  where
-    setActiveContact :: ChatCommand -> STM ()
-    setActiveContact cmd =
-      writeTVar (activeContact ct) $ case cmd of
-        ChatWith a -> Just a
-        SendMessage a _ -> Just a
-        _ -> Nothing
-    agentTransmission :: ChatCommand -> Maybe (ATransmission 'Client)
-    agentTransmission = \case
-      AddContact a -> transmission a $ NEW smpServer
-      AcceptContact a qInfo -> transmission a $ JOIN qInfo $ ReplyVia smpServer
-      ChatWith a -> transmission a SUB
-      SendMessage a msg -> transmission a $ SEND msg
-      ChatHelp -> Nothing
-      SetName _ -> Nothing
-    transmission :: Contact -> ACommand 'Client -> Maybe (ATransmission 'Client)
-    transmission (Contact a) cmd = Just ("1", a, cmd)
-
-receiveFromAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO ()
-receiveFromAgent t ct c = forever . atomically $ do
-  resp <- chatResponse <$> readTBQueue (sndQ c)
-  writeTBQueue (outQ t) resp
-  setActiveContact resp
-  where
-    chatResponse :: ATransmission 'Agent -> ChatResponse
-    chatResponse (_, a, resp) = case resp of
-      INV qInfo -> Invitation qInfo
-      CON -> Connected contact
-      END -> Disconnected contact
-      MSG {m_body} -> ReceivedMessage contact m_body
-      SENT _ -> NoChatResponse
-      OK -> Connected contact -- hack for subscribing to all
-      ERR e -> ChatError e
-      where
-        contact = Contact a
-    setActiveContact :: ChatResponse -> STM ()
-    setActiveContact = \case
-      Connected a -> set $ Just a
-      ReceivedMessage a _ -> set $ Just a
-      Disconnected _ -> set Nothing
-      _ -> return ()
-      where
-        set a = writeTVar (activeContact ct) a

SimplexMarkdown.hs

@@ -1,122 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module SimplexMarkdown 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 Styled
-import System.Console.ANSI.Types
-
-data Markdown = Markdown Format Text | Markdown :|: Markdown
-  deriving (Show)
-
-data Format
-  = Bold
-  | Italic
-  | Underline
-  | StrikeThrough
-  | Colored Color
-  | NoFormat
-  deriving (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
-
-styleMarkdown :: Markdown -> StyledString
-styleMarkdown (s1 :|: s2) = styleMarkdown s1 <> styleMarkdown s2
-styleMarkdown (Markdown f s) = Styled sgr $ T.unpack s
-  where
-    sgr = case f of
-      Bold -> [SetConsoleIntensity BoldIntensity]
-      Italic -> [SetUnderlining SingleUnderline, SetItalicized True]
-      Underline -> [SetUnderlining SingleUnderline]
-      StrikeThrough -> [SetSwapForegroundBackground True]
-      Colored c -> [SetColor Foreground Vivid c]
-      NoFormat -> []
-
-formats :: Map Char Format
-formats =
-  M.fromList
-    [ ('*', Bold),
-      ('_', Italic),
-      ('+', Underline),
-      ('~', StrikeThrough),
-      ('^', 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)
-    ]
-
-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 [f] = f
-    merge (f : fs) = foldl (:|:) f fs
-    fragmentP :: Parser Markdown
-    fragmentP =
-      A.anyChar >>= \case
-        ' ' -> unmarked . (" " <>) <$> A.takeWhile (== ' ')
-        c -> case M.lookup c formats of
-          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 f s) <|> noFormat (T.singleton c <> p <> s)
-    coloredP :: Parser Markdown
-    coloredP = do
-      color <- A.takeWhile (\c -> c /= ' ' && c /= '^')
-      case M.lookup color colors of
-        Just c ->
-          let f = Colored c
-           in (A.char ' ' *> formattedP '^' (color <> " ") f)
-                <|> (A.char '^' $> Markdown f color)
-                <|> noFormat ("^" <> color)
-        _ -> noFormat ("^" <> color)
-    unformattedP :: Char -> Parser Markdown
-    unformattedP c = unmarked . (T.singleton 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

Styled.hs

@@ -1,29 +0,0 @@
-module Styled (StyledString (..), plain, bPlain, styledToANSITerm, styledToPlain) where
-
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.String
-import System.Console.ANSI (SGR (..), setSGRCode)
-
-data StyledString = Styled [SGR] String | StyledString :<>: StyledString
-
-instance Semigroup StyledString where (<>) = (:<>:)
-
-instance Monoid StyledString where mempty = plain ""
-
-instance IsString StyledString where fromString = plain
-
-plain :: String -> StyledString
-plain = Styled []
-
-bPlain :: ByteString -> StyledString
-bPlain = Styled [] . B.unpack
-
-styledToANSITerm :: StyledString -> String
-styledToANSITerm (Styled [] s) = s
-styledToANSITerm (Styled sgr s) = setSGRCode sgr <> s <> setSGRCode [Reset]
-styledToANSITerm (s1 :<>: s2) = styledToANSITerm s1 <> styledToANSITerm s2
-
-styledToPlain :: StyledString -> String
-styledToPlain (Styled _ s) = s
-styledToPlain (s1 :<>: s2) = styledToPlain s1 <> styledToPlain s2

Types.hs

@@ -1,14 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
-module Types where
-
-import Data.ByteString.Char8 (ByteString)
-
-newtype Contact = Contact {toBs :: ByteString}
-
-data TermMode = TermModeBasic | TermModeEditor deriving (Eq)
-
-termModeName :: TermMode -> String
-termModeName = \case
-  TermModeBasic -> "basic"
-  TermModeEditor -> "editor"