lovely-projects/simplex-chat
lovely-projects/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-03-14 09:45:42 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

SimpleX Directory Service (#2766)

Browse source 
* SimpleX Directory Service

* more events

* update events

* fix

* Apply suggestions from code review

metavar

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

* metavar 2

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

* process events

* remove command serialization

* update

* update

* process group profile update

* basic group registration flow

* search works

* better messages

* improve messages

* test broadcast bot

* test for directory service

* better processing of group profile change, test

* refactor

* de-list group when owner or service is removed from the group, tests

* fix: removing any member or any member leaving should not delist the group

* refactor

* more tests, fixes

* disable bot tests in CI

* remove comment

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin 2023-08-01 20:54:51 +01:00 • committed by GitHub
parent f0d64a30e9
commit 2b69103055
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
23 changed files with 1473 additions and 142 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

69
apps/simplex-broadcast-bot/Main.hs
View file

@ -1,76 +1,11 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Concurrent (forkIO)
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad.Reader
import qualified Data.Text as T
import Options
import Simplex.Chat.Bot
import Simplex.Chat.Controller
import Broadcast.Bot
import Broadcast.Options
import Simplex.Chat.Core
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..))
import Simplex.Chat.Terminal (terminalChatConfig)
import Simplex.Chat.Types
import System.Directory (getAppUserDataDirectory)
main :: IO ()
main = do
opts <- welcomeGetOpts
simplexChatCore terminalChatConfig (mkChatOpts opts) Nothing $ broadcastBot opts
welcomeGetOpts :: IO BroadcastBotOpts
welcomeGetOpts = do
appDir <- getAppUserDataDirectory "simplex"
opts@BroadcastBotOpts {coreOptions = CoreChatOpts {dbFilePrefix}} <- getBroadcastBotOpts appDir "simplex_status_bot"
putStrLn $ "SimpleX Chat Bot v" ++ versionNumber
putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db"
pure opts
broadcastBot :: BroadcastBotOpts -> User -> ChatController -> IO ()
broadcastBot BroadcastBotOpts {publishers, welcomeMessage, prohibitedMessage} _user cc = do
initializeBotAddress cc
race_ (forever $ void getLine) . forever $ do
(_, resp) <- atomically . readTBQueue $ outputQ cc
case resp of
CRContactConnected _ ct _ -> do
contactConnected ct
sendMessage cc ct welcomeMessage
CRNewChatItem _ (AChatItem _ SMDRcv (DirectChat ct) ci@ChatItem {content = CIRcvMsgContent mc})
| publisher `elem` publishers ->
if allowContent mc
then do
sendChatCmd cc "/contacts" >>= \case
CRContactsList _ cts -> void . forkIO $ do
let cts' = filter broadcastTo cts
forM_ cts' $ \ct' -> sendComposedMessage cc ct' Nothing mc
sendReply $ "Forwarded to " <> show (length cts') <> " contact(s)"
r -> putStrLn $ "Error getting contacts list: " <> show r
else sendReply "!1 Message is not supported!"
| otherwise -> do
sendReply prohibitedMessage
deleteMessage cc ct $ chatItemId' ci
where
sendReply = sendComposedMessage cc ct (Just $ chatItemId' ci) . textMsgContent
publisher = Publisher {contactId = contactId' ct, localDisplayName = localDisplayName' ct}
allowContent = \case
MCText _ -> True
MCLink {} -> True
MCImage {} -> True
_ -> False
broadcastTo ct'@Contact {activeConn = conn@Connection {connStatus}} =
(connStatus == ConnSndReady || connStatus == ConnReady)
&& not (connDisabled conn)
&& contactId' ct' /= contactId' ct
_ -> pure ()
where
contactConnected ct = putStrLn $ T.unpack (localDisplayName' ct) <> " connected"

71
apps/simplex-broadcast-bot/src/Broadcast/Bot.hs Normal file
View file

@ -0,0 +1,71 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Broadcast.Bot where
import Control.Concurrent (forkIO)
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad.Reader
import qualified Data.Text as T
import Broadcast.Options
import Simplex.Chat.Bot
import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Controller
import Simplex.Chat.Core
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..))
import Simplex.Chat.Types
import System.Directory (getAppUserDataDirectory)
welcomeGetOpts :: IO BroadcastBotOpts
welcomeGetOpts = do
appDir <- getAppUserDataDirectory "simplex"
opts@BroadcastBotOpts {coreOptions = CoreChatOpts {dbFilePrefix}} <- getBroadcastBotOpts appDir "simplex_status_bot"
putStrLn $ "SimpleX Chat Bot v" ++ versionNumber
putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db"
pure opts
broadcastBot :: BroadcastBotOpts -> User -> ChatController -> IO ()
broadcastBot BroadcastBotOpts {publishers, welcomeMessage, prohibitedMessage} _user cc = do
initializeBotAddress cc
race_ (forever $ void getLine) . forever $ do
(_, resp) <- atomically . readTBQueue $ outputQ cc
case resp of
CRContactConnected _ ct _ -> do
contactConnected ct
sendMessage cc ct welcomeMessage
CRNewChatItem _ (AChatItem _ SMDRcv (DirectChat ct) ci@ChatItem {content = CIRcvMsgContent mc})
| publisher `elem` publishers ->
if allowContent mc
then do
sendChatCmd cc ListContacts >>= \case
CRContactsList _ cts -> void . forkIO $ do
let cts' = filter broadcastTo cts
forM_ cts' $ \ct' -> sendComposedMessage cc ct' Nothing mc
sendReply $ "Forwarded to " <> show (length cts') <> " contact(s)"
r -> putStrLn $ "Error getting contacts list: " <> show r
else sendReply "!1 Message is not supported!"
| otherwise -> do
sendReply prohibitedMessage
deleteMessage cc ct $ chatItemId' ci
where
sendReply = sendComposedMessage cc ct (Just $ chatItemId' ci) . textMsgContent
publisher = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct}
allowContent = \case
MCText _ -> True
MCLink {} -> True
MCImage {} -> True
_ -> False
broadcastTo ct'@Contact {activeConn = conn@Connection {connStatus}} =
(connStatus == ConnSndReady || connStatus == ConnReady)
&& not (connDisabled conn)
&& contactId' ct' /= contactId' ct
_ -> pure ()
where
contactConnected ct = putStrLn $ T.unpack (localDisplayName' ct) <> " connected"

42
apps/simplex-broadcast-bot/Options.hs → apps/simplex-broadcast-bot/src/Broadcast/Options.hs
View file

@ -4,48 +4,33 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Options where
module Broadcast.Options where
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Options.Applicative
import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Controller (updateStr, versionNumber, versionString)
import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts, coreChatOptsP)
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Util (safeDecodeUtf8)
data Publisher = Publisher
{ contactId :: Int64,
localDisplayName :: Text
}
deriving (Eq)
data BroadcastBotOpts = BroadcastBotOpts
{ coreOptions :: CoreChatOpts,
publishers :: [Publisher],
publishers :: [KnownContact],
welcomeMessage :: String,
prohibitedMessage :: String
}
defaultWelcomeMessage :: [Publisher] -> String
defaultWelcomeMessage ps = "Hello! I am a broadcast bot.\nI broadcast messages to all connected users from " <> publisherNames ps <> "."
defaultWelcomeMessage :: [KnownContact] -> String
defaultWelcomeMessage ps = "Hello! I am a broadcast bot.\nI broadcast messages to all connected users from " <> knownContactNames ps <> "."
defaultProhibitedMessage :: [Publisher] -> String
defaultProhibitedMessage ps = "Sorry, only these users can broadcast messages: " <> publisherNames ps <> ". Your message is deleted."
publisherNames :: [Publisher] -> String
publisherNames = T.unpack . T.intercalate ", " . map (("@" <>) . localDisplayName)
defaultProhibitedMessage :: [KnownContact] -> String
defaultProhibitedMessage ps = "Sorry, only these users can broadcast messages: " <> knownContactNames ps <> ". Your message is deleted."
broadcastBotOpts :: FilePath -> FilePath -> Parser BroadcastBotOpts
broadcastBotOpts appDir defaultDbFileName = do
coreOptions <- coreChatOptsP appDir defaultDbFileName
publishers <-
option
parsePublishers
parseKnownContacts
( long "publishers"
<> metavar "PUBLISHERS"
<> help "Comma-separated list of publishers in the format CONTACT_ID:DISPLAY_NAME whose messages will be broadcasted"
@ -74,17 +59,6 @@ broadcastBotOpts appDir defaultDbFileName = do
prohibitedMessage = fromMaybe (defaultProhibitedMessage publishers) prohibitedMessage_
}
parsePublishers :: ReadM [Publisher]
parsePublishers = eitherReader $ parseAll publishersP . encodeUtf8 . T.pack
publishersP :: A.Parser [Publisher]
publishersP = publisherP `A.sepBy1` A.char ','
where
publisherP = do
contactId <- A.decimal <* A.char ':'
localDisplayName <- safeDecodeUtf8 <$> A.takeTill (A.inClass ", ")
pure Publisher {contactId, localDisplayName}
getBroadcastBotOpts :: FilePath -> FilePath -> IO BroadcastBotOpts
getBroadcastBotOpts appDir defaultDbFileName =
execParser $

2
apps/simplex-chat/Main.hs
View file

@ -28,7 +28,7 @@ main = do
t <- withTerminal pure
simplexChatTerminal terminalChatConfig opts t
else simplexChatCore terminalChatConfig opts Nothing $ \user cc -> do
r <- sendChatCmd cc chatCmd
r <- sendChatCmdStr cc chatCmd
ts <- getCurrentTime
tz <- getCurrentTimeZone
putStrLn $ serializeChatResponse (Just user) ts tz r

15
apps/simplex-directory-service/Main.hs Normal file
View file

@ -0,0 +1,15 @@
{-# LANGUAGE NamedFieldPuns #-}
module Main where
import Directory.Options
import Directory.Service
import Directory.Store
import Simplex.Chat.Core
import Simplex.Chat.Terminal (terminalChatConfig)
main :: IO ()
main = do
opts@DirectoryOpts {directoryLog} <- welcomeGetOpts
st <- getDirectoryStore directoryLog
simplexChatCore terminalChatConfig (mkChatOpts opts) Nothing $ directoryService st opts

5
apps/simplex-directory-service/README.md Normal file
View file

@ -0,0 +1,5 @@
# SimpleX Directory Service
The service is currently a chat bot that allows to register and search for groups.
Superusers are configured via CLI options.

139
apps/simplex-directory-service/src/Directory/Events.hs Normal file
View file

@ -0,0 +1,139 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
module Directory.Events where
import Control.Applicative ((<|>))
import Data.Attoparsec.Text (Parser)
import qualified Data.Attoparsec.Text as A
import Data.Text (Text)
import qualified Data.Text as T
import Directory.Store
import Simplex.Chat.Controller
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Protocol (MsgContent (..))
import Simplex.Chat.Types
import Data.Char (isSpace)
import Data.Either (fromRight)
data DirectoryEvent
= DEContactConnected Contact
| DEGroupInvitation {contact :: Contact, groupInfo :: GroupInfo, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole}
| DEServiceJoinedGroup ContactId GroupInfo
| DEGroupUpdated {contactId :: ContactId, fromGroup :: GroupInfo, toGroup :: GroupInfo}
| DEContactRoleChanged ContactId GroupInfo GroupMemberRole
| DEServiceRoleChanged GroupInfo GroupMemberRole
| DEContactRemovedFromGroup ContactId GroupInfo
| DEContactLeftGroup ContactId GroupInfo
| DEServiceRemovedFromGroup GroupInfo
| DEGroupDeleted GroupInfo
| DEUnsupportedMessage Contact ChatItemId
| DEItemEditIgnored Contact
| DEItemDeleteIgnored Contact
| DEContactCommand Contact ChatItemId ADirectoryCmd
crDirectoryEvent :: ChatResponse -> Maybe DirectoryEvent
crDirectoryEvent = \case
CRContactConnected {contact} -> Just $ DEContactConnected contact
CRReceivedGroupInvitation {contact, groupInfo, fromMemberRole, memberRole} -> Just $ DEGroupInvitation {contact, groupInfo, fromMemberRole, memberRole}
CRUserJoinedGroup {groupInfo, hostMember} -> (`DEServiceJoinedGroup` groupInfo) <$> memberContactId hostMember
CRGroupUpdated {fromGroup, toGroup, member_} -> (\contactId -> DEGroupUpdated {contactId, fromGroup, toGroup}) <$> (memberContactId =<< member_)
CRMemberRole {groupInfo, member, toRole} -> (\ctId -> DEContactRoleChanged ctId groupInfo toRole) <$> memberContactId member
CRMemberRoleUser {groupInfo, toRole} -> Just $ DEServiceRoleChanged groupInfo toRole
CRDeletedMember {groupInfo, deletedMember} -> (`DEContactRemovedFromGroup` groupInfo) <$> memberContactId deletedMember
CRLeftMember {groupInfo, member} -> (`DEContactLeftGroup` groupInfo) <$> memberContactId member
CRDeletedMemberUser {groupInfo} -> Just $ DEServiceRemovedFromGroup groupInfo
CRGroupDeleted {groupInfo} -> Just $ DEGroupDeleted groupInfo
CRChatItemUpdated {chatItem = AChatItem _ SMDRcv (DirectChat ct) _} -> Just $ DEItemEditIgnored ct
CRChatItemDeleted {deletedChatItem = AChatItem _ SMDRcv (DirectChat ct) _, byUser = False} -> Just $ DEItemDeleteIgnored ct
CRNewChatItem {chatItem = AChatItem _ SMDRcv (DirectChat ct) ci@ChatItem {content = CIRcvMsgContent mc, meta = CIMeta {itemLive}}} ->
Just $ case (mc, itemLive) of
(MCText t, Nothing) -> DEContactCommand ct ciId $ fromRight err $ A.parseOnly directoryCmdP $ T.dropWhileEnd isSpace t
_ -> DEUnsupportedMessage ct ciId
where
ciId = chatItemId' ci
err = ADC SDRUser DCUnknownCommand
_ -> Nothing
data DirectoryRole = DRUser | DRSuperUser
data SDirectoryRole (r :: DirectoryRole) where
SDRUser :: SDirectoryRole 'DRUser
SDRSuperUser :: SDirectoryRole 'DRSuperUser
data DirectoryCmdTag (r :: DirectoryRole) where
DCHelp_ :: DirectoryCmdTag 'DRUser
DCConfirmDuplicateGroup_ :: DirectoryCmdTag 'DRUser
DCListUserGroups_ :: DirectoryCmdTag 'DRUser
DCDeleteGroup_ :: DirectoryCmdTag 'DRUser
DCApproveGroup_ :: DirectoryCmdTag 'DRSuperUser
DCRejectGroup_ :: DirectoryCmdTag 'DRSuperUser
DCSuspendGroup_ :: DirectoryCmdTag 'DRSuperUser
DCResumeGroup_ :: DirectoryCmdTag 'DRSuperUser
DCListGroups_ :: DirectoryCmdTag 'DRSuperUser
deriving instance Show (DirectoryCmdTag r)
data ADirectoryCmdTag = forall r. ADCT (SDirectoryRole r) (DirectoryCmdTag r)
data DirectoryCmd (r :: DirectoryRole) where
DCHelp :: DirectoryCmd 'DRUser
DCSearchGroup :: Text -> DirectoryCmd 'DRUser
DCConfirmDuplicateGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser
DCListUserGroups :: DirectoryCmd 'DRUser
DCDeleteGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser
DCApproveGroup :: {groupId :: GroupId, localDisplayName :: GroupName, groupApprovalId :: GroupApprovalId} -> DirectoryCmd 'DRSuperUser
DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
DCListGroups :: DirectoryCmd 'DRSuperUser
DCUnknownCommand :: DirectoryCmd 'DRUser
DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r
data ADirectoryCmd = forall r. ADC (SDirectoryRole r) (DirectoryCmd r)
directoryCmdP :: Parser ADirectoryCmd
directoryCmdP =
(A.char '/' *> cmdStrP) <|> (ADC SDRUser . DCSearchGroup <$> A.takeText)
where
cmdStrP =
(tagP >>= \(ADCT u t) -> ADC u <$> (cmdP t <|> pure (DCCommandError t)))
<|> pure (ADC SDRUser DCUnknownCommand)
tagP = A.takeTill (== ' ') >>= \case
"help" -> u DCHelp_
"h" -> u DCHelp_
"confim" -> u DCConfirmDuplicateGroup_
"list" -> u DCListUserGroups_
"delete" -> u DCDeleteGroup_
"approve" -> su DCApproveGroup_
"reject" -> su DCRejectGroup_
"suspend" -> su DCSuspendGroup_
"resume" -> su DCResumeGroup_
"all" -> su DCListGroups_
_ -> fail "bad command tag"
where
u = pure . ADCT SDRUser
su = pure . ADCT SDRSuperUser
cmdP :: DirectoryCmdTag r -> Parser (DirectoryCmd r)
cmdP = \case
DCHelp_ -> pure DCHelp
DCConfirmDuplicateGroup_ -> gc DCConfirmDuplicateGroup
DCListUserGroups_ -> pure DCListUserGroups
DCDeleteGroup_ -> gc DCDeleteGroup
DCApproveGroup_ -> do
(groupId, localDisplayName) <- gc (,)
groupApprovalId <- A.space *> A.decimal
pure $ DCApproveGroup {groupId, localDisplayName, groupApprovalId}
DCRejectGroup_ -> gc DCRejectGroup
DCSuspendGroup_ -> gc DCSuspendGroup
DCResumeGroup_ -> gc DCResumeGroup
DCListGroups_ -> pure DCListGroups
where
gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> A.takeTill (== ' ')

77
apps/simplex-directory-service/src/Directory/Options.hs Normal file
View file

@ -0,0 +1,77 @@
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Directory.Options where
import Options.Applicative
import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Controller (updateStr, versionNumber, versionString)
import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts, coreChatOptsP)
data DirectoryOpts = DirectoryOpts
{ coreOptions :: CoreChatOpts,
superUsers :: [KnownContact],
directoryLog :: FilePath,
serviceName :: String
}
directoryOpts :: FilePath -> FilePath -> Parser DirectoryOpts
directoryOpts appDir defaultDbFileName = do
coreOptions <- coreChatOptsP appDir defaultDbFileName
superUsers <-
option
parseKnownContacts
( long "super-users"
<> metavar "SUPER_USERS"
<> help "Comma-separated list of super-users in the format CONTACT_ID:DISPLAY_NAME who will be allowed to manage the directory"
<> value []
)
directoryLog <-
strOption
( long "directory-file"
<> metavar "DIRECTORY_FILE"
<> help "Append only log for directory state"
)
serviceName <-
strOption
( long "service-name"
<> metavar "SERVICE_NAME"
<> help "The display name of the directory service bot, without *'s and spaces (SimpleX-Directory)"
<> value "SimpleX-Directory"
)
pure
DirectoryOpts
{ coreOptions,
superUsers,
directoryLog,
serviceName
}
getDirectoryOpts :: FilePath -> FilePath -> IO DirectoryOpts
getDirectoryOpts appDir defaultDbFileName =
execParser $
info
(helper <*> versionOption <*> directoryOpts appDir defaultDbFileName)
(header versionStr <> fullDesc <> progDesc "Start SimpleX Directory Service with DB_FILE, DIRECTORY_FILE and SUPER_USERS options")
where
versionStr = versionString versionNumber
versionOption = infoOption versionAndUpdate (long "version" <> short 'v' <> help "Show version")
versionAndUpdate = versionStr <> "\n" <> updateStr
mkChatOpts :: DirectoryOpts -> ChatOpts
mkChatOpts DirectoryOpts {coreOptions} =
ChatOpts
{ coreOptions,
chatCmd = "",
chatCmdDelay = 3,
chatServerPort = Nothing,
optFilesFolder = Nothing,
showReactions = False,
allowInstantFiles = True,
autoAcceptFileSize = 0,
muteNotifications = True,
maintenance = False
}

331
apps/simplex-directory-service/src/Directory/Service.hs Normal file
View file

@ -0,0 +1,331 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
module Directory.Service
( welcomeGetOpts,
directoryService,
)
where
import Control.Concurrent (forkIO)
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad.Reader
import qualified Data.ByteString.Char8 as B
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Directory.Events
import Directory.Options
import Directory.Store
import Simplex.Chat.Bot
import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Controller
import Simplex.Chat.Core
import Simplex.Chat.Messages
-- import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..))
import Simplex.Chat.Types
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
import System.Directory (getAppUserDataDirectory)
data GroupProfileUpdate = GPNoServiceLink | GPServiceLinkAdded | GPServiceLinkRemoved | GPHasServiceLink | GPServiceLinkError
welcomeGetOpts :: IO DirectoryOpts
welcomeGetOpts = do
appDir <- getAppUserDataDirectory "simplex"
opts@DirectoryOpts {coreOptions = CoreChatOpts {dbFilePrefix}} <- getDirectoryOpts appDir "simplex_directory_service"
putStrLn $ "SimpleX Directory Service Bot v" ++ versionNumber
putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db"
pure opts
directoryService :: DirectoryStore -> DirectoryOpts -> User -> ChatController -> IO ()
directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = do
initializeBotAddress cc
race_ (forever $ void getLine) . forever $ do
(_, resp) <- atomically . readTBQueue $ outputQ cc
forM_ (crDirectoryEvent resp) $ \case
DEContactConnected ct -> deContactConnected ct
DEGroupInvitation {contact = ct, groupInfo = g, fromMemberRole, memberRole} -> deGroupInvitation ct g fromMemberRole memberRole
DEServiceJoinedGroup ctId g -> deServiceJoinedGroup ctId g
DEGroupUpdated {contactId, fromGroup, toGroup} -> deGroupUpdated contactId fromGroup toGroup
DEContactRoleChanged ctId g role -> deContactRoleChanged ctId g role
DEServiceRoleChanged g role -> deServiceRoleChanged g role
DEContactRemovedFromGroup ctId g -> deContactRemovedFromGroup ctId g
DEContactLeftGroup ctId g -> deContactLeftGroup ctId g
DEServiceRemovedFromGroup g -> deServiceRemovedFromGroup g
DEGroupDeleted _g -> pure ()
DEUnsupportedMessage _ct _ciId -> pure ()
DEItemEditIgnored _ct -> pure ()
DEItemDeleteIgnored _ct -> pure ()
DEContactCommand ct ciId aCmd -> case aCmd of
ADC SDRUser cmd -> deUserCommand ct ciId cmd
ADC SDRSuperUser cmd -> deSuperUserCommand ct ciId cmd
where
withSuperUsers action = void . forkIO $ forM_ superUsers $ \KnownContact {contactId} -> action contactId
notifySuperUsers s = withSuperUsers $ \contactId -> sendMessage' cc contactId s
-- withContact ctId GroupInfo {localDisplayName} err action = do
-- getContact cc ctId >>= \case
-- Just ct -> action ct
-- Nothing -> putStrLn $ T.unpack $ "Error: " <> err <> ", group: " <> localDisplayName <> ", can't find contact ID " <> tshow ctId
notifyOwner GroupReg {dbContactId} = sendMessage' cc dbContactId
ctId `isOwner` GroupReg {dbContactId} = ctId == dbContactId
withGroupReg GroupInfo {groupId, localDisplayName} err action = do
atomically (getGroupReg st groupId) >>= \case
Just gr -> action gr
Nothing -> putStrLn $ T.unpack $ "Error: " <> err <> ", group: " <> localDisplayName <> ", can't find group registration ID " <> tshow groupId
setGroupInactive GroupReg {groupRegStatus, dbGroupId} grStatus = atomically $ do
writeTVar groupRegStatus grStatus
unlistGroup st dbGroupId
groupInfoText GroupProfile {displayName = n, fullName = fn, description = d} =
n <> (if n == fn || T.null fn then "" else " (" <> fn <> ")") <> maybe "" ("\nWelcome message:\n" <>) d
groupReference GroupInfo {groupId, groupProfile = p'@GroupProfile {displayName}} =
"ID " <> show groupId <> " (" <> T.unpack displayName <> ")"
deContactConnected :: Contact -> IO ()
deContactConnected ct = do
putStrLn $ T.unpack (localDisplayName' ct) <> " connected"
sendMessage cc ct $
"Welcome to " <> serviceName <> " service!\n\
\Send a search string to find groups or */help* to learn how to add groups to directory.\n\n\
\For example, send _privacy_ to find groups about privacy."
deGroupInvitation :: Contact -> GroupInfo -> GroupMemberRole -> GroupMemberRole -> IO ()
deGroupInvitation ct g fromMemberRole memberRole =
case badInvitation fromMemberRole memberRole of
-- TODO check duplicate group name and ask to confirm
Just msg -> sendMessage cc ct msg
Nothing -> do
let GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = g
atomically $ addGroupReg st ct g
r <- sendChatCmd cc $ APIJoinGroup groupId
sendMessage cc ct $ T.unpack $ case r of
CRUserAcceptedGroupSent {} -> "Joining the group #" <> displayName <> "…"
_ -> "Error joining group " <> displayName <> ", please re-send the invitation!"
deServiceJoinedGroup :: ContactId -> GroupInfo -> IO ()
deServiceJoinedGroup ctId g =
withGroupReg g "joined group" $ \gr ->
when (ctId `isOwner` gr) $ do
let GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = g
notifyOwner gr $ T.unpack $ "Joined the group #" <> displayName <> ", creating the link…"
sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case
CRGroupLinkCreated {connReqContact} -> do
setGroupInactive gr GRSPendingUpdate
notifyOwner gr
"Created the public link to join the group via this directory service that is always online.\n\n\
\Please add it to the group welcome message.\n\
\For example, add:"
notifyOwner gr $ "Link to join the group " <> T.unpack displayName <> ": " <> B.unpack (strEncode connReqContact)
CRChatCmdError _ (ChatError e) -> case e of
CEGroupUserRole {} -> notifyOwner gr "Failed creating group link, as service is no longer an admin."
CEGroupMemberUserRemoved -> notifyOwner gr "Failed creating group link, as service is removed from the group."
CEGroupNotJoined _ -> notifyOwner gr $ unexpectedError "group not joined"
CEGroupMemberNotActive -> notifyOwner gr $ unexpectedError "service membership is not active"
_ -> notifyOwner gr $ unexpectedError "can't create group link"
_ -> notifyOwner gr $ unexpectedError "can't create group link"
deGroupUpdated :: ContactId -> GroupInfo -> GroupInfo -> IO ()
deGroupUpdated ctId fromGroup toGroup =
unless (sameProfile p p') $ do
atomically $ unlistGroup st groupId
withGroupReg toGroup "group updated" $ \gr -> do
readTVarIO (groupRegStatus gr) >>= \case
GRSPendingConfirmation -> pure ()
GRSProposed -> pure ()
GRSPendingUpdate -> groupProfileUpdate >>= \case
GPNoServiceLink ->
when (ctId `isOwner` gr) $ notifyOwner gr $ "The profile updated for " <> groupRef <> ", but the group link is not added to the welcome message."
GPServiceLinkAdded
| ctId `isOwner` gr -> groupLinkAdded gr
| otherwise -> notifyOwner gr "The group link is added by another group member, your registration will not be processed.\n\nPlease update the group profile yourself."
GPServiceLinkRemoved -> when (ctId `isOwner` gr) $ notifyOwner gr $ "The group link of " <> groupRef <> " is removed from the welcome message, please add it."
GPHasServiceLink -> when (ctId `isOwner` gr) $ groupLinkAdded gr
GPServiceLinkError -> do
when (ctId `isOwner` gr) $ notifyOwner gr $ "Error: " <> serviceName <> " has no group link for " <> groupRef <> ". Please report the error to the developers."
putStrLn $ "Error: no group link for " <> groupRef
GRSPendingApproval n -> processProfileChange gr $ n + 1
GRSActive -> processProfileChange gr 1
GRSSuspended -> processProfileChange gr 1
GRSRemoved -> pure ()
where
isInfix l d_ = l `T.isInfixOf` fromMaybe "" d_
GroupInfo {groupId, groupProfile = p} = fromGroup
GroupInfo {localDisplayName, groupProfile = p'@GroupProfile {image = image'}} = toGroup
groupRef = groupReference toGroup
sameProfile
GroupProfile {displayName = n, fullName = fn, image = i, description = d}
GroupProfile {displayName = n', fullName = fn', image = i', description = d'} =
n == n' && fn == fn' && i == i' && d == d'
groupLinkAdded gr = do
notifyOwner gr $ "Thank you! The group link for " <> groupRef <> " is added to the welcome message.\nYou will be notified once the group is added to the directory - it may take up to 24 hours."
let gaId = 1
setGroupInactive gr $ GRSPendingApproval gaId
sendForApproval gr gaId
processProfileChange gr n' = groupProfileUpdate >>= \case
GPNoServiceLink -> do
setGroupInactive gr GRSPendingUpdate
notifyOwner gr $ "The group profile is updated " <> groupRef <> ", but no link is added to the welcome message.\n\nThe group will remain hidden from the directory until the group link is added and the group is re-approved."
GPServiceLinkRemoved -> do
setGroupInactive gr GRSPendingUpdate
notifyOwner gr $ "The group link for " <> groupRef <> " is removed from the welcome message.\n\nThe group is hidden from the directory until the group link is added and the group is re-approved."
notifySuperUsers $ "The group link is removed from " <> groupRef <> ", de-listed."
GPServiceLinkAdded -> do
setGroupInactive gr $ GRSPendingApproval n'
notifyOwner gr $ "The group link is added to " <> groupRef <> "!\nIt is hidden from the directory until approved."
notifySuperUsers $ "The group link is added to " <> groupRef <> "."
sendForApproval gr n'
GPHasServiceLink -> do
setGroupInactive gr $ GRSPendingApproval n'
notifyOwner gr $ "The group " <> groupRef <> " is updated!\nIt is hidden from the directory until approved."
notifySuperUsers $ "The group " <> groupRef <> " is updated."
sendForApproval gr n'
GPServiceLinkError -> putStrLn $ "Error: no group link for " <> groupRef <> " pending approval."
groupProfileUpdate = profileUpdate <$> sendChatCmd cc (APIGetGroupLink groupId)
where
profileUpdate = \case
CRGroupLink {connReqContact} ->
let groupLink = safeDecodeUtf8 $ strEncode connReqContact
hadLinkBefore = groupLink `isInfix` description p
hasLinkNow = groupLink `isInfix` description p'
in if
| hadLinkBefore && hasLinkNow -> GPHasServiceLink
| hadLinkBefore -> GPServiceLinkRemoved
| hasLinkNow -> GPServiceLinkAdded
| otherwise -> GPNoServiceLink
_ -> GPServiceLinkError
sendForApproval GroupReg {dbGroupId, dbContactId} gaId = do
ct_ <- getContact cc dbContactId
let text = maybe ("The group ID " <> tshow dbGroupId <> " submitted: ") (\c -> localDisplayName' c <> " submitted the group ID " <> tshow dbGroupId <> ": ") ct_
<> groupInfoText p' <> "\n\nTo approve send:"
msg = maybe (MCText text) (\image -> MCImage {text, image}) image'
withSuperUsers $ \cId -> do
sendComposedMessage' cc cId Nothing msg
sendMessage' cc cId $ "/approve " <> show dbGroupId <> ":" <> T.unpack localDisplayName <> " " <> show gaId
deContactRoleChanged :: ContactId -> GroupInfo -> GroupMemberRole -> IO ()
deContactRoleChanged ctId g role = undefined
deServiceRoleChanged :: GroupInfo -> GroupMemberRole -> IO ()
deServiceRoleChanged g role = undefined
deContactRemovedFromGroup :: ContactId -> GroupInfo -> IO ()
deContactRemovedFromGroup ctId g =
withGroupReg g "contact removed" $ \gr -> do
when (ctId `isOwner` gr) $ do
setGroupInactive gr GRSRemoved
let groupRef = groupReference g
notifyOwner gr $ "You are removed from the group " <> groupRef <> ".\n\nGroup is no longer listed in the directory."
notifySuperUsers $ "The group " <> groupRef <> " is de-listed (group owner is removed)."
deContactLeftGroup :: ContactId -> GroupInfo -> IO ()
deContactLeftGroup ctId g =
withGroupReg g "contact left" $ \gr -> do
when (ctId `isOwner` gr) $ do
setGroupInactive gr GRSRemoved
let groupRef = groupReference g
notifyOwner gr $ "You left the group " <> groupRef <> ".\n\nGroup is no longer listed in the directory."
notifySuperUsers $ "The group " <> groupRef <> " is de-listed (group owner left)."
deServiceRemovedFromGroup :: GroupInfo -> IO ()
deServiceRemovedFromGroup g =
withGroupReg g "service removed" $ \gr -> do
setGroupInactive gr GRSRemoved
let groupRef = groupReference g
notifyOwner gr $ serviceName <> " is removed from the group " <> groupRef <> ".\n\nGroup is no longer listed in the directory."
notifySuperUsers $ "The group " <> groupRef <> " is de-listed (directory service is removed)."
deUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRUser -> IO ()
deUserCommand ct ciId = \case
DCHelp ->
sendMessage cc ct $
"You must be the owner to add the group to the directory:\n\
\1. Invite " <> serviceName <> " bot to your group as *admin*.\n\
\2. " <> serviceName <> " bot will create a public group link for the new members to join even when you are offline.\n\
\3. You will then need to add this link to the group welcome message.\n\
\4. Once the link is added, service admins will approve the group (it can take up to 24 hours), and everybody will be able to find it in directory.\n\n\
\Start from inviting the bot to your group as admin - it will guide you through the process"
DCSearchGroup s -> do
sendChatCmd cc (APIListGroups userId Nothing $ Just $ T.unpack s) >>= \case
CRGroupsList {groups} ->
atomically (filterListedGroups st groups) >>= \case
[] -> sendReply "No groups found"
gs -> do
sendReply $ "Found " <> show (length gs) <> " group(s)"
void . forkIO $ forM_ gs $ \GroupInfo {groupProfile = p@GroupProfile {image = image_}} -> do
let text = groupInfoText p
msg = maybe (MCText text) (\image -> MCImage {text, image}) image_
sendComposedMessage cc ct Nothing msg
_ -> sendReply "Unexpected error"
DCConfirmDuplicateGroup _ugrId _gName -> pure ()
DCListUserGroups -> pure ()
DCDeleteGroup _ugrId _gName -> pure ()
DCUnknownCommand -> sendReply "Unknown command"
DCCommandError tag -> sendReply $ "Command error: " <> show tag
where
sendReply = sendComposedMessage cc ct (Just ciId) . textMsgContent
deSuperUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRSuperUser -> IO ()
deSuperUserCommand ct ciId cmd
| superUser `elem` superUsers = case cmd of
DCApproveGroup {groupId, localDisplayName = n, groupApprovalId} ->
atomically (getGroupReg st groupId) >>= \case
Nothing -> sendMessage cc ct $ "Group ID " <> show groupId <> " not found"
Just GroupReg {dbContactId, groupRegStatus} -> do
readTVarIO groupRegStatus >>= \case
GRSPendingApproval gaId
| gaId == groupApprovalId -> do
getGroup cc groupId >>= \case
Just GroupInfo {localDisplayName = n'}
| n == n' -> do
atomically $ do
writeTVar groupRegStatus GRSActive
listGroup st groupId
sendReply "Group approved!"
sendMessage' cc dbContactId $ "The group ID " <> show groupId <> " (" <> T.unpack n <> ") is approved and listed in directory!\nPlease note: if you change the group profile it will be hidden from directory until it is re-approved."
| otherwise -> sendReply "Incorrect group name"
Nothing -> pure ()
| otherwise -> sendReply "Incorrect approval code"
_ -> sendReply $ "Error: the group ID " <> show groupId <> " (" <> T.unpack n <> ") is not pending approval."
DCRejectGroup _gaId _gName -> pure ()
DCSuspendGroup _gId _gName -> pure ()
DCResumeGroup _gId _gName -> pure ()
DCListGroups -> pure ()
DCCommandError tag -> sendReply $ "Command error: " <> show tag
| otherwise = sendReply "You are not allowed to use this command"
where
superUser = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct}
sendReply = sendComposedMessage cc ct (Just ciId) . textMsgContent
badInvitation :: GroupMemberRole -> GroupMemberRole -> Maybe String
badInvitation contactRole serviceRole = case (contactRole, serviceRole) of
(GROwner, GRAdmin) -> Nothing
(_, GRAdmin) -> Just "You must have a group *owner* role to register the group"
(GROwner, _) -> Just "You must grant directory service *admin* role to register the group"
_ -> Just "You must have a group *owner* role and you must grant directory service *admin* role to register the group"
getContact :: ChatController -> ContactId -> IO (Maybe Contact)
getContact cc ctId = resp <$> sendChatCmd cc (APIGetChat (ChatRef CTDirect ctId) (CPLast 0) Nothing)
where
resp :: ChatResponse -> Maybe Contact
resp = \case
CRApiChat _ (AChat SCTDirect Chat {chatInfo = DirectChat ct}) -> Just ct
_ -> Nothing
getGroup :: ChatController -> GroupId -> IO (Maybe GroupInfo)
getGroup cc gId = resp <$> sendChatCmd cc (APIGetChat (ChatRef CTGroup gId) (CPLast 0) Nothing)
where
resp :: ChatResponse -> Maybe GroupInfo
resp = \case
CRApiChat _ (AChat SCTGroup Chat {chatInfo = GroupChat g}) -> Just g
_ -> Nothing
unexpectedError :: String -> String
unexpectedError err = "Unexpected error: " <> err <> ", please notify the developers."

90
apps/simplex-directory-service/src/Directory/Store.hs Normal file
View file

@ -0,0 +1,90 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
module Directory.Store where
import Control.Concurrent.STM
import Data.Int (Int64)
import Data.Set (Set)
import Simplex.Chat.Types
import Data.List (find)
import qualified Data.Set as S
data DirectoryStore = DirectoryStore
{ groupRegs :: TVar [GroupReg],
listedGroups :: TVar (Set GroupId)
}
data GroupReg = GroupReg
{ userGroupRegId :: UserGroupRegId,
dbGroupId :: GroupId,
dbContactId :: ContactId,
groupRegStatus :: TVar GroupRegStatus
}
type GroupRegId = Int64
type UserGroupRegId = Int64
type GroupApprovalId = Int64
data GroupRegStatus
= GRSPendingConfirmation
| GRSProposed
| GRSPendingUpdate
| GRSPendingApproval GroupApprovalId
| GRSActive
| GRSSuspended
| GRSRemoved
addGroupReg :: DirectoryStore -> Contact -> GroupInfo -> STM ()
addGroupReg st ct GroupInfo {groupId} = do
groupRegStatus <- newTVar GRSProposed
let gr = GroupReg {userGroupRegId = groupId, dbGroupId = groupId, dbContactId = contactId' ct, groupRegStatus}
modifyTVar' (groupRegs st) (gr :)
getGroupReg :: DirectoryStore -> GroupRegId -> STM (Maybe GroupReg)
getGroupReg st gId = find ((gId ==) . dbGroupId) <$> readTVar (groupRegs st)
getUserGroupRegId :: DirectoryStore -> ContactId -> UserGroupRegId -> STM (Maybe GroupReg)
getUserGroupRegId st ctId ugrId = find (\r -> ctId == dbContactId r && ugrId == userGroupRegId r) <$> readTVar (groupRegs st)
getContactGroupRegs :: DirectoryStore -> ContactId -> STM [GroupReg]
getContactGroupRegs st ctId = filter ((ctId ==) . dbContactId) <$> readTVar (groupRegs st)
filterListedGroups :: DirectoryStore -> [GroupInfo] -> STM [GroupInfo]
filterListedGroups st gs = do
lgs <- readTVar $ listedGroups st
pure $ filter (\GroupInfo {groupId} -> groupId `S.member` lgs) gs
listGroup :: DirectoryStore -> GroupId -> STM ()
listGroup st gId = modifyTVar' (listedGroups st) $ S.insert gId
unlistGroup :: DirectoryStore -> GroupId -> STM ()
unlistGroup st gId = modifyTVar' (listedGroups st) $ S.delete gId
data DirectoryLogRecord
= CreateGroupReg GroupReg
| UpdateGroupRegStatus GroupRegId GroupRegStatus
getDirectoryStore :: FilePath -> IO DirectoryStore
getDirectoryStore path = do
groupRegs <- readDirectoryState path
st <- atomically newDirectoryStore
atomically $ mapM_ (add st) groupRegs
pure st
where
add :: DirectoryStore -> GroupReg -> STM ()
add st gr = modifyTVar' (groupRegs st) (gr :) -- TODO set listedGroups
newDirectoryStore :: STM DirectoryStore
newDirectoryStore = do
groupRegs <- newTVar []
listedGroups <- newTVar mempty
pure DirectoryStore {groupRegs, listedGroups}
readDirectoryState :: FilePath -> IO [GroupReg]
readDirectoryState _ = pure []
writeDirectoryState :: FilePath -> [GroupReg] -> IO ()
writeDirectoryState _ _ = pure ()

18
package.yaml
View file

@ -10,6 +10,7 @@ copyright: 2020-22 simplex.chat
category: Web, System, Services, Cryptography
extra-source-files:
- README.md
- cabal.project
dependencies:
- aeson == 2.0.*
@ -91,8 +92,16 @@ executables:
- -threaded
simplex-broadcast-bot:
source-dirs: apps/simplex-broadcast-bot
main: Main.hs
source-dirs: apps/simplex-broadcast-bot/src
main: ../Main.hs
dependencies:
- simplex-chat
ghc-options:
- -threaded
simplex-directory-service:
source-dirs: apps/simplex-directory-service/src
main: ../Main.hs
dependencies:
- simplex-chat
ghc-options:
@ -100,7 +109,10 @@ executables:
tests:
simplex-chat-test:
source-dirs: tests
source-dirs:
- tests
- apps/simplex-broadcast-bot/src
- apps/simplex-directory-service/src
main: Test.hs
dependencies:
- simplex-chat

71
simplex-chat.cabal
View file

@ -28,6 +28,7 @@ library
Simplex.Chat
Simplex.Chat.Archive
Simplex.Chat.Bot
Simplex.Chat.Bot.KnownContacts
Simplex.Chat.Call
Simplex.Chat.Controller
Simplex.Chat.Core
@ -275,12 +276,13 @@ executable simplex-bot-advanced
cpp-options: -DswiftJSON
executable simplex-broadcast-bot
main-is: Main.hs
main-is: ../Main.hs
other-modules:
Options
Broadcast.Bot
Broadcast.Options
Paths_simplex_chat
hs-source-dirs:
apps/simplex-broadcast-bot
apps/simplex-broadcast-bot/src
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
build-depends:
aeson ==2.0.*
@ -375,10 +377,65 @@ executable simplex-chat
if flag(swift)
cpp-options: -DswiftJSON
executable simplex-directory-service
main-is: ../Main.hs
other-modules:
Directory.Events
Directory.Options
Directory.Service
Directory.Store
Paths_simplex_chat
hs-source-dirs:
apps/simplex-directory-service/src
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
build-depends:
aeson ==2.0.*
, ansi-terminal >=0.10 && <0.12
, async ==2.2.*
, attoparsec ==0.14.*
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, bytestring ==0.10.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
, containers ==0.6.*
, cryptonite >=0.27 && <0.30
, direct-sqlcipher ==2.3.*
, directory ==1.3.*
, email-validate ==2.3.*
, exceptions ==0.10.*
, filepath ==1.4.*
, http-types ==0.12.*
, memory ==0.15.*
, mtl ==2.2.*
, network >=3.1.2.7 && <3.2
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
, random >=1.1 && <1.3
, record-hasfield ==1.0.*
, simple-logger ==0.1.*
, simplex-chat
, simplexmq >=5.0
, socks ==0.6.*
, sqlcipher-simple ==0.4.*
, stm ==2.5.*
, template-haskell ==2.16.*
, terminal ==0.2.*
, text ==1.2.*
, time ==1.9.*
, unliftio ==0.2.*
, unliftio-core ==0.2.*
, zip ==1.7.*
default-language: Haskell2010
if flag(swift)
cpp-options: -DswiftJSON
test-suite simplex-chat-test
type: exitcode-stdio-1.0
main-is: Test.hs
other-modules:
Bots.BroadcastTests
Bots.DirectoryTests
ChatClient
ChatTests
ChatTests.Direct
@ -392,9 +449,17 @@ test-suite simplex-chat-test
SchemaDump
ViewTests
WebRTCTests
Broadcast.Bot
Broadcast.Options
Directory.Events
Directory.Options
Directory.Service
Directory.Store
Paths_simplex_chat
hs-source-dirs:
tests
apps/simplex-broadcast-bot/src
apps/simplex-directory-service/src
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
build-depends:
aeson ==2.0.*

27
src/Simplex/Chat.hs
View file

@ -332,7 +332,13 @@ execChatCommand s = do
u <- readTVarIO =<< asks currentUser
case parseChatCommand s of
Left e -> pure $ chatCmdError u e
Right cmd -> either (CRChatCmdError u) id <$> runExceptT (processChatCommand cmd)
Right cmd -> execChatCommand_ u cmd
execChatCommand' :: ChatMonad' m => ChatCommand -> m ChatResponse
execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd)
execChatCommand_ :: ChatMonad' m => Maybe User -> ChatCommand -> m ChatResponse
execChatCommand_ u cmd = either (CRChatCmdError u) id <$> runExceptT (processChatCommand cmd)
parseChatCommand :: ByteString -> Either String ChatCommand
parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace
@ -1486,8 +1492,11 @@ processChatCommand = \case
ListMembers gName -> withUser $ \user -> do
groupId <- withStore $ \db -> getGroupIdByName db user gName
processChatCommand $ APIListMembers groupId
ListGroups -> withUser $ \user ->
CRGroupsList user <$> withStore' (`getUserGroupDetails` user)
APIListGroups userId contactId_ search_ -> withUserId userId $ \user ->
CRGroupsList user <$> withStore' (\db -> getUserGroupDetails db user contactId_ search_)
ListGroups cName_ search_ -> withUser $ \user@User {userId} -> do
ct_ <- forM cName_ $ \cName -> withStore $ \db -> getContactByName db user cName
processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_
APIUpdateGroupProfile groupId p' -> withUser $ \user -> do
g <- withStore $ \db -> getGroup db user groupId
runUpdateGroupProfile user g p'
@ -1497,6 +1506,8 @@ processChatCommand = \case
CRGroupProfile user <$> withStore (\db -> getGroupInfoByName db user gName)
UpdateGroupDescription gName description ->
updateGroupProfileByName gName $ \p -> p {description}
ShowGroupDescription gName -> withUser $ \user ->
CRGroupDescription user <$> withStore (\db -> getGroupInfoByName db user gName)
APICreateGroupLink groupId mRole -> withUser $ \user -> withChatLock "createGroupLink" $ do
gInfo <- withStore $ \db -> getGroupInfo db user groupId
assertUserGroupRole gInfo GRAdmin
@ -2534,7 +2545,7 @@ expireChatItems user@User {userId} ttl sync = do
createdAtCutoff = addUTCTime (-43200 :: NominalDiffTime) currentTs
contacts <- withStoreCtx' (Just "expireChatItems, getUserContacts") (`getUserContacts` user)
loop contacts $ processContact expirationDate
groups <- withStoreCtx' (Just "expireChatItems, getUserGroupDetails") (`getUserGroupDetails` user)
groups <- withStoreCtx' (Just "expireChatItems, getUserGroupDetails") (\db -> getUserGroupDetails db user Nothing Nothing)
loop groups $ processGroup expirationDate createdAtCutoff
where
loop :: [a] -> (a -> m ()) -> m ()
@ -3954,7 +3965,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta content
withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci)
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
toView $ CRReceivedGroupInvitation user gInfo ct memRole
toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole}
whenContactNtfs user ct $
showToast ("#" <> localDisplayName <> " " <> c <> "> ") "invited you to join the group"
where
@ -5128,11 +5139,15 @@ chatCommandP =
"/clear #" *> (ClearGroup <$> displayName),
"/clear " *> char_ '@' *> (ClearContact <$> displayName),
("/members " <|> "/ms ") *> char_ '#' *> (ListMembers <$> displayName),
("/groups" <|> "/gs") $> ListGroups,
"/_groups" *> (APIListGroups <$> A.decimal <*> optional (" @" *> A.decimal) <*> optional (A.space *> stringP)),
("/groups" <|> "/gs") *> (ListGroups <$> optional (" @" *> displayName) <*> optional (A.space *> stringP)),
"/_group_profile #" *> (APIUpdateGroupProfile <$> A.decimal <* A.space <*> jsonP),
("/group_profile " <|> "/gp ") *> char_ '#' *> (UpdateGroupNames <$> displayName <* A.space <*> groupProfile),
("/group_profile " <|> "/gp ") *> char_ '#' *> (ShowGroupProfile <$> displayName),
"/group_descr " *> char_ '#' *> (UpdateGroupDescription <$> displayName <*> optional (A.space *> msgTextP)),
"/set welcome " *> char_ '#' *> (UpdateGroupDescription <$> displayName <* A.space <*> (Just <$> msgTextP)),
"/delete welcome " *> char_ '#' *> (UpdateGroupDescription <$> displayName <*> pure Nothing),
"/show welcome " *> char_ '#' *> (ShowGroupDescription <$> displayName),
"/_create link #" *> (APICreateGroupLink <$> A.decimal <*> (memberRole <|> pure GRMember)),
"/_set link role #" *> (APIGroupLinkMemberRole <$> A.decimal <*> memberRole),
"/_delete link #" *> (APIDeleteGroupLink <$> A.decimal),

35
src/Simplex/Chat/Bot.hs
View file

@ -9,9 +9,7 @@ module Simplex.Chat.Bot where
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad.Reader
import qualified Data.Aeson as J
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import qualified Data.Text as T
import Simplex.Chat.Controller
import Simplex.Chat.Core
@ -19,9 +17,8 @@ import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Protocol (MsgContent (..))
import Simplex.Chat.Store
import Simplex.Chat.Types (Contact (..), IsContact (..), User (..))
import Simplex.Chat.Types (Contact (..), ContactId, IsContact (..), User (..))
import Simplex.Messaging.Encoding.String (strEncode)
import Simplex.Messaging.Util (safeDecodeUtf8)
import System.Exit (exitFailure)
chatBotRepl :: String -> (Contact -> String -> IO String) -> User -> ChatController -> IO ()
@ -32,49 +29,55 @@ chatBotRepl welcome answer _user cc = do
case resp of
CRContactConnected _ contact _ -> do
contactConnected contact
void $ sendMsg contact welcome
void $ sendMessage cc contact welcome
CRNewChatItem _ (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content = mc@CIRcvMsgContent {}}) -> do
let msg = T.unpack $ ciContentToText mc
void $ sendMsg contact =<< answer contact msg
void $ sendMessage cc contact =<< answer contact msg
_ -> pure ()
where
sendMsg Contact {contactId} msg = sendChatCmd cc $ "/_send @" <> show contactId <> " text " <> msg
contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected"
initializeBotAddress :: ChatController -> IO ()
initializeBotAddress cc = do
sendChatCmd cc "/show_address" >>= \case
sendChatCmd cc ShowMyAddress >>= \case
CRUserContactLink _ UserContactLink {connReqContact} -> showBotAddress connReqContact
CRChatCmdError _ (ChatErrorStore SEUserContactLinkNotFound) -> do
putStrLn "No bot address, creating..."
sendChatCmd cc "/address" >>= \case
sendChatCmd cc CreateMyAddress >>= \case
CRUserContactLinkCreated _ uri -> showBotAddress uri
_ -> putStrLn "can't create bot address" >> exitFailure
_ -> putStrLn "unexpected response" >> exitFailure
where
showBotAddress uri = do
putStrLn $ "Bot's contact address is: " <> B.unpack (strEncode uri)
void $ sendChatCmd cc "/auto_accept on"
void $ sendChatCmd cc $ AddressAutoAccept $ Just AutoAccept {acceptIncognito = False, autoReply = Nothing}
sendMessage :: ChatController -> Contact -> String -> IO ()
sendMessage cc ct = sendComposedMessage cc ct Nothing . textMsgContent
sendMessage' :: ChatController -> ContactId -> String -> IO ()
sendMessage' cc ctId = sendComposedMessage' cc ctId Nothing . textMsgContent
sendComposedMessage :: ChatController -> Contact -> Maybe ChatItemId -> MsgContent -> IO ()
sendComposedMessage cc ct quotedItemId msgContent = do
sendComposedMessage cc = sendComposedMessage' cc . contactId'
sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO ()
sendComposedMessage' cc ctId quotedItemId msgContent = do
let cm = ComposedMessage {filePath = Nothing, quotedItemId, msgContent}
sendChatCmd cc ("/_send @" <> show (contactId' ct) <> " json " <> jsonEncode cm) >>= \case
CRNewChatItem {} -> printLog cc CLLInfo $ "sent message to " <> contactInfo ct
sendChatCmd cc (APISendMessage (ChatRef CTDirect ctId) False Nothing cm) >>= \case
CRNewChatItem {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId
r -> putStrLn $ "unexpected send message response: " <> show r
where
jsonEncode = T.unpack . safeDecodeUtf8 . LB.toStrict . J.encode
deleteMessage :: ChatController -> Contact -> ChatItemId -> IO ()
deleteMessage cc ct chatItemId = do
let cmd = "/_delete item @" <> show (contactId' ct) <> " " <> show chatItemId <> " internal"
let cmd = APIDeleteChatItem (contactRef ct) chatItemId CIDMInternal
sendChatCmd cc cmd >>= \case
CRChatItemDeleted {} -> printLog cc CLLInfo $ "deleted message from " <> contactInfo ct
r -> putStrLn $ "unexpected delete message response: " <> show r
contactRef :: Contact -> ChatRef
contactRef = ChatRef CTDirect . contactId'
textMsgContent :: String -> MsgContent
textMsgContent = MCText . T.pack

33
src/Simplex/Chat/Bot/KnownContacts.hs Normal file
View file

@ -0,0 +1,33 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Chat.Bot.KnownContacts where
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Int (Int64)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text as T
import Options.Applicative
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Util (safeDecodeUtf8)
data KnownContact = KnownContact
{ contactId :: Int64,
localDisplayName :: Text
}
deriving (Eq)
knownContactNames :: [KnownContact] -> String
knownContactNames = T.unpack . T.intercalate ", " . map (("@" <>) . localDisplayName)
parseKnownContacts :: ReadM [KnownContact]
parseKnownContacts = eitherReader $ parseAll knownContactsP . encodeUtf8 . T.pack
knownContactsP :: A.Parser [KnownContact]
knownContactsP = contactP `A.sepBy1` A.char ','
where
contactP = do
contactId <- A.decimal <* A.char ':'
localDisplayName <- safeDecodeUtf8 <$> A.takeTill (A.inClass ", ")
pure KnownContact {contactId, localDisplayName}

7
src/Simplex/Chat/Controller.hs
View file

@ -362,10 +362,12 @@ data ChatCommand
| DeleteGroup GroupName
| ClearGroup GroupName
| ListMembers GroupName
| ListGroups -- UserId (not used in UI)
| APIListGroups UserId (Maybe ContactId) (Maybe String)
| ListGroups (Maybe ContactName) (Maybe String)
| UpdateGroupNames GroupName GroupProfile
| ShowGroupProfile GroupName
| UpdateGroupDescription GroupName (Maybe Text)
| ShowGroupDescription GroupName
| CreateGroupLink GroupName GroupMemberRole
| GroupLinkMemberRole GroupName GroupMemberRole
| DeleteGroupLink GroupName
@ -518,7 +520,7 @@ data ChatResponse
| CRHostConnected {protocol :: AProtocolType, transportHost :: TransportHost}
| CRHostDisconnected {protocol :: AProtocolType, transportHost :: TransportHost}
| CRGroupInvitation {user :: User, groupInfo :: GroupInfo}
| CRReceivedGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, memberRole :: GroupMemberRole}
| CRReceivedGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole}
| CRUserJoinedGroup {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember}
| CRJoinedGroupMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
| CRJoinedGroupMemberConnecting {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember, member :: GroupMember}
@ -533,6 +535,7 @@ data ChatResponse
| CRGroupDeleted {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
| CRGroupUpdated {user :: User, fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember}
| CRGroupProfile {user :: User, groupInfo :: GroupInfo}
| CRGroupDescription {user :: User, groupInfo :: GroupInfo} -- only used in CLI
| CRGroupLinkCreated {user :: User, groupInfo :: GroupInfo, connReqContact :: ConnReqContact, memberRole :: GroupMemberRole}
| CRGroupLink {user :: User, groupInfo :: GroupInfo, connReqContact :: ConnReqContact, memberRole :: GroupMemberRole}
| CRGroupLinkDeleted {user :: User, groupInfo :: GroupInfo}

7
src/Simplex/Chat/Core.hs
View file

@ -39,5 +39,8 @@ runSimplexChat ChatOpts {maintenance} u cc chat
a2 <- async $ chat u cc
waitEither_ a1 a2
sendChatCmd :: ChatController -> String -> IO ChatResponse
sendChatCmd cc s = runReaderT (execChatCommand . encodeUtf8 $ T.pack s) cc
sendChatCmdStr :: ChatController -> String -> IO ChatResponse
sendChatCmdStr cc s = runReaderT (execChatCommand . encodeUtf8 $ T.pack s) cc
sendChatCmd :: ChatController -> ChatCommand -> IO ChatResponse
sendChatCmd cc cmd = runReaderT (execChatCommand' cmd) cc

9
src/Simplex/Chat/Store/Groups.hs
View file

@ -448,8 +448,8 @@ getUserGroups db user@User {userId} = do
groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ?" (Only userId)
rights <$> mapM (runExceptT . getGroup db user) groupIds
getUserGroupDetails :: DB.Connection -> User -> IO [GroupInfo]
getUserGroupDetails db User {userId, userContactId} =
getUserGroupDetails :: DB.Connection -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo]
getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
map (toGroupInfo userContactId)
<$> DB.query
db
@ -462,8 +462,11 @@ getUserGroupDetails db User {userId, userContactId} =
JOIN group_members mu USING (group_id)
JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id)
WHERE g.user_id = ? AND mu.contact_id = ?
AND (gp.display_name LIKE '%' || ? || '%' OR gp.full_name LIKE '%' || ? || '%' OR gp.description LIKE '%' || ? || '%')
|]
(userId, userContactId)
(userId, userContactId, search, search, search)
where
search = fromMaybe "" search_
getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [FullGroupPreferences]
getContactGroupPreferences db User {userId} Contact {contactId} = do

7
src/Simplex/Chat/View.hs
View file

@ -200,7 +200,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
addressSS UserContactSubStatus {userContactError} = maybe ("Your address is active! To show: " <> highlight' "/sa") (\e -> "User address error: " <> sShow e <> ", to delete your address: " <> highlight' "/da") userContactError
(groupLinkErrors, groupLinksSubscribed) = partition (isJust . userContactError) groupLinks
CRGroupInvitation u g -> ttyUser u [groupInvitation' g]
CRReceivedGroupInvitation u g c role -> ttyUser u $ viewReceivedGroupInvitation g c role
CRReceivedGroupInvitation {user = u, groupInfo = g, contact = c, memberRole = r} -> ttyUser u $ viewReceivedGroupInvitation g c r
CRUserJoinedGroup u g _ -> ttyUser u $ viewUserJoinedGroup g
CRJoinedGroupMember u g m -> ttyUser u $ viewJoinedGroupMember g m
CRHostConnected p h -> [plain $ "connected to " <> viewHostEvent p h]
@ -217,6 +217,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
CRGroupDeleted u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> groupName' g) <> " to delete the local copy of the group"]
CRGroupUpdated u g g' m -> ttyUser u $ viewGroupUpdated g g' m
CRGroupProfile u g -> ttyUser u $ viewGroupProfile g
CRGroupDescription u g -> ttyUser u $ viewGroupDescription g
CRGroupLinkCreated u g cReq mRole -> ttyUser u $ groupLink_ "Group link is created!" g cReq mRole
CRGroupLink u g cReq mRole -> ttyUser u $ groupLink_ "Group link:" g cReq mRole
CRGroupLinkDeleted u g -> ttyUser u $ viewGroupLinkDeleted g
@ -1135,6 +1136,10 @@ viewGroupProfile g@GroupInfo {groupProfile = GroupProfile {description, image, g
where
pref = getGroupPreference f . mergeGroupPreferences
viewGroupDescription :: GroupInfo -> [StyledString]
viewGroupDescription GroupInfo {groupProfile = GroupProfile {description}} =
maybe ["No welcome message!"] ((bold' "Welcome message:" :) . map plain . T.lines) description
bold' :: String -> StyledString
bold' = styled Bold

76
tests/Bots/BroadcastTests.hs Normal file
View file

@ -0,0 +1,76 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Bots.BroadcastTests where
import Broadcast.Bot
import Broadcast.Options
import ChatClient
import ChatTests.Utils
import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Exception (bracket)
import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Core
import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
import Simplex.Chat.Types (Profile (..))
import System.FilePath ((</>))
import Test.Hspec
broadcastBotTests :: SpecWith FilePath
broadcastBotTests = do
it "should broadcast message" testBroadcastMessages
withBroadcastBot :: BroadcastBotOpts -> IO () -> IO ()
withBroadcastBot opts test =
bracket (forkIO bot) killThread (\_ -> threadDelay 500000 >> test)
where
bot = simplexChatCore testCfg (mkChatOpts opts) Nothing $ broadcastBot opts
broadcastBotProfile :: Profile
broadcastBotProfile = Profile {displayName = "broadcast_bot", fullName = "Broadcast Bot", image = Nothing, contactLink = Nothing, preferences = Nothing}
mkBotOpts :: FilePath -> [KnownContact] -> BroadcastBotOpts
mkBotOpts tmp publishers =
BroadcastBotOpts
{ coreOptions = (coreOptions (testOpts :: ChatOpts)) {dbFilePrefix = tmp </> botDbPrefix},
publishers,
welcomeMessage = defaultWelcomeMessage publishers,
prohibitedMessage = defaultWelcomeMessage publishers
}
botDbPrefix :: FilePath
botDbPrefix = "broadcast_bot"
testBroadcastMessages :: HasCallStack => FilePath -> IO ()
testBroadcastMessages tmp = do
botLink <-
withNewTestChat tmp botDbPrefix broadcastBotProfile $ \bc_bot ->
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
connectUsers bc_bot alice
bc_bot ##> "/ad"
getContactLink bc_bot True
let botOpts = mkBotOpts tmp [KnownContact 2 "alice"]
withBroadcastBot botOpts $
withTestChat tmp "alice" $ \alice ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
alice <## "1 contacts connected (use /cs for the list)"
bob `connectVia` botLink
bob #> "@broadcast_bot hello"
bob <# "broadcast_bot> > hello"
bob <## " Hello! I am a broadcast bot."
bob <## "I broadcast messages to all connected users from @alice."
cath `connectVia` botLink
alice #> "@broadcast_bot hello all!"
bob <# "broadcast_bot> hello all!"
cath <# "broadcast_bot> hello all!"
alice <# "broadcast_bot> > hello all!"
alice <## " Forwarded to 2 contact(s)"
where
cc `connectVia` botLink = do
cc ##> ("/c " <> botLink)
cc <## "connection request sent!"
cc <## "broadcast_bot (Broadcast Bot): contact is connected"
cc <# "broadcast_bot> Hello! I am a broadcast bot."
cc <## "I broadcast messages to all connected users from @alice."

456
tests/Bots/DirectoryTests.hs Normal file
View file

@ -0,0 +1,456 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PostfixOperators #-}
module Bots.DirectoryTests where
import ChatClient
import ChatTests.Utils
import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Exception (finally)
import Directory.Options
import Directory.Service
import Directory.Store
import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Core
import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
import Simplex.Chat.Types (Profile (..), GroupMemberRole (GROwner))
import System.FilePath ((</>))
import Test.Hspec
directoryServiceTests :: SpecWith FilePath
directoryServiceTests = do
it "should register group" testDirectoryService
describe "de-listing the group" $ do
it "should de-list if owner leaves the group" testDelistedOwnerLeaves
it "should de-list if owner is removed from the group" testDelistedOwnerRemoved
it "should NOT de-list if another member leaves the group" testNotDelistedMemberLeaves
it "should NOT de-list if another member is removed from the group" testNotDelistedMemberRemoved
it "should de-list if service is removed from the group" testDelistedServiceRemoved
describe "should require re-approval if profile is changed by" $ do
it "the registration owner" testRegOwnerChangedProfile
it "another owner" testAnotherOwnerChangedProfile
describe "should require profile update if group link is removed by " $ do
it "the registration owner" testRegOwnerRemovedLink
it "another owner" testAnotherOwnerRemovedLink
directoryProfile :: Profile
directoryProfile = Profile {displayName = "SimpleX-Directory", fullName = "", image = Nothing, contactLink = Nothing, preferences = Nothing}
mkDirectoryOpts :: FilePath -> [KnownContact] -> DirectoryOpts
mkDirectoryOpts tmp superUsers =
DirectoryOpts
{ coreOptions = (coreOptions (testOpts :: ChatOpts)) {dbFilePrefix = tmp </> serviceDbPrefix},
superUsers,
directoryLog = tmp </> "directory_service.log",
serviceName = "SimpleX-Directory"
}
serviceDbPrefix :: FilePath
serviceDbPrefix = "directory_service"
testDirectoryService :: HasCallStack => FilePath -> IO ()
testDirectoryService tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
bob #> "@SimpleX-Directory privacy"
bob <# "SimpleX-Directory> > privacy"
bob <## " No groups found"
putStrLn "*** create a group"
bob ##> "/g PSA Privacy, Security & Anonymity"
bob <## "group #PSA (Privacy, Security & Anonymity) is created"
bob <## "to add members use /a PSA <name> or /create link #PSA"
bob ##> "/a PSA SimpleX-Directory member"
bob <## "invitation to join the group #PSA sent to SimpleX-Directory"
bob <# "SimpleX-Directory> You must grant directory service admin role to register the group"
bob ##> "/mr PSA SimpleX-Directory admin"
putStrLn "*** discover service joins group and creates the link for profile"
bob <## "#PSA: you changed the role of SimpleX-Directory from member to admin"
bob <# "SimpleX-Directory> Joining the group #PSA…"
bob <## "#PSA: SimpleX-Directory joined the group"
bob <# "SimpleX-Directory> Joined the group #PSA, creating the link…"
bob <# "SimpleX-Directory> Created the public link to join the group via this directory service that is always online."
bob <## ""
bob <## "Please add it to the group welcome message."
bob <## "For example, add:"
welcomeWithLink <- dropStrPrefix "SimpleX-Directory> " . dropTime <$> getTermLine bob
putStrLn "*** update profile without link"
updateGroupProfile bob "Welcome!"
bob <# "SimpleX-Directory> The profile updated for ID 1 (PSA), but the group link is not added to the welcome message."
(superUser </)
putStrLn "*** update profile so that it has link"
updateGroupProfile bob welcomeWithLink
bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (PSA) is added to the welcome message."
bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
approvalRequested superUser welcomeWithLink (1 :: Int)
putStrLn "*** update profile so that it still has link"
let welcomeWithLink' = "Welcome! " <> welcomeWithLink
updateGroupProfile bob welcomeWithLink'
bob <# "SimpleX-Directory> The group ID 1 (PSA) is updated!"
bob <## "It is hidden from the directory until approved."
superUser <# "SimpleX-Directory> The group ID 1 (PSA) is updated."
approvalRequested superUser welcomeWithLink' (2 :: Int)
putStrLn "*** try approving with the old registration code"
superUser #> "@SimpleX-Directory /approve 1:PSA 1"
superUser <# "SimpleX-Directory> > /approve 1:PSA 1"
superUser <## " Incorrect approval code"
putStrLn "*** update profile so that it has no link"
updateGroupProfile bob "Welcome!"
bob <# "SimpleX-Directory> The group link for ID 1 (PSA) is removed from the welcome message."
bob <## ""
bob <## "The group is hidden from the directory until the group link is added and the group is re-approved."
superUser <# "SimpleX-Directory> The group link is removed from ID 1 (PSA), de-listed."
superUser #> "@SimpleX-Directory /approve 1:PSA 2"
superUser <# "SimpleX-Directory> > /approve 1:PSA 2"
superUser <## " Error: the group ID 1 (PSA) is not pending approval."
putStrLn "*** update profile so that it has link again"
updateGroupProfile bob welcomeWithLink'
bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (PSA) is added to the welcome message."
bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
approvalRequested superUser welcomeWithLink' (1 :: Int)
superUser #> "@SimpleX-Directory /approve 1:PSA 1"
superUser <# "SimpleX-Directory> > /approve 1:PSA 1"
superUser <## " Group approved!"
bob <# "SimpleX-Directory> The group ID 1 (PSA) is approved and listed in directory!"
bob <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved."
search bob "privacy" welcomeWithLink'
search bob "security" welcomeWithLink'
cath `connectVia` dsLink
search cath "privacy" welcomeWithLink'
where
search u s welcome = do
u #> ("@SimpleX-Directory " <> s)
u <# ("SimpleX-Directory> > " <> s)
u <## " Found 1 group(s)"
u <# "SimpleX-Directory> PSA (Privacy, Security & Anonymity)"
u <## "Welcome message:"
u <## welcome
updateGroupProfile u welcome = do
u ##> ("/set welcome #PSA " <> welcome)
u <## "description changed to:"
u <## welcome
approvalRequested su welcome grId = do
su <# "SimpleX-Directory> bob submitted the group ID 1: PSA (Privacy, Security & Anonymity)"
su <## "Welcome message:"
su <## welcome
su <## ""
su <## "To approve send:"
su <# ("SimpleX-Directory> /approve 1:PSA " <> show grId)
testDelistedOwnerLeaves :: HasCallStack => FilePath -> IO ()
testDelistedOwnerLeaves tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
leaveGroup "privacy" bob
cath <## "#privacy: bob left the group"
bob <# "SimpleX-Directory> You left the group ID 1 (privacy)."
bob <## ""
bob <## "Group is no longer listed in the directory."
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (group owner left)."
groupNotFound cath "privacy"
testDelistedOwnerRemoved :: HasCallStack => FilePath -> IO ()
testDelistedOwnerRemoved tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob ->
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
removeMember "privacy" cath bob
bob <# "SimpleX-Directory> You are removed from the group ID 1 (privacy)."
bob <## ""
bob <## "Group is no longer listed in the directory."
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (group owner is removed)."
groupNotFound cath "privacy"
testNotDelistedMemberLeaves :: HasCallStack => FilePath -> IO ()
testNotDelistedMemberLeaves tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
leaveGroup "privacy" cath
bob <## "#privacy: cath left the group"
(superUser </)
groupFound cath "privacy"
testNotDelistedMemberRemoved :: HasCallStack => FilePath -> IO ()
testNotDelistedMemberRemoved tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
removeMember "privacy" bob cath
(superUser </)
groupFound cath "privacy"
testDelistedServiceRemoved :: HasCallStack => FilePath -> IO ()
testDelistedServiceRemoved tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
bob ##> "/rm #privacy SimpleX-Directory"
bob <## "#privacy: you removed SimpleX-Directory from the group"
cath <## "#privacy: bob removed SimpleX-Directory from the group"
bob <# "SimpleX-Directory> SimpleX-Directory is removed from the group ID 1 (privacy)."
bob <## ""
bob <## "Group is no longer listed in the directory."
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (directory service is removed)."
groupNotFound cath "privacy"
testRegOwnerChangedProfile :: HasCallStack => FilePath -> IO ()
testRegOwnerChangedProfile tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
bob ##> "/gp privacy privacy Privacy and Security"
bob <## "full name changed to: Privacy and Security"
bob <# "SimpleX-Directory> The group ID 1 (privacy) is updated!"
bob <## "It is hidden from the directory until approved."
cath <## "bob updated group #privacy:"
cath <## "full name changed to: Privacy and Security"
groupNotFound cath "privacy"
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated."
reapproveGroup superUser bob
groupFound cath "privacy"
testAnotherOwnerChangedProfile :: HasCallStack => FilePath -> IO ()
testAnotherOwnerChangedProfile tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
cath ##> "/gp privacy privacy Privacy and Security"
cath <## "full name changed to: Privacy and Security"
bob <## "cath updated group #privacy:"
bob <## "full name changed to: Privacy and Security"
bob <# "SimpleX-Directory> The group ID 1 (privacy) is updated!"
bob <## "It is hidden from the directory until approved."
groupNotFound cath "privacy"
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated."
reapproveGroup superUser bob
groupFound cath "privacy"
testRegOwnerRemovedLink :: HasCallStack => FilePath -> IO ()
testRegOwnerRemovedLink tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
bob ##> "/show welcome #privacy"
bob <## "Welcome message:"
welcomeWithLink <- getTermLine bob
bob ##> "/set welcome #privacy Welcome!"
bob <## "description changed to:"
bob <## "Welcome!"
bob <# "SimpleX-Directory> The group link for ID 1 (privacy) is removed from the welcome message."
bob <## ""
bob <## "The group is hidden from the directory until the group link is added and the group is re-approved."
cath <## "bob updated group #privacy:"
cath <## "description changed to:"
cath <## "Welcome!"
superUser <# "SimpleX-Directory> The group link is removed from ID 1 (privacy), de-listed."
groupNotFound cath "privacy"
bob ##> ("/set welcome #privacy " <> welcomeWithLink)
bob <## "description changed to:"
bob <## welcomeWithLink
bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (privacy) is added to the welcome message."
bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
cath <## "bob updated group #privacy:"
cath <## "description changed to:"
cath <## welcomeWithLink
reapproveGroup superUser bob
groupFound cath "privacy"
testAnotherOwnerRemovedLink :: HasCallStack => FilePath -> IO ()
testAnotherOwnerRemovedLink tmp =
withDirectoryService tmp $ \superUser dsLink ->
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
bob ##> "/show welcome #privacy"
bob <## "Welcome message:"
welcomeWithLink <- getTermLine bob
cath ##> "/set welcome #privacy Welcome!"
cath <## "description changed to:"
cath <## "Welcome!"
bob <## "cath updated group #privacy:"
bob <## "description changed to:"
bob <## "Welcome!"
bob <# "SimpleX-Directory> The group link for ID 1 (privacy) is removed from the welcome message."
bob <## ""
bob <## "The group is hidden from the directory until the group link is added and the group is re-approved."
superUser <# "SimpleX-Directory> The group link is removed from ID 1 (privacy), de-listed."
groupNotFound cath "privacy"
cath ##> ("/set welcome #privacy " <> welcomeWithLink)
cath <## "description changed to:"
cath <## welcomeWithLink
bob <## "cath updated group #privacy:"
bob <## "description changed to:"
bob <## welcomeWithLink
bob <# "SimpleX-Directory> The group link is added by another group member, your registration will not be processed."
bob <## ""
bob <## "Please update the group profile yourself."
bob ##> ("/set welcome #privacy " <> welcomeWithLink <> " - welcome!")
bob <## "description changed to:"
bob <## (welcomeWithLink <> " - welcome!")
bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (privacy) is added to the welcome message."
bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
cath <## "bob updated group #privacy:"
cath <## "description changed to:"
cath <## (welcomeWithLink <> " - welcome!")
reapproveGroup superUser bob
groupFound cath "privacy"
reapproveGroup :: HasCallStack => TestCC -> TestCC -> IO ()
reapproveGroup superUser bob = do
superUser <#. "SimpleX-Directory> bob submitted the group ID 1: privacy ("
superUser <## "Welcome message:"
superUser <##. "Link to join the group privacy: "
superUser <## ""
superUser <## "To approve send:"
superUser <# "SimpleX-Directory> /approve 1:privacy 1"
superUser #> "@SimpleX-Directory /approve 1:privacy 1"
superUser <# "SimpleX-Directory> > /approve 1:privacy 1"
superUser <## " Group approved!"
bob <# "SimpleX-Directory> The group ID 1 (privacy) is approved and listed in directory!"
bob <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved."
addCathAsOwner :: HasCallStack => TestCC -> TestCC -> IO ()
addCathAsOwner bob cath = do
connectUsers bob cath
fullAddMember "privacy" "Privacy" bob cath GROwner
joinGroup "privacy" cath bob
cath <## "#privacy: member SimpleX-Directory is connected"
withDirectoryService :: HasCallStack => FilePath -> (TestCC -> String -> IO ()) -> IO ()
withDirectoryService tmp test = do
dsLink <-
withNewTestChat tmp serviceDbPrefix directoryProfile $ \ds ->
withNewTestChat tmp "super_user" aliceProfile $ \superUser -> do
connectUsers ds superUser
ds ##> "/ad"
getContactLink ds True
let opts = mkDirectoryOpts tmp [KnownContact 2 "alice"]
withDirectory opts $
withTestChat tmp "super_user" $ \superUser -> do
superUser <## "1 contacts connected (use /cs for the list)"
test superUser dsLink
where
withDirectory :: DirectoryOpts -> IO () -> IO ()
withDirectory opts@DirectoryOpts {directoryLog} action = do
st <- getDirectoryStore directoryLog
t <- forkIO $ bot st
threadDelay 500000
action `finally` killThread t
where
bot st = simplexChatCore testCfg (mkChatOpts opts) Nothing $ directoryService st opts
registerGroup :: TestCC -> TestCC -> String -> String -> IO ()
registerGroup su u n fn = do
u ##> ("/g " <> n <> " " <> fn)
u <## ("group #" <> n <> " (" <> fn <> ") is created")
u <## ("to add members use /a " <> n <> " <name> or /create link #" <> n)
u ##> ("/a " <> n <> " SimpleX-Directory admin")
u <## ("invitation to join the group #" <> n <> " sent to SimpleX-Directory")
u <# ("SimpleX-Directory> Joining the group #" <> n <> "…")
u <## ("#" <> n <> ": SimpleX-Directory joined the group")
u <# ("SimpleX-Directory> Joined the group #" <> n <> ", creating the link…")
u <# "SimpleX-Directory> Created the public link to join the group via this directory service that is always online."
u <## ""
u <## "Please add it to the group welcome message."
u <## "For example, add:"
welcomeWithLink <- dropStrPrefix "SimpleX-Directory> " . dropTime <$> getTermLine u
u ##> ("/set welcome " <> n <> " " <> welcomeWithLink)
u <## "description changed to:"
u <## welcomeWithLink
u <# ("SimpleX-Directory> Thank you! The group link for ID 1 (" <> n <> ") is added to the welcome message.")
u <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
su <# ("SimpleX-Directory> bob submitted the group ID 1: " <> n <> " (" <> fn <> ")")
su <## "Welcome message:"
su <## welcomeWithLink
su <## ""
su <## "To approve send:"
let approve = "/approve 1:" <> n <> " 1"
su <# ("SimpleX-Directory> " <> approve)
su #> ("@SimpleX-Directory " <> approve)
su <# ("SimpleX-Directory> > " <> approve)
su <## " Group approved!"
u <# ("SimpleX-Directory> The group ID 1 (" <> n <> ") is approved and listed in directory!")
u <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved."
connectVia :: TestCC -> String -> IO ()
u `connectVia` dsLink = do
u ##> ("/c " <> dsLink)
u <## "connection request sent!"
u <## "SimpleX-Directory: contact is connected"
u <# "SimpleX-Directory> Welcome to SimpleX-Directory service!"
u <## "Send a search string to find groups or /help to learn how to add groups to directory."
u <## ""
u <## "For example, send privacy to find groups about privacy."
joinGroup :: String -> TestCC -> TestCC -> IO ()
joinGroup gName member host = do
let gn = "#" <> gName
memberName <- userName member
hostName <- userName host
member ##> ("/j " <> gName)
member <## (gn <> ": you joined the group")
member <#. (gn <> " " <> hostName <> "> Link to join the group " <> gName <> ": ")
host <## (gn <> ": " <> memberName <> " joined the group")
leaveGroup :: String -> TestCC -> IO ()
leaveGroup gName member = do
let gn = "#" <> gName
member ##> ("/l " <> gName)
member <## (gn <> ": you left the group")
member <## ("use /d " <> gn <> " to delete the group")
removeMember :: String -> TestCC -> TestCC -> IO ()
removeMember gName admin removed = do
let gn = "#" <> gName
adminName <- userName admin
removedName <- userName removed
admin ##> ("/rm " <> gName <> " " <> removedName)
admin <## (gn <> ": you removed " <> removedName <> " from the group")
removed <## (gn <> ": " <> adminName <> " removed you from the group")
removed <## ("use /d " <> gn <> " to delete the group")
groupFound :: TestCC -> String -> IO ()
groupFound u s = do
u #> ("@SimpleX-Directory " <> s)
u <# ("SimpleX-Directory> > " <> s)
u <## " Found 1 group(s)"
u <#. "SimpleX-Directory> privacy ("
u <## "Welcome message:"
u <##. "Link to join the group privacy: "
groupNotFound :: TestCC -> String -> IO ()
groupNotFound u s = do
u #> ("@SimpleX-Directory " <> s)
u <# ("SimpleX-Directory> > " <> s)
u <## " No groups found"

23
tests/ChatTests/Utils.hs
View file

@ -48,9 +48,15 @@ xit' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
xit' = if os == "linux" then xit else it
xit'' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
xit'' d t = do
xit'' = ifCI xit it
xdescribe'' :: HasCallStack => String -> SpecWith a -> SpecWith a
xdescribe'' = ifCI xdescribe describe
ifCI :: HasCallStack => (HasCallStack => String -> a -> SpecWith b) -> (HasCallStack => String -> a -> SpecWith b) -> String -> a -> SpecWith b
ifCI xrun run d t = do
ci <- runIO $ lookupEnv "CI"
(if ci == Just "true" then xit else it) d t
(if ci == Just "true" then xrun else run) d t
versionTestMatrix2 :: (HasCallStack => TestCC -> TestCC -> IO ()) -> SpecWith FilePath
versionTestMatrix2 runTest = do
@ -349,6 +355,11 @@ dropTime_ msg = case splitAt 6 msg of
if all isDigit [m, m', s, s'] then Just text else Nothing
_ -> Nothing
dropStrPrefix :: HasCallStack => String -> String -> String
dropStrPrefix pfx s =
let (p, rest) = splitAt (length pfx) s
in if p == pfx then rest else error $ "no prefix " <> pfx <> " in string : " <> s
dropReceipt :: HasCallStack => String -> String
dropReceipt msg = fromMaybe err $ dropReceipt_ msg
where
@ -475,14 +486,18 @@ createGroup3 gName cc1 cc2 cc3 = do
]
addMember :: HasCallStack => String -> TestCC -> TestCC -> GroupMemberRole -> IO ()
addMember gName inviting invitee role = do
addMember gName = fullAddMember gName ""
fullAddMember :: HasCallStack => String -> String -> TestCC -> TestCC -> GroupMemberRole -> IO ()
fullAddMember gName fullName inviting invitee role = do
name1 <- userName inviting
memName <- userName invitee
inviting ##> ("/a " <> gName <> " " <> memName <> " " <> B.unpack (strEncode role))
let fullName' = if null fullName || fullName == gName then "" else " (" <> fullName <> ")"
concurrentlyN_
[ inviting <## ("invitation to join the group #" <> gName <> " sent to " <> memName),
do
invitee <## ("#" <> gName <> ": " <> name1 <> " invites you to join the group as " <> B.unpack (strEncode role))
invitee <## ("#" <> gName <> fullName' <> ": " <> name1 <> " invites you to join the group as " <> B.unpack (strEncode role))
invitee <## ("use /j " <> gName <> " to accept")
]

5
tests/Test.hs
View file

@ -1,5 +1,8 @@
import Bots.BroadcastTests
import Bots.DirectoryTests
import ChatClient
import ChatTests
import ChatTests.Utils (xdescribe'')
import Control.Logger.Simple
import Data.Time.Clock.System
import MarkdownTests
@ -23,6 +26,8 @@ main = do
around testBracket $ do
describe "Mobile API Tests" mobileTests
describe "SimpleX chat client" chatTests
xdescribe'' "SimpleX Broadcast bot" broadcastBotTests
xdescribe'' "SimpleX Directory service bot" directoryServiceTests
where
testBracket test = do
t <- getSystemTime