use shared namespace for usernames, contact names and group names (#76)
* test adding same contact, add display_names table and functions * rename display_name -> full_name * use shared namespace for usernames, contact names and group names
This commit is contained in:
Evgeny Poberezkin
GitHub
parent
e99c4bda1e
commit
e9d931059b
@ -1,7 +1,7 @@
|
||||
CREATE TABLE contact_profiles ( -- remote user profile
|
||||
contact_profile_id INTEGER PRIMARY KEY,
|
||||
contact_ref TEXT NOT NULL, -- contact name set by remote user (not unique), this name must not contain spaces
|
||||
display_name TEXT NOT NULL,
|
||||
display_name TEXT NOT NULL, -- contact name set by remote user (not unique), this name must not contain spaces
|
||||
full_name TEXT NOT NULL,
|
||||
properties TEXT NOT NULL DEFAULT '{}' -- JSON with contact profile properties
|
||||
);
|
||||
|
||||
@ -9,20 +9,35 @@ CREATE TABLE users (
|
||||
user_id INTEGER PRIMARY KEY,
|
||||
contact_id INTEGER NOT NULL UNIQUE REFERENCES contacts ON DELETE CASCADE
|
||||
DEFERRABLE INITIALLY DEFERRED,
|
||||
active_user INTEGER -- 1 for active user
|
||||
local_display_name TEXT NOT NULL UNIQUE,
|
||||
active_user INTEGER NOT NULL DEFAULT 0, -- 1 for active user
|
||||
FOREIGN KEY (user_id, local_display_name)
|
||||
REFERENCES display_names (user_id, local_display_name)
|
||||
ON DELETE RESTRICT
|
||||
DEFERRABLE INITIALLY DEFERRED
|
||||
);
|
||||
|
||||
CREATE TABLE display_names (
|
||||
user_id INTEGER NOT NULL REFERENCES users,
|
||||
local_display_name TEXT NOT NULL,
|
||||
ldn_base TEXT NOT NULL,
|
||||
ldn_suffix INTEGER NOT NULL DEFAULT 0,
|
||||
PRIMARY KEY (user_id, local_display_name) ON CONFLICT FAIL,
|
||||
UNIQUE (user_id, ldn_base, ldn_suffix) ON CONFLICT FAIL
|
||||
) WITHOUT ROWID;
|
||||
|
||||
CREATE TABLE contacts (
|
||||
contact_id INTEGER PRIMARY KEY,
|
||||
contact_profile_id INTEGER UNIQUE REFERENCES contact_profiles, -- NULL if it's an incognito profile
|
||||
local_contact_ref TEXT NOT NULL,
|
||||
lcr_base TEXT NOT NULL,
|
||||
lcr_suffix INTEGER NOT NULL DEFAULT 0,
|
||||
contact_profile_id INTEGER REFERENCES contact_profiles, -- NULL if it's an incognito profile
|
||||
user_id INTEGER NOT NULL REFERENCES users,
|
||||
local_display_name TEXT NOT NULL,
|
||||
is_user INTEGER NOT NULL DEFAULT 0, -- 1 if this contact is a user
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now')),
|
||||
UNIQUE (user_id, local_contact_ref) ON CONFLICT FAIL,
|
||||
UNIQUE (user_id, lcr_base, lcr_suffix) ON CONFLICT FAIL
|
||||
FOREIGN KEY (user_id, local_display_name)
|
||||
REFERENCES display_names (user_id, local_display_name)
|
||||
ON DELETE RESTRICT,
|
||||
UNIQUE (user_id, local_display_name),
|
||||
UNIQUE (user_id, contact_profile_id)
|
||||
);
|
||||
|
||||
CREATE TABLE known_servers(
|
||||
@ -36,20 +51,21 @@ CREATE TABLE known_servers(
|
||||
|
||||
CREATE TABLE group_profiles ( -- shared group profiles
|
||||
group_profile_id INTEGER PRIMARY KEY,
|
||||
group_ref TEXT NOT NULL, -- this name must not contain spaces
|
||||
display_name TEXT NOT NULL,
|
||||
display_name TEXT NOT NULL, -- this name must not contain spaces
|
||||
full_name TEXT NOT NULL,
|
||||
properties TEXT NOT NULL DEFAULT '{}' -- JSON with user or contact profile
|
||||
);
|
||||
|
||||
CREATE TABLE groups (
|
||||
group_id INTEGER PRIMARY KEY, -- local group ID
|
||||
local_group_ref TEXT NOT NULL, -- local group name without spaces
|
||||
lgr_base TEXT NOT NULL,
|
||||
lgr_suffix INTEGER NOT NULL DEFAULT 0,
|
||||
group_profile_id INTEGER REFERENCES group_profiles, -- shared group profile
|
||||
user_id INTEGER NOT NULL REFERENCES users,
|
||||
UNIQUE (user_id, local_group_ref) ON CONFLICT FAIL,
|
||||
UNIQUE (user_id, lgr_base, lgr_suffix) ON CONFLICT FAIL
|
||||
local_display_name TEXT NOT NULL, -- local group name without spaces
|
||||
group_profile_id INTEGER REFERENCES group_profiles, -- shared group profile
|
||||
FOREIGN KEY (user_id, local_display_name)
|
||||
REFERENCES display_names (user_id, local_display_name)
|
||||
ON DELETE RESTRICT,
|
||||
UNIQUE (user_id, local_display_name),
|
||||
UNIQUE (user_id, group_profile_id)
|
||||
);
|
||||
|
||||
CREATE TABLE group_members ( -- group members, excluding the local user
|
||||
|
||||
@ -55,16 +55,16 @@ data ChatCommand
|
||||
| MarkdownHelp
|
||||
| AddContact
|
||||
| Connect SMPQueueInfo
|
||||
| DeleteContact ContactRef
|
||||
| SendMessage ContactRef ByteString
|
||||
| DeleteContact ContactName
|
||||
| SendMessage ContactName ByteString
|
||||
| NewGroup GroupProfile
|
||||
| AddMember GroupRef ContactRef GroupMemberRole
|
||||
| RemoveMember GroupRef ContactRef
|
||||
| MemberRole GroupRef ContactRef GroupMemberRole
|
||||
| LeaveGroup GroupRef
|
||||
| DeleteGroup GroupRef
|
||||
| ListMembers GroupRef
|
||||
| SendGroupMessage GroupRef ByteString
|
||||
| AddMember GroupName ContactName GroupMemberRole
|
||||
| RemoveMember GroupName ContactName
|
||||
| MemberRole GroupName ContactName GroupMemberRole
|
||||
| LeaveGroup GroupName
|
||||
| DeleteGroup GroupName
|
||||
| ListMembers GroupName
|
||||
| SendGroupMessage GroupName ByteString
|
||||
deriving (Show)
|
||||
|
||||
cfg :: AgentConfig
|
||||
@ -195,7 +195,7 @@ processAgentMessage :: forall m. ChatMonad m => User -> ConnId -> ACommand 'Agen
|
||||
processAgentMessage User {userId, profile} agentConnId agentMessage = do
|
||||
chatDirection <- withStore $ \st -> getConnectionChatDirection st userId agentConnId
|
||||
case chatDirection of
|
||||
ReceivedDirectMessage (CContact ct@Contact {localContactRef = c}) ->
|
||||
ReceivedDirectMessage (CContact ct@Contact {localDisplayName = c}) ->
|
||||
case agentMessage of
|
||||
MSG meta msgBody -> do
|
||||
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage msgBody
|
||||
@ -225,7 +225,7 @@ processAgentMessage User {userId, profile} agentConnId agentMessage = do
|
||||
_ -> pure ()
|
||||
_ -> pure ()
|
||||
where
|
||||
newTextMessage :: ContactRef -> MsgMeta -> Maybe MsgBodyContent -> m ()
|
||||
newTextMessage :: ContactName -> MsgMeta -> Maybe MsgBodyContent -> m ()
|
||||
newTextMessage c meta = \case
|
||||
Just MsgBodyContent {contentData = bs} -> do
|
||||
let text = safeDecodeUtf8 bs
|
||||
@ -268,17 +268,17 @@ getCreateActiveUser st = do
|
||||
newUser = do
|
||||
putStrLn
|
||||
"No user profiles found, it will be created now.\n\
|
||||
\Please choose your alias and your profile name.\n\
|
||||
\Please choose your display name and your full name.\n\
|
||||
\They will be sent to your contacts when you connect.\n\
|
||||
\They are only stored on your device and you can change them later."
|
||||
loop
|
||||
where
|
||||
loop = do
|
||||
contactRef <- getContactRef
|
||||
displayName <- T.pack <$> getWithPrompt "profile name (optional)"
|
||||
liftIO (runExceptT $ createUser st Profile {contactRef, displayName} True) >>= \case
|
||||
Left SEDuplicateContactRef -> do
|
||||
putStrLn "chosen alias already used by another profile on this device, choose another one"
|
||||
displayName <- getContactName
|
||||
fullName <- T.pack <$> getWithPrompt "full name (optional)"
|
||||
liftIO (runExceptT $ createUser st Profile {displayName, fullName} True) >>= \case
|
||||
Left SEDuplicateName -> do
|
||||
putStrLn "chosen display name is already used by another profile on this device, choose another one"
|
||||
loop
|
||||
Left e -> putStrLn ("database error " <> show e) >> exitFailure
|
||||
Right user -> pure user
|
||||
@ -302,14 +302,14 @@ getCreateActiveUser st = do
|
||||
liftIO $ setActiveUser st (userId user)
|
||||
pure user
|
||||
userStr :: User -> String
|
||||
userStr User {localContactRef, profile = Profile {displayName}} =
|
||||
T.unpack $ localContactRef <> if T.null displayName then "" else " (" <> displayName <> ")"
|
||||
getContactRef :: IO ContactRef
|
||||
getContactRef = do
|
||||
contactRef <- getWithPrompt "alias (no spaces)"
|
||||
if null contactRef || isJust (find (== ' ') contactRef)
|
||||
then putStrLn "alias has space(s), choose another one" >> getContactRef
|
||||
else pure $ T.pack contactRef
|
||||
userStr User {localDisplayName, profile = Profile {fullName}} =
|
||||
T.unpack $ localDisplayName <> if T.null fullName then "" else " (" <> fullName <> ")"
|
||||
getContactName :: IO ContactName
|
||||
getContactName = do
|
||||
displayName <- getWithPrompt "display name (no spaces)"
|
||||
if null displayName || isJust (find (== ' ') displayName)
|
||||
then putStrLn "display name has space(s), choose another one" >> getContactName
|
||||
else pure $ T.pack displayName
|
||||
getWithPrompt :: String -> IO String
|
||||
getWithPrompt s = putStr (s <> ": ") >> hFlush stdout >> getLine
|
||||
|
||||
@ -340,24 +340,23 @@ chatCommandP :: Parser ChatCommand
|
||||
chatCommandP =
|
||||
("/help" <|> "/h") $> ChatHelp
|
||||
<|> ("/group #" <|> "/g #") *> (NewGroup <$> groupProfile)
|
||||
<|> ("/add #" <|> "/a #") *> (AddMember <$> groupRef <* A.space <*> contactRef <*> memberRole)
|
||||
<|> ("/remove #" <|> "/rm #") *> (RemoveMember <$> groupRef <* A.space <*> contactRef)
|
||||
<|> ("/delete #" <|> "/d #") *> (DeleteGroup <$> groupRef)
|
||||
<|> ("/members #" <|> "/ms #") *> (ListMembers <$> groupRef)
|
||||
<|> A.char '#' *> (SendGroupMessage <$> groupRef <* A.space <*> A.takeByteString)
|
||||
<|> ("/add #" <|> "/a #") *> (AddMember <$> displayName <* A.space <*> displayName <*> memberRole)
|
||||
<|> ("/remove #" <|> "/rm #") *> (RemoveMember <$> displayName <* A.space <*> displayName)
|
||||
<|> ("/delete #" <|> "/d #") *> (DeleteGroup <$> displayName)
|
||||
<|> ("/members #" <|> "/ms #") *> (ListMembers <$> displayName)
|
||||
<|> A.char '#' *> (SendGroupMessage <$> displayName <* A.space <*> A.takeByteString)
|
||||
<|> ("/add" <|> "/a") $> AddContact
|
||||
<|> ("/connect " <|> "/c ") *> (Connect <$> smpQueueInfoP)
|
||||
<|> ("/delete @" <|> "/delete " <|> "/d @" <|> "/d ") *> (DeleteContact <$> contactRef)
|
||||
<|> A.char '@' *> (SendMessage <$> contactRef <*> (A.space *> A.takeByteString))
|
||||
<|> ("/delete @" <|> "/delete " <|> "/d @" <|> "/d ") *> (DeleteContact <$> displayName)
|
||||
<|> A.char '@' *> (SendMessage <$> displayName <*> (A.space *> A.takeByteString))
|
||||
<|> ("/markdown" <|> "/m") $> MarkdownHelp
|
||||
where
|
||||
contactRef = safeDecodeUtf8 <$> (B.cons <$> A.satisfy refChar <*> A.takeTill (== ' '))
|
||||
displayName = safeDecodeUtf8 <$> (B.cons <$> A.satisfy refChar <*> A.takeTill (== ' '))
|
||||
refChar c = c > ' ' && c /= '#' && c /= '@'
|
||||
groupRef = contactRef
|
||||
groupProfile = do
|
||||
gRef <- groupRef
|
||||
gRef <- displayName
|
||||
gName <- safeDecodeUtf8 <$> (A.space *> A.takeByteString) <|> pure ""
|
||||
pure GroupProfile {groupRef = gRef, displayName = if T.null gName then gRef else gName}
|
||||
pure GroupProfile {displayName = gRef, fullName = if T.null gName then gRef else gName}
|
||||
memberRole =
|
||||
(" owner" $> GROwner)
|
||||
<|> (" admin" $> GRAdmin)
|
||||
|
||||
@ -1,44 +0,0 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
module Simplex.Chat.Protocol_ where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Text (Text)
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId)
|
||||
|
||||
data ChatEvent = GroupEvent | MessageEvent | InfoEvent
|
||||
|
||||
data Profile = Profile
|
||||
{ profileId :: ByteString,
|
||||
displayName :: Text
|
||||
}
|
||||
|
||||
data Contact = Contact
|
||||
{ contactId :: ByteString,
|
||||
profile :: Profile,
|
||||
connections :: [Connection]
|
||||
}
|
||||
|
||||
data Connection = Connection
|
||||
{ connId :: ConnId,
|
||||
connLevel :: Int,
|
||||
viaConn :: ConnId
|
||||
}
|
||||
|
||||
data GroupMember = GroupMember
|
||||
{ groupId :: ByteString,
|
||||
sharedMemberId :: ByteString,
|
||||
contact :: Contact,
|
||||
memberRole :: GroupMemberRole,
|
||||
memberStatus :: GroupMemberStatus
|
||||
}
|
||||
|
||||
data GroupMemberRole = GROwner | GRAdmin | GRStandard
|
||||
|
||||
data GroupMemberStatus = GSInvited | GSConnected | GSConnectedAll
|
||||
|
||||
data Group = Group
|
||||
{ groupId :: ByteString,
|
||||
displayName :: Text,
|
||||
members :: [GroupMember]
|
||||
}
|
||||
@ -8,6 +8,7 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Simplex.Chat.Store
|
||||
@ -83,19 +84,17 @@ insertedRowId :: DB.Connection -> IO Int64
|
||||
insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()"
|
||||
|
||||
createUser :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> Profile -> Bool -> m User
|
||||
createUser st Profile {contactRef, displayName} activeUser =
|
||||
liftIOEither . checkConstraint SEDuplicateContactRef . withTransaction st $ \db -> do
|
||||
DB.execute db "INSERT INTO contact_profiles (contact_ref, display_name) VALUES (?, ?)" (contactRef, displayName)
|
||||
profileId <- insertedRowId db
|
||||
DB.execute db "INSERT INTO users (contact_id, active_user) VALUES (0, ?)" (Only activeUser)
|
||||
createUser st Profile {displayName, fullName} activeUser =
|
||||
liftIOEither . checkConstraint SEDuplicateName . withTransaction st $ \db -> do
|
||||
DB.execute db "INSERT INTO users (local_display_name, active_user, contact_id) VALUES (?, ?, 0)" (displayName, activeUser)
|
||||
userId <- insertedRowId db
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO contacts (contact_profile_id, local_contact_ref, lcr_base, user_id, is_user) VALUES (?, ?, ?, ?, ?)"
|
||||
(profileId, contactRef, contactRef, userId, True)
|
||||
DB.execute db "INSERT INTO display_names (local_display_name, ldn_base, user_id) VALUES (?, ?, ?)" (displayName, displayName, userId)
|
||||
DB.execute db "INSERT INTO contact_profiles (display_name, full_name) VALUES (?, ?)" (displayName, fullName)
|
||||
profileId <- insertedRowId db
|
||||
DB.execute db "INSERT INTO contacts (contact_profile_id, local_display_name, user_id, is_user) VALUES (?, ?, ?, ?)" (profileId, displayName, userId, True)
|
||||
contactId <- insertedRowId db
|
||||
DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId)
|
||||
pure . Right $ toUser (userId, contactId, activeUser, contactRef, displayName)
|
||||
pure . Right $ toUser (userId, contactId, activeUser, displayName, fullName)
|
||||
|
||||
getUsers :: SQLiteStore -> IO [User]
|
||||
getUsers st =
|
||||
@ -104,16 +103,16 @@ getUsers st =
|
||||
<$> DB.query_
|
||||
db
|
||||
[sql|
|
||||
SELECT u.user_id, u.contact_id, u.active_user, c.local_contact_ref, p.display_name
|
||||
SELECT u.user_id, u.contact_id, u.active_user, u.local_display_name, p.full_name
|
||||
FROM users u
|
||||
JOIN contacts c ON u.contact_id = c.contact_id
|
||||
JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id
|
||||
|]
|
||||
|
||||
toUser :: (UserId, Int64, Bool, ContactRef, Text) -> User
|
||||
toUser (userId, userContactId, activeUser, contactRef, displayName) =
|
||||
let profile = Profile {contactRef, displayName}
|
||||
in User {userId, userContactId, localContactRef = contactRef, profile, activeUser}
|
||||
toUser :: (UserId, Int64, Bool, ContactName, Text) -> User
|
||||
toUser (userId, userContactId, activeUser, displayName, fullName) =
|
||||
let profile = Profile {displayName, fullName}
|
||||
in User {userId, userContactId, localDisplayName = displayName, profile, activeUser}
|
||||
|
||||
setActiveUser :: MonadUnliftIO m => SQLiteStore -> UserId -> m ()
|
||||
setActiveUser st userId = do
|
||||
@ -134,51 +133,17 @@ createDirectConnection st userId agentConnId =
|
||||
|
||||
createDirectContact ::
|
||||
(MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> Connection -> Profile -> m ()
|
||||
createDirectContact st userId Connection {connId} Profile {contactRef, displayName} =
|
||||
liftIOEither . withTransaction st $ \db -> do
|
||||
DB.execute db "INSERT INTO contact_profiles (contact_ref, display_name) VALUES (?, ?)" (contactRef, displayName)
|
||||
profileId <- insertedRowId db
|
||||
lcrSuffix <- getLcrSuffix db
|
||||
create db profileId lcrSuffix 20
|
||||
where
|
||||
getLcrSuffix :: DB.Connection -> IO Int
|
||||
getLcrSuffix db =
|
||||
maybe 0 ((+ 1) . fromOnly) . listToMaybe
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
SELECT lcr_suffix FROM contacts
|
||||
WHERE user_id = :user_id AND lcr_base = :contact_ref
|
||||
ORDER BY lcr_suffix DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
[":user_id" := userId, ":contact_ref" := contactRef]
|
||||
create :: DB.Connection -> Int64 -> Int -> Int -> IO (Either StoreError ())
|
||||
create _ _ _ 0 = pure $ Left SEDuplicateContactRef
|
||||
create db profileId lcrSuffix attempts = do
|
||||
let lcr = localContactRef' lcrSuffix
|
||||
E.try (insertUser lcr) >>= \case
|
||||
Right () -> do
|
||||
contactId <- insertedRowId db
|
||||
DB.execute db "UPDATE connections SET contact_id = ? WHERE connection_id = ?" (contactId, connId)
|
||||
pure $ Right ()
|
||||
Left e
|
||||
| DB.sqlError e == DB.ErrorConstraint -> create db profileId (lcrSuffix + 1) (attempts - 1)
|
||||
| otherwise -> E.throwIO e
|
||||
where
|
||||
localContactRef' 0 = contactRef
|
||||
localContactRef' n = contactRef <> T.pack ('_' : show n)
|
||||
insertUser lcr =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO contacts
|
||||
(contact_profile_id, local_contact_ref, lcr_base, lcr_suffix, user_id) VALUES (?, ?, ?, ?, ?)
|
||||
|]
|
||||
(profileId, lcr, contactRef, lcrSuffix, userId)
|
||||
createDirectContact st userId Connection {connId} Profile {displayName, fullName} =
|
||||
liftIOEither . withTransaction st $ \db ->
|
||||
withLocalDisplayName db userId displayName $ \localDisplayName' -> do
|
||||
DB.execute db "INSERT INTO contact_profiles (display_name, full_name) VALUES (?, ?)" (displayName, fullName)
|
||||
profileId <- insertedRowId db
|
||||
DB.execute db "INSERT INTO contacts (contact_profile_id, local_display_name, user_id) VALUES (?, ?, ?)" (profileId, localDisplayName', userId)
|
||||
contactId <- insertedRowId db
|
||||
DB.execute db "UPDATE connections SET contact_id = ? WHERE connection_id = ?" (contactId, connId)
|
||||
|
||||
deleteContact :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactRef -> m ()
|
||||
deleteContact st userId contactRef =
|
||||
deleteContact :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactName -> m ()
|
||||
deleteContact st userId displayName =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
DB.executeNamed
|
||||
db
|
||||
@ -187,23 +152,30 @@ deleteContact st userId contactRef =
|
||||
SELECT connection_id
|
||||
FROM connections c
|
||||
JOIN contacts cs ON c.contact_id = cs.contact_id
|
||||
WHERE cs.user_id = :user_id AND cs.local_contact_ref = :contact_ref
|
||||
WHERE cs.user_id = :user_id AND cs.local_display_name = :display_name
|
||||
)
|
||||
|]
|
||||
[":user_id" := userId, ":contact_ref" := contactRef]
|
||||
[":user_id" := userId, ":display_name" := displayName]
|
||||
DB.executeNamed
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM contacts
|
||||
WHERE user_id = :user_id AND local_contact_ref = :contact_ref
|
||||
WHERE user_id = :user_id AND local_display_name = :display_name
|
||||
|]
|
||||
[":user_id" := userId, ":contact_ref" := contactRef]
|
||||
[":user_id" := userId, ":display_name" := displayName]
|
||||
DB.executeNamed
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM display_names
|
||||
WHERE user_id = :user_id AND local_display_name = :display_name
|
||||
|]
|
||||
[":user_id" := userId, ":display_name" := displayName]
|
||||
|
||||
-- TODO return the last connection that is ready, not any last connection
|
||||
-- requires updating connection status
|
||||
getContact ::
|
||||
(MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ContactRef -> m Contact
|
||||
getContact st userId localContactRef =
|
||||
(MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ContactName -> m Contact
|
||||
getContact st userId localDisplayName =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
||||
c@Contact {contactId} <- getContact_ db
|
||||
activeConn <- getConnection_ db contactId
|
||||
@ -214,12 +186,12 @@ getContact st userId localContactRef =
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
SELECT c.contact_id, p.contact_ref, p.display_name
|
||||
SELECT c.contact_id, p.display_name, p.full_name
|
||||
FROM contacts c
|
||||
JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id
|
||||
WHERE c.user_id = :user_id AND c.local_contact_ref = :local_contact_ref AND c.is_user = :is_user
|
||||
WHERE c.user_id = :user_id AND c.local_display_name = :local_display_name AND c.is_user = :is_user
|
||||
|]
|
||||
[":user_id" := userId, ":local_contact_ref" := localContactRef, ":is_user" := False]
|
||||
[":user_id" := userId, ":local_display_name" := localDisplayName, ":is_user" := False]
|
||||
getConnection_ db contactId = ExceptT $ do
|
||||
connection
|
||||
<$> DB.queryNamed
|
||||
@ -233,15 +205,15 @@ getContact st userId localContactRef =
|
||||
LIMIT 1
|
||||
|]
|
||||
[":user_id" := userId, ":contact_id" := contactId]
|
||||
toContact [(contactId, contactRef, displayName)] =
|
||||
let profile = Profile {contactRef, displayName}
|
||||
in Right Contact {contactId, localContactRef, profile, activeConn = undefined}
|
||||
toContact _ = Left $ SEContactNotFound localContactRef
|
||||
toContact [(contactId, displayName, fullName)] =
|
||||
let profile = Profile {displayName, fullName}
|
||||
in Right Contact {contactId, localDisplayName, profile, activeConn = undefined}
|
||||
toContact _ = Left $ SEContactNotFound localDisplayName
|
||||
connection (connRow : _) = Right $ toConnection connRow
|
||||
connection _ = Left $ SEContactNotReady localContactRef
|
||||
connection _ = Left $ SEContactNotReady localDisplayName
|
||||
|
||||
getContactConnections :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ContactRef -> m [Connection]
|
||||
getContactConnections st userId contactRef =
|
||||
getContactConnections :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ContactName -> m [Connection]
|
||||
getContactConnections st userId displayName =
|
||||
liftIOEither . withTransaction st $ \db ->
|
||||
connections
|
||||
<$> DB.queryNamed
|
||||
@ -253,11 +225,11 @@ getContactConnections st userId contactRef =
|
||||
JOIN contacts cs ON c.contact_id == cs.contact_id
|
||||
WHERE c.user_id = :user_id
|
||||
AND cs.user_id = :user_id
|
||||
AND cs.local_contact_ref == :contact_ref
|
||||
AND cs.local_display_name == :display_name
|
||||
|]
|
||||
[":user_id" := userId, ":contact_ref" := contactRef]
|
||||
[":user_id" := userId, ":display_name" := displayName]
|
||||
where
|
||||
connections [] = Left $ SEContactNotFound contactRef
|
||||
connections [] = Left $ SEContactNotFound displayName
|
||||
connections rows = Right $ map toConnection rows
|
||||
|
||||
type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, ConnStatus, ConnType, Maybe Int64, Maybe Int64, UTCTime)
|
||||
@ -302,27 +274,26 @@ getConnectionChatDirection st userId agentConnId =
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT c.local_contact_ref, p.contact_ref, p.display_name
|
||||
SELECT c.local_display_name, p.display_name, p.full_name
|
||||
FROM contacts c
|
||||
JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id
|
||||
WHERE c.user_id = ? AND c.contact_id = ?
|
||||
|]
|
||||
(userId, contactId)
|
||||
toContact contactId c [(localContactRef, contactRef, displayName)] =
|
||||
let profile = Profile {contactRef, displayName}
|
||||
in Right $ CContact Contact {contactId, localContactRef, profile, activeConn = c}
|
||||
toContact contactId c [(localDisplayName, displayName, fullName)] =
|
||||
let profile = Profile {displayName, fullName}
|
||||
in Right $ CContact Contact {contactId, localDisplayName, profile, activeConn = c}
|
||||
toContact _ _ _ = Left $ SEInternal "referenced contact not found"
|
||||
|
||||
-- | creates completely new group with a single member - the current user
|
||||
createNewGroup :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> TVar ChaChaDRG -> User -> GroupProfile -> m Group
|
||||
createNewGroup st gVar User {userId, userContactId, profile} p@GroupProfile {groupRef, displayName} =
|
||||
liftIOEither . checkConstraint SEDuplicateGroupRef . withTransaction st $ \db -> do
|
||||
-- group inserted before profile to ensure its local_group_ref is unique
|
||||
DB.execute db "INSERT INTO groups (local_group_ref, lgr_base, user_id) VALUES (?, ?, ?)" (groupRef, groupRef, userId)
|
||||
groupId <- insertedRowId db
|
||||
DB.execute db "INSERT INTO group_profiles (group_ref, display_name) VALUES (?, ?)" (groupRef, displayName)
|
||||
createNewGroup st gVar User {userId, userContactId, profile} p@GroupProfile {displayName, fullName} =
|
||||
liftIOEither . checkConstraint SEDuplicateName . withTransaction st $ \db -> do
|
||||
DB.execute db "INSERT INTO display_names (local_display_name, ldn_base, user_id) VALUES (?, ?, ?)" (displayName, displayName, userId)
|
||||
DB.execute db "INSERT INTO group_profiles (display_name, full_name) VALUES (?, ?)" (displayName, fullName)
|
||||
profileId <- insertedRowId db
|
||||
DB.execute db "UPDATE groups SET group_profile_id = ? WHERE group_id = ?" (profileId, groupId)
|
||||
DB.execute db "INSERT INTO groups (local_display_name, user_id, group_profile_id) VALUES (?, ?, ?)" (displayName, userId, profileId)
|
||||
groupId <- insertedRowId db
|
||||
memberId <- randomId gVar 12
|
||||
createMember_ db groupId userContactId GROwner GSMemReady (Just userContactId) memberId
|
||||
groupMemberId <- insertedRowId db
|
||||
@ -336,71 +307,44 @@ createNewGroup st gVar User {userId, userContactId, profile} p@GroupProfile {gro
|
||||
memberProfile = profile,
|
||||
memberContactId = Just userContactId
|
||||
}
|
||||
pure $ Right Group {groupId, localGroupRef = groupRef, groupProfile = p, members = [], membership}
|
||||
pure $ Right Group {groupId, localDisplayName = displayName, groupProfile = p, members = [], membership}
|
||||
|
||||
-- | creates a new group record for the group the current user was invited to
|
||||
createGroup :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> TVar ChaChaDRG -> User -> Contact -> GroupProfile -> m Group
|
||||
createGroup st gVar User {userId, userContactId, profile} contact p@GroupProfile {groupRef, displayName} =
|
||||
liftIOEither . withTransaction st $ \db -> do
|
||||
DB.execute db "INSERT INTO group_profiles (group_ref, display_name) VALUES (?, ?)" (groupRef, displayName)
|
||||
profileId <- insertedRowId db
|
||||
lgrSuffix <- getLgrSuffix db
|
||||
group <- create db profileId lgrSuffix 20
|
||||
pure group
|
||||
where
|
||||
-- createMember_ db groupId userContactId GROwner GSMemReady (Just userContactId) memberId
|
||||
-- groupMemberId <- insertedRowId db
|
||||
-- let membership =
|
||||
-- GroupMember
|
||||
-- { groupMemberId,
|
||||
-- memberId,
|
||||
-- memberRole = GROwner,
|
||||
-- memberStatus = GSMemReady,
|
||||
-- invitedBy = IBUser,
|
||||
-- memberProfile = profile,
|
||||
-- memberContactId = Just userContactId
|
||||
-- }
|
||||
-- pure $ Right Group {groupId, localGroupRef = groupRef, groupProfile = p, members = [], membership}
|
||||
createGroup st gVar User {userId, userContactId, profile} contact p@GroupProfile {displayName, fullName} =
|
||||
liftIOEither . withTransaction st $ \db ->
|
||||
withLocalDisplayName db userId displayName $ \localDisplayName -> do
|
||||
DB.execute db "INSERT INTO group_profiles (display_name, full_name) VALUES (?, ?)" (displayName, fullName)
|
||||
profileId <- insertedRowId db
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO groups
|
||||
(group_profile_id, local_display_name, user_id) VALUES (?, ?, ?)
|
||||
|]
|
||||
(profileId, localDisplayName, userId)
|
||||
groupId <- insertedRowId db
|
||||
pure Group {groupId, localDisplayName, groupProfile = p, members = undefined, membership = undefined}
|
||||
|
||||
getLgrSuffix :: DB.Connection -> IO Int
|
||||
getLgrSuffix db =
|
||||
maybe 0 ((+ 1) . fromOnly) . listToMaybe
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
SELECT lgr_suffix FROM groups
|
||||
WHERE user_id = :user_id AND lgr_base = :group_ref
|
||||
ORDER BY lgr_suffix DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
[":user_id" := userId, ":group_ref" := groupRef]
|
||||
create :: DB.Connection -> Int64 -> Int -> Int -> IO (Either StoreError Group)
|
||||
create _ _ _ 0 = pure $ Left SEDuplicateGroupRef
|
||||
create db profileId lgrSuffix attempts = do
|
||||
let lgr = localGroupRef' lgrSuffix
|
||||
E.try (insertGroup lgr) >>= \case
|
||||
Right () -> do
|
||||
groupId <- insertedRowId db
|
||||
pure $ Right Group {groupId, localGroupRef = lgr, groupProfile = p, members = undefined, membership = undefined}
|
||||
Left e
|
||||
| DB.sqlError e == DB.ErrorConstraint -> create db profileId (lgrSuffix + 1) (attempts - 1)
|
||||
| otherwise -> E.throwIO e
|
||||
where
|
||||
localGroupRef' 0 = groupRef
|
||||
localGroupRef' n = groupRef <> T.pack ('_' : show n)
|
||||
insertGroup lgr =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO groups
|
||||
(group_profile_id, local_group_ref, lgr_base, lgr_suffix, user_id) VALUES (?, ?, ?, ?, ?)
|
||||
|]
|
||||
(profileId, lgr, groupRef, lgrSuffix, userId)
|
||||
-- where
|
||||
-- createMember_ db groupId userContactId GROwner GSMemReady (Just userContactId) memberId
|
||||
-- groupMemberId <- insertedRowId db
|
||||
-- let membership =
|
||||
-- GroupMember
|
||||
-- { groupMemberId,
|
||||
-- memberId,
|
||||
-- memberRole = GROwner,
|
||||
-- memberStatus = GSMemReady,
|
||||
-- invitedBy = IBUser,
|
||||
-- memberProfile = profile,
|
||||
-- memberContactId = Just userContactId
|
||||
-- }
|
||||
-- pure $ Right Group {groupId, localDisplayName = displayName, groupProfile = p, members = [], membership}
|
||||
|
||||
-- TODO return the last connection that is ready, not any last connection
|
||||
-- requires updating connection status
|
||||
getGroup :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> User -> GroupRef -> m Group
|
||||
getGroup st User {userId, userContactId} localGroupRef =
|
||||
getGroup :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> User -> GroupName -> m Group
|
||||
getGroup st User {userId, userContactId} localDisplayName =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
||||
g@Group {groupId} <- getGroup_ db
|
||||
members <- getMembers_ db groupId
|
||||
@ -413,17 +357,17 @@ getGroup st User {userId, userContactId} localGroupRef =
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT g.group_id, p.group_ref, p.display_name
|
||||
SELECT g.group_id, p.display_name, p.full_name
|
||||
FROM groups g
|
||||
JOIN group_profiles p ON p.group_profile_id = g.group_profile_id
|
||||
WHERE g.local_group_ref = ? AND g.user_id = ?
|
||||
WHERE g.local_display_name = ? AND g.user_id = ?
|
||||
|]
|
||||
(localGroupRef, userId)
|
||||
toGroup :: [(Int64, GroupRef, Text)] -> Either StoreError Group
|
||||
toGroup [(groupId, groupRef, displayName)] =
|
||||
let groupProfile = GroupProfile {groupRef, displayName}
|
||||
in Right Group {groupId, localGroupRef, groupProfile, members = undefined, membership = undefined}
|
||||
toGroup _ = Left $ SEGroupNotFound localGroupRef
|
||||
(localDisplayName, userId)
|
||||
toGroup :: [(Int64, GroupName, Text)] -> Either StoreError Group
|
||||
toGroup [(groupId, displayName, fullName)] =
|
||||
let groupProfile = GroupProfile {displayName, fullName}
|
||||
in Right Group {groupId, localDisplayName, groupProfile, members = undefined, membership = undefined}
|
||||
toGroup _ = Left $ SEGroupNotFound localDisplayName
|
||||
getMembers_ :: DB.Connection -> Int64 -> ExceptT StoreError IO [(GroupMember, Connection)]
|
||||
getMembers_ db groupId = ExceptT $ do
|
||||
Right . map toContactMember
|
||||
@ -432,7 +376,7 @@ getGroup st User {userId, userContactId} localGroupRef =
|
||||
[sql|
|
||||
SELECT
|
||||
m.group_member_id, m.member_id, m.member_role, m.member_status,
|
||||
m.invited_by, m.contact_id, p.contact_ref, p.display_name,
|
||||
m.invited_by, m.contact_id, p.display_name, p.full_name,
|
||||
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.created_at
|
||||
FROM group_members m
|
||||
@ -452,7 +396,7 @@ getGroup st User {userId, userContactId} localGroupRef =
|
||||
[sql|
|
||||
SELECT
|
||||
m.group_member_id, m.member_id, m.member_role, m.member_status,
|
||||
m.invited_by, m.contact_id, p.contact_ref, p.display_name
|
||||
m.invited_by, m.contact_id, p.display_name, p.full_name
|
||||
FROM group_members m
|
||||
JOIN groups g ON g.group_id = m.group_id
|
||||
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
|
||||
@ -462,15 +406,15 @@ getGroup st User {userId, userContactId} localGroupRef =
|
||||
toContactMember :: (GroupMemberRow :. ConnectionRow) -> (GroupMember, Connection)
|
||||
toContactMember (memberRow :. connRow) = (toGroupMember memberRow, toConnection connRow)
|
||||
toGroupMember :: GroupMemberRow -> GroupMember
|
||||
toGroupMember (groupMemberId, memberId, memberRole, memberStatus, invitedById, memberContactId, contactRef, displayName) =
|
||||
let memberProfile = Profile {contactRef, displayName}
|
||||
toGroupMember (groupMemberId, memberId, memberRole, memberStatus, invitedById, memberContactId, displayName, fullName) =
|
||||
let memberProfile = Profile {displayName, fullName}
|
||||
invitedBy = toInvitedBy userContactId invitedById
|
||||
in GroupMember {groupMemberId, memberId, memberRole, memberStatus, invitedBy, memberProfile, memberContactId}
|
||||
userMember :: [GroupMemberRow] -> Either StoreError GroupMember
|
||||
userMember [memberRow] = Right $ toGroupMember memberRow
|
||||
userMember _ = Left SEGroupWithoutUser
|
||||
|
||||
type GroupMemberRow = (Int64, ByteString, GroupMemberRole, GroupMemberStatus, Maybe Int64, Maybe Int64, ContactRef, Text)
|
||||
type GroupMemberRow = (Int64, ByteString, GroupMemberRole, GroupMemberStatus, Maybe Int64, Maybe Int64, ContactName, Text)
|
||||
|
||||
createGroupMember :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> TVar ChaChaDRG -> User -> Int64 -> Int64 -> GroupMemberRole -> InvitedBy -> ConnId -> m MemberId
|
||||
createGroupMember st gVar User {userId, userContactId} groupId contactId memberRole invitedBy agentConnId =
|
||||
@ -512,6 +456,42 @@ createMember_ db groupId contactId memberRole memberStatus invitedBy memberId =
|
||||
":contact_id" := contactId
|
||||
]
|
||||
|
||||
-- | Saves unique local display name based on passed displayName, suffixed with _N if required.
|
||||
-- This function should be called inside transaction.
|
||||
withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO a) -> IO (Either StoreError a)
|
||||
withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreateName` 20)
|
||||
where
|
||||
getLdnSuffix :: IO Int
|
||||
getLdnSuffix =
|
||||
maybe 0 ((+ 1) . fromOnly) . listToMaybe
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
SELECT ldn_suffix FROM display_names
|
||||
WHERE user_id = :user_id AND ldn_base = :display_name
|
||||
ORDER BY ldn_suffix DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
[":user_id" := userId, ":display_name" := displayName]
|
||||
tryCreateName :: Int -> Int -> IO (Either StoreError a)
|
||||
tryCreateName _ 0 = pure $ Left SEDuplicateName
|
||||
tryCreateName ldnSuffix attempts = do
|
||||
let ldn = displayName <> (if ldnSuffix == 0 then "" else T.pack $ '_' : show ldnSuffix)
|
||||
E.try (insertName ldn) >>= \case
|
||||
Right () -> Right <$> action ldn
|
||||
Left e
|
||||
| DB.sqlError e == DB.ErrorConstraint -> tryCreateName (ldnSuffix + 1) (attempts - 1)
|
||||
| otherwise -> E.throwIO e
|
||||
where
|
||||
insertName ldn =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO display_names
|
||||
(local_display_name, ldn_base, ldn_suffix, user_id) VALUES (?, ?, ?, ?)
|
||||
|]
|
||||
(ldn, displayName, ldnSuffix, userId)
|
||||
|
||||
createWithRandomId :: TVar ChaChaDRG -> (ByteString -> IO ()) -> IO (Either StoreError ByteString)
|
||||
createWithRandomId gVar create = tryCreate 3
|
||||
where
|
||||
@ -529,11 +509,10 @@ randomId :: TVar ChaChaDRG -> Int -> IO ByteString
|
||||
randomId gVar n = B64.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n)
|
||||
|
||||
data StoreError
|
||||
= SEDuplicateContactRef
|
||||
| SEContactNotFound ContactRef
|
||||
| SEContactNotReady ContactRef
|
||||
| SEDuplicateGroupRef
|
||||
| SEGroupNotFound GroupRef
|
||||
= SEDuplicateName
|
||||
| SEContactNotFound ContactName
|
||||
| SEContactNotReady ContactName
|
||||
| SEGroupNotFound GroupName
|
||||
| SEGroupWithoutUser
|
||||
| SEDuplicateGroupMember
|
||||
| SEConnectionNotFound ConnId
|
||||
|
||||
@ -15,7 +15,7 @@ import System.Terminal
|
||||
import System.Terminal.Internal (LocalTerminal, Terminal, VirtualTerminal)
|
||||
import UnliftIO.STM
|
||||
|
||||
data ActiveTo = ActiveNone | ActiveC ContactRef
|
||||
data ActiveTo = ActiveNone | ActiveC ContactName
|
||||
deriving (Eq)
|
||||
|
||||
data ChatTerminal = ChatTerminal
|
||||
|
||||
@ -26,7 +26,7 @@ import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
|
||||
data User = User
|
||||
{ userId :: UserId,
|
||||
userContactId :: Int64,
|
||||
localContactRef :: ContactRef,
|
||||
localDisplayName :: ContactName,
|
||||
profile :: Profile,
|
||||
activeUser :: Bool
|
||||
}
|
||||
@ -35,7 +35,7 @@ type UserId = Int64
|
||||
|
||||
data Contact = Contact
|
||||
{ contactId :: Int64,
|
||||
localContactRef :: ContactRef,
|
||||
localDisplayName :: ContactName,
|
||||
profile :: Profile,
|
||||
activeConn :: Connection
|
||||
}
|
||||
@ -44,13 +44,13 @@ data Contact = Contact
|
||||
contactConnId :: Contact -> ConnId
|
||||
contactConnId Contact {activeConn = Connection {agentConnId}} = agentConnId
|
||||
|
||||
type ContactRef = Text
|
||||
type ContactName = Text
|
||||
|
||||
type GroupRef = Text
|
||||
type GroupName = Text
|
||||
|
||||
data Group = Group
|
||||
{ groupId :: Int64,
|
||||
localGroupRef :: Text,
|
||||
localDisplayName :: GroupName,
|
||||
groupProfile :: GroupProfile,
|
||||
members :: [(GroupMember, Connection)],
|
||||
membership :: GroupMember
|
||||
@ -58,8 +58,8 @@ data Group = Group
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Profile = Profile
|
||||
{ contactRef :: ContactRef,
|
||||
displayName :: Text
|
||||
{ displayName :: ContactName,
|
||||
fullName :: Text
|
||||
}
|
||||
deriving (Generic, Eq, Show)
|
||||
|
||||
@ -68,8 +68,8 @@ instance ToJSON Profile where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
instance FromJSON Profile
|
||||
|
||||
data GroupProfile = GroupProfile
|
||||
{ groupRef :: GroupRef,
|
||||
displayName :: Text
|
||||
{ displayName :: GroupName,
|
||||
fullName :: Text
|
||||
}
|
||||
deriving (Generic, Eq, Show)
|
||||
|
||||
|
||||
@ -45,19 +45,19 @@ showInvitation = printToView . invitation
|
||||
showChatError :: ChatReader m => ChatError -> m ()
|
||||
showChatError = printToView . chatError
|
||||
|
||||
showContactDeleted :: ChatReader m => ContactRef -> m ()
|
||||
showContactDeleted :: ChatReader m => ContactName -> m ()
|
||||
showContactDeleted = printToView . contactDeleted
|
||||
|
||||
showContactConnected :: ChatReader m => ContactRef -> m ()
|
||||
showContactConnected :: ChatReader m => ContactName -> m ()
|
||||
showContactConnected = printToView . contactConnected
|
||||
|
||||
showContactDisconnected :: ChatReader m => ContactRef -> m ()
|
||||
showContactDisconnected :: ChatReader m => ContactName -> m ()
|
||||
showContactDisconnected = printToView . contactDisconnected
|
||||
|
||||
showReceivedMessage :: ChatReader m => ContactRef -> UTCTime -> Text -> MsgIntegrity -> m ()
|
||||
showReceivedMessage :: ChatReader m => ContactName -> UTCTime -> Text -> MsgIntegrity -> m ()
|
||||
showReceivedMessage c utcTime msg mOk = printToView =<< liftIO (receivedMessage c utcTime msg mOk)
|
||||
|
||||
showSentMessage :: ChatReader m => ContactRef -> ByteString -> m ()
|
||||
showSentMessage :: ChatReader m => ContactName -> ByteString -> m ()
|
||||
showSentMessage c msg = printToView =<< liftIO (sentMessage c msg)
|
||||
|
||||
showGroupCreated :: ChatReader m => GroupProfile -> m ()
|
||||
@ -72,19 +72,19 @@ invitation qInfo =
|
||||
"and ask them to connect: /c <name_for_you> <invitation_above>"
|
||||
]
|
||||
|
||||
contactDeleted :: ContactRef -> [StyledString]
|
||||
contactDeleted :: ContactName -> [StyledString]
|
||||
contactDeleted c = [ttyContact c <> " is deleted"]
|
||||
|
||||
contactConnected :: ContactRef -> [StyledString]
|
||||
contactConnected :: ContactName -> [StyledString]
|
||||
contactConnected c = [ttyContact c <> " is connected"]
|
||||
|
||||
contactDisconnected :: ContactRef -> [StyledString]
|
||||
contactDisconnected :: ContactName -> [StyledString]
|
||||
contactDisconnected c = ["disconnected from " <> ttyContact c <> " - restart chat"]
|
||||
|
||||
groupCreated :: GroupProfile -> [StyledString]
|
||||
groupCreated GroupProfile {groupRef, displayName} = ["group " <> ttyGroup groupRef <> " (" <> plain displayName <> ") is created"]
|
||||
groupCreated GroupProfile {displayName, fullName} = ["group " <> ttyGroup displayName <> " (" <> plain fullName <> ") is created"]
|
||||
|
||||
receivedMessage :: ContactRef -> UTCTime -> Text -> MsgIntegrity -> IO [StyledString]
|
||||
receivedMessage :: ContactName -> UTCTime -> Text -> MsgIntegrity -> IO [StyledString]
|
||||
receivedMessage c utcTime msg mOk = do
|
||||
t <- formatUTCTime <$> getCurrentTimeZone <*> getZonedTime
|
||||
pure $ prependFirst (t <> " " <> ttyFromContact c) (msgPlain msg) ++ showIntegrity mOk
|
||||
@ -110,7 +110,7 @@ receivedMessage c utcTime msg mOk = do
|
||||
msgError :: String -> [StyledString]
|
||||
msgError s = [styled (Colored Red) s]
|
||||
|
||||
sentMessage :: ContactRef -> ByteString -> IO [StyledString]
|
||||
sentMessage :: ContactName -> ByteString -> IO [StyledString]
|
||||
sentMessage c msg = do
|
||||
time <- formatTime defaultTimeLocale "%H:%M" <$> getZonedTime
|
||||
pure $ prependFirst (styleTime time <> " " <> ttyToContact c) (msgPlain $ safeDecodeUtf8 msg)
|
||||
@ -125,9 +125,9 @@ msgPlain = map styleMarkdownText . T.lines
|
||||
chatError :: ChatError -> [StyledString]
|
||||
chatError = \case
|
||||
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"]
|
||||
SEDuplicateGroupRef -> ["group with this alias already exists"]
|
||||
e -> ["chat db error: " <> plain (show e)]
|
||||
ChatErrorAgent err -> case err of
|
||||
-- CONN e -> case e of
|
||||
@ -141,16 +141,16 @@ chatError = \case
|
||||
printToView :: (MonadUnliftIO m, MonadReader ChatController m) => [StyledString] -> m ()
|
||||
printToView s = asks chatTerminal >>= liftIO . (`printToTerminal` s)
|
||||
|
||||
ttyContact :: ContactRef -> StyledString
|
||||
ttyContact :: ContactName -> StyledString
|
||||
ttyContact = styled (Colored Green)
|
||||
|
||||
ttyToContact :: ContactRef -> StyledString
|
||||
ttyToContact :: ContactName -> StyledString
|
||||
ttyToContact c = styled (Colored Cyan) $ "@" <> c <> " "
|
||||
|
||||
ttyFromContact :: ContactRef -> StyledString
|
||||
ttyFromContact :: ContactName -> StyledString
|
||||
ttyFromContact c = styled (Colored Yellow) $ c <> "> "
|
||||
|
||||
ttyGroup :: GroupRef -> StyledString
|
||||
ttyGroup :: GroupName -> StyledString
|
||||
ttyGroup g = styled (Colored Blue) $ "#" <> g
|
||||
|
||||
-- ttyFromGroup :: Group -> Contact -> StyledString
|
||||
|
||||
@ -6,17 +6,17 @@ import ChatClient
|
||||
import Control.Concurrent.Async (concurrently_)
|
||||
import Control.Concurrent.STM
|
||||
import Data.Char (isDigit)
|
||||
import Data.List (dropWhileEnd, find, isPrefixOf)
|
||||
import Data.List (dropWhileEnd, isPrefixOf)
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Types (Profile (..))
|
||||
import System.Terminal.Internal (VirtualTerminal (..))
|
||||
import Test.Hspec
|
||||
|
||||
aliceProfile :: Profile
|
||||
aliceProfile = Profile {contactRef = "alice", displayName = "Alice"}
|
||||
aliceProfile = Profile {displayName = "alice", fullName = "Alice"}
|
||||
|
||||
bobProfile :: Profile
|
||||
bobProfile = Profile {contactRef = "bob", displayName = "Bob"}
|
||||
bobProfile = Profile {displayName = "bob", fullName = "Bob"}
|
||||
|
||||
testAddContact :: Spec
|
||||
testAddContact = describe "add chat contact" $
|
||||
@ -32,6 +32,22 @@ testAddContact = describe "add chat contact" $
|
||||
bob <# "alice> hello"
|
||||
bob #> "@alice hi"
|
||||
alice <# "bob> hi"
|
||||
-- test adding the same contact one more time - local name will be different
|
||||
alice ##> "/a"
|
||||
Just inv' <- invitation <$> getWindow alice
|
||||
bob ##> ("/c " <> inv')
|
||||
concurrently_
|
||||
(bob <## "alice_1 is connected")
|
||||
(alice <## "bob_1 is connected")
|
||||
alice #> "@bob_1 hello"
|
||||
bob <# "alice_1> hello"
|
||||
bob #> "@alice_1 hi"
|
||||
alice <# "bob_1> hi"
|
||||
-- test deleting contact
|
||||
alice ##> "/d bob_1"
|
||||
alice <## "bob_1 is deleted"
|
||||
chatCommand alice "@bob_1 hey"
|
||||
alice <## "no contact bob_1"
|
||||
|
||||
(##>) :: TestCC -> String -> IO ()
|
||||
(##>) cc cmd = do
|
||||
@ -67,7 +83,11 @@ getWindow (TestCC _ t _) = do
|
||||
if win' /= win then pure win' else retry
|
||||
|
||||
invitation :: [String] -> Maybe String
|
||||
invitation win = dropWhileEnd (== ' ') <$> find ("smp::" `isPrefixOf`) win
|
||||
invitation win = lastMaybe $ map (dropWhileEnd (== ' ')) $ filter ("smp::" `isPrefixOf`) win
|
||||
|
||||
lastOutput :: [String] -> String
|
||||
lastOutput win = dropWhileEnd (== ' ') $ win !! (length win - 2) -- (- 2) to exclude prompt
|
||||
|
||||
lastMaybe :: [a] -> Maybe a
|
||||
lastMaybe [] = Nothing
|
||||
lastMaybe xs = Just $ last xs
|
||||
|
||||
Loading…
Reference in New Issue
Block a user