mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-09-09 16:06:09 +00:00
Evgenyandspaced4ndy
b2de37a9fb
* core: member acceptance * migration * move hook * core: support sending direct messages to members (#5680) * fix compilation, todos * fix test * predicates * comment * extend hook * wip * wip * wip * wip * fix test * mute output * schema * better query * plans * fix test * directory * captcha * captcha works * remove column, add UI types and group status icon * fix test * query plans * exclude messages of pending members from history * commands for filter settings * core: separately delete pending approval members; other apis validation (#5699) * accepted status * send captcha messages as replies * fix blocked words * simpler filter info * info about /filter and /role after group registration * update query plans --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
78 lines
2.6 KiB
Haskell
78 lines
2.6 KiB
Haskell
{-# 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)
|