store: start the workers and the code sweep

apps/simplex-store-service/src/StoreService/Service.hs

@@ -25,9 +25,11 @@ import StoreService.Group (GroupEvent, ensureManagedGroup, groupEvent, hasTracke
 import StoreService.Group.Command (badgeTypeP, codeP, maxMonths, maxNameYears, nameCodeP, textTokenP)
 import StoreService.Names.Codes (issueNameCode, revokeNameCode)
 import StoreService.Names.Env (NamesEnv (..), newNamesEnv)
+import StoreService.Names.Orders (ordersEnv)
 import StoreService.Names.Records (runRecordEdits)
 import StoreService.Names.Sender (runSender)
 import StoreService.Names.Turns (Turns, newTurns)
+import StoreService.Names.Worker (newWorker, runCodeSweep, runWorkers)
 import StoreService.Options
 import StoreService.Poller (newPollerEnv, newReadHints, runPoller)
 import StoreService.Providers (Provider)
@@ -170,7 +172,8 @@ storeService opts@StoreServiceOpts {serviceConfigFile} cfg env = do
       webEnv <- newWebEnv chatStore sc ws hints providers namesEnv
       exportWebapp (listener sc) (stripe sc)
       pollerEnv <- newPollerEnv chatStore ws (nePhases <$> namesEnv) hints providers (poll sc)
-      pure $ [runWebListener webEnv, runPoller pollerEnv] <> maybe [] (\ne -> [runSender (neSender ne), runRecordEdits (neRecords ne)]) namesEnv
+      nameLanes <- maybe (pure []) namesLanes namesEnv
+      pure $ [runWebListener webEnv, runPoller pollerEnv] <> nameLanes
 
 startNames :: ChatController -> Turns -> Waiters -> [Provider] -> NamesConfig -> IO NamesEnv
 startNames cc@ChatController {chatStore} turns waiters providers nc@NamesConfig {nTLD, nChain = ChainConfig {cChainId}} =
@@ -180,6 +183,12 @@ startNames cc@ChatController {chatStore} turns waiters providers nc@NamesConfig
       logInfo $ "names: on, TLD " <> safeDecodeUtf8 (strEncode nTLD) <> ", chain " <> tshow cChainId
       newNamesEnv cc userId nc chatStore turns waiters providers
 
+-- | The workers resume every registration in their phases, and the code sweep runs at the start and then daily.
+namesLanes :: NamesEnv -> IO [IO ()]
+namesLanes ne@NamesEnv {neChain, neSender, neRecords} = do
+  worker <- newWorker (ordersEnv ne) neChain neSender
+  pure [runSender neSender, runRecordEdits neRecords, runWorkers worker, runCodeSweep worker]
+
 seedServiceCatalog :: DBStore -> IO ()
 seedServiceCatalog st = do
   now <- truncateToSecond <$> getCurrentTime

tests/Bots/StoreService/GroupIntegrationTests.hs

@@ -8,11 +8,12 @@
 {-# LANGUAGE TupleSections #-}
 
 -- Members' messages reach a console over separate connections in no fixed order, so gating is asserted from the bot's store.
-module Bots.StoreService.GroupIntegrationTests (badgeGroupIntegrationTests, namesBootTests, namesCodesChatTests) where
+module Bots.StoreService.GroupIntegrationTests (badgeGroupIntegrationTests, namesBootTests, namesCodesChatTests, namesWorkerBootTests) where
 
 import StoreService.Config (BadgeIssuerKey (..), GroupConfig (..))
 import StoreService.Group (GroupAction (..), GroupEvent (..), codeInTracker, ensureManagedGroup)
 import StoreService.Group.Command (maxUses)
+import StoreService.Names.Abi (selector, uint256)
 import StoreService.Names.Codes (issueNameCode, reserveCode, revokeNameCode)
 import StoreService.Names.Phases (RegistrationId (..))
 import StoreService.Names.Store (PrepaidCode (..), getPrepaidCode, spendPrepaidCode)
@@ -21,7 +22,9 @@ import StoreService.Options (StoreServiceOpts (..))
 import StoreService.Service (ServiceState (..), storeService, newServiceState)
 import StoreService.Store (ManagedGroup (..), getManagedGroup)
 import Bots.StoreService.BotTests (badgeBotName, badgeCmdUsage, badgeProfile, badgeTypeOf, credentialOf, entryOf, issueCode, issueRaw, mkStoreServiceOpts, newPurchaseKeys, redeemWithQueue, requestObject, revokeRaw, serviceDbPrefix, shouldAnswerError, statementOf, stopStoreService, testIssuerKeyIdx)
-import Bots.StoreService.ConfigTests (chainSection, namesSection)
+import Bots.StoreService.ConfigTests (chainSection, controllerAddr, namesSection)
+import Bots.StoreService.FakeEthNode (CallAnswer (..), FakeEthNode (..), answerCall, awaitSent, withFakeEthNode)
+import Bots.StoreService.WebTests (digestFixture)
 import Bots.StoreService.NamesSearchTests (aliceHex)
 import Bots.StoreService.NamesStoreTests (order, ownerA, placeCode, placePaid)
 import ChatClient
@@ -175,6 +178,27 @@ testNamesBoot ps = do
     forM_ ["/api/code/check", "/api/name/register"] $ \path -> (path,) <$> codeRequest path `shouldReturn` (path, 429)
     poll t >>= (`shouldSatisfy` isNothing)
 
+namesWorkerBootTests :: SpecWith TestParams
+namesWorkerBootTests = it "starts the workers with the service, sending the commit of an order queued after the start" testWorkerBoot
+
+testWorkerBoot :: HasCallStack => TestParams -> IO ()
+testWorkerBoot ps = withFakeEthNode $ \node@FakeEthNode {fnUrl} -> do
+  svc <- prepareGroupService ps
+  let onFakeNode line = if "rpc_url" `T.isPrefixOf` line then "rpc_url = " <> T.pack fnUrl else line
+      controller = either error id $ strDecode $ encodeUtf8 controllerAddr
+  -- the order's commitment, digestFixture 1, not yet committed
+  forM_ [("minCommitmentAge()", "", 60 :: Int), ("maxCommitmentAge()", "", 86400), ("commitments(bytes32)", digestFixture 1, 0)] $ \(signature, args, value) ->
+    answerCall node controller (selector signature <> args) $ Returns $ uint256 value
+  (t, cc, _, port) <- startGroupService svc {gsIniSections = "" : namesSection <> map onFakeNode chainSection} Nothing
+  flip finally (stopGroupService t cc) $ do
+    pollUntilTrue (listening port)
+    let st = chatStore cc
+    code <- issueNameRaw cc "name 8"
+    row <- fromMaybe (error "no prepaid code row") <$> withTransaction st (`getPrepaidCode` namePrepaidCodeHash code)
+    placeCode st "r1" ownerA (order "alicebakery" 1) row `shouldReturn` Right ()
+    timeout waitLimit (awaitSent node 1) >>= (`shouldSatisfy` isJust)
+    poll t >>= (`shouldSatisfy` isNothing)
+
 namesCodesChatTests :: SpecWith TestParams
 namesCodesChatTests = describe "StoreService names: prepaid codes" $ do
   it "issues prepaid codes on /issue name and /bulk name, answering the usage to years below 2" testGroupNameCodes

tests/Test.hs

@@ -152,6 +152,7 @@ main = do
             storeServiceTests
             describe "managed group" badgeGroupIntegrationTests
           describe "StoreService names: boot" namesBootTests
+          describe "StoreService names: worker" namesWorkerBootTests
           namesCodesChatTests
           namesProfilesChatTests
           describe "Remote session" remoteTests