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
23 changed files with 1078 additions and 701 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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 '?'

71
apps/dog-food/Styled.hs
View File

@@ -1,71 +0,0 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
module Styled
( StyledString (..),
bPlain,
plain,
styleMarkdown,
styleMarkdownText,
styled,
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.Chat.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]
class StyledFormat a where
styled :: Format -> a -> StyledString
instance StyledFormat String where styled = Styled . sgr
instance StyledFormat ByteString where styled f = styled f . B.unpack
instance StyledFormat Text where styled f = styled f . T.unpack
sgr :: Format -> [SGR]
sgr = \case
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

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}