Merge branch 'master' of simplexmq
This commit is contained in:
commit
2362fd5d29
66
src/ChatOptions.hs
Normal file
66
src/ChatOptions.hs
Normal 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
103
src/ChatTerminal.hs
Normal 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
89
src/ChatTerminal/Basic.hs
Normal 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
139
src/ChatTerminal/Core.hs
Normal 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]
|
61
src/ChatTerminal/Editor.hs
Normal file
61
src/ChatTerminal/Editor.hs
Normal 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
289
src/Main.hs
Normal 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
60
src/Styled.hs
Normal 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
14
src/Types.hs
Normal 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"
|
Loading…
Reference in New Issue
Block a user