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.

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

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)