servers: blocking records for content moderation (#1430)

* servers: blocking records for content moderation

* update

* encode BLOCKED as AUTH in old versions

* update

* unblock queue command

* test, status command
This commit is contained in:
Evgeny
2025-01-12 19:34:00 +00:00
committed by GitHub
parent 9d9ec8cd0b
commit 3d4e0b06c0
20 changed files with 415 additions and 94 deletions
+13 -4
View File
@@ -5,7 +5,7 @@ module Simplex.Messaging.Server.Control where
import qualified Data.Attoparsec.ByteString.Char8 as A
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (BasicAuth, SenderId)
import Simplex.Messaging.Protocol (BasicAuth, BlockingInfo, SenderId)
data CPClientRole = CPRNone | CPRUser | CPRAdmin
deriving (Eq)
@@ -22,6 +22,9 @@ data ControlProtocol
| CPSocketThreads
| CPServerInfo
| CPDelete SenderId
| CPStatus SenderId
| CPBlock SenderId BlockingInfo
| CPUnblock SenderId
| CPSave
| CPHelp
| CPQuit
@@ -39,14 +42,17 @@ instance StrEncoding ControlProtocol where
CPSockets -> "sockets"
CPSocketThreads -> "socket-threads"
CPServerInfo -> "server-info"
CPDelete bs -> "delete " <> strEncode bs
CPDelete sId -> "delete " <> strEncode sId
CPStatus sId -> "status " <> strEncode sId
CPBlock sId info -> "block " <> strEncode sId <> " " <> strEncode info
CPUnblock sId -> "unblock " <> strEncode sId
CPSave -> "save"
CPHelp -> "help"
CPQuit -> "quit"
CPSkip -> ""
strP =
A.takeTill (== ' ') >>= \case
"auth" -> CPAuth <$> (A.space *> strP)
"auth" -> CPAuth <$> _strP
"suspend" -> pure CPSuspend
"resume" -> pure CPResume
"clients" -> pure CPClients
@@ -56,7 +62,10 @@ instance StrEncoding ControlProtocol where
"sockets" -> pure CPSockets
"socket-threads" -> pure CPSocketThreads
"server-info" -> pure CPServerInfo
"delete" -> CPDelete <$> (A.space *> strP)
"delete" -> CPDelete <$> _strP
"status" -> CPStatus <$> _strP
"block" -> CPBlock <$> _strP <*> _strP
"unblock" -> CPUnblock <$> _strP
"save" -> pure CPSave
"help" -> pure CPHelp
"quit" -> pure CPQuit