mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-12 23:56:28 +00:00
move haskell implementation to a folder (#108)
* move haskell implementation to a folder * build v5 branch * fixing CI
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
8b7d6e5f19
commit
5cba18120b
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,87 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.Controller where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Int (Int64)
|
||||
import Data.Map.Strict (Map)
|
||||
import Numeric.Natural
|
||||
import Simplex.Chat.Notification
|
||||
import Simplex.Chat.Store (StoreError)
|
||||
import Simplex.Chat.Terminal
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent (AgentClient)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig)
|
||||
import Simplex.Messaging.Agent.Protocol (AgentErrorType)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
|
||||
import System.IO (Handle)
|
||||
import UnliftIO.STM
|
||||
|
||||
data ChatConfig = ChatConfig
|
||||
{ agentConfig :: AgentConfig,
|
||||
dbPoolSize :: Int,
|
||||
tbqSize :: Natural,
|
||||
fileChunkSize :: Integer
|
||||
}
|
||||
|
||||
data ChatController = ChatController
|
||||
{ currentUser :: TVar User,
|
||||
smpAgent :: AgentClient,
|
||||
chatTerminal :: ChatTerminal,
|
||||
chatStore :: SQLiteStore,
|
||||
idsDrg :: TVar ChaChaDRG,
|
||||
inputQ :: TBQueue InputEvent,
|
||||
notifyQ :: TBQueue Notification,
|
||||
sendNotification :: Notification -> IO (),
|
||||
chatLock :: TMVar (),
|
||||
sndFiles :: TVar (Map Int64 Handle),
|
||||
rcvFiles :: TVar (Map Int64 Handle),
|
||||
config :: ChatConfig
|
||||
}
|
||||
|
||||
data InputEvent = InputCommand String | InputControl Char
|
||||
|
||||
data ChatError
|
||||
= ChatError ChatErrorType
|
||||
| ChatErrorMessage String
|
||||
| ChatErrorAgent AgentErrorType
|
||||
| ChatErrorStore StoreError
|
||||
deriving (Show, Exception)
|
||||
|
||||
data ChatErrorType
|
||||
= CEGroupUserRole
|
||||
| CEGroupContactRole ContactName
|
||||
| CEGroupDuplicateMember ContactName
|
||||
| CEGroupDuplicateMemberId
|
||||
| CEGroupNotJoined GroupName
|
||||
| CEGroupMemberNotActive
|
||||
| CEGroupMemberUserRemoved
|
||||
| CEGroupMemberNotFound ContactName
|
||||
| CEGroupInternal String
|
||||
| CEFileNotFound String
|
||||
| CEFileAlreadyReceiving String
|
||||
| CEFileAlreadyExists FilePath
|
||||
| CEFileRead FilePath SomeException
|
||||
| CEFileWrite FilePath SomeException
|
||||
| CEFileSend Int64 AgentErrorType
|
||||
| CEFileRcvChunk String
|
||||
| CEFileInternal String
|
||||
deriving (Show, Exception)
|
||||
|
||||
type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m)
|
||||
|
||||
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'
|
||||
@@ -0,0 +1,109 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.Help
|
||||
( chatHelpInfo,
|
||||
filesHelpInfo,
|
||||
groupsHelpInfo,
|
||||
markdownInfo,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.List (intersperse)
|
||||
import Data.Text (Text)
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Styled
|
||||
import System.Console.ANSI.Types
|
||||
|
||||
highlight :: Text -> Markdown
|
||||
highlight = Markdown (Colored Cyan)
|
||||
|
||||
green :: Text -> Markdown
|
||||
green = Markdown (Colored Green)
|
||||
|
||||
indent :: Markdown
|
||||
indent = " "
|
||||
|
||||
listHighlight :: [Text] -> Markdown
|
||||
listHighlight = mconcat . intersperse ", " . map highlight
|
||||
|
||||
chatHelpInfo :: [StyledString]
|
||||
chatHelpInfo =
|
||||
map
|
||||
styleMarkdown
|
||||
[ highlight "Using SimpleX chat prototype",
|
||||
"Follow these steps to set up a connection:",
|
||||
"",
|
||||
green "Step 1: " <> highlight "/connect" <> " - Alice adds a contact.",
|
||||
indent <> "Alice should send the invitation printed by the /add command",
|
||||
indent <> "to her contact, Bob, out-of-band, via any trusted channel.",
|
||||
"",
|
||||
green "Step 2: " <> highlight "/connect <invitation>" <> " - Bob accepts the invitation.",
|
||||
indent <> "Bob should use the invitation he received out-of-band.",
|
||||
"",
|
||||
green "Step 3: " <> "Bob and Alice are notified that the connection is set up,",
|
||||
indent <> "both can now send messages:",
|
||||
indent <> highlight "@bob Hello, Bob!" <> " - Alice messages Bob (assuming Bob has display name 'bob').",
|
||||
indent <> highlight "@alice Hey, Alice!" <> " - Bob replies to Alice.",
|
||||
"",
|
||||
green "To send file:",
|
||||
indent <> highlight "/file bob ./photo.jpg" <> " - Alice sends file to Bob",
|
||||
indent <> "File commands: " <> highlight "/help files",
|
||||
"",
|
||||
green "To create group:",
|
||||
indent <> highlight "/group team" <> " - create group #team",
|
||||
indent <> "Group commands: " <> highlight "/help groups",
|
||||
"",
|
||||
green "Other commands:",
|
||||
indent <> highlight "/profile " <> " - show user profile",
|
||||
indent <> highlight "/profile <name> [<full_name>]" <> " - update user profile",
|
||||
indent <> highlight "/delete <contact>" <> " - delete contact and all messages with them",
|
||||
indent <> highlight "/markdown " <> " - show supported markdown syntax",
|
||||
indent <> highlight "/quit " <> " - quit chat",
|
||||
"",
|
||||
"The commands may be abbreviated to a single letter: " <> listHighlight ["/c", "/f", "/g", "/p", "/h"] <> ", etc."
|
||||
]
|
||||
|
||||
filesHelpInfo :: [StyledString]
|
||||
filesHelpInfo =
|
||||
map
|
||||
styleMarkdown
|
||||
[ green "File transfer commands:",
|
||||
indent <> highlight "/file @<contact> <file_path> " <> " - send file to contact",
|
||||
indent <> highlight "/file #<group> <file_path> " <> " - send file to group",
|
||||
indent <> highlight "/freceive <file_id> [<file_path>]" <> " - accept to receive file",
|
||||
indent <> highlight "/fcancel <file_id> " <> " - cancel sending / receiving file",
|
||||
indent <> highlight "/fstatus <file_id> " <> " - show file transfer status",
|
||||
"",
|
||||
"The commands may be abbreviated: " <> listHighlight ["/f", "/fr", "/fc", "/fs"]
|
||||
]
|
||||
|
||||
groupsHelpInfo :: [StyledString]
|
||||
groupsHelpInfo =
|
||||
map
|
||||
styleMarkdown
|
||||
[ green "Group management commands:",
|
||||
indent <> highlight "/group <group> [<full_name>] " <> " - create group",
|
||||
indent <> highlight "/add <group> <contact> [<role>]" <> " - add contact to group, roles: " <> highlight "owner" <> ", " <> highlight "admin" <> " (default), " <> highlight "member",
|
||||
indent <> highlight "/join <group> " <> " - accept group invitation",
|
||||
indent <> highlight "/remove <group> <member> " <> " - remove member from group",
|
||||
indent <> highlight "/leave <group> " <> " - leave group",
|
||||
indent <> highlight "/delete <group> " <> " - delete group",
|
||||
indent <> highlight "/members <group> " <> " - list group members",
|
||||
indent <> highlight "#<group> <message> " <> " - send message to group",
|
||||
"",
|
||||
"The commands may be abbreviated: " <> listHighlight ["/g", "/a", "/j", "/rm", "/l", "/d", "/ms"]
|
||||
]
|
||||
|
||||
markdownInfo :: [StyledString]
|
||||
markdownInfo =
|
||||
map
|
||||
styleMarkdown
|
||||
[ green "Markdown:",
|
||||
indent <> highlight "*bold* " <> " - " <> Markdown Bold "bold text",
|
||||
indent <> highlight "_italic_ " <> " - " <> Markdown Italic "italic text" <> " (shown as underlined)",
|
||||
indent <> highlight "+underlined+ " <> " - " <> Markdown Underline "underlined text",
|
||||
indent <> highlight "~strikethrough~" <> " - " <> Markdown StrikeThrough "strikethrough text" <> " (shown as inverse)",
|
||||
indent <> highlight "`code snippet` " <> " - " <> Markdown Snippet "a + b // no *markdown* here",
|
||||
indent <> highlight "!1 text! " <> " - " <> Markdown (Colored Red) "red text" <> " (1-6: red, green, blue, yellow, cyan, magenta)",
|
||||
indent <> highlight "#secret# " <> " - " <> Markdown Secret "secret text" <> " (can be copy-pasted)"
|
||||
]
|
||||
@@ -0,0 +1,118 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module Simplex.Chat.Input where
|
||||
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Data.List (dropWhileEnd)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Terminal
|
||||
import System.Exit (exitSuccess)
|
||||
import System.Terminal hiding (insertChars)
|
||||
import UnliftIO.STM
|
||||
|
||||
getKey :: MonadTerminal m => m (Key, Modifiers)
|
||||
getKey =
|
||||
flush >> awaitEvent >>= \case
|
||||
Left Interrupt -> liftIO exitSuccess
|
||||
Right (KeyEvent key ms) -> pure (key, ms)
|
||||
_ -> getKey
|
||||
|
||||
runTerminalInput :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
|
||||
runTerminalInput = do
|
||||
ChatController {inputQ, chatTerminal = ct} <- ask
|
||||
liftIO $
|
||||
withChatTerm ct $ do
|
||||
updateInput ct
|
||||
receiveFromTTY inputQ ct
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
CharKey c
|
||||
| ms == mempty || ms == shiftKey -> insertCharsWithContact [c]
|
||||
| ms == altKey && c == 'b' -> setPosition prevWordPos
|
||||
| ms == altKey && c == 'f' -> setPosition nextWordPos
|
||||
| otherwise -> ts
|
||||
TabKey -> insertCharsWithContact " "
|
||||
BackspaceKey -> backDeleteChar
|
||||
DeleteKey -> deleteChar
|
||||
HomeKey -> setPosition 0
|
||||
EndKey -> setPosition $ length s
|
||||
ArrowKey d -> case d of
|
||||
Leftwards -> setPosition leftPos
|
||||
Rightwards -> setPosition rightPos
|
||||
Upwards
|
||||
| ms == mempty && null s -> let s' = previousInput ts in ts' (s', length s')
|
||||
| ms == mempty -> let p' = p - tw in if p' > 0 then setPosition p' else ts
|
||||
| otherwise -> ts
|
||||
Downwards
|
||||
| ms == mempty -> let p' = p + tw in if p' <= length s then setPosition p' else ts
|
||||
| otherwise -> ts
|
||||
_ -> ts
|
||||
where
|
||||
insertCharsWithContact cs
|
||||
| null s && cs /= "@" && cs /= "#" && cs /= "/" =
|
||||
insertChars $ contactPrefix <> cs
|
||||
| otherwise = insertChars cs
|
||||
insertChars = ts' . if p >= length s then append else insert
|
||||
append cs = let s' = s <> cs in (s', length s')
|
||||
insert cs = let (b, a) = splitAt p s in (b <> cs <> a, p + length cs)
|
||||
contactPrefix = case ac of
|
||||
ActiveNone -> ""
|
||||
ActiveC c -> "@" <> T.unpack c <> " "
|
||||
ActiveG g -> "#" <> T.unpack g <> " "
|
||||
backDeleteChar
|
||||
| p == 0 || null s = ts
|
||||
| p >= length s = ts' (init s, length s - 1)
|
||||
| otherwise = let (b, a) = splitAt p s in ts' (init b <> a, p - 1)
|
||||
deleteChar
|
||||
| p >= length s || null s = ts
|
||||
| p == 0 = ts' (tail s, 0)
|
||||
| otherwise = let (b, a) = splitAt p s in ts' (b <> tail a, p)
|
||||
leftPos
|
||||
| ms == mempty = max 0 (p - 1)
|
||||
| ms == shiftKey = 0
|
||||
| ms == ctrlKey = prevWordPos
|
||||
| ms == altKey = prevWordPos
|
||||
| otherwise = p
|
||||
rightPos
|
||||
| ms == mempty = min (length s) (p + 1)
|
||||
| ms == shiftKey = length s
|
||||
| ms == ctrlKey = nextWordPos
|
||||
| ms == altKey = nextWordPos
|
||||
| otherwise = p
|
||||
setPosition p' = ts' (s, p')
|
||||
prevWordPos
|
||||
| p == 0 || null s = p
|
||||
| otherwise =
|
||||
let before = take p s
|
||||
beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before
|
||||
in max 0 $ p - length before + length beforeWord
|
||||
nextWordPos
|
||||
| p >= length s || null s = p
|
||||
| otherwise =
|
||||
let after = drop p s
|
||||
afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after
|
||||
in min (length s) $ p + length after - length afterWord
|
||||
ts' (s', p') = ts {inputString = s', inputPosition = p'}
|
||||
@@ -0,0 +1,138 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.Markdown where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.Attoparsec.Text (Parser)
|
||||
import qualified Data.Attoparsec.Text as A
|
||||
import Data.Either (fromRight)
|
||||
import Data.Functor (($>))
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.String
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import System.Console.ANSI.Types
|
||||
|
||||
data Markdown = Markdown Format Text | Markdown :|: Markdown
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Format
|
||||
= Bold
|
||||
| Italic
|
||||
| Underline
|
||||
| StrikeThrough
|
||||
| Snippet
|
||||
| Secret
|
||||
| Colored Color
|
||||
| NoFormat
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Semigroup Markdown where (<>) = (:|:)
|
||||
|
||||
instance Monoid Markdown where mempty = unmarked ""
|
||||
|
||||
instance IsString Markdown where fromString = unmarked . T.pack
|
||||
|
||||
unmarked :: Text -> Markdown
|
||||
unmarked = Markdown NoFormat
|
||||
|
||||
colorMD :: Char
|
||||
colorMD = '!'
|
||||
|
||||
secretMD :: Char
|
||||
secretMD = '#'
|
||||
|
||||
formats :: Map Char Format
|
||||
formats =
|
||||
M.fromList
|
||||
[ ('*', Bold),
|
||||
('_', Italic),
|
||||
('+', Underline),
|
||||
('~', StrikeThrough),
|
||||
('`', Snippet),
|
||||
(secretMD, Secret),
|
||||
(colorMD, Colored White)
|
||||
]
|
||||
|
||||
colors :: Map Text Color
|
||||
colors =
|
||||
M.fromList
|
||||
[ ("red", Red),
|
||||
("green", Green),
|
||||
("blue", Blue),
|
||||
("yellow", Yellow),
|
||||
("cyan", Cyan),
|
||||
("magenta", Magenta),
|
||||
("r", Red),
|
||||
("g", Green),
|
||||
("b", Blue),
|
||||
("y", Yellow),
|
||||
("c", Cyan),
|
||||
("m", Magenta),
|
||||
("1", Red),
|
||||
("2", Green),
|
||||
("3", Blue),
|
||||
("4", Yellow),
|
||||
("5", Cyan),
|
||||
("6", Magenta)
|
||||
]
|
||||
|
||||
parseMarkdown :: Text -> Markdown
|
||||
parseMarkdown s = fromRight (unmarked s) $ A.parseOnly (markdownP <* A.endOfInput) s
|
||||
|
||||
markdownP :: Parser Markdown
|
||||
markdownP = merge <$> A.many' fragmentP
|
||||
where
|
||||
merge :: [Markdown] -> Markdown
|
||||
merge [] = ""
|
||||
merge fs = foldr1 (:|:) fs
|
||||
fragmentP :: Parser Markdown
|
||||
fragmentP =
|
||||
A.anyChar >>= \case
|
||||
' ' -> unmarked . T.cons ' ' <$> A.takeWhile (== ' ')
|
||||
c -> case M.lookup c formats of
|
||||
Just Secret -> secretP
|
||||
Just (Colored White) -> coloredP
|
||||
Just f -> formattedP c "" f
|
||||
Nothing -> unformattedP c
|
||||
formattedP :: Char -> Text -> Format -> Parser Markdown
|
||||
formattedP c p f = do
|
||||
s <- A.takeTill (== c)
|
||||
(A.char c $> markdown c p f s) <|> noFormat (c `T.cons` p <> s)
|
||||
markdown :: Char -> Text -> Format -> Text -> Markdown
|
||||
markdown c p f s
|
||||
| T.null s || T.head s == ' ' || T.last s == ' ' =
|
||||
unmarked $ c `T.cons` p <> s `T.snoc` c
|
||||
| otherwise = Markdown f s
|
||||
secretP :: Parser Markdown
|
||||
secretP = secret <$> A.takeWhile (== secretMD) <*> A.takeTill (== secretMD) <*> A.takeWhile (== secretMD)
|
||||
secret :: Text -> Text -> Text -> Markdown
|
||||
secret b s a
|
||||
| T.null a || T.null s || T.head s == ' ' || T.last s == ' ' =
|
||||
unmarked $ secretMD `T.cons` ss
|
||||
| otherwise = Markdown Secret $ T.init ss
|
||||
where
|
||||
ss = b <> s <> a
|
||||
coloredP :: Parser Markdown
|
||||
coloredP = do
|
||||
color <- A.takeWhile (\c -> c /= ' ' && c /= colorMD)
|
||||
case M.lookup color colors of
|
||||
Just c ->
|
||||
let f = Colored c
|
||||
in (A.char ' ' *> formattedP colorMD (color `T.snoc` ' ') f)
|
||||
<|> noFormat (colorMD `T.cons` color)
|
||||
_ -> noFormat (colorMD `T.cons` color)
|
||||
unformattedP :: Char -> Parser Markdown
|
||||
unformattedP c = unmarked . T.cons c <$> wordsP
|
||||
wordsP :: Parser Text
|
||||
wordsP = do
|
||||
s <- (<>) <$> A.takeTill (== ' ') <*> A.takeWhile (== ' ')
|
||||
A.peekChar >>= \case
|
||||
Nothing -> pure s
|
||||
Just c -> case M.lookup c formats of
|
||||
Just _ -> pure s
|
||||
Nothing -> (s <>) <$> wordsP
|
||||
noFormat :: Text -> Parser Markdown
|
||||
noFormat = pure . unmarked
|
||||
@@ -0,0 +1,98 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Simplex.Chat.Notification (Notification (..), initializeNotifications) where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad (void)
|
||||
import Data.List (isInfixOf)
|
||||
import Data.Map (Map, fromList)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist, getAppUserDataDirectory)
|
||||
import System.FilePath (combine)
|
||||
import System.Info (os)
|
||||
import System.Process (readCreateProcess, shell)
|
||||
|
||||
data Notification = Notification {title :: Text, text :: Text}
|
||||
|
||||
initializeNotifications :: IO (Notification -> IO ())
|
||||
initializeNotifications =
|
||||
hideException <$> case os of
|
||||
"darwin" -> pure $ notify macScript
|
||||
"mingw32" -> initWinNotify
|
||||
"linux" ->
|
||||
doesFileExist "/proc/sys/kernel/osrelease" >>= \case
|
||||
False -> pure $ notify linuxScript
|
||||
True -> do
|
||||
v <- readFile "/proc/sys/kernel/osrelease"
|
||||
if "Microsoft" `isInfixOf` v || "WSL" `isInfixOf` v
|
||||
then initWslNotify
|
||||
else pure $ notify linuxScript
|
||||
_ -> pure . const $ pure ()
|
||||
|
||||
hideException :: (a -> IO ()) -> (a -> IO ())
|
||||
hideException f a = f a `catch` \(_ :: SomeException) -> pure ()
|
||||
|
||||
notify :: (Notification -> Text) -> Notification -> IO ()
|
||||
notify script notification =
|
||||
void $ readCreateProcess (shell . T.unpack $ script notification) ""
|
||||
|
||||
linuxScript :: Notification -> Text
|
||||
linuxScript Notification {title, text} = "notify-send '" <> linuxEscape title <> "' '" <> linuxEscape text <> "'"
|
||||
|
||||
linuxEscape :: Text -> Text
|
||||
linuxEscape = replaceAll $ fromList [('\'', "'\\''")]
|
||||
|
||||
macScript :: Notification -> Text
|
||||
macScript Notification {title, text} = "osascript -e 'display notification \"" <> macEscape text <> "\" with title \"" <> macEscape title <> "\"'"
|
||||
|
||||
macEscape :: Text -> Text
|
||||
macEscape = replaceAll $ fromList [('"', "\\\""), ('\'', "")]
|
||||
|
||||
initWslNotify :: IO (Notification -> IO ())
|
||||
initWslNotify = notify . wslScript <$> savePowershellScript
|
||||
|
||||
wslScript :: FilePath -> Notification -> Text
|
||||
wslScript path Notification {title, text} = "powershell.exe \"" <> T.pack path <> " \\\"" <> wslEscape title <> "\\\" \\\"" <> wslEscape text <> "\\\"\""
|
||||
|
||||
wslEscape :: Text -> Text
|
||||
wslEscape = replaceAll $ fromList [('`', "\\`\\`"), ('\\', "\\\\"), ('"', "\\`\\\"")]
|
||||
|
||||
initWinNotify :: IO (Notification -> IO ())
|
||||
initWinNotify = notify . winScript <$> savePowershellScript
|
||||
|
||||
winScript :: FilePath -> Notification -> Text
|
||||
winScript path Notification {title, text} = "powershell.exe \"" <> T.pack path <> " '" <> winRemoveQuotes title <> "' '" <> winRemoveQuotes text <> "'\""
|
||||
|
||||
winRemoveQuotes :: Text -> Text
|
||||
winRemoveQuotes = replaceAll $ fromList [('`', ""), ('\'', ""), ('"', "")]
|
||||
|
||||
replaceAll :: Map Char Text -> Text -> Text
|
||||
replaceAll rules = T.concatMap $ \c -> T.singleton c `fromMaybe` M.lookup c rules
|
||||
|
||||
savePowershellScript :: IO FilePath
|
||||
savePowershellScript = do
|
||||
appDir <- getAppUserDataDirectory "simplex"
|
||||
createDirectoryIfMissing False appDir
|
||||
let psScript = combine appDir "win-toast-notify.ps1"
|
||||
writeFile
|
||||
psScript
|
||||
"[Windows.UI.Notifications.ToastNotificationManager, Windows.UI.Notifications, ContentType = WindowsRuntime] > $null\n\
|
||||
\$Template = [Windows.UI.Notifications.ToastNotificationManager]::GetTemplateContent([Windows.UI.Notifications.ToastTemplateType]::ToastText02)\n\
|
||||
\$RawXml = [xml] $Template.GetXml()\n\
|
||||
\($RawXml.toast.visual.binding.text|where {$_.id -eq \"1\"}).AppendChild($RawXml.CreateTextNode($args[0])) > $null\n\
|
||||
\($RawXml.toast.visual.binding.text|where {$_.id -eq \"2\"}).AppendChild($RawXml.CreateTextNode($args[1])) > $null\n\
|
||||
\$SerializedXml = New-Object Windows.Data.Xml.Dom.XmlDocument\n\
|
||||
\$SerializedXml.LoadXml($RawXml.OuterXml)\n\
|
||||
\$Toast = [Windows.UI.Notifications.ToastNotification]::new($SerializedXml)\n\
|
||||
\$Toast.Tag = \"simplex-chat\"\n\
|
||||
\$Toast.Group = \"simplex-chat\"\n\
|
||||
\$Toast.ExpirationTime = [DateTimeOffset]::Now.AddMinutes(1)\n\
|
||||
\$Notifier = [Windows.UI.Notifications.ToastNotificationManager]::CreateToastNotifier(\"PowerShell\")\n\
|
||||
\$Notifier.Show($Toast);\n"
|
||||
return psScript
|
||||
@@ -0,0 +1,62 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.Options (getChatOpts, ChatOpts (..)) where
|
||||
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Options.Applicative
|
||||
import Simplex.Messaging.Agent.Protocol (SMPServer (..), smpServerP)
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import System.FilePath (combine)
|
||||
|
||||
data ChatOpts = ChatOpts
|
||||
{ dbFile :: String,
|
||||
smpServers :: NonEmpty SMPServer
|
||||
}
|
||||
|
||||
chatOpts :: FilePath -> Parser ChatOpts
|
||||
chatOpts appDir =
|
||||
ChatOpts
|
||||
<$> strOption
|
||||
( long "database"
|
||||
<> short 'd'
|
||||
<> metavar "DB_FILE"
|
||||
<> help ("sqlite database file path (" <> defaultDbFilePath <> ")")
|
||||
<> value defaultDbFilePath
|
||||
)
|
||||
<*> option
|
||||
parseSMPServer
|
||||
( long "server"
|
||||
<> short 's'
|
||||
<> metavar "SERVER"
|
||||
<> help
|
||||
( "SMP server(s) to use"
|
||||
<> "\n(smp2.simplex.im,smp3.simplex.im)"
|
||||
)
|
||||
<> value
|
||||
( L.fromList
|
||||
[ "smp2.simplex.im#z5W2QLQ1Br3Yd6CoWg7bIq1bHdwK7Y8bEiEXBs/WfAg=", -- London, UK
|
||||
"smp3.simplex.im#nxc7HnrnM8dOKgkMp008ub/9o9LXJlxlMrMpR+mfMQw=" -- Fremont, CA
|
||||
]
|
||||
)
|
||||
)
|
||||
where
|
||||
defaultDbFilePath = combine appDir "simplex"
|
||||
|
||||
parseSMPServer :: ReadM (NonEmpty SMPServer)
|
||||
parseSMPServer = eitherReader $ parseAll servers . B.pack
|
||||
where
|
||||
servers = L.fromList <$> smpServerP `A.sepBy1` A.char ','
|
||||
|
||||
getChatOpts :: FilePath -> IO ChatOpts
|
||||
getChatOpts appDir = execParser opts
|
||||
where
|
||||
opts =
|
||||
info
|
||||
(chatOpts appDir <**> helper)
|
||||
( fullDesc
|
||||
<> header "Chat prototype using Simplex Messaging Protocol (SMP)"
|
||||
<> progDesc "Start chat with DB_FILE file and use SERVER as SMP server"
|
||||
)
|
||||
@@ -0,0 +1,383 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Chat.Protocol where
|
||||
|
||||
import Control.Applicative (optional)
|
||||
import Control.Monad ((<=<))
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Util (safeDecodeUtf8)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Util (bshow)
|
||||
|
||||
data ChatDirection (p :: AParty) where
|
||||
ReceivedDirectMessage :: Connection -> Maybe Contact -> ChatDirection 'Agent
|
||||
SentDirectMessage :: Contact -> ChatDirection 'Client
|
||||
ReceivedGroupMessage :: Connection -> GroupName -> GroupMember -> ChatDirection 'Agent
|
||||
SentGroupMessage :: GroupName -> ChatDirection 'Client
|
||||
SndFileConnection :: Connection -> SndFileTransfer -> ChatDirection 'Agent
|
||||
RcvFileConnection :: Connection -> RcvFileTransfer -> ChatDirection 'Agent
|
||||
|
||||
deriving instance Eq (ChatDirection p)
|
||||
|
||||
deriving instance Show (ChatDirection p)
|
||||
|
||||
fromConnection :: ChatDirection 'Agent -> Connection
|
||||
fromConnection = \case
|
||||
ReceivedDirectMessage conn _ -> conn
|
||||
ReceivedGroupMessage conn _ _ -> conn
|
||||
SndFileConnection conn _ -> conn
|
||||
RcvFileConnection conn _ -> conn
|
||||
|
||||
data ChatMsgEvent
|
||||
= XMsgNew MsgContent
|
||||
| XFile FileInvitation
|
||||
| XFileAcpt String
|
||||
| XInfo Profile
|
||||
| XGrpInv GroupInvitation
|
||||
| XGrpAcpt MemberId
|
||||
| XGrpMemNew MemberInfo
|
||||
| XGrpMemIntro MemberInfo
|
||||
| XGrpMemInv MemberId IntroInvitation
|
||||
| XGrpMemFwd MemberInfo IntroInvitation
|
||||
| XGrpMemInfo MemberId Profile
|
||||
| XGrpMemCon MemberId
|
||||
| XGrpMemConAll MemberId
|
||||
| XGrpMemDel MemberId
|
||||
| XGrpLeave
|
||||
| XGrpDel
|
||||
| XInfoProbe ByteString
|
||||
| XInfoProbeCheck ByteString
|
||||
| XInfoProbeOk ByteString
|
||||
| XOk
|
||||
deriving (Eq, Show)
|
||||
|
||||
data MessageType = MTText | MTImage deriving (Eq, Show)
|
||||
|
||||
data MsgContent = MsgContent
|
||||
{ messageType :: MessageType,
|
||||
files :: [(ContentType, Int)],
|
||||
content :: [MsgContentBody]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
toMsgType :: ByteString -> Either String MessageType
|
||||
toMsgType = \case
|
||||
"c.text" -> Right MTText
|
||||
"c.image" -> Right MTImage
|
||||
t -> Left $ "invalid message type " <> B.unpack t
|
||||
|
||||
rawMsgType :: MessageType -> ByteString
|
||||
rawMsgType = \case
|
||||
MTText -> "c.text"
|
||||
MTImage -> "c.image"
|
||||
|
||||
data ChatMessage = ChatMessage
|
||||
{ chatMsgId :: Maybe Int64,
|
||||
chatMsgEvent :: ChatMsgEvent,
|
||||
chatDAG :: Maybe ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
toChatMessage :: RawChatMessage -> Either String ChatMessage
|
||||
toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} = do
|
||||
(chatDAG, body) <- getDAG <$> mapM toMsgBodyContent chatMsgBody
|
||||
let chatMsg msg = pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
|
||||
case (chatMsgEvent, chatMsgParams) of
|
||||
("x.msg.new", mt : rawFiles) -> do
|
||||
t <- toMsgType mt
|
||||
files <- mapM (toContentInfo <=< parseAll contentInfoP) rawFiles
|
||||
chatMsg . XMsgNew $ MsgContent {messageType = t, files, content = body}
|
||||
("x.file", [name, size, qInfo]) -> do
|
||||
let fileName = T.unpack $ safeDecodeUtf8 name
|
||||
fileSize <- parseAll A.decimal size
|
||||
fileQInfo <- parseAll smpQueueInfoP qInfo
|
||||
chatMsg . XFile $ FileInvitation {fileName, fileSize, fileQInfo}
|
||||
("x.file.acpt", [name]) ->
|
||||
chatMsg . XFileAcpt . T.unpack $ safeDecodeUtf8 name
|
||||
("x.info", []) -> do
|
||||
profile <- getJSON body
|
||||
chatMsg $ XInfo profile
|
||||
("x.grp.inv", [fromMemId, fromRole, memId, role, qInfo]) -> do
|
||||
fromMem <- (,) <$> B64.decode fromMemId <*> toMemberRole fromRole
|
||||
invitedMem <- (,) <$> B64.decode memId <*> toMemberRole role
|
||||
groupQInfo <- parseAll smpQueueInfoP qInfo
|
||||
profile <- getJSON body
|
||||
chatMsg . XGrpInv $ GroupInvitation fromMem invitedMem groupQInfo profile
|
||||
("x.grp.acpt", [memId]) ->
|
||||
chatMsg . XGrpAcpt =<< B64.decode memId
|
||||
("x.grp.mem.new", [memId, role]) -> do
|
||||
chatMsg . XGrpMemNew =<< toMemberInfo memId role body
|
||||
("x.grp.mem.intro", [memId, role]) ->
|
||||
chatMsg . XGrpMemIntro =<< toMemberInfo memId role body
|
||||
("x.grp.mem.inv", [memId, groupQInfo, directQInfo]) ->
|
||||
chatMsg =<< (XGrpMemInv <$> B64.decode memId <*> toIntroInv groupQInfo directQInfo)
|
||||
("x.grp.mem.fwd", [memId, role, groupQInfo, directQInfo]) -> do
|
||||
chatMsg =<< (XGrpMemFwd <$> toMemberInfo memId role body <*> toIntroInv groupQInfo directQInfo)
|
||||
("x.grp.mem.info", [memId]) ->
|
||||
chatMsg =<< (XGrpMemInfo <$> B64.decode memId <*> getJSON body)
|
||||
("x.grp.mem.con", [memId]) ->
|
||||
chatMsg . XGrpMemCon =<< B64.decode memId
|
||||
("x.grp.mem.con.all", [memId]) ->
|
||||
chatMsg . XGrpMemConAll =<< B64.decode memId
|
||||
("x.grp.mem.del", [memId]) ->
|
||||
chatMsg . XGrpMemDel =<< B64.decode memId
|
||||
("x.grp.leave", []) ->
|
||||
chatMsg XGrpLeave
|
||||
("x.grp.del", []) ->
|
||||
chatMsg XGrpDel
|
||||
("x.info.probe", [probe]) -> do
|
||||
chatMsg . XInfoProbe =<< B64.decode probe
|
||||
("x.info.probe.check", [probeHash]) -> do
|
||||
chatMsg =<< (XInfoProbeCheck <$> B64.decode probeHash)
|
||||
("x.info.probe.ok", [probe]) -> do
|
||||
chatMsg =<< (XInfoProbeOk <$> B64.decode probe)
|
||||
("x.ok", []) ->
|
||||
chatMsg XOk
|
||||
_ -> Left $ "bad syntax or unsupported event " <> B.unpack chatMsgEvent
|
||||
where
|
||||
getDAG :: [MsgContentBody] -> (Maybe ByteString, [MsgContentBody])
|
||||
getDAG body = case break (isContentType SimplexDAG) body of
|
||||
(b, MsgContentBody SimplexDAG dag : a) -> (Just dag, b <> a)
|
||||
_ -> (Nothing, body)
|
||||
toMemberInfo :: ByteString -> ByteString -> [MsgContentBody] -> Either String MemberInfo
|
||||
toMemberInfo memId role body = MemberInfo <$> B64.decode memId <*> toMemberRole role <*> getJSON body
|
||||
toIntroInv :: ByteString -> ByteString -> Either String IntroInvitation
|
||||
toIntroInv groupQInfo directQInfo = IntroInvitation <$> parseAll smpQueueInfoP groupQInfo <*> parseAll smpQueueInfoP directQInfo
|
||||
toContentInfo :: (RawContentType, Int) -> Either String (ContentType, Int)
|
||||
toContentInfo (rawType, size) = (,size) <$> toContentType rawType
|
||||
getJSON :: FromJSON a => [MsgContentBody] -> Either String a
|
||||
getJSON = J.eitherDecodeStrict' <=< getSimplexContentType XCJson
|
||||
|
||||
isContentType :: ContentType -> MsgContentBody -> Bool
|
||||
isContentType t MsgContentBody {contentType = t'} = t == t'
|
||||
|
||||
isSimplexContentType :: XContentType -> MsgContentBody -> Bool
|
||||
isSimplexContentType = isContentType . SimplexContentType
|
||||
|
||||
getContentType :: ContentType -> [MsgContentBody] -> Either String ByteString
|
||||
getContentType t body = case find (isContentType t) body of
|
||||
Just MsgContentBody {contentData} -> Right contentData
|
||||
Nothing -> Left "no required content type"
|
||||
|
||||
getSimplexContentType :: XContentType -> [MsgContentBody] -> Either String ByteString
|
||||
getSimplexContentType = getContentType . SimplexContentType
|
||||
|
||||
rawChatMessage :: ChatMessage -> RawChatMessage
|
||||
rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
|
||||
case chatMsgEvent of
|
||||
XMsgNew MsgContent {messageType = t, files, content} ->
|
||||
let rawFiles = map (serializeContentInfo . rawContentInfo) files
|
||||
in rawMsg "x.msg.new" (rawMsgType t : rawFiles) content
|
||||
XFile FileInvitation {fileName, fileSize, fileQInfo} ->
|
||||
rawMsg "x.file" [encodeUtf8 $ T.pack fileName, bshow fileSize, serializeSmpQueueInfo fileQInfo] []
|
||||
XFileAcpt fileName ->
|
||||
rawMsg "x.file.acpt" [encodeUtf8 $ T.pack fileName] []
|
||||
XInfo profile ->
|
||||
rawMsg "x.info" [] [jsonBody profile]
|
||||
XGrpInv (GroupInvitation (fromMemId, fromRole) (memId, role) qInfo groupProfile) ->
|
||||
let params =
|
||||
[ B64.encode fromMemId,
|
||||
serializeMemberRole fromRole,
|
||||
B64.encode memId,
|
||||
serializeMemberRole role,
|
||||
serializeSmpQueueInfo qInfo
|
||||
]
|
||||
in rawMsg "x.grp.inv" params [jsonBody groupProfile]
|
||||
XGrpAcpt memId ->
|
||||
rawMsg "x.grp.acpt" [B64.encode memId] []
|
||||
XGrpMemNew (MemberInfo memId role profile) ->
|
||||
let params = [B64.encode memId, serializeMemberRole role]
|
||||
in rawMsg "x.grp.mem.new" params [jsonBody profile]
|
||||
XGrpMemIntro (MemberInfo memId role profile) ->
|
||||
rawMsg "x.grp.mem.intro" [B64.encode memId, serializeMemberRole role] [jsonBody profile]
|
||||
XGrpMemInv memId IntroInvitation {groupQInfo, directQInfo} ->
|
||||
let params = [B64.encode memId, serializeSmpQueueInfo groupQInfo, serializeSmpQueueInfo directQInfo]
|
||||
in rawMsg "x.grp.mem.inv" params []
|
||||
XGrpMemFwd (MemberInfo memId role profile) IntroInvitation {groupQInfo, directQInfo} ->
|
||||
let params =
|
||||
[ B64.encode memId,
|
||||
serializeMemberRole role,
|
||||
serializeSmpQueueInfo groupQInfo,
|
||||
serializeSmpQueueInfo directQInfo
|
||||
]
|
||||
in rawMsg "x.grp.mem.fwd" params [jsonBody profile]
|
||||
XGrpMemInfo memId profile ->
|
||||
rawMsg "x.grp.mem.info" [B64.encode memId] [jsonBody profile]
|
||||
XGrpMemCon memId ->
|
||||
rawMsg "x.grp.mem.con" [B64.encode memId] []
|
||||
XGrpMemConAll memId ->
|
||||
rawMsg "x.grp.mem.con.all" [B64.encode memId] []
|
||||
XGrpMemDel memId ->
|
||||
rawMsg "x.grp.mem.del" [B64.encode memId] []
|
||||
XGrpLeave ->
|
||||
rawMsg "x.grp.leave" [] []
|
||||
XGrpDel ->
|
||||
rawMsg "x.grp.del" [] []
|
||||
XInfoProbe probe ->
|
||||
rawMsg "x.info.probe" [B64.encode probe] []
|
||||
XInfoProbeCheck probeHash ->
|
||||
rawMsg "x.info.probe.check" [B64.encode probeHash] []
|
||||
XInfoProbeOk probe ->
|
||||
rawMsg "x.info.probe.ok" [B64.encode probe] []
|
||||
XOk ->
|
||||
rawMsg "x.ok" [] []
|
||||
where
|
||||
rawMsg :: ByteString -> [ByteString] -> [MsgContentBody] -> RawChatMessage
|
||||
rawMsg event chatMsgParams body =
|
||||
RawChatMessage {chatMsgId, chatMsgEvent = event, chatMsgParams, chatMsgBody = rawWithDAG body}
|
||||
rawContentInfo :: (ContentType, Int) -> (RawContentType, Int)
|
||||
rawContentInfo (t, size) = (rawContentType t, size)
|
||||
jsonBody :: ToJSON a => a -> MsgContentBody
|
||||
jsonBody x =
|
||||
let json = LB.toStrict $ J.encode x
|
||||
in MsgContentBody {contentType = SimplexContentType XCJson, contentData = json}
|
||||
rawWithDAG :: [MsgContentBody] -> [RawMsgBodyContent]
|
||||
rawWithDAG body = map rawMsgBodyContent $ case chatDAG of
|
||||
Nothing -> body
|
||||
Just dag -> MsgContentBody {contentType = SimplexDAG, contentData = dag} : body
|
||||
|
||||
toMsgBodyContent :: RawMsgBodyContent -> Either String MsgContentBody
|
||||
toMsgBodyContent RawMsgBodyContent {contentType, contentData} = do
|
||||
cType <- toContentType contentType
|
||||
pure MsgContentBody {contentType = cType, contentData}
|
||||
|
||||
rawMsgBodyContent :: MsgContentBody -> RawMsgBodyContent
|
||||
rawMsgBodyContent MsgContentBody {contentType = t, contentData} =
|
||||
RawMsgBodyContent {contentType = rawContentType t, contentData}
|
||||
|
||||
data MsgContentBody = MsgContentBody
|
||||
{ contentType :: ContentType,
|
||||
contentData :: ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ContentType
|
||||
= SimplexContentType XContentType
|
||||
| MimeContentType MContentType
|
||||
| SimplexDAG
|
||||
deriving (Eq, Show)
|
||||
|
||||
data XContentType = XCText | XCImage | XCJson deriving (Eq, Show)
|
||||
|
||||
data MContentType = MCImageJPG | MCImagePNG deriving (Eq, Show)
|
||||
|
||||
toContentType :: RawContentType -> Either String ContentType
|
||||
toContentType (RawContentType ns cType) = case ns of
|
||||
"x" -> case cType of
|
||||
"text" -> Right $ SimplexContentType XCText
|
||||
"image" -> Right $ SimplexContentType XCImage
|
||||
"json" -> Right $ SimplexContentType XCJson
|
||||
"dag" -> Right SimplexDAG
|
||||
_ -> err
|
||||
"m" -> case cType of
|
||||
"image/jpg" -> Right $ MimeContentType MCImageJPG
|
||||
"image/png" -> Right $ MimeContentType MCImagePNG
|
||||
_ -> err
|
||||
_ -> err
|
||||
where
|
||||
err = Left . B.unpack $ "invalid content type " <> ns <> "." <> cType
|
||||
|
||||
rawContentType :: ContentType -> RawContentType
|
||||
rawContentType t = case t of
|
||||
SimplexContentType t' -> RawContentType "x" $ case t' of
|
||||
XCText -> "text"
|
||||
XCImage -> "image"
|
||||
XCJson -> "json"
|
||||
MimeContentType t' -> RawContentType "m" $ case t' of
|
||||
MCImageJPG -> "image/jpg"
|
||||
MCImagePNG -> "image/png"
|
||||
SimplexDAG -> RawContentType "x" "dag"
|
||||
|
||||
newtype ContentMsg = NewContentMsg ContentData
|
||||
|
||||
newtype ContentData = ContentText Text
|
||||
|
||||
data RawChatMessage = RawChatMessage
|
||||
{ chatMsgId :: Maybe Int64,
|
||||
chatMsgEvent :: ByteString,
|
||||
chatMsgParams :: [ByteString],
|
||||
chatMsgBody :: [RawMsgBodyContent]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data RawMsgBodyContent = RawMsgBodyContent
|
||||
{ contentType :: RawContentType,
|
||||
contentData :: ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data RawContentType = RawContentType NameSpace ByteString
|
||||
deriving (Eq, Show)
|
||||
|
||||
type NameSpace = ByteString
|
||||
|
||||
newtype MsgData = MsgData ByteString
|
||||
deriving (Eq, Show)
|
||||
|
||||
class DataLength a where
|
||||
dataLength :: a -> Int
|
||||
|
||||
rawChatMessageP :: Parser RawChatMessage
|
||||
rawChatMessageP = do
|
||||
chatMsgId <- optional A.decimal <* A.space
|
||||
chatMsgEvent <- B.intercalate "." <$> identifierP `A.sepBy1'` A.char '.' <* A.space
|
||||
chatMsgParams <- A.takeWhile1 (not . A.inClass ", ") `A.sepBy'` A.char ',' <* A.space
|
||||
chatMsgBody <- msgBodyContent =<< contentInfoP `A.sepBy'` A.char ',' <* A.space
|
||||
pure RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody}
|
||||
where
|
||||
msgBodyContent :: [(RawContentType, Int)] -> Parser [RawMsgBodyContent]
|
||||
msgBodyContent [] = pure []
|
||||
msgBodyContent ((contentType, size) : ps) = do
|
||||
contentData <- A.take size <* A.space
|
||||
((RawMsgBodyContent {contentType, contentData}) :) <$> msgBodyContent ps
|
||||
|
||||
contentInfoP :: Parser (RawContentType, Int)
|
||||
contentInfoP = do
|
||||
contentType <- RawContentType <$> identifierP <* A.char '.' <*> A.takeTill (A.inClass ":, ")
|
||||
size <- A.char ':' *> A.decimal
|
||||
pure (contentType, size)
|
||||
|
||||
identifierP :: Parser ByteString
|
||||
identifierP = B.cons <$> A.letter_ascii <*> A.takeWhile (\c -> A.isAlpha_ascii c || A.isDigit c)
|
||||
|
||||
serializeRawChatMessage :: RawChatMessage -> ByteString
|
||||
serializeRawChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} =
|
||||
B.unwords
|
||||
[ maybe "" bshow chatMsgId,
|
||||
chatMsgEvent,
|
||||
B.intercalate "," chatMsgParams,
|
||||
B.unwords $ map serializeBodyContentInfo chatMsgBody,
|
||||
B.unwords $ map msgContentData chatMsgBody
|
||||
]
|
||||
|
||||
serializeBodyContentInfo :: RawMsgBodyContent -> ByteString
|
||||
serializeBodyContentInfo RawMsgBodyContent {contentType = t, contentData} =
|
||||
serializeContentInfo (t, B.length contentData)
|
||||
|
||||
serializeContentInfo :: (RawContentType, Int) -> ByteString
|
||||
serializeContentInfo (RawContentType ns cType, size) = ns <> "." <> cType <> ":" <> bshow size
|
||||
|
||||
msgContentData :: RawMsgBodyContent -> ByteString
|
||||
msgContentData RawMsgBodyContent {contentData} = contentData <> " "
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,74 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Simplex.Chat.Styled
|
||||
( StyledString (..),
|
||||
StyledFormat (..),
|
||||
styleMarkdown,
|
||||
styleMarkdownText,
|
||||
sLength,
|
||||
sShow,
|
||||
)
|
||||
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
|
||||
|
||||
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
|
||||
plain :: a -> StyledString
|
||||
|
||||
instance StyledFormat String where
|
||||
styled = Styled . sgr
|
||||
plain = Styled []
|
||||
|
||||
instance StyledFormat ByteString where
|
||||
styled f = styled f . B.unpack
|
||||
plain = Styled [] . B.unpack
|
||||
|
||||
instance StyledFormat Text where
|
||||
styled f = styled f . T.unpack
|
||||
plain = Styled [] . T.unpack
|
||||
|
||||
sShow :: Show a => a -> StyledString
|
||||
sShow = plain . show
|
||||
|
||||
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
|
||||
@@ -0,0 +1,176 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Simplex.Chat.Terminal where
|
||||
|
||||
import Control.Monad.Catch (MonadMask)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Types
|
||||
import System.Console.ANSI.Types
|
||||
import System.Terminal
|
||||
import System.Terminal.Internal (LocalTerminal, Terminal, VirtualTerminal)
|
||||
import UnliftIO.STM
|
||||
|
||||
data ActiveTo = ActiveNone | ActiveC ContactName | ActiveG GroupName
|
||||
deriving (Eq)
|
||||
|
||||
data ChatTerminal = ChatTerminal
|
||||
{ activeTo :: TVar ActiveTo,
|
||||
termDevice :: TerminalDevice,
|
||||
termState :: TVar TerminalState,
|
||||
termSize :: Size,
|
||||
nextMessageRow :: TVar Int,
|
||||
termLock :: TMVar ()
|
||||
}
|
||||
|
||||
data TerminalState = TerminalState
|
||||
{ inputPrompt :: String,
|
||||
inputString :: String,
|
||||
inputPosition :: Int,
|
||||
previousInput :: String
|
||||
}
|
||||
|
||||
class Terminal t => WithTerminal t where
|
||||
withTerm :: (MonadIO m, MonadMask m) => t -> (t -> m a) -> m a
|
||||
|
||||
data TerminalDevice = forall t. WithTerminal t => TerminalDevice t
|
||||
|
||||
instance WithTerminal LocalTerminal where
|
||||
withTerm _ = withTerminal
|
||||
|
||||
instance WithTerminal VirtualTerminal where
|
||||
withTerm t = ($ t)
|
||||
|
||||
withChatTerm :: (MonadIO m, MonadMask m) => ChatTerminal -> (forall t. WithTerminal t => TerminalT t m a) -> m a
|
||||
withChatTerm ChatTerminal {termDevice = TerminalDevice t} action = withTerm t $ runTerminalT action
|
||||
|
||||
newChatTerminal :: WithTerminal t => t -> IO ChatTerminal
|
||||
newChatTerminal t = do
|
||||
activeTo <- newTVarIO ActiveNone
|
||||
termSize <- withTerm t . 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, termDevice = TerminalDevice t, 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 =
|
||||
withChatTerm ct $
|
||||
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
|
||||
@@ -0,0 +1,497 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.Types where
|
||||
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import qualified Data.Aeson as J
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Typeable (Typeable)
|
||||
import Database.SQLite.Simple (ResultError (..), SQLData (..))
|
||||
import Database.SQLite.Simple.FromField (FieldParser, FromField (..), returnError)
|
||||
import Database.SQLite.Simple.Internal (Field (..))
|
||||
import Database.SQLite.Simple.Ok (Ok (Ok))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import GHC.Generics
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId, SMPQueueInfo)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
|
||||
|
||||
class IsContact a where
|
||||
contactId' :: a -> Int64
|
||||
profile' :: a -> Profile
|
||||
localDisplayName' :: a -> ContactName
|
||||
|
||||
instance IsContact User where
|
||||
contactId' = userContactId
|
||||
profile' = profile
|
||||
localDisplayName' = localDisplayName
|
||||
|
||||
instance IsContact Contact where
|
||||
contactId' = contactId
|
||||
profile' = profile
|
||||
localDisplayName' = localDisplayName
|
||||
|
||||
data User = User
|
||||
{ userId :: UserId,
|
||||
userContactId :: Int64,
|
||||
localDisplayName :: ContactName,
|
||||
profile :: Profile,
|
||||
activeUser :: Bool
|
||||
}
|
||||
|
||||
type UserId = Int64
|
||||
|
||||
data Contact = Contact
|
||||
{ contactId :: Int64,
|
||||
localDisplayName :: ContactName,
|
||||
profile :: Profile,
|
||||
activeConn :: Connection,
|
||||
viaGroup :: Maybe Int64
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
contactConnId :: Contact -> ConnId
|
||||
contactConnId Contact {activeConn = Connection {agentConnId}} = agentConnId
|
||||
|
||||
type ContactName = Text
|
||||
|
||||
type GroupName = Text
|
||||
|
||||
data Group = Group
|
||||
{ groupId :: Int64,
|
||||
localDisplayName :: GroupName,
|
||||
groupProfile :: GroupProfile,
|
||||
members :: [GroupMember],
|
||||
membership :: GroupMember
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Profile = Profile
|
||||
{ displayName :: ContactName,
|
||||
fullName :: Text
|
||||
}
|
||||
deriving (Generic, Eq, Show)
|
||||
|
||||
instance ToJSON Profile where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
instance FromJSON Profile
|
||||
|
||||
data GroupProfile = GroupProfile
|
||||
{ displayName :: GroupName,
|
||||
fullName :: Text
|
||||
}
|
||||
deriving (Generic, Eq, Show)
|
||||
|
||||
instance ToJSON GroupProfile where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
instance FromJSON GroupProfile
|
||||
|
||||
data GroupInvitation = GroupInvitation
|
||||
{ fromMember :: (MemberId, GroupMemberRole),
|
||||
invitedMember :: (MemberId, GroupMemberRole),
|
||||
queueInfo :: SMPQueueInfo,
|
||||
groupProfile :: GroupProfile
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data IntroInvitation = IntroInvitation
|
||||
{ groupQInfo :: SMPQueueInfo,
|
||||
directQInfo :: SMPQueueInfo
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data MemberInfo = MemberInfo MemberId GroupMemberRole Profile
|
||||
deriving (Eq, Show)
|
||||
|
||||
memberInfo :: GroupMember -> MemberInfo
|
||||
memberInfo m = MemberInfo (memberId m) (memberRole m) (memberProfile m)
|
||||
|
||||
data ReceivedGroupInvitation = ReceivedGroupInvitation
|
||||
{ fromMember :: GroupMember,
|
||||
userMember :: GroupMember,
|
||||
queueInfo :: SMPQueueInfo,
|
||||
groupProfile :: GroupProfile
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data GroupMember = GroupMember
|
||||
{ groupMemberId :: Int64,
|
||||
groupId :: Int64,
|
||||
memberId :: MemberId,
|
||||
memberRole :: GroupMemberRole,
|
||||
memberCategory :: GroupMemberCategory,
|
||||
memberStatus :: GroupMemberStatus,
|
||||
invitedBy :: InvitedBy,
|
||||
localDisplayName :: ContactName,
|
||||
memberProfile :: Profile,
|
||||
memberContactId :: Maybe Int64,
|
||||
activeConn :: Maybe Connection
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
memberConnId :: GroupMember -> Maybe ConnId
|
||||
memberConnId GroupMember {activeConn} = case activeConn of
|
||||
Just Connection {agentConnId} -> Just agentConnId
|
||||
Nothing -> Nothing
|
||||
|
||||
data NewGroupMember = NewGroupMember
|
||||
{ memInfo :: MemberInfo,
|
||||
memCategory :: GroupMemberCategory,
|
||||
memStatus :: GroupMemberStatus,
|
||||
memInvitedBy :: InvitedBy,
|
||||
localDisplayName :: ContactName,
|
||||
memProfileId :: Int64,
|
||||
memContactId :: Maybe Int64
|
||||
}
|
||||
|
||||
type MemberId = ByteString
|
||||
|
||||
data InvitedBy = IBContact Int64 | IBUser | IBUnknown
|
||||
deriving (Eq, Show)
|
||||
|
||||
toInvitedBy :: Int64 -> Maybe Int64 -> InvitedBy
|
||||
toInvitedBy userCtId (Just ctId)
|
||||
| userCtId == ctId = IBUser
|
||||
| otherwise = IBContact ctId
|
||||
toInvitedBy _ Nothing = IBUnknown
|
||||
|
||||
fromInvitedBy :: Int64 -> InvitedBy -> Maybe Int64
|
||||
fromInvitedBy userCtId = \case
|
||||
IBUnknown -> Nothing
|
||||
IBContact ctId -> Just ctId
|
||||
IBUser -> Just userCtId
|
||||
|
||||
data GroupMemberRole = GRMember | GRAdmin | GROwner
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
instance FromField GroupMemberRole where fromField = fromBlobField_ toMemberRole
|
||||
|
||||
instance ToField GroupMemberRole where toField = toField . serializeMemberRole
|
||||
|
||||
toMemberRole :: ByteString -> Either String GroupMemberRole
|
||||
toMemberRole = \case
|
||||
"owner" -> Right GROwner
|
||||
"admin" -> Right GRAdmin
|
||||
"member" -> Right GRMember
|
||||
r -> Left $ "invalid group member role " <> B.unpack r
|
||||
|
||||
serializeMemberRole :: GroupMemberRole -> ByteString
|
||||
serializeMemberRole = \case
|
||||
GROwner -> "owner"
|
||||
GRAdmin -> "admin"
|
||||
GRMember -> "member"
|
||||
|
||||
fromBlobField_ :: Typeable k => (ByteString -> Either String k) -> FieldParser k
|
||||
fromBlobField_ p = \case
|
||||
f@(Field (SQLBlob b) _) ->
|
||||
case p b of
|
||||
Right k -> Ok k
|
||||
Left e -> returnError ConversionFailed f ("could not parse field: " ++ e)
|
||||
f -> returnError ConversionFailed f "expecting SQLBlob column type"
|
||||
|
||||
data GroupMemberCategory
|
||||
= GCUserMember
|
||||
| GCInviteeMember -- member invited by the user
|
||||
| GCHostMember -- member who invited the user
|
||||
| GCPreMember -- member who joined before the user and was introduced to the user (user receives x.grp.mem.intro about such members)
|
||||
| GCPostMember -- member who joined after the user to whom the user was introduced (user receives x.grp.mem.new announcing these members and then x.grp.mem.fwd with invitation from these members)
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromField GroupMemberCategory where fromField = fromTextField_ memberCategoryT
|
||||
|
||||
instance ToField GroupMemberCategory where toField = toField . serializeMemberCategory
|
||||
|
||||
memberCategoryT :: Text -> Maybe GroupMemberCategory
|
||||
memberCategoryT = \case
|
||||
"user" -> Just GCUserMember
|
||||
"invitee" -> Just GCInviteeMember
|
||||
"host" -> Just GCHostMember
|
||||
"pre" -> Just GCPreMember
|
||||
"post" -> Just GCPostMember
|
||||
_ -> Nothing
|
||||
|
||||
serializeMemberCategory :: GroupMemberCategory -> Text
|
||||
serializeMemberCategory = \case
|
||||
GCUserMember -> "user"
|
||||
GCInviteeMember -> "invitee"
|
||||
GCHostMember -> "host"
|
||||
GCPreMember -> "pre"
|
||||
GCPostMember -> "post"
|
||||
|
||||
data GroupMemberStatus
|
||||
= GSMemRemoved -- member who was removed from the group
|
||||
| GSMemLeft -- member who left the group
|
||||
| GSMemGroupDeleted -- user member of the deleted group
|
||||
| GSMemInvited -- member is sent to or received invitation to join the group
|
||||
| GSMemIntroduced -- user received x.grp.mem.intro for this member (only with GCPreMember)
|
||||
| GSMemIntroInvited -- member is sent to or received from intro invitation
|
||||
| GSMemAccepted -- member accepted invitation (only User and Invitee)
|
||||
| GSMemAnnounced -- host announced (x.grp.mem.new) a member (Invitee and PostMember) to the group - at this point this member can send messages and invite other members (if they have sufficient permissions)
|
||||
| GSMemConnected -- member created the group connection with the inviting member
|
||||
| GSMemComplete -- host confirmed (x.grp.mem.all) that a member (User, Invitee and PostMember) created group connections with all previous members
|
||||
| GSMemCreator -- user member that created the group (only GCUserMember)
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
instance FromField GroupMemberStatus where fromField = fromTextField_ memberStatusT
|
||||
|
||||
instance ToField GroupMemberStatus where toField = toField . serializeMemberStatus
|
||||
|
||||
memberActive :: GroupMember -> Bool
|
||||
memberActive m = case memberStatus m of
|
||||
GSMemRemoved -> False
|
||||
GSMemLeft -> False
|
||||
GSMemGroupDeleted -> False
|
||||
GSMemInvited -> False
|
||||
GSMemIntroduced -> False
|
||||
GSMemIntroInvited -> False
|
||||
GSMemAccepted -> False
|
||||
GSMemAnnounced -> False
|
||||
GSMemConnected -> True
|
||||
GSMemComplete -> True
|
||||
GSMemCreator -> True
|
||||
|
||||
memberCurrent :: GroupMember -> Bool
|
||||
memberCurrent m = case memberStatus m of
|
||||
GSMemRemoved -> False
|
||||
GSMemLeft -> False
|
||||
GSMemGroupDeleted -> False
|
||||
GSMemInvited -> False
|
||||
GSMemIntroduced -> True
|
||||
GSMemIntroInvited -> True
|
||||
GSMemAccepted -> True
|
||||
GSMemAnnounced -> True
|
||||
GSMemConnected -> True
|
||||
GSMemComplete -> True
|
||||
GSMemCreator -> True
|
||||
|
||||
memberStatusT :: Text -> Maybe GroupMemberStatus
|
||||
memberStatusT = \case
|
||||
"removed" -> Just GSMemRemoved
|
||||
"left" -> Just GSMemLeft
|
||||
"deleted" -> Just GSMemGroupDeleted
|
||||
"invited" -> Just GSMemInvited
|
||||
"introduced" -> Just GSMemIntroduced
|
||||
"intro-inv" -> Just GSMemIntroInvited
|
||||
"accepted" -> Just GSMemAccepted
|
||||
"announced" -> Just GSMemAnnounced
|
||||
"connected" -> Just GSMemConnected
|
||||
"complete" -> Just GSMemComplete
|
||||
"creator" -> Just GSMemCreator
|
||||
_ -> Nothing
|
||||
|
||||
serializeMemberStatus :: GroupMemberStatus -> Text
|
||||
serializeMemberStatus = \case
|
||||
GSMemRemoved -> "removed"
|
||||
GSMemLeft -> "left"
|
||||
GSMemGroupDeleted -> "deleted"
|
||||
GSMemInvited -> "invited"
|
||||
GSMemIntroduced -> "introduced"
|
||||
GSMemIntroInvited -> "intro-inv"
|
||||
GSMemAccepted -> "accepted"
|
||||
GSMemAnnounced -> "announced"
|
||||
GSMemConnected -> "connected"
|
||||
GSMemComplete -> "complete"
|
||||
GSMemCreator -> "creator"
|
||||
|
||||
data SndFileTransfer = SndFileTransfer
|
||||
{ fileId :: Int64,
|
||||
fileName :: String,
|
||||
filePath :: String,
|
||||
fileSize :: Integer,
|
||||
chunkSize :: Integer,
|
||||
recipientDisplayName :: ContactName,
|
||||
connId :: Int64,
|
||||
agentConnId :: ConnId,
|
||||
fileStatus :: FileStatus
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data FileInvitation = FileInvitation
|
||||
{ fileName :: String,
|
||||
fileSize :: Integer,
|
||||
fileQInfo :: SMPQueueInfo
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data RcvFileTransfer = RcvFileTransfer
|
||||
{ fileId :: Int64,
|
||||
fileInvitation :: FileInvitation,
|
||||
fileStatus :: RcvFileStatus,
|
||||
senderDisplayName :: ContactName,
|
||||
chunkSize :: Integer
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data RcvFileStatus
|
||||
= RFSNew
|
||||
| RFSAccepted RcvFileInfo
|
||||
| RFSConnected RcvFileInfo
|
||||
| RFSComplete RcvFileInfo
|
||||
| RFSCancelled RcvFileInfo
|
||||
deriving (Eq, Show)
|
||||
|
||||
data RcvFileInfo = RcvFileInfo
|
||||
{ filePath :: FilePath,
|
||||
connId :: Int64,
|
||||
agentConnId :: ConnId
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data FileTransfer = FTSnd [SndFileTransfer] | FTRcv RcvFileTransfer
|
||||
|
||||
data FileStatus = FSNew | FSAccepted | FSConnected | FSComplete | FSCancelled deriving (Eq, Ord, Show)
|
||||
|
||||
instance FromField FileStatus where fromField = fromTextField_ fileStatusT
|
||||
|
||||
instance ToField FileStatus where toField = toField . serializeFileStatus
|
||||
|
||||
fileStatusT :: Text -> Maybe FileStatus
|
||||
fileStatusT = \case
|
||||
"new" -> Just FSNew
|
||||
"accepted" -> Just FSAccepted
|
||||
"connected" -> Just FSConnected
|
||||
"complete" -> Just FSComplete
|
||||
"cancelled" -> Just FSCancelled
|
||||
_ -> Nothing
|
||||
|
||||
serializeFileStatus :: FileStatus -> Text
|
||||
serializeFileStatus = \case
|
||||
FSNew -> "new"
|
||||
FSAccepted -> "accepted"
|
||||
FSConnected -> "connected"
|
||||
FSComplete -> "complete"
|
||||
FSCancelled -> "cancelled"
|
||||
|
||||
data RcvChunkStatus = RcvChunkOk | RcvChunkFinal | RcvChunkDuplicate | RcvChunkError
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Connection = Connection
|
||||
{ connId :: Int64,
|
||||
agentConnId :: ConnId,
|
||||
connLevel :: Int,
|
||||
viaContact :: Maybe Int64,
|
||||
connType :: ConnType,
|
||||
connStatus :: ConnStatus,
|
||||
entityId :: Maybe Int64, -- contact, group member or file ID
|
||||
createdAt :: UTCTime
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ConnStatus
|
||||
= -- | connection is created by initiating party with agent NEW command (createConnection)
|
||||
ConnNew
|
||||
| -- | connection is joined by joining party with agent JOIN command (joinConnection)
|
||||
ConnJoined
|
||||
| -- | initiating party received CONF notification (to be renamed to REQ)
|
||||
ConnRequested
|
||||
| -- | initiating party accepted connection with agent LET command (to be renamed to ACPT) (allowConnection)
|
||||
ConnAccepted
|
||||
| -- | connection can be sent messages to (after joining party received INFO notification)
|
||||
ConnSndReady
|
||||
| -- | connection is ready for both parties to send and receive messages
|
||||
ConnReady
|
||||
| -- | connection deleted
|
||||
ConnDeleted
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromField ConnStatus where fromField = fromTextField_ connStatusT
|
||||
|
||||
instance ToField ConnStatus where toField = toField . serializeConnStatus
|
||||
|
||||
connStatusT :: Text -> Maybe ConnStatus
|
||||
connStatusT = \case
|
||||
"new" -> Just ConnNew
|
||||
"joined" -> Just ConnJoined
|
||||
"requested" -> Just ConnRequested
|
||||
"accepted" -> Just ConnAccepted
|
||||
"snd-ready" -> Just ConnSndReady
|
||||
"ready" -> Just ConnReady
|
||||
"deleted" -> Just ConnDeleted
|
||||
_ -> Nothing
|
||||
|
||||
serializeConnStatus :: ConnStatus -> Text
|
||||
serializeConnStatus = \case
|
||||
ConnNew -> "new"
|
||||
ConnJoined -> "joined"
|
||||
ConnRequested -> "requested"
|
||||
ConnAccepted -> "accepted"
|
||||
ConnSndReady -> "snd-ready"
|
||||
ConnReady -> "ready"
|
||||
ConnDeleted -> "deleted"
|
||||
|
||||
data ConnType = ConnContact | ConnMember | ConnSndFile | ConnRcvFile
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromField ConnType where fromField = fromTextField_ connTypeT
|
||||
|
||||
instance ToField ConnType where toField = toField . serializeConnType
|
||||
|
||||
connTypeT :: Text -> Maybe ConnType
|
||||
connTypeT = \case
|
||||
"contact" -> Just ConnContact
|
||||
"member" -> Just ConnMember
|
||||
"snd_file" -> Just ConnSndFile
|
||||
"rcv_file" -> Just ConnRcvFile
|
||||
_ -> Nothing
|
||||
|
||||
serializeConnType :: ConnType -> Text
|
||||
serializeConnType = \case
|
||||
ConnContact -> "contact"
|
||||
ConnMember -> "member"
|
||||
ConnSndFile -> "snd_file"
|
||||
ConnRcvFile -> "rcv_file"
|
||||
|
||||
data NewConnection = NewConnection
|
||||
{ agentConnId :: ByteString,
|
||||
connLevel :: Int,
|
||||
viaConn :: Maybe Int64
|
||||
}
|
||||
|
||||
data GroupMemberIntro = GroupMemberIntro
|
||||
{ introId :: Int64,
|
||||
reMember :: GroupMember,
|
||||
toMember :: GroupMember,
|
||||
introStatus :: GroupMemberIntroStatus,
|
||||
introInvitation :: Maybe IntroInvitation
|
||||
}
|
||||
|
||||
data GroupMemberIntroStatus
|
||||
= GMIntroPending
|
||||
| GMIntroSent
|
||||
| GMIntroInvReceived
|
||||
| GMIntroInvForwarded
|
||||
| GMIntroReConnected
|
||||
| GMIntroToConnected
|
||||
| GMIntroConnected
|
||||
|
||||
instance FromField GroupMemberIntroStatus where fromField = fromTextField_ introStatusT
|
||||
|
||||
instance ToField GroupMemberIntroStatus where toField = toField . serializeIntroStatus
|
||||
|
||||
introStatusT :: Text -> Maybe GroupMemberIntroStatus
|
||||
introStatusT = \case
|
||||
"new" -> Just GMIntroPending
|
||||
"sent" -> Just GMIntroSent
|
||||
"rcv" -> Just GMIntroInvReceived
|
||||
"fwd" -> Just GMIntroInvForwarded
|
||||
"re-con" -> Just GMIntroReConnected
|
||||
"to-con" -> Just GMIntroToConnected
|
||||
"con" -> Just GMIntroConnected
|
||||
_ -> Nothing
|
||||
|
||||
serializeIntroStatus :: GroupMemberIntroStatus -> Text
|
||||
serializeIntroStatus = \case
|
||||
GMIntroPending -> "new"
|
||||
GMIntroSent -> "sent"
|
||||
GMIntroInvReceived -> "rcv"
|
||||
GMIntroInvForwarded -> "fwd"
|
||||
GMIntroReConnected -> "re-con"
|
||||
GMIntroToConnected -> "to-con"
|
||||
GMIntroConnected -> "con"
|
||||
@@ -0,0 +1,16 @@
|
||||
module Simplex.Chat.Util where
|
||||
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8With)
|
||||
|
||||
safeDecodeUtf8 :: ByteString -> Text
|
||||
safeDecodeUtf8 = decodeUtf8With onError
|
||||
where
|
||||
onError _ _ = Just '?'
|
||||
|
||||
ifM :: Monad m => m Bool -> m a -> m a -> m a
|
||||
ifM ba t f = ba >>= \b -> if b then t else f
|
||||
|
||||
unlessM :: Monad m => m Bool -> m () -> m ()
|
||||
unlessM b = ifM b $ pure ()
|
||||
@@ -0,0 +1,687 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.View
|
||||
( printToView,
|
||||
showInvitation,
|
||||
showChatError,
|
||||
showContactDeleted,
|
||||
showContactGroups,
|
||||
showContactConnected,
|
||||
showContactDisconnected,
|
||||
showContactAnotherClient,
|
||||
showContactSubscribed,
|
||||
showContactSubError,
|
||||
showGroupSubscribed,
|
||||
showGroupEmpty,
|
||||
showGroupRemoved,
|
||||
showMemberSubError,
|
||||
showReceivedMessage,
|
||||
showReceivedGroupMessage,
|
||||
showSentMessage,
|
||||
showSentGroupMessage,
|
||||
showSentFileInvitation,
|
||||
showSentGroupFileInvitation,
|
||||
showSentFileInfo,
|
||||
showSndFileStart,
|
||||
showSndFileComplete,
|
||||
showSndFileCancelled,
|
||||
showSndGroupFileCancelled,
|
||||
showSndFileRcvCancelled,
|
||||
receivedFileInvitation,
|
||||
showRcvFileAccepted,
|
||||
showRcvFileStart,
|
||||
showRcvFileComplete,
|
||||
showRcvFileCancelled,
|
||||
showRcvFileSndCancelled,
|
||||
showFileTransferStatus,
|
||||
showSndFileSubError,
|
||||
showRcvFileSubError,
|
||||
showGroupCreated,
|
||||
showGroupDeletedUser,
|
||||
showGroupDeleted,
|
||||
showSentGroupInvitation,
|
||||
showReceivedGroupInvitation,
|
||||
showJoinedGroupMember,
|
||||
showUserJoinedGroup,
|
||||
showJoinedGroupMemberConnecting,
|
||||
showConnectedToGroupMember,
|
||||
showDeletedMember,
|
||||
showDeletedMemberUser,
|
||||
showLeftMemberUser,
|
||||
showLeftMember,
|
||||
showGroupMembers,
|
||||
showContactsMerged,
|
||||
showUserProfile,
|
||||
showUserProfileUpdated,
|
||||
showContactUpdated,
|
||||
showMessageError,
|
||||
safeDecodeUtf8,
|
||||
msgPlain,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Composition ((.:), (.:.))
|
||||
import Data.Function (on)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (groupBy, intersperse, sortOn)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
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 Numeric (showFFloat)
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Store (StoreError (..))
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Terminal (printToTerminal)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Util (safeDecodeUtf8)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import System.Console.ANSI.Types
|
||||
|
||||
type ChatReader m = (MonadUnliftIO m, MonadReader ChatController m)
|
||||
|
||||
showInvitation :: ChatReader m => SMPQueueInfo -> m ()
|
||||
showInvitation = printToView . invitation
|
||||
|
||||
showChatError :: ChatReader m => ChatError -> m ()
|
||||
showChatError = printToView . chatError
|
||||
|
||||
showContactDeleted :: ChatReader m => ContactName -> m ()
|
||||
showContactDeleted = printToView . contactDeleted
|
||||
|
||||
showContactGroups :: ChatReader m => ContactName -> [GroupName] -> m ()
|
||||
showContactGroups = printToView .: contactGroups
|
||||
|
||||
showContactConnected :: ChatReader m => Contact -> m ()
|
||||
showContactConnected = printToView . contactConnected
|
||||
|
||||
showContactDisconnected :: ChatReader m => ContactName -> m ()
|
||||
showContactDisconnected = printToView . contactDisconnected
|
||||
|
||||
showContactAnotherClient :: ChatReader m => ContactName -> m ()
|
||||
showContactAnotherClient = printToView . contactAnotherClient
|
||||
|
||||
showContactSubscribed :: ChatReader m => ContactName -> m ()
|
||||
showContactSubscribed = printToView . contactSubscribed
|
||||
|
||||
showContactSubError :: ChatReader m => ContactName -> ChatError -> m ()
|
||||
showContactSubError = printToView .: contactSubError
|
||||
|
||||
showGroupSubscribed :: ChatReader m => GroupName -> m ()
|
||||
showGroupSubscribed = printToView . groupSubscribed
|
||||
|
||||
showGroupEmpty :: ChatReader m => GroupName -> m ()
|
||||
showGroupEmpty = printToView . groupEmpty
|
||||
|
||||
showGroupRemoved :: ChatReader m => GroupName -> m ()
|
||||
showGroupRemoved = printToView . groupRemoved
|
||||
|
||||
showMemberSubError :: ChatReader m => GroupName -> ContactName -> ChatError -> m ()
|
||||
showMemberSubError = printToView .:. memberSubError
|
||||
|
||||
showReceivedMessage :: ChatReader m => ContactName -> UTCTime -> [StyledString] -> MsgIntegrity -> m ()
|
||||
showReceivedMessage = showReceivedMessage_ . ttyFromContact
|
||||
|
||||
showReceivedGroupMessage :: ChatReader m => GroupName -> ContactName -> UTCTime -> [StyledString] -> MsgIntegrity -> m ()
|
||||
showReceivedGroupMessage = showReceivedMessage_ .: ttyFromGroup
|
||||
|
||||
showReceivedMessage_ :: ChatReader m => StyledString -> UTCTime -> [StyledString] -> MsgIntegrity -> m ()
|
||||
showReceivedMessage_ from utcTime msg mOk = printToView =<< liftIO (receivedMessage from utcTime msg mOk)
|
||||
|
||||
showSentMessage :: ChatReader m => ContactName -> ByteString -> m ()
|
||||
showSentMessage = showSentMessage_ . ttyToContact
|
||||
|
||||
showSentGroupMessage :: ChatReader m => GroupName -> ByteString -> m ()
|
||||
showSentGroupMessage = showSentMessage_ . ttyToGroup
|
||||
|
||||
showSentMessage_ :: ChatReader m => StyledString -> ByteString -> m ()
|
||||
showSentMessage_ to msg = printToView =<< liftIO (sentMessage to msg)
|
||||
|
||||
showSentFileInvitation :: ChatReader m => ContactName -> FilePath -> m ()
|
||||
showSentFileInvitation = showSentFileInvitation_ . ttyToContact
|
||||
|
||||
showSentGroupFileInvitation :: ChatReader m => GroupName -> FilePath -> m ()
|
||||
showSentGroupFileInvitation = showSentFileInvitation_ . ttyToGroup
|
||||
|
||||
showSentFileInvitation_ :: ChatReader m => StyledString -> FilePath -> m ()
|
||||
showSentFileInvitation_ to filePath = printToView =<< liftIO (sentFileInvitation to filePath)
|
||||
|
||||
showSentFileInfo :: ChatReader m => Int64 -> m ()
|
||||
showSentFileInfo = printToView . sentFileInfo
|
||||
|
||||
showSndFileStart :: ChatReader m => SndFileTransfer -> m ()
|
||||
showSndFileStart = printToView . sndFileStart
|
||||
|
||||
showSndFileComplete :: ChatReader m => SndFileTransfer -> m ()
|
||||
showSndFileComplete = printToView . sndFileComplete
|
||||
|
||||
showSndFileCancelled :: ChatReader m => SndFileTransfer -> m ()
|
||||
showSndFileCancelled = printToView . sndFileCancelled
|
||||
|
||||
showSndGroupFileCancelled :: ChatReader m => [SndFileTransfer] -> m ()
|
||||
showSndGroupFileCancelled = printToView . sndGroupFileCancelled
|
||||
|
||||
showSndFileRcvCancelled :: ChatReader m => SndFileTransfer -> m ()
|
||||
showSndFileRcvCancelled = printToView . sndFileRcvCancelled
|
||||
|
||||
showRcvFileAccepted :: ChatReader m => RcvFileTransfer -> FilePath -> m ()
|
||||
showRcvFileAccepted = printToView .: rcvFileAccepted
|
||||
|
||||
showRcvFileStart :: ChatReader m => RcvFileTransfer -> m ()
|
||||
showRcvFileStart = printToView . rcvFileStart
|
||||
|
||||
showRcvFileComplete :: ChatReader m => RcvFileTransfer -> m ()
|
||||
showRcvFileComplete = printToView . rcvFileComplete
|
||||
|
||||
showRcvFileCancelled :: ChatReader m => RcvFileTransfer -> m ()
|
||||
showRcvFileCancelled = printToView . rcvFileCancelled
|
||||
|
||||
showRcvFileSndCancelled :: ChatReader m => RcvFileTransfer -> m ()
|
||||
showRcvFileSndCancelled = printToView . rcvFileSndCancelled
|
||||
|
||||
showFileTransferStatus :: ChatReader m => (FileTransfer, [Integer]) -> m ()
|
||||
showFileTransferStatus = printToView . fileTransferStatus
|
||||
|
||||
showSndFileSubError :: ChatReader m => SndFileTransfer -> ChatError -> m ()
|
||||
showSndFileSubError = printToView .: sndFileSubError
|
||||
|
||||
showRcvFileSubError :: ChatReader m => RcvFileTransfer -> ChatError -> m ()
|
||||
showRcvFileSubError = printToView .: rcvFileSubError
|
||||
|
||||
showGroupCreated :: ChatReader m => Group -> m ()
|
||||
showGroupCreated = printToView . groupCreated
|
||||
|
||||
showGroupDeletedUser :: ChatReader m => GroupName -> m ()
|
||||
showGroupDeletedUser = printToView . groupDeletedUser
|
||||
|
||||
showGroupDeleted :: ChatReader m => GroupName -> GroupMember -> m ()
|
||||
showGroupDeleted = printToView .: groupDeleted
|
||||
|
||||
showSentGroupInvitation :: ChatReader m => GroupName -> ContactName -> m ()
|
||||
showSentGroupInvitation = printToView .: sentGroupInvitation
|
||||
|
||||
showReceivedGroupInvitation :: ChatReader m => Group -> ContactName -> GroupMemberRole -> m ()
|
||||
showReceivedGroupInvitation = printToView .:. receivedGroupInvitation
|
||||
|
||||
showJoinedGroupMember :: ChatReader m => GroupName -> GroupMember -> m ()
|
||||
showJoinedGroupMember = printToView .: joinedGroupMember
|
||||
|
||||
showUserJoinedGroup :: ChatReader m => GroupName -> m ()
|
||||
showUserJoinedGroup = printToView . userJoinedGroup
|
||||
|
||||
showJoinedGroupMemberConnecting :: ChatReader m => GroupName -> GroupMember -> GroupMember -> m ()
|
||||
showJoinedGroupMemberConnecting = printToView .:. joinedGroupMemberConnecting
|
||||
|
||||
showConnectedToGroupMember :: ChatReader m => GroupName -> GroupMember -> m ()
|
||||
showConnectedToGroupMember = printToView .: connectedToGroupMember
|
||||
|
||||
showDeletedMember :: ChatReader m => GroupName -> Maybe GroupMember -> Maybe GroupMember -> m ()
|
||||
showDeletedMember = printToView .:. deletedMember
|
||||
|
||||
showDeletedMemberUser :: ChatReader m => GroupName -> GroupMember -> m ()
|
||||
showDeletedMemberUser = printToView .: deletedMemberUser
|
||||
|
||||
showLeftMemberUser :: ChatReader m => GroupName -> m ()
|
||||
showLeftMemberUser = printToView . leftMemberUser
|
||||
|
||||
showLeftMember :: ChatReader m => GroupName -> GroupMember -> m ()
|
||||
showLeftMember = printToView .: leftMember
|
||||
|
||||
showGroupMembers :: ChatReader m => Group -> m ()
|
||||
showGroupMembers = printToView . groupMembers
|
||||
|
||||
showContactsMerged :: ChatReader m => Contact -> Contact -> m ()
|
||||
showContactsMerged = printToView .: contactsMerged
|
||||
|
||||
showUserProfile :: ChatReader m => Profile -> m ()
|
||||
showUserProfile = printToView . userProfile
|
||||
|
||||
showUserProfileUpdated :: ChatReader m => User -> User -> m ()
|
||||
showUserProfileUpdated = printToView .: userProfileUpdated
|
||||
|
||||
showContactUpdated :: ChatReader m => Contact -> Contact -> m ()
|
||||
showContactUpdated = printToView .: contactUpdated
|
||||
|
||||
showMessageError :: ChatReader m => Text -> Text -> m ()
|
||||
showMessageError = printToView .: messageError
|
||||
|
||||
invitation :: SMPQueueInfo -> [StyledString]
|
||||
invitation qInfo =
|
||||
[ "pass this invitation to your contact (via another channel): ",
|
||||
"",
|
||||
(plain . serializeSmpQueueInfo) qInfo,
|
||||
"",
|
||||
"and ask them to connect: " <> highlight' "/c <invitation_above>"
|
||||
]
|
||||
|
||||
contactDeleted :: ContactName -> [StyledString]
|
||||
contactDeleted c = [ttyContact c <> ": contact is deleted"]
|
||||
|
||||
contactGroups :: ContactName -> [GroupName] -> [StyledString]
|
||||
contactGroups c gNames = [ttyContact c <> ": contact cannot be deleted, it is a member of the group(s) " <> ttyGroups gNames]
|
||||
where
|
||||
ttyGroups :: [GroupName] -> StyledString
|
||||
ttyGroups [] = ""
|
||||
ttyGroups [g] = ttyGroup g
|
||||
ttyGroups (g : gs) = ttyGroup g <> ", " <> ttyGroups gs
|
||||
|
||||
contactConnected :: Contact -> [StyledString]
|
||||
contactConnected ct = [ttyFullContact ct <> ": contact is connected"]
|
||||
|
||||
contactDisconnected :: ContactName -> [StyledString]
|
||||
contactDisconnected c = [ttyContact c <> ": disconnected from server (messages will be queued)"]
|
||||
|
||||
contactAnotherClient :: ContactName -> [StyledString]
|
||||
contactAnotherClient c = [ttyContact c <> ": contact is connected to another client"]
|
||||
|
||||
contactSubscribed :: ContactName -> [StyledString]
|
||||
contactSubscribed c = [ttyContact c <> ": connected to server"]
|
||||
|
||||
contactSubError :: ContactName -> ChatError -> [StyledString]
|
||||
contactSubError c e = [ttyContact c <> ": contact error " <> sShow e]
|
||||
|
||||
groupSubscribed :: GroupName -> [StyledString]
|
||||
groupSubscribed g = [ttyGroup g <> ": connected to server(s)"]
|
||||
|
||||
groupEmpty :: GroupName -> [StyledString]
|
||||
groupEmpty g = [ttyGroup g <> ": group is empty"]
|
||||
|
||||
groupRemoved :: GroupName -> [StyledString]
|
||||
groupRemoved g = [ttyGroup g <> ": you are no longer a member or group deleted"]
|
||||
|
||||
memberSubError :: GroupName -> ContactName -> ChatError -> [StyledString]
|
||||
memberSubError g c e = [ttyGroup g <> " member " <> ttyContact c <> " error: " <> sShow e]
|
||||
|
||||
groupCreated :: Group -> [StyledString]
|
||||
groupCreated g@Group {localDisplayName} =
|
||||
[ "group " <> ttyFullGroup g <> " is created",
|
||||
"use " <> highlight ("/a " <> localDisplayName <> " <name>") <> " to add members"
|
||||
]
|
||||
|
||||
groupDeletedUser :: GroupName -> [StyledString]
|
||||
groupDeletedUser g = groupDeleted_ g Nothing
|
||||
|
||||
groupDeleted :: GroupName -> GroupMember -> [StyledString]
|
||||
groupDeleted g m = groupDeleted_ g (Just m) <> ["use " <> highlight ("/d #" <> g) <> " to delete the local copy of the group"]
|
||||
|
||||
groupDeleted_ :: GroupName -> Maybe GroupMember -> [StyledString]
|
||||
groupDeleted_ g m = [ttyGroup g <> ": " <> memberOrUser m <> " deleted the group"]
|
||||
|
||||
sentGroupInvitation :: GroupName -> ContactName -> [StyledString]
|
||||
sentGroupInvitation g c = ["invitation to join the group " <> ttyGroup g <> " sent to " <> ttyContact c]
|
||||
|
||||
receivedGroupInvitation :: Group -> ContactName -> GroupMemberRole -> [StyledString]
|
||||
receivedGroupInvitation g@Group {localDisplayName} c role =
|
||||
[ ttyFullGroup g <> ": " <> ttyContact c <> " invites you to join the group as " <> plain (serializeMemberRole role),
|
||||
"use " <> highlight ("/j " <> localDisplayName) <> " to accept"
|
||||
]
|
||||
|
||||
joinedGroupMember :: GroupName -> GroupMember -> [StyledString]
|
||||
joinedGroupMember g m = [ttyGroup g <> ": " <> ttyMember m <> " joined the group "]
|
||||
|
||||
userJoinedGroup :: GroupName -> [StyledString]
|
||||
userJoinedGroup g = [ttyGroup g <> ": you joined the group"]
|
||||
|
||||
joinedGroupMemberConnecting :: GroupName -> GroupMember -> GroupMember -> [StyledString]
|
||||
joinedGroupMemberConnecting g host m = [ttyGroup g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"]
|
||||
|
||||
connectedToGroupMember :: GroupName -> GroupMember -> [StyledString]
|
||||
connectedToGroupMember g m = [ttyGroup g <> ": " <> connectedMember m <> " is connected"]
|
||||
|
||||
deletedMember :: GroupName -> Maybe GroupMember -> Maybe GroupMember -> [StyledString]
|
||||
deletedMember g by m = [ttyGroup g <> ": " <> memberOrUser by <> " removed " <> memberOrUser m <> " from the group"]
|
||||
|
||||
deletedMemberUser :: GroupName -> GroupMember -> [StyledString]
|
||||
deletedMemberUser g by = deletedMember g (Just by) Nothing <> groupPreserved g
|
||||
|
||||
leftMemberUser :: GroupName -> [StyledString]
|
||||
leftMemberUser g = leftMember_ g Nothing <> groupPreserved g
|
||||
|
||||
leftMember :: GroupName -> GroupMember -> [StyledString]
|
||||
leftMember g m = leftMember_ g (Just m)
|
||||
|
||||
leftMember_ :: GroupName -> Maybe GroupMember -> [StyledString]
|
||||
leftMember_ g m = [ttyGroup g <> ": " <> memberOrUser m <> " left the group"]
|
||||
|
||||
groupPreserved :: GroupName -> [StyledString]
|
||||
groupPreserved g = ["use " <> highlight ("/d #" <> g) <> " to delete the group"]
|
||||
|
||||
memberOrUser :: Maybe GroupMember -> StyledString
|
||||
memberOrUser = maybe "you" ttyMember
|
||||
|
||||
connectedMember :: GroupMember -> StyledString
|
||||
connectedMember m = case memberCategory m of
|
||||
GCPreMember -> "member " <> ttyFullMember m
|
||||
GCPostMember -> "new member " <> ttyMember m -- without fullName as as it was shown in joinedGroupMemberConnecting
|
||||
_ -> "member " <> ttyMember m -- these case is not used
|
||||
|
||||
groupMembers :: Group -> [StyledString]
|
||||
groupMembers Group {membership, members} = map groupMember . filter (not . removedOrLeft) $ membership : members
|
||||
where
|
||||
removedOrLeft m = let s = memberStatus m in s == GSMemRemoved || s == GSMemLeft
|
||||
groupMember m = ttyFullMember m <> ": " <> role m <> ", " <> category m <> status m
|
||||
role = plain . serializeMemberRole . memberRole
|
||||
category m = case memberCategory m of
|
||||
GCUserMember -> "you, "
|
||||
GCInviteeMember -> "invited, "
|
||||
GCHostMember -> "host, "
|
||||
_ -> ""
|
||||
status m = case memberStatus m of
|
||||
GSMemRemoved -> "removed"
|
||||
GSMemLeft -> "left"
|
||||
GSMemInvited -> "not yet joined"
|
||||
GSMemConnected -> "connected"
|
||||
GSMemComplete -> "connected"
|
||||
GSMemCreator -> "created group"
|
||||
_ -> ""
|
||||
|
||||
contactsMerged :: Contact -> Contact -> [StyledString]
|
||||
contactsMerged _to@Contact {localDisplayName = c1} _from@Contact {localDisplayName = c2} =
|
||||
[ "contact " <> ttyContact c2 <> " is merged into " <> ttyContact c1,
|
||||
"use " <> ttyToContact c1 <> highlight' "<message>" <> " to send messages"
|
||||
]
|
||||
|
||||
userProfile :: Profile -> [StyledString]
|
||||
userProfile Profile {displayName, fullName} =
|
||||
[ "user profile: " <> ttyFullName displayName fullName,
|
||||
"use " <> highlight' "/p <display name> [<full name>]" <> " to change it",
|
||||
"(the updated profile will be sent to all your contacts)"
|
||||
]
|
||||
|
||||
userProfileUpdated :: User -> User -> [StyledString]
|
||||
userProfileUpdated
|
||||
User {localDisplayName = n, profile = Profile {fullName}}
|
||||
User {localDisplayName = n', profile = Profile {fullName = fullName'}}
|
||||
| n == n' && fullName == fullName' = []
|
||||
| n == n' = ["user full name " <> (if T.null fullName' || fullName' == n' then "removed" else "changed to " <> plain fullName') <> notified]
|
||||
| otherwise = ["user profile is changed to " <> ttyFullName n' fullName' <> notified]
|
||||
where
|
||||
notified = " (your contacts are notified)"
|
||||
|
||||
contactUpdated :: Contact -> Contact -> [StyledString]
|
||||
contactUpdated
|
||||
Contact {localDisplayName = n, profile = Profile {fullName}}
|
||||
Contact {localDisplayName = n', profile = Profile {fullName = fullName'}}
|
||||
| n == n' && fullName == fullName' = []
|
||||
| n == n' = ["contact " <> ttyContact n <> fullNameUpdate]
|
||||
| otherwise =
|
||||
[ "contact " <> ttyContact n <> " changed to " <> ttyFullName n' fullName',
|
||||
"use " <> ttyToContact n' <> highlight' "<message>" <> " to send messages"
|
||||
]
|
||||
where
|
||||
fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName'
|
||||
|
||||
messageError :: Text -> Text -> [StyledString]
|
||||
messageError prefix err = [plain prefix <> ": " <> plain err]
|
||||
|
||||
receivedMessage :: StyledString -> UTCTime -> [StyledString] -> MsgIntegrity -> IO [StyledString]
|
||||
receivedMessage from utcTime msg mOk = do
|
||||
t <- formatUTCTime <$> getCurrentTimeZone <*> getZonedTime
|
||||
pure $ prependFirst (t <> " " <> from) 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 :: StyledString -> ByteString -> IO [StyledString]
|
||||
sentMessage to msg = sendWithTime_ to . msgPlain $ safeDecodeUtf8 msg
|
||||
|
||||
sentFileInvitation :: StyledString -> FilePath -> IO [StyledString]
|
||||
sentFileInvitation to f = sendWithTime_ ("/f " <> to) [ttyFilePath f]
|
||||
|
||||
sendWithTime_ :: StyledString -> [StyledString] -> IO [StyledString]
|
||||
sendWithTime_ to styledMsg = do
|
||||
time <- formatTime defaultTimeLocale "%H:%M" <$> getZonedTime
|
||||
pure $ prependFirst (styleTime time <> " " <> to) styledMsg
|
||||
|
||||
prependFirst :: StyledString -> [StyledString] -> [StyledString]
|
||||
prependFirst s [] = [s]
|
||||
prependFirst s (s' : ss) = (s <> s') : ss
|
||||
|
||||
msgPlain :: Text -> [StyledString]
|
||||
msgPlain = map styleMarkdownText . T.lines
|
||||
|
||||
sentFileInfo :: Int64 -> [StyledString]
|
||||
sentFileInfo fileId =
|
||||
["use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"]
|
||||
|
||||
sndFileStart :: SndFileTransfer -> [StyledString]
|
||||
sndFileStart = sendingFile_ "started"
|
||||
|
||||
sndFileComplete :: SndFileTransfer -> [StyledString]
|
||||
sndFileComplete = sendingFile_ "completed"
|
||||
|
||||
sndFileCancelled :: SndFileTransfer -> [StyledString]
|
||||
sndFileCancelled = sendingFile_ "cancelled"
|
||||
|
||||
sndGroupFileCancelled :: [SndFileTransfer] -> [StyledString]
|
||||
sndGroupFileCancelled fts =
|
||||
case filter (\SndFileTransfer {fileStatus = s} -> s /= FSCancelled && s /= FSComplete) fts of
|
||||
[] -> ["sending file can't be cancelled"]
|
||||
ts@(ft : _) -> ["cancelled sending " <> sndFile ft <> " to " <> listMembers ts]
|
||||
|
||||
sendingFile_ :: StyledString -> SndFileTransfer -> [StyledString]
|
||||
sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
|
||||
[status <> " sending " <> sndFile ft <> " to " <> ttyContact c]
|
||||
|
||||
sndFileRcvCancelled :: SndFileTransfer -> [StyledString]
|
||||
sndFileRcvCancelled ft@SndFileTransfer {recipientDisplayName = c} =
|
||||
[ttyContact c <> " cancelled receiving " <> sndFile ft]
|
||||
|
||||
sndFile :: SndFileTransfer -> StyledString
|
||||
sndFile SndFileTransfer {fileId, fileName} = fileTransfer fileId fileName
|
||||
|
||||
receivedFileInvitation :: RcvFileTransfer -> [StyledString]
|
||||
receivedFileInvitation RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName, fileSize}} =
|
||||
[ "sends file " <> ttyFilePath fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)",
|
||||
"use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"
|
||||
]
|
||||
|
||||
humanReadableSize :: Integer -> StyledString
|
||||
humanReadableSize size
|
||||
| size < kB = sShow size <> " bytes"
|
||||
| size < mB = hrSize kB "KiB"
|
||||
| size < gB = hrSize mB "MiB"
|
||||
| otherwise = hrSize gB "GiB"
|
||||
where
|
||||
hrSize sB name = plain $ unwords [showFFloat (Just 1) (fromIntegral size / (fromIntegral sB :: Double)) "", name]
|
||||
kB = 1024
|
||||
mB = kB * 1024
|
||||
gB = mB * 1024
|
||||
|
||||
rcvFileAccepted :: RcvFileTransfer -> FilePath -> [StyledString]
|
||||
rcvFileAccepted RcvFileTransfer {fileId, senderDisplayName = c} filePath =
|
||||
["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath]
|
||||
|
||||
rcvFileStart :: RcvFileTransfer -> [StyledString]
|
||||
rcvFileStart = receivingFile_ "started"
|
||||
|
||||
rcvFileComplete :: RcvFileTransfer -> [StyledString]
|
||||
rcvFileComplete = receivingFile_ "completed"
|
||||
|
||||
rcvFileCancelled :: RcvFileTransfer -> [StyledString]
|
||||
rcvFileCancelled = receivingFile_ "cancelled"
|
||||
|
||||
receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString]
|
||||
receivingFile_ status ft@RcvFileTransfer {senderDisplayName = c} =
|
||||
[status <> " receiving " <> rcvFile ft <> " from " <> ttyContact c]
|
||||
|
||||
rcvFileSndCancelled :: RcvFileTransfer -> [StyledString]
|
||||
rcvFileSndCancelled ft@RcvFileTransfer {senderDisplayName = c} =
|
||||
[ttyContact c <> " cancelled sending " <> rcvFile ft]
|
||||
|
||||
rcvFile :: RcvFileTransfer -> StyledString
|
||||
rcvFile RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} = fileTransfer fileId fileName
|
||||
|
||||
fileTransfer :: Int64 -> String -> StyledString
|
||||
fileTransfer fileId fileName = "file " <> sShow fileId <> " (" <> ttyFilePath fileName <> ")"
|
||||
|
||||
fileTransferStatus :: (FileTransfer, [Integer]) -> [StyledString]
|
||||
fileTransferStatus (FTSnd [ft@SndFileTransfer {fileStatus, fileSize, chunkSize}], chunksNum) =
|
||||
["sending " <> sndFile ft <> " " <> sndStatus]
|
||||
where
|
||||
sndStatus = case fileStatus of
|
||||
FSNew -> "not accepted yet"
|
||||
FSAccepted -> "just started"
|
||||
FSConnected -> "progress " <> fileProgress chunksNum chunkSize fileSize
|
||||
FSComplete -> "complete"
|
||||
FSCancelled -> "cancelled"
|
||||
fileTransferStatus (FTSnd [], _) = ["no file transfers (empty group)"]
|
||||
fileTransferStatus (FTSnd fts@(ft : _), chunksNum) =
|
||||
case concatMap membersTransferStatus $ groupBy ((==) `on` fs) $ sortOn fs fts of
|
||||
[membersStatus] -> ["sending " <> sndFile ft <> " " <> membersStatus]
|
||||
membersStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) membersStatuses
|
||||
where
|
||||
fs = fileStatus :: SndFileTransfer -> FileStatus
|
||||
membersTransferStatus [] = []
|
||||
membersTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listMembers ts]
|
||||
where
|
||||
sndStatus = case fileStatus of
|
||||
FSNew -> "not accepted"
|
||||
FSAccepted -> "just started"
|
||||
FSConnected -> "in progress (" <> sShow (sum chunksNum * chunkSize * 100 `div` (toInteger (length chunksNum) * fileSize)) <> "%)"
|
||||
FSComplete -> "complete"
|
||||
FSCancelled -> "cancelled"
|
||||
fileTransferStatus (FTRcv ft@RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, fileStatus, chunkSize}, chunksNum) =
|
||||
["receiving " <> rcvFile ft <> " " <> rcvStatus]
|
||||
where
|
||||
rcvStatus = case fileStatus of
|
||||
RFSNew -> "not accepted yet, use " <> highlight ("/fr " <> show fileId) <> " to receive file"
|
||||
RFSAccepted _ -> "just started"
|
||||
RFSConnected _ -> "progress " <> fileProgress chunksNum chunkSize fileSize
|
||||
RFSComplete RcvFileInfo {filePath} -> "complete, path: " <> plain filePath
|
||||
RFSCancelled RcvFileInfo {filePath} -> "cancelled, received part path: " <> plain filePath
|
||||
|
||||
listMembers :: [SndFileTransfer] -> StyledString
|
||||
listMembers = mconcat . intersperse ", " . map (ttyContact . recipientDisplayName)
|
||||
|
||||
fileProgress :: [Integer] -> Integer -> Integer -> StyledString
|
||||
fileProgress chunksNum chunkSize fileSize =
|
||||
sShow (sum chunksNum * chunkSize * 100 `div` fileSize) <> "% of " <> humanReadableSize fileSize
|
||||
|
||||
sndFileSubError :: SndFileTransfer -> ChatError -> [StyledString]
|
||||
sndFileSubError SndFileTransfer {fileId, fileName} e =
|
||||
["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
|
||||
|
||||
rcvFileSubError :: RcvFileTransfer -> ChatError -> [StyledString]
|
||||
rcvFileSubError RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e =
|
||||
["received file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
|
||||
|
||||
chatError :: ChatError -> [StyledString]
|
||||
chatError = \case
|
||||
ChatError err -> case err of
|
||||
CEGroupDuplicateMember c -> ["contact " <> ttyContact c <> " is already in the group"]
|
||||
CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"]
|
||||
CEGroupUserRole -> ["you have insufficient permissions for this group command"]
|
||||
CEGroupContactRole c -> ["contact " <> ttyContact c <> " has insufficient permissions for this group action"]
|
||||
CEGroupNotJoined g -> ["you did not join this group, use " <> highlight ("/join #" <> g)]
|
||||
CEGroupMemberNotActive -> ["you cannot invite other members yet, try later"]
|
||||
CEGroupMemberUserRemoved -> ["you are no longer the member of the group"]
|
||||
CEGroupMemberNotFound c -> ["contact " <> ttyContact c <> " is not a group member"]
|
||||
CEGroupInternal s -> ["chat group bug: " <> plain s]
|
||||
CEFileNotFound f -> ["file not found: " <> plain f]
|
||||
CEFileAlreadyReceiving f -> ["file is already accepted: " <> plain f]
|
||||
CEFileAlreadyExists f -> ["file already exists: " <> plain f]
|
||||
CEFileRead f e -> ["cannot read file " <> plain f, sShow e]
|
||||
CEFileWrite f e -> ["cannot write file " <> plain f, sShow e]
|
||||
CEFileSend fileId e -> ["error sending file " <> sShow fileId <> ": " <> sShow e]
|
||||
CEFileRcvChunk e -> ["error receiving file: " <> plain e]
|
||||
CEFileInternal e -> ["file error: " <> plain e]
|
||||
-- e -> ["chat error: " <> sShow e]
|
||||
ChatErrorStore err -> case err of
|
||||
SEDuplicateName -> ["this display name is already used by user, contact or group"]
|
||||
SEContactNotFound c -> ["no contact " <> ttyContact c]
|
||||
SEContactNotReady c -> ["contact " <> ttyContact c <> " is not active yet"]
|
||||
SEGroupNotFound g -> ["no group " <> ttyGroup g]
|
||||
SEGroupAlreadyJoined -> ["you already joined this group"]
|
||||
SEFileNotFound fileId -> fileNotFound fileId
|
||||
SESndFileNotFound fileId -> fileNotFound fileId
|
||||
SERcvFileNotFound fileId -> fileNotFound fileId
|
||||
e -> ["chat db error: " <> sShow e]
|
||||
ChatErrorAgent e -> ["smp agent error: " <> sShow e]
|
||||
ChatErrorMessage e -> ["chat message error: " <> sShow e]
|
||||
where
|
||||
fileNotFound fileId = ["file " <> sShow fileId <> " not found"]
|
||||
|
||||
printToView :: (MonadUnliftIO m, MonadReader ChatController m) => [StyledString] -> m ()
|
||||
printToView s = asks chatTerminal >>= liftIO . (`printToTerminal` s)
|
||||
|
||||
ttyContact :: ContactName -> StyledString
|
||||
ttyContact = styled (Colored Green)
|
||||
|
||||
ttyFullContact :: Contact -> StyledString
|
||||
ttyFullContact Contact {localDisplayName, profile = Profile {fullName}} =
|
||||
ttyFullName localDisplayName fullName
|
||||
|
||||
ttyMember :: GroupMember -> StyledString
|
||||
ttyMember GroupMember {localDisplayName} = ttyContact localDisplayName
|
||||
|
||||
ttyFullMember :: GroupMember -> StyledString
|
||||
ttyFullMember GroupMember {localDisplayName, memberProfile = Profile {fullName}} =
|
||||
ttyFullName localDisplayName fullName
|
||||
|
||||
ttyFullName :: ContactName -> Text -> StyledString
|
||||
ttyFullName c fullName = ttyContact c <> optFullName c fullName
|
||||
|
||||
ttyToContact :: ContactName -> StyledString
|
||||
ttyToContact c = styled (Colored Cyan) $ "@" <> c <> " "
|
||||
|
||||
ttyFromContact :: ContactName -> StyledString
|
||||
ttyFromContact c = styled (Colored Yellow) $ c <> "> "
|
||||
|
||||
ttyGroup :: GroupName -> StyledString
|
||||
ttyGroup g = styled (Colored Blue) $ "#" <> g
|
||||
|
||||
ttyFullGroup :: Group -> StyledString
|
||||
ttyFullGroup Group {localDisplayName, groupProfile = GroupProfile {fullName}} =
|
||||
ttyGroup localDisplayName <> optFullName localDisplayName fullName
|
||||
|
||||
ttyFromGroup :: GroupName -> ContactName -> StyledString
|
||||
ttyFromGroup g c = styled (Colored Yellow) $ "#" <> g <> " " <> c <> "> "
|
||||
|
||||
ttyToGroup :: GroupName -> StyledString
|
||||
ttyToGroup g = styled (Colored Cyan) $ "#" <> g <> " "
|
||||
|
||||
ttyFilePath :: FilePath -> StyledString
|
||||
ttyFilePath = plain
|
||||
|
||||
optFullName :: ContactName -> Text -> StyledString
|
||||
optFullName localDisplayName fullName
|
||||
| T.null fullName || localDisplayName == fullName = ""
|
||||
| otherwise = plain (" (" <> fullName <> ")")
|
||||
|
||||
highlight :: StyledFormat a => a -> StyledString
|
||||
highlight = styled (Colored Cyan)
|
||||
|
||||
highlight' :: String -> StyledString
|
||||
highlight' = highlight
|
||||
|
||||
styleTime :: String -> StyledString
|
||||
styleTime = Styled [SetColor Foreground Vivid Black]
|
||||
@@ -0,0 +1,168 @@
|
||||
# Chat protocol
|
||||
|
||||
## Design constraints
|
||||
|
||||
- the transport message has a fixed size (8 or 16kb), but the SMP agent will be updated to support sending messages up to maximum configured size (TBC - 64-256kb) in 8-16Kb blocks.
|
||||
- the chat message can have multiple content parts, but it should fit the agent message of the variable size.
|
||||
- one of the chat message types should support transmitting large binaries in chunks that could potentially be interleaved with other messages. For example, image preview would fit the message, but the full size image will be transmitted in chunks later - same for large files.
|
||||
- using object storage can be effective for large groups, but we will postpone it until content channels are implemented.
|
||||
|
||||
## Questions
|
||||
|
||||
- should content types be:
|
||||
- limited to MIME-types
|
||||
- separate content types vocabulary
|
||||
- both MIME types and extensions (currently we support MIME (m.) and Simplex (x.) namespaces)
|
||||
- allow additional content types namespaces
|
||||
|
||||
## Message syntax
|
||||
|
||||
The syntax of the message inside agent MSG:
|
||||
|
||||
```abnf
|
||||
agentMessageBody = [chatMsgId] SP msgEvent SP [parameters] SP [contentParts [SP msgBodyParts]]
|
||||
chatMsgId = 1*DIGIT ; used to refer to previous message;
|
||||
; in the group should only be used in messages sent to all members,
|
||||
; which is the main reason not to use external agent ID -
|
||||
; some messages are sent only to one member
|
||||
msgEvent = protocolNamespace 1*("." msgTypeName)
|
||||
protocolNamespace = 1*ALPHA ; "x" for all events defined in the protocol
|
||||
msgTypeName = 1*ALPHA
|
||||
parameters = parameter *("," parameter)
|
||||
parameter = 1*(%x21-2B / %x2D-7E) ; exclude control characters, space, comma (%x2C)
|
||||
contentParts = contentPart *("," contentPart)
|
||||
contentPart = contentTypeNamespace "." contentType ":" contentSize [":" contentHash]
|
||||
contentType = "i." <mime-type> / contentTypeNamespace "." 1*("." contentTypeName)
|
||||
contentTypeNamespace = 1*ALPHA
|
||||
contentTypeName = 1*ALPHA
|
||||
contentHash = <base64>
|
||||
msgBodyParts = msgBodyPart *(SP msgBodyPart)
|
||||
msgEventParents = msgEventParent *msgEventParent ; binary body part for content type "x.dag"
|
||||
msgEventParent = memberId refMsgId refMsgHash
|
||||
memberId = 8*8(OCTET) ; shared member ID
|
||||
refMsgId = 8*8(OCTET) ; sequential message number - external agent message ID
|
||||
refMsgHash = 16*16(OCTET) ; SHA256 of agent message body
|
||||
```
|
||||
|
||||
### Example: messages, updates, groups
|
||||
|
||||
```
|
||||
"3 x.msg.new c.text x.text:5 hello "
|
||||
"4 x.msg.new c.image i.image/jpg:256,i.image/png:4096 abcd abcd "
|
||||
"4 x.msg.new c.image x.dag:32,i.image/jpg:8000,i.image/png:16000 binary1"
|
||||
"5 x.msg.new c.image,i.image/jpg:150000 i.image/jpg:256 abcd "
|
||||
"6 x.msg.file 5,1.1 x.file:60000 abcd "
|
||||
"7 x.msg.file 5,1.2 x.file:60000 abcd "
|
||||
"8 x.msg.file 5,1.3 x.file:30000 abcd "
|
||||
'8 x.msg.update 3 x.text:11,x.dag:16 hello there abcd '
|
||||
'9 x.msg.delete 3'
|
||||
'10 x.msg.new app/v1 i.text/html:NNN,i.text/css:NNN,c.js:NNN,c.json:NNN ... ... ... {...} '
|
||||
'11 x.msg.eval 8 c.json:NNN {...} '
|
||||
'12 x.msg.new c.text x.text:16,x.dag:32 hello there @123 abcd '
|
||||
' x.grp.mem.inv 23456,123 x.json:NNN {...} '
|
||||
' x.grp.mem.acpt 23456 x.text:NNN <invitation> '
|
||||
' x.grp.mem.intro 23456,234 x.json:NNN {...} '
|
||||
' x.grp.mem.inv 23456,234 x.text:NNN <invitation> '
|
||||
' x.grp.mem.req 23456,123 x.json:NNN {...} '
|
||||
' x.grp.mem.direct.inv 23456,234 x.text:NNN <invitation> '
|
||||
' x.file name,size x.text:NNN <invitation> '
|
||||
```
|
||||
|
||||
### Group protocol
|
||||
|
||||
#### Add group member
|
||||
|
||||
A -> B: invite to group - `MSG: x.grp.inv G_MEM_ID_A,G_MEM_ROLE_A,G_MEM_ID_B,G_MEM_ROLE_B,<invitation> x.json:NNN <group_profile>`
|
||||
user B confirms
|
||||
B -> A: establish group connection (B: JOIN, A: LET)
|
||||
B -> Ag: join group - `in SMP confirmation: x.grp.acpt G_MEM_ID_B`
|
||||
A -> group (including B)): announce group member: `MSG: N x.grp.mem.new G_MEM_ID_B,G_MEM_ROLE_B,G_MEM_ID_M,... x.json:NNN <B_profile>`
|
||||
|
||||
In the message `x.grp.mem.new` A sends the sorted list of all members to whom A is connected followed by the new member ID, role and profile. The following introductions will be sent about/to all members A "knows about" (includes members introduced to A and members who accepted group invitation but not connected yet), once they are connected, so it can be a bigger list than sent in `x.grp.mem.new`.
|
||||
|
||||
All members who received `x.grp.mem.new` from A should check the list of connected members and if any connected members that recipients invited to the group are not in this list, they should introduce them to this new member (the last ID, role and profile in `x.grp.mem.new`). That might lead to double introductions that would provide a stronger consistency of group membership at a cost of extra connection between some members that will be unused.
|
||||
|
||||
subsequent messages between A and B are via group connection
|
||||
A -> Bg: intro member - `MSG: x.grp.mem.intro G_MEM_ID_M,G_MEM_ROLE_M x.json:NNN <M_profile>`
|
||||
B -> Ag: inv for mem - `MSG: x.grp.mem.inv G_MEM_ID_M,<gr_invitation>,<dm_invitation>,<probe>`
|
||||
M is an existing member, messages are via group connection
|
||||
A -> Mg: fwd inv - `MSG: x.grp.mem.fwd G_MEM_ID_B,<gr_invitation>,<dm_invitation>,<probe>`
|
||||
M -> Bg: establish group connection (M: JOIN, B: LET)
|
||||
M -> B: establish direct connection (M: JOIN, B: LET)
|
||||
M -> Bg: confirm profile and role - `CONF: x.grp.mem.info G_MEM_ID_M,G_MEM_ROLE x.json:NNN <M_profile>`
|
||||
B -> Mg: send profile probe - `MSG: x.info.probe <probe>` - it should always be send, even when there is no profile match.
|
||||
if M is a known contact (profile match) send probe to M:
|
||||
B -> M (via old DM conn): profile match probe: `MSG: x.info.probe.check <probe_hash>`
|
||||
M -> B (via old DM conn): probe confirm: `MSG: x.info.probe.ok <probe>`
|
||||
link to the same contact
|
||||
B -> Ag: connected to M: `MSG: x.grp.mem.con G_MEM_ID_M`
|
||||
M -> Ag: connected to M: `MSG: x.grp.mem.con G_MEM_ID_B`
|
||||
|
||||
once all members connected
|
||||
A -> group: `MSG: N x.grp.mem.con.all G_MEM_ID_B`
|
||||
|
||||
#### Send group message
|
||||
|
||||
Example:
|
||||
|
||||
`MSG: N x.msg.new c.text x.text:5 hello `
|
||||
|
||||
#### Group member statuses
|
||||
|
||||
1. Me
|
||||
- invited
|
||||
- accepted
|
||||
- connected to member who invited me
|
||||
- announced to group
|
||||
- x.grp.mem.new to group
|
||||
- confirmed as connected to group
|
||||
- this happens once member who invited me sends x.grp.mem.ok to group
|
||||
1. Member that I invited:
|
||||
- invited
|
||||
- accepted
|
||||
- connected to me
|
||||
- announced to group
|
||||
- this happens after x.grp.mem.new but before introductions are sent.
|
||||
This message is used to determine which members should be additionally introduced if they were announced before (or in "parallel").
|
||||
- confirmed as connected to group
|
||||
2. Member who invited me
|
||||
- invited_me
|
||||
- connected to me
|
||||
- I won't know whether this member was announced or confirmed to group - with the correctly functioning clients it must have happened.
|
||||
3. Prior member introduced to me after I joined (x.grp.mem.intro)
|
||||
- introduced
|
||||
- sent invitation
|
||||
- connected
|
||||
- connected directly (or confirmed existing contact)
|
||||
4. Member I was introduced to after that member joined (via x.grp.mem.fwd)
|
||||
- announced via x.grp.mem.new
|
||||
- received invitation
|
||||
- connected
|
||||
- connected directly (or confirmed existing contact)
|
||||
|
||||
#### Introductions
|
||||
|
||||
1. Introductions I sent to members I invited
|
||||
- the time of joining is determined by the time of creating the connection and sending the x.grp.mem.new message to the group.
|
||||
- introductions of the members who were connected before the new member should be sent - how to determine which members were connected before?
|
||||
- use time stamp of creating connection, possibly in the member record - not very reliable, as time can change.
|
||||
- use record ID - requires changing the schema, as currently members are added as invited, not as connected. So possibly invited members should be tracked in a separate table, and all members should still be tracked together to ensure that memberId is unique.
|
||||
- record ID is also not 100% sufficient, as there can be forks in message history and I may need to intro the member I invited to the member that was announced after my member in my chronology, but in another graph branch.
|
||||
- some other mechanism that allows to establish who should be connected to whom and whether I should introduce or another member (in case of forks - although maybe we both can introduce and eventually two group connections will be created between these members and they would just ignore the first one - although in cases of multiple branches in the graph it can be N connections).
|
||||
- introductions/member connection statuses:
|
||||
- created introduction
|
||||
- sent to the member I invited
|
||||
- received the invitation from the member I invited
|
||||
- forwarded this invitation to previously connected member
|
||||
- received confirmation from member I invited
|
||||
- received confirmation from member I forwarded to
|
||||
- completed introduction and recorded that these members are now fully connected to each other
|
||||
2. Introductions I received from the member who invited me
|
||||
- if somebody else sends such introduction - this is an error (can be logged or ignored)
|
||||
- duplicate memberId is an error (e.g. it is a member that was announced in the group broadcast - I should be introduced to this member, and not the other way around? Although it can happen in case of fork and maybe I should establish the connection anyway).
|
||||
- member connection status in this case is just a member status from part 3, so maybe no need to track invitations separately and just put SMPQueueInfo on member record.
|
||||
3. Invitation forwarded to me by any prior member
|
||||
- any admin/owner can add members, so they can forward their queue invitations - I should just check forwarding member permission
|
||||
- duplicate memberId is an error
|
||||
- unannounced memberId is an error - I should have seen member announcement prior to receiving this forwarded invitation. Fork would not happen here as it is the same member that announces and forwards the invitation, so they should be in order.
|
||||
- member connection status in this case is just a member status from part 4, so maybe no need to track invitations separately and just put SMPQueueInfo on member record.
|
||||
Reference in New Issue
Block a user