From 4afce49312fa730e91b12417cfc7bbcf50cfb4fe Mon Sep 17 00:00:00 2001 From: spacedandy-agents-simplex <342056592+spacedandy-agents-simplex@users.noreply.github.com> Date: Thu, 22 Oct 2026 15:19:17 +0000 Subject: [PATCH] directory: test that a search in progress holds its place under the in-flight cap, and that '%' in search text matches literally The cap tests passed with the slot's increment removed (cap 0 rejects before counting, and two requests one after the other never overlap), so taking, forking and freeing a place is now one function, forkWithinCap, tested with a held request. The '%' probe needed a 'q' that no field had, so it found nothing escaped or not; "privacy%group" finds the group unless '%' is escaped. --- .../src/Directory/Service.hs | 16 ++++++----- tests/Bots/DirectoryTests.hs | 27 +++++++++++-------- 2 files changed, 26 insertions(+), 17 deletions(-) diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 1bad8e4c9a..e3f12a89b1 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -17,6 +17,7 @@ module Directory.Service newServiceState, directoryService, directoryServiceCLI, + forkWithinCap, ) where @@ -326,6 +327,13 @@ readBlockedWordsConfig DirectoryOpts {blockedFragmentsFile, blockedWordsFile, na unless testing $ putStrLn $ "Blocked fragments: " <> show (length blockedFragments) <> ", blocked words: " <> show (length blockedWords) <> ", spelling rules: " <> show (M.size spelling) pure BlockedWordsConfig {blockedFragments, blockedWords, extensionRules, spelling} +-- the place is freed however the action ends, so a failed search can't shrink the cap +forkWithinCap :: TVar Int -> Int -> IO () -> IO Bool +forkWithinCap inFlight cap action = do + accepted <- atomically $ stateTVar inFlight $ \n -> if n < cap then (True, n + 1) else (False, n) + when accepted $ void $ forkIO $ action `finally` atomically (modifyTVar' inFlight (subtract 1)) + pure accepted + directoryServiceEvent :: DirectoryOpts -> ServiceState -> User -> ChatController -> DirectoryEvent -> IO () directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults, maxServiceRequestsInFlight, prohibitedToObserver, alwaysCaptcha, alwaysObserver} env@ServiceState {searchRequests, serviceRequestsInFlight} user@User {userId} cc = \case DEContactConnected ct -> deContactConnected ct @@ -360,13 +368,9 @@ directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, o deServiceRequest :: AgentInvId -> J.Object -> IO () deServiceRequest reqId req = do -- the event loop is shared with registrations and captchas, so the bound is on the forked handlers - accepted <- atomically $ stateTVar serviceRequestsInFlight $ \n -> - if n < maxServiceRequestsInFlight then (True, n + 1) else (False, n) - if accepted - then void $ forkIO $ (respond =<< requestResponse) `finally` releaseSlot - else reject "service is busy" + accepted <- forkWithinCap serviceRequestsInFlight maxServiceRequestsInFlight (respond =<< requestResponse) + unless accepted $ reject "service is busy" where - releaseSlot = atomically $ modifyTVar' serviceRequestsInFlight (subtract 1) -- this runs on the shared event loop, so the reject is enqueued rather than sent here reject reason = sendChatCmd cc (APIRejectServiceRequest userId reqId $ Just reason) >>= \case diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 0c299119b9..3bd647b500 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -11,9 +11,9 @@ import ChatClient import ChatTests.DBUtils import ChatTests.Groups (memberJoinChannel, prepareChannel1Relay) import ChatTests.Utils -import Control.Concurrent (threadDelay) +import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, threadDelay) import Control.Concurrent.Async (async, cancel) -import Control.Concurrent.STM (atomically, peekTQueue, readTVarIO, tryReadTMVar) +import Control.Concurrent.STM (atomically, newTVarIO, peekTQueue, readTVar, readTVarIO, retry, tryReadTMVar) import Control.Exception (finally) import Control.Monad (forM_, when, void) import Control.Monad.Except (runExceptT) @@ -77,6 +77,7 @@ directoryServiceTests = do it "should match LIKE wildcards in search text literally" testDirectorySearchRpcLiteral it "should reject service requests over the cap" testDirectorySearchRpcBusy it "should take a new service request once the previous one is answered" testDirectorySearchRpcSlotReleased + it "should hold a place under the in-flight cap until the request is answered" testServiceRequestSlotHeld it "should send every entry field the apps render" testDirectorySearchEntryFields it "should send a channel entry with its published link" testDirectorySearchChannelEntry it "should drop an oversize image and keep the entry" testSearchEntryImageBound @@ -742,18 +743,11 @@ testDirectorySearchRpcLiteral ps = withNewTestChat ps "bob" bobProfile $ \bob -> do bob `connectVia` dsShortLink registerGroupId superUser bob "PrivacyGroup" "" 1 1 - let descr = replicate 200 'e' - bob ##> ("/set welcome #PrivacyGroup " <> descr) - bob <## "welcome message changed to:" - bob <## descr - groupUpdatedHidden superUser bob "PrivacyGroup" "" $ - notifySuperUser_ superUser bob "PrivacyGroup" "" (Just descr) 1 1 - void $ approveRegistrationId superUser bob "PrivacyGroup" 1 1 withNewTestChat ps "cath" cathProfile $ \cath -> do (found, _) <- searchNames cath dsShortLink "privacy" Nothing found `shouldBe` ["PrivacyGroup"] - -- ten wildcard pairs against two hundred e's, then a character the description lacks - (none, _) <- searchNames cath dsShortLink (concat (replicate 10 "%e") <> "%q") Nothing + -- as a wildcard, '%' would match the empty string between the words + (none, _) <- searchNames cath dsShortLink "privacy%group" Nothing none `shouldBe` [] -- as a wildcard, '_' would match the 'g' (none', _) <- searchNames cath dsShortLink "privacy_roup" Nothing @@ -780,6 +774,17 @@ testDirectorySearchRpcSlotReleased ps = search cath <## noResults +-- the requests above are answered one after another, so only this shows a running request counts against the cap +testServiceRequestSlotHeld :: HasCallStack => TestParams -> IO () +testServiceRequestSlotHeld _ = do + inFlight <- newTVarIO 0 + answer <- newEmptyMVar + forkWithinCap inFlight 1 (takeMVar answer) `shouldReturn` True + forkWithinCap inFlight 1 (pure ()) `shouldReturn` False + putMVar answer () + timeout 5000000 (atomically $ readTVar inFlight >>= \n -> when (n /= 0) retry) `shouldReturn` Just () + forkWithinCap inFlight 1 (pure ()) `shouldReturn` True + -- Read from the controller, not the terminal: an entry with an image is longer than a terminal -- row, and the test terminal only queues the last row of a line that wrapped. searchDirectoryCounts :: TestCC -> String -> String -> Maybe J.Value -> IO ([DirectorySearchEntry], Maybe J.Value, Int, Int)