store: revoke a prepaid code in the code's turn

apps/simplex-store-service/src/StoreService/Names/Codes.hs

@@ -106,7 +106,7 @@ reserveCode turns st now codeHash rid len write =
         | pcReservedBy == Just rid -> Right <$> write db
         | otherwise ->
             reservePrepaidCode db pcId rid now >>= \case
-              -- Only a change outside the code's turn, such as an operator's revoke, can refuse it here.
+              -- Only a writer outside this process, which takes no turn here, can refuse it.
               False -> Left . maybe CRInvalid (fromMaybe CRReserved . codeRefusal now rid len) <$> getPrepaidCode db codeHash
               True ->
                 write db >>= \case
@@ -139,10 +139,9 @@ issueNameCode cc len years paymentStatus = do
     Left e -> Left e
 
 -- | Left is a refusal or a failure; both sides are the text to show the operator.
-revokeNameCode :: ChatController -> NamePrepaidCode -> IO (Either Text Text)
-revokeNameCode cc code = do
+revokeNameCode :: Turns -> ChatController -> NamePrepaidCode -> IO (Either Text Text)
+revokeNameCode turns cc code = withCodeTurn turns codeHash $ do
   now <- getCurrentTime
-  let codeHash = namePrepaidCodeHash code
   withDB' "revokeNameCode" cc (\db -> (,) <$> revokePrepaidCode db codeHash now <*> getPrepaidCode db codeHash) <&> \case
     Right (Revoked _, Just PrepaidCode {pcReservedBy = Just _}) -> Right "Revoked. The order holding it keeps it."
     Right (Revoked _, _) -> Right "Revoked."
@@ -150,3 +149,5 @@ revokeNameCode cc code = do
     Right (AlreadyRedeemed, _) -> Left "Already used. It cannot be revoked."
     Right (NoSuchCode, _) -> Left "No such code."
     Left _ -> Left "The code could not be revoked."
+  where
+    codeHash = namePrepaidCodeHash code

apps/simplex-store-service/src/StoreService/Names/Env.hs

@@ -12,7 +12,7 @@ import StoreService.Names.Contracts (Contracts, newContracts)
 import StoreService.Names.Phases (Phases, newPhases)
 import StoreService.Names.Profiles (Profiles, chatProfile, defaultProfileLimits, monotonicSeconds, newProfiles, systemResolver)
 import StoreService.Names.Sender (Sender, newSender)
-import StoreService.Names.Turns (Turns, newTurns)
+import StoreService.Names.Turns (Turns)
 
 data NamesEnv = NamesEnv
   { neChat :: ChatController,
@@ -27,10 +27,9 @@ data NamesEnv = NamesEnv
     neSender :: Sender
   }
 
-newNamesEnv :: ChatController -> UserId -> NamesConfig -> DBStore -> IO NamesEnv
-newNamesEnv neChat@ChatController {random} neUserId neConfig@NamesConfig {nTLD, nChain} neStore = do
+newNamesEnv :: ChatController -> UserId -> NamesConfig -> DBStore -> Turns -> IO NamesEnv
+newNamesEnv neChat@ChatController {random} neUserId neConfig@NamesConfig {nTLD, nChain} neStore neTurns = do
   nePhases <- newPhases
-  neTurns <- newTurns
   neChain <- newChainClient random nChain
   neContracts <- newContracts nTLD neChain
   neProfiles <- newProfiles defaultProfileLimits monotonicSeconds (chatProfile neChat neUserId) systemResolver

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

@@ -26,6 +26,7 @@ import StoreService.Group.Command (badgeTypeP, codeP, maxMonths, maxNameYears, n
 import StoreService.Names.Codes (issueNameCode, revokeNameCode)
 import StoreService.Names.Env (NamesEnv (..), newNamesEnv)
 import StoreService.Names.Sender (runSender)
+import StoreService.Names.Turns (Turns, newTurns)
 import StoreService.Options
 import StoreService.Poller (newPollerEnv, newReadHints, runPoller)
 import StoreService.Providers.BTCPay (btcpayProvider)
@@ -129,6 +130,8 @@ storeService opts@StoreServiceOpts {serviceConfigFile} cfg env = do
   serviceCfg <- traverse readConfigOrExit serviceConfigFile
   key <- requireIssuerKey opts serviceCfg cfg
   waiters <- newWaiters
+  -- The hooks' //revoke takes a prepaid code's turn, so the turns exist before the chat starts.
+  turns <- newTurns
   let groupCfg = serviceCfg >>= \ServiceConfig {group} -> group
       trackerQ_ = groupEventQ env <$ groupCfg
       readEvents cc =
@@ -140,7 +143,7 @@ storeService opts@StoreServiceOpts {serviceConfigFile} cfg env = do
               | isJust groupCfg -> forM_ (groupEvent ev) $ atomically . writeTQueue (groupEventQ env)
             _ -> pure ()
       startLanes cc = do
-        lanes <- maybe (pure []) (serviceLanes waiters cc) serviceCfg
+        lanes <- maybe (pure []) (serviceLanes waiters turns cc) serviceCfg
         -- The group is resolved before the other lanes start, so a failed lookup exits at once rather than waiting for them to end.
         groupLane_ <- forM groupCfg $ \gc -> runGroupLane cc (groupEventQ env) <$> ensureManagedGroup cc gc
         raceAny_ $ processQueuedRequests key trackerQ_ env : maybeToList groupLane_ <> lanes
@@ -148,32 +151,32 @@ storeService opts@StoreServiceOpts {serviceConfigFile} cfg env = do
         defaultChatHooks
           { preStartHook = Just $ badgePreStartHook opts,
             postStartHook = Just $ badgePostStartHook opts env,
-            preCmdHook = Just badgeCmdHook
+            preCmdHook = Just $ badgeCmdHook turns
           }
   -- The reader runs from the start and must not block, since outputQ carries every chat event and a full queue stalls the core.
   simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc -> raceAny_ [readEvents cc, startLanes cc]
   where
-    serviceLanes :: Waiters -> ChatController -> ServiceConfig -> IO [IO ()]
-    serviceLanes ws cc@ChatController {chatStore} sc = do
+    serviceLanes :: Waiters -> Turns -> ChatController -> ServiceConfig -> IO [IO ()]
+    serviceLanes ws turns cc@ChatController {chatStore} sc = do
       -- Seed before the listener accepts anything, since every checkout is priced from these.
       seedServiceCatalog chatStore
       btc <- maybe (pure []) (fmap (: []) . btcpayProvider) (btcpay sc)
       str <- maybe (pure []) (fmap (: []) . stripeProvider) (stripe sc)
       let providers = btc <> str
       hints <- newReadHints
-      namesEnv <- forM (names sc) (startNames cc)
+      namesEnv <- forM (names sc) (startNames cc turns)
       webEnv <- newWebEnv chatStore sc ws hints providers namesEnv
       exportWebapp (listener sc) (stripe sc)
       pollerEnv <- newPollerEnv chatStore ws hints providers (poll sc)
       pure $ [runWebListener webEnv, runPoller pollerEnv] <> maybe [] (\ne -> [runSender (neSender ne)]) namesEnv
 
-startNames :: ChatController -> NamesConfig -> IO NamesEnv
-startNames cc@ChatController {chatStore} nc@NamesConfig {nTLD, nChain = ChainConfig {cChainId}} =
+startNames :: ChatController -> Turns -> NamesConfig -> IO NamesEnv
+startNames cc@ChatController {chatStore} turns nc@NamesConfig {nTLD, nChain = ChainConfig {cChainId}} =
   readTVarIO (currentUser cc) >>= \case
     Nothing -> putStrLn "No current user" >> exitFailure
     Just User {userId} -> do
       logInfo $ "names: on, TLD " <> safeDecodeUtf8 (strEncode nTLD) <> ", chain " <> tshow cChainId
-      newNamesEnv cc userId nc chatStore
+      newNamesEnv cc userId nc chatStore turns
 
 seedServiceCatalog :: DBStore -> IO ()
 seedServiceCatalog st = do
@@ -189,6 +192,8 @@ storeServiceCLI opts@StoreServiceOpts {serviceConfigFile} = do
   serviceCfg <- traverse readConfigOrExit serviceConfigFile
   key <- requireIssuerKey opts serviceCfg terminalChatConfig
   env <- newServiceState
+  -- This mode runs no names lanes, so only its own //revoke takes these turns.
+  turns <- newTurns
   let eventHook _cc ev = do
         case ev of
           Right (CEvtServiceRequest u reqId sigKey reqData) ->
@@ -199,7 +204,7 @@ storeServiceCLI opts@StoreServiceOpts {serviceConfigFile} = do
         defaultChatHooks
           { preStartHook = Just $ badgePreStartHook opts,
             postStartHook = Just $ badgePostStartHook opts env,
-            preCmdHook = Just badgeCmdHook,
+            preCmdHook = Just $ badgeCmdHook turns,
             eventHook = Just eventHook
           }
   raceAny_
@@ -207,19 +212,19 @@ storeServiceCLI opts@StoreServiceOpts {serviceConfigFile} = do
       processQueuedRequests key Nothing env
     ]
 
-badgeCmdHook :: ChatController -> ChatCommand -> IO (Either (Either ChatError ChatResponse) ChatCommand)
-badgeCmdHook cc = \case
-  CustomChatCommand cmd -> Left <$> runBadgeCmd cc cmd
+badgeCmdHook :: Turns -> ChatController -> ChatCommand -> IO (Either (Either ChatError ChatResponse) ChatCommand)
+badgeCmdHook turns cc = \case
+  CustomChatCommand cmd -> Left <$> runBadgeCmd turns cc cmd
   cmd -> pure $ Right cmd
 
-runBadgeCmd :: ChatController -> ByteString -> IO (Either ChatError ChatResponse)
-runBadgeCmd cc cmd
+runBadgeCmd :: Turns -> ChatController -> ByteString -> IO (Either ChatError ChatResponse)
+runBadgeCmd turns cc cmd
   | Right issueOpts <- A.parseOnly issueCmdP cmd =
       issuedReply formatBadgeCode <$> issueBadgeCode cc issueOpts
   | Right (len, years, paymentStatus) <- A.parseOnly issueNameCmdP cmd =
       issuedReply (formatNameCode . NCPrepaid) <$> issueNameCode cc len years paymentStatus
   | Right code <- A.parseOnly revokeCmdP cmd = revokedReply <$> revokeWithTracker cc code
-  | Right code <- A.parseOnly revokeNameCmdP cmd = revokedReply <$> revokeNameCode cc code
+  | Right code <- A.parseOnly revokeNameCmdP cmd = revokedReply <$> revokeNameCode turns cc code
   | otherwise =
       pure $ chatCmdError $
         "Usage: //issue supporter|legend|investor [months 1-" <> show maxMonths <> "] [paid|unpaid|free], //issue name <length "

tests/Bots/StoreService/GroupIntegrationTests.hs

@@ -13,19 +13,22 @@ module Bots.StoreService.GroupIntegrationTests (badgeGroupIntegrationTests, name
 import StoreService.Config (BadgeIssuerKey (..), GroupConfig (..))
 import StoreService.Group (GroupAction (..), GroupEvent (..), codeInTracker, ensureManagedGroup)
 import StoreService.Group.Command (maxUses)
+import StoreService.Names.Codes (reserveCode, revokeNameCode)
 import StoreService.Names.Phases (RegistrationId (..))
 import StoreService.Names.Store (PrepaidCode (..), getPrepaidCode, spendPrepaidCode)
+import StoreService.Names.Turns (newTurns, withCodeTurn)
 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.NamesStoreTests (order, ownerA, placeCode)
+import Bots.StoreService.NamesStoreTests (order, ownerA, placeCode, placePaid)
 import ChatClient
 import ChatTests.DBUtils
 import ChatTests.Utils
 import Control.Concurrent (threadDelay)
-import Control.Concurrent.Async (Async, async, cancel, poll, waitCatchSTM)
+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
+import Control.Concurrent.Async (Async, async, cancel, poll, wait, waitCatchSTM)
 import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, orElse, readTMVar, readTQueue, readTVarIO, tryReadTMVar, writeTQueue)
 import Control.Exception (IOException, bracket, catch, finally, throwIO, try)
 import Control.Monad (forM_, guard, mfilter, replicateM_, unless, void, when)
@@ -147,6 +150,7 @@ 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
   it "issues prepaid codes on //issue name, checks them through the names router and revokes them on //revoke" testOperatorNameCodes
+  it "revokes a prepaid code in the code's turn, after a reservation holding it" testRevokeTakesCodeTurn
 
 testGroupNameCodes :: HasCallStack => TestParams -> IO ()
 testGroupNameCodes ps =
@@ -198,6 +202,48 @@ testOperatorNameCodes ps = do
     revoke spent `shouldReturn` Left "Already used. It cannot be revoked."
     check spent `shouldReturn` coverage 8 2 "used"
 
+testRevokeTakesCodeTurn :: HasCallStack => TestParams -> IO ()
+testRevokeTakesCodeTurn ps = do
+  svc <- prepareGroupService ps
+  (t, cc, _, port) <- startGroupService svc {gsIniSections = "" : namesSection <> chainSection} Nothing
+  flip finally (stopGroupService t cc) $ do
+    pollUntilTrue (listening port)
+    turns <- newTurns
+    let st = chatStore cc
+        revokeAfter code release = do
+          revoking <- async $ revokeNameCode turns cc code
+          threadDelay 200000
+          poll revoking >>= (`shouldSatisfy` isNothing)
+          release
+          finished revoking
+    held <- issueNameRaw cc "name 8"
+    holder <- holdTurn $ \body -> withCodeTurn turns (namePrepaidCodeHash held) body
+    revokeAfter held (releaseTurn holder) `shouldReturn` Right "Revoked."
+    finished (thAction holder) `shouldReturn` ()
+    now <- getCurrentTime
+    placePaid st "r1" ownerA (order "alicebakery" 1) (addUTCTime 3600 now) `shouldReturn` Right ()
+    reserved <- issueNameRaw cc "name 8"
+    reserving <- holdTurn $ \body -> reserveCode turns st now (namePrepaidCodeHash reserved) (RegistrationId "r1") 8 (\_ -> Right <$> body :: IO (Either Text ()))
+    revokeAfter reserved (releaseTurn reserving) `shouldReturn` Right "Revoked. The order holding it keeps it."
+    finished (thAction reserving) `shouldReturn` Right (Right ())
+
+data TurnHolder a = TurnHolder {thAction :: Async a, thRelease :: MVar ()}
+
+-- | Runs the action until its body is inside the turn, where the body waits for the release.
+holdTurn :: (IO () -> IO a) -> IO (TurnHolder a)
+holdTurn inTurn = do
+  entered <- newEmptyMVar
+  thRelease <- newEmptyMVar
+  thAction <- async $ inTurn $ putMVar entered () >> takeMVar thRelease
+  takeMVar entered
+  pure TurnHolder {thAction, thRelease}
+
+releaseTurn :: TurnHolder a -> IO ()
+releaseTurn TurnHolder {thRelease} = putMVar thRelease ()
+
+finished :: Async a -> IO a
+finished a = timeout 5000000 (wait a) >>= maybe (fail "did not finish") pure
+
 issueNameRaw :: HasCallStack => ChatController -> String -> IO NamePrepaidCode
 issueNameRaw cc args =
   sendChatCmdStr cc ("//issue " <> args) >>= \case