store: cancel the invoice of an order not written

apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs

@@ -5,8 +5,10 @@
 module StoreService.Web.Names.Orders (nameInvoiceHandler, nameInvoiceView, orderRefusalResponse, registrationChangedResponse) where
 
 import Control.Concurrent.STM (atomically)
+import qualified Control.Exception as E
 import Control.Monad (forM_, unless)
 import Data.Aeson ((.=))
+import Data.Maybe (isJust)
 import qualified Data.Aeson as J
 import qualified Data.Aeson.KeyMap as KM
 import Data.Text (Text)
@@ -101,7 +103,9 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters
           let invoice = NewNameInvoice {nniInvoiceId = invId, nniProvider = pProvider provider, nniAmount = amount, nniCurrency = catalogCurrency, nniDestination = piDestination, nniExpiresAt = addUTCTime (invoiceWindow cfg ioMethod) now, nniCreatedAt = now}
               registration = NewRegistration {nrgId = rid, nrgOwner = orOwner, nrgOrder = orFields, nrgYears = nYears $ oeConfig env}
               paid = PaidOrder {poMethod = ioMethod, poPrice = fromIntegral ioPrice, poInvoiceId = invId, poProviderRef = piProviderRef}
-          placeOrder env req (\db at -> insertNameInvoice db invoice >> createPaidRegistration db registration paid at) >>= \case
+          placeOrder env req (\db at -> insertNameInvoice db invoice >> createPaidRegistration db registration paid at)
+            `E.catch` strandedBy provider piProviderRef
+            >>= \case
             Left refusal -> do
               logWarn ("POST /api/invoice (name): the order lost to another, so invoice " <> piProviderRef <> " is cancelled at the provider")
               cancelAtProvider provider piProviderRef
@@ -113,6 +117,14 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters
               case (row_, registration_) of
                 (Just row, Just r) -> respondView row r
                 _ -> logError ("POST /api/invoice (name): order " <> invText invId <> " is not readable after its commit") >> respond internalError
+    -- An invoice created at the provider for an order that was not written would stay payable with nothing watching it.
+    strandedBy :: Provider -> Text -> E.SomeException -> IO a
+    strandedBy provider ref e = do
+      unless (isAsync e) $ do
+        logError ("POST /api/invoice (name): the order was not written, so invoice " <> ref <> " is cancelled at the provider: " <> tshow e)
+        cancelAtProvider provider ref
+      E.throwIO e
+    isAsync e = isJust (E.fromException e :: Maybe E.SomeAsyncException)
     cancelAtProvider Provider {pCancelInvoice} ref =
       pCancelInvoice ref >>= \case
         Left (ProviderError e) -> logWarn ("names: cancelling invoice " <> ref <> " at the provider failed: " <> e)

tests/Bots/StoreService/NamesOrdersTests.hs

@@ -79,6 +79,7 @@ namesOrdersTests = describe "StoreService names: orders" $ do
     it "refuses a bad signature, or another signer's" testBadSignature
     it "refuses a stale timestamp on a new order" testStaleTimestamp
     it "lets one of two concurrent orders for one owner and name win" testConcurrentOrders
+    it "cancels the provider invoice and logs it when the order's insert fails" testInsertFailureCancels
     it "checks the duration within the slack, before and after the term start" testDurationSlack
     it "answers catalog_changed with the chain price" testCatalogChanged
     it "answers name_taken for a registered, reserved or being registered name" testNameTaken
@@ -458,6 +459,19 @@ testConcurrentOrders = withOrders $ \ctx -> do
   filter ((== 409) . fst) [a, b] `shouldBe` [refusedWith 409 "order_exists"]
   length <$> registrationsOf ctx ownerA `shouldReturn` 1
 
+-- | The stub gives every invoice one ref, so the second order's insert breaks the unique ref.
+testInsertFailureCancels :: IO ()
+testInsertFailureCancels = withOrdersVia (\p -> p {pCreateInvoice = \m d -> fmap (\i -> i {piProviderRef = "pref-same"}) <$> pCreateInvoice p m d}) $ \ctx -> do
+  void $ placed ctx aliceOrder
+  -- a listener that answers the handler's exception instead of rethrowing it into the test
+  mgr <- newManager defaultManagerSettings
+  logs <- Warp.withApplication (pure $ webApp $ cWeb ctx) $ \port -> do
+    let answering = ctx {cClient = (mgr, "http://127.0.0.1:" <> show port)}
+    capturingStderr $ fst <$> placeOrder answering aliceOrder {oLabel = "dynamis", oPrice = 20000, oCommitment = commitmentOf 2} `shouldReturn` 500
+  logs `shouldSatisfy` T.isInfixOf "invoice pref-same is cancelled at the provider"
+  calls <- stubCalls (cStub ctx)
+  [r | StubCancel r <- calls] `shouldBe` ["pref-same"]
+
 testDurationSlack :: IO ()
 testDurationSlack = withOrders $ \ctx -> do
   let slack = fromIntegral slackSeconds