From aba09939e2a3d748fe922df902321d4a87f52b8b Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 11 Mar 2025 10:32:02 +0000 Subject: [PATCH] directory: more permissive captcha rules (#5741) --- .../src/Directory/Captcha.hs | 40 +++++++++++++++++++ .../src/Directory/Service.hs | 10 +---- simplex-chat.cabal | 1 + tests/Bots/DirectoryTests.hs | 14 +++++++ 4 files changed, 57 insertions(+), 8 deletions(-) create mode 100644 apps/simplex-directory-service/src/Directory/Captcha.hs diff --git a/apps/simplex-directory-service/src/Directory/Captcha.hs b/apps/simplex-directory-service/src/Directory/Captcha.hs new file mode 100644 index 0000000000..54d595e96f --- /dev/null +++ b/apps/simplex-directory-service/src/Directory/Captcha.hs @@ -0,0 +1,40 @@ +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) + +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) = + let g' = fromMaybe g $ M.lookup g captchaMatches + in c == g' && matchChars cs + +captchaChars :: String +captchaChars = "23456789ABCDEFGHIJKLMNOPQRSTUVWXYZabdefghijkmnpqrty" + +captchaMatches :: M.Map Char Char +captchaMatches = + M.fromList + [ ('0', 'O'), + ('1', 'I'), + ('c', 'C'), + ('l', 'I'), + ('o', 'O'), + ('s', 'S'), + ('u', 'U'), + ('v', 'V'), + ('w', 'W'), + ('x', 'X'), + ('z', 'Z') + ] diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 79654b4da6..575c7ca738 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -39,6 +39,7 @@ import qualified Data.Text.IO as T import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) import Data.Time.LocalTime (getCurrentTimeZone) import Directory.BlockedWords +import Directory.Captcha import Directory.Events import Directory.Options import Directory.Search @@ -67,7 +68,6 @@ import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (safeDecodeUtf8, tshow, ($>>=), (<$$>)) import System.Directory (getAppUserDataDirectory) import System.Process (readProcess) -import System.Random (randomRIO) data GroupProfileUpdate = GPNoServiceLink | GPServiceLinkAdded | GPServiceLinkRemoved | GPHasServiceLink | GPServiceLinkError @@ -455,12 +455,6 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName atomically $ TM.insert gmId captcha $ pendingCaptchas env sendCaptcha mc where - getCaptchaStr 0 s = pure s - getCaptchaStr n s = do - i <- randomRIO (0, length chars - 1) - let c = chars !! i - getCaptchaStr (n - 1) (c : s) - chars = "23456789ABCDEFGHIJKLMNOPQRSTUVWXYZabdefghijkmnpqrsty" getCaptcha s = case captchaGenerator opts of Nothing -> pure textMsg Just script -> content <$> readProcess script [s] "" @@ -491,7 +485,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName 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 - | captchaText == msgText -> do + | matchCaptchaStr captchaText msgText -> do sendComposedMessages_ cc (SRGroup groupId $ Just $ groupMemberId' m) [(Just ciId, MCText $ "Correct, you joined the group " <> n)] approvePendingMember a g m | attempts >= maxCaptchaAttempts -> rejectPendingMember tooManyAttempts diff --git a/simplex-chat.cabal b/simplex-chat.cabal index bbdd766a7b..377fb41d81 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -408,6 +408,7 @@ executable simplex-directory-service StrictData other-modules: Directory.BlockedWords + Directory.Captcha Directory.Events Directory.Options Directory.Search diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 31b36159fd..1e22b1854e 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -13,6 +13,7 @@ import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Exception (finally) import Control.Monad (forM_, when) import qualified Data.Text as T +import Directory.Captcha import qualified Directory.Events as DE import Directory.Options import Directory.Service @@ -65,6 +66,8 @@ directoryServiceTests = do it "should list user's groups" testListUserGroups describe "store log" $ do it "should restore directory service state" testRestoreDirectory + describe "captcha" $ do + it "should accept some incorrect spellings" testCaptcha directoryProfile :: Profile directoryProfile = Profile {displayName = "SimpleX-Directory", fullName = "", image = Nothing, contactLink = Nothing, preferences = Nothing} @@ -974,6 +977,17 @@ testRestoreDirectory ps = do cath #> "@SimpleX-Directory security" groupFoundN' 2 cath "security" +testCaptcha :: HasCallStack => TestParams -> IO () +testCaptcha _ps = do + let captcha = "23456789ABCDEFGHIJKLMNOPQRSTUVWXYZabdefghijkmnpqrty" + matchCaptchaStr captcha captcha `shouldBe` True + matchCaptchaStr captcha "23456789ABcDEFGH1JKLMNoPQRsTuvwxYzabdefghijkmnpqrty" `shouldBe` True + matchCaptchaStr "OOIICSUVWXZ" "OOIICSUVWXZ" `shouldBe` True + matchCaptchaStr "OOIICSUVWXZ" "0o1lcsuvwxz" `shouldBe` True + matchCaptchaStr "OOIICSUVWXZ" "" `shouldBe` False + matchCaptchaStr "OOIICSUVWXZ" "0o1lcsuvwx" `shouldBe` False + matchCaptchaStr "OOIICSUVWXZ" "0o1lcsuvwxzz" `shouldBe` False + listGroups :: HasCallStack => TestCC -> TestCC -> TestCC -> IO () listGroups superUser bob cath = do bob #> "@SimpleX-Directory /list"