dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-08-21 19:00:01 +00:00
Code Issues Packages Projects Releases Wiki Activity

directory: implementation draft

Browse Source
This commit is contained in:
Evgeny @ SimpleX Chat
2026-08-02 11:14:57 +00:00
parent db0d6e2951
commit db1edeebbd
12 changed files with 1000 additions and 407 deletions
Download Patch File Download Diff File Expand all files Collapse all files
apps/simplex-directory-service/src/Directory/Events.hs
+52 -9
View File
@@ -61,6 +61,8 @@ data DirectoryEvent
| DEServiceRemovedFromGroup GroupInfo
| DEGroupDeleted GroupInfo
| DEChatLinkReceived {contact :: Contact, chatItemId :: ChatItemId, chatLink :: MsgChatLink, ownerSig :: Maybe LinkOwnerSig}
| DEContactLinkCheck Contact
| DEContactUpdated {fromContact :: Contact, toContact :: Contact}
| DEMemberUpdated {groupInfo :: GroupInfo, fromMember :: GroupMember, toMember :: GroupMember}
| DEUnsupportedMessage Contact ChatItemId
| DEItemEditIgnored Contact
@@ -80,6 +82,7 @@ crDirectoryEvent = \case
crDirectoryEvent_ :: ChatEvent -> Maybe DirectoryEvent
crDirectoryEvent_ = \case
CEvtContactConnected {contact} -> Just $ DEContactConnected contact
CEvtContactUpdated {fromContact, toContact} -> Just $ DEContactUpdated {fromContact, toContact}
CEvtReceivedGroupInvitation {contact, groupInfo, fromMemberRole, memberRole} -> Just $ DEGroupInvitation {contact, groupInfo, fromMemberRole, memberRole}
CEvtUserJoinedGroup {groupInfo, hostMember} -> (\contactId -> DEServiceJoinedGroup {contactId, groupInfo, hostMember}) <$> memberContactId hostMember
CEvtGroupUpdated {fromGroup, toGroup, member_} -> (\member -> DEGroupUpdated {member, fromGroup, toGroup}) <$> member_
@@ -130,6 +133,7 @@ data DirectoryCmdTag (r :: DirectoryRole) where
DCSearchNext_ :: DirectoryCmdTag 'DRUser
DCAllGroups_ :: DirectoryCmdTag 'DRUser
DCRecentGroups_ :: DirectoryCmdTag 'DRUser
DCFindContacts_ :: DirectoryCmdTag 'DRUser
DCSubmitGroup_ :: DirectoryCmdTag 'DRUser
DCConfirmDuplicateGroup_ :: DirectoryCmdTag 'DRUser
DCListUserGroups_ :: DirectoryCmdTag 'DRUser
@@ -163,14 +167,19 @@ data DirectoryCmd (r :: DirectoryRole) where
DCSearchNext :: DirectoryCmd 'DRUser
DCAllGroups :: DirectoryCmd 'DRUser
DCRecentGroups :: DirectoryCmd 'DRUser
DCFindContacts :: ChatPeerType -> Maybe Text -> DirectoryCmd 'DRUser
DCSubmitGroup :: ConnReqContact -> DirectoryCmd 'DRUser
DCConfirmDuplicateGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser
DCListUserGroups :: DirectoryCmd 'DRUser
DCDeleteGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser
DCDeleteContact :: Maybe (ContactId, ContactName) -> DirectoryCmd 'DRUser
DCMemberRole :: UserGroupRegId -> Maybe GroupName -> Maybe GroupMemberRole -> DirectoryCmd 'DRUser
DCGroupFilter :: UserGroupRegId -> Maybe GroupName -> Maybe DirectoryMemberAcceptance -> DirectoryCmd 'DRUser
DCShowUpgradeGroupLink :: GroupId -> Maybe GroupName -> DirectoryCmd 'DRUser
DCApproveGroup :: {groupId :: GroupId, displayName :: GroupName, groupApprovalId :: GroupApprovalId, promote :: Maybe Bool} -> DirectoryCmd 'DRAdmin
DCApproveContact :: ContactId -> ContactName -> GroupApprovalId -> DirectoryCmd 'DRAdmin
DCSuspendContact :: ContactId -> ContactName -> DirectoryCmd 'DRAdmin
DCResumeContact :: ContactId -> ContactName -> DirectoryCmd 'DRAdmin
DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
@@ -181,6 +190,7 @@ data DirectoryCmd (r :: DirectoryRole) where
-- DCAddBlockedWord :: Text -> DirectoryCmd 'DRAdmin
-- DCRemoveBlockedWord :: Text -> DirectoryCmd 'DRAdmin
DCPromoteGroup :: GroupId -> GroupName -> Bool -> DirectoryCmd 'DRSuperUser
DCPromoteContact :: ContactId -> ContactName -> Bool -> DirectoryCmd 'DRSuperUser
DCExecuteCommand :: String -> DirectoryCmd 'DRSuperUser
DCUnknownCommand :: DirectoryCmd 'DRUser
DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r
@@ -207,6 +217,8 @@ directoryCmdP ft =
"next" -> u DCSearchNext_
"all" -> u DCAllGroups_
"new" -> u DCRecentGroups_
"find" -> u DCFindContacts_
"?" -> u DCFindContacts_
"submit" -> u DCSubmitGroup_
"confirm" -> u DCConfirmDuplicateGroup_
"list" -> u DCListUserGroups_
@@ -247,10 +259,20 @@ directoryCmdP ft =
DCSearchNext_ -> pure DCSearchNext
DCAllGroups_ -> pure DCAllGroups
DCRecentGroups_ -> pure DCRecentGroups
DCFindContacts_ -> do
_ <- A.takeWhile isSpace
pt <- (A.string "business" $> CPTBusiness) <|> (A.string "biz" $> CPTBusiness) <|> (A.string "bot" $> CPTBot)
search <- (spacesP *> (Just <$> A.takeText)) <|> pure Nothing
pure $ DCFindContacts pt search
DCSubmitGroup_ -> fmap DCSubmitGroup . strDecode . encodeUtf8 <$?> (spacesP *> A.takeText)
DCConfirmDuplicateGroup_ -> gc DCConfirmDuplicateGroup
DCListUserGroups_ -> pure DCListUserGroups
DCDeleteGroup_ -> gc DCDeleteGroup
DCDeleteGroup_ -> spacesP *> (contactDel <|> groupDel)
where
contactDel =
(A.char '@' *> (((\i n -> DCDeleteContact (Just (i, n))) <$> A.decimal <*> (A.char ':' *> displayNameTextP)) <|> pure (DCDeleteContact Nothing)))
<|> ((A.string "address" <|> A.string "addr") $> DCDeleteContact Nothing)
groupDel = DCDeleteGroup <$> A.decimal <*> (A.char ':' *> displayNameTextP)
DCMemberRole_ -> do
(groupId, displayName_) <- gc_ (,)
memberRole_ <- optional $ spacesP *> ("member" $> GRMember <|> "observer" $> GRObserver)
@@ -283,13 +305,19 @@ directoryCmdP ft =
<|> pure PCAll
DCShowUpgradeGroupLink_ -> gc_ DCShowUpgradeGroupLink
DCApproveGroup_ -> do
(groupId, displayName) <- gc (,)
groupApprovalId <- A.space *> A.decimal
promote <- Just <$> (" promote=" *> onOffP) <|> pure Nothing
pure DCApproveGroup {groupId, displayName, groupApprovalId, promote}
_ <- spacesP
addr <- (A.char '@' $> True) <|> pure False
theId <- A.decimal
displayName <- A.char ':' *> displayNameTextP
approvalId <- A.space *> A.decimal
if addr
then pure $ DCApproveContact theId displayName approvalId
else do
promote <- Just <$> (" promote=" *> onOffP) <|> pure Nothing
pure DCApproveGroup {groupId = theId, displayName, groupApprovalId = approvalId, promote}
DCRejectGroup_ -> gc DCRejectGroup
DCSuspendGroup_ -> gc DCSuspendGroup
DCResumeGroup_ -> gc DCResumeGroup
DCSuspendGroup_ -> gcOrAddr DCSuspendGroup DCSuspendContact
DCResumeGroup_ -> gcOrAddr DCResumeGroup DCResumeContact
DCListLastGroups_ -> DCListLastGroups <$> (A.space *> A.decimal <|> pure 10)
DCListPendingGroups_ -> DCListPendingGroups <$> (A.space *> A.decimal <|> pure 10)
DCSendToGroupOwner_ -> do
@@ -300,12 +328,21 @@ directoryCmdP ft =
-- DCAddBlockedWord_ -> DCAddBlockedWord <$> wordP
-- DCRemoveBlockedWord_ -> DCRemoveBlockedWord <$> wordP
DCPromoteGroup_ -> do
(groupId, displayName) <- gc (,)
_ <- spacesP
addr <- (A.char '@' $> True) <|> pure False
i <- A.decimal
n <- A.char ':' *> displayNameTextP
promote <- A.space *> onOffP
pure $ DCPromoteGroup groupId displayName promote
pure $ if addr then DCPromoteContact i n promote else DCPromoteGroup i n promote
DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (spacesP *> A.takeText)
where
gc f = f <$> (spacesP *> A.decimal) <*> (A.char ':' *> displayNameTextP)
gcOrAddr groupF contactF = do
_ <- spacesP
addr <- (A.char '@' $> True) <|> pure False
i <- A.decimal
n <- A.char ':' *> displayNameTextP
pure $ if addr then contactF i n else groupF i n
gc_ f = f <$> (spacesP *> A.decimal) <*> optional (A.char ':' *> displayNameTextP)
-- wordP = spacesP *> A.takeTill isSpace
spacesP = A.takeWhile1 isSpace
@@ -318,17 +355,22 @@ directoryCmdTag = \case
DCSearchNext -> "next"
DCAllGroups -> "all"
DCRecentGroups -> "new"
DCFindContacts {} -> "find"
DCSubmitGroup _ -> "submit"
DCConfirmDuplicateGroup {} -> "confirm"
DCListUserGroups -> "list"
DCDeleteGroup {} -> "delete"
DCDeleteContact {} -> "delete"
DCApproveGroup {} -> "approve"
DCApproveContact {} -> "approve"
DCMemberRole {} -> "role"
DCGroupFilter {} -> "filter"
DCShowUpgradeGroupLink {} -> "link"
DCRejectGroup {} -> "reject"
DCSuspendGroup {} -> "suspend"
DCSuspendContact {} -> "suspend"
DCResumeGroup {} -> "resume"
DCResumeContact {} -> "resume"
DCListLastGroups _ -> "last"
DCListPendingGroups _ -> "pending"
DCSendToGroupOwner {} -> "owner"
@@ -336,6 +378,7 @@ directoryCmdTag = \case
-- DCAddBlockedWord _ -> "block_word"
-- DCRemoveBlockedWord _ -> "unblock_word"
DCPromoteGroup {} -> "promote"
DCPromoteContact {} -> "promote"
DCExecuteCommand _ -> "exec"
DCUnknownCommand -> "unknown"
DCCommandError _ -> "error"
apps/simplex-directory-service/src/Directory/Listing.hs
+60 -27
View File
@@ -52,11 +52,13 @@ promotedFileName = "promoted.json"
listingImageFolder :: String
listingImageFolder = "images"
data DirectoryEntryType = DETGroup
{ groupType :: Maybe GroupType,
admission :: Maybe GroupMemberAdmission,
summary :: GroupSummary
}
data DirectoryEntryType
= DETGroup
{ groupType :: Maybe GroupType,
admission :: Maybe GroupMemberAdmission,
summary :: GroupSummary
}
| DETContact {peerType :: ChatPeerType}
$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "DET") ''DirectoryEntryType)
@@ -130,36 +132,67 @@ groupDirectoryEntry now g@GroupInfo {groupProfile, chatTs, createdAt, groupSumma
entry . toPublicLink . connLinkContact <$> gLink_
where
toPublicLink (CCLink fullLink shortLink) = PublicLink (Just fullLink) shortLink
imgFileData :: PublicLink -> ImageData -> Maybe (FilePath, ByteString)
imgFileData PublicLink {connFullLink, connShortLink} (ImageData img) =
let (img', imgExt) =
fromMaybe (img, ".jpg") $
(,".jpg") <$> T.stripPrefix "data:image/jpg;base64," img
<|> (,".png") <$> T.stripPrefix "data:image/png;base64," img
linkHash = case connFullLink of
Just fl -> strEncode fl
Nothing -> maybe "" strEncode connShortLink
imgName = B.unpack $ B64URL.encodeUnpadded $ BA.convert $ (CH.hash :: ByteString -> Digest MD5) linkHash
imgFile = listingImageFolder </> imgName <> imgExt
in case B64.decode $ encodeUtf8 img' of
Right img'' -> Just (imgFile, img'')
Left _ -> Nothing
generateListing :: FilePath -> [(GroupInfo, GroupReg, Maybe GroupLink)] -> IO ()
generateListing dir gs = do
imgFileData :: PublicLink -> ImageData -> Maybe (FilePath, ByteString)
imgFileData PublicLink {connFullLink, connShortLink} (ImageData img) =
let (img', imgExt) =
fromMaybe (img, ".jpg") $
(,".jpg") <$> T.stripPrefix "data:image/jpg;base64," img
<|> (,".png") <$> T.stripPrefix "data:image/png;base64," img
linkHash = case connFullLink of
Just fl -> strEncode fl
Nothing -> maybe "" strEncode connShortLink
imgName = B.unpack $ B64URL.encodeUnpadded $ BA.convert $ (CH.hash :: ByteString -> Digest MD5) linkHash
imgFile = listingImageFolder </> imgName <> imgExt
in case B64.decode $ encodeUtf8 img' of
Right img'' -> Just (imgFile, img'')
Left _ -> Nothing
contactDirectoryEntry :: UTCTime -> Contact -> ChatPeerType -> Maybe (DirectoryEntry, Maybe (FilePath, ImageFileData))
contactDirectoryEntry now ct@Contact {profile = LocalProfile {displayName, shortDescr, description, image, contactLink}, createdAt, chatTs} peerType =
case contactLink of
Just cl ->
let pubLink = toPublicLink cl
imgData = imgFileData pubLink =<< image
de =
DirectoryEntry
{ entryType = DETContact peerType,
displayName,
simplexName = shortNameInfoStr . SimplexNameInfo NTContact <$> verifiedContactDomain ct,
groupLink = pubLink,
shortDescr = toFormattedText <$> shortDescr,
welcomeMessage = toFormattedText <$> description,
imageFile = fst <$> imgData,
activeAt = recentRoundedTime 900 now $ fromMaybe createdAt chatTs,
createdAt = recentRoundedTime 86400 now createdAt
}
in Just (de, imgData)
Nothing -> Nothing
where
toPublicLink = \case
CLFull fullLink -> PublicLink (Just fullLink) Nothing
CLShort shortLink -> PublicLink Nothing (Just shortLink)
generateListing :: FilePath -> [(GroupInfo, GroupReg, Maybe GroupLink)] -> [(Contact, ContactReg)] -> IO ()
generateListing dir gs cs = do
createDirectoryIfMissing True dir
oldDirs <- filter ((directoryDataPath <> ".") `isPrefixOf`) <$> listDirectory dir
ts <- getCurrentTime
let newDirPath = directoryDataPath <> "." <> iso8601Show ts <> "/"
newDir = dir </> newDirPath
createDirectoryIfMissing True (newDir </> listingImageFolder)
gs' <-
fmap catMaybes $ forM gs $ \(g, gr, link_) ->
forM (groupDirectoryEntry ts g link_) $ \(g', img) -> do
let writeEntry (e, img) = do
forM_ img $ \(imgFile, imgData) -> B.writeFile (newDir </> imgFile) imgData
pure (g', gr)
saveListing newDir listingFileName gs'
saveListing newDir promotedFileName $ filter (\(_, GroupReg {promoted}) -> promoted) gs'
pure e
gEntries <-
fmap catMaybes $ forM gs $ \(g, GroupReg {promoted}, link_) ->
forM (groupDirectoryEntry ts g link_) $ \ei -> (,promoted) <$> writeEntry ei
cEntries <-
fmap catMaybes $ forM cs $ \(ct, ContactReg {peerType, contactPromoted}) ->
forM (contactDirectoryEntry ts ct peerType) $ \ei -> (,contactPromoted) <$> writeEntry ei
let entries = gEntries ++ cEntries
saveListing newDir listingFileName entries
saveListing newDir promotedFileName $ filter snd entries
-- atomically update the link
let newSymLink = newDir <> ".link"
symLink = dir </> directoryDataPath
apps/simplex-directory-service/src/Directory/Search.hs
+6 -2
View File
@@ -1,13 +1,17 @@
module Directory.Search where
import Data.Int (Int64)
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
import Simplex.Chat.Types
data SearchRequest = SearchRequest
{ searchType :: SearchType,
{ target :: SearchTarget,
searchType :: SearchType,
searchTime :: UTCTime,
lastGroup :: GroupId -- cursor for search
lastId :: Int64 -- cursor for search: group_id or contact_reg_id, per target
}
data SearchTarget = TGroups | TContacts ChatPeerType
data SearchType = STAll | STRecent | STSearch Text
apps/simplex-directory-service/src/Directory/Service.hs
+247 -12
View File
@@ -50,11 +50,14 @@ import Directory.Util
import Simplex.Chat.Bot
import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Controller
import Control.Monad.Reader (runReaderT)
import Data.Int (Int64)
import Simplex.Chat.Core
import Simplex.Chat.Library.Internal (updateKnownContactFromLink)
import Simplex.Chat.Markdown (Format (..), FormattedText (..), SimplexLinkType (..), parseMaybeMarkdownList, viewName)
import Simplex.Chat.Messages
import Simplex.Chat.Options
import Simplex.Chat.Protocol (GroupShortLinkData (..), LinkOwnerSig (..), MsgChatLink (..), MsgContent (..), memberSupportVoiceVersion)
import Simplex.Chat.Protocol (ContactShortLinkData (..), GroupShortLinkData (..), LinkOwnerSig (..), MsgChatLink (..), MsgContent (..), memberSupportVoiceVersion)
import Simplex.Chat.Store.Direct (getContact)
import Simplex.Chat.Store.Groups (getGroupLink, getGroupMember, getGroupMemberByMemberId, setGroupCustomData) -- TODO remove setGroupCustomData
import Simplex.Chat.Store.Profiles (GroupLinkInfo (..), getGroupLinkInfo)
@@ -204,12 +207,17 @@ linkCheckThread_ opts env@ServiceState {eventQ}
forever $ do
threadDelay $ linkCheckInterval opts * 1000000
u <- readTVarIO $ currentUser cc
forM_ u $ \user ->
forM_ u $ \user -> do
withDB' "linkCheckThread" cc (\db -> getAllGroupRegs_ db (storeCxt cc) user) >>= \case
Left e -> logError $ "linkCheckThread error: " <> T.pack e
Right grs -> forM_ grs $ \(gInfo, gr) ->
unless (groupRemoved $ groupRegStatus gr) $
atomically $ writeTQueue eventQ $ DEGroupLinkCheck gInfo
getAllContactRegs cc user >>= \case
Left e -> logError $ "linkCheckThread contacts error: " <> T.pack e
Right crs -> forM_ crs $ \(ct, ContactReg {contactRegStatus}) ->
unless (groupRemoved contactRegStatus) $
atomically $ writeTQueue eventQ $ DEContactLinkCheck ct
| otherwise = Nothing
directoryPreStartHook :: DirectoryOpts -> ChatController -> IO ()
@@ -334,6 +342,8 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
DEServiceRemovedFromGroup g -> deServiceRemovedFromGroup g
DEGroupDeleted g -> deGroupDeleted g
DEChatLinkReceived {contact = ct, chatLink, ownerSig} -> deChatLinkReceived ct chatLink ownerSig
DEContactLinkCheck ct -> deContactLinkCheck ct
DEContactUpdated {fromContact, toContact} -> deContactUpdated fromContact toContact
DEMemberUpdated {groupInfo = g, fromMember, toMember} -> deMemberUpdated g fromMember toMember
DEUnsupportedMessage _ct _ciId -> pure ()
DEItemEditIgnored _ct -> pure ()
@@ -975,9 +985,140 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
_ -> sendMessage cc ct "Error: could not connect. Please report it to directory admins."
deChatLinkReceived ct (MCLGroup {groupProfile = GroupProfile {publicGroup = Just pg}}) _ =
sendMessage cc ct $ "To add a " <> groupTypeStr' pg <> " to directory you must be the owner."
deChatLinkReceived ct (MCLContact {connLink}) (Just ownerSig) =
sendChatCmd cc (APIConnectPlan userId (Just (aConnectTarget (ACL SCMContact (CLShort connLink)))) PRMAllGroups (Just ownerSig)) >>= \case
Right (CRConnectionPlan _ _ _ _ (CPContactAddress cap)) -> handleContactAddressPlan ct connLink cap
Right _ -> sendMessage cc ct "Error: unexpected plan for the address. Please report it to directory admins."
_ -> sendMessage cc ct "Error: could not verify the address. Please report it to directory admins."
deChatLinkReceived ct (MCLContact {}) Nothing =
sendMessage cc ct "To add your address to the directory you must send it yourself; the owner signature is required."
deChatLinkReceived ct _ _ =
sendMessage cc ct "Only channels can be added to directory via link."
handleContactAddressPlan :: Contact -> ShortLinkContact -> ContactAddressPlan -> IO ()
handleContactAddressPlan ct connLink = \case
CAPOk {contactSLinkData_ = Just ContactShortLinkData {profile}, ownerVerification = Just OVVerified} ->
registerContactAddress ct connLink profile
CAPOk {ownerVerification = Just (OVFailed reason)} ->
sendMessage cc ct $ "Address ownership verification failed: " <> reason
CAPKnown ct' -> registerContactAddress ct' connLink (contactLinkProfile ct')
CAPContactViaAddress ct' -> registerContactAddress ct' connLink (contactLinkProfile ct')
_ -> sendMessage cc ct "Error: could not verify the address ownership. Please report it to directory admins."
where
contactLinkProfile Contact {profile} = fromLocalProfile profile
registerContactAddress :: Contact -> ShortLinkContact -> Profile -> IO ()
registerContactAddress ct connLink Profile {contactLink, peerType, displayName} =
case contactLinkShort contactLink of
Just addr | addr == connLink -> case resolvedPeerType peerType of
Just pt ->
getContactRegByContactId cc (contactId' ct) >>= \case
Left e -> logError $ "getContactRegByContactId: " <> T.pack e
Right (Just _) ->
setContactStatus (contactId' ct) (GRSPendingApproval 1) $ do
sendMessage cc ct "Your address registration is updated and pending approval."
notifyAdminUsers approveCmd
Right Nothing ->
addContactRegStore cc ct pt (GRSPendingApproval 1) >>= \case
Left e -> do
logError $ "addContactRegStore: " <> T.pack e
sendMessage cc ct "Error registering your address. Please report it to directory admins."
Right _ -> do
_ <- refreshContactFromLink ct
sendMessage cc ct "Your address is submitted to the directory and pending approval."
notifyAdminUsers approveCmd
Nothing -> sendMessage cc ct "This account type cannot be added to the directory."
_ -> sendMessage cc ct "Please add this address to your profile, then re-send it."
where
approveCmd = "New address to approve: /approve @" <> tshow (contactId' ct) <> ":" <> viewName displayName <> " 1"
resolvedPeerType :: Maybe ChatPeerType -> Maybe ChatPeerType
resolvedPeerType = \case
Just (CPTUnknown _) -> Nothing
Just CPTBot -> Just CPTBot
_ -> Just CPTBusiness
contactLinkShort :: Maybe ConnLinkContact -> Maybe ShortLinkContact
contactLinkShort = \case
Just (CLShort sl) -> Just sl
_ -> Nothing
refreshContactFromLink :: Contact -> IO (Maybe (Contact, Bool))
refreshContactFromLink ct =
runReaderT (runExceptT (updateKnownContactFromLink user ct)) cc >>= \case
Right r -> pure $ Just r
Left e -> Nothing <$ logError ("updateKnownContactFromLink: " <> tshow e)
setContactStatus :: ContactId -> GroupRegStatus -> IO () -> IO ()
setContactStatus ctId crStatus' continue =
setContactRegStatusStore cc ctId crStatus' >>= \case
Left e -> logError $ "setContactRegStatusStore " <> tshow ctId <> ": " <> T.pack e
Right (crStatus, _) -> do
let status = grDirectoryStatus crStatus
status' = grDirectoryStatus crStatus'
when ((status == DSListed || status' == DSListed) && status /= status') $ listingsUpdated env
continue
deContactLinkCheck :: Contact -> IO ()
deContactLinkCheck ct =
refreshContactFromLink ct >>= \case
Just (ct', True) -> reapproveContact ct' "the address profile changed"
_ -> pure ()
deContactUpdated :: Contact -> Contact -> IO ()
deContactUpdated fromCt toCt =
getContactRegByContactId cc (contactId' toCt) >>= \case
Right (Just ContactReg {contactRegStatus}) | not (groupRemoved contactRegStatus) ->
case (contactLinkShort (contactLinkOf fromCt), contactLinkShort (contactLinkOf toCt)) of
(Just _, Nothing) -> suspendContact toCt "your address was removed from your profile; add it back to be listed again"
(Just a, Just b) | a /= b -> removeContact toCt "your address changed; please register the new address"
_
| visibleChanged fromCt toCt -> reapproveContact toCt "your profile changed"
| otherwise -> pure ()
_ -> pure ()
where
contactLinkOf Contact {profile = LocalProfile {contactLink}} = contactLink
visibleChanged :: Contact -> Contact -> Bool
visibleChanged Contact {profile = a} Contact {profile = b} =
dn a /= dn b
|| fn a /= fn b
|| sd a /= sd b
|| ds a /= ds b
|| im a /= im b
|| pt a /= pt b
where
dn LocalProfile {displayName} = displayName
fn LocalProfile {fullName} = fullName
sd LocalProfile {shortDescr} = shortDescr
ds LocalProfile {description} = description
im LocalProfile {image} = image
pt LocalProfile {peerType} = peerType
reapproveContact :: Contact -> Text -> IO ()
reapproveContact ct reason =
getContactRegByContactId cc (contactId' ct) >>= \case
Right (Just ContactReg {contactRegStatus}) | reapprovable contactRegStatus ->
setContactStatus (contactId' ct) (GRSPendingApproval 1) $ do
sendMessage cc ct $ "Your address listing is hidden pending re-approval (" <> reason <> ")."
notifyAdminUsers $ "Address re-approval needed: /approve @" <> tshow (contactId' ct) <> ":" <> viewName (contactDisplayName ct) <> " 1"
_ -> pure ()
where
reapprovable = \case GRSActive -> True; GRSPendingApproval _ -> True; _ -> False
suspendContact :: Contact -> Text -> IO ()
suspendContact ct reason =
setContactStatus (contactId' ct) GRSSuspended $
sendMessage cc ct ("Your address listing is suspended: " <> reason <> ".")
removeContact :: Contact -> Text -> IO ()
removeContact ct reason =
setContactStatus (contactId' ct) GRSRemoved $
sendMessage cc ct ("Your address listing was removed: " <> reason <> ".")
contactDisplayName :: Contact -> Text
contactDisplayName Contact {profile = LocalProfile {displayName}} = displayName
groupTypeStr :: GroupType -> Text
groupTypeStr = \case
GTChannel -> "channel"
@@ -1127,20 +1268,31 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
isGroupLink _ = False
DCSearchNext ->
atomically (TM.lookup (contactId' ct) searchRequests) >>= \case
Just SearchRequest {searchType, searchTime, lastGroup} -> do
Just SearchRequest {target, searchType, searchTime, lastId} -> do
currentTime <- getCurrentTime
if diffUTCTime currentTime searchTime > 300 -- 5 minutes
then do
atomically $ TM.delete (contactId' ct) searchRequests
showAllGroups
else
sendFoundListedGroups searchType (Just lastGroup) "No more groups" $ \gs _ ->
"Sending " <> tshow (length gs) <> " more group(s)."
else case target of
TGroups ->
sendFoundListedGroups searchType (Just lastId) "No more groups" $ \gs _ ->
"Sending " <> tshow (length gs) <> " more group(s)."
TContacts pt ->
sendFoundContacts pt searchType (Just lastId) "No more results" $ \cs _ ->
"Sending " <> tshow (length cs) <> " more result(s)."
Nothing -> showAllGroups
where
showAllGroups = deUserCommand ct ciId DCAllGroups
DCAllGroups -> sendFoundListedGroups STAll Nothing "No groups listed" $ allGroupsReply "top"
DCRecentGroups -> sendFoundListedGroups STRecent Nothing "No groups listed" $ allGroupsReply "the most recent"
DCFindContacts pt search ->
sendFoundContacts pt (maybe STAll STSearch search) Nothing notFound $ \cs n ->
let more = if n > length cs then ", sending top " <> tshow (length cs) else ""
in "Found " <> tshow n <> " " <> label <> more <> "."
where
label = case pt of CPTBot -> "bot(s)"; _ -> "business(es)"
notFound = "No " <> label <> " found."
DCSubmitGroup _link -> pure ()
DCConfirmDuplicateGroup ugrId gName ->
withUserGroupReg ugrId gName $ \g@GroupInfo {groupProfile = GroupProfile {displayName}} gr@GroupReg {groupRegStatus} -> case groupRegStatus of
@@ -1153,7 +1305,12 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
DCListUserGroups ->
getUserGroupRegs cc user (contactId' ct) >>= \case
Left e -> sendReply $ "Error reading groups: " <> T.pack e
Right gs -> sendGroupsInfo ct ciId isAdmin (gs, length gs)
Right gs -> do
sendGroupsInfo ct ciId isAdmin (gs, length gs)
getContactRegByContactId cc (contactId' ct) >>= \case
Right (Just ContactReg {contactRegStatus}) ->
sendReply $ "Your address registration status: " <> groupRegStatusText contactRegStatus <> "."
_ -> pure ()
DCDeleteGroup gId gName ->
(if isAdmin then withGroupAndReg sendReply else withUserGroupReg) gId gName $ \g@GroupInfo {groupProfile = GroupProfile {displayName, publicGroup = pg_}} GroupReg {dbGroupId} -> do
let gt = maybe "group" groupTypeStr' pg_
@@ -1163,6 +1320,21 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
sendReply $ (if isAdmin then "The " <> gt <> " " else "Your " <> gt <> " ") <> displayName <> " is deleted from the directory"
when (isJust pg_) $ leavePublicGroup g
Left e -> sendReply $ "Error deleting " <> gt <> " " <> displayName <> ": " <> T.pack e
DCDeleteContact ref
| isJust ref && not isAdmin -> sendReply "Only admins can delete another contact's address."
| otherwise ->
let (delId, nameStr) = case ref of
Just (cid, n) -> (cid, viewName n)
Nothing -> (contactId' ct, viewContactName ct)
in getContactRegByContactId cc delId >>= \case
Left e -> sendReply $ "Error: " <> T.pack e
Right Nothing -> sendReply $ if isAdmin && isJust ref then "No address registration for " <> nameStr <> "." else "You have no registered address."
Right (Just ContactReg {contactRegStatus}) ->
deleteContactReg cc delId >>= \case
Left e -> sendReply $ "Error deleting address: " <> T.pack e
Right () -> do
when (grDirectoryStatus contactRegStatus == DSListed) $ listingsUpdated env
sendReply $ (if isAdmin && isJust ref then "The address " <> nameStr <> " is" else "Your address is") <> " deleted from the directory."
DCMemberRole gId gName_ mRole_ ->
(if isAdmin then withGroupAndReg_ sendReply else withUserGroupReg_) gId gName_ $ \g _gr ->
ifPublicGroup g (sendReply "This command is not available for public groups.") $ do
@@ -1289,16 +1461,36 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
sendReply notFound
Right (gs, n) -> do
let moreGroups = n - length gs
updateSearchRequest searchType $ last gs
updateSearchReq TGroups searchType $ let (GroupInfo {groupId}, _) = last gs in groupId
sendFoundGroups (replyStr gs n) gs moreGroups
Left e -> sendReply $ "Error: searchListedGroups. Please notify the developers.\n" <> T.pack e
sendFoundContacts pt searchType lastReg_ notFound replyStr =
searchListedContacts cc user pt searchType lastReg_ searchResults >>= \case
Right ([], _) -> do
atomically $ TM.delete (contactId' ct) searchRequests
sendReply notFound
Right (cs, n) -> do
let more = n - length cs
updateSearchReq (TContacts pt) searchType $ let (_, ContactReg {contactRegId}) = last cs in contactRegId
void . forkIO $ sendComposedMessages_ cc (SRDirect $ contactId' ct) (foundContactMsgs (replyStr cs n) cs more)
Left e -> sendReply $ "Error: searchListedContacts. Please notify the developers.\n" <> T.pack e
foundContactMsgs reply cs more = replyMsg :| map foundContact cs <> [moreMsg | more > 0]
where
replyMsg = (Just ciId, MCText reply)
foundContact (Contact {profile = LocalProfile {displayName, shortDescr, description, image = image_, contactLink}}, _) =
let descr = maybe "" (\d -> " (" <> d <> ")") shortDescr
welcome = maybe "" ("\n" <>) description
link = maybe "" (\l -> "\n" <> strEncodeTxt l) contactLink
text = displayName <> descr <> welcome <> link
in (Nothing, maybe (MCText text) (\image -> MCImage {text, image}) image_)
moreMsg = (Nothing, MCText $ "Send /next for " <> tshow more <> " more result(s).")
allGroupsReply sortName gs n =
let more = if n > length gs then ", sending " <> sortName <> " " <> tshow (length gs) else ""
in tshow n <> " group(s) listed" <> more <> "."
updateSearchRequest :: SearchType -> (GroupInfo, GroupReg) -> IO ()
updateSearchRequest searchType (GroupInfo {groupId}, _) = do
updateSearchReq :: SearchTarget -> SearchType -> Int64 -> IO ()
updateSearchReq target searchType lastId = do
searchTime <- getCurrentTime
let search = SearchRequest {searchType, searchTime, lastGroup = groupId}
let search = SearchRequest {target, searchType, searchTime, lastId}
atomically $ TM.insert (contactId' ct) search searchRequests
sendFoundGroups reply gs moreGroups =
void . forkIO $ sendComposedMessages_ cc (SRDirect $ contactId' ct) msgs
@@ -1366,6 +1558,17 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
_ -> sendReply $ "Error: the group " <> groupRef <> " is not pending approval."
where
groupRef = groupReference' groupId n
DCApproveContact contactId n contactApprovalId ->
getContactReg cc user contactId >>= \case
Left e -> sendReply $ "Error: address " <> tshow contactId <> " not found: " <> T.pack e
Right (ct', ContactReg {contactRegStatus}) -> case contactRegStatus of
GRSPendingApproval gaId
| gaId == contactApprovalId ->
setContactStatus contactId GRSActive $ do
sendMessage cc ct' "Your address is approved and listed in the directory.\n_Please note_: if you change your profile the listing will be hidden until it is re-approved."
sendReply $ "Address " <> tshow contactId <> " (" <> viewName n <> ") approved!"
| otherwise -> sendReply "Incorrect approval code"
_ -> sendReply $ "Error: address " <> tshow contactId <> " is not pending approval."
DCRejectGroup _gaId _gName -> pure ()
DCSuspendGroup groupId gName -> do
let groupRef = groupReference' groupId gName
@@ -1387,6 +1590,22 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
sendReply "Group listing resumed!"
notifyOtherSuperUsers $ groupStr <> " listing resumed by " <> viewName (localDisplayName' ct)
_ -> sendReply $ "The group " <> groupRef <> " is not suspended, can't be resumed."
DCSuspendContact contactId n ->
getContactReg cc user contactId >>= \case
Left e -> sendReply $ "Error: address " <> tshow contactId <> " not found: " <> T.pack e
Right (ct', ContactReg {contactRegStatus}) -> case contactRegStatus of
GRSActive -> setContactStatus contactId GRSSuspended $ do
sendMessage cc ct' $ "Your address (" <> viewName n <> ") is suspended and hidden from the directory. Please contact the administrators."
sendReply "Address suspended!"
_ -> sendReply $ "Address " <> tshow contactId <> " is not active, can't be suspended."
DCResumeContact contactId n ->
getContactReg cc user contactId >>= \case
Left e -> sendReply $ "Error: address " <> tshow contactId <> " not found: " <> T.pack e
Right (ct', ContactReg {contactRegStatus}) -> case contactRegStatus of
GRSSuspended -> setContactStatus contactId GRSActive $ do
sendMessage cc ct' $ "Your address (" <> viewName n <> ") is listed in the directory again!"
sendReply "Address listing resumed!"
_ -> sendReply $ "Address " <> tshow contactId <> " is not suspended, can't be resumed."
DCListLastGroups count ->
listLastGroups cc user count >>= \case
Left e -> sendReply $ "Error reading groups: " <> T.pack e
@@ -1454,6 +1673,19 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
if promote' /= promoted
then setGroupPromoted sendReply st env cc gr promote' notify
else notify
DCPromoteContact contactId _n promote' ->
getContactReg cc user contactId >>= \case
Left e -> sendReply $ "Error: address " <> tshow contactId <> " not found: " <> T.pack e
Right (_, ContactReg {contactRegStatus, contactPromoted}) -> do
let notify = sendReply $ "Address promotion " <> (if promote' then "enabled" <> (if contactRegStatus == GRSActive then "." else ", but the address is not listed.") else "disabled.")
if promote' /= contactPromoted
then
setContactPromotedStore cc contactId promote' >>= \case
Left e -> sendReply $ "Error updating promotion: " <> T.pack e
Right (status, _) -> do
when (status == DSListed) $ listingsUpdated env
notify
else notify
DCExecuteCommand cmdStr ->
sendChatCmdStr cc cmdStr >>= \case
Right r -> do
@@ -1557,8 +1789,11 @@ setGroupPromoted sendReply st env cc GroupReg {dbGroupId = gId} grPromoted' cont
updateGroupListingFiles :: ChatController -> User -> FilePath -> IO ()
updateGroupListingFiles cc u dir =
getAllListedGroups cc u >>= \case
Right gs -> generateListing dir gs
Left e -> logError $ "generateListing error: failed to read groups: " <> T.pack e
Right gs ->
getAllListedContacts cc u >>= \case
Left e -> logError $ "generateListing error: failed to read contacts: " <> T.pack e
Right cs -> generateListing dir gs cs
getContact' :: ChatController -> User -> ContactId -> IO (Either String Contact)
getContact' cc user ctId = withDB "getContact" cc $ \db -> withExceptT show $ getContact db (storeCxt cc) user ctId
apps/simplex-directory-service/src/Directory/Store.hs
+155 -1
View File
@@ -44,6 +44,18 @@ module Directory.Store
getAllListedGroups_,
searchListedGroups,
verifiedGroupDomain,
ContactReg (..),
ContactRegId,
addContactRegStore,
getContactReg,
getContactRegByContactId,
setContactRegStatusStore,
setContactPromotedStore,
deleteContactReg,
getAllListedContacts,
getAllContactRegs,
searchListedContacts,
verifiedContactDomain,
groupRegStatusText,
pendingApproval,
groupRemoved,
@@ -78,7 +90,7 @@ import Data.Int (Int64)
import Data.List (sortOn)
import Data.Map (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust)
import Data.Maybe (catMaybes, fromMaybe, isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
@@ -90,6 +102,7 @@ import Simplex.Chat.Controller
import Simplex.Chat.Names (claimDomain)
import Simplex.Chat.Options.DB (FromField (..), ToField (..))
import Simplex.Chat.Store
import Simplex.Chat.Store.Direct (getContact)
import Simplex.Chat.Store.Groups
import Simplex.Chat.Store.Shared (groupInfoQueryFields, groupInfoQueryFrom)
import Simplex.Chat.Types
@@ -236,6 +249,103 @@ $(JQ.deriveJSON defaultJSON ''DirectoryMemberAcceptance)
$(JQ.deriveJSON defaultJSON ''DirectoryGroupData)
type ContactRegId = Int64
data ContactReg = ContactReg
{ contactRegId :: ContactRegId,
crContactId :: Maybe ContactId,
peerType :: ChatPeerType,
contactRegStatus :: GroupRegStatus,
contactPromoted :: Bool,
crCreatedAt :: UTCTime
}
contactRegQuery :: Query
contactRegQuery =
[sql|
SELECT contact_reg_id, contact_id, peer_type, contact_reg_status, contact_promoted, created_at
FROM sx_directory_contact_regs
|]
rowToContactReg :: (ContactRegId, Maybe ContactId, ChatPeerType, GroupRegStatus, BoolInt, UTCTime) -> ContactReg
rowToContactReg (contactRegId, crContactId, peerType, contactRegStatus, BI contactPromoted, crCreatedAt) =
ContactReg {contactRegId, crContactId, peerType, contactRegStatus, contactPromoted, crCreatedAt}
addContactRegStore :: ChatController -> Contact -> ChatPeerType -> GroupRegStatus -> IO (Either String ContactReg)
addContactRegStore cc Contact {contactId = ctId} peerType contactRegStatus =
withDB "addContactRegStore" cc $ \db -> do
createdAt <- liftIO getCurrentTime
liftIO $
DB.execute
db
[sql|
INSERT INTO sx_directory_contact_regs
(contact_id, peer_type, contact_reg_status, contact_promoted, created_at, updated_at)
VALUES (?,?,?,?,?,?)
|]
(ctId, peerType, contactRegStatus, BI False, createdAt, createdAt)
getContactReg_ db ctId
getContactReg_ :: DB.Connection -> ContactId -> ExceptT String IO ContactReg
getContactReg_ db ctId =
ExceptT $ firstRow rowToContactReg "contact registration not found" $
DB.query db (contactRegQuery <> " WHERE contact_id = ?") (Only ctId)
getContactReg :: ChatController -> User -> ContactId -> IO (Either String (Contact, ContactReg))
getContactReg cc user ctId =
withDB "getContactReg" cc $ \db -> do
cr <- getContactReg_ db ctId
ct <- withExceptT show $ getContact db (storeCxt cc) user ctId
pure (ct, cr)
getContactRegByContactId :: ChatController -> ContactId -> IO (Either String (Maybe ContactReg))
getContactRegByContactId cc ctId =
withDB' "getContactRegByContactId" cc $ \db ->
maybeFirstRow' Nothing (Just . rowToContactReg) $
DB.query db (contactRegQuery <> " WHERE contact_id = ?") (Only ctId)
setContactRegStatusStore :: ChatController -> ContactId -> GroupRegStatus -> IO (Either String (GroupRegStatus, ContactReg))
setContactRegStatusStore cc ctId crStatus' =
withDB "setContactRegStatusStore" cc $ \db -> do
cr <- getContactReg_ db ctId
ts <- liftIO getCurrentTime
liftIO $ DB.execute db "UPDATE sx_directory_contact_regs SET contact_reg_status = ?, updated_at = ? WHERE contact_id = ?" (crStatus', ts, ctId)
pure (contactRegStatus cr, cr {contactRegStatus = crStatus'})
setContactPromotedStore :: ChatController -> ContactId -> Bool -> IO (Either String (DirectoryStatus, Bool))
setContactPromotedStore cc ctId promoted' =
withDB "setContactPromotedStore" cc $ \db -> do
ContactReg {contactRegStatus, contactPromoted} <- getContactReg_ db ctId
ts <- liftIO getCurrentTime
liftIO $ DB.execute db "UPDATE sx_directory_contact_regs SET contact_promoted = ?, updated_at = ? WHERE contact_id = ?" (BI promoted', ts, ctId)
pure (grDirectoryStatus contactRegStatus, contactPromoted)
deleteContactReg :: ChatController -> ContactId -> IO (Either String ())
deleteContactReg cc ctId =
withDB' "deleteContactReg" cc $ \db ->
DB.execute db "DELETE FROM sx_directory_contact_regs WHERE contact_id = ?" (Only ctId)
getAllListedContacts :: ChatController -> User -> IO (Either String [(Contact, ContactReg)])
getAllListedContacts cc user =
withDB' "getAllListedContacts" cc $ \db ->
loadContactRegs cc user db =<< DB.query db (contactRegQuery <> " WHERE contact_reg_status = ?") (Only GRSActive)
getAllContactRegs :: ChatController -> User -> IO (Either String [(Contact, ContactReg)])
getAllContactRegs cc user =
withDB' "getAllContactRegs" cc $ \db ->
loadContactRegs cc user db =<< DB.query_ db contactRegQuery
loadContactRegs :: ChatController -> User -> DB.Connection -> [(ContactRegId, Maybe ContactId, ChatPeerType, GroupRegStatus, BoolInt, UTCTime)] -> IO [(Contact, ContactReg)]
loadContactRegs cc user db rows =
fmap catMaybes $ forM (map rowToContactReg rows) $ \cr@ContactReg {crContactId} -> case crContactId of
Just ctId -> fmap (,cr) . eitherToMaybe <$> runExceptT (getContact db (storeCxt cc) user ctId)
Nothing -> pure Nothing
verifiedContactDomain :: Contact -> Maybe SimplexDomain
verifiedContactDomain Contact {profile = LocalProfile {contactDomain, contactDomainVerified}}
| contactDomainVerified == Just True = claimDomain <$> contactDomain
| otherwise = Nothing
fromCustomData :: Maybe CustomData -> DirectoryGroupData
fromCustomData cd_ =
let memberAcceptance = fromMaybe noJoinFilter $ cd_ >>= \(CustomData o) -> JT.parseMaybe (.: "memberAcceptance") o
@@ -423,6 +533,50 @@ searchListedGroups cc user@User {userId, userContactId} searchType lastGroup_ pa
)
|]
searchListedContacts :: ChatController -> User -> ChatPeerType -> SearchType -> Maybe ContactRegId -> Int -> IO (Either String ([(Contact, ContactReg)], Int))
searchListedContacts cc user peerType searchType lastReg_ pageSize =
withDB' "searchListedContacts" cc $ \db -> do
rows <- case searchType of
STSearch search ->
let s = T.toLower search
in case lastReg_ of
Nothing -> DB.query db (baseQ <> searchCond <> order) (GRSActive, peerType, s, s, s, pageSize)
Just crId -> DB.query db (baseQ <> cursorCond <> searchCond <> order) ((GRSActive, peerType, crId, s, s, s) :. Only pageSize)
_ -> case lastReg_ of
Nothing -> DB.query db (baseQ <> order) (GRSActive, peerType, pageSize)
Just crId -> DB.query db (baseQ <> cursorCond <> order) (GRSActive, peerType, crId, pageSize)
crs <- loadContactRegs cc user db rows
n <- case searchType of
STSearch search -> let s = T.toLower search in count $ DB.query db (countQ <> searchCond) (GRSActive, peerType, s, s, s)
_ -> count $ DB.query db countQ (GRSActive, peerType)
pure (crs, n)
where
count = maybeFirstRow' 0 fromOnly
baseQ =
[sql|
SELECT r.contact_reg_id, r.contact_id, r.peer_type, r.contact_reg_status, r.contact_promoted, r.created_at
FROM sx_directory_contact_regs r
JOIN contacts ct ON ct.contact_id = r.contact_id
JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
WHERE r.contact_reg_status = ? AND r.peer_type = ?
|]
countQ =
[sql|
SELECT COUNT(1)
FROM sx_directory_contact_regs r
JOIN contacts ct ON ct.contact_id = r.contact_id
JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
WHERE r.contact_reg_status = ? AND r.peer_type = ?
|]
cursorCond = " AND r.contact_reg_id > ? "
searchCond =
[sql|
AND (LOWER(cp.display_name) LIKE '%' || ? || '%'
OR LOWER(cp.short_descr) LIKE '%' || ? || '%'
OR LOWER(cp.description) LIKE '%' || ? || '%')
|]
order = " ORDER BY r.contact_reg_id ASC LIMIT ? "
getAllGroupRegs_ :: DB.Connection -> StoreCxt -> User -> IO [(GroupInfo, GroupReg)]
getAllGroupRegs_ db cxt user@User {userId, userContactId} = do
currentTs <- getCurrentTime
apps/simplex-directory-service/src/Directory/Store/Migrate.hs
+1 -1
View File
@@ -113,7 +113,7 @@ saveGroupListingFiles opts cfg = case webFolder opts of
Just dir ->
withChatStore opts $ \st -> withActiveUser st $ \user ->
withTransaction st $ \db ->
getAllListedGroups_ db (mkStoreCxt cfg) user >>= generateListing dir
getAllListedGroups_ db (mkStoreCxt cfg) user >>= \gs -> generateListing dir gs []
verifyGroupRegistration :: StoreCxt -> DB.Connection -> User -> GroupReg -> IO Bool
verifyGroupRegistration cxt db user GroupReg {dbGroupId = gId, dbContactId = ctId, dbOwnerMemberId, groupRegStatus} =
apps/simplex-directory-service/src/Directory/Store/Postgres/Migrations.hs
+28 -1
View File
@@ -16,7 +16,8 @@ directorySchemaMigrations = sortOn name $ map migration schemaMigrations
schemaMigrations :: [(String, Text, Maybe Text)]
schemaMigrations =
[ ("20250924_directory_schema", m20250924_directory_schema, Just down_m20250924_directory_schema)
[ ("20250924_directory_schema", m20250924_directory_schema, Just down_m20250924_directory_schema),
("20260801_directory_contact_regs", m20260801_directory_contact_regs, Just down_m20260801_directory_contact_regs)
]
m20250924_directory_schema :: Text
@@ -50,3 +51,29 @@ DROP INDEX idx_sx_directory_group_regs_owner_contact_id_user_group_reg_id;
DROP TABLE sx_directory_group_regs;
|]
m20260801_directory_contact_regs :: Text
m20260801_directory_contact_regs =
T.pack
[r|
CREATE TABLE sx_directory_contact_regs(
contact_reg_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
contact_id BIGINT REFERENCES contacts(contact_id) ON UPDATE RESTRICT ON DELETE CASCADE,
peer_type TEXT NOT NULL,
contact_reg_status TEXT NOT NULL,
contact_promoted SMALLINT NOT NULL DEFAULT 0,
created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
updated_at TIMESTAMPTZ NOT NULL DEFAULT (now())
);
CREATE UNIQUE INDEX idx_sx_directory_contact_regs_contact_id ON sx_directory_contact_regs(contact_id);
|]
down_m20260801_directory_contact_regs :: Text
down_m20260801_directory_contact_regs =
T.pack
[r|
DROP INDEX idx_sx_directory_contact_regs_contact_id;
DROP TABLE sx_directory_contact_regs;
|]
apps/simplex-directory-service/src/Directory/Store/SQLite/Migrations.hs
+26 -1
View File
@@ -15,7 +15,8 @@ directorySchemaMigrations = sortOn name $ map migration schemaMigrations
schemaMigrations :: [(String, Query, Maybe Query)]
schemaMigrations =
[ ("20250924_directory_schema", m20250924_directory_schema, Just down_m20250924_directory_schema)
[ ("20250924_directory_schema", m20250924_directory_schema, Just down_m20250924_directory_schema),
("20260801_directory_contact_regs", m20260801_directory_contact_regs, Just down_m20260801_directory_contact_regs)
]
m20250924_directory_schema :: Query
@@ -47,3 +48,27 @@ DROP INDEX idx_sx_directory_group_regs_owner_contact_id_user_group_reg_id;
DROP TABLE sx_directory_group_regs;
|]
m20260801_directory_contact_regs :: Query
m20260801_directory_contact_regs =
[sql|
CREATE TABLE sx_directory_contact_regs(
contact_reg_id INTEGER PRIMARY KEY AUTOINCREMENT,
contact_id INTEGER REFERENCES contacts(contact_id) ON UPDATE RESTRICT ON DELETE CASCADE,
peer_type TEXT NOT NULL,
contact_reg_status TEXT NOT NULL,
contact_promoted INTEGER NOT NULL DEFAULT 0,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE UNIQUE INDEX idx_sx_directory_contact_regs_contact_id ON sx_directory_contact_regs(contact_id);
|]
down_m20260801_directory_contact_regs :: Query
down_m20260801_directory_contact_regs =
[sql|
DROP INDEX idx_sx_directory_contact_regs_contact_id;
DROP TABLE sx_directory_contact_regs;
|]