Merge branch 'master' of simplexmq

This commit is contained in:
Evgeny Poberezkin 2021-05-02 20:42:28 +01:00
commit 2362fd5d29
8 changed files with 821 additions and 0 deletions

66
src/ChatOptions.hs Normal file
View File

@ -0,0 +1,66 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module ChatOptions (getChatOpts, ChatOpts (..)) where
import qualified Data.ByteString.Char8 as B
import Options.Applicative
import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP)
import Simplex.Messaging.Parsers (parseAll)
import System.FilePath (combine)
import Types
data ChatOpts = ChatOpts
{ dbFileName :: String,
smpServer :: SMPServer,
termMode :: TermMode
}
chatOpts :: FilePath -> Parser ChatOpts
chatOpts appDir =
ChatOpts
<$> 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 (smp1.simplex.im:5223#pLdiGvm0jD1CMblnov6Edd/391OrYsShw+RgdfR0ChA=)"
<> value (SMPServer "smp1.simplex.im" (Just "5223") (Just "pLdiGvm0jD1CMblnov6Edd/391OrYsShw+RgdfR0ChA="))
)
<*> option
parseTermMode
( long "term"
<> short 't'
<> metavar "TERM"
<> help ("terminal mode: editor or basic (" <> termModeName TermModeEditor <> ")")
<> value TermModeEditor
)
where
defaultDbFilePath = combine appDir "smp-chat.db"
parseSMPServer :: ReadM SMPServer
parseSMPServer = eitherReader $ parseAll smpServerP . 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"
)

103
src/ChatTerminal.hs Normal file
View File

@ -0,0 +1,103 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module ChatTerminal
( ChatTerminal (..),
newChatTerminal,
chatTerminal,
ttyContact,
ttyFromContact,
)
where
import ChatTerminal.Basic
import ChatTerminal.Core
import ChatTerminal.Editor
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race_)
import Control.Monad
import Numeric.Natural
import Styled
import System.Terminal
import Types
import UnliftIO.STM
newChatTerminal :: Natural -> TermMode -> IO ChatTerminal
newChatTerminal qSize termMode = do
inputQ <- newTBQueueIO qSize
outputQ <- newTBQueueIO qSize
activeContact <- newTVarIO Nothing
termSize <- withTerminal . runTerminalT $ getWindowSize
let lastRow = height termSize - 1
termState <- newTVarIO newTermState
termLock <- newTMVarIO ()
nextMessageRow <- newTVarIO lastRow
threadDelay 500000 -- this delay is the same as timeout in getTerminalSize
return ChatTerminal {inputQ, outputQ, activeContact, termMode, termState, termSize, nextMessageRow, termLock}
newTermState :: TerminalState
newTermState =
TerminalState
{ inputString = "",
inputPosition = 0,
inputPrompt = "> ",
previousInput = ""
}
chatTerminal :: ChatTerminal -> IO ()
chatTerminal ct
| termSize ct == Size 0 0 || termMode ct == TermModeBasic =
run basicReceiveFromTTY basicSendToTTY
| otherwise = do
withTerminal . runTerminalT $ 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 >>= mapM_ putStyledLn
withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m ()
withTermLock ChatTerminal {termLock} action = do
_ <- atomically $ takeTMVar termLock
action
atomically $ putTMVar termLock ()
receiveFromTTY :: ChatTerminal -> IO ()
receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} =
withTerminal . runTerminalT . forever $
getKey >>= processKey >> withTermLock ct (updateInput ct)
where
processKey :: MonadTerminal m => (Key, Modifiers) -> m ()
processKey = \case
(EnterKey, _) -> submitInput
key -> atomically $ do
ac <- readTVar activeContact
modifyTVar termState $ updateTermState ac (width termSize) key
submitInput :: MonadTerminal m => m ()
submitInput = do
msg <- atomically $ do
ts <- readTVar termState
let s = inputString ts
writeTVar termState $ ts {inputString = "", inputPosition = 0, previousInput = s}
writeTBQueue inputQ s
return s
withTermLock ct $ printMessage ct [styleMessage msg]
sendToTTY :: ChatTerminal -> IO ()
sendToTTY ct = forever $ do
-- `readOutputQ` should be outside of `withTerminal` (see #94)
msg <- readOutputQ ct
withTerminal . runTerminalT . withTermLock ct $ do
printMessage ct msg
updateInput ct
readOutputQ :: ChatTerminal -> IO [StyledString]
readOutputQ = atomically . readTBQueue . outputQ

89
src/ChatTerminal/Basic.hs Normal file
View File

@ -0,0 +1,89 @@
{-# 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
putStyledLn :: StyledString -> IO ()
putStyledLn s =
withTerminal . runTerminalT $
putStyled s >> C.putLn >> flush
-- Currently it is assumed that the message does not have internal line breaks.
-- Previous implementation "kind of" supported them,
-- but it was not determining the number of printed lines correctly
-- because of accounting for control sequences in length
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
getKey :: MonadTerminal m => m (Key, Modifiers)
getKey =
flush >> awaitEvent >>= \case
Left Interrupt -> liftIO exitSuccess
Right (KeyEvent key ms) -> pure (key, ms)
_ -> getKey
getTermLine :: MonadTerminal m => m String
getTermLine = getChars ""
where
getChars s =
getKey >>= \(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

139
src/ChatTerminal/Core.hs Normal file
View File

@ -0,0 +1,139 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module ChatTerminal.Core where
import Control.Concurrent.STM
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.List (dropWhileEnd)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
import Styled
import System.Console.ANSI.Types
import System.Terminal hiding (insertChars)
import Types
data ChatTerminal = ChatTerminal
{ inputQ :: TBQueue String,
outputQ :: TBQueue [StyledString],
activeContact :: TVar (Maybe Contact),
termMode :: TermMode,
termState :: TVar TerminalState,
termSize :: Size,
nextMessageRow :: TVar Int,
termLock :: TMVar ()
}
data TerminalState = TerminalState
{ inputPrompt :: String,
inputString :: String,
inputPosition :: Int,
previousInput :: String
}
inputHeight :: TerminalState -> ChatTerminal -> Int
inputHeight ts ct = length (inputPrompt ts <> inputString ts) `div` width (termSize ct) + 1
positionRowColumn :: Int -> Int -> Position
positionRowColumn wid pos =
let row = pos `div` wid
col = pos - row * wid
in Position {row, col}
updateTermState :: Maybe Contact -> Int -> (Key, Modifiers) -> TerminalState -> TerminalState
updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p} = case key of
CharKey c
| ms == mempty || ms == shiftKey -> insertCharsWithContact [c]
| ms == altKey && c == 'b' -> setPosition prevWordPos
| ms == altKey && c == 'f' -> setPosition nextWordPos
| otherwise -> ts
TabKey -> insertCharsWithContact " "
BackspaceKey -> backDeleteChar
DeleteKey -> deleteChar
HomeKey -> setPosition 0
EndKey -> setPosition $ length s
ArrowKey d -> case d of
Leftwards -> setPosition leftPos
Rightwards -> setPosition rightPos
Upwards
| ms == mempty && null s -> let s' = previousInput ts in ts' (s', length s')
| ms == mempty -> let p' = p - tw in if p' > 0 then setPosition p' else ts
| otherwise -> ts
Downwards
| ms == mempty -> let p' = p + tw in if p' <= length s then setPosition p' else ts
| otherwise -> ts
_ -> 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' (init s, length s - 1)
| otherwise = let (b, a) = splitAt p s in ts' (init b <> a, p - 1)
deleteChar
| p >= length s || null s = ts
| p == 0 = ts' (tail s, 0)
| otherwise = let (b, a) = splitAt p s in ts' (b <> tail a, p)
leftPos
| ms == mempty = max 0 (p - 1)
| ms == shiftKey = 0
| ms == ctrlKey = prevWordPos
| ms == altKey = prevWordPos
| otherwise = p
rightPos
| ms == mempty = min (length s) (p + 1)
| ms == shiftKey = length s
| ms == ctrlKey = nextWordPos
| ms == altKey = nextWordPos
| otherwise = p
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 = styleMarkdownText . T.pack
safeDecodeUtf8 :: ByteString -> Text
safeDecodeUtf8 = decodeUtf8With onError
where
onError _ _ = Just '?'
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]

View File

@ -0,0 +1,61 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module ChatTerminal.Editor where
import ChatTerminal.Basic
import ChatTerminal.Core
import Styled
import System.Terminal
import UnliftIO.STM
-- debug :: MonadTerminal m => String -> m ()
-- debug s = do
-- saveCursor
-- setCursorPosition $ Position 0 0
-- putString s
-- restoreCursor
updateInput :: forall m. MonadTerminal m => ChatTerminal -> m ()
updateInput ct@ChatTerminal {termSize = Size {height, width}, termState, nextMessageRow} = do
hideCursor
ts <- readTVarIO termState
nmr <- readTVarIO nextMessageRow
let ih = inputHeight ts ct
iStart = height - ih
prompt = inputPrompt ts
Position {row, col} = positionRowColumn width $ length prompt + inputPosition ts
if nmr >= iStart
then atomically $ writeTVar nextMessageRow iStart
else clearLines nmr iStart
setCursorPosition $ Position {row = max nmr iStart, col = 0}
putString $ prompt <> inputString ts <> " "
eraseInLine EraseForward
setCursorPosition $ Position {row = iStart + row, col}
showCursor
flush
where
clearLines :: Int -> Int -> m ()
clearLines from till
| from >= till = return ()
| otherwise = do
setCursorPosition $ Position {row = from, col = 0}
eraseInLine EraseForward
clearLines (from + 1) till
printMessage :: forall m. MonadTerminal m => ChatTerminal -> [StyledString] -> m ()
printMessage ChatTerminal {termSize = Size {height, width}, nextMessageRow} msg = do
nmr <- readTVarIO nextMessageRow
setCursorPosition $ Position {row = nmr, col = 0}
mapM_ printStyled msg
flush
let lc = sum $ map lineCount msg
atomically . writeTVar nextMessageRow $ min (height - 1) (nmr + lc)
where
lineCount :: StyledString -> Int
lineCount s = sLength s `div` width + 1
printStyled :: StyledString -> m ()
printStyled s = do
putStyled s
eraseInLine EraseForward
putLn

289
src/Main.hs Normal file
View File

@ -0,0 +1,289 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import ChatOptions
import ChatTerminal
import ChatTerminal.Core
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 Data.List (intersperse)
import qualified Data.Text as T
import Data.Text.Encoding
import Numeric.Natural
import Simplex.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.Client (smpDefaultConfig)
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Util (raceAny_)
import Styled
import System.Console.ANSI.Types
import System.Directory (getAppUserDataDirectory)
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
}
-- | GroupMessage ChatGroup ByteString
-- | AddToGroup Contact
data ChatCommand
= ChatHelp
| MarkdownHelp
| AddConnection Contact
| Connect Contact SMPQueueInfo
| DeleteConnection Contact
| SendMessage Contact ByteString
chatCommandP :: Parser ChatCommand
chatCommandP =
("/help" <|> "/h") $> ChatHelp
<|> ("/markdown" <|> "/m") $> MarkdownHelp
<|> ("/add " <|> "/a ") *> (AddConnection <$> contact)
<|> ("/connect " <> "/c ") *> connect
<|> ("/delete " <> "/d ") *> (DeleteConnection <$> contact)
<|> "@" *> sendMessage
where
connect = Connect <$> contact <* A.space <*> smpQueueInfoP
sendMessage = SendMessage <$> contact <* A.space <*> A.takeByteString
contact = Contact <$> A.takeTill (== ' ')
data ChatResponse
= ChatHelpInfo
| MarkdownInfo
| Invitation SMPQueueInfo
| Connected Contact
| Confirmation Contact
| ReceivedMessage Contact ByteString
| Disconnected Contact
| YesYes
| ContactError ConnectionErrorType Contact
| ErrorInput ByteString
| ChatError AgentErrorType
| NoChatResponse
serializeChatResponse :: ChatResponse -> [StyledString]
serializeChatResponse = \case
ChatHelpInfo -> chatHelpInfo
MarkdownInfo -> markdownInfo
Invitation qInfo ->
[ "pass this invitation to your contact (via any channel): ",
"",
(bPlain . serializeSmpQueueInfo) qInfo,
"",
"and ask them to connect: /c <name_for_you> <invitation_above>"
]
Connected c -> [ttyContact c <> " connected"]
Confirmation c -> [ttyContact c <> " ok"]
ReceivedMessage c t -> prependFirst (ttyFromContact c) $ msgPlain t
-- TODO either add command to re-connect or update message below
Disconnected c -> ["disconnected from " <> ttyContact c <> " - try \"/chat " <> bPlain (toBs c) <> "\""]
YesYes -> ["you got it!"]
ContactError e c -> case e of
UNKNOWN -> ["no contact " <> ttyContact c]
DUPLICATE -> ["contact " <> ttyContact c <> " already exists"]
SIMPLEX -> ["contact " <> ttyContact c <> " did not accept invitation yet"]
ErrorInput t -> ["invalid input: " <> bPlain t]
ChatError e -> ["chat error: " <> plain (show e)]
NoChatResponse -> [""]
where
prependFirst :: StyledString -> [StyledString] -> [StyledString]
prependFirst s [] = [s]
prependFirst s (s' : ss) = (s <> s') : ss
msgPlain :: ByteString -> [StyledString]
msgPlain = map styleMarkdownText . T.lines . safeDecodeUtf8
chatHelpInfo :: [StyledString]
chatHelpInfo =
map
styleMarkdown
[ Markdown (Colored Cyan) "Using Simplex chat prototype.",
"Follow these steps to set up a connection:",
"",
Markdown (Colored Green) "Step 1: " <> Markdown (Colored Cyan) "/add bob" <> " -- Alice adds her contact, Bob (she can use any name).",
indent <> "Alice should send the invitation printed by the /add command",
indent <> "to her contact, Bob, out-of-band, via any trusted channel.",
"",
Markdown (Colored Green) "Step 2: " <> Markdown (Colored Cyan) "/connect alice <invitation>" <> " -- Bob accepts the invitation.",
indent <> "Bob also can use any name for his contact, Alice,",
indent <> "followed by the invitation he received out-of-band.",
"",
Markdown (Colored Green) "Step 3: " <> "Bob and Alice are notified that the connection is set up,",
indent <> "both can now send messages:",
indent <> Markdown (Colored Cyan) "@bob Hello, Bob!" <> " -- Alice messages Bob.",
indent <> Markdown (Colored Cyan) "@alice Hey, Alice!" <> " -- Bob replies to Alice.",
"",
Markdown (Colored Green) "Other commands:",
indent <> Markdown (Colored Cyan) "/delete" <> " -- deletes contact and all messages with them.",
indent <> Markdown (Colored Cyan) "/markdown" <> " -- prints the supported markdown syntax.",
"",
"The commands may be abbreviated to a single letter: " <> listCommands ["/a", "/c", "/d", "/m"]
]
where
listCommands = mconcat . intersperse ", " . map highlight
highlight = Markdown (Colored Cyan)
indent = " "
markdownInfo :: [StyledString]
markdownInfo =
map
styleMarkdown
[ "Markdown:",
" *bold* - " <> Markdown Bold "bold text",
" _italic_ - " <> Markdown Italic "italic text" <> " (shown as underlined)",
" +underlined+ - " <> Markdown Underline "underlined text",
" ~strikethrough~ - " <> Markdown StrikeThrough "strikethrough text" <> " (shown as inverse)",
" `code snippet` - " <> Markdown Snippet "a + b // no *markdown* here",
" !1 text! - " <> red "red text" <> " (1-6: red, green, blue, yellow, cyan, magenta)",
" #secret# - " <> Markdown Secret "secret text" <> " (can be copy-pasted)"
]
where
red = Markdown (Colored Red)
main :: IO ()
main = do
ChatOpts {dbFileName, smpServer, termMode} <- welcomeGetOpts
t <- getChatClient smpServer
ct <- newChatTerminal (tbqSize cfg) termMode
-- setLogLevel LogInfo -- LogError
-- withGlobalLogging logCfg $ do
env <- newSMPAgentEnv cfg {dbFile = dbFileName}
dogFoodChat t ct env
welcomeGetOpts :: IO ChatOpts
welcomeGetOpts = do
appDir <- getAppUserDataDirectory "simplex"
opts@ChatOpts {dbFileName} <- getChatOpts appDir
putStrLn "SimpleX chat prototype"
putStrLn $ "db: " <> dbFileName
putStrLn "type \"/help\" or \"/h\" for usage info"
pure opts
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 -> IO ChatClient
getChatClient srv = atomically $ newChatClient (tbqSize cfg) srv
newChatClient :: Natural -> SMPServer -> STM ChatClient
newChatClient qSize smpServer = do
inQ <- newTBQueue qSize
outQ <- newTBQueue qSize
return ChatClient {inQ, outQ, smpServer}
receiveFromChatTerm :: ChatClient -> ChatTerminal -> IO ()
receiveFromChatTerm t ct = forever $ do
atomically (readTBQueue $ inputQ ct)
>>= processOrError . parseAll chatCommandP . encodeUtf8 . T.pack
where
processOrError = \case
Left err -> writeOutQ . ErrorInput $ B.pack err
Right ChatHelp -> writeOutQ ChatHelpInfo
Right MarkdownHelp -> writeOutQ MarkdownInfo
Right cmd -> atomically $ writeTBQueue (inQ t) cmd
writeOutQ = atomically . writeTBQueue (outQ t)
sendToChatTerm :: ChatClient -> ChatTerminal -> IO ()
sendToChatTerm ChatClient {outQ} ChatTerminal {outputQ} = forever $ do
atomically (readTBQueue outQ) >>= \case
NoChatResponse -> return ()
resp -> atomically . writeTBQueue outputQ $ serializeChatResponse 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 = \case
SendMessage a _ -> setActive ct a
DeleteConnection a -> unsetActive ct a
_ -> pure ()
agentTransmission :: ChatCommand -> Maybe (ATransmission 'Client)
agentTransmission = \case
AddConnection a -> transmission a $ NEW smpServer
Connect a qInfo -> transmission a $ JOIN qInfo $ ReplyVia smpServer
DeleteConnection a -> transmission a DEL
SendMessage a msg -> transmission a $ SEND msg
ChatHelp -> Nothing
MarkdownHelp -> 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 {msgBody} -> ReceivedMessage contact msgBody
SENT _ -> NoChatResponse
OK -> Confirmation contact
ERR (CONN e) -> ContactError e contact
ERR e -> ChatError e
where
contact = Contact a
setActiveContact :: ChatResponse -> STM ()
setActiveContact = \case
Connected a -> setActive ct a
ReceivedMessage a _ -> setActive ct a
Disconnected a -> unsetActive ct a
_ -> pure ()
setActive :: ChatTerminal -> Contact -> STM ()
setActive ct = writeTVar (activeContact ct) . Just
unsetActive :: ChatTerminal -> Contact -> STM ()
unsetActive ct a = modifyTVar (activeContact ct) unset
where
unset a' = if Just a == a' then Nothing else a'

60
src/Styled.hs Normal file
View File

@ -0,0 +1,60 @@
module Styled
( StyledString (..),
bPlain,
plain,
styleMarkdown,
styleMarkdownText,
sLength,
)
where
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import Simplex.Markdown
import System.Console.ANSI.Types
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
styleMarkdownText :: Text -> StyledString
styleMarkdownText = styleMarkdown . parseMarkdown
styleMarkdown :: Markdown -> StyledString
styleMarkdown (s1 :|: s2) = styleMarkdown s1 <> styleMarkdown s2
styleMarkdown (Markdown Snippet s) = '`' `wrap` styled Snippet s
styleMarkdown (Markdown Secret s) = '#' `wrap` styled Secret s
styleMarkdown (Markdown f s) = styled f s
wrap :: Char -> StyledString -> StyledString
wrap c s = plain [c] <> s <> plain [c]
styled :: Format -> Text -> StyledString
styled f = Styled sgr . T.unpack
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]
Secret -> [SetColor Foreground Dull Black, SetColor Background Dull Black]
Snippet -> []
NoFormat -> []
sLength :: StyledString -> Int
sLength (Styled _ s) = length s
sLength (s1 :<>: s2) = sLength s1 + sLength s2

14
src/Types.hs Normal file
View File

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