directory: more permissive captcha rules (#5741)

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')
+    ]

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

simplex-chat.cabal

@@ -408,6 +408,7 @@ executable simplex-directory-service
       StrictData
   other-modules:
       Directory.BlockedWords
+      Directory.Captcha
       Directory.Events
       Directory.Options
       Directory.Search

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"