diff --git a/apps/simplex-store-service/src/StoreService/Names/Codes.hs b/apps/simplex-store-service/src/StoreService/Names/Codes.hs index ac424c55bf..8097716c87 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Codes.hs +++ b/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 diff --git a/apps/simplex-store-service/src/StoreService/Names/Env.hs b/apps/simplex-store-service/src/StoreService/Names/Env.hs index db1bbfe52a..75fbc47914 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Env.hs +++ b/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 diff --git a/apps/simplex-store-service/src/StoreService/Service.hs b/apps/simplex-store-service/src/StoreService/Service.hs index 18e8a7bc1f..5db51fea25 100644 --- a/apps/simplex-store-service/src/StoreService/Service.hs +++ b/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 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