store: reserve a code after the registration's write

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))

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