mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-03-30 20:45:49 +00:00
simplex-directory-service: add audio captcha (#6619)
* simplex-directory-service: add audio captcha * add plan * updated plan * implement changes * add tests with coverage * add tests * implement further changes * directory tests overview * fix tests on 8.10.7 * /audio command toggles between text and voice captcha * core: /audio enables voice captcha, retry sends both image and voice * remove irrelevant directory service tests * fix flaky testJoinGroup message ordering
This commit is contained in:
sh
@@ -10,11 +10,13 @@
|
||||
module Directory.Events
|
||||
( DirectoryEvent (..),
|
||||
DirectoryCmd (..),
|
||||
DirectoryCmdTag (..),
|
||||
ADirectoryCmd (..),
|
||||
DirectoryHelpSection (..),
|
||||
DirectoryRole (..),
|
||||
SDirectoryRole (..),
|
||||
crDirectoryEvent,
|
||||
directoryCmdP,
|
||||
directoryCmdTag,
|
||||
)
|
||||
where
|
||||
|
||||
@@ -9,6 +9,7 @@ module Directory.Options
|
||||
( DirectoryOpts (..),
|
||||
MigrateLog (..),
|
||||
getDirectoryOpts,
|
||||
directoryOpts,
|
||||
mkChatOpts,
|
||||
)
|
||||
where
|
||||
@@ -34,6 +35,7 @@ data DirectoryOpts = DirectoryOpts
|
||||
nameSpellingFile :: Maybe FilePath,
|
||||
profileNameLimit :: Int,
|
||||
captchaGenerator :: Maybe FilePath,
|
||||
voiceCaptchaGenerator :: Maybe FilePath,
|
||||
directoryLog :: Maybe FilePath,
|
||||
migrateDirectoryLog :: Maybe MigrateLog,
|
||||
serviceName :: T.Text,
|
||||
@@ -119,6 +121,13 @@ directoryOpts appDir defaultDbName = do
|
||||
<> 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
|
||||
@@ -166,6 +175,7 @@ directoryOpts appDir defaultDbName = do
|
||||
nameSpellingFile,
|
||||
profileNameLimit,
|
||||
captchaGenerator,
|
||||
voiceCaptchaGenerator,
|
||||
directoryLog,
|
||||
migrateDirectoryLog,
|
||||
serviceName = T.pack serviceName,
|
||||
|
||||
@@ -20,11 +20,14 @@ where
|
||||
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception (SomeException, try)
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.Attoparsec.Text as A
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Either (fromRight)
|
||||
import Data.List (find, intercalate)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.Map.Strict as M
|
||||
@@ -63,13 +66,15 @@ import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.View (serializeChatError, serializeChatResponse, simplexChatContact, viewContactName, viewGroupName)
|
||||
import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ConnectionLink (..), CreatedConnLink (..), SConnectionMode (..), sameConnReqContact, sameShortLinkContact)
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util (eitherToMaybe, raceAny_, safeDecodeUtf8, tshow, unlessM, (<$$>))
|
||||
import System.Directory (getAppUserDataDirectory)
|
||||
import System.Directory (getAppUserDataDirectory, removeFile)
|
||||
import System.Exit (exitFailure)
|
||||
import System.Process (readProcess)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
data GroupProfileUpdate
|
||||
= GPNoServiceLink
|
||||
@@ -97,10 +102,13 @@ data ServiceState = ServiceState
|
||||
updateListingsJob :: TMVar ChatController
|
||||
}
|
||||
|
||||
data CaptchaMode = CMText | CMAudio
|
||||
|
||||
data PendingCaptcha = PendingCaptcha
|
||||
{ captchaText :: Text,
|
||||
sentAt :: UTCTime,
|
||||
attempts :: Int
|
||||
attempts :: Int,
|
||||
captchaMode :: CaptchaMode
|
||||
}
|
||||
|
||||
captchaLength :: Int
|
||||
@@ -555,33 +563,57 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
||||
|
||||
dePendingMember :: GroupInfo -> GroupMember -> IO ()
|
||||
dePendingMember g@GroupInfo {groupProfile = GroupProfile {displayName}} m
|
||||
| memberRequiresCaptcha a m = sendMemberCaptcha g m Nothing captchaNotice 0
|
||||
| memberRequiresCaptcha a m = sendMemberCaptcha g m Nothing captchaNotice 0 CMText
|
||||
| otherwise = approvePendingMember a g m
|
||||
where
|
||||
a = groupMemberAcceptance g
|
||||
captchaNotice = "Captcha is generated by SimpleX Directory service.\n\n*Send captcha text* to join the group " <> displayName <> "."
|
||||
captchaNotice =
|
||||
"Captcha is generated by SimpleX Directory service.\n\n*Send captcha text* to join the group " <> displayName <> "."
|
||||
<> if isJust (voiceCaptchaGenerator opts) then "\nSend /audio to receive a voice captcha." else ""
|
||||
|
||||
sendMemberCaptcha :: GroupInfo -> GroupMember -> Maybe ChatItemId -> Text -> Int -> IO ()
|
||||
sendMemberCaptcha GroupInfo {groupId} m quotedId noticeText prevAttempts = do
|
||||
sendMemberCaptcha :: GroupInfo -> GroupMember -> Maybe ChatItemId -> Text -> Int -> CaptchaMode -> IO ()
|
||||
sendMemberCaptcha GroupInfo {groupId} m quotedId noticeText prevAttempts mode = do
|
||||
s <- getCaptchaStr captchaLength ""
|
||||
mc <- getCaptcha s
|
||||
sentAt <- getCurrentTime
|
||||
let captcha = PendingCaptcha {captchaText = T.pack s, sentAt, attempts = prevAttempts + 1}
|
||||
let captcha = PendingCaptcha {captchaText = T.pack s, sentAt, attempts = prevAttempts + 1, captchaMode = mode}
|
||||
atomically $ TM.insert gmId captcha $ pendingCaptchas env
|
||||
sendCaptcha mc
|
||||
case mode of
|
||||
CMAudio -> do
|
||||
mc <- getCaptchaContent s
|
||||
sendComposedMessages_ cc sendRef [(quotedId, MCText noticeText), (Nothing, mc)]
|
||||
sendVoiceCaptcha sendRef s
|
||||
CMText -> do
|
||||
mc <- getCaptchaContent s
|
||||
sendComposedMessages_ cc sendRef [(quotedId, MCText noticeText), (Nothing, mc)]
|
||||
where
|
||||
getCaptcha s = case captchaGenerator opts of
|
||||
Nothing -> pure textMsg
|
||||
Just script -> content <$> readProcess script [s] ""
|
||||
where
|
||||
textMsg = MCText $ T.pack s
|
||||
content r = case T.lines $ T.pack r of
|
||||
[] -> textMsg
|
||||
"" : _ -> textMsg
|
||||
img : _ -> MCImage "" $ ImageData img
|
||||
sendCaptcha mc = sendComposedMessages_ cc (SRGroup groupId $ Just $ GCSMemberSupport (Just gmId)) [(quotedId, MCText noticeText), (Nothing, mc)]
|
||||
sendRef = SRGroup groupId $ Just $ GCSMemberSupport (Just gmId)
|
||||
gmId = groupMemberId' m
|
||||
|
||||
sendVoiceCaptcha :: SendRef -> String -> IO ()
|
||||
sendVoiceCaptcha sendRef s =
|
||||
forM_ (voiceCaptchaGenerator opts) $ \script ->
|
||||
void . forkIO $ do
|
||||
voiceResult <- try $ readProcess script [s] "" :: IO (Either SomeException String)
|
||||
case voiceResult of
|
||||
Right r -> case lines r of
|
||||
(filePath : durationStr : _)
|
||||
| not (null filePath), Just duration <- readMaybe durationStr -> do
|
||||
sendComposedMessageFile cc sendRef Nothing (MCVoice "" duration) (CF.plain filePath)
|
||||
void (try $ removeFile filePath :: IO (Either SomeException ()))
|
||||
_ -> logError "voice captcha generator: unexpected output"
|
||||
Left e -> logError $ "voice captcha generator error: " <> tshow e
|
||||
|
||||
getCaptchaContent :: String -> IO MsgContent
|
||||
getCaptchaContent s = case captchaGenerator opts of
|
||||
Nothing -> pure $ MCText $ T.pack s
|
||||
Just script -> content <$> readProcess script [s] ""
|
||||
where
|
||||
content r = case T.lines $ T.pack r of
|
||||
[] -> textMsg
|
||||
"" : _ -> textMsg
|
||||
img : _ -> MCImage "" $ ImageData img
|
||||
textMsg = MCText $ T.pack s
|
||||
|
||||
approvePendingMember :: DirectoryMemberAcceptance -> GroupInfo -> GroupMember -> IO ()
|
||||
approvePendingMember a g@GroupInfo {groupId} m@GroupMember {memberProfile = LocalProfile {displayName, image}} = do
|
||||
gli_ <- join . eitherToMaybe <$> withDB' "getGroupLinkInfo" cc (\db -> getGroupLinkInfo db userId groupId)
|
||||
@@ -598,16 +630,34 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
||||
dePendingMemberMsg :: GroupInfo -> GroupMember -> ChatItemId -> Text -> IO ()
|
||||
dePendingMemberMsg g@GroupInfo {groupId, groupProfile = GroupProfile {displayName = n}} m@GroupMember {memberProfile = LocalProfile {displayName}} ciId msgText
|
||||
| memberRequiresCaptcha a m = do
|
||||
ts <- getCurrentTime
|
||||
atomically (TM.lookup (groupMemberId' m) $ pendingCaptchas env) >>= \case
|
||||
Just PendingCaptcha {captchaText, sentAt, attempts}
|
||||
| ts `diffUTCTime` sentAt > captchaTTL -> sendMemberCaptcha g m (Just ciId) captchaExpired $ attempts - 1
|
||||
| matchCaptchaStr captchaText msgText -> do
|
||||
sendComposedMessages_ cc (SRGroup groupId $ Just $ GCSMemberSupport (Just $ groupMemberId' m)) [(Just ciId, MCText $ "Correct, you joined the group " <> n)]
|
||||
approvePendingMember a g m
|
||||
| attempts >= maxCaptchaAttempts -> rejectPendingMember tooManyAttempts
|
||||
| otherwise -> sendMemberCaptcha g m (Just ciId) (wrongCaptcha attempts) attempts
|
||||
Nothing -> sendMemberCaptcha g m (Just ciId) noCaptcha 0
|
||||
let gmId = groupMemberId' m
|
||||
sendRef = SRGroup groupId $ Just $ GCSMemberSupport (Just gmId)
|
||||
-- /audio is matched as text, not as DirectoryCmd, because it is only valid
|
||||
-- in group context at captcha stage, while DirectoryCmd is for DM commands.
|
||||
isAudioCmd = T.strip msgText == "/audio"
|
||||
cmd = fromRight (ADC SDRUser DCUnknownCommand) $ A.parseOnly (directoryCmdP <* A.endOfInput) $ T.strip msgText
|
||||
atomically (TM.lookup gmId $ pendingCaptchas env) >>= \case
|
||||
Nothing ->
|
||||
let mode = if isAudioCmd then CMAudio else CMText
|
||||
in sendMemberCaptcha g m (Just ciId) noCaptcha 0 mode
|
||||
Just pc@PendingCaptcha {captchaText, sentAt, attempts, captchaMode}
|
||||
| isAudioCmd -> case captchaMode of
|
||||
CMText -> do
|
||||
atomically $ TM.insert gmId pc {captchaMode = CMAudio} $ pendingCaptchas env
|
||||
sendVoiceCaptcha sendRef (T.unpack captchaText)
|
||||
CMAudio ->
|
||||
sendComposedMessages_ cc sendRef [(Just ciId, MCText audioAlreadyEnabled)]
|
||||
| otherwise -> case cmd of
|
||||
ADC SDRUser (DCSearchGroup _) -> do
|
||||
ts <- getCurrentTime
|
||||
if
|
||||
| ts `diffUTCTime` sentAt > captchaTTL -> sendMemberCaptcha g m (Just ciId) captchaExpired (attempts - 1) captchaMode
|
||||
| matchCaptchaStr captchaText msgText -> do
|
||||
sendComposedMessages_ cc sendRef [(Just ciId, MCText $ "Correct, you joined the group " <> n)]
|
||||
approvePendingMember a g m
|
||||
| attempts >= maxCaptchaAttempts -> rejectPendingMember tooManyAttempts
|
||||
| otherwise -> sendMemberCaptcha g m (Just ciId) (wrongCaptcha attempts) attempts captchaMode
|
||||
_ -> sendComposedMessages_ cc sendRef [(Just ciId, MCText unknownCommand)]
|
||||
| otherwise = approvePendingMember a g m
|
||||
where
|
||||
a = groupMemberAcceptance g
|
||||
@@ -619,11 +669,19 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
||||
atomically $ TM.delete gmId $ pendingCaptchas env
|
||||
logInfo $ "Member " <> viewName displayName <> " rejected, group " <> tshow groupId <> ":" <> viewGroupName g
|
||||
r -> logError $ "unexpected remove member response: " <> tshow r
|
||||
captchaExpired :: Text
|
||||
captchaExpired = "Captcha expired, please try again."
|
||||
wrongCaptcha :: Int -> Text
|
||||
wrongCaptcha attempts
|
||||
| attempts == maxCaptchaAttempts - 1 = "Incorrect text, please try again - this is your last attempt."
|
||||
| otherwise = "Incorrect text, please try again."
|
||||
noCaptcha :: Text
|
||||
noCaptcha = "Unexpected message, please try again."
|
||||
audioAlreadyEnabled :: Text
|
||||
audioAlreadyEnabled = "Audio captcha is already enabled."
|
||||
unknownCommand :: Text
|
||||
unknownCommand = "Unknown command, please enter captcha text."
|
||||
tooManyAttempts :: Text
|
||||
tooManyAttempts = "Too many failed attempts, you can't join group."
|
||||
|
||||
memberRequiresCaptcha :: DirectoryMemberAcceptance -> GroupMember -> Bool
|
||||
|
||||
@@ -2,6 +2,15 @@ packages: .
|
||||
-- packages: . ../simplexmq
|
||||
-- packages: . ../simplexmq ../direct-sqlcipher ../sqlcipher-simple
|
||||
|
||||
-- uncomment two sections below to run tests with coverage
|
||||
-- package *
|
||||
-- coverage: True
|
||||
-- library-coverage: True
|
||||
|
||||
-- package attoparsec
|
||||
-- coverage: False
|
||||
-- library-coverage: False
|
||||
|
||||
index-state: 2023-12-12T00:00:00Z
|
||||
|
||||
package cryptostore
|
||||
|
||||
520
plans/audio-captcha-improvements.md
Normal file
520
plans/audio-captcha-improvements.md
Normal file
@@ -0,0 +1,520 @@
|
||||
# Audio Captcha Improvements Plan
|
||||
|
||||
## Table of Contents
|
||||
|
||||
1. [Executive Summary](#executive-summary)
|
||||
2. [High-Level Design](#high-level-design)
|
||||
3. [Detailed Implementation Plan](#detailed-implementation-plan)
|
||||
4. [Test Updates](#test-updates)
|
||||
5. [Files Changed](#files-changed)
|
||||
|
||||
---
|
||||
|
||||
## Executive Summary
|
||||
|
||||
Improve the audio captcha feature by:
|
||||
|
||||
1. **Proper command parsing** — add `DCCaptchaMode CaptchaMode` constructor to `DirectoryCmd` GADT, using existing Attoparsec parsing infrastructure
|
||||
2. **Audio captcha retry** — when user switches to audio mode, subsequent retries send voice captcha (not image)
|
||||
3. **Make `/audio` clickable** — use `/'audio'` format for clickable command in chat UI
|
||||
|
||||
---
|
||||
|
||||
## High-Level Design
|
||||
|
||||
```
|
||||
┌──────────────────────────────────────────────────────────────────┐
|
||||
│ CaptchaMode (Events.hs) │
|
||||
├──────────────────────────────────────────────────────────────────┤
|
||||
│ CMText -- default image/text captcha │
|
||||
│ CMAudio -- voice captcha mode │
|
||||
└──────────────────────────────────────────────────────────────────┘
|
||||
|
||||
┌──────────────────────────────────────────────────────────────────┐
|
||||
│ PendingCaptcha State │
|
||||
├──────────────────────────────────────────────────────────────────┤
|
||||
│ captchaText :: Text -- the captcha answer │
|
||||
│ sentAt :: UTCTime -- when captcha was sent │
|
||||
│ attempts :: Int -- number of attempts │
|
||||
│ captchaMode :: CaptchaMode -- current mode (CMText/CMAudio) │
|
||||
└──────────────────────────────────────────────────────────────────┘
|
||||
|
||||
┌──────────────────────────────────────────────────────────────────┐
|
||||
│ DirectoryCmd (Events.hs) │
|
||||
├──────────────────────────────────────────────────────────────────┤
|
||||
│ DCCaptchaMode :: CaptchaMode -> DirectoryCmd 'DRUser │
|
||||
│ (integrated into existing GADT, parsed via directoryCmdP) │
|
||||
└──────────────────────────────────────────────────────────────────┘
|
||||
|
||||
Flow:
|
||||
1. User joins group → sendMemberCaptcha (image) + captchaNotice with /'audio'
|
||||
2. User sends /audio → parsed as DCCaptchaMode CMAudio → set captchaMode=CMAudio, sendVoiceCaptcha
|
||||
3. User sends wrong answer:
|
||||
- captchaMode=CMText → send new IMAGE captcha
|
||||
- captchaMode=CMAudio → send new VOICE captcha ← NEW BEHAVIOR
|
||||
4. User sends correct answer → approve member
|
||||
|
||||
Message parsing flow (in Service.hs dePendingMemberMsg):
|
||||
┌─────────────────────────────────────────────────────────────────┐
|
||||
│ 1. Parse msgText with directoryCmdP (existing infrastructure) │
|
||||
│ ↓ │
|
||||
│ 2. TM.lookup pendingCaptcha (ONCE, not per-branch) │
|
||||
│ ↓ │
|
||||
│ ├─ Nothing → sendMemberCaptcha with mode from parsed cmd │
|
||||
│ └─ Just pc → case on parsed cmd: │
|
||||
│ ├─ DCCaptchaMode CMAudio → set mode, send voice captcha │
|
||||
│ ├─ DCSearchGroup _ → captcha answer (verify/retry) │
|
||||
│ └─ _ → unknown command (error message) │
|
||||
└─────────────────────────────────────────────────────────────────┘
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
## Detailed Implementation Plan
|
||||
|
||||
### 3.1 Add `CaptchaMode` type in Events.hs
|
||||
|
||||
**File:** `apps/simplex-directory-service/src/Directory/Events.hs`
|
||||
|
||||
**Location:** After `DirectoryHelpSection` (line 146)
|
||||
|
||||
**Add:**
|
||||
```haskell
|
||||
data CaptchaMode = CMText | CMAudio
|
||||
deriving (Show)
|
||||
```
|
||||
|
||||
**Update exports (line 10-19):**
|
||||
```haskell
|
||||
module Directory.Events
|
||||
( DirectoryEvent (..),
|
||||
DirectoryCmd (..),
|
||||
ADirectoryCmd (..),
|
||||
DirectoryHelpSection (..),
|
||||
CaptchaMode (..),
|
||||
DirectoryRole (..),
|
||||
SDirectoryRole (..),
|
||||
crDirectoryEvent,
|
||||
directoryCmdP,
|
||||
directoryCmdTag,
|
||||
)
|
||||
where
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
### 3.2 Add `DCCaptchaMode_` tag in Events.hs
|
||||
|
||||
**File:** `apps/simplex-directory-service/src/Directory/Events.hs`
|
||||
|
||||
**Location:** In `DirectoryCmdTag` GADT (after line 127, before admin commands)
|
||||
|
||||
**Add:**
|
||||
```haskell
|
||||
DCCaptchaMode_ :: DirectoryCmdTag 'DRUser
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
### 3.3 Add `DCCaptchaMode` constructor in Events.hs
|
||||
|
||||
**File:** `apps/simplex-directory-service/src/Directory/Events.hs`
|
||||
|
||||
**Location:** In `DirectoryCmd` GADT (after line 160, with other user commands)
|
||||
|
||||
**Add:**
|
||||
```haskell
|
||||
DCCaptchaMode :: CaptchaMode -> DirectoryCmd 'DRUser
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
### 3.4 Add "audio" tag parsing in Events.hs
|
||||
|
||||
**File:** `apps/simplex-directory-service/src/Directory/Events.hs`
|
||||
|
||||
**Location:** In `tagP` function (after line 205, in user commands section)
|
||||
|
||||
**Add:**
|
||||
```haskell
|
||||
"audio" -> u DCCaptchaMode_
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
### 3.5 Add `DCCaptchaMode_` case in `cmdP`
|
||||
|
||||
**File:** `apps/simplex-directory-service/src/Directory/Events.hs`
|
||||
|
||||
**Location:** In `cmdP` function (after line 237, with other simple commands)
|
||||
|
||||
**Add:**
|
||||
```haskell
|
||||
DCCaptchaMode_ -> pure $ DCCaptchaMode CMAudio
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
### 3.6 Add `DCCaptchaMode` case in `directoryCmdTag`
|
||||
|
||||
**File:** `apps/simplex-directory-service/src/Directory/Events.hs`
|
||||
|
||||
**Location:** In `directoryCmdTag` function (after line 316)
|
||||
|
||||
**Add:**
|
||||
```haskell
|
||||
DCCaptchaMode _ -> "audio"
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
### 3.7 Update `PendingCaptcha` with `captchaMode` field
|
||||
|
||||
**File:** `apps/simplex-directory-service/src/Directory/Service.hs`
|
||||
|
||||
**Location:** Lines 103-107
|
||||
|
||||
**Before:**
|
||||
```haskell
|
||||
data PendingCaptcha = PendingCaptcha
|
||||
{ captchaText :: Text,
|
||||
sentAt :: UTCTime,
|
||||
attempts :: Int
|
||||
}
|
||||
```
|
||||
|
||||
**After:**
|
||||
```haskell
|
||||
data PendingCaptcha = PendingCaptcha
|
||||
{ captchaText :: Text,
|
||||
sentAt :: UTCTime,
|
||||
attempts :: Int,
|
||||
captchaMode :: CaptchaMode
|
||||
}
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
### 3.8 Update import in Service.hs
|
||||
|
||||
**File:** `apps/simplex-directory-service/src/Directory/Service.hs`
|
||||
|
||||
**Location:** Line 41
|
||||
|
||||
**Before:**
|
||||
```haskell
|
||||
import Directory.Events
|
||||
```
|
||||
|
||||
**After (no change needed):** The implicit import already imports all exports including the new `CaptchaMode`.
|
||||
|
||||
---
|
||||
|
||||
### 3.9 Update `sendMemberCaptcha` signature and implementation
|
||||
|
||||
**File:** `apps/simplex-directory-service/src/Directory/Service.hs`
|
||||
|
||||
**Location:** Function `sendMemberCaptcha` (lines 569-589)
|
||||
|
||||
**Before:**
|
||||
```haskell
|
||||
sendMemberCaptcha :: GroupInfo -> GroupMember -> Maybe ChatItemId -> Text -> Int -> IO ()
|
||||
sendMemberCaptcha GroupInfo {groupId} m quotedId noticeText prevAttempts = do
|
||||
s <- getCaptchaStr captchaLength ""
|
||||
mc <- getCaptcha s
|
||||
sentAt <- getCurrentTime
|
||||
let captcha = PendingCaptcha {captchaText = T.pack s, sentAt, attempts = prevAttempts + 1}
|
||||
atomically $ TM.insert gmId captcha $ pendingCaptchas env
|
||||
sendCaptcha mc
|
||||
where
|
||||
getCaptcha s = case captchaGenerator opts of
|
||||
Nothing -> pure textMsg
|
||||
Just script -> content <$> readProcess script [s] ""
|
||||
where
|
||||
textMsg = MCText $ T.pack s
|
||||
content r = case T.lines $ T.pack r of
|
||||
[] -> textMsg
|
||||
"" : _ -> textMsg
|
||||
img : _ -> MCImage "" $ ImageData img
|
||||
sendRef = SRGroup groupId $ Just $ GCSMemberSupport (Just gmId)
|
||||
sendCaptcha mc = sendComposedMessages_ cc sendRef [(quotedId, MCText noticeText), (Nothing, mc)]
|
||||
gmId = groupMemberId' m
|
||||
```
|
||||
|
||||
**After:**
|
||||
```haskell
|
||||
sendMemberCaptcha :: GroupInfo -> GroupMember -> Maybe ChatItemId -> Text -> Int -> CaptchaMode -> IO ()
|
||||
sendMemberCaptcha GroupInfo {groupId} m quotedId noticeText prevAttempts mode = do
|
||||
s <- getCaptchaStr captchaLength ""
|
||||
sentAt <- getCurrentTime
|
||||
let captcha = PendingCaptcha {captchaText = T.pack s, sentAt, attempts = prevAttempts + 1, captchaMode = mode}
|
||||
atomically $ TM.insert gmId captcha $ pendingCaptchas env
|
||||
case mode of
|
||||
CMAudio -> do
|
||||
sendComposedMessages_ cc sendRef [(quotedId, MCText noticeText)]
|
||||
sendVoiceCaptcha sendRef s
|
||||
CMText -> do
|
||||
mc <- getCaptcha s
|
||||
sendCaptcha mc
|
||||
where
|
||||
getCaptcha s = case captchaGenerator opts of
|
||||
Nothing -> pure textMsg
|
||||
Just script -> content <$> readProcess script [s] ""
|
||||
where
|
||||
textMsg = MCText $ T.pack s
|
||||
content r = case T.lines $ T.pack r of
|
||||
[] -> textMsg
|
||||
"" : _ -> textMsg
|
||||
img : _ -> MCImage "" $ ImageData img
|
||||
sendRef = SRGroup groupId $ Just $ GCSMemberSupport (Just gmId)
|
||||
sendCaptcha mc = sendComposedMessages_ cc sendRef [(quotedId, MCText noticeText), (Nothing, mc)]
|
||||
gmId = groupMemberId' m
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
### 3.10 Update `dePendingMember` call site
|
||||
|
||||
**File:** `apps/simplex-directory-service/src/Directory/Service.hs`
|
||||
|
||||
**Location:** Line 561
|
||||
|
||||
**Before:**
|
||||
```haskell
|
||||
| memberRequiresCaptcha a m = sendMemberCaptcha g m Nothing captchaNotice 0
|
||||
```
|
||||
|
||||
**After:**
|
||||
```haskell
|
||||
| memberRequiresCaptcha a m = sendMemberCaptcha g m Nothing captchaNotice 0 CMText
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
### 3.11 Make `/audio` clickable in `captchaNotice`
|
||||
|
||||
**File:** `apps/simplex-directory-service/src/Directory/Service.hs`
|
||||
|
||||
**Location:** `dePendingMember` function, `captchaNotice` definition (lines 565-567)
|
||||
|
||||
**Before:**
|
||||
```haskell
|
||||
captchaNotice =
|
||||
"Captcha is generated by SimpleX Directory service.\n\n*Send captcha text* to join the group " <> displayName <> "."
|
||||
<> if isJust (voiceCaptchaGenerator opts) then "\nSend /audio to receive a voice captcha." else ""
|
||||
```
|
||||
|
||||
**After:**
|
||||
```haskell
|
||||
captchaNotice =
|
||||
"Captcha is generated by SimpleX Directory service.\n\n*Send captcha text* to join the group " <> displayName <> "."
|
||||
<> if isJust (voiceCaptchaGenerator opts) then "\nSend /'audio' to receive a voice captcha." else ""
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
### 3.12 Refactor `dePendingMemberMsg` with inverted structure
|
||||
|
||||
**File:** `apps/simplex-directory-service/src/Directory/Service.hs`
|
||||
|
||||
**Location:** `dePendingMemberMsg` function (lines 618-656)
|
||||
|
||||
**Key changes:**
|
||||
1. Parse command FIRST using existing `directoryCmdP`
|
||||
2. Do TM.lookup ONCE (not per-branch)
|
||||
3. Case on lookup result, then on command inside
|
||||
|
||||
**Before:**
|
||||
```haskell
|
||||
dePendingMemberMsg :: GroupInfo -> GroupMember -> ChatItemId -> Text -> IO ()
|
||||
dePendingMemberMsg g@GroupInfo {groupId, groupProfile = GroupProfile {displayName = n}} m@GroupMember {memberProfile = LocalProfile {displayName}} ciId msgText
|
||||
| memberRequiresCaptcha a m = do
|
||||
let gmId = groupMemberId' m
|
||||
sendRef = SRGroup groupId $ Just $ GCSMemberSupport (Just gmId)
|
||||
if T.toLower (T.strip msgText) == "/audio"
|
||||
then
|
||||
atomically (TM.lookup gmId $ pendingCaptchas env) >>= \case
|
||||
Just PendingCaptcha {captchaText} ->
|
||||
sendVoiceCaptcha sendRef (T.unpack captchaText)
|
||||
Nothing -> sendMemberCaptcha g m (Just ciId) noCaptcha 0
|
||||
else do
|
||||
ts <- getCurrentTime
|
||||
atomically (TM.lookup gmId $ pendingCaptchas env) >>= \case
|
||||
Just PendingCaptcha {captchaText, sentAt, attempts}
|
||||
| ts `diffUTCTime` sentAt > captchaTTL -> sendMemberCaptcha g m (Just ciId) captchaExpired $ attempts - 1
|
||||
| matchCaptchaStr captchaText msgText -> do
|
||||
sendComposedMessages_ cc sendRef [(Just ciId, MCText $ "Correct, you joined the group " <> n)]
|
||||
approvePendingMember a g m
|
||||
| attempts >= maxCaptchaAttempts -> rejectPendingMember tooManyAttempts
|
||||
| otherwise -> sendMemberCaptcha g m (Just ciId) (wrongCaptcha attempts) attempts
|
||||
Nothing -> sendMemberCaptcha g m (Just ciId) noCaptcha 0
|
||||
| otherwise = approvePendingMember a g m
|
||||
where
|
||||
a = groupMemberAcceptance g
|
||||
rejectPendingMember rjctNotice = do
|
||||
let gmId = groupMemberId' m
|
||||
sendComposedMessages cc (SRGroup groupId $ Just $ GCSMemberSupport (Just gmId)) [MCText rjctNotice]
|
||||
sendChatCmd cc (APIRemoveMembers groupId [gmId] False) >>= \case
|
||||
Right (CRUserDeletedMembers _ _ (_ : _) _) -> do
|
||||
atomically $ TM.delete gmId $ pendingCaptchas env
|
||||
logInfo $ "Member " <> viewName displayName <> " rejected, group " <> tshow groupId <> ":" <> viewGroupName g
|
||||
r -> logError $ "unexpected remove member response: " <> tshow r
|
||||
captchaExpired = "Captcha expired, please try again."
|
||||
wrongCaptcha attempts
|
||||
| attempts == maxCaptchaAttempts - 1 = "Incorrect text, please try again - this is your last attempt."
|
||||
| otherwise = "Incorrect text, please try again."
|
||||
noCaptcha = "Unexpected message, please try again."
|
||||
tooManyAttempts = "Too many failed attempts, you can't join group."
|
||||
```
|
||||
|
||||
**After:**
|
||||
```haskell
|
||||
dePendingMemberMsg :: GroupInfo -> GroupMember -> ChatItemId -> Text -> IO ()
|
||||
dePendingMemberMsg g@GroupInfo {groupId, groupProfile = GroupProfile {displayName = n}} m@GroupMember {memberProfile = LocalProfile {displayName}} ciId msgText
|
||||
| memberRequiresCaptcha a m = do
|
||||
let gmId = groupMemberId' m
|
||||
sendRef = SRGroup groupId $ Just $ GCSMemberSupport (Just gmId)
|
||||
cmd = fromRight (ADC SDRUser DCUnknownCommand) $ A.parseOnly (directoryCmdP <* A.endOfInput) $ T.strip msgText
|
||||
atomically (TM.lookup gmId $ pendingCaptchas env) >>= \case
|
||||
Nothing ->
|
||||
let mode = case cmd of ADC SDRUser (DCCaptchaMode CMAudio) -> CMAudio; _ -> CMText
|
||||
in sendMemberCaptcha g m (Just ciId) noCaptcha 0 mode
|
||||
Just pc@PendingCaptcha {captchaText, sentAt, attempts, captchaMode} -> case cmd of
|
||||
ADC SDRUser (DCCaptchaMode CMAudio) -> do
|
||||
atomically $ TM.insert gmId pc {captchaMode = CMAudio} $ pendingCaptchas env
|
||||
sendVoiceCaptcha sendRef (T.unpack captchaText)
|
||||
ADC SDRUser (DCSearchGroup _) -> do
|
||||
ts <- getCurrentTime
|
||||
if
|
||||
| ts `diffUTCTime` sentAt > captchaTTL -> sendMemberCaptcha g m (Just ciId) captchaExpired (attempts - 1) captchaMode
|
||||
| matchCaptchaStr captchaText msgText -> do
|
||||
sendComposedMessages_ cc sendRef [(Just ciId, MCText $ "Correct, you joined the group " <> n)]
|
||||
approvePendingMember a g m
|
||||
| attempts >= maxCaptchaAttempts -> rejectPendingMember tooManyAttempts
|
||||
| otherwise -> sendMemberCaptcha g m (Just ciId) (wrongCaptcha attempts) attempts captchaMode
|
||||
_ -> sendComposedMessages_ cc sendRef [(Just ciId, MCText unknownCommand)]
|
||||
| otherwise = approvePendingMember a g m
|
||||
where
|
||||
a = groupMemberAcceptance g
|
||||
rejectPendingMember rjctNotice = do
|
||||
let gmId = groupMemberId' m
|
||||
sendComposedMessages cc (SRGroup groupId $ Just $ GCSMemberSupport (Just gmId)) [MCText rjctNotice]
|
||||
sendChatCmd cc (APIRemoveMembers groupId [gmId] False) >>= \case
|
||||
Right (CRUserDeletedMembers _ _ (_ : _) _) -> do
|
||||
atomically $ TM.delete gmId $ pendingCaptchas env
|
||||
logInfo $ "Member " <> viewName displayName <> " rejected, group " <> tshow groupId <> ":" <> viewGroupName g
|
||||
r -> logError $ "unexpected remove member response: " <> tshow r
|
||||
captchaExpired = "Captcha expired, please try again."
|
||||
wrongCaptcha attempts
|
||||
| attempts == maxCaptchaAttempts - 1 = "Incorrect text, please try again - this is your last attempt."
|
||||
| otherwise = "Incorrect text, please try again."
|
||||
noCaptcha = "Unexpected message, please try again."
|
||||
unknownCommand = "Unknown command, please enter captcha text."
|
||||
tooManyAttempts = "Too many failed attempts, you can't join group."
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
### 3.13 Add imports in Service.hs
|
||||
|
||||
**File:** `apps/simplex-directory-service/src/Directory/Service.hs`
|
||||
|
||||
**Location:** After existing imports (around line 28)
|
||||
|
||||
**Add:**
|
||||
```haskell
|
||||
import qualified Data.Attoparsec.Text as A
|
||||
import Data.Either (fromRight)
|
||||
```
|
||||
|
||||
**Note:** `T.strip` is already available via the existing `import qualified Data.Text as T`.
|
||||
|
||||
---
|
||||
|
||||
## Test Updates
|
||||
|
||||
**File:** `tests/Bots/DirectoryTests.hs`
|
||||
|
||||
### 4.1 Update expected output for clickable command
|
||||
|
||||
**Location:** Line 1278 (or wherever `"Send /audio"` appears)
|
||||
|
||||
**Before:**
|
||||
```haskell
|
||||
cath <## "Send /audio to receive a voice captcha."
|
||||
```
|
||||
|
||||
**After:**
|
||||
```haskell
|
||||
cath <## "Send /'audio' to receive a voice captcha."
|
||||
```
|
||||
|
||||
### 4.2 Add test for audio captcha retry behavior
|
||||
|
||||
**Location:** New test function `testVoiceCaptchaRetry` after `testVoiceCaptchaScreening`
|
||||
|
||||
**Strategy:** Add test that verifies wrong answer after `/audio` sends voice retry (not image).
|
||||
|
||||
```haskell
|
||||
testVoiceCaptchaRetry :: HasCallStack => TestParams -> IO ()
|
||||
testVoiceCaptchaRetry ps = do
|
||||
-- Setup similar to testVoiceCaptchaScreening...
|
||||
-- After receiving initial image captcha and switching to audio:
|
||||
-- cath requests audio captcha
|
||||
cath #> "#privacy (support) /audio"
|
||||
cath <# "#privacy (support) 'SimpleX Directory'> voice message (00:05)"
|
||||
cath <#. "#privacy (support) 'SimpleX Directory'> sends file "
|
||||
cath <##. "use /fr 1"
|
||||
-- cath sends WRONG answer after switching to audio mode
|
||||
cath #> "#privacy (support) wrong_answer"
|
||||
cath <# "#privacy (support) 'SimpleX Directory'!> > cath wrong_answer"
|
||||
cath <## " Incorrect text, please try again."
|
||||
-- KEY ASSERTION: retry sends VOICE captcha (not image) because captchaMode=CMAudio
|
||||
cath <# "#privacy (support) 'SimpleX Directory'> voice message (00:05)"
|
||||
cath <#. "#privacy (support) 'SimpleX Directory'> sends file "
|
||||
cath <##. "use /fr 2"
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
## Files Changed
|
||||
|
||||
| File | Changes |
|
||||
|------|---------|
|
||||
| `apps/simplex-directory-service/src/Directory/Events.hs` | Add `CaptchaMode` type; add `DCCaptchaMode_` tag; add `DCCaptchaMode` constructor; add "audio" tag parsing; add `cmdP` case; add `directoryCmdTag` case; export `directoryCmdP`; update exports |
|
||||
| `apps/simplex-directory-service/src/Directory/Service.hs` | Add imports (`Data.Attoparsec.Text`, `Data.Either.fromRight`); update `PendingCaptcha` with `captchaMode :: CaptchaMode`; update `sendMemberCaptcha` signature; refactor `dePendingMemberMsg` with inverted structure; make `/audio` clickable |
|
||||
| `tests/Bots/DirectoryTests.hs` | Update expected output (`/'audio'`); add `testVoiceCaptchaRetry` |
|
||||
|
||||
---
|
||||
|
||||
## Summary of Changes
|
||||
|
||||
1. **New type in Events.hs:**
|
||||
- `data CaptchaMode = CMText | CMAudio`
|
||||
|
||||
2. **New constructor in DirectoryCmd GADT:**
|
||||
- `DCCaptchaMode :: CaptchaMode -> DirectoryCmd 'DRUser`
|
||||
- Uses existing Attoparsec parsing infrastructure via `directoryCmdP`
|
||||
|
||||
3. **State tracking (Service.hs):**
|
||||
- `PendingCaptcha { ..., captchaMode :: CaptchaMode }`
|
||||
|
||||
4. **Refactored `dePendingMemberMsg` (Service.hs):**
|
||||
- Parses command FIRST using `directoryCmdP`
|
||||
- Does `TM.lookup` ONCE (inverted structure, no duplication)
|
||||
- `Nothing` case: send new captcha in mode derived from command
|
||||
- `Just pc` case: switch on command type
|
||||
- `DCCaptchaMode CMAudio` → set mode, send voice captcha
|
||||
- `DCSearchGroup _` → captcha answer (verify/retry)
|
||||
- `_` → unknown command (error message)
|
||||
|
||||
5. **Updated `sendMemberCaptcha` (Service.hs):**
|
||||
- Takes `CaptchaMode` parameter instead of `Bool`
|
||||
- Sends voice or image captcha based on mode
|
||||
|
||||
6. **Clickable command:**
|
||||
- `"Send /'audio'"` instead of `"Send /audio"`
|
||||
|
||||
7. **Test coverage:**
|
||||
- `testVoiceCaptchaScreening` (updated): verify clickable command format
|
||||
- `testVoiceCaptchaRetry` (new): verify retry behavior with `captchaMode` persistence
|
||||
79
plans/directory-tests-coverage.md
Normal file
79
plans/directory-tests-coverage.md
Normal file
@@ -0,0 +1,79 @@
|
||||
# Directory Modules: Test Coverage Report
|
||||
|
||||
## Final Coverage
|
||||
|
||||
| Module | Expressions | Coverage | Gap |
|
||||
|---|---|---|---|
|
||||
| **Captcha** | 84/84 | **100%** | -- |
|
||||
| **Search** | 3/3 | **100%** | -- |
|
||||
| **BlockedWords** | 158/158 | **100%** | -- |
|
||||
| **Events** | 527/559 | **94%** | 32 expr |
|
||||
| **Options** | 223/291 | **76%** | 68 expr |
|
||||
| **Store** | 1137/1306 | **87%** | 169 expr |
|
||||
| **Listing** | 379/650 | **58%** | 271 expr |
|
||||
|
||||
84 tests, 0 failures.
|
||||
|
||||
## What was covered
|
||||
|
||||
Tests added to `tests/Bots/DirectoryTests.hs`:
|
||||
|
||||
- **Search**: `SearchRequest` field selectors (`searchType`, `searchTime`, `lastGroup`)
|
||||
- **BlockedWords**: `BlockedWordsConfig` field selectors, `removeTriples` with `'\0'` input to force initial `False` argument
|
||||
- **Options**: `directoryOpts` parser via `execParserPure` (minimal args, non-default args, all `MigrateLog` variants), `mkChatOpts` remaining fields
|
||||
- **Events**: command parser edge cases (`/`, `/filter 1 name=all`, `/submit`, moderate/strong presets), `Show` instances for `DirectoryCmdTag`, `DirectoryCmd`, `SDirectoryRole`, `DirectoryHelpSection`, `DirectoryEvent`, `ADirectoryCmd` (including `showList`), `DCApproveGroup` field selectors via `OverloadedRecordDot`, `CEvtChatErrors` path
|
||||
- **Store**: `Show` instances for `GroupRegStatus` constructors, `ProfileCondition`, `noJoinFilter`, `GroupReg.createdAt` field
|
||||
- **Listing**: `DirectoryEntryType` JSON round-trip with field selectors
|
||||
|
||||
Source changes:
|
||||
|
||||
- `Directory/Options.hs`: exported `directoryOpts`
|
||||
- `Directory/Events.hs`: exported `DirectoryCmdTag (..)`
|
||||
|
||||
## Why not 100%
|
||||
|
||||
### Events (32 expr remaining)
|
||||
|
||||
**Field selectors (9 expr)** on `DEGroupInvitation`, `DEServiceJoinedGroup`, `DEGroupUpdated` -- need `Contact`, `GroupInfo`, `GroupMember` types which have 20+ nested required fields each with no test constructors available.
|
||||
|
||||
**`crDirectoryEvent_` branches (3 expr)**: `DEItemDeleteIgnored`, `DEUnsupportedMessage`, `CEvtMessageError` -- need `AChatItem` or `User`, both strict-data types with deep dependency chains impossible to construct in unit tests.
|
||||
|
||||
**`DCSubmitGroup` paths (2 expr)**: constructor and `directoryCmdTag` case -- need a valid `ConnReqContact` (SMP queue URI with cryptographic keys).
|
||||
|
||||
**Lazy `fail` strings (2 expr)**: `"bad command tag"` and `"bad help section"` -- Attoparsec discards the string argument to `fail` without evaluating it. Inherently uncoverable by HPC.
|
||||
|
||||
### Options (68 expr remaining)
|
||||
|
||||
**Parser metadata strings (~50 expr)**: `metavar` and `help` string literals in `optparse-applicative` option declarations are evaluated lazily by the library. `execParserPure` constructs the parser but doesn't force help strings unless `--help` is invoked.
|
||||
|
||||
**`getDirectoryOpts` (~10 expr)**: wraps `execParser` which reads process `argv` -- can't unit-test without spawning a process.
|
||||
|
||||
**`parseKnownGroup` internals (~8 expr)**: the `--owners-group` arg is parsed but the `KnownContacts` parser internals are instrumented separately.
|
||||
|
||||
### Store (169 expr remaining)
|
||||
|
||||
**DB operations (~150 expr)**: `withDB'` wrappers, SQL query strings, error message literals inside database functions (`setGroupStatusStore`, `setGroupRegOwnerStore`, `searchListedGroups`, `getAllGroupRegs_`, etc.) -- all require a running SQLite database with realistic data.
|
||||
|
||||
**Pagination branches (~15 expr)**: `searchListedGroups` and `getAllGroupRegs_` cursor pagination -- need multi-page result sets.
|
||||
|
||||
**Parser failure (~4 expr)**: `GroupRegStatus` `strDecode` failure path -- needs malformed stored data.
|
||||
|
||||
### Listing (271 expr remaining)
|
||||
|
||||
**Image processing (~80 expr)**: `imgFileData`, image file Base64 encoding paths -- require groups with profile images.
|
||||
|
||||
**Listing generation (~120 expr)**: `generateListing`, `groupDirectoryEntry` -- require `GroupInfo` (21+ fields), `GroupLink`, `CreatedLinkContact` types with deep nesting into chat protocol internals.
|
||||
|
||||
**Field selectors (~40 expr)**: `DirectoryEntry` fields (`displayName`, `fullName`, `image`, `memberCount`, etc.) -- need full `DirectoryEntry` construction which requires `CreatedLinkContact`.
|
||||
|
||||
**TH-generated JSON (~30 expr)**: Template Haskell `deriveJSON` expressions are marked as runtime-uncovered by HPC despite executing at compile time.
|
||||
|
||||
## Summary
|
||||
|
||||
All remaining gaps fall into three categories:
|
||||
|
||||
1. **DB integration paths** -- require a running database (Store)
|
||||
2. **Complex chat protocol types** -- types with 20+ required nested fields (Events, Listing)
|
||||
3. **Lazy evaluation artifacts** -- HPC can't observe values that are never forced at runtime (Options `help` strings, Attoparsec `fail` strings, TH-generated code)
|
||||
|
||||
None are testable with pure unit tests without either standing up a database or constructing massive type hierarchies.
|
||||
@@ -600,6 +600,7 @@ test-suite simplex-chat-test
|
||||
apps/simplex-directory-service/src
|
||||
default-extensions:
|
||||
StrictData
|
||||
-- add -fhpc to ghc-options below to run tests with coverage
|
||||
ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded
|
||||
build-depends:
|
||||
QuickCheck ==2.14.*
|
||||
|
||||
@@ -12,7 +12,7 @@ import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (isJust)
|
||||
@@ -26,6 +26,7 @@ import Simplex.Chat.Protocol (MsgContent (..))
|
||||
import Simplex.Chat.Store
|
||||
import Simplex.Chat.Types (Contact (..), ContactId, IsContact (..), User (..))
|
||||
import Simplex.Messaging.Agent.Protocol (CreatedConnLink (..))
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile)
|
||||
import Simplex.Messaging.Encoding.String (strEncode)
|
||||
import System.Exit (exitFailure)
|
||||
|
||||
@@ -89,6 +90,13 @@ sendComposedMessages_ cc sendRef qmcs = do
|
||||
Right (CRNewChatItems {}) -> printLog cc CLLInfo $ "sent " <> show (length cms) <> " messages to " <> show sendRef
|
||||
r -> putStrLn $ "unexpected send message response: " <> show r
|
||||
|
||||
sendComposedMessageFile :: ChatController -> SendRef -> Maybe ChatItemId -> MsgContent -> CryptoFile -> IO ()
|
||||
sendComposedMessageFile cc sendRef qiId mc file = do
|
||||
let cm = ComposedMessage {fileSource = Just file, quotedItemId = qiId, msgContent = mc, mentions = M.empty}
|
||||
sendChatCmd cc (APISendMessages sendRef False Nothing (cm :| [])) >>= \case
|
||||
Right (CRNewChatItems {}) -> printLog cc CLLInfo $ "sent file message to " <> show sendRef
|
||||
r -> putStrLn $ "unexpected send message response: " <> show r
|
||||
|
||||
deleteMessage :: ChatController -> Contact -> ChatItemId -> IO ()
|
||||
deleteMessage cc ct chatItemId = do
|
||||
let cmd = APIDeleteChatItem (contactRef ct) [chatItemId] CIDMInternal
|
||||
|
||||
@@ -19,7 +19,8 @@ import Directory.Listing
|
||||
import Directory.Options
|
||||
import Directory.Service
|
||||
import Directory.Store
|
||||
import GHC.IO.Handle (hClose)
|
||||
import System.Directory (emptyPermissions, setOwnerExecutable, setOwnerReadable, setOwnerWritable, setPermissions)
|
||||
import System.IO (hClose)
|
||||
import Simplex.Chat.Bot.KnownContacts
|
||||
import Simplex.Chat.Controller (ChatConfig (..))
|
||||
import qualified Simplex.Chat.Markdown as MD
|
||||
@@ -70,10 +71,18 @@ directoryServiceTests = do
|
||||
it "should list and promote user's groups" $ testListUserGroups True
|
||||
describe "member admission" $ do
|
||||
it "should ask member to pass captcha screen" testCapthaScreening
|
||||
it "should send voice captcha on /audio command" testVoiceCaptchaScreening
|
||||
it "should retry with voice captcha after switching to audio mode" testVoiceCaptchaRetry
|
||||
it "should reject member after too many captcha attempts" testCaptchaTooManyAttempts
|
||||
it "should respond to unknown command during captcha" testCaptchaUnknownCommand
|
||||
describe "store log" $ do
|
||||
it "should restore directory service state" testRestoreDirectory
|
||||
describe "captcha" $ do
|
||||
it "should accept some incorrect spellings" testCaptcha
|
||||
it "should generate captcha of correct length" testGetCaptchaStr
|
||||
describe "help commands" $ do
|
||||
it "should not list audio command" testHelpNoAudio
|
||||
it "should reject audio command in DM" testAudioCommandInDM
|
||||
|
||||
directoryProfile :: Profile
|
||||
directoryProfile = Profile {displayName = "SimpleX Directory", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing}
|
||||
@@ -102,6 +111,7 @@ mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup webFolder =
|
||||
nameSpellingFile = Nothing,
|
||||
profileNameLimit = maxBound,
|
||||
captchaGenerator = Nothing,
|
||||
voiceCaptchaGenerator = Nothing,
|
||||
directoryLog = Just $ ps </> "directory_service.log",
|
||||
migrateDirectoryLog = Nothing,
|
||||
serviceName = "SimpleX Directory",
|
||||
@@ -404,9 +414,11 @@ testJoinGroup ps =
|
||||
cath <## "connection request sent!"
|
||||
cath <## "#privacy: joining the group..."
|
||||
cath <## "#privacy: you joined the group"
|
||||
cath <## "contact and member are merged: 'SimpleX Directory', #privacy 'SimpleX Directory_1'"
|
||||
cath <## "use @'SimpleX Directory' <message> to send messages"
|
||||
cath <# ("#privacy 'SimpleX Directory'> " <> welcomeMsg)
|
||||
cath
|
||||
<### [ "contact and member are merged: 'SimpleX Directory', #privacy 'SimpleX Directory_1'",
|
||||
"use @'SimpleX Directory' <message> to send messages",
|
||||
Predicate (\l -> l == welcomeMsg || dropTime_ l == Just ("#privacy 'SimpleX Directory'> " <> welcomeMsg) || dropTime_ l == Just ("#privacy 'SimpleX Directory_1'> " <> welcomeMsg))
|
||||
]
|
||||
cath <## "#privacy: member bob (Bob) is connected"
|
||||
bob <## "#privacy: 'SimpleX Directory' added cath (Catherine) to the group (connecting...)"
|
||||
bob <## "#privacy: new member cath is connected"
|
||||
@@ -1225,6 +1237,152 @@ testCapthaScreening ps =
|
||||
cath <## " Correct, you joined the group privacy"
|
||||
cath <## "#privacy: you joined the group"
|
||||
|
||||
testVoiceCaptchaScreening :: HasCallStack => TestParams -> IO ()
|
||||
testVoiceCaptchaScreening ps@TestParams {tmpPath} = do
|
||||
let mockScript = tmpPath </> "mock_voice_gen.py"
|
||||
-- Mock script writes a dummy audio file, prints path and duration
|
||||
writeFile mockScript $ unlines
|
||||
[ "#!/usr/bin/env python3",
|
||||
"import os, tempfile",
|
||||
"out = os.environ.get('VOICE_CAPTCHA_OUT')",
|
||||
"if not out:",
|
||||
" fd, out = tempfile.mkstemp(suffix='.m4a')",
|
||||
" os.close(fd)",
|
||||
"open(out, 'wb').write(b'\\x00' * 100)",
|
||||
"print(out)",
|
||||
"print(5)"
|
||||
]
|
||||
setPermissions mockScript $ setOwnerExecutable True $ setOwnerReadable True $ setOwnerWritable True emptyPermissions
|
||||
withDirectoryServiceVoiceCaptcha ps mockScript $ \superUser dsLink ->
|
||||
withNewTestChat ps "bob" bobProfile $ \bob ->
|
||||
withNewTestChat ps "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
-- get group link
|
||||
bob #> "@'SimpleX Directory' /role 1"
|
||||
bob <# "'SimpleX Directory'> > /role 1"
|
||||
bob <## " The initial member role for the group privacy is set to member"
|
||||
bob <## "Send /'role 1 observer' to change it."
|
||||
bob <## ""
|
||||
note <- getTermLine bob
|
||||
let groupLink = dropStrPrefix "Please note: it applies only to members joining via this link: " note
|
||||
-- enable captcha
|
||||
bob #> "@'SimpleX Directory' /filter 1 captcha"
|
||||
bob <# "'SimpleX Directory'> > /filter 1 captcha"
|
||||
bob <## " Spam filter settings for group privacy set to:"
|
||||
bob <## "- reject long/inappropriate names: disabled"
|
||||
bob <## "- pass captcha to join: enabled"
|
||||
bob <## ""
|
||||
bob <## "/'filter 1 name' - enable name filter"
|
||||
bob <## "/'filter 1 name captcha' - enable both"
|
||||
bob <## "/'filter 1 off' - disable filter"
|
||||
-- cath joins, receives text captcha with /audio hint
|
||||
cath ##> ("/c " <> groupLink)
|
||||
cath <## "connection request sent!"
|
||||
cath <## "#privacy: joining the group..."
|
||||
cath <## "#privacy: you joined the group, pending approval"
|
||||
cath <# "#privacy (support) 'SimpleX Directory'> Captcha is generated by SimpleX Directory service."
|
||||
cath <## ""
|
||||
cath <## "Send captcha text to join the group privacy."
|
||||
cath <## "Send /audio to receive a voice captcha."
|
||||
captcha <- dropStrPrefix "#privacy (support) 'SimpleX Directory'> " . dropTime <$> getTermLine cath
|
||||
-- cath requests audio captcha
|
||||
cath #> "#privacy (support) /audio"
|
||||
cath <# "#privacy (support) 'SimpleX Directory'> voice message (00:05)"
|
||||
cath <#. "#privacy (support) 'SimpleX Directory'> sends file "
|
||||
cath <##. "use /fr 1"
|
||||
-- cath sends /audio again, already enabled
|
||||
cath #> "#privacy (support) /audio"
|
||||
cath <# "#privacy (support) 'SimpleX Directory'!> > cath /audio"
|
||||
cath <## " Audio captcha is already enabled."
|
||||
-- send correct captcha
|
||||
sendCaptcha cath captcha
|
||||
cath <#. "#privacy 'SimpleX Directory'> Link to join the group privacy: https://"
|
||||
cath <## "#privacy: member bob (Bob) is connected"
|
||||
bob <## "#privacy: 'SimpleX Directory' added cath (Catherine) to the group (connecting...)"
|
||||
bob <## "#privacy: new member cath is connected"
|
||||
where
|
||||
sendCaptcha cath captcha = do
|
||||
cath #> ("#privacy (support) " <> captcha)
|
||||
cath <# ("#privacy (support) 'SimpleX Directory'!> > cath " <> captcha)
|
||||
cath <## " Correct, you joined the group privacy"
|
||||
cath <## "#privacy: you joined the group"
|
||||
|
||||
testVoiceCaptchaRetry :: HasCallStack => TestParams -> IO ()
|
||||
testVoiceCaptchaRetry ps@TestParams {tmpPath} = do
|
||||
let mockScript = tmpPath </> "mock_voice_gen_retry.py"
|
||||
writeFile mockScript $ unlines
|
||||
[ "#!/usr/bin/env python3",
|
||||
"import os, tempfile",
|
||||
"out = os.environ.get('VOICE_CAPTCHA_OUT')",
|
||||
"if not out:",
|
||||
" fd, out = tempfile.mkstemp(suffix='.m4a')",
|
||||
" os.close(fd)",
|
||||
"open(out, 'wb').write(b'\\x00' * 100)",
|
||||
"print(out)",
|
||||
"print(5)"
|
||||
]
|
||||
setPermissions mockScript $ setOwnerExecutable True $ setOwnerReadable True $ setOwnerWritable True emptyPermissions
|
||||
withDirectoryServiceVoiceCaptcha ps mockScript $ \superUser dsLink ->
|
||||
withNewTestChat ps "bob" bobProfile $ \bob ->
|
||||
withNewTestChat ps "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
bob #> "@'SimpleX Directory' /role 1"
|
||||
bob <# "'SimpleX Directory'> > /role 1"
|
||||
bob <## " The initial member role for the group privacy is set to member"
|
||||
bob <## "Send /'role 1 observer' to change it."
|
||||
bob <## ""
|
||||
note <- getTermLine bob
|
||||
let groupLink = dropStrPrefix "Please note: it applies only to members joining via this link: " note
|
||||
bob #> "@'SimpleX Directory' /filter 1 captcha"
|
||||
bob <# "'SimpleX Directory'> > /filter 1 captcha"
|
||||
bob <## " Spam filter settings for group privacy set to:"
|
||||
bob <## "- reject long/inappropriate names: disabled"
|
||||
bob <## "- pass captcha to join: enabled"
|
||||
bob <## ""
|
||||
bob <## "/'filter 1 name' - enable name filter"
|
||||
bob <## "/'filter 1 name captcha' - enable both"
|
||||
bob <## "/'filter 1 off' - disable filter"
|
||||
-- cath joins, receives text captcha with /audio hint
|
||||
cath ##> ("/c " <> groupLink)
|
||||
cath <## "connection request sent!"
|
||||
cath <## "#privacy: joining the group..."
|
||||
cath <## "#privacy: you joined the group, pending approval"
|
||||
cath <# "#privacy (support) 'SimpleX Directory'> Captcha is generated by SimpleX Directory service."
|
||||
cath <## ""
|
||||
cath <## "Send captcha text to join the group privacy."
|
||||
cath <## "Send /audio to receive a voice captcha."
|
||||
_ <- getTermLine cath -- captcha image/text
|
||||
-- cath requests audio captcha
|
||||
cath #> "#privacy (support) /audio"
|
||||
cath <# "#privacy (support) 'SimpleX Directory'> voice message (00:05)"
|
||||
cath <#. "#privacy (support) 'SimpleX Directory'> sends file "
|
||||
cath <##. "use /fr 1"
|
||||
-- cath sends WRONG answer after switching to audio mode
|
||||
cath #> "#privacy (support) wrong_answer"
|
||||
cath <# "#privacy (support) 'SimpleX Directory'!> > cath wrong_answer"
|
||||
cath <## " Incorrect text, please try again."
|
||||
-- KEY ASSERTION: retry sends BOTH image and voice because captchaMode=CMAudio
|
||||
_ <- getTermLine cath -- captcha image/text
|
||||
cath <# "#privacy (support) 'SimpleX Directory'> voice message (00:05)"
|
||||
cath <#. "#privacy (support) 'SimpleX Directory'> sends file "
|
||||
cath <##. "use /fr 2"
|
||||
|
||||
withDirectoryServiceVoiceCaptcha :: HasCallStack => TestParams -> FilePath -> (TestCC -> String -> IO ()) -> IO ()
|
||||
withDirectoryServiceVoiceCaptcha ps voiceScript test = do
|
||||
dsLink <-
|
||||
withNewTestChatCfg ps testCfg serviceDbPrefix directoryProfile $ \ds ->
|
||||
withNewTestChatCfg ps testCfg "super_user" aliceProfile $ \superUser -> do
|
||||
connectUsers ds superUser
|
||||
ds ##> "/ad"
|
||||
getContactLink ds True
|
||||
let opts = (mkDirectoryOpts ps [KnownContact 2 "alice"] Nothing Nothing) {voiceCaptchaGenerator = Just voiceScript}
|
||||
runDirectory testCfg opts $
|
||||
withTestChatCfg ps testCfg "super_user" $ \superUser -> do
|
||||
superUser <## "subscribed 1 connections on server localhost"
|
||||
test superUser dsLink
|
||||
|
||||
testRestoreDirectory :: HasCallStack => TestParams -> IO ()
|
||||
testRestoreDirectory ps = do
|
||||
testListUserGroups False ps
|
||||
@@ -1538,3 +1696,119 @@ groupNotFound_ suffix u s = do
|
||||
u #> ("@'SimpleX Directory" <> suffix <> "' " <> s)
|
||||
u <# ("'SimpleX Directory" <> suffix <> "'> > " <> s)
|
||||
u <## " No groups found"
|
||||
|
||||
testCaptchaTooManyAttempts :: HasCallStack => TestParams -> IO ()
|
||||
testCaptchaTooManyAttempts ps =
|
||||
withDirectoryService ps $ \superUser dsLink ->
|
||||
withNewTestChat ps "bob" bobProfile $ \bob ->
|
||||
withNewTestChat ps "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
bob #> "@'SimpleX Directory' /role 1"
|
||||
bob <# "'SimpleX Directory'> > /role 1"
|
||||
bob <## " The initial member role for the group privacy is set to member"
|
||||
bob <## "Send /'role 1 observer' to change it."
|
||||
bob <## ""
|
||||
note <- getTermLine bob
|
||||
let groupLink = dropStrPrefix "Please note: it applies only to members joining via this link: " note
|
||||
bob #> "@'SimpleX Directory' /filter 1 captcha"
|
||||
bob <# "'SimpleX Directory'> > /filter 1 captcha"
|
||||
bob <## " Spam filter settings for group privacy set to:"
|
||||
bob <## "- reject long/inappropriate names: disabled"
|
||||
bob <## "- pass captcha to join: enabled"
|
||||
bob <## ""
|
||||
bob <## "/'filter 1 name' - enable name filter"
|
||||
bob <## "/'filter 1 name captcha' - enable both"
|
||||
bob <## "/'filter 1 off' - disable filter"
|
||||
cath ##> ("/c " <> groupLink)
|
||||
cath <## "connection request sent!"
|
||||
cath <## "#privacy: joining the group..."
|
||||
cath <## "#privacy: you joined the group, pending approval"
|
||||
cath <# "#privacy (support) 'SimpleX Directory'> Captcha is generated by SimpleX Directory service."
|
||||
cath <## ""
|
||||
cath <## "Send captcha text to join the group privacy."
|
||||
_ <- getTermLine cath
|
||||
forM_ [1 :: Int .. 4] $ \i -> do
|
||||
cath #> "#privacy (support) wrong"
|
||||
cath <# "#privacy (support) 'SimpleX Directory'!> > cath wrong"
|
||||
if i == 4
|
||||
then cath <## " Incorrect text, please try again - this is your last attempt."
|
||||
else cath <## " Incorrect text, please try again."
|
||||
_ <- getTermLine cath
|
||||
pure ()
|
||||
cath #> "#privacy (support) wrong"
|
||||
cath <# "#privacy (support) 'SimpleX Directory'> Too many failed attempts, you can't join group."
|
||||
-- member removal produces multiple messages
|
||||
_ <- getTermLine cath
|
||||
_ <- getTermLine cath
|
||||
_ <- getTermLine cath
|
||||
pure ()
|
||||
|
||||
testCaptchaUnknownCommand :: HasCallStack => TestParams -> IO ()
|
||||
testCaptchaUnknownCommand ps =
|
||||
withDirectoryService ps $ \superUser dsLink ->
|
||||
withNewTestChat ps "bob" bobProfile $ \bob ->
|
||||
withNewTestChat ps "cath" cathProfile $ \cath -> do
|
||||
bob `connectVia` dsLink
|
||||
registerGroup superUser bob "privacy" "Privacy"
|
||||
bob #> "@'SimpleX Directory' /role 1"
|
||||
bob <# "'SimpleX Directory'> > /role 1"
|
||||
bob <## " The initial member role for the group privacy is set to member"
|
||||
bob <## "Send /'role 1 observer' to change it."
|
||||
bob <## ""
|
||||
note <- getTermLine bob
|
||||
let groupLink = dropStrPrefix "Please note: it applies only to members joining via this link: " note
|
||||
bob #> "@'SimpleX Directory' /filter 1 captcha"
|
||||
bob <# "'SimpleX Directory'> > /filter 1 captcha"
|
||||
bob <## " Spam filter settings for group privacy set to:"
|
||||
bob <## "- reject long/inappropriate names: disabled"
|
||||
bob <## "- pass captcha to join: enabled"
|
||||
bob <## ""
|
||||
bob <## "/'filter 1 name' - enable name filter"
|
||||
bob <## "/'filter 1 name captcha' - enable both"
|
||||
bob <## "/'filter 1 off' - disable filter"
|
||||
cath ##> ("/c " <> groupLink)
|
||||
cath <## "connection request sent!"
|
||||
cath <## "#privacy: joining the group..."
|
||||
cath <## "#privacy: you joined the group, pending approval"
|
||||
cath <# "#privacy (support) 'SimpleX Directory'> Captcha is generated by SimpleX Directory service."
|
||||
cath <## ""
|
||||
cath <## "Send captcha text to join the group privacy."
|
||||
_ <- getTermLine cath
|
||||
cath #> "#privacy (support) /help"
|
||||
cath <# "#privacy (support) 'SimpleX Directory'!> > cath /help"
|
||||
cath <## " Unknown command, please enter captcha text."
|
||||
|
||||
testHelpNoAudio :: HasCallStack => TestParams -> IO ()
|
||||
testHelpNoAudio ps =
|
||||
withDirectoryService ps $ \_ dsLink ->
|
||||
withNewTestChat ps "bob" bobProfile $ \bob -> do
|
||||
bob `connectVia` dsLink
|
||||
-- commands help should not mention /audio
|
||||
bob #> "@'SimpleX Directory' /help commands"
|
||||
bob <# "'SimpleX Directory'> /'help commands' - receive this help message."
|
||||
bob <## "/help - how to register your group to be added to directory."
|
||||
bob <## "/list - list the groups you registered."
|
||||
bob <## "`/role <ID>` - view and set default member role for your group."
|
||||
bob <## "`/filter <ID>` - view and set spam filter settings for group."
|
||||
bob <## "`/link <ID>` - view and upgrade group link."
|
||||
bob <## "`/delete <ID>:<NAME>` - remove the group you submitted from directory, with ID and name as shown by /list command."
|
||||
bob <## ""
|
||||
bob <## "To search for groups, send the search text."
|
||||
|
||||
testAudioCommandInDM :: HasCallStack => TestParams -> IO ()
|
||||
testAudioCommandInDM ps =
|
||||
withDirectoryService ps $ \_ dsLink ->
|
||||
withNewTestChat ps "bob" bobProfile $ \bob -> do
|
||||
bob `connectVia` dsLink
|
||||
bob #> "@'SimpleX Directory' /audio"
|
||||
bob <# "'SimpleX Directory'> > /audio"
|
||||
bob <## " Unknown command"
|
||||
|
||||
testGetCaptchaStr :: HasCallStack => TestParams -> IO ()
|
||||
testGetCaptchaStr _ps = do
|
||||
s0 <- getCaptchaStr 0 ""
|
||||
s0 `shouldBe` ""
|
||||
s7 <- getCaptchaStr 7 ""
|
||||
length s7 `shouldBe` 7
|
||||
all (`elem` ("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" :: String)) s7 `shouldBe` True
|
||||
|
||||
Reference in New Issue
Block a user