Initial commit: bots, AI-parameterised support bot, web frontend
- simplex-deadmans-bot: Dead Man's Switch Haskell bot - simplexxx-directory: private SimpleXXX directory bot (fork of simplex-directory-service) - simplex-support-bot: support triage bot with configurable AI backend - --ai-url and --ai-model flags for any OpenAI-compatible provider - works with Grok, Ollama, OpenAI, LM Studio, etc. - AI_API_KEY env var (GROK_API_KEY still accepted as alias) - web: SimpleXXX directory frontend (Groups/Channels tabs, matches simplex.chat/directory style) - manager/: placeholder for Python profile manager (coming soon) Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
Jon
27
bots/haskell/simplexxx-directory/Main.hs
Normal file
27
bots/haskell/simplexxx-directory/Main.hs
Normal file
@@ -0,0 +1,27 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Directory.Options
|
||||
import Directory.Service
|
||||
import Directory.Store
|
||||
import Directory.Store.Migrate
|
||||
import Simplex.Chat.Terminal (terminalChatConfig)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
opts@DirectoryOpts {directoryLog, migrateDirectoryLog, runCLI} <- welcomeGetOpts
|
||||
case migrateDirectoryLog of
|
||||
Just cmd -> migrate cmd opts terminalChatConfig
|
||||
Nothing -> do
|
||||
st <- openDirectoryLog directoryLog
|
||||
if runCLI
|
||||
then directoryServiceCLI st opts
|
||||
else directoryService st opts terminalChatConfig
|
||||
where
|
||||
migrate = \case
|
||||
MLCheck -> checkDirectoryLog
|
||||
MLImport -> importDirectoryLogToDB
|
||||
MLExport -> exportDBToDirectoryLog
|
||||
MLListing -> saveGroupListingFiles
|
||||
@@ -0,0 +1,77 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Directory.BlockedWords where
|
||||
|
||||
import Data.Char (isMark, isPunctuation, isSpace)
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Normalize as TN
|
||||
|
||||
data BlockedWordsConfig = BlockedWordsConfig
|
||||
{ blockedWords :: Set Text,
|
||||
blockedFragments :: Set Text,
|
||||
extensionRules :: [(String, [String])],
|
||||
spelling :: Map Char [Char]
|
||||
}
|
||||
|
||||
hasBlockedFragments :: BlockedWordsConfig -> Text -> Bool
|
||||
hasBlockedFragments BlockedWordsConfig {spelling, blockedFragments} s =
|
||||
any (\w -> any (`T.isInfixOf` w) blockedFragments) ws
|
||||
where
|
||||
ws = S.fromList $ filter (not . T.null) $ normalizeText spelling s
|
||||
|
||||
hasBlockedWords :: BlockedWordsConfig -> Text -> Bool
|
||||
hasBlockedWords BlockedWordsConfig {spelling, blockedWords} s =
|
||||
not $ ws1 `S.disjoint` blockedWords && (length ws <= 1 || ws2 `S.disjoint` blockedWords)
|
||||
where
|
||||
ws = T.words s
|
||||
ws1 = normalizeWords ws
|
||||
ws2 = normalizeWords $ T.splitOn " " s
|
||||
normalizeWords = S.fromList . filter (not . T.null) . concatMap (normalizeText spelling)
|
||||
|
||||
normalizeText :: Map Char [Char] -> Text -> [Text]
|
||||
normalizeText spelling' =
|
||||
map (T.pack . filter (\c -> not $ isSpace c || isPunctuation c || isMark c))
|
||||
. allSubstitutions spelling'
|
||||
. removeTriples
|
||||
. T.unpack
|
||||
. T.toLower
|
||||
. TN.normalize TN.NFKD
|
||||
|
||||
-- replaces triple and larger occurences with doubles
|
||||
removeTriples :: String -> String
|
||||
removeTriples xs = go xs '\0' False
|
||||
where
|
||||
go [] _ _ = []
|
||||
go (c : cs) prev samePrev
|
||||
| prev /= c = c : go cs c False
|
||||
| samePrev = go cs c True
|
||||
| otherwise = c : go cs c True
|
||||
|
||||
-- Generate all possible strings by substituting each character
|
||||
allSubstitutions :: Map Char [Char] -> String -> [String]
|
||||
allSubstitutions spelling' = sequence . map substs
|
||||
where
|
||||
substs c = fromMaybe [c] $ M.lookup c spelling'
|
||||
|
||||
wordVariants :: [(String, [String])] -> String -> [Text]
|
||||
wordVariants [] s = [T.pack s]
|
||||
wordVariants (sub : subs) s = concatMap (wordVariants subs) (replace sub)
|
||||
where
|
||||
replace (pat, tos) = go s
|
||||
where
|
||||
go [] = [""]
|
||||
go s'@(c : rest)
|
||||
| pat `isPrefixOf` s' =
|
||||
let s'' = drop (length pat) s'
|
||||
restVariants = go s''
|
||||
in map (pat <>) restVariants
|
||||
<> concatMap (\to -> map (to <>) restVariants) tos
|
||||
| otherwise = map (c :) (go rest)
|
||||
37
bots/haskell/simplexxx-directory/src/Directory/Captcha.hs
Normal file
37
bots/haskell/simplexxx-directory/src/Directory/Captcha.hs
Normal file
@@ -0,0 +1,37 @@
|
||||
module Directory.Captcha (getCaptchaStr, matchCaptchaStr) where
|
||||
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import System.Random (randomRIO)
|
||||
|
||||
getCaptchaStr :: Int -> String -> IO String
|
||||
getCaptchaStr 0 s = pure s
|
||||
getCaptchaStr n s = do
|
||||
i <- randomRIO (0, length captchaChars - 1)
|
||||
let c = captchaChars !! i
|
||||
getCaptchaStr (n - 1) (c : s)
|
||||
where
|
||||
captchaChars = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
|
||||
|
||||
matchCaptchaStr :: T.Text -> T.Text -> Bool
|
||||
matchCaptchaStr captcha guess = T.length captcha == T.length guess && matchChars (T.zip captcha guess)
|
||||
where
|
||||
matchChars [] = True
|
||||
matchChars ((c, g) : cs) = matchChar c == matchChar g && matchChars cs
|
||||
matchChar c = fromMaybe c $ M.lookup c captchaMatches
|
||||
captchaMatches =
|
||||
M.fromList
|
||||
[ ('0', 'O'),
|
||||
('1', 'I'),
|
||||
('c', 'C'),
|
||||
('l', 'I'),
|
||||
('o', 'O'),
|
||||
('p', 'P'),
|
||||
('s', 'S'),
|
||||
('u', 'U'),
|
||||
('v', 'V'),
|
||||
('w', 'W'),
|
||||
('x', 'X'),
|
||||
('z', 'Z')
|
||||
]
|
||||
337
bots/haskell/simplexxx-directory/src/Directory/Events.hs
Normal file
337
bots/haskell/simplexxx-directory/src/Directory/Events.hs
Normal file
@@ -0,0 +1,337 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
|
||||
module Directory.Events
|
||||
( DirectoryEvent (..),
|
||||
DirectoryCmd (..),
|
||||
DirectoryCmdTag (..),
|
||||
ADirectoryCmd (..),
|
||||
DirectoryHelpSection (..),
|
||||
DirectoryRole (..),
|
||||
SDirectoryRole (..),
|
||||
crDirectoryEvent,
|
||||
directoryCmdP,
|
||||
directoryCmdTag,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Data.Attoparsec.Text (Parser)
|
||||
import qualified Data.Attoparsec.Text as A
|
||||
import Data.Char (isSpace)
|
||||
import Data.Either (fromRight)
|
||||
import Data.Functor (($>))
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Directory.Store
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Markdown (MarkdownList, displayNameTextP)
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Protocol (LinkOwnerSig, MsgChatLink, MsgContent (..))
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Messaging.Agent.Protocol (AgentErrorType (..))
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (BrokerErrorType (..))
|
||||
import Simplex.Messaging.Util (tshow, (<$?>))
|
||||
|
||||
data DirectoryEvent
|
||||
= DEContactConnected Contact
|
||||
| DEGroupInvitation {contact :: Contact, groupInfo :: GroupInfo, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole}
|
||||
| DEServiceJoinedGroup {contactId :: ContactId, groupInfo :: GroupInfo, hostMember :: GroupMember}
|
||||
| DEGroupUpdated {member :: GroupMember, fromGroup :: GroupInfo, toGroup :: GroupInfo}
|
||||
| DEGroupLinkCheck GroupInfo
|
||||
| DEPendingMember GroupInfo GroupMember
|
||||
| DEPendingMemberMsg GroupInfo GroupMember ChatItemId Text
|
||||
| DEContactRoleChanged GroupInfo ContactId GroupMemberRole -- contactId here is the contact whose role changed
|
||||
| DEServiceRoleChanged GroupInfo GroupMemberRole
|
||||
| DEContactRemovedFromGroup ContactId GroupInfo
|
||||
| DEContactLeftGroup ContactId GroupInfo
|
||||
| DEServiceRemovedFromGroup GroupInfo
|
||||
| DEGroupDeleted GroupInfo
|
||||
| DEChatLinkReceived {contact :: Contact, chatItemId :: ChatItemId, chatLink :: MsgChatLink, ownerSig :: Maybe LinkOwnerSig}
|
||||
| DEMemberUpdated {groupInfo :: GroupInfo, fromMember :: GroupMember, toMember :: GroupMember}
|
||||
| DEUnsupportedMessage Contact ChatItemId
|
||||
| DEItemEditIgnored Contact
|
||||
| DEItemDeleteIgnored Contact
|
||||
| DEContactCommand Contact ChatItemId ADirectoryCmd
|
||||
| DELogChatResponse Text
|
||||
deriving (Show)
|
||||
|
||||
crDirectoryEvent :: Either ChatError ChatEvent -> Maybe DirectoryEvent
|
||||
crDirectoryEvent = \case
|
||||
Right evt -> crDirectoryEvent_ evt
|
||||
Left e -> case e of
|
||||
ChatErrorAgent {agentError = BROKER _ (NETWORK _)} -> Nothing
|
||||
ChatErrorAgent {agentError = BROKER _ TIMEOUT} -> Nothing
|
||||
_ -> Just $ DELogChatResponse $ "chat error: " <> tshow e
|
||||
|
||||
crDirectoryEvent_ :: ChatEvent -> Maybe DirectoryEvent
|
||||
crDirectoryEvent_ = \case
|
||||
CEvtContactConnected {contact} -> Just $ DEContactConnected contact
|
||||
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_
|
||||
CEvtJoinedGroupMember {groupInfo, member = m}
|
||||
| pending m -> Just $ DEPendingMember groupInfo m
|
||||
| otherwise -> Nothing
|
||||
CEvtNewChatItems {chatItems = AChatItem _ _ (GroupChat g _scopeInfo) ci : _} -> case ci of
|
||||
ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent (MCText t)} | pending m -> Just $ DEPendingMemberMsg g m (chatItemId' ci) t
|
||||
_ -> Nothing
|
||||
CEvtMemberRole {groupInfo, member, toRole}
|
||||
| groupMemberId' member == groupMemberId' (membership groupInfo) -> Just $ DEServiceRoleChanged groupInfo toRole
|
||||
| otherwise -> (\ctId -> DEContactRoleChanged groupInfo ctId toRole) <$> memberContactId member
|
||||
CEvtDeletedMember {groupInfo, deletedMember} -> (`DEContactRemovedFromGroup` groupInfo) <$> memberContactId deletedMember
|
||||
CEvtLeftMember {groupInfo, member} -> (`DEContactLeftGroup` groupInfo) <$> memberContactId member
|
||||
CEvtDeletedMemberUser {groupInfo} -> Just $ DEServiceRemovedFromGroup groupInfo
|
||||
CEvtGroupDeleted {groupInfo} -> Just $ DEGroupDeleted groupInfo
|
||||
CEvtUnknownMemberAnnounced {groupInfo, unknownMember, announcedMember} -> Just $ DEMemberUpdated {groupInfo, fromMember = unknownMember, toMember = announcedMember}
|
||||
CEvtGroupMemberUpdated {groupInfo, fromMember, toMember} -> Just $ DEMemberUpdated {groupInfo, fromMember, toMember}
|
||||
CEvtChatItemUpdated {chatItem = AChatItem _ SMDRcv (DirectChat ct) _} -> Just $ DEItemEditIgnored ct
|
||||
CEvtChatItemsDeleted {chatItemDeletions = ((ChatItemDeletion (AChatItem _ SMDRcv (DirectChat ct) _) _) : _), byUser = False} -> Just $ DEItemDeleteIgnored ct
|
||||
CEvtNewChatItems {chatItems = (AChatItem _ SMDRcv (DirectChat ct) ci@ChatItem {content = CIRcvMsgContent mc, formattedText = ft, meta = CIMeta {itemLive}}) : _} ->
|
||||
Just $ case (mc, itemLive) of
|
||||
(MCText t, Nothing) -> DEContactCommand ct ciId $ fromRight err $ A.parseOnly (directoryCmdP ft <* A.endOfInput) $ T.dropWhileEnd isSpace t
|
||||
(MCChat {chatLink, ownerSig}, Nothing) -> DEChatLinkReceived {contact = ct, chatItemId = ciId, chatLink, ownerSig}
|
||||
_ -> DEUnsupportedMessage ct ciId
|
||||
where
|
||||
ciId = chatItemId' ci
|
||||
err = ADC SDRUser DCUnknownCommand
|
||||
CEvtMessageError {severity, errorMessage} -> Just $ DELogChatResponse $ "message error: " <> severity <> ", " <> errorMessage
|
||||
CEvtChatErrors {chatErrors} -> Just $ DELogChatResponse $ "chat errors: " <> T.intercalate ", " (map tshow chatErrors)
|
||||
_ -> Nothing
|
||||
where
|
||||
pending m = memberStatus m == GSMemPendingApproval
|
||||
|
||||
data DirectoryRole = DRUser | DRAdmin | DRSuperUser
|
||||
|
||||
data SDirectoryRole (r :: DirectoryRole) where
|
||||
SDRUser :: SDirectoryRole 'DRUser
|
||||
SDRAdmin :: SDirectoryRole 'DRAdmin
|
||||
SDRSuperUser :: SDirectoryRole 'DRSuperUser
|
||||
|
||||
deriving instance Show (SDirectoryRole r)
|
||||
|
||||
data DirectoryCmdTag (r :: DirectoryRole) where
|
||||
DCHelp_ :: DirectoryCmdTag 'DRUser
|
||||
DCSearchNext_ :: DirectoryCmdTag 'DRUser
|
||||
DCAllGroups_ :: DirectoryCmdTag 'DRUser
|
||||
DCRecentGroups_ :: DirectoryCmdTag 'DRUser
|
||||
DCSubmitGroup_ :: DirectoryCmdTag 'DRUser
|
||||
DCConfirmDuplicateGroup_ :: DirectoryCmdTag 'DRUser
|
||||
DCListUserGroups_ :: DirectoryCmdTag 'DRUser
|
||||
DCDeleteGroup_ :: DirectoryCmdTag 'DRUser
|
||||
DCMemberRole_ :: DirectoryCmdTag 'DRUser
|
||||
DCGroupFilter_ :: DirectoryCmdTag 'DRUser
|
||||
DCShowUpgradeGroupLink_ :: DirectoryCmdTag 'DRUser
|
||||
DCApproveGroup_ :: DirectoryCmdTag 'DRAdmin
|
||||
DCRejectGroup_ :: DirectoryCmdTag 'DRAdmin
|
||||
DCSuspendGroup_ :: DirectoryCmdTag 'DRAdmin
|
||||
DCResumeGroup_ :: DirectoryCmdTag 'DRAdmin
|
||||
DCListLastGroups_ :: DirectoryCmdTag 'DRAdmin
|
||||
DCListPendingGroups_ :: DirectoryCmdTag 'DRAdmin
|
||||
DCSendToGroupOwner_ :: DirectoryCmdTag 'DRAdmin
|
||||
DCInviteOwnerToGroup_ :: DirectoryCmdTag 'DRAdmin
|
||||
-- DCAddBlockedWord_ :: DirectoryCmdTag 'DRAdmin
|
||||
-- DCRemoveBlockedWord_ :: DirectoryCmdTag 'DRAdmin
|
||||
DCPromoteGroup_ :: DirectoryCmdTag 'DRSuperUser
|
||||
DCExecuteCommand_ :: DirectoryCmdTag 'DRSuperUser
|
||||
|
||||
deriving instance Show (DirectoryCmdTag r)
|
||||
|
||||
data ADirectoryCmdTag = forall r. ADCT (SDirectoryRole r) (DirectoryCmdTag r)
|
||||
|
||||
data DirectoryHelpSection = DHSRegistration | DHSCommands
|
||||
deriving (Show)
|
||||
|
||||
data DirectoryCmd (r :: DirectoryRole) where
|
||||
DCHelp :: DirectoryHelpSection -> DirectoryCmd 'DRUser
|
||||
DCSearchGroup :: Text -> Maybe MarkdownList -> DirectoryCmd 'DRUser
|
||||
DCSearchNext :: DirectoryCmd 'DRUser
|
||||
DCAllGroups :: DirectoryCmd 'DRUser
|
||||
DCRecentGroups :: DirectoryCmd 'DRUser
|
||||
DCSubmitGroup :: ConnReqContact -> DirectoryCmd 'DRUser
|
||||
DCConfirmDuplicateGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser
|
||||
DCListUserGroups :: DirectoryCmd 'DRUser
|
||||
DCDeleteGroup :: UserGroupRegId -> GroupName -> 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
|
||||
DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
|
||||
DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
|
||||
DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
|
||||
DCListLastGroups :: Int -> DirectoryCmd 'DRAdmin
|
||||
DCListPendingGroups :: Int -> DirectoryCmd 'DRAdmin
|
||||
DCSendToGroupOwner :: GroupId -> GroupName -> Text -> DirectoryCmd 'DRAdmin
|
||||
DCInviteOwnerToGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
|
||||
-- DCAddBlockedWord :: Text -> DirectoryCmd 'DRAdmin
|
||||
-- DCRemoveBlockedWord :: Text -> DirectoryCmd 'DRAdmin
|
||||
DCPromoteGroup :: GroupId -> GroupName -> Bool -> DirectoryCmd 'DRSuperUser
|
||||
DCExecuteCommand :: String -> DirectoryCmd 'DRSuperUser
|
||||
DCUnknownCommand :: DirectoryCmd 'DRUser
|
||||
DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r
|
||||
|
||||
deriving instance Show (DirectoryCmd r)
|
||||
|
||||
data ADirectoryCmd = forall r. ADC (SDirectoryRole r) (DirectoryCmd r)
|
||||
|
||||
deriving instance Show ADirectoryCmd
|
||||
|
||||
directoryCmdP :: Maybe MarkdownList -> Parser ADirectoryCmd
|
||||
directoryCmdP ft =
|
||||
(A.char '/' *> cmdStrP)
|
||||
<|> (A.char '.' $> ADC SDRUser DCSearchNext)
|
||||
<|> (ADC SDRUser . (`DCSearchGroup` ft) <$> A.takeText)
|
||||
where
|
||||
cmdStrP =
|
||||
(tagP >>= \(ADCT u t) -> ADC u <$> (cmdP t <|> pure (DCCommandError t)))
|
||||
<|> pure (ADC SDRUser DCUnknownCommand)
|
||||
tagP =
|
||||
A.takeTill isSpace >>= \case
|
||||
"help" -> u DCHelp_
|
||||
"h" -> u DCHelp_
|
||||
"next" -> u DCSearchNext_
|
||||
"all" -> u DCAllGroups_
|
||||
"new" -> u DCRecentGroups_
|
||||
"submit" -> u DCSubmitGroup_
|
||||
"confirm" -> u DCConfirmDuplicateGroup_
|
||||
"list" -> u DCListUserGroups_
|
||||
"ls" -> u DCListUserGroups_
|
||||
"delete" -> u DCDeleteGroup_
|
||||
"role" -> u DCMemberRole_
|
||||
"filter" -> u DCGroupFilter_
|
||||
"link" -> u DCShowUpgradeGroupLink_
|
||||
"approve" -> au DCApproveGroup_
|
||||
"reject" -> au DCRejectGroup_
|
||||
"suspend" -> au DCSuspendGroup_
|
||||
"resume" -> au DCResumeGroup_
|
||||
"last" -> au DCListLastGroups_
|
||||
"pending" -> au DCListPendingGroups_
|
||||
"owner" -> au DCSendToGroupOwner_
|
||||
"invite" -> au DCInviteOwnerToGroup_
|
||||
-- "block_word" -> au DCAddBlockedWord_
|
||||
-- "unblock_word" -> au DCRemoveBlockedWord_
|
||||
"promote" -> su DCPromoteGroup_
|
||||
"exec" -> su DCExecuteCommand_
|
||||
"x" -> su DCExecuteCommand_
|
||||
_ -> fail "bad command tag"
|
||||
where
|
||||
u = pure . ADCT SDRUser
|
||||
au = pure . ADCT SDRAdmin
|
||||
su = pure . ADCT SDRSuperUser
|
||||
cmdP :: DirectoryCmdTag r -> Parser (DirectoryCmd r)
|
||||
cmdP = \case
|
||||
DCHelp_ -> DCHelp . fromMaybe DHSRegistration <$> optional (A.takeWhile isSpace *> helpSectionP)
|
||||
where
|
||||
helpSectionP =
|
||||
A.takeText >>= \case
|
||||
"registration" -> pure DHSRegistration
|
||||
"r" -> pure DHSRegistration
|
||||
"commands" -> pure DHSCommands
|
||||
"c" -> pure DHSCommands
|
||||
_ -> fail "bad help section"
|
||||
DCSearchNext_ -> pure DCSearchNext
|
||||
DCAllGroups_ -> pure DCAllGroups
|
||||
DCRecentGroups_ -> pure DCRecentGroups
|
||||
DCSubmitGroup_ -> fmap DCSubmitGroup . strDecode . encodeUtf8 <$?> (spacesP *> A.takeText)
|
||||
DCConfirmDuplicateGroup_ -> gc DCConfirmDuplicateGroup
|
||||
DCListUserGroups_ -> pure DCListUserGroups
|
||||
DCDeleteGroup_ -> gc DCDeleteGroup
|
||||
DCMemberRole_ -> do
|
||||
(groupId, displayName_) <- gc_ (,)
|
||||
memberRole_ <- optional $ spacesP *> ("member" $> GRMember <|> "observer" $> GRObserver)
|
||||
pure $ DCMemberRole groupId displayName_ memberRole_
|
||||
DCGroupFilter_ -> do
|
||||
(groupId, displayName_) <- gc_ (,)
|
||||
acceptance_ <-
|
||||
(A.takeWhile isSpace >> A.endOfInput) $> Nothing
|
||||
<|> Just <$> (acceptancePresetsP <|> acceptanceFiltersP)
|
||||
pure $ DCGroupFilter groupId displayName_ acceptance_
|
||||
where
|
||||
acceptancePresetsP =
|
||||
spacesP
|
||||
*> A.choice
|
||||
[ "off" $> noJoinFilter,
|
||||
"basic" $> basicJoinFilter,
|
||||
("moderate" <|> "mod") $> moderateJoinFilter,
|
||||
"strong" $> strongJoinFilter
|
||||
]
|
||||
acceptanceFiltersP = do
|
||||
rejectNames <- filterP "name"
|
||||
passCaptcha <- filterP "captcha"
|
||||
makeObserver <- filterP "observer"
|
||||
pure DirectoryMemberAcceptance {rejectNames, passCaptcha, makeObserver}
|
||||
filterP :: Text -> Parser (Maybe ProfileCondition)
|
||||
filterP s = Just <$> (spacesP *> A.string s *> conditionP) <|> pure Nothing
|
||||
conditionP =
|
||||
"=all" $> PCAll
|
||||
<|> ("=noimage" <|> "=no_image" <|> "=no-image") $> PCNoImage
|
||||
<|> 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}
|
||||
DCRejectGroup_ -> gc DCRejectGroup
|
||||
DCSuspendGroup_ -> gc DCSuspendGroup
|
||||
DCResumeGroup_ -> gc DCResumeGroup
|
||||
DCListLastGroups_ -> DCListLastGroups <$> (A.space *> A.decimal <|> pure 10)
|
||||
DCListPendingGroups_ -> DCListPendingGroups <$> (A.space *> A.decimal <|> pure 10)
|
||||
DCSendToGroupOwner_ -> do
|
||||
(groupId, displayName) <- gc (,)
|
||||
msg <- A.space *> A.takeText
|
||||
pure $ DCSendToGroupOwner groupId displayName msg
|
||||
DCInviteOwnerToGroup_ -> gc DCInviteOwnerToGroup
|
||||
-- DCAddBlockedWord_ -> DCAddBlockedWord <$> wordP
|
||||
-- DCRemoveBlockedWord_ -> DCRemoveBlockedWord <$> wordP
|
||||
DCPromoteGroup_ -> do
|
||||
(groupId, displayName) <- gc (,)
|
||||
promote <- A.space *> onOffP
|
||||
pure $ DCPromoteGroup groupId displayName promote
|
||||
DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (spacesP *> A.takeText)
|
||||
where
|
||||
gc f = f <$> (spacesP *> A.decimal) <*> (A.char ':' *> displayNameTextP)
|
||||
gc_ f = f <$> (spacesP *> A.decimal) <*> optional (A.char ':' *> displayNameTextP)
|
||||
-- wordP = spacesP *> A.takeTill isSpace
|
||||
spacesP = A.takeWhile1 isSpace
|
||||
onOffP = (A.string "on" $> True) <|> (A.string "off" $> False)
|
||||
|
||||
directoryCmdTag :: DirectoryCmd r -> Text
|
||||
directoryCmdTag = \case
|
||||
DCHelp _ -> "help"
|
||||
DCSearchGroup {} -> "search"
|
||||
DCSearchNext -> "next"
|
||||
DCAllGroups -> "all"
|
||||
DCRecentGroups -> "new"
|
||||
DCSubmitGroup _ -> "submit"
|
||||
DCConfirmDuplicateGroup {} -> "confirm"
|
||||
DCListUserGroups -> "list"
|
||||
DCDeleteGroup {} -> "delete"
|
||||
DCApproveGroup {} -> "approve"
|
||||
DCMemberRole {} -> "role"
|
||||
DCGroupFilter {} -> "filter"
|
||||
DCShowUpgradeGroupLink {} -> "link"
|
||||
DCRejectGroup {} -> "reject"
|
||||
DCSuspendGroup {} -> "suspend"
|
||||
DCResumeGroup {} -> "resume"
|
||||
DCListLastGroups _ -> "last"
|
||||
DCListPendingGroups _ -> "pending"
|
||||
DCSendToGroupOwner {} -> "owner"
|
||||
DCInviteOwnerToGroup {} -> "invite"
|
||||
-- DCAddBlockedWord _ -> "block_word"
|
||||
-- DCRemoveBlockedWord _ -> "unblock_word"
|
||||
DCPromoteGroup {} -> "promote"
|
||||
DCExecuteCommand _ -> "exec"
|
||||
DCUnknownCommand -> "unknown"
|
||||
DCCommandError _ -> "error"
|
||||
171
bots/haskell/simplexxx-directory/src/Directory/Listing.hs
Normal file
171
bots/haskell/simplexxx-directory/src/Directory/Listing.hs
Normal file
@@ -0,0 +1,171 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Directory.Listing where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Monad
|
||||
import Crypto.Hash (Digest, MD5)
|
||||
import qualified Crypto.Hash as CH
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.TH as JQ
|
||||
import qualified Data.ByteArray as BA
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import qualified Data.ByteString.Base64.URL as B64URL
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Int (Int64)
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Clock.System
|
||||
import Data.Time.Format.ISO8601 (iso8601Show)
|
||||
import Directory.Store
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
|
||||
directoryDataPath :: String
|
||||
directoryDataPath = "data"
|
||||
|
||||
listingFileName :: String
|
||||
listingFileName = "listing.json"
|
||||
|
||||
promotedFileName :: String
|
||||
promotedFileName = "promoted.json"
|
||||
|
||||
listingImageFolder :: String
|
||||
listingImageFolder = "images"
|
||||
|
||||
data DirectoryEntryType = DETGroup
|
||||
{ groupType :: Maybe GroupType,
|
||||
admission :: Maybe GroupMemberAdmission,
|
||||
summary :: GroupSummary
|
||||
}
|
||||
|
||||
$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "DET") ''DirectoryEntryType)
|
||||
|
||||
data PublicLink = PublicLink
|
||||
{ connFullLink :: Maybe ConnReqContact,
|
||||
connShortLink :: Maybe ShortLinkContact
|
||||
}
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''PublicLink)
|
||||
|
||||
data DirectoryEntry = DirectoryEntry
|
||||
{ entryType :: DirectoryEntryType,
|
||||
displayName :: Text,
|
||||
groupLink :: PublicLink,
|
||||
shortDescr :: Maybe MarkdownList,
|
||||
welcomeMessage :: Maybe MarkdownList,
|
||||
imageFile :: Maybe String,
|
||||
activeAt :: Maybe UTCTime,
|
||||
createdAt :: Maybe UTCTime
|
||||
}
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''DirectoryEntry)
|
||||
|
||||
data DirectoryListing = DirectoryListing {entries :: [DirectoryEntry]}
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''DirectoryListing)
|
||||
|
||||
type ImageFileData = ByteString
|
||||
|
||||
newOrActive :: NominalDiffTime
|
||||
newOrActive = 30 * nominalDay
|
||||
|
||||
recentRoundedTime :: Int64 -> UTCTime -> UTCTime -> Maybe UTCTime
|
||||
recentRoundedTime roundTo now t
|
||||
| diffUTCTime now t > newOrActive = Nothing
|
||||
| otherwise =
|
||||
let secs = (systemSeconds (utcToSystemTime t) `div` roundTo) * roundTo
|
||||
in Just $ systemToUTCTime $ MkSystemTime secs 0
|
||||
|
||||
groupDirectoryEntry :: UTCTime -> GroupInfo -> Maybe GroupLink -> Maybe (DirectoryEntry, Maybe (FilePath, ImageFileData))
|
||||
groupDirectoryEntry now GroupInfo {groupProfile, chatTs, createdAt, groupSummary} gLink_ =
|
||||
let GroupProfile {displayName, shortDescr, description, image, memberAdmission, publicGroup} = groupProfile
|
||||
gt = (\PublicGroupProfile {groupType} -> groupType) <$> publicGroup
|
||||
entryType = DETGroup gt memberAdmission groupSummary
|
||||
description' = case publicGroup of
|
||||
Just PublicGroupProfile {groupType = gt', groupLink = sLnk} ->
|
||||
let gtStr = case gt' of GTChannel -> "channel"; _ -> "group"
|
||||
linkLine = "Link to join the " <> gtStr <> " " <> displayName <> ": " <> decodeUtf8 (strEncode sLnk)
|
||||
in Just $ maybe linkLine (<> "\n\n" <> linkLine) description
|
||||
Nothing -> description
|
||||
entry groupLink =
|
||||
let de =
|
||||
DirectoryEntry
|
||||
{ entryType,
|
||||
displayName,
|
||||
groupLink,
|
||||
shortDescr = toFormattedText <$> shortDescr,
|
||||
welcomeMessage = toFormattedText <$> description',
|
||||
imageFile = fst <$> imgData,
|
||||
activeAt = recentRoundedTime 900 now $ fromMaybe createdAt chatTs,
|
||||
createdAt = recentRoundedTime 86400 now createdAt
|
||||
}
|
||||
imgData = imgFileData groupLink =<< image
|
||||
in (de, imgData)
|
||||
in case publicGroup of
|
||||
Just PublicGroupProfile {groupLink = sLnk} ->
|
||||
Just $ entry $ PublicLink Nothing (Just sLnk)
|
||||
Nothing ->
|
||||
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
|
||||
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
|
||||
forM_ img $ \(imgFile, imgData) -> B.writeFile (newDir </> imgFile) imgData
|
||||
pure (g', gr)
|
||||
saveListing newDir listingFileName gs'
|
||||
saveListing newDir promotedFileName $ filter (\(_, GroupReg {promoted}) -> promoted) gs'
|
||||
-- atomically update the link
|
||||
let newSymLink = newDir <> ".link"
|
||||
symLink = dir </> directoryDataPath
|
||||
createDirectoryLink newDirPath newSymLink
|
||||
renamePath newSymLink symLink
|
||||
mapM_ (removePathForcibly . (dir </>)) oldDirs
|
||||
where
|
||||
saveListing newDir f = LB.writeFile (newDir </> f) . J.encode . DirectoryListing . map fst
|
||||
|
||||
toFormattedText :: Text -> MarkdownList
|
||||
toFormattedText t = fromMaybe [FormattedText Nothing t] $ parseMaybeMarkdownList t
|
||||
236
bots/haskell/simplexxx-directory/src/Directory/Options.hs
Normal file
236
bots/haskell/simplexxx-directory/src/Directory/Options.hs
Normal file
@@ -0,0 +1,236 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Directory.Options
|
||||
( DirectoryOpts (..),
|
||||
MigrateLog (..),
|
||||
getDirectoryOpts,
|
||||
directoryOpts,
|
||||
mkChatOpts,
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
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 (ChatCmdLog (..), ChatOpts (..), CoreChatOpts, CreateBotOpts (..), coreChatOptsP)
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
|
||||
data DirectoryOpts = DirectoryOpts
|
||||
{ coreOptions :: CoreChatOpts,
|
||||
adminUsers :: [KnownContact],
|
||||
superUsers :: [KnownContact],
|
||||
ownersGroup :: Maybe KnownGroup,
|
||||
noAddress :: Bool, -- skip creating address
|
||||
blockedWordsFile :: Maybe FilePath,
|
||||
blockedFragmentsFile :: Maybe FilePath,
|
||||
blockedExtensionRules :: Maybe FilePath,
|
||||
nameSpellingFile :: Maybe FilePath,
|
||||
profileNameLimit :: Int,
|
||||
captchaGenerator :: Maybe FilePath,
|
||||
voiceCaptchaGenerator :: Maybe FilePath,
|
||||
directoryLog :: Maybe FilePath,
|
||||
migrateDirectoryLog :: Maybe MigrateLog,
|
||||
serviceName :: T.Text,
|
||||
runCLI :: Bool,
|
||||
searchResults :: Int,
|
||||
webFolder :: Maybe FilePath,
|
||||
linkCheckInterval :: Int,
|
||||
testing :: Bool
|
||||
}
|
||||
|
||||
data MigrateLog = MLCheck | MLImport | MLExport | MLListing
|
||||
|
||||
directoryOpts :: FilePath -> FilePath -> Parser DirectoryOpts
|
||||
directoryOpts appDir defaultDbName = do
|
||||
coreOptions <- coreChatOptsP appDir defaultDbName
|
||||
adminUsers <-
|
||||
option
|
||||
parseKnownContacts
|
||||
( long "admin-users"
|
||||
<> metavar "ADMIN_USERS"
|
||||
<> value []
|
||||
<> help "Comma-separated list of admin-users in the format CONTACT_ID:DISPLAY_NAME who will be allowed to manage the directory"
|
||||
)
|
||||
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"
|
||||
)
|
||||
ownersGroup <-
|
||||
optional $
|
||||
option
|
||||
parseKnownGroup
|
||||
( long "owners-group"
|
||||
<> metavar "OWNERS_GROUP"
|
||||
<> help "The group of group owners in the format GROUP_ID:DISPLAY_NAME - owners of listed groups will be invited automatically"
|
||||
)
|
||||
noAddress <-
|
||||
switch
|
||||
( long "no-address"
|
||||
<> help "skip checking and creating service address"
|
||||
)
|
||||
blockedWordsFile <-
|
||||
optional $
|
||||
strOption
|
||||
( long "blocked-words-file"
|
||||
<> metavar "BLOCKED_WORDS_FILE"
|
||||
<> help "File with the basic forms of words not allowed in profiles"
|
||||
)
|
||||
blockedFragmentsFile <-
|
||||
optional $
|
||||
strOption
|
||||
( long "blocked-fragments-file"
|
||||
<> metavar "BLOCKED_WORDS_FILE"
|
||||
<> help "File with the basic forms of word fragments not allowed in profiles"
|
||||
)
|
||||
blockedExtensionRules <-
|
||||
optional $
|
||||
strOption
|
||||
( long "blocked-extenstion-rules"
|
||||
<> metavar "BLOCKED_EXTENSION_RULES"
|
||||
<> help "Substitions to extend the list of blocked words"
|
||||
)
|
||||
nameSpellingFile <-
|
||||
optional $
|
||||
strOption
|
||||
( long "name-spelling-file"
|
||||
<> metavar "NAME_SPELLING_FILE"
|
||||
<> help "File with the character substitions to match in profile names"
|
||||
)
|
||||
profileNameLimit <-
|
||||
option
|
||||
auto
|
||||
( long "profile-name-limit"
|
||||
<> metavar "PROFILE_NAME_LIMIT"
|
||||
<> help "Max length of profile name that will be allowed to connect and to join groups"
|
||||
<> value maxBound
|
||||
)
|
||||
captchaGenerator <-
|
||||
optional $
|
||||
strOption
|
||||
( long "captcha-generator"
|
||||
<> metavar "CAPTCHA_GENERATOR"
|
||||
<> help "Executable to generate captcha files, must accept text as parameter and save file to stdout as base64 up to 12500 bytes"
|
||||
)
|
||||
voiceCaptchaGenerator <-
|
||||
optional $
|
||||
strOption
|
||||
( long "voice-captcha-generator"
|
||||
<> metavar "VOICE_CAPTCHA_GENERATOR"
|
||||
<> help "Executable to generate voice captcha, accepts text as parameter, writes audio file, outputs file_path and duration_seconds to stdout"
|
||||
)
|
||||
directoryLog <-
|
||||
optional $
|
||||
strOption
|
||||
( long "directory-file"
|
||||
<> metavar "DIRECTORY_FILE"
|
||||
<> help "Append only log for directory state"
|
||||
)
|
||||
migrateDirectoryLog <-
|
||||
optional $
|
||||
option
|
||||
parseMigrateLog
|
||||
( long "migrate-directory-file"
|
||||
<> metavar "MIGRATE_COMMAND"
|
||||
<> help "Command to import/export directory log file"
|
||||
)
|
||||
serviceName <-
|
||||
strOption
|
||||
( long "service-name"
|
||||
<> metavar "SERVICE_NAME"
|
||||
<> help "The display name of the directory service bot, without *'s and spaces (SimpleXXX)"
|
||||
<> value "SimpleXXX"
|
||||
)
|
||||
runCLI <-
|
||||
switch
|
||||
( long "run-cli"
|
||||
<> help "Run directory service as CLI"
|
||||
)
|
||||
webFolder <-
|
||||
optional $
|
||||
strOption
|
||||
( long "web-folder"
|
||||
<> metavar "WEB_FOLDER"
|
||||
<> help "Folder to store static web assets"
|
||||
)
|
||||
linkCheckInterval <-
|
||||
option
|
||||
auto
|
||||
( long "link-check-interval"
|
||||
<> metavar "SECONDS"
|
||||
<> help "Interval in seconds to check public group link data (default: 1800)"
|
||||
<> value 1800
|
||||
)
|
||||
pure
|
||||
DirectoryOpts
|
||||
{ coreOptions,
|
||||
adminUsers,
|
||||
superUsers,
|
||||
ownersGroup,
|
||||
noAddress,
|
||||
blockedWordsFile,
|
||||
blockedFragmentsFile,
|
||||
blockedExtensionRules,
|
||||
nameSpellingFile,
|
||||
profileNameLimit,
|
||||
captchaGenerator,
|
||||
voiceCaptchaGenerator,
|
||||
directoryLog,
|
||||
migrateDirectoryLog,
|
||||
serviceName = T.pack serviceName,
|
||||
runCLI,
|
||||
searchResults = 10,
|
||||
webFolder,
|
||||
linkCheckInterval,
|
||||
testing = False
|
||||
}
|
||||
|
||||
getDirectoryOpts :: FilePath -> FilePath -> IO DirectoryOpts
|
||||
getDirectoryOpts appDir defaultDbName =
|
||||
execParser $
|
||||
info
|
||||
(helper <*> versionOption <*> directoryOpts appDir defaultDbName)
|
||||
(header versionStr <> fullDesc <> progDesc "Start SimpleXXX 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, serviceName} =
|
||||
ChatOpts
|
||||
{ coreOptions,
|
||||
chatCmd = "",
|
||||
chatCmdDelay = 3,
|
||||
chatCmdLog = CCLNone,
|
||||
chatServerPort = Nothing,
|
||||
optFilesFolder = Nothing,
|
||||
optTempDirectory = Nothing,
|
||||
showReactions = False,
|
||||
allowInstantFiles = True,
|
||||
autoAcceptFileSize = 0,
|
||||
muteNotifications = True,
|
||||
markRead = False,
|
||||
createBot = Just CreateBotOpts {botDisplayName = serviceName, allowFiles = False}
|
||||
}
|
||||
|
||||
parseMigrateLog :: ReadM MigrateLog
|
||||
parseMigrateLog = eitherReader $ parseAll mlP . encodeUtf8 . T.pack
|
||||
where
|
||||
mlP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"check" -> pure MLCheck
|
||||
"import" -> pure MLImport
|
||||
"export" -> pure MLExport
|
||||
"listing" -> pure MLListing
|
||||
_ -> fail "bad MigrateLog"
|
||||
13
bots/haskell/simplexxx-directory/src/Directory/Search.hs
Normal file
13
bots/haskell/simplexxx-directory/src/Directory/Search.hs
Normal file
@@ -0,0 +1,13 @@
|
||||
module Directory.Search where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Simplex.Chat.Types
|
||||
|
||||
data SearchRequest = SearchRequest
|
||||
{ searchType :: SearchType,
|
||||
searchTime :: UTCTime,
|
||||
lastGroup :: GroupId -- cursor for search
|
||||
}
|
||||
|
||||
data SearchType = STAll | STRecent | STSearch Text
|
||||
1538
bots/haskell/simplexxx-directory/src/Directory/Service.hs
Normal file
1538
bots/haskell/simplexxx-directory/src/Directory/Service.hs
Normal file
File diff suppressed because it is too large
Load Diff
587
bots/haskell/simplexxx-directory/src/Directory/Store.hs
Normal file
587
bots/haskell/simplexxx-directory/src/Directory/Store.hs
Normal file
@@ -0,0 +1,587 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Directory.Store
|
||||
( DirectoryLog (..),
|
||||
GroupReg (..),
|
||||
GroupRegStatus (..),
|
||||
UserGroupRegId,
|
||||
GroupApprovalId,
|
||||
DirectoryGroupData (..),
|
||||
DirectoryMemberAcceptance (..),
|
||||
DirectoryStatus (..),
|
||||
ProfileCondition (..),
|
||||
DirectoryLogRecord (..),
|
||||
openDirectoryLog,
|
||||
readDirectoryLogData,
|
||||
addGroupRegStore,
|
||||
insertGroupReg,
|
||||
delGroupReg,
|
||||
deleteGroupReg,
|
||||
setGroupStatusStore,
|
||||
setGroupStatusPromoStore,
|
||||
setGroupPromotedStore,
|
||||
grDirectoryStatus,
|
||||
setGroupRegOwner,
|
||||
getUserGroupReg,
|
||||
getUserGroupRegs,
|
||||
getAllGroupRegs_,
|
||||
getDuplicateGroupRegs,
|
||||
getGroupReg,
|
||||
getGroupAndReg,
|
||||
listLastGroups,
|
||||
listPendingGroups,
|
||||
getAllListedGroups,
|
||||
getAllListedGroups_,
|
||||
searchListedGroups,
|
||||
groupRegStatusText,
|
||||
pendingApproval,
|
||||
groupRemoved,
|
||||
fromCustomData,
|
||||
toCustomData,
|
||||
noJoinFilter,
|
||||
basicJoinFilter,
|
||||
moderateJoinFilter,
|
||||
strongJoinFilter,
|
||||
groupDBError,
|
||||
logGCreate,
|
||||
logGDelete,
|
||||
logGUpdateOwner,
|
||||
logGUpdateStatus,
|
||||
logGUpdatePromotion,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Aeson ((.:), (.=))
|
||||
import qualified Data.Aeson.KeyMap as JM
|
||||
import qualified Data.Aeson.TH as JQ
|
||||
import qualified Data.Aeson.Types as JT
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
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.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
||||
import Data.Time.Clock.System (systemEpochDay)
|
||||
import Directory.Search
|
||||
import Directory.Util
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Protocol (supportedChatVRange)
|
||||
import Simplex.Chat.Options.DB (FromField (..), ToField (..))
|
||||
import Simplex.Chat.Store
|
||||
import Simplex.Chat.Store.Groups
|
||||
import Simplex.Chat.Store.Shared (groupInfoQueryFields, groupInfoQueryFrom)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Store.DB (BoolInt (..), fromTextField_)
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, firstRow, maybeFirstRow', safeDecodeUtf8)
|
||||
import System.IO (BufferMode (..), Handle, IOMode (..), hSetBuffering, openFile)
|
||||
|
||||
#if defined(dbPostgres)
|
||||
import Database.PostgreSQL.Simple (Only (..), Query, (:.) (..))
|
||||
import Database.PostgreSQL.Simple.SqlQQ (sql)
|
||||
#else
|
||||
import Database.SQLite.Simple (Only (..), Query, (:.) (..))
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
#endif
|
||||
|
||||
data DirectoryLog = DirectoryLog
|
||||
{ directoryLogFile :: Maybe Handle
|
||||
}
|
||||
|
||||
data GroupReg = GroupReg
|
||||
{ dbGroupId :: GroupId,
|
||||
userGroupRegId :: UserGroupRegId,
|
||||
dbContactId :: ContactId,
|
||||
dbOwnerMemberId :: Maybe GroupMemberId,
|
||||
groupRegStatus :: GroupRegStatus,
|
||||
promoted :: Bool,
|
||||
createdAt :: UTCTime
|
||||
}
|
||||
|
||||
data DirectoryGroupData = DirectoryGroupData
|
||||
{ memberAcceptance :: DirectoryMemberAcceptance
|
||||
}
|
||||
|
||||
-- these filters are applied in the order of fields, depending on ProfileCondition:
|
||||
-- Nothing - do not apply
|
||||
-- Just
|
||||
-- PCAll - apply to all profiles
|
||||
-- PCNoImage - apply to profiles without images
|
||||
data DirectoryMemberAcceptance = DirectoryMemberAcceptance
|
||||
{ rejectNames :: Maybe ProfileCondition, -- reject long names and names with profanity
|
||||
passCaptcha :: Maybe ProfileCondition, -- run captcha challenge with joining members
|
||||
makeObserver :: Maybe ProfileCondition -- the role assigned in the end, after captcha challenge
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ProfileCondition = PCAll | PCNoImage deriving (Eq, Show)
|
||||
|
||||
noJoinFilter :: DirectoryMemberAcceptance
|
||||
noJoinFilter = DirectoryMemberAcceptance Nothing Nothing Nothing
|
||||
|
||||
basicJoinFilter :: DirectoryMemberAcceptance
|
||||
basicJoinFilter =
|
||||
DirectoryMemberAcceptance
|
||||
{ rejectNames = Just PCNoImage,
|
||||
passCaptcha = Nothing,
|
||||
makeObserver = Nothing
|
||||
}
|
||||
|
||||
moderateJoinFilter :: DirectoryMemberAcceptance
|
||||
moderateJoinFilter =
|
||||
DirectoryMemberAcceptance
|
||||
{ rejectNames = Just PCAll,
|
||||
passCaptcha = Just PCNoImage,
|
||||
makeObserver = Nothing
|
||||
}
|
||||
|
||||
strongJoinFilter :: DirectoryMemberAcceptance
|
||||
strongJoinFilter =
|
||||
DirectoryMemberAcceptance
|
||||
{ rejectNames = Just PCAll,
|
||||
passCaptcha = Just PCAll,
|
||||
makeObserver = Nothing
|
||||
}
|
||||
|
||||
type UserGroupRegId = Int64
|
||||
|
||||
type GroupApprovalId = Int64
|
||||
|
||||
data GroupRegStatus
|
||||
= GRSPendingConfirmation
|
||||
| GRSProposed
|
||||
| GRSPendingUpdate
|
||||
| GRSPendingApproval GroupApprovalId
|
||||
| GRSActive
|
||||
| GRSSuspended
|
||||
| GRSSuspendedBadRoles
|
||||
| GRSRemoved
|
||||
deriving (Eq, Show)
|
||||
|
||||
pendingApproval :: GroupRegStatus -> Bool
|
||||
pendingApproval = \case
|
||||
GRSPendingApproval _ -> True
|
||||
_ -> False
|
||||
|
||||
groupRemoved :: GroupRegStatus -> Bool
|
||||
groupRemoved = \case
|
||||
GRSRemoved -> True
|
||||
_ -> False
|
||||
|
||||
data DirectoryStatus = DSListed | DSReserved | DSRegistered | DSRemoved
|
||||
deriving (Eq)
|
||||
|
||||
groupRegStatusText :: GroupRegStatus -> Text
|
||||
groupRegStatusText = \case
|
||||
GRSPendingConfirmation -> "pending confirmation (duplicate names)"
|
||||
GRSProposed -> "proposed"
|
||||
GRSPendingUpdate -> "pending profile update"
|
||||
GRSPendingApproval _ -> "pending admin approval"
|
||||
GRSActive -> "active"
|
||||
GRSSuspended -> "suspended by admin"
|
||||
GRSSuspendedBadRoles -> "suspended because roles changed"
|
||||
GRSRemoved -> "removed"
|
||||
|
||||
grDirectoryStatus :: GroupRegStatus -> DirectoryStatus
|
||||
grDirectoryStatus = \case
|
||||
GRSActive -> DSListed
|
||||
GRSSuspended -> DSReserved
|
||||
GRSSuspendedBadRoles -> DSReserved
|
||||
GRSRemoved -> DSRemoved
|
||||
_ -> DSRegistered
|
||||
|
||||
$(JQ.deriveJSON (enumJSON $ dropPrefix "PC") ''ProfileCondition)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''DirectoryMemberAcceptance)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''DirectoryGroupData)
|
||||
|
||||
fromCustomData :: Maybe CustomData -> DirectoryGroupData
|
||||
fromCustomData cd_ =
|
||||
let memberAcceptance = fromMaybe noJoinFilter $ cd_ >>= \(CustomData o) -> JT.parseMaybe (.: "memberAcceptance") o
|
||||
in DirectoryGroupData {memberAcceptance}
|
||||
|
||||
toCustomData :: DirectoryGroupData -> CustomData
|
||||
toCustomData DirectoryGroupData {memberAcceptance} =
|
||||
CustomData $ JM.fromList ["memberAcceptance" .= memberAcceptance]
|
||||
|
||||
addGroupRegStore :: ChatController -> Contact -> GroupInfo -> GroupRegStatus -> IO (Either String GroupReg)
|
||||
addGroupRegStore cc Contact {contactId = dbContactId} GroupInfo {groupId = dbGroupId} groupRegStatus =
|
||||
withDB' "addGroupRegStore" cc $ \db -> do
|
||||
createdAt <- getCurrentTime
|
||||
maxUgrId <-
|
||||
maybeFirstRow' 0 (fromMaybe 0 . fromOnly) $
|
||||
DB.query db "SELECT MAX(user_group_reg_id) FROM sx_directory_group_regs WHERE contact_id = ?" (Only dbContactId)
|
||||
let gr = GroupReg {dbGroupId, userGroupRegId = maxUgrId + 1, dbContactId, dbOwnerMemberId = Nothing, groupRegStatus, promoted = False, createdAt}
|
||||
insertGroupReg db gr
|
||||
pure gr
|
||||
|
||||
insertGroupReg :: DB.Connection -> GroupReg -> IO ()
|
||||
insertGroupReg db GroupReg {dbGroupId, userGroupRegId, dbContactId, dbOwnerMemberId, groupRegStatus, promoted, createdAt} = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO sx_directory_group_regs
|
||||
(group_id, user_group_reg_id, contact_id, owner_member_id, group_reg_status, group_promoted, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
(dbGroupId, userGroupRegId, dbContactId, dbOwnerMemberId, groupRegStatus, BI promoted, createdAt, createdAt)
|
||||
|
||||
delGroupReg :: ChatController -> GroupId -> IO (Either String ())
|
||||
delGroupReg cc gId = withDB' "delGroupReg" cc (`deleteGroupReg` gId)
|
||||
|
||||
deleteGroupReg :: DB.Connection -> GroupId -> IO ()
|
||||
deleteGroupReg db gId = DB.execute db "DELETE FROM sx_directory_group_regs WHERE group_id = ?" (Only gId)
|
||||
|
||||
setGroupStatusStore :: ChatController -> GroupId -> GroupRegStatus -> IO (Either String (GroupRegStatus, GroupReg))
|
||||
setGroupStatusStore cc gId grStatus' =
|
||||
withDB "setGroupStatusStore" cc $ \db -> do
|
||||
gr <- getGroupReg_ db gId
|
||||
ts <- liftIO getCurrentTime
|
||||
liftIO $ DB.execute db "UPDATE sx_directory_group_regs SET group_reg_status = ?, updated_at = ? WHERE group_id = ?" (grStatus', ts, gId)
|
||||
pure (groupRegStatus gr, gr {groupRegStatus = grStatus'})
|
||||
|
||||
setGroupStatusPromoStore :: ChatController -> GroupId -> GroupRegStatus -> Bool -> IO (Either String (DirectoryStatus, Bool))
|
||||
setGroupStatusPromoStore cc gId grStatus' grPromoted' =
|
||||
withDB "setGroupStatusPromoStore" cc $ \db -> do
|
||||
GroupReg {groupRegStatus, promoted} <- getGroupReg_ db gId
|
||||
ts <- liftIO getCurrentTime
|
||||
liftIO $ DB.execute db "UPDATE sx_directory_group_regs SET group_reg_status = ?, group_promoted = ?, updated_at = ? WHERE group_id = ?" (grStatus', BI grPromoted', ts, gId)
|
||||
pure (grDirectoryStatus groupRegStatus, promoted)
|
||||
|
||||
setGroupPromotedStore :: ChatController -> GroupId -> Bool -> IO (Either String (DirectoryStatus, Bool))
|
||||
setGroupPromotedStore cc gId grPromoted' =
|
||||
withDB "setGroupPromotedStore" cc $ \db -> do
|
||||
GroupReg {groupRegStatus, promoted} <- getGroupReg_ db gId
|
||||
ts <- liftIO getCurrentTime
|
||||
liftIO $ DB.execute db "UPDATE sx_directory_group_regs SET group_promoted = ?, updated_at = ? WHERE group_id = ?" (BI grPromoted', ts, gId)
|
||||
pure (grDirectoryStatus groupRegStatus, promoted)
|
||||
|
||||
groupDBError :: StoreError -> String
|
||||
groupDBError = \case
|
||||
SEGroupNotFound _ -> "group not found"
|
||||
e -> show e
|
||||
|
||||
setGroupRegOwner :: ChatController -> GroupId -> GroupMember -> IO (Either String ())
|
||||
setGroupRegOwner cc gId owner = do
|
||||
ts <- getCurrentTime
|
||||
withDB' "setGroupRegOwner" cc $ \db ->
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE sx_directory_group_regs
|
||||
SET owner_member_id = ?, updated_at = ?
|
||||
WHERE group_id = ?
|
||||
|]
|
||||
(groupMemberId' owner, ts, gId)
|
||||
|
||||
getGroupReg :: ChatController -> GroupId -> IO (Either String GroupReg)
|
||||
getGroupReg cc gId = withDB "getGroupReg" cc (`getGroupReg_` gId)
|
||||
|
||||
getGroupReg_ :: DB.Connection -> GroupId -> ExceptT String IO GroupReg
|
||||
getGroupReg_ db gId =
|
||||
ExceptT $ firstRow rowToGroupReg "group registration not found" $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT group_id, user_group_reg_id, contact_id, owner_member_id, group_reg_status, group_promoted, created_at
|
||||
FROM sx_directory_group_regs
|
||||
WHERE group_id = ?
|
||||
|]
|
||||
(Only gId)
|
||||
|
||||
getGroupAndReg :: ChatController -> User -> GroupId -> IO (Either String (GroupInfo, GroupReg))
|
||||
getGroupAndReg cc user@User {userId, userContactId} gId =
|
||||
withDB "getGroupAndReg" cc $ \db ->
|
||||
ExceptT $ firstRow (toGroupInfoReg (vr cc) user) ("group " ++ show gId ++ " not found") $
|
||||
DB.query db (groupReqQuery <> " AND g.group_id = ?") (userId, userContactId, gId)
|
||||
|
||||
getUserGroupReg :: ChatController -> User -> ContactId -> UserGroupRegId -> IO (Either String (GroupInfo, GroupReg))
|
||||
getUserGroupReg cc user@User {userId, userContactId} ctId ugrId =
|
||||
withDB "getUserGroupReg" cc $ \db ->
|
||||
ExceptT $ firstRow (toGroupInfoReg (vr cc) user) ("group " ++ show ugrId ++ " not found") $
|
||||
DB.query db (groupReqQuery <> " AND r.contact_id = ? AND r.user_group_reg_id = ?") (userId, userContactId, ctId, ugrId)
|
||||
|
||||
getUserGroupRegs :: ChatController -> User -> ContactId -> IO (Either String [(GroupInfo, GroupReg)])
|
||||
getUserGroupRegs cc user@User {userId, userContactId} ctId =
|
||||
withDB' "getUserGroupRegs" cc $ \db ->
|
||||
map (toGroupInfoReg (vr cc) user)
|
||||
<$> DB.query db (groupReqQuery <> " AND r.contact_id = ? ORDER BY r.user_group_reg_id") (userId, userContactId, ctId)
|
||||
|
||||
getAllListedGroups :: ChatController -> User -> IO (Either String [(GroupInfo, GroupReg, Maybe GroupLink)])
|
||||
getAllListedGroups cc user = withDB' "getAllListedGroups" cc $ \db -> getAllListedGroups_ db (vr cc) user
|
||||
|
||||
getAllListedGroups_ :: DB.Connection -> VersionRangeChat -> User -> IO [(GroupInfo, GroupReg, Maybe GroupLink)]
|
||||
getAllListedGroups_ db vr' user@User {userId, userContactId} =
|
||||
DB.query db (groupReqQuery <> " AND r.group_reg_status = ?") (userId, userContactId, GRSActive)
|
||||
>>= mapM (withGroupLink . toGroupInfoReg vr' user)
|
||||
where
|
||||
withGroupLink (g, gr) = (g,gr,) . eitherToMaybe <$> runExceptT (getGroupLink db user g)
|
||||
|
||||
searchListedGroups :: ChatController -> User -> SearchType -> Maybe GroupId -> Int -> IO (Either String ([(GroupInfo, GroupReg)], Int))
|
||||
searchListedGroups cc user@User {userId, userContactId} searchType lastGroup_ pageSize =
|
||||
withDB' "searchListedGroups" cc $ \db ->
|
||||
case searchType of
|
||||
STAll -> case lastGroup_ of
|
||||
Nothing -> do
|
||||
gs <- groups $ DB.query db (listedGroupQuery <> orderBy <> " LIMIT ?") (userId, userContactId, GRSActive, pageSize)
|
||||
n <- count $ DB.query db countQuery' (Only GRSActive)
|
||||
pure (gs, n)
|
||||
Just gId -> do
|
||||
gs <- groups $ DB.query db (listedGroupQuery <> " AND r.group_id > ? " <> orderBy <> " LIMIT ?") (userId, userContactId, GRSActive, gId, pageSize)
|
||||
n <- count $ DB.query db (countQuery' <> " AND r.group_id > ?") (GRSActive, gId)
|
||||
pure (gs, n)
|
||||
where
|
||||
countQuery' = countQuery <> " WHERE r.group_reg_status = ? "
|
||||
orderBy = " ORDER BY g.summary_current_members_count DESC, r.group_reg_id ASC "
|
||||
STRecent -> case lastGroup_ of
|
||||
Nothing -> do
|
||||
gs <- groups $ DB.query db (listedGroupQuery <> orderBy <> " LIMIT ?") (userId, userContactId, GRSActive, pageSize)
|
||||
n <- count $ DB.query db countQuery' (Only GRSActive)
|
||||
pure (gs, n)
|
||||
Just gId -> do
|
||||
gs <- groups $ DB.query db (listedGroupQuery <> " AND r.group_id > ? " <> orderBy <> " LIMIT ?") (userId, userContactId, GRSActive, gId, pageSize)
|
||||
n <- count $ DB.query db (countQuery' <> " AND r.group_id > ?") (GRSActive, gId)
|
||||
pure (gs, n)
|
||||
where
|
||||
countQuery' = countQuery <> " WHERE r.group_reg_status = ? "
|
||||
orderBy = " ORDER BY r.created_at DESC, r.group_reg_id ASC "
|
||||
STSearch search -> case lastGroup_ of
|
||||
Nothing -> do
|
||||
gs <- groups $ DB.query db (listedGroupQuery <> searchCond <> orderBy <> " LIMIT ?") (userId, userContactId, GRSActive, s, s, s, s, pageSize)
|
||||
n <- count $ DB.query db (countQuery' <> searchCond) (GRSActive, s, s, s, s)
|
||||
pure (gs, n)
|
||||
Just gId -> do
|
||||
gs <- groups $ DB.query db (listedGroupQuery <> " AND r.group_id > ? " <> searchCond <> orderBy <> " LIMIT ?") (userId, userContactId, GRSActive, gId, s, s, s, s, pageSize)
|
||||
n <- count $ DB.query db (countQuery' <> " AND r.group_id > ? " <> searchCond) (GRSActive, gId, s, s, s, s)
|
||||
pure (gs, n)
|
||||
where
|
||||
s = T.toLower search
|
||||
countQuery' = countQuery <> " JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id WHERE r.group_reg_status = ? "
|
||||
orderBy = " ORDER BY g.summary_current_members_count DESC, r.group_reg_id ASC "
|
||||
where
|
||||
groups = (map (toGroupInfoReg (vr cc) user) <$>)
|
||||
count = maybeFirstRow' 0 fromOnly
|
||||
listedGroupQuery = groupReqQuery <> " AND r.group_reg_status = ? "
|
||||
countQuery = "SELECT COUNT(1) FROM groups g JOIN sx_directory_group_regs r ON g.group_id = r.group_id "
|
||||
searchCond =
|
||||
[sql|
|
||||
AND (LOWER(gp.display_name) LIKE '%' || ? || '%'
|
||||
OR LOWER(gp.full_name) LIKE '%' || ? || '%'
|
||||
OR LOWER(gp.short_descr) LIKE '%' || ? || '%'
|
||||
OR LOWER(gp.description) LIKE '%' || ? || '%'
|
||||
)
|
||||
|]
|
||||
|
||||
getAllGroupRegs_ :: DB.Connection -> User -> IO [(GroupInfo, GroupReg)]
|
||||
getAllGroupRegs_ db user@User {userId, userContactId} =
|
||||
map (toGroupInfoReg supportedChatVRange user)
|
||||
<$> DB.query db groupReqQuery (userId, userContactId)
|
||||
|
||||
getDuplicateGroupRegs :: ChatController -> User -> Text -> IO (Either String [(GroupInfo, GroupReg)])
|
||||
getDuplicateGroupRegs cc user@User {userId, userContactId} displayName =
|
||||
withDB' "getDuplicateGroupRegs" cc $ \db ->
|
||||
map (toGroupInfoReg (vr cc) user)
|
||||
<$> DB.query db (groupReqQuery <> " AND gp.display_name = ?") (userId, userContactId, displayName)
|
||||
|
||||
listLastGroups :: ChatController -> User -> Int -> IO (Either String ([(GroupInfo, GroupReg)], Int))
|
||||
listLastGroups cc user@User {userId, userContactId} count =
|
||||
withDB' "getUserGroupRegs" cc $ \db -> do
|
||||
gs <-
|
||||
map (toGroupInfoReg (vr cc) user)
|
||||
<$> DB.query db (groupReqQuery <> " ORDER BY group_reg_id DESC LIMIT ?") (userId, userContactId, count)
|
||||
n <- maybeFirstRow' 0 fromOnly $ DB.query_ db "SELECT COUNT(1) FROM sx_directory_group_regs"
|
||||
pure (gs, n)
|
||||
|
||||
listPendingGroups :: ChatController -> User -> Int -> IO (Either String ([(GroupInfo, GroupReg)], Int))
|
||||
listPendingGroups cc user@User {userId, userContactId} count =
|
||||
withDB' "getUserGroupRegs" cc $ \db -> do
|
||||
gs <-
|
||||
map (toGroupInfoReg (vr cc) user)
|
||||
<$> DB.query db (groupReqQuery <> " AND r.group_reg_status LIKE 'pending_approval%' ORDER BY group_reg_id DESC LIMIT ?") (userId, userContactId, count)
|
||||
n <- maybeFirstRow' 0 fromOnly $ DB.query_ db "SELECT COUNT(1) FROM sx_directory_group_regs WHERE group_reg_status LIKE 'pending_approval%'"
|
||||
pure (gs, n)
|
||||
|
||||
toGroupInfoReg :: VersionRangeChat -> User -> (GroupInfoRow :. GroupRegRow) -> (GroupInfo, GroupReg)
|
||||
toGroupInfoReg vr' User {userContactId} (groupRow :. grRow) =
|
||||
(toGroupInfo vr' userContactId [] groupRow, rowToGroupReg grRow)
|
||||
|
||||
type GroupRegRow = (GroupId, UserGroupRegId, ContactId, Maybe GroupMemberId, GroupRegStatus, BoolInt, UTCTime)
|
||||
|
||||
rowToGroupReg :: GroupRegRow -> GroupReg
|
||||
rowToGroupReg (dbGroupId, userGroupRegId, dbContactId, dbOwnerMemberId, groupRegStatus, BI promoted, createdAt) =
|
||||
GroupReg {dbGroupId, userGroupRegId, dbContactId, dbOwnerMemberId, groupRegStatus, promoted, createdAt}
|
||||
|
||||
groupReqQuery :: Query
|
||||
groupReqQuery = groupInfoQueryFields <> groupRegFields <> groupInfoQueryFrom <> groupRegFromCond
|
||||
where
|
||||
groupRegFields = ", r.group_id, r.user_group_reg_id, r.contact_id, r.owner_member_id, r.group_reg_status, r.group_promoted, r.created_at "
|
||||
groupRegFromCond = " JOIN sx_directory_group_regs r ON r.group_id = g.group_id WHERE g.user_id = ? AND mu.contact_id = ? "
|
||||
|
||||
data DirectoryLogRecord
|
||||
= GRCreate GroupReg
|
||||
| GRDelete GroupId
|
||||
| GRUpdateStatus GroupId GroupRegStatus
|
||||
| GRUpdatePromotion GroupId Bool
|
||||
| GRUpdateOwner GroupId GroupMemberId
|
||||
|
||||
data DLRTag
|
||||
= GRCreate_
|
||||
| GRDelete_
|
||||
| GRUpdateStatus_
|
||||
| GRUpdatePromotion_
|
||||
| GRUpdateOwner_
|
||||
|
||||
logDLR :: DirectoryLog -> DirectoryLogRecord -> IO ()
|
||||
logDLR st r = forM_ (directoryLogFile st) $ \h -> B.hPutStrLn h (strEncode r)
|
||||
|
||||
logGCreate :: DirectoryLog -> GroupReg -> IO ()
|
||||
logGCreate st = logDLR st . GRCreate
|
||||
|
||||
logGDelete :: DirectoryLog -> GroupId -> IO ()
|
||||
logGDelete st = logDLR st . GRDelete
|
||||
|
||||
logGUpdateStatus :: DirectoryLog -> GroupId -> GroupRegStatus -> IO ()
|
||||
logGUpdateStatus st gId = logDLR st . GRUpdateStatus gId
|
||||
|
||||
logGUpdatePromotion :: DirectoryLog -> GroupId -> Bool -> IO ()
|
||||
logGUpdatePromotion st gId = logDLR st . GRUpdatePromotion gId
|
||||
|
||||
logGUpdateOwner :: DirectoryLog -> GroupId -> GroupMemberId -> IO ()
|
||||
logGUpdateOwner st gId = logDLR st . GRUpdateOwner gId
|
||||
|
||||
instance StrEncoding DLRTag where
|
||||
strEncode = \case
|
||||
GRCreate_ -> "GCREATE"
|
||||
GRDelete_ -> "GDELETE"
|
||||
GRUpdateStatus_ -> "GSTATUS"
|
||||
GRUpdatePromotion_ -> "GPROMOTE"
|
||||
GRUpdateOwner_ -> "GOWNER"
|
||||
strP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"GCREATE" -> pure GRCreate_
|
||||
"GDELETE" -> pure GRDelete_
|
||||
"GSTATUS" -> pure GRUpdateStatus_
|
||||
"GPROMOTE" -> pure GRUpdatePromotion_
|
||||
"GOWNER" -> pure GRUpdateOwner_
|
||||
_ -> fail "invalid DLRTag"
|
||||
|
||||
instance StrEncoding DirectoryLogRecord where
|
||||
strEncode = \case
|
||||
GRCreate gr -> strEncode (GRCreate_, gr)
|
||||
GRDelete gId -> strEncode (GRDelete_, gId)
|
||||
GRUpdateStatus gId grStatus -> strEncode (GRUpdateStatus_, gId, grStatus)
|
||||
GRUpdatePromotion gId promoted -> strEncode (GRUpdatePromotion_, gId, promoted)
|
||||
GRUpdateOwner gId grOwnerId -> strEncode (GRUpdateOwner_, gId, grOwnerId)
|
||||
strP =
|
||||
strP_ >>= \case
|
||||
GRCreate_ -> GRCreate <$> strP
|
||||
GRDelete_ -> GRDelete <$> strP
|
||||
GRUpdateStatus_ -> GRUpdateStatus <$> A.decimal <*> _strP
|
||||
GRUpdatePromotion_ -> GRUpdatePromotion <$> A.decimal <*> _strP
|
||||
GRUpdateOwner_ -> GRUpdateOwner <$> A.decimal <* A.space <*> A.decimal
|
||||
|
||||
instance StrEncoding GroupReg where
|
||||
strEncode GroupReg {dbGroupId, userGroupRegId, dbContactId, dbOwnerMemberId, groupRegStatus, promoted} =
|
||||
B.unwords $
|
||||
[ "group_id=" <> strEncode dbGroupId,
|
||||
"user_group_id=" <> strEncode userGroupRegId,
|
||||
"contact_id=" <> strEncode dbContactId,
|
||||
"owner_member_id=" <> strEncode dbOwnerMemberId,
|
||||
"status=" <> strEncode groupRegStatus
|
||||
]
|
||||
<> ["promoted=" <> strEncode promoted | promoted]
|
||||
strP = do
|
||||
dbGroupId <- "group_id=" *> strP_
|
||||
userGroupRegId <- "user_group_id=" *> strP_
|
||||
dbContactId <- "contact_id=" *> strP_
|
||||
dbOwnerMemberId <- "owner_member_id=" *> strP_
|
||||
groupRegStatus <- "status=" *> strP
|
||||
promoted <- (" promoted=" *> strP) <|> pure False
|
||||
let createdAt = UTCTime systemEpochDay 0
|
||||
pure GroupReg {dbGroupId, userGroupRegId, dbContactId, dbOwnerMemberId, groupRegStatus, promoted, createdAt}
|
||||
|
||||
instance StrEncoding GroupRegStatus where
|
||||
strEncode = \case
|
||||
GRSPendingConfirmation -> "pending_confirmation"
|
||||
GRSProposed -> "proposed"
|
||||
GRSPendingUpdate -> "pending_update"
|
||||
GRSPendingApproval gaId -> "pending_approval:" <> strEncode gaId
|
||||
GRSActive -> "active"
|
||||
GRSSuspended -> "suspended"
|
||||
GRSSuspendedBadRoles -> "suspended_bad_roles"
|
||||
GRSRemoved -> "removed"
|
||||
strP =
|
||||
A.takeTill (\c -> c == ' ' || c == ':') >>= \case
|
||||
"pending_confirmation" -> pure GRSPendingConfirmation
|
||||
"proposed" -> pure GRSProposed
|
||||
"pending_update" -> pure GRSPendingUpdate
|
||||
"pending_approval" -> GRSPendingApproval <$> (A.char ':' *> A.decimal)
|
||||
"active" -> pure GRSActive
|
||||
"suspended" -> pure GRSSuspended
|
||||
"suspended_bad_roles" -> pure GRSSuspendedBadRoles
|
||||
"removed" -> pure GRSRemoved
|
||||
_ -> fail "invalid GroupRegStatus"
|
||||
|
||||
instance ToField GroupRegStatus where toField = toField . safeDecodeUtf8 . strEncode
|
||||
|
||||
instance FromField GroupRegStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
|
||||
|
||||
openDirectoryLog :: Maybe FilePath -> IO DirectoryLog
|
||||
openDirectoryLog = \case
|
||||
Just f -> DirectoryLog . Just <$> openLogFile f
|
||||
Nothing -> pure $ DirectoryLog Nothing
|
||||
where
|
||||
openLogFile f = do
|
||||
h <- openFile f AppendMode
|
||||
hSetBuffering h LineBuffering
|
||||
pure h
|
||||
|
||||
readDirectoryLogData :: FilePath -> IO [GroupReg]
|
||||
readDirectoryLogData f =
|
||||
sortOn dbGroupId . M.elems
|
||||
<$> (foldM processDLR M.empty . B.lines =<< B.readFile f)
|
||||
where
|
||||
processDLR :: Map GroupId GroupReg -> ByteString -> IO (Map GroupId GroupReg)
|
||||
processDLR m l = case strDecode l of
|
||||
Left e -> m <$ putStrLn ("Error parsing log record: " <> e <> ", " <> B.unpack (B.take 80 l))
|
||||
Right r -> case r of
|
||||
GRCreate gr@GroupReg {dbGroupId = gId} -> do
|
||||
when (isJust $ M.lookup gId m) $
|
||||
putStrLn $
|
||||
"Warning: duplicate group with ID " <> show gId <> ", group replaced."
|
||||
pure $ M.insert gId gr m
|
||||
GRDelete gId -> case M.lookup gId m of
|
||||
Just _ -> pure $ M.delete gId m
|
||||
Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", deletion ignored.")
|
||||
GRUpdateStatus gId groupRegStatus -> case M.lookup gId m of
|
||||
Just gr -> pure $ M.insert gId gr {groupRegStatus} m
|
||||
Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", status update ignored.")
|
||||
GRUpdatePromotion gId promoted -> case M.lookup gId m of
|
||||
Just gr -> pure $ M.insert gId gr {promoted} m
|
||||
Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", promotion update ignored.")
|
||||
GRUpdateOwner gId grOwnerId -> case M.lookup gId m of
|
||||
Just gr -> pure $ M.insert gId gr {dbOwnerMemberId = Just grOwnerId} m
|
||||
Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", owner update ignored.")
|
||||
149
bots/haskell/simplexxx-directory/src/Directory/Store/Migrate.hs
Normal file
149
bots/haskell/simplexxx-directory/src/Directory/Store/Migrate.hs
Normal file
@@ -0,0 +1,149 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Directory.Store.Migrate where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.List (find)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import Directory.Listing
|
||||
import Directory.Options
|
||||
import Directory.Store
|
||||
import Simplex.Chat (createChatDatabase)
|
||||
import Simplex.Chat.Controller (ChatConfig (..), ChatDatabase (..))
|
||||
import Simplex.Chat.Options (CoreChatOpts (..))
|
||||
import Simplex.Chat.Options.DB
|
||||
import Simplex.Chat.Protocol (supportedChatVRange)
|
||||
import Simplex.Chat.Store.Groups (getHostMember)
|
||||
import Simplex.Chat.Store.Profiles (getUsers)
|
||||
import Simplex.Chat.Store.Shared (getGroupInfo)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Store.Common
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Agent.Store.Interface (closeDBStore, migrateDBSchema)
|
||||
import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..))
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util (whenM)
|
||||
import System.Directory (doesFileExist, renamePath)
|
||||
import System.Exit (exitFailure)
|
||||
import System.IO (IOMode (..), withFile)
|
||||
|
||||
#if defined(dbPostgres)
|
||||
import Directory.Store.Postgres.Migrations
|
||||
#else
|
||||
import Directory.Store.SQLite.Migrations
|
||||
#endif
|
||||
|
||||
runDirectoryMigrations :: DirectoryOpts -> ChatConfig -> DBStore -> IO ()
|
||||
runDirectoryMigrations opts ChatConfig {confirmMigrations} chatStore =
|
||||
migrateDBSchema
|
||||
chatStore
|
||||
(toDBOpts dbOptions chatSuffix False [])
|
||||
(Just "sx_directory_migrations")
|
||||
directorySchemaMigrations
|
||||
MigrationConfig {confirm, backupPath = Nothing}
|
||||
>>= either (exit . ("directory migrations " <>) . show) pure
|
||||
where
|
||||
DirectoryOpts {coreOptions = CoreChatOpts {dbOptions, yesToUpMigrations}} = opts
|
||||
confirm = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations
|
||||
|
||||
checkDirectoryLog :: DirectoryOpts -> ChatConfig -> IO ()
|
||||
checkDirectoryLog opts cfg =
|
||||
withDirectoryLog opts $ \logFile -> withChatStore opts $ \st -> do
|
||||
runDirectoryMigrations opts cfg st
|
||||
gs <- readDirectoryLogData logFile
|
||||
withActiveUser st $ \user -> withTransaction st $ \db -> do
|
||||
mapM_ (verifyGroupRegistration db user) gs
|
||||
putStrLn $ show (length gs) <> " group registrations OK"
|
||||
|
||||
importDirectoryLogToDB :: DirectoryOpts -> ChatConfig -> IO ()
|
||||
importDirectoryLogToDB opts cfg = do
|
||||
withDirectoryLog opts $ \logFile -> withChatStore opts $ \st -> do
|
||||
runDirectoryMigrations opts cfg st
|
||||
gs <- readDirectoryLogData logFile
|
||||
ctRegs <- TM.emptyIO
|
||||
withActiveUser st $ \user -> withTransaction st $ \db -> do
|
||||
forM_ gs $ \gr ->
|
||||
whenM (verifyGroupRegistration db user gr) $ do
|
||||
putStrLn $ "importing group " <> show (dbGroupId gr)
|
||||
insertGroupReg db =<< fixUserGroupRegId ctRegs gr
|
||||
renamePath logFile (logFile ++ ".bak")
|
||||
putStrLn $ show (length gs) <> " group registrations imported"
|
||||
where
|
||||
fixUserGroupRegId ctRegs gr@GroupReg {dbGroupId, dbContactId} = do
|
||||
ugIds <- fromMaybe [] <$> TM.lookupIO dbContactId ctRegs
|
||||
gr' <-
|
||||
if userGroupRegId gr `elem` ugIds
|
||||
then do
|
||||
let ugId = maximum ugIds + 1
|
||||
putStrLn $ "Warning: updating userGroupRegId for group " <> show dbGroupId <> ", contact " <> show dbContactId
|
||||
pure gr {userGroupRegId = ugId}
|
||||
else pure gr
|
||||
atomically $ TM.insert dbContactId (userGroupRegId gr' : ugIds) ctRegs
|
||||
pure gr'
|
||||
|
||||
exit :: String -> IO a
|
||||
exit err = putStrLn ("Error: " <> err) >> exitFailure
|
||||
|
||||
exportDBToDirectoryLog :: DirectoryOpts -> ChatConfig -> IO ()
|
||||
exportDBToDirectoryLog opts cfg =
|
||||
withDirectoryLog opts $ \logFile -> withChatStore opts $ \st -> do
|
||||
whenM (doesFileExist logFile) $ exit $ "directory log file " ++ logFile ++ " already exists"
|
||||
runDirectoryMigrations opts cfg st
|
||||
withActiveUser st $ \user -> do
|
||||
gs <- withFile logFile WriteMode $ \h -> withTransaction st $ \db -> do
|
||||
gs <- getAllGroupRegs_ db user
|
||||
forM_ gs $ \(_, gr) ->
|
||||
whenM (verifyGroupRegistration db user gr) $
|
||||
B.hPutStrLn h $ strEncode $ GRCreate gr
|
||||
pure gs
|
||||
putStrLn $ show (length gs) <> " group registrations exported"
|
||||
|
||||
saveGroupListingFiles :: DirectoryOpts -> ChatConfig -> IO ()
|
||||
saveGroupListingFiles opts _cfg = case webFolder opts of
|
||||
Nothing -> exit "use --web-folder to generate listings"
|
||||
Just dir ->
|
||||
withChatStore opts $ \st -> withActiveUser st $ \user ->
|
||||
withTransaction st $ \db ->
|
||||
getAllListedGroups_ db supportedChatVRange user >>= generateListing dir
|
||||
|
||||
verifyGroupRegistration :: DB.Connection -> User -> GroupReg -> IO Bool
|
||||
verifyGroupRegistration db user GroupReg {dbGroupId = gId, dbContactId = ctId, dbOwnerMemberId, groupRegStatus} =
|
||||
runExceptT (getGroupInfo db supportedChatVRange user gId) >>= \case
|
||||
Left e -> False <$ putStrLn ("Error: loading group " <> show gId <> " (skipping): " <> show e)
|
||||
Right GroupInfo {localDisplayName} -> do
|
||||
let groupRef = show gId <> " " <> T.unpack localDisplayName
|
||||
runExceptT (getHostMember db supportedChatVRange user gId) >>= \case
|
||||
Left e -> False <$ putStrLn ("Error: loading host member of group " <> groupRef <> " (skipping): " <> show e)
|
||||
Right GroupMember {groupMemberId = mId', memberContactId = ctId'} -> case dbOwnerMemberId of
|
||||
Nothing -> True <$ putStrLn ("Warning: group " <> groupRef <> " has no owner member ID, host member ID is " <> show mId' <> ", registration status: " <> B.unpack (strEncode groupRegStatus))
|
||||
Just mId
|
||||
| mId /= mId' -> False <$ putStrLn ("Error: different host member ID of " <> groupRef <> " (skipping): " <> show mId')
|
||||
| otherwise -> True <$ unless (Just ctId == ctId') (putStrLn $ "Warning: bad group " <> groupRef <> " contact ID: " <> show ctId')
|
||||
|
||||
withDirectoryLog :: DirectoryOpts -> (FilePath -> IO ()) -> IO ()
|
||||
withDirectoryLog DirectoryOpts {directoryLog} action =
|
||||
maybe (exit "directory log file not specified") action directoryLog
|
||||
|
||||
withChatStore :: DirectoryOpts -> (DBStore -> IO ()) -> IO ()
|
||||
withChatStore DirectoryOpts {coreOptions = CoreChatOpts {dbOptions, yesToUpMigrations, migrationBackupPath}} action =
|
||||
createChatDatabase dbOptions migrationConfig >>= \case
|
||||
Left e -> exit $ show e
|
||||
Right ChatDatabase {chatStore, agentStore} -> do
|
||||
action chatStore
|
||||
closeDBStore chatStore
|
||||
closeDBStore agentStore
|
||||
where
|
||||
migrationConfig = MigrationConfig (if yesToUpMigrations then MCYesUp else MCConsole) migrationBackupPath
|
||||
|
||||
withActiveUser :: DBStore -> (User -> IO ()) -> IO ()
|
||||
withActiveUser st action = withTransaction st getUsers >>= maybe (exit "no active user") action . find activeUser
|
||||
@@ -0,0 +1,52 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Directory.Store.Postgres.Migrations where
|
||||
|
||||
import Data.List (sortOn)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
directorySchemaMigrations :: [Migration]
|
||||
directorySchemaMigrations = sortOn name $ map migration schemaMigrations
|
||||
where
|
||||
migration (name, up, down) = Migration {name, up, down}
|
||||
|
||||
schemaMigrations :: [(String, Text, Maybe Text)]
|
||||
schemaMigrations =
|
||||
[ ("20250924_directory_schema", m20250924_directory_schema, Just down_m20250924_directory_schema)
|
||||
]
|
||||
|
||||
m20250924_directory_schema :: Text
|
||||
m20250924_directory_schema =
|
||||
T.pack
|
||||
[r|
|
||||
CREATE TABLE sx_directory_group_regs(
|
||||
group_reg_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
|
||||
group_id BIGINT NOT NULL REFERENCES groups ON UPDATE RESTRICT ON DELETE CASCADE,
|
||||
user_group_reg_id BIGINT NOT NULL,
|
||||
contact_id BIGINT NOT NULL REFERENCES contacts(contact_id) ON UPDATE RESTRICT ON DELETE CASCADE,
|
||||
owner_member_id BIGINT REFERENCES group_members(group_member_id) ON UPDATE RESTRICT ON DELETE CASCADE,
|
||||
group_reg_status TEXT NOT NULL,
|
||||
group_promoted SMALLINT NOT NULL,
|
||||
created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
|
||||
updated_at TIMESTAMPTZ NOT NULL DEFAULT (now())
|
||||
);
|
||||
|
||||
CREATE UNIQUE INDEX idx_sx_directory_group_regs_group_id ON sx_directory_group_regs(group_id);
|
||||
CREATE UNIQUE INDEX idx_sx_directory_group_regs_owner_member_id ON sx_directory_group_regs(owner_member_id);
|
||||
CREATE UNIQUE INDEX idx_sx_directory_group_regs_owner_contact_id_user_group_reg_id ON sx_directory_group_regs(contact_id, user_group_reg_id);
|
||||
|]
|
||||
|
||||
down_m20250924_directory_schema :: Text
|
||||
down_m20250924_directory_schema =
|
||||
T.pack
|
||||
[r|
|
||||
DROP INDEX idx_sx_directory_group_regs_group_id;
|
||||
DROP INDEX idx_sx_directory_group_regs_owner_member_id;
|
||||
DROP INDEX idx_sx_directory_group_regs_owner_contact_id_user_group_reg_id;
|
||||
|
||||
DROP TABLE sx_directory_group_regs;
|
||||
|]
|
||||
@@ -0,0 +1,49 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Directory.Store.SQLite.Migrations (directorySchemaMigrations) where
|
||||
|
||||
import Data.List (sortOn)
|
||||
import Database.SQLite.Simple (Query (..))
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
|
||||
directorySchemaMigrations :: [Migration]
|
||||
directorySchemaMigrations = sortOn name $ map migration schemaMigrations
|
||||
where
|
||||
migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down}
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
schemaMigrations =
|
||||
[ ("20250924_directory_schema", m20250924_directory_schema, Just down_m20250924_directory_schema)
|
||||
]
|
||||
|
||||
m20250924_directory_schema :: Query
|
||||
m20250924_directory_schema =
|
||||
[sql|
|
||||
CREATE TABLE sx_directory_group_regs(
|
||||
group_reg_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
group_id INTEGER NOT NULL REFERENCES groups ON UPDATE RESTRICT ON DELETE CASCADE,
|
||||
user_group_reg_id INTEGER NOT NULL,
|
||||
contact_id INTEGER NOT NULL REFERENCES contacts(contact_id) ON UPDATE RESTRICT ON DELETE CASCADE,
|
||||
owner_member_id INTEGER REFERENCES group_members(group_member_id) ON UPDATE RESTRICT ON DELETE CASCADE,
|
||||
group_reg_status TEXT NOT NULL,
|
||||
group_promoted INTEGER NOT NULL,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
|
||||
CREATE UNIQUE INDEX idx_sx_directory_group_regs_group_id ON sx_directory_group_regs(group_id);
|
||||
CREATE UNIQUE INDEX idx_sx_directory_group_regs_owner_member_id ON sx_directory_group_regs(owner_member_id);
|
||||
CREATE UNIQUE INDEX idx_sx_directory_group_regs_owner_contact_id_user_group_reg_id ON sx_directory_group_regs(contact_id, user_group_reg_id);
|
||||
|]
|
||||
|
||||
down_m20250924_directory_schema :: Query
|
||||
down_m20250924_directory_schema =
|
||||
[sql|
|
||||
DROP INDEX idx_sx_directory_group_regs_group_id;
|
||||
DROP INDEX idx_sx_directory_group_regs_owner_member_id;
|
||||
DROP INDEX idx_sx_directory_group_regs_owner_contact_id_user_group_reg_id;
|
||||
|
||||
DROP TABLE sx_directory_group_regs;
|
||||
|]
|
||||
31
bots/haskell/simplexxx-directory/src/Directory/Util.hs
Normal file
31
bots/haskell/simplexxx-directory/src/Directory/Util.hs
Normal file
@@ -0,0 +1,31 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Directory.Util where
|
||||
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad.Except
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Store.Common (withTransaction)
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Util (catchAll)
|
||||
|
||||
vr :: ChatController -> VersionRangeChat
|
||||
vr ChatController {config = ChatConfig {chatVRange}} = chatVRange
|
||||
{-# INLINE vr #-}
|
||||
|
||||
withDB' :: Text -> ChatController -> (DB.Connection -> IO a) -> IO (Either String a)
|
||||
withDB' cxt cc a = withDB cxt cc $ ExceptT . fmap Right . a
|
||||
|
||||
withDB :: Text -> ChatController -> (DB.Connection -> ExceptT String IO a) -> IO (Either String a)
|
||||
withDB cxt ChatController {chatStore} action = do
|
||||
r_ <- withTransaction chatStore (runExceptT . action) `catchAll` (pure . Left . show)
|
||||
case r_ of
|
||||
Left e -> logError $ "Database error: " <> cxt <> " " <> T.pack e
|
||||
Right _ -> pure ()
|
||||
pure r_
|
||||
13
bots/haskell/simplexxx-directory/start.sh
Executable file
13
bots/haskell/simplexxx-directory/start.sh
Executable file
@@ -0,0 +1,13 @@
|
||||
#!/bin/bash
|
||||
set -e
|
||||
|
||||
# export PATH="$HOME/.ghcup/bin:$HOME/.cabal/bin:$PATH"
|
||||
|
||||
#cd "$(dirname "$0")/../.."
|
||||
|
||||
|
||||
cabal run simplexxx-directory -- \
|
||||
--super-users "1:ADMIN" \
|
||||
--service-name "SimpleXXX" \
|
||||
--admin-users "4:xXx" \
|
||||
--web-folder "../simplex-chat-web-folder"
|
||||
Reference in New Issue
Block a user