IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

simplex-chat schema, refactor chat to use SMP agent functions (#62)

Browse Source 
* chat messages namespace and types

* initial schema (WIP)

* schema for messages (WIP)

* fix schema, add migrations, remove broadcast

* simplex-chat spike (WIP)

* chat client design

* update chat schema

* more chat schema updates

* simplex-chat app structure

* chat app layout demo

* update schema

* refactor dog-food (WIP)

* refactor / simplify

* refactor output of sent message to avoid separate parsing

* refactor inputSubscriber

* remove unused simplex-chat code

* update simplexmq commit

* update schema

* remove ncurses
This commit is contained in:
Evgeny Poberezkin 2021-06-25 18:18:24 +01:00 committed by GitHub
parent 4232f73ed2
commit eb2404c9ce
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
23 changed files with 1078 additions and 701 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -48,3 +48,4 @@ stack.yaml.lock
# chat database
*.db
*.db.bak

19
apps/dog-food/ChatOptions.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module ChatOptions (getChatOpts, ChatOpts (..)) where
@ -11,12 +10,10 @@ import Options.Applicative
import Simplex.Messaging.Agent.Protocol (SMPServer (..), smpServerP)
import Simplex.Messaging.Parsers (parseAll)
import System.FilePath (combine)
import Types
data ChatOpts = ChatOpts
{ dbFile :: String,
smpServers :: NonEmpty SMPServer,
termMode :: TermMode
smpServers :: NonEmpty SMPServer
}
chatOpts :: FilePath -> Parser ChatOpts
@ -37,14 +34,6 @@ chatOpts appDir =
<> help "SMP server(s) to use (smp1.simplex.im#pLdiGvm0jD1CMblnov6Edd/391OrYsShw+RgdfR0ChA=)"
<> value (L.fromList ["smp1.simplex.im#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"
@ -53,12 +42,6 @@ parseSMPServer = eitherReader $ parseAll servers . B.pack
where
servers = L.fromList <$> smpServerP `A.sepBy1` A.char ','
parseTermMode :: ReadM TermMode
parseTermMode = maybeReader $ \case
"basic" -> Just TermModeBasic
"editor" -> Just TermModeEditor
_ -> Nothing
getChatOpts :: FilePath -> IO ChatOpts
getChatOpts appDir = execParser opts
where

108
apps/dog-food/ChatTerminal.hs
View File

@ -1,108 +0,0 @@
{-# 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 Control.Monad.IO.Class (liftIO)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Time.LocalTime (getZonedTime)
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
activeTo <- newTVarIO ActiveNone
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, activeTo, 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, activeTo, 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 activeTo
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 $ do
localTime <- liftIO getZonedTime
let localTimeStr = formatTime defaultTimeLocale "%H:%M" localTime
printMessage ct [styleMessage localTimeStr 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
apps/dog-food/ChatTerminal/Basic.hs
View File

@ -1,89 +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
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

61
apps/dog-food/ChatTerminal/Editor.hs
View File

@ -1,61 +0,0 @@
{-# 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

343
apps/dog-food/Main.hs
View File

@ -2,7 +2,6 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
@ -10,36 +9,19 @@
module Main where
import ChatOptions
import ChatTerminal
import ChatTerminal.Core
import Control.Applicative ((<|>))
import Control.Concurrent.STM
import Control.Logger.Simple
import Control.Monad.IO.Unlift
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 Data.Time.Clock (DiffTime, UTCTime)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Time.LocalTime
import Numeric.Natural
import Simplex.Chat.Markdown
import Simplex.Messaging.Agent (getSMPAgentClient, runSMPAgentClient)
import Simplex.Messaging.Agent.Client (AgentClient (..))
import Simplex.Chat
import Simplex.Chat.Controller
import Simplex.Input
import Simplex.Messaging.Agent (getSMPAgentClient)
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Client (smpDefaultConfig)
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Util (raceAny_)
import Styled
import System.Console.ANSI.Types
import Simplex.Terminal
import System.Directory (getAppUserDataDirectory)
import Types
import UnliftIO.Async (race_)
cfg :: AgentConfig
cfg =
@ -56,183 +38,15 @@ cfg =
logCfg :: LogConfig
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
data ChatClient = ChatClient
{ inQ :: TBQueue ChatCommand,
outQ :: TBQueue ChatResponse
}
-- | GroupMessage ChatGroup ByteString
-- | AddToGroup Contact
data ChatCommand
= ChatHelp
| MarkdownHelp
| AddConnection Contact
| Connect Contact SMPQueueInfo
| DeleteConnection Contact
| SendMessage Contact ByteString
| NewGroup Group
| AddToGroup Group Contact
| RemoveFromGroup Group Contact
| DeleteGroup Group
| ListGroup Group
| SendGroupMessage Group ByteString
deriving (Show)
chatCommandP :: Parser ChatCommand
chatCommandP =
("/help" <|> "/h") $> ChatHelp
<|> ("/group #" <|> "/g #") *> (NewGroup <$> group)
<|> ("/add #" <|> "/a #") *> (AddToGroup <$> group <* A.space <*> contact)
<|> ("/remove #" <|> "/rm #") *> (RemoveFromGroup <$> group <* A.space <*> contact)
<|> ("/delete #" <|> "/d #") *> (DeleteGroup <$> group)
<|> ("/members #" <|> "/ms #") *> (ListGroup <$> group)
<|> A.char '#' *> (SendGroupMessage <$> group <* A.space <*> A.takeByteString)
<|> ("/add " <|> "/a ") *> (AddConnection <$> contact)
<|> ("/connect " <|> "/c ") *> (Connect <$> contact <* A.space <*> smpQueueInfoP)
<|> ("/delete " <|> "/d ") *> (DeleteConnection <$> contact)
<|> A.char '@' *> (SendMessage <$> contact <* A.space <*> A.takeByteString)
<|> ("/markdown" <|> "/m") $> MarkdownHelp
where
contact = Contact <$> A.takeTill (== ' ')
group = Group <$> A.takeTill (== ' ')
data ChatResponse
= ChatHelpInfo
| MarkdownInfo
| Invitation SMPQueueInfo
| Connected Contact
| Confirmation Contact
| ReceivedMessage Contact UTCTime ByteString MsgIntegrity
| Disconnected Contact
| GroupMembers Group [Contact]
| ReceivedGroupMessage Group Contact UTCTime ByteString MsgIntegrity
| GroupConfirmation Group
| YesYes
| ContactError ConnectionErrorType Contact
| GroupError AgentErrorType Group
| ErrorInput ByteString
| ChatError AgentErrorType
| NoChatResponse
serializeChatResponse :: ChatOpts -> TimeZone -> ZonedTime -> ChatResponse -> [StyledString]
serializeChatResponse _ localTz currentTime = \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 utcTime t mi -> receivedMessage utcTime t mi $ ttyFromContact c
ReceivedGroupMessage g c utcTime t mi -> receivedMessage utcTime t mi $ ttyFromGroup g c
Disconnected c -> ["disconnected from " <> ttyContact c <> " - restart chat"]
GroupMembers g cs -> [ttyGroup g <> ": " <> plain (B.unpack . B.intercalate ", " $ map toBs cs)]
GroupConfirmation g -> [ttyGroup g <> " ok"]
YesYes -> ["you got it!"]
ContactError e c -> case e of
NOT_FOUND -> ["no contact " <> ttyContact c]
DUPLICATE -> ["contact " <> ttyContact c <> " already exists"]
SIMPLEX -> ["contact " <> ttyContact c <> " did not accept invitation yet"]
GroupError e g -> case e of
BCAST B_NOT_FOUND -> ["no group " <> ttyGroup g]
BCAST B_DUPLICATE -> ["group " <> ttyGroup g <> " already exists"]
CONN NOT_FOUND -> ["cannot add unknown contact to the group " <> ttyGroup g]
CONN DUPLICATE -> ["this contact is already in the group " <> ttyGroup g]
CONN SIMPLEX -> ["this contact did not not accept invitation yet"]
_ -> ["chat error: " <> plain (show e)]
ErrorInput t -> ["invalid input: " <> bPlain t]
ChatError e -> ["chat error: " <> plain (show e)]
NoChatResponse -> [""]
where
receivedMessage :: UTCTime -> ByteString -> MsgIntegrity -> StyledString -> [StyledString]
receivedMessage utcTime t mi from =
prependFirst (formatUTCTime utcTime <> " " <> from) (msgPlain t) ++ showIntegrity mi
prependFirst :: StyledString -> [StyledString] -> [StyledString]
prependFirst s [] = [s]
prependFirst s (s' : ss) = (s <> s') : ss
formatUTCTime :: UTCTime -> StyledString
formatUTCTime utcTime = do
let localTime = utcToLocalTime localTz utcTime
format =
if (localDay localTime < localDay (zonedTimeToLocalTime currentTime))
&& (timeOfDayToTime (localTimeOfDay localTime) > (6 * 60 * 60 :: DiffTime))
then "%m-%d" -- if message is from yesterday or before and 6 hours has passed since midnight
else "%H:%M"
styleTime $ formatTime defaultTimeLocale format localTime
msgPlain :: ByteString -> [StyledString]
msgPlain = map styleMarkdownText . T.lines . safeDecodeUtf8
showIntegrity :: MsgIntegrity -> [StyledString]
showIntegrity MsgOk = []
showIntegrity (MsgError err) = msgError $ case err of
MsgSkipped fromId toId ->
"skipped message ID " <> show fromId
<> if fromId == toId then "" else ".." <> show toId
MsgBadId msgId -> "unexpected message ID " <> show msgId
MsgBadHash -> "incorrect message hash"
MsgDuplicate -> "duplicate message ID"
msgError :: String -> [StyledString]
msgError s = [styled (Colored Red) s]
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
opts@ChatOpts {dbFile, smpServers, termMode} <- welcomeGetOpts
t <- atomically $ newChatClient (tbqSize cfg)
ct <- newChatTerminal (tbqSize cfg) termMode
ChatOpts {dbFile, smpServers} <- welcomeGetOpts
ct <- newChatTerminal
a <- getSMPAgentClient cfg {dbFile, smpServers}
cc <- atomically $ newChatController a ct $ tbqSize cfg
-- setLogLevel LogInfo -- LogError
-- withGlobalLogging logCfg $ do
env <- newSMPAgentEnv cfg {dbFile, smpServers}
dogFoodChat t ct env opts
runReaderT simplexChat cc
welcomeGetOpts :: IO ChatOpts
welcomeGetOpts = do
@ -243,134 +57,5 @@ welcomeGetOpts = do
putStrLn "type \"/help\" or \"/h\" for usage info"
pure opts
dogFoodChat :: ChatClient -> ChatTerminal -> Env -> ChatOpts -> IO ()
dogFoodChat t ct env opts = do
c <- runReaderT getSMPAgentClient env
localTz <- liftIO getCurrentTimeZone
raceAny_
[ runReaderT (runSMPAgentClient c) env,
sendToAgent t ct c,
sendToChatTerm t ct opts localTz,
receiveFromAgent t ct c,
receiveFromChatTerm t ct,
chatTerminal ct
]
newChatClient :: Natural -> STM ChatClient
newChatClient qSize = do
inQ <- newTBQueue qSize
outQ <- newTBQueue qSize
return ChatClient {inQ, outQ}
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 -> ChatOpts -> TimeZone -> IO ()
sendToChatTerm ChatClient {outQ} ChatTerminal {outputQ} opts localTz = forever $ do
atomically (readTBQueue outQ) >>= \case
NoChatResponse -> return ()
resp -> do
currentTime <- liftIO getZonedTime
atomically . writeTBQueue outputQ $ serializeChatResponse opts localTz currentTime resp
sendToAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO ()
sendToAgent ChatClient {inQ} ct AgentClient {rcvQ} = do
atomically $ writeTBQueue rcvQ $ ATransmission "1" (Conn "") SUBALL -- hack for subscribing to all
forever . atomically $ do
cmd <- readTBQueue inQ
writeTBQueue rcvQ `mapM_` agentTransmission cmd
setActiveTo cmd
where
setActiveTo :: ChatCommand -> STM ()
setActiveTo = \case
SendMessage a _ -> setActive ct $ ActiveC a
SendGroupMessage g _ -> setActive ct $ ActiveG g
DeleteConnection a -> unsetActive ct $ ActiveC a
DeleteGroup g -> unsetActive ct $ ActiveG g
_ -> pure ()
agentTransmission :: ChatCommand -> Maybe (ATransmission 'Client)
agentTransmission = \case
AddConnection a -> transmission a NEW
Connect a qInfo -> transmission a $ JOIN qInfo $ ReplyMode On
DeleteConnection a -> transmission a DEL
SendMessage a msg -> transmission a $ SEND msg
NewGroup g -> bTransmission g NEW
AddToGroup g a -> bTransmission g $ ADD (Conn $ toBs a)
RemoveFromGroup g a -> bTransmission g $ REM (Conn $ toBs a)
DeleteGroup g -> bTransmission g DEL
ListGroup g -> bTransmission g LS
SendGroupMessage g msg -> bTransmission g $ SEND $ serializeGroupMessage g msg
ChatHelp -> Nothing
MarkdownHelp -> Nothing
transmission :: EntityCommand 'Conn_ c => Contact -> ACommand 'Client c -> Maybe (ATransmission 'Client)
transmission (Contact a) cmd = Just $ ATransmission "1" (Conn a) cmd
bTransmission :: EntityCommand 'Broadcast_ c => Group -> ACommand 'Client c -> Maybe (ATransmission 'Client)
bTransmission (Group g) cmd = Just $ ATransmission "1" (Broadcast g) cmd
receiveFromAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO ()
receiveFromAgent t ct c = forever . atomically $ do
resp <- chatResponse <$> readTBQueue (sndQ c)
writeTBQueue (outQ t) resp
setActiveTo resp
where
chatResponse :: ATransmission 'Agent -> ChatResponse
chatResponse (ATransmission _ entity resp) = case entity of
Conn a -> connectionResponse a resp
Broadcast g -> broadcastResponse g resp
_ -> NoChatResponse
connectionResponse :: EntityCommand 'Conn_ c => ByteString -> ACommand 'Agent c -> ChatResponse
connectionResponse a = \case
INV qInfo -> Invitation qInfo
CON -> Connected contact
END -> Disconnected contact
MSG {msgBody, msgIntegrity, brokerMeta} -> case parseAll groupMessageP msgBody of
Right (group, msg) -> ReceivedGroupMessage group contact (snd brokerMeta) msg msgIntegrity
_ -> ReceivedMessage contact (snd brokerMeta) msgBody msgIntegrity
SENT _ -> NoChatResponse
OK -> Confirmation contact
ERR (CONN e) -> ContactError e contact
ERR e -> ChatError e
where
contact = Contact a
broadcastResponse :: EntityCommand 'Broadcast_ c => ByteString -> ACommand 'Agent c -> ChatResponse
broadcastResponse g = \case
MS as -> GroupMembers group $ map (Contact . fromConn) as
SENT _ -> NoChatResponse
OK -> GroupConfirmation group
ERR e@(CONN _) -> GroupError e group
ERR e@(BCAST _) -> GroupError e group
ERR e -> ChatError e
where
group = Group g
setActiveTo :: ChatResponse -> STM ()
setActiveTo = \case
Connected a -> setActive ct $ ActiveC a
ReceivedMessage a _ _ _ -> setActive ct $ ActiveC a
ReceivedGroupMessage g _ _ _ _ -> setActive ct $ ActiveG g
Disconnected a -> unsetActive ct $ ActiveC a
_ -> pure ()
groupMessageP :: Parser (Group, ByteString)
groupMessageP =
let group = Group <$> A.takeTill (== ' ')
in "####" *> ((,) <$> group <* A.space <*> A.takeByteString)
serializeGroupMessage :: Group -> ByteString -> ByteString
serializeGroupMessage (Group g) msg = "####" <> g <> " " <> msg
setActive :: ChatTerminal -> ActiveTo -> STM ()
setActive ct = writeTVar (activeTo ct)
unsetActive :: ChatTerminal -> ActiveTo -> STM ()
unsetActive ct a = modifyTVar (activeTo ct) unset
where
unset a' = if a == a' then ActiveNone else a'
simplexChat :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
simplexChat = race_ runTerminalInput runChatController

111
apps/dog-food/Simplex/Chat.hs Normal file
View File

@ -0,0 +1,111 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Chat where
import Control.Applicative ((<|>))
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import Data.Functor (($>))
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Simplex.Chat.Controller
import Simplex.Chat.Styled (plain)
import Simplex.Help
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Terminal
import Simplex.View
import Types
import UnliftIO.Async (race_)
import UnliftIO.STM
data ChatCommand
= ChatHelp
| MarkdownHelp
| AddContact Contact
| Connect Contact SMPQueueInfo
| DeleteContact Contact
| SendMessage Contact ByteString
deriving (Show)
runChatController :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
runChatController = race_ inputSubscriber agentSubscriber
inputSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
inputSubscriber = do
q <- asks inputQ
forever $
atomically (readTBQueue q) >>= \case
InputControl _ -> pure ()
InputCommand s ->
case parseAll chatCommandP . encodeUtf8 $ T.pack s of
Left e -> printToView [plain s, "invalid input: " <> plain e]
Right cmd -> do
case cmd of
SendMessage c msg -> showSentMessage c msg
_ -> printToView [plain s]
runExceptT (processChatCommand cmd) >>= \case
Left (ChatErrorAgent c e) -> showAgentError c e
_ -> pure ()
processChatCommand :: ChatMonad m => ChatCommand -> m ()
processChatCommand = \case
ChatHelp -> printToView chatHelpInfo
MarkdownHelp -> printToView markdownInfo
AddContact c -> do
(_, qInfo) <- withAgent c (`createConnection` Just (fromContact c))
showInvitation c qInfo
Connect c qInfo ->
void . withAgent c $ \smp -> joinConnection smp (Just $ fromContact c) qInfo
DeleteContact c -> do
withAgent c (`deleteConnection` fromContact c)
showContactDeleted c
unsetActive' $ ActiveC c
SendMessage c msg -> do
void . withAgent c $ \smp -> sendMessage smp (fromContact c) msg
setActive' $ ActiveC c
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
agentSubscriber = do
q <- asks $ subQ . smpAgent
forever $ do
(_, a, resp) <- atomically (readTBQueue q)
case resp of
CON -> do
showContactConnected $ Contact a
setActive' $ ActiveC $ Contact a
END -> do
showContactDisconnected $ Contact a
unsetActive' $ ActiveC $ Contact a
MSG {brokerMeta, msgBody, msgIntegrity} -> do
-- ReceivedMessage contact (snd brokerMeta) msgBody msgIntegrity
showReceivedMessage (Contact a) (snd brokerMeta) msgBody msgIntegrity
setActive' $ ActiveC $ Contact a
_ -> pure ()
withAgent :: ChatMonad m => Contact -> (AgentClient -> ExceptT AgentErrorType m a) -> m a
withAgent c action =
asks smpAgent
>>= runExceptT . action
>>= liftEither . first (ChatErrorAgent c)
chatCommandP :: Parser ChatCommand
chatCommandP =
("/help" <|> "/h") $> ChatHelp
<|> ("/add " <|> "/a ") *> (AddContact <$> contact)
<|> ("/connect " <|> "/c ") *> (Connect <$> contact <* A.space <*> smpQueueInfoP)
<|> ("/delete " <|> "/d ") *> (DeleteContact <$> contact)
<|> A.char '@' *> (SendMessage <$> contact <* A.space <*> A.takeByteString)
<|> ("/markdown" <|> "/m") $> MarkdownHelp
where
contact = Contact <$> A.takeTill (== ' ')

43
apps/dog-food/Simplex/Chat/Controller.hs Normal file
View File

@ -0,0 +1,43 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
module Simplex.Chat.Controller where
import Control.Exception
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Numeric.Natural
import Simplex.Messaging.Agent (AgentClient)
import Simplex.Messaging.Agent.Protocol (AgentErrorType)
import Simplex.Terminal
import Types
import UnliftIO.STM
data ChatController = ChatController
{ smpAgent :: AgentClient,
chatTerminal :: ChatTerminal,
inputQ :: TBQueue InputEvent
}
data InputEvent = InputCommand String | InputControl Char
data ChatError = ChatErrorAgent Contact AgentErrorType
deriving (Show, Exception)
type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m)
newChatController :: AgentClient -> ChatTerminal -> Natural -> STM ChatController
newChatController smpAgent chatTerminal qSize = do
inputQ <- newTBQueue qSize
pure ChatController {smpAgent, chatTerminal, inputQ}
setActive' :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
setActive' to = asks (activeTo . chatTerminal) >>= atomically . (`writeTVar` to)
unsetActive' :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
unsetActive' a = asks (activeTo . chatTerminal) >>= atomically . (`modifyTVar` unset)
where
unset a' = if a == a' then ActiveNone else a'

55
apps/dog-food/Simplex/Help.hs Normal file
View File

@ -0,0 +1,55 @@
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Help where
import Data.List (intersperse)
import Simplex.Chat.Markdown
import Simplex.Chat.Styled
import System.Console.ANSI.Types
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)

108
apps/dog-food/ChatTerminal/Core.hs → apps/dog-food/Simplex/Input.hs
View File

@ -1,50 +1,51 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module ChatTerminal.Core where
module Simplex.Input where
import Control.Concurrent.STM
import Data.ByteString.Char8 (ByteString)
import Control.Monad.IO.Unlift
import Control.Monad.Reader
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 Simplex.Chat.Markdown
import Styled
import System.Console.ANSI.Types
import Simplex.Chat.Controller
import Simplex.Terminal
import System.Exit (exitSuccess)
import System.Terminal hiding (insertChars)
import Types
import UnliftIO.STM
data ActiveTo = ActiveNone | ActiveC Contact | ActiveG Group
deriving (Eq)
getKey :: MonadTerminal m => m (Key, Modifiers)
getKey =
flush >> awaitEvent >>= \case
Left Interrupt -> liftIO exitSuccess
Right (KeyEvent key ms) -> pure (key, ms)
_ -> getKey
data ChatTerminal = ChatTerminal
{ inputQ :: TBQueue String,
outputQ :: TBQueue [StyledString],
activeTo :: TVar ActiveTo,
termMode :: TermMode,
termState :: TVar TerminalState,
termSize :: Size,
nextMessageRow :: TVar Int,
termLock :: TMVar ()
}
runTerminalInput :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
runTerminalInput = do
ChatController {inputQ, chatTerminal = ct} <- ask
liftIO . withTerminal . runTerminalT $ do
updateInput ct
receiveFromTTY inputQ ct
data TerminalState = TerminalState
{ inputPrompt :: String,
inputString :: String,
inputPosition :: Int,
previousInput :: String
}
receiveFromTTY :: MonadTerminal m => TBQueue InputEvent -> ChatTerminal -> m ()
receiveFromTTY inputQ ct@ChatTerminal {activeTo, termSize, termState} =
forever $ getKey >>= processKey >> withTermLock ct (updateInput ct)
where
processKey :: MonadTerminal m => (Key, Modifiers) -> m ()
processKey = \case
(EnterKey, _) -> submitInput
key -> atomically $ do
ac <- readTVar activeTo
modifyTVar termState $ updateTermState ac (width termSize) key
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}
submitInput :: MonadTerminal m => m ()
submitInput = atomically $ do
ts <- readTVar termState
let s = inputString ts
writeTVar termState $ ts {inputString = "", inputPosition = 0, previousInput = s}
writeTBQueue inputQ $ InputCommand s
updateTermState :: ActiveTo -> Int -> (Key, Modifiers) -> TerminalState -> TerminalState
updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p} = case key of
@ -115,38 +116,3 @@ updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition
afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after
in min (length s) $ p + length after - length afterWord
ts' (s', p') = ts {inputString = s', inputPosition = p'}
styleMessage :: String -> String -> StyledString
styleMessage time msg = do
case msg of
"" -> ""
s@('@' : _) -> sentMessage s
s@('#' : _) -> sentMessage s
s -> markdown s
where
sentMessage :: String -> StyledString
sentMessage s =
let (c, rest) = span (/= ' ') s
in styleTime time <> " " <> styled (Colored Cyan) c <> markdown rest
markdown :: String -> StyledString
markdown = styleMarkdownText . T.pack
styleTime :: String -> StyledString
styleTime = Styled [SetColor Foreground Vivid Black]
safeDecodeUtf8 :: ByteString -> Text
safeDecodeUtf8 = decodeUtf8With onError
where
onError _ _ = Just '?'
ttyContact :: Contact -> StyledString
ttyContact (Contact a) = styled (Colored Green) a
ttyFromContact :: Contact -> StyledString
ttyFromContact (Contact a) = styled (Colored Yellow) $ a <> "> "
ttyGroup :: Group -> StyledString
ttyGroup (Group g) = styled (Colored Blue) $ "#" <> g
ttyFromGroup :: Group -> Contact -> StyledString
ttyFromGroup (Group g) (Contact a) = styled (Colored Yellow) $ "#" <> g <> " " <> a <> "> "

154
apps/dog-food/Simplex/Terminal.hs Normal file
View File

@ -0,0 +1,154 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Terminal where
import Simplex.Chat.Styled
import System.Console.ANSI.Types
import System.Terminal
import Types
import UnliftIO.STM
data ActiveTo = ActiveNone | ActiveC Contact | ActiveG Group
deriving (Eq)
data ChatTerminal = ChatTerminal
{ activeTo :: TVar ActiveTo,
termState :: TVar TerminalState,
termSize :: Size,
nextMessageRow :: TVar Int,
termLock :: TMVar ()
}
data TerminalState = TerminalState
{ inputPrompt :: String,
inputString :: String,
inputPosition :: Int,
previousInput :: String
}
newChatTerminal :: IO ChatTerminal
newChatTerminal = do
activeTo <- newTVarIO ActiveNone
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 {activeTo, termState, termSize, nextMessageRow, termLock}
newTermState :: TerminalState
newTermState =
TerminalState
{ inputString = "",
inputPosition = 0,
inputPrompt = "> ",
previousInput = ""
}
withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m ()
withTermLock ChatTerminal {termLock} action = do
_ <- atomically $ takeTMVar termLock
action
atomically $ putTMVar termLock ()
printToTerminal :: ChatTerminal -> [StyledString] -> IO ()
printToTerminal ct s = withTerminal . runTerminalT . withTermLock ct $ do
printMessage ct s
updateInput ct
updateInput :: forall m. MonadTerminal m => ChatTerminal -> m ()
updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessageRow} = do
hideCursor
ts <- readTVarIO termState
nmr <- readTVarIO nextMessageRow
let ih = inputHeight ts
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
inputHeight :: TerminalState -> Int
inputHeight ts = length (inputPrompt ts <> inputString ts) `div` width + 1
positionRowColumn :: Int -> Int -> Position
positionRowColumn wid pos =
let row = pos `div` wid
col = pos - row * wid
in Position {row, col}
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
-- 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

151
apps/dog-food/Simplex/View.hs Normal file
View File

@ -0,0 +1,151 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.View
( printToView,
showInvitation,
showAgentError,
showContactDeleted,
showContactConnected,
showContactDisconnected,
showReceivedMessage,
showSentMessage,
ttyContact,
ttyFromContact,
ttyGroup,
ttyFromGroup,
)
where
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Data.ByteString.Char8 (ByteString)
import Data.Composition ((.:))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Time.Clock (DiffTime, UTCTime)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Time.LocalTime (TimeZone, ZonedTime, getCurrentTimeZone, getZonedTime, localDay, localTimeOfDay, timeOfDayToTime, utcToLocalTime, zonedTimeToLocalTime)
import Simplex.Chat.Controller
import Simplex.Chat.Markdown
import Simplex.Chat.Styled
import Simplex.Messaging.Agent.Protocol
import Simplex.Terminal (printToTerminal)
import System.Console.ANSI.Types
import Types
type ChatReader m = (MonadUnliftIO m, MonadReader ChatController m)
showInvitation :: ChatReader m => Contact -> SMPQueueInfo -> m ()
showInvitation = printToView .: invitation
showAgentError :: ChatReader m => Contact -> AgentErrorType -> m ()
showAgentError = printToView .: agentError
showContactDeleted :: ChatReader m => Contact -> m ()
showContactDeleted = printToView . contactDeleted
showContactConnected :: ChatReader m => Contact -> m ()
showContactConnected = printToView . contactConnected
showContactDisconnected :: ChatReader m => Contact -> m ()
showContactDisconnected = printToView . contactDisconnected
showReceivedMessage :: ChatReader m => Contact -> UTCTime -> ByteString -> MsgIntegrity -> m ()
showReceivedMessage c utcTime msg mOk = printToView =<< liftIO (receivedMessage c utcTime msg mOk)
showSentMessage :: ChatReader m => Contact -> ByteString -> m ()
showSentMessage c msg = printToView =<< liftIO (sentMessage c msg)
invitation :: Contact -> SMPQueueInfo -> [StyledString]
invitation c qInfo =
[ "pass this invitation to your contact " <> ttyContact c <> " (via any channel): ",
"",
(bPlain . serializeSmpQueueInfo) qInfo,
"",
"and ask them to connect: /c <name_for_you> <invitation_above>"
]
contactDeleted :: Contact -> [StyledString]
contactDeleted c = [ttyContact c <> " is deleted"]
contactConnected :: Contact -> [StyledString]
contactConnected c = [ttyContact c <> " is connected"]
contactDisconnected :: Contact -> [StyledString]
contactDisconnected c = ["disconnected from " <> ttyContact c <> " - restart chat"]
receivedMessage :: Contact -> UTCTime -> ByteString -> MsgIntegrity -> IO [StyledString]
receivedMessage c utcTime msg mOk = do
t <- formatUTCTime <$> getCurrentTimeZone <*> getZonedTime
pure $ prependFirst (t <> " " <> ttyFromContact c) (msgPlain msg) ++ showIntegrity mOk
where
formatUTCTime :: TimeZone -> ZonedTime -> StyledString
formatUTCTime localTz currentTime =
let localTime = utcToLocalTime localTz utcTime
format =
if (localDay localTime < localDay (zonedTimeToLocalTime currentTime))
&& (timeOfDayToTime (localTimeOfDay localTime) > (6 * 60 * 60 :: DiffTime))
then "%m-%d" -- if message is from yesterday or before and 6 hours has passed since midnight
else "%H:%M"
in styleTime $ formatTime defaultTimeLocale format localTime
showIntegrity :: MsgIntegrity -> [StyledString]
showIntegrity MsgOk = []
showIntegrity (MsgError err) = msgError $ case err of
MsgSkipped fromId toId ->
"skipped message ID " <> show fromId
<> if fromId == toId then "" else ".." <> show toId
MsgBadId msgId -> "unexpected message ID " <> show msgId
MsgBadHash -> "incorrect message hash"
MsgDuplicate -> "duplicate message ID"
msgError :: String -> [StyledString]
msgError s = [styled (Colored Red) s]
sentMessage :: Contact -> ByteString -> IO [StyledString]
sentMessage c msg = do
time <- formatTime defaultTimeLocale "%H:%M" <$> getZonedTime
pure $ prependFirst (styleTime time <> " " <> ttyToContact c) (msgPlain msg)
prependFirst :: StyledString -> [StyledString] -> [StyledString]
prependFirst s [] = [s]
prependFirst s (s' : ss) = (s <> s') : ss
msgPlain :: ByteString -> [StyledString]
msgPlain = map styleMarkdownText . T.lines . safeDecodeUtf8
agentError :: Contact -> AgentErrorType -> [StyledString]
agentError c = \case
CONN e -> case e of
NOT_FOUND -> ["no contact " <> ttyContact c]
DUPLICATE -> ["contact " <> ttyContact c <> " already exists"]
SIMPLEX -> ["contact " <> ttyContact c <> " did not accept invitation yet"]
e -> ["chat error: " <> plain (show e)]
printToView :: (MonadUnliftIO m, MonadReader ChatController m) => [StyledString] -> m ()
printToView s = asks chatTerminal >>= liftIO . (`printToTerminal` s)
ttyContact :: Contact -> StyledString
ttyContact (Contact a) = styled (Colored Green) a
ttyToContact :: Contact -> StyledString
ttyToContact (Contact a) = styled (Colored Cyan) $ a <> " "
ttyFromContact :: Contact -> StyledString
ttyFromContact (Contact a) = styled (Colored Yellow) $ a <> "> "
ttyGroup :: Group -> StyledString
ttyGroup (Group g) = styled (Colored Blue) $ "#" <> g
ttyFromGroup :: Group -> Contact -> StyledString
ttyFromGroup (Group g) (Contact a) = styled (Colored Yellow) $ "#" <> g <> " " <> a <> "> "
styleTime :: String -> StyledString
styleTime = Styled [SetColor Foreground Vivid Black]
safeDecodeUtf8 :: ByteString -> Text
safeDecodeUtf8 = decodeUtf8With onError
where
onError _ _ = Just '?'

11
apps/dog-food/Types.hs
View File

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

45
apps/simplex-chat/Main.hs Normal file
View File

@ -0,0 +1,45 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (readTVarIO, retry)
import Control.Monad (forever, void)
import Simplex.Demo (chatLayoutDemo)
import Simplex.Store (createStore)
import System.IO (hFlush, stdout)
import System.Terminal (putStringLn, runTerminalT, withTerminal)
import qualified System.Terminal as C
import qualified System.Terminal.Internal as C
defaultSettings :: C.Size -> C.VirtualTerminalSettings
defaultSettings size =
C.VirtualTerminalSettings
{ C.virtualType = "xterm",
C.virtualWindowSize = pure size,
C.virtualEvent = retry,
C.virtualInterrupt = retry
}
main :: IO ()
main = do
void $ createStore "simplex-chat.db" 4
hFlush stdout
-- ChatTerminal {termSize} <- newChatTerminal
-- pos <- C.withVirtualTerminal (defaultSettings termSize) $
-- \t -> runTerminalT (C.setAlternateScreenBuffer True >> C.putString "a" >> C.flush >> C.getCursorPosition) t
-- print pos
-- race_ (printEvents t) (updateTerminal t)
void . withTerminal . runTerminalT $ chatLayoutDemo >> C.flush >> C.awaitEvent
printEvents :: C.VirtualTerminal -> IO ()
printEvents t = forever $ do
event <- withTerminal . runTerminalT $ C.flush >> C.awaitEvent
runTerminalT (putStringLn $ show event) t
updateTerminal :: C.VirtualTerminal -> IO ()
updateTerminal t = forever $ do
threadDelay 10000
win <- readTVarIO $ C.virtualWindow t
withTerminal . runTerminalT $ mapM_ C.putStringLn win >> C.flush

119
apps/simplex-chat/Simplex/Demo.hs Normal file
View File

@ -0,0 +1,119 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Demo where
import Simplex.Chat.Styled
import System.Console.ANSI.Types
import System.Terminal
someViewUpdate :: Monad m => m ()
someViewUpdate = pure ()
chatLayoutDemo :: MonadTerminal m => m ()
chatLayoutDemo =
mapM_
putStyledLn
[ " search " <> Styled gray "(ctrl-s) " <> lineV <> Styled toContact " @bob " <> "Bob Roberts " <> Styled greenColor "@john" <> "",
" " <> lineV <> Styled gray " 14:15 online profile (ctrl-p)",
lineH 20 <> crossover <> lineH 59,
"* " <> Styled [SetConsoleIntensity BoldIntensity] "all chats " <> " " <> lineV <> "",
Styled gray " (ctrl-a) " <> lineV <> "",
"*" <> Styled toContact " @alice " <> Styled darkGray "14:37 " <> lineV <> "",
Styled gray " Hello there! ... " <> lineV <> "",
Styled selected " " <> Styled (toContact <> selected) " @bob " <> Styled (selected <> gray) "12:35 " <> lineV <> "",
Styled selected " All good, John... " <> lineV <> "",
"*" <> Styled group " #team " <> Styled darkGray "10:55 " <> lineV <> "",
Styled gray " What's up ther... " <> lineV <> "",
" " <> Styled toContact " @tom " <> Styled darkGray "Wed " <> lineV <> "",
Styled gray " Have you seen ... " <> lineV <> "",
" " <> lineV,
" " <> lineV,
" " <> lineV,
" " <> lineV,
" " <> lineV,
" " <> lineV <> Styled greenColor " ✔︎" <> Styled darkGray " 12:30" <> Styled toContact " @bob" <> " hey bob - how is it going?",
" " <> lineV <> Styled greenColor " ✔︎" <> Styled darkGray " " <> Styled toContact " " <> " let's meet soon!",
" " <> lineV <> " *" <> Styled darkGray " 12:35" <> Styled contact " bob>" <> " All good, John! How are you?",
" " <> teeL <> lineH 59,
" " <> lineV <> " > " <> Styled toContact "@bob" <> " 😀 This is the message that will be sent to @bob"
]
>> putStyled (Styled ctrlKeys " help (ctrl-h) new contact (ctrl-n) choose chat (ctrl-↓↑) new group (ctrl-g) ")
contact :: [SGR]
contact = [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Yellow]
toContact :: [SGR]
toContact = [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Cyan]
group :: [SGR]
group = [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Cyan]
selected :: [SGR]
selected = [SetColor Background Vivid Black]
ctrlKeys :: [SGR]
ctrlKeys = [SetColor Background Dull White, SetColor Foreground Dull Black]
gray :: [SGR]
gray = [SetColor Foreground Dull White]
darkGray :: [SGR]
darkGray = [SetColor Foreground Vivid Black]
greenColor :: [SGR]
greenColor = [SetColor Foreground Vivid Green]
lineV :: StyledString
lineV = Styled selected " " -- "\x2502"
lineH :: Int -> StyledString
lineH n = Styled darkGray $ replicate n '\x2500'
teeL :: StyledString
teeL = Styled selected " " -- "\x251C"
crossover :: StyledString
crossover = Styled selected " " -- "\x253C"
putStyledLn :: MonadTerminal m => StyledString -> m ()
putStyledLn s = putStyled s >> putLn
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

41
apps/simplex-chat/Simplex/Store.hs Normal file
View File

@ -0,0 +1,41 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TemplateHaskell #-}
module Simplex.Store where
import Control.Concurrent.STM
import Control.Monad (replicateM_)
import Data.FileEmbed (embedDir, makeRelativeToProject)
import Data.Function (on)
import Data.List (sortBy)
import Data.Text.Encoding (decodeUtf8)
import qualified Database.SQLite.Simple as DB
import Numeric.Natural (Natural)
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), connectSQLiteStore, createSQLiteStore)
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
import System.FilePath (takeBaseName, takeExtension)
-- | The list of migrations in ascending order by date
migrations :: [Migration]
migrations =
sortBy (compare `on` name) . map migration . filter sqlFile $
$(makeRelativeToProject "migrations" >>= embedDir)
where
sqlFile (file, _) = takeExtension file == ".sql"
migration (file, qStr) = Migration {name = takeBaseName file, up = decodeUtf8 qStr}
data SQLitePool = SQLitePool
{ dbFilePath :: FilePath,
dbPool :: TBQueue DB.Connection,
dbNew :: Bool
}
createStore :: FilePath -> Natural -> IO SQLitePool
createStore dbFilePath poolSize = do
SQLiteStore {dbConn = c, dbNew} <- createSQLiteStore dbFilePath migrations
dbPool <- newTBQueueIO poolSize
atomically $ writeTBQueue dbPool c
replicateM_ (fromInteger $ toInteger $ poolSize - 1) $
connectSQLiteStore dbFilePath >>= atomically . writeTBQueue dbPool . dbConn
pure SQLitePool {dbFilePath, dbPool, dbNew}

160
migrations/20210612_initial.sql Normal file
View File

@ -0,0 +1,160 @@
CREATE TABLE contact_profiles ( -- remote user profile
contact_profile_id INTEGER PRIMARY KEY,
contact_ref TEXT NOT NULL, -- contact name set by remote user (not unique), this name must not contain spaces
properties TEXT NOT NULL DEFAULT '{}' -- JSON with contact profile properties
);
-- the first record (id = 1) is reserved for the first local user
INSERT INTO contact_profiles (contact_profile_id, contact_ref) VALUES (1, '');
CREATE TABLE users (
user_id INTEGER PRIMARY KEY,
contact_profile_id INTEGER NOT NULL UNIQUE REFERENCES contact_profiles -- user's profile
);
-- the first record (id = 1) is reserved for the first local user
INSERT INTO users (user_id, contact_profile_id) VALUES (1, 1);
CREATE TABLE known_servers(
server_id INTEGER PRIMARY KEY,
host TEXT NOT NULL,
port TEXT NOT NULL,
key_hash BLOB,
user_id INTEGER NOT NULL REFERENCES user_id,
UNIQUE (user_id, host, port)
) WITHOUT ROWID;
CREATE TABLE contacts (
contact_id INTEGER PRIMARY KEY,
local_contact_ref TEXT NOT NULL UNIQUE, -- contact name set by local user - must be unique
local_properties TEXT NOT NULL DEFAULT '{}', -- JSON set by local user
contact_profile_id INTEGER UNIQUE REFERENCES contact_profiles, -- profile sent by remote contact, NULL for incognito contacts
contact_status TEXT NOT NULL DEFAULT '',
user_id INTEGER NOT NULL REFERENCES user_id
);
CREATE TABLE connections ( -- all SMP agent connections
connection_id INTEGER PRIMARY KEY,
agent_conn_id BLOB NOT NULL UNIQUE,
conn_level INTEGER NOT NULL DEFAULT 0,
via_conn BLOB REFERENCES contact_connections (connection_id),
conn_status TEXT NOT NULL DEFAULT '',
user_id INTEGER NOT NULL REFERENCES user_id
);
CREATE TABLE contact_connections ( -- connections only for direct messages, many per contact
connection_id INTEGER NOT NULL UNIQUE REFERENCES connections ON DELETE CASCADE,
contact_id INTEGER NOT NULL REFERENCES contacts ON DELETE RESTRICT -- connection must be removed first via the agent
);
CREATE TABLE contact_invitations (
invitation_id INTEGER PRIMARY KEY,
agent_inv_id BLOB UNIQUE,
invitation TEXT,
contact_id INTEGER NOT NULL REFERENCES contacts ON DELETE RESTRICT,
invitation_status TEXT NOT NULL DEFAULT ''
);
CREATE TABLE group_profiles ( -- shared group profiles
group_profile_id INTEGER PRIMARY KEY,
group_ref TEXT NOT NULL, -- this name must not contain spaces
properties TEXT NOT NULL DEFAULT '{}' -- JSON with user or contact profile
);
CREATE TABLE groups (
group_id INTEGER PRIMARY KEY, -- local group ID
local_group_ref TEXT NOT NULL UNIQUE, -- local group name without spaces
local_properties TEXT NOT NULL, -- local JSON group properties
group_profile_id INTEGER REFERENCES group_profiles, -- shared group profile
user_group_member_details_id INTEGER NOT NULL
REFERENCES group_member_details (group_member_details_id) ON DELETE RESTRICT,
user_id INTEGER NOT NULL REFERENCES user_id
);
CREATE TABLE group_members ( -- group members, excluding the local user
group_member_id INTEGER PRIMARY KEY,
group_id INTEGER NOT NULL REFERENCES groups ON DELETE RESTRICT,
group_member_details_id INTEGER NOT NULL REFERENCES group_member_details ON DELETE RESTRICT,
contact_id INTEGER NOT NULL REFERENCES contacts ON DELETE RESTRICT,
connection_id INTEGER UNIQUE REFERENCES connections
);
CREATE TABLE group_member_details (
group_member_details_id INTEGER PRIMARY KEY,
group_id INTEGER NOT NULL REFERENCES groups ON DELETE RESTRICT,
member_id BLOB NOT NULL, -- shared member ID, unique per group
member_role TEXT NOT NULL DEFAULT '', -- owner, admin, moderator, ''
member_status TEXT NOT NULL DEFAULT '', -- inv | con | full | off
invited_by INTEGER REFERENCES contacts ON DELETE RESTRICT, -- NULL for the members who joined before the current user and for the group creator
UNIQUE (group_id, member_id)
);
CREATE TABLE events ( -- messages received by the agent, append only
event_id INTEGER PRIMARY KEY,
agent_msg_id INTEGER NOT NULL, -- internal message ID
external_msg_id INTEGER NOT NULL, -- external message ID (sent or received)
agent_meta TEXT NOT NULL, -- JSON with timestamps etc. sent in MSG
connection_id INTEGER NOT NULL REFERENCES connections,
received INTEGER NOT NULL, -- 0 for received, 1 for sent
event_type TEXT NOT NULL, -- event type - see protocol/types.ts
event_encoding INTEGER NOT NULL, -- format of event_body: 0 - binary, 1 - text utf8, 2 - JSON (utf8)
content_type TEXT NOT NULL, -- content type - see protocol/types.ts
event_body BLOB, -- agent message body as sent
event_hash BLOB NOT NULL,
integrity TEXT NOT NULL DEFAULT '',
created_at TEXT NOT NULL DEFAULT (datetime('now'))
);
CREATE INDEX events_external_msg_id_index ON events (connection_id, external_msg_id);
CREATE TABLE contact_profile_events (
event_id INTEGER NOT NULL UNIQUE REFERENCES events,
contact_profile_id INTEGER NOT NULL REFERENCES contact_profiles
);
CREATE TABLE group_profile_events (
event_id INTEGER NOT NULL UNIQUE REFERENCES events,
group_profile_id INTEGER NOT NULL REFERENCES group_profiles
);
CREATE TABLE group_events (
event_id INTEGER NOT NULL UNIQUE REFERENCES events,
group_id INTEGER NOT NULL REFERENCES groups ON DELETE RESTRICT,
group_member_id INTEGER REFERENCES group_members -- NULL for current user
);
CREATE TABLE group_event_parents (
group_event_parent_id INTEGER PRIMARY KEY,
event_id INTEGER NOT NULL REFERENCES group_events (event_id),
parent_group_member_id INTEGER REFERENCES group_members (group_member_id), -- can be NULL if parent_member_id is incorrect
parent_member_id BLOB, -- shared member ID, unique per group
parent_event_id INTEGER REFERENCES events (event_id) ON DELETE CASCADE, -- this can be NULL if received event references another event that's not received yet
parent_external_msg_id INTEGER NOT NULL,
parent_event_hash BLOB NOT NULL
);
CREATE INDEX group_event_parents_parent_external_msg_id_index
ON group_event_parents (parent_member_id, parent_external_msg_id);
CREATE TABLE blobs (
blob_id INTEGER PRIMARY KEY,
content BLOB NOT NULL
);
CREATE TABLE messages ( -- mutable messages presented to user
message_id INTEGER PRIMARY KEY,
contact_id INTEGER NOT NULL REFERENCES contacts ON DELETE RESTRICT, -- 1 for sent messages
group_id INTEGER REFERENCES groups ON DELETE RESTRICT, -- NULL for direct messages
deleted INTEGER NOT NULL, -- 1 for deleted
msg_type TEXT NOT NULL,
content_type TEXT NOT NULL,
msg_text TEXT NOT NULL, -- textual representation
msg_props TEXT NOT NULL, -- JSON
msg_blob_id INTEGER REFERENCES blobs (blob_id) ON DELETE RESTRICT -- optional binary content
);
CREATE TABLE message_events (
event_id INTEGER NOT NULL UNIQUE REFERENCES events,
message_id INTEGER NOT NULL REFERENCES messages
);

25
package.yaml
View File

@ -15,7 +15,9 @@ dependencies:
- ansi-terminal == 0.10.*
- attoparsec == 0.13.*
- base >= 4.7 && < 5
- bytestring == 0.10.*
- containers == 0.6.*
- simplexmq == 0.3.*
- text == 1.2.*
library:
@ -29,6 +31,7 @@ executables:
- simplex-chat
- async == 2.2.*
- bytestring == 0.10.*
- composition == 1.0.*
- directory == 1.3.*
- filepath == 1.4.*
- mtl == 2.2.*
@ -39,6 +42,28 @@ executables:
- terminal == 0.2.*
- time == 1.9.*
- unliftio == 0.2.*
- unliftio-core == 0.2.*
ghc-options:
- -threaded
simplex-chat:
source-dirs: apps/simplex-chat
main: Main.hs
dependencies:
- simplex-chat
- async == 2.2.*
- bytestring == 0.10.*
- composition == 1.0.*
- cryptonite == 0.27.*
- file-embed == 0.0.14.*
- filepath == 1.4.*
- mtl == 2.2.*
- simplexmq == 0.3.*
- sqlite-simple == 0.4.*
- stm == 2.5.*
- terminal == 0.2.*
- unliftio == 0.2.*
- unliftio-core == 0.2.*
ghc-options:
- -threaded

74
protocol/types.ts Normal file
View File

@ -0,0 +1,74 @@
// x. namespace is for chat messages transmitted inside SMP agent MSG
type MemberMessageType =
| "x.grp.info" // group profile information or update
| "x.grp.off" // disable group
| "x.grp.del" // group deleted
| "x.grp.mem.new" // new group member
| "x.grp.mem.acl" // group member permissions (ACL)
| "x.grp.mem.leave" // group member left
| "x.grp.mem.off" // suspend group member
| "x.grp.mem.on" // enable group member
| "x.grp.mem.del" // group member removed
type ProfileMessageType =
| "x.info" // profile information or update
| "x.info.grp" // information about group in profile
| "x.info.con" // information about contact in profile
type NotificationMessageType = "x.msg.read"
type OpenConnMessageType =
| "x.open.grp" // open invitation to the group
| "x.open.con" // open invitation to the contact
type ContentMessageType =
| "x.msg.new" // new message
| "x.msg.append" // additional part of the message
| "x.msg.del" // delete message
| "x.msg.update" // update message
| "x.msg.fwd" // forward message
| "x.msg.reply" // reply to message
// TODO namespace for chat messages transmitted as other agent messages
type DirectMessageType =
| ProfileMessageType
| NotificationMessageType
| OpenConnMessageType
| ContentMessageType
type GroupMessageType = MemberMessageType | DirectMessageType
type ContentType =
| "c.text"
| "c.html"
| "c.image"
| "c.audio"
| "c.video"
| "c.doc"
| "c.sticker"
| "c.file"
| "c.link"
| "c.form"
| "c.poll"
| "c.applet"
// the type of message data transmitted inside SMP agent MSG
interface MessageData<T extends GroupMessageType> {
type: T
sent: Date
data: unknown
}
interface DirectMessageData<T extends DirectMessageType> extends MessageData<T> {}
interface GroupMessageData<T extends GroupMessageType> extends MessageData<T> {
msgId: number
parents: ParentMessage[]
}
interface ParentMessage {
memberId: Uint8Array
msgId: number
msgHash: Uint8Array
}

13
src/Simplex/Chat/Protocol._hs
View File

@ -1,13 +0,0 @@
module Simplex.Chat.Protocol where
data Profile = Profile
{ displayName :: Text,
fullName :: Text
}
data Contact = Contact
{ profile :: Profile,
connection :: ConnAlias
}
data ChatMessage = ContentMessage | ReadNotification | FileTransfer

44
src/Simplex/Chat/Protocol.hs Normal file
View File

@ -0,0 +1,44 @@
{-# LANGUAGE DuplicateRecordFields #-}
module Simplex.Chat.Protocol where
import Data.ByteString (ByteString)
import Data.Text (Text)
import Simplex.Messaging.Agent.Protocol (ConnId)
data ChatEvent = GroupEvent | MessageEvent | InfoEvent
data Profile = Profile
{ profileId :: ByteString,
displayName :: Text
}
data Contact = Contact
{ contactId :: ByteString,
profile :: Profile,
connections :: [Connection]
}
data Connection = Connection
{ connId :: ConnId,
connLevel :: Int,
viaConn :: ConnId
}
data GroupMember = GroupMember
{ groupId :: ByteString,
sharedMemberId :: ByteString,
contact :: Contact,
memberRole :: GroupMemberRole,
memberStatus :: GroupMemberStatus
}
data GroupMemberRole = GROwner | GRAdmin | GRStandard
data GroupMemberStatus = GSInvited | GSConnected | GSConnectedAll
data Group = Group
{ groupId :: ByteString,
displayName :: Text,
members :: [GroupMember]
}

2
apps/dog-food/Styled.hs → src/Simplex/Chat/Styled.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
module Styled
module Simplex.Chat.Styled
( StyledString (..),
bPlain,
plain,

2
stack.yaml
View File

@ -43,7 +43,7 @@ extra-deps:
# - simplexmq-0.3.1@sha256:f247aaff3c16c5d3974a4ab4d5882ab50ac78073110997c0bceb05a74d10a325,6688
# - ../simplexmq
- github: simplex-chat/simplexmq
commit: dffa7a61006aa5c4050c954857aaf1357fe33242
commit: 09c6adeabc533537dcc039e2195123c6f7167ebe
#
# extra-deps: []