diff --git a/apps/simplex-store-service/src/StoreService/Names/Codes.hs b/apps/simplex-store-service/src/StoreService/Names/Codes.hs index 5709fc1fc9..5b0d44c03d 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Codes.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Codes.hs @@ -21,6 +21,7 @@ module StoreService.Names.Codes where import Control.Applicative ((<|>)) +import qualified Control.Exception as E import Data.ByteString (ByteString) import Data.Functor ((<&>)) import Data.Int (Int64) @@ -102,24 +103,31 @@ reserveRefusal db now codeHash rid len = maybe CRInvalid (fromMaybe CRReserved . readPrepaidCode :: DBStore -> NamePrepaidCode -> IO (Maybe PrepaidCode) readPrepaidCode st code = withTransaction st (`getPrepaidCode` namePrepaidCodeHash code) --- | In the code's turn and one transaction, the code is checked and reserved for the registration, then --- the write runs. A write that refuses gives the code back. +newtype ReservationRefused = ReservationRefused CodeRefusal + deriving (Show) + +instance E.Exception ReservationRefused + +-- | In the code's turn and one transaction, the code is checked, the write runs, then the code is reserved for the +-- registration, so the registration's row is locked before the code's. A refused reservation rolls the write back. reserveCode :: Turns -> DBStore -> UTCTime -> ByteString -> RegistrationId -> Int -> (DB.Connection -> IO (Either e a)) -> IO (Either CodeRefusal (Either e a)) reserveCode turns st now codeHash rid len write = - withCodeTurn turns codeHash $ withTransaction st $ \db -> - getPrepaidCode db codeHash >>= \case - Nothing -> pure $ Left CRInvalid - Just code@PrepaidCode {pcId, pcReservedBy} - | Just refusal <- codeRefusal now rid len code -> pure $ Left refusal - | pcReservedBy == Just rid -> Right <$> write db - | otherwise -> - reservePrepaidCode db pcId rid now >>= \case - -- Only a writer outside this process, which takes no turn here, can refuse it. - False -> Left <$> reserveRefusal db now codeHash rid len - True -> - write db >>= \case - refused@(Left _) -> Right refused <$ releasePrepaidCode db pcId rid - written -> pure $ Right written + withCodeTurn turns codeHash $ either (\(ReservationRefused refusal) -> Left refusal) id <$> E.try (withTransaction st reserve) + where + reserve db = + getPrepaidCode db codeHash >>= \case + Nothing -> pure $ Left CRInvalid + Just code@PrepaidCode {pcId, pcReservedBy} + | Just refusal <- codeRefusal now rid len code -> pure $ Left refusal + | otherwise -> + write db >>= \case + written@(Right _) + | pcReservedBy /= Just rid -> + reservePrepaidCode db pcId rid now >>= \case + True -> pure $ Right written + -- Only a writer outside this process, which takes no turn here, can refuse it. + False -> E.throwIO . ReservationRefused =<< reserveRefusal db now codeHash rid len + written -> pure $ Right written -- | The write runs first, and the code is released only if it succeeds. False when the registration did not hold the code. releaseCode :: Turns -> DBStore -> Int64 -> RegistrationId -> (DB.Connection -> IO (Either e a)) -> IO (Either e (a, Bool)) diff --git a/tests/Bots/StoreService/NamesCodesTests.hs b/tests/Bots/StoreService/NamesCodesTests.hs index f9cf0f26ba..d04d217464 100644 --- a/tests/Bots/StoreService/NamesCodesTests.hs +++ b/tests/Bots/StoreService/NamesCodesTests.hs @@ -34,7 +34,7 @@ import StoreService.Config (ListenerConfig (..)) import StoreService.Group.Command (CmdAction (..), GroupCmd (..), groupCmdAction) import StoreService.Names.Codes import StoreService.Names.Phases (RegistrationId (..)) -import StoreService.Names.Store (NewPrepaidCode (..), PrepaidCode (..), getPrepaidCode, insertPrepaidCode, revokePrepaidCode, spendPrepaidCode) +import StoreService.Names.Store (NewPrepaidCode (..), PrepaidCode (..), getPrepaidCode, insertPrepaidCode, reservePrepaidCode, revokePrepaidCode, spendPrepaidCode) import StoreService.Names.Turns (Turns, newTurns) import StoreService.Store (RevokeResult (..)) import StoreService.Web.Http (codeLimit, newHttpEnv, notFound) @@ -53,11 +53,12 @@ namesCodesTests = describe "StoreService names: prepaid codes" $ do it "answers bad_request to a body that is not an object with a code text, and 405 to GET" testCheckBadBody it "takes a code token for every check, whatever its outcome" testCheckLimit describe "reservations" $ do - it "reserves an unused code in the transaction of the registration's write" testReserve + it "reserves an unused code after the registration's write, in its transaction" testReserve it "refuses each unusable code with its tag, before the write runs" testReserveRefusals it "keeps a code its registration holds even if revoked or expired since, still checking the length" testReserveHeld it "refuses a spent code to its own registration with code_used, before the write runs" testReserveSpent - it "gives the code back when the write refuses" testReserveWriteRefused + it "reserves nothing when the write refuses" testReserveWriteRefused + it "rolls the write back when the code's reservation is refused after it" testReserveRollsBack it "lets one of two concurrent reservations of a code win, the other answered code_reserved" testConcurrentReserve it "releases and spends a code only after the write, and only for its holder" testReleaseSpend describe "group commands" $ do @@ -238,7 +239,8 @@ testReserve = withOrders $ \turns st -> do code <- newCode 8 PrepaidCode {pcCodeHash} <- issueAs st code usable let holderInWrite db = Right . (pcReservedBy =<<) <$> getPrepaidCode db pcCodeHash :: IO (Either Text (Maybe RegistrationId)) - reserveCode turns st tNow pcCodeHash r1 8 holderInWrite `shouldReturn` Right (Right (Just r1)) + reserveCode turns st tNow pcCodeHash r1 8 holderInWrite `shouldReturn` Right (Right Nothing) + (pcReservedBy =<<) <$> withTransaction st (`getPrepaidCode` pcCodeHash) `shouldReturn` Just r1 reserveCode turns st tNow pcCodeHash r1 11 holderInWrite `shouldReturn` Right (Right (Just r1)) testReserveRefusals :: IO () @@ -307,6 +309,15 @@ testReserveWriteRefused = withOrders $ \turns st -> do reserveCode turns st tNow pcCodeHash r2 8 writeOk `shouldReturn` Right (Right ()) (pcReservedBy =<<) <$> readCode st row `shouldReturn` Just r2 +-- | The write reserves the code for another registration, as a writer outside this process could between the check and the reservation. +testReserveRollsBack :: IO () +testReserveRollsBack = withOrders $ \turns st -> do + code <- newCode 8 + row@PrepaidCode {pcId, pcCodeHash} <- issueAs st code usable + let takenMeanwhile db = Right () <$ reservePrepaidCode db pcId r2 tNow :: IO (Either Text ()) + reserveCode turns st tNow pcCodeHash r1 8 takenMeanwhile `shouldReturn` Left CRReserved + readCode st row `shouldReturn` Just row + testConcurrentReserve :: IO () testConcurrentReserve = withOrders $ \turns st -> do code <- newCode 8