store: merge long polls

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

@@ -1,6 +1,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 
-module StoreService.Names.Phases (Phases, RegistrationId (..), newPhases, publish, awaitChange, phasesCount) where
+module StoreService.Names.Phases (Phases, RegistrationId (..), newPhases, publish, awaitChange, phasesCount, phasesWaiting) where
 
 import Control.Concurrent.STM
 import Control.Exception (bracket)
@@ -29,6 +29,10 @@ publish (Phases watches) rid version =
 phasesCount :: Phases -> IO Int
 phasesCount (Phases watches) = Map.size <$> readTVarIO watches
 
+-- | The waiters across all registrations.
+phasesWaiting :: Phases -> STM Int
+phasesWaiting (Phases watches) = readTVar watches >>= fmap sum . mapM (\Watch {wRefs} -> readTVar wRefs) . Map.elems
+
 subscribe :: Phases -> RegistrationId -> STM Watch
 subscribe (Phases watches) rid =
   readTVar watches >>= \ws -> case Map.lookup rid ws of

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 
 module StoreService.Orders
   ( RegistrationChanged (..),
@@ -88,7 +89,7 @@ data Product = PBadge (Maybe ByteString) | PName NameRegistration
 data NameOutcome = NOWritten RegistrationId Int64 | NOLate RegistrationId
 
 settleOrder :: DBStore -> Waiters -> Maybe Phases -> InvoiceId -> PaymentSignal -> UTCTime -> IO (Either Text InvoiceStatus)
-settleOrder st waiters phases invId@(InvoiceId invText) signal now' = do
+settleOrder st waiters phases invId signal now' = do
   outcome <- withTransaction st $ \db ->
     settlementInvoice db invId >>= \case
       Just InvoiceRow {irStatus}
@@ -111,7 +112,7 @@ settleOrder st waiters phases invId@(InvoiceId invText) signal now' = do
           NOWritten rid v -> publishRegistration phases (rid, v)
           NOLate _ -> pure ()
       forM_ name $ \case
-        NOLate (RegistrationId rid) -> logError ("names: invoice " <> invText <> " was paid after its order closed, so registration " <> rid <> " stays unpaid; refund the payment")
+        NOLate rid -> latePayment invId rid
         NOWritten {} -> pure ()
       pure (Right status)
   where
@@ -199,14 +200,30 @@ closeInvoiceOrder db invId now =
     Just InvoiceRow {irProduct = IPName rid} -> getRegistration db rid >>= maybe (pure Nothing) (\r -> closeOrder db r now)
     _ -> pure Nothing
 
+latePayment :: InvoiceId -> RegistrationId -> IO ()
+latePayment (InvoiceId invText) (RegistrationId rid) =
+  logError ("names: invoice " <> invText <> " was paid after its order closed, so registration " <> rid <> " stays unpaid; refund the payment")
+
 -- | False when the invoice was no longer open. Throws RegistrationChanged, changing nothing, when its order changed meanwhile.
+-- The provider has taken the cancel, so a name invoice a payment landed on meanwhile expires too, and its payment is late.
 cancelOpenInvoice :: DBStore -> Waiters -> Maybe Phases -> InvoiceId -> UTCTime -> IO Bool
 cancelOpenInvoice st waiters phases invId now = do
   closed <- withTransaction st $ \db -> do
-    cancelled <- updateInvoiceStatus db invId ISOpen ISExpired now
-    if cancelled then Just <$> closeInvoiceOrder db invId now else pure Nothing
-  forM_ closed $ \order -> atomically $ publish waiters invId ISExpired >> mapM_ (publishRegistration phases) order
+    -- On Postgres, a settlement holding the row is waited for, and the read below sees its payment.
+    lockInvoice db invId now
+    settlementInvoice db invId >>= \case
+      Just row@InvoiceRow {irStatus = ISOpen} -> do
+        cancelled <- updateInvoiceStatus db invId ISOpen ISExpired now
+        if cancelled then Just . (,lateOf row) <$> closeInvoiceOrder db invId now else pure Nothing
+      _ -> pure Nothing
+  forM_ closed $ \(order, late) -> do
+    atomically $ publish waiters invId ISExpired >> mapM_ (publishRegistration phases) order
+    mapM_ (latePayment invId) late
   pure (isJust closed)
+  where
+    lateOf InvoiceRow {irProduct, irPayment} = case irProduct of
+      IPName rid | maybe False paymentHolds irPayment -> Just rid
+      _ -> Nothing
 
 -- | Of the given invoices, expires those still open, with no money received, and past the cutoff, closing their orders.
 -- Each in its own transaction, so an invoice that fails is logged and skipped, and the others still expire.

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

@@ -9,10 +9,11 @@ import Network.HTTP.Types (Method)
 import Network.Wai (Request, ResponseReceived, pathInfo)
 import StoreService.Names.Env (NamesEnv (..))
 import StoreService.Names.Orders (ordersEnv)
-import StoreService.Web.Http (HttpEnv, Limit, Respond, codeLimit, limited, only, previewLimit, recordsLimit, searchLimit)
+import StoreService.Web.Http (HttpEnv, Limit, Respond, codeLimit, holdMicros, limited, only, previewLimit, readLimit, recordsLimit, searchLimit)
 import StoreService.Web.Names.Codes (codeCheckHandler)
 import StoreService.Web.Names.Orders (codeOrderHandler)
 import StoreService.Web.Names.Records (recordsHandler)
+import StoreService.Web.Names.Registration (registrationHandler)
 import StoreService.Web.Names.Search (previewHandler, searchHandler)
 
 data Route = Route
@@ -29,6 +30,7 @@ namesRoutes env@NamesEnv {neConfig, neStore, neContracts, neProfiles, neRecords,
   ["api", "link", "preview"] -> Just Route {rMethod = "POST", rLimit = previewLimit, rHandler = previewHandler neProfiles}
   -- below every fixed /api/name/<word> route, which it would otherwise match
   ["api", "name", hash] -> Just Route {rMethod = "GET", rLimit = searchLimit, rHandler = searchHandler neConfig neStore neContracts neProfiles hash}
+  ["api", "registration", rid] -> Just Route {rMethod = "GET", rLimit = readLimit, rHandler = registrationHandler (ordersEnv env) holdMicros rid}
   _ -> Nothing
 
 -- | Nothing for a path no route knows. The limit is taken only once the route and the method match.

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

@@ -0,0 +1,80 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module StoreService.Web.Names.Registration
+  ( registrationHandler,
+    registrationAt,
+    registrationVersion,
+    lapseMoment,
+    heldFor,
+    versionParam,
+  )
+where
+
+import Control.Monad (join)
+import qualified Data.ByteString.Char8 as B
+import Data.Char (isDigit)
+import Data.Int (Int64)
+import Data.Maybe (maybeToList)
+import Data.Text (Text)
+import Data.Time.Clock (UTCTime, diffUTCTime)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
+import Network.HTTP.Types (status200)
+import Network.Wai (Request, ResponseReceived, queryString)
+import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
+import StoreService.Names.Orders (OrdersEnv (..))
+import StoreService.Names.Phases (RegistrationId (..), awaitChange)
+import StoreService.Names.Store (NamePhase (..), NameRegistration (..), getRegistration)
+import StoreService.Names.View (registrationView)
+import StoreService.Web.Http (Respond, jsonResponse, notFound)
+import Text.Read (readMaybe)
+
+-- | GET /api/registration/:id, held while its version is seenVersion.
+registrationHandler :: OrdersEnv -> Int -> Text -> Request -> Respond -> IO ResponseReceived
+registrationHandler OrdersEnv {oeStore, oeConfig, oeContracts, oePhases, oeNow} hold ridText req respond =
+  readNow >>= \case
+    Nothing -> respond notFound
+    Just (now, r@NameRegistration {nrVersion})
+      | versionParam req == Just nrVersion -> do
+          _ <- awaitChange oePhases rid (registrationVersion oeStore rid) nrVersion (heldFor hold now $ maybeToList $ lapseMoment r)
+          readNow >>= maybe (respond notFound) answer
+      | otherwise -> answer (now, r)
+  where
+    rid = RegistrationId ridText
+    readNow = oeNow >>= \now -> fmap (now,) <$> withTransaction oeStore (`getRegistration` rid)
+    answer (now, r) = respond . jsonResponse status200 =<< registrationView oeStore oeConfig oeContracts (registrationAt now r)
+
+-- | Versions start at 1, so a registration deleted during a hold reads as changed.
+registrationVersion :: DBStore -> RegistrationId -> IO Int64
+registrationVersion st rid = maybe 0 nrVersion <$> withTransaction st (`getRegistration` rid)
+
+notSignedInTime :: Text
+notSignedInTime = "The name was not signed in time"
+
+-- | Past revealBefore with no reveal, the commitment can no longer register, so it reads failed.
+registrationAt :: UTCTime -> NameRegistration -> NameRegistration
+registrationAt now r = case lapseMoment r of
+  Just lapse | now > lapse -> r {nrPhase = PFailed, nrError = Just notSignedInTime}
+  _ -> r
+
+lapseMoment :: NameRegistration -> Maybe UTCTime
+lapseMoment = \case
+  NameRegistration {nrPhase = PCommitted, nrReveal = Nothing, nrRevealBefore = Just before} -> Just $ posixSecondsToUTCTime $ fromIntegral before
+  _ -> Nothing
+
+-- | The hold, cut to end just past the next moment at which the answer changes with time alone.
+heldFor :: Int -> UTCTime -> [UTCTime] -> Int
+heldFor hold now moments = fromInteger $ minimum $ toInteger hold : [ceiling (diffUTCTime moment now * microsPerSecond) + 1 | moment <- moments, moment >= now]
+  where
+    microsPerSecond = 1000000
+
+-- | Nothing unless seenVersion is a decimal version, so any other value answers at once.
+versionParam :: Request -> Maybe Int64
+versionParam req = case join $ lookup "seenVersion" $ queryString req of
+  Just s | not (B.null s) && B.all isDigit s -> readMaybe (B.unpack s) >>= inRange
+  _ -> Nothing
+  where
+    inRange :: Integer -> Maybe Int64
+    inRange v = if v <= toInteger (maxBound :: Int64) then Just (fromInteger v) else Nothing

apps/simplex-store-service/src/StoreService/Web/Server.hs

@@ -18,7 +18,8 @@ import StoreService.Catalog (PricedOffer (..), priceOffer)
 import StoreService.Config (ListenerConfig (..), ServiceConfig (..), StripeConfig (..))
 import StoreService.Names.Env (NamesEnv)
 import StoreService.Names.Orders (OrdersEnv (..), ordersEnv)
-import StoreService.Names.Store (getRegistration, textMethod)
+import StoreService.Names.Phases (RegistrationId, awaitChange)
+import StoreService.Names.Store (NamePhase (..), NameRegistration (..), getRegistration, textMethod)
 import StoreService.Orders (RegistrationChanged (..), cancelOpenInvoice)
 import StoreService.Poller (ReadHints, queueReadHint)
 import StoreService.Providers (OrderDraft (..), Provider (..), ProviderError (..), ProviderInvoice (..), WebhookError (..))
@@ -27,9 +28,11 @@ import StoreService.Waiters (Seen, Waiters, awaitStatus)
 import StoreService.Web.Http
 import StoreService.Web.Names (namesApp, namesRoutes)
 import StoreService.Web.Names.Orders (nameInvoiceHandler, nameInvoiceView, registrationChangedResponse)
+import StoreService.Web.Names.Registration (heldFor, lapseMoment, registrationAt, registrationVersion, versionParam)
+import Control.Concurrent.Async (race)
 import qualified Control.Exception as E
 import StoreService.Log (logError, logInfo, logWarn)
-import Control.Monad (forM_, when)
+import Control.Monad (forM_, void, when)
 import Data.Aeson ((.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.KeyMap as KM
@@ -38,7 +41,7 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LB
 import Data.Char (toLower)
 import Data.List (isPrefixOf)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (catMaybes, fromMaybe)
 import Data.String (fromString)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -221,38 +224,91 @@ readInvoiceHandler :: WebEnv -> InvoiceId -> Request -> Respond -> IO ResponseRe
 readInvoiceHandler env@WebEnv {weStore} invId req respond =
   getInvoice weStore invId >>= \case
     Nothing -> respond notFound
+    Just row@InvoiceRow {irProduct = IPName rid} | Just orders <- weOrders env -> readNameInvoice env orders row rid req respond
     Just row -> case holdFor row of
       Nothing -> respondInvoice env row respond
       Just seen -> do
         -- Settlement publishes after it commits, so the row read below is at least as new as whatever woke us.
-        _ <- awaitStatus (weWaiters env) invId readSeen seen (weHoldMicros env)
-        getInvoice weStore invId >>= maybe (respond notFound) (\row' -> respondInvoice env row' respond)
+        _ <- awaitStatus (weWaiters env) invId (readSeen env invId (pure id)) seen (weHoldMicros env)
+        respondCurrent env invId respond
   where
     holdFor :: InvoiceRow -> Maybe Seen
     holdFor row@InvoiceRow {irStatus} = case waitParam req of
-      Just seen | seen == irStatus, seen /= ISPaid, samePayment -> Just (irStatus, paymentMark row)
+      Just seen | seen == irStatus, seen /= ISPaid, samePayment req row -> Just (seenOf row)
       _ -> Nothing
-      where
-        -- The counter a hold watches starts at zero, so a payment recorded before this request arrived cannot wake it.
-        samePayment = case paidParam req of
-          Nothing -> True
-          Just seen -> seen == paymentMark row
-    readSeen :: IO Seen
-    readSeen = maybe (ISOpen, ("", False)) (\row -> (irStatus row, paymentMark row)) <$> getInvoice weStore invId
+
+-- | A name invoice also holds while its registration's version is seenVersion, a paid one on that alone,
+-- except one paid after its order closed, which has nothing more to wait for.
+readNameInvoice :: WebEnv -> OrdersEnv -> InvoiceRow -> RegistrationId -> Request -> Respond -> IO ResponseReceived
+readNameInvoice env@WebEnv {weConfig, weWaiters, weHoldMicros} orders@OrdersEnv {oeStore, oeNow, oePhases} stored@InvoiceRow {irInvoiceId = invId} rid req respond =
+  readName orders stored rid >>= \case
+    Nothing -> respond notFound
+    Just (now, row, r) -> case waitParam req of
+      Just wait | holds wait row r -> hold now row r >> respondCurrent env invId respond
+      _ -> respond . jsonResponse status200 =<< nameInvoiceView orders (confirmationsFor weConfig) row r
+  where
+    seenVersion = versionParam req
+    holds wait row@InvoiceRow {irStatus} NameRegistration {nrPhase, nrVersion} =
+      wait == irStatus
+        && not (irStatus == ISPaid && nrPhase == PUnpaid)
+        && samePayment req row
+        && maybe (irStatus /= ISPaid) (== nrVersion) seenVersion
+    hold now row r = do
+      let micros = heldFor weHoldMicros now $ catMaybes [expiryMoment row, lapseMoment r]
+          onStatus = awaitStatus weWaiters invId (readSeen env invId (invoiceAt <$> oeNow)) (seenOf row) micros
+          onVersion v = awaitChange oePhases rid (registrationVersion oeStore rid) v micros
+      case (irStatus row, seenVersion) of
+        (ISPaid, Just v) -> void $ onVersion v
+        (_, Just v) -> void $ race onStatus (onVersion v)
+        (_, Nothing) -> void onStatus
+
+-- | The invoice and its registration as a read now shows them.
+readName :: OrdersEnv -> InvoiceRow -> RegistrationId -> IO (Maybe (UTCTime, InvoiceRow, NameRegistration))
+readName OrdersEnv {oeStore, oeNow} row rid = do
+  now <- oeNow
+  fmap (\r -> (now, invoiceAt now row, registrationAt now r)) <$> withTransaction oeStore (`getRegistration` rid)
+
+-- | An open name invoice past its expiry with no money received reads expired before the sweep marks it.
+invoiceAt :: UTCTime -> InvoiceRow -> InvoiceRow
+invoiceAt now row = case expiryMoment row of
+  Just expiry | now > expiry -> row {irStatus = ISExpired}
+  _ -> row
+
+-- | A funded open invoice stays open until it settles.
+expiryMoment :: InvoiceRow -> Maybe UTCTime
+expiryMoment InvoiceRow {irStatus, irExpiresAt, irPayment}
+  | irStatus == ISOpen && not (maybe False paymentHolds irPayment) = Just irExpiresAt
+  | otherwise = Nothing
+
+-- | The counter a hold watches starts at zero, so a payment recorded before this request arrived cannot wake it.
+samePayment :: Request -> InvoiceRow -> Bool
+samePayment req row = maybe True (== paymentMark row) (paidParam req)
+
+seenOf :: InvoiceRow -> Seen
+seenOf row@InvoiceRow {irStatus} = (irStatus, paymentMark row)
+
+-- | What a hold compares, read as the answer would show it.
+readSeen :: WebEnv -> InvoiceId -> IO (InvoiceRow -> InvoiceRow) -> IO Seen
+readSeen WebEnv {weStore} invId reading = do
+  readAs <- reading
+  maybe (ISOpen, ("", False)) (seenOf . readAs) <$> getInvoice weStore invId
+
+respondCurrent :: WebEnv -> InvoiceId -> Respond -> IO ResponseReceived
+respondCurrent env@WebEnv {weStore} invId respond = getInvoice weStore invId >>= maybe (respond notFound) (\row -> respondInvoice env row respond)
 
 respondInvoice :: WebEnv -> InvoiceRow -> Respond -> IO ResponseReceived
 respondInvoice env row respond = invoiceViewOf env row >>= respond . either id (jsonResponse status200)
 
 -- | A badge's view, or a name's with its registration.
 invoiceViewOf :: WebEnv -> InvoiceRow -> IO (Either Response J.Value)
-invoiceViewOf env@WebEnv {weConfig, weStore} row@InvoiceRow {irInvoiceId = InvoiceId invId, irProduct} = case irProduct of
+invoiceViewOf env@WebEnv {weConfig} row@InvoiceRow {irInvoiceId = InvoiceId invId, irProduct} = case irProduct of
   IPBadge badgeType months -> pure $ Right $ badgeInvoiceView (confirmationsFor weConfig) badgeType months row
   IPName rid -> case weOrders env of
     Nothing -> Left providerUnavailable <$ namesOff invId
     Just orders ->
-      withTransaction weStore (`getRegistration` rid) >>= \case
+      readName orders row rid >>= \case
         Nothing -> pure $ Left notFound
-        Just r -> Right <$> nameInvoiceView orders (confirmationsFor weConfig) row r
+        Just (_, row', r) -> Right <$> nameInvoiceView orders (confirmationsFor weConfig) row' r
 
 namesOff :: Text -> IO ()
 namesOff invId = logError ("invoice " <> invId <> " is a name's, and this service sells no names")
@@ -285,7 +341,7 @@ cancelInvoiceHandler env@WebEnv {weStore, weProviders} invId@(InvoiceId invText)
       now <- getCurrentTime
       E.try (cancelOpenInvoice weStore (weWaiters env) (oePhases <$> weOrders env) invId now) >>= \case
         Left (RegistrationChanged rid) -> maybe (pure providerUnavailable) (`registrationChangedResponse` rid) (weOrders env) >>= respond
-        Right _ -> getInvoice weStore invId >>= maybe (respond notFound) (\row' -> respondInvoice env row' respond)
+        Right _ -> respondCurrent env invId respond
 
 paidParam :: Request -> Maybe (Text, Bool)
 paidParam req = case lookup "seenPaid" (queryString req) of

simplex-chat.cabal

@@ -476,6 +476,7 @@ executable simplex-store-service
       StoreService.Web.Names.Codes
       StoreService.Web.Names.Orders
       StoreService.Web.Names.Records
+      StoreService.Web.Names.Registration
       StoreService.Web.Names.Search
       StoreService.Web.Server
       Paths_simplex_chat
@@ -769,6 +770,7 @@ test-suite simplex-chat-test
       Bots.StoreService.NamesLabelTests
       Bots.StoreService.NamesLinksTests
       Bots.StoreService.NamesOrdersTests
+      Bots.StoreService.NamesPhasesTests
       Bots.StoreService.NamesProfilesTests
       Bots.StoreService.NamesRecordsTests
       Bots.StoreService.NamesSearchTests
@@ -831,6 +833,7 @@ test-suite simplex-chat-test
       StoreService.Web.Names.Codes
       StoreService.Web.Names.Orders
       StoreService.Web.Names.Records
+      StoreService.Web.Names.Registration
       StoreService.Web.Names.Search
       StoreService.Web.Server
       Paths_simplex_chat

tests/Bots/StoreService/NamesOrdersTests.hs

@@ -2,7 +2,23 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Bots.StoreService.NamesOrdersTests (namesOrdersTests) where
+module Bots.StoreService.NamesOrdersTests
+  ( namesOrdersTests,
+    Ctx (..),
+    Order (..),
+    withOrders,
+    withOrdersCancelling,
+    aliceOrder,
+    commitmentOf,
+    orderTime,
+    placed,
+    post,
+    settleNow,
+    settled,
+    invoiceRegistration,
+    registrationOf,
+  )
+where
 
 import Bots.StoreService.FakeBTCPay (FakeBTCPay (..), setInvoiceState, withFakeBTCPay)
 import Bots.StoreService.FakeEthNode
@@ -123,6 +139,7 @@ namesOrdersTests = describe "StoreService names: orders" $ do
     it "alerts on a late payment as BTCPay reports it for an expired, cancelled or swept invoice, once" testLateBTCPayPayments
     it "alerts once on money read while open when the provider then closes the invoice, also after a restart" testOneLateAlert
     it "answers cancel with funded, not_open, paid when settlement won, and expired with the payment read meanwhile" testCancelAnswers
+    it "alerts once when a cancel expires an invoice a payment landed on while the provider was told" testCancelAlertsFunded
     it "leaves a late payment of a cancelled invoice unpaid and alerts" testLatePayment
     it "queues an order settled while open and publishes its version" testSettlementQueues
     it "takes the invoice's row before recording a payment that moves no status" testSettlementLocksInvoice
@@ -1067,6 +1084,21 @@ testCancelAnswers = withOrders $ \ctx -> do
   where
     cancelAt c (InvoiceId t) = post c ("/api/invoice/" <> T.unpack t <> "/cancel") ""
 
+-- | Cancel takes the invoice row and decides on the payment it then reads, as settlement does.
+testCancelAlertsFunded :: IO ()
+testCancelAlertsFunded = withOrdersCancelling (SigFunded paid PaidInPart) $ \ctx -> do
+  (invId, _) <- placed ctx aliceOrder
+  logs <- capturingStderr $ do
+    (status, v) <- post ctx ("/api/invoice/" <> T.unpack (invoiceText invId) <> "/cancel") ""
+    (status, field "status" =<< v, field "cryptoAmountPaid" =<< v) `shouldBe` (200, Just "expired", Just "0.00078")
+  length (T.breakOnAll (alertOf invId) logs) `shouldBe` 1
+  capturingStderr (settleNow ctx invId (SigClosed paid) `shouldReturn` Right ISExpired) >>= (`shouldNotSatisfy` T.isInfixOf (alertOf invId))
+  (nrPhase &&& nrLive) <$> invoiceRegistration ctx invId `shouldReturn` (PUnpaid, False)
+  where
+    paid = rcv 5000 (Just "0.00078")
+    invoiceText (InvoiceId t) = t
+    alertOf invId = "invoice " <> invoiceText invId <> " was paid after its order closed"
+
 testNamesOff :: IO ()
 testNamesOff = withOrders $ \ctx -> do
   (invId@(InvoiceId t), _) <- placed ctx aliceOrder

tests/Bots/StoreService/NamesPhasesTests.hs

@@ -0,0 +1,321 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module Bots.StoreService.NamesPhasesTests (namesPhasesTests) where
+
+import Bots.StoreService.NamesOrdersTests
+import Bots.StoreService.NamesStoreTests (reveal)
+import Bots.StoreService.WebTests (bounded, jsonObject, rcv, statusOf, webGet)
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (Async, async, cancel, wait, waitCatchSTM)
+import qualified Control.Concurrent.Async as Async
+import Control.Concurrent.STM (STM, atomically, check, orElse)
+import Control.Monad (forM_)
+import qualified Data.Aeson as J
+import qualified Data.Aeson.Key as K
+import qualified Data.Aeson.KeyMap as KM
+import Data.IORef (readIORef, writeIORef)
+import Data.Int (Int64)
+import Data.Maybe (fromJust, fromMaybe, isNothing)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
+import Network.HTTP.Client (defaultManagerSettings, newManager)
+import qualified Network.Wai.Handler.Warp as Warp
+import Simplex.Chat.PaymentService.Types (InvoiceId (..), InvoiceStatus (..))
+import Simplex.Messaging.Agent.Store.Common (withTransaction)
+import StoreService.Names.Orders (OrdersEnv (..))
+import StoreService.Names.Phases (RegistrationId (..), phasesWaiting, publish)
+import StoreService.Names.Store (NamePhase (..), NameRegistration (..), VersionWrite (..), getRegistration, updateRegistration)
+import StoreService.Providers (Funded (..), PaymentSignal (..))
+import StoreService.Store.Invoices (InvoiceRow (..), getInvoice)
+import StoreService.Waiters (publishPayment, waitingCountSTM)
+import StoreService.Web.Http (holdMicros, readLimit)
+import StoreService.Web.Names (Route (..), namesApp)
+import StoreService.Web.Names.Registration (registrationHandler)
+import StoreService.Web.Server (WebEnv (..), webApp)
+import System.Timeout (timeout)
+import Test.Hspec
+
+namesPhasesTests :: Spec
+namesPhasesTests = describe "StoreService names: phases" $ do
+  describe "changes" $ do
+    it "wakes a held invoice poll and a held registration poll on each change: phase, label set and cleared, reveal times, error" testEachChangeWakes
+    it "holds a paid name invoice on its registration's version alone, and answers at once without a valid version" testPaidHoldsOnVersion
+    it "answers at once an invoice paid after its order closed" testLatePaidAnswersAtOnce
+    it "wakes an open invoice poll by a version change, and holds it on its status without a valid version" testOpenWakesOnVersion
+  describe "time" $ do
+    it "wakes an unpaid invoice held on its status at its expiry, reading it expired" testExpiryWakes
+    it "reads a funded open invoice past its expiry as open, and holds it" testFundedStaysOpen
+    it "reads a committed registration with no reveal past revealBefore as failed, waking held registration and invoice polls" testLapseReadsFailed
+  describe "registration poll" $ do
+    it "answers at once without seenVersion, with another version, or with one that is not a number" testAnswersAtOnce
+    it "answers unchanged after the hold" testHoldTimesOut
+    it "answers an unknown registration 404" testUnknownRegistration
+    it "leaves waitingCount to polls waiting on a payment" testWaitingCount
+
+data Polls = Polls
+  { pCtx :: Ctx,
+    -- | Sets the service's clock, which then runs on in real time, so a hold can end at a moment.
+    pSetNow :: UTCTime -> IO ()
+  }
+
+-- | The registration route as namesRoutes registers it, beside the invoice routes, since a NamesEnv needs a running chat controller.
+withPolls :: Int -> (Polls -> IO a) -> IO a
+withPolls hold action = withOrders $ \ctx@Ctx {cClock, cOrders, cWeb} -> do
+  started <- getCurrentTime
+  let elapsed = (`diffUTCTime` started) <$> getCurrentTime
+      running = addUTCTime <$> elapsed <*> readIORef cClock
+      orders = cOrders {oeNow = running}
+      web = cWeb {weOrders = Just orders}
+      routes = \case
+        ["api", "registration", rid] -> Just Route {rMethod = "GET", rLimit = readLimit, rHandler = registrationHandler orders hold rid}
+        _ -> Nothing
+      app req respond = fromMaybe (webApp web req respond) (namesApp (weHttp web) routes req respond)
+      pSetNow t = elapsed >>= \e -> writeIORef cClock (addUTCTime (negate e) t)
+  mgr <- newManager defaultManagerSettings
+  Warp.testWithApplication (pure app) $ \port ->
+    action Polls {pCtx = ctx {cOrders = orders, cWeb = web, cClient = (mgr, "http://127.0.0.1:" <> show port)}, pSetNow}
+
+-- | How long a held poll is watched for a wake that must not come.
+parkDelay :: Int
+parkDelay = 200000
+
+-- | How long a poll may take to be held or to answer once woken; far below the hold.
+prompt :: Int
+prompt = 6000000
+
+-- | How far ahead of a moment the clock is set, so a poll is held well before the moment wakes it.
+shortOfMoment :: NominalDiffTime
+shortOfMoment = 3
+
+shortHold :: Int
+shortHold = 500000
+
+get :: Ctx -> String -> IO (Int, J.Object)
+get Ctx {cClient} path = webGet cClient path >>= \r -> (statusOf r,) <$> jsonObject r
+
+-- | The holds the server has taken: invoices held on a payment, and waiters on a registration's version.
+subscriptions :: Ctx -> STM (Int, Int)
+subscriptions Ctx {cWeb, cOrders} = (,) <$> waitingCountSTM (weWaiters cWeb) <*> phasesWaiting (oePhases cOrders)
+
+-- | A poll once the server holds it, having taken these many more holds of each kind.
+held :: Ctx -> (Int, Int) -> String -> IO (Async (Int, J.Object))
+held ctx (payments, versions) path = do
+  (payments0, versions0) <- atomically $ subscriptions ctx
+  poll <- async $ get ctx path
+  let holding = subscriptions ctx >>= check . (== (payments0 + payments, versions0 + versions))
+  timeout prompt (atomically $ (Left <$> waitCatchSTM poll) `orElse` (Right <$> holding)) >>= \case
+    Just (Right ()) -> pure poll
+    Just (Left answered) -> fail $ path <> " was answered at once: " <> show answered
+    Nothing -> cancel poll >> fail (path <> " was not held with " <> show (payments, versions) <> " more holds")
+
+woken :: String -> Async (Int, J.Object) -> IO (Int, J.Object)
+woken what poll = timeout prompt (wait poll) >>= maybe (cancel poll >> fail (what <> " was not woken")) pure
+
+answeredAtOnce :: Ctx -> String -> IO (Int, J.Object)
+answeredAtOnce ctx path = timeout prompt (get ctx path) >>= maybe (fail (path <> " was held")) pure
+
+invoicePath :: InvoiceId -> String
+invoicePath (InvoiceId t) = "/api/invoice/" <> T.unpack t
+
+registrationPath :: RegistrationId -> String
+registrationPath (RegistrationId t) = "/api/registration/" <> T.unpack t
+
+-- | The query the page sends to follow an invoice, as it last saw it.
+following :: InvoiceStatus -> Int64 -> Text -> Bool -> String
+following status version = followingAs status (Just $ show version)
+
+-- | With seenVersion as given, a number or not, or left out.
+followingAs :: InvoiceStatus -> Maybe String -> Text -> Bool -> String
+followingAs status version paid full =
+  "?wait=" <> statusText <> maybe "" ("&seenVersion=" <>) version <> "&seenPaid=" <> T.unpack paid <> "&seenFull=" <> (if full then "1" else "0")
+  where
+    statusText = case status of
+      ISOpen -> "open"
+      ISPaid -> "paid"
+      ISExpired -> "expired"
+
+seenVersion :: Int64 -> String
+seenVersion v = "?seenVersion=" <> show v
+
+-- | A write as the worker or a reveal makes it: a compare-and-set, then a publish after the commit.
+change :: Ctx -> RegistrationId -> (NameRegistration -> NameRegistration) -> IO Int64
+change Ctx {cStore, cOrders, cClock} rid f = do
+  now <- readIORef cClock
+  written <- withTransaction cStore $ \db -> getRegistration db rid >>= \r -> updateRegistration db (f $ fromJust r) now
+  case written of
+    Written v -> v <$ atomically (publish (oePhases cOrders) rid v)
+    other -> fail $ "registration not written: " <> show other
+
+key :: Text -> J.Object -> Maybe J.Value
+key k = KM.lookup (K.fromText k)
+
+seconds :: UTCTime -> Integer
+seconds = floor . utcTimeToPOSIXSeconds
+
+-- | The settled payment's marks: its crypto amount and paid in full.
+settledPaid :: Text
+settledPaid = "0.00156"
+
+-- tests
+
+-- | Paid and queued at version 2; each change below is one the worker, a reveal or a re-commit makes.
+testEachChangeWakes :: IO ()
+testEachChangeWakes = bounded "each change wakes" $ withPolls holdMicros $ \Polls {pCtx = ctx} -> do
+  (inv, _) <- placed ctx aliceOrder
+  settleNow ctx inv settled `shouldReturn` Right ISPaid
+  NameRegistration {nrId} <- invoiceRegistration ctx inv
+  let day = seconds orderTime + 86400
+      changes :: [(String, NameRegistration -> NameRegistration, Text, J.Value)]
+      changes =
+        [ ("phase", \r -> r {nrPhase = PCommitting}, "phase", "committing"),
+          ("committed", \r -> r {nrPhase = PCommitted, nrRevealAfter = Just (fromInteger day), nrRevealBefore = Just (fromInteger $ day + 86400)}, "revealBefore", J.toJSON (day + 86400)),
+          ("label set", \r -> r {nrReveal = Just reveal}, "label", "alicebakery"),
+          ("label cleared", \r -> r {nrReveal = Nothing}, "label", J.Null),
+          ("reveal times after a re-commit", \r -> r {nrRevealAfter = Just (fromInteger $ day + 60), nrRevealBefore = Just (fromInteger $ day + 86460)}, "revealBefore", J.toJSON (day + 86460)),
+          ("error", \r -> r {nrPhase = PFailed, nrError = Just "The commit transaction failed"}, "error", "The commit transaction failed")
+        ]
+  forM_ changes $ \(what, f, k, expected) -> do
+    v <- nrVersion <$> invoiceRegistration ctx inv
+    invoicePoll <- held ctx (0, 1) $ invoicePath inv <> following ISPaid v settledPaid True
+    registrationPoll <- held ctx (0, 1) $ registrationPath nrId <> seenVersion v
+    v' <- change ctx nrId f
+    (status, o) <- woken (what <> ": invoice poll") invoicePoll
+    (status, key "status" o, key "version" (registrationOf o), key k (registrationOf o)) `shouldBe` (200, Just "paid", Just (J.toJSON v'), Just expected)
+    (status', r) <- woken (what <> ": registration poll") registrationPoll
+    (status', key "version" r, key k r) `shouldBe` (200, Just (J.toJSON v'), Just expected)
+
+testPaidHoldsOnVersion :: IO ()
+testPaidHoldsOnVersion = bounded "paid holds on version" $ withPolls holdMicros $ \Polls {pCtx = ctx@Ctx {cWeb}} -> do
+  (inv, _) <- placed ctx aliceOrder
+  settleNow ctx inv settled `shouldReturn` Right ISPaid
+  NameRegistration {nrId, nrVersion} <- invoiceRegistration ctx inv
+  -- without a version there is nothing a paid invoice could wait for
+  forM_ [Nothing, Just "two"] $ \version ->
+    (fst <$> answeredAtOnce ctx (invoicePath inv <> followingAs ISPaid version settledPaid True)) `shouldReturn` 200
+  poll <- held ctx (0, 1) $ invoicePath inv <> following ISPaid nrVersion settledPaid True
+  atomically $ publishPayment (weWaiters cWeb) inv
+  threadDelay parkDelay
+  Async.poll poll >>= (`shouldSatisfy` isNothing)
+  v' <- change ctx nrId $ \r -> r {nrPhase = PCommitting}
+  (_, o) <- woken "paid invoice poll" poll
+  (key "version" (registrationOf o), key "phase" (registrationOf o)) `shouldBe` (Just (J.toJSON v'), Just "committing")
+  -- marks other than the page saw answer at once
+  (fst <$> answeredAtOnce ctx (invoicePath inv <> following ISPaid v' "0.001" True)) `shouldReturn` 200
+
+testLatePaidAnswersAtOnce :: IO ()
+testLatePaidAnswersAtOnce = bounded "late paid" $ withPolls holdMicros $ \Polls {pCtx = ctx} -> do
+  (inv, _) <- placed ctx aliceOrder
+  fst <$> post ctx (invoicePath inv <> "/cancel") "" `shouldReturn` 200
+  settleNow ctx inv settled `shouldReturn` Right ISPaid
+  NameRegistration {nrVersion} <- invoiceRegistration ctx inv
+  (status, o) <- answeredAtOnce ctx $ invoicePath inv <> following ISPaid nrVersion settledPaid True
+  (status, key "status" o, key "phase" (registrationOf o)) `shouldBe` (200, Just "paid", Just "unpaid")
+
+testOpenWakesOnVersion :: IO ()
+testOpenWakesOnVersion = bounded "open wakes on version" $ withPolls holdMicros $ \Polls {pCtx = ctx} -> do
+  (inv, _) <- placed ctx aliceOrder
+  NameRegistration {nrId, nrVersion} <- invoiceRegistration ctx inv
+  -- a version the page has not seen answers at once
+  (fst <$> answeredAtOnce ctx (invoicePath inv <> following ISOpen (nrVersion - 1) "" False)) `shouldReturn` 200
+  poll <- held ctx (1, 1) $ invoicePath inv <> following ISOpen nrVersion "" False
+  v' <- change ctx nrId $ \r -> r {nrError = Just "Checking the payment"}
+  (_, o) <- woken "open invoice poll" poll
+  (key "status" o, key "version" (registrationOf o)) `shouldBe` (Just "open", Just (J.toJSON v'))
+  -- a seenVersion that is no version leaves the hold on the status and payment alone
+  byStatus <- held ctx (1, 0) $ invoicePath inv <> followingAs ISOpen (Just "two") "" False
+  settleNow ctx inv (SigFunded (rcv 5000 (Just "0.00078")) PaidInPart) `shouldReturn` Right ISOpen
+  (_, paidInPart) <- woken "open invoice poll without a version" byStatus
+  (key "status" paidInPart, key "cryptoAmountPaid" paidInPart) `shouldBe` (Just "open", Just "0.00078")
+
+-- | The stub's crypto invoice expires 45 minutes after the order; the clock is set just short of it.
+testExpiryWakes :: IO ()
+testExpiryWakes = bounded "expiry wakes" $ withPolls holdMicros $ \Polls {pCtx = ctx, pSetNow} -> do
+  (inv, _) <- placed ctx aliceOrder
+  Just InvoiceRow {irExpiresAt} <- getInvoice (cStore ctx) inv
+  NameRegistration {nrVersion} <- invoiceRegistration ctx inv
+  pSetNow $ addUTCTime (negate shortOfMoment) irExpiresAt
+  poll <- held ctx (1, 0) $ invoicePath inv <> followingAs ISOpen Nothing "" False
+  (status, o) <- woken "unpaid invoice poll" poll
+  (status, key "status" o, key "version" (registrationOf o)) `shouldBe` (200, Just "expired", Just (J.toJSON nrVersion))
+  -- read so, not written: the sweep or the next order closes it
+  (irStatus <$>) <$> getInvoice (cStore ctx) inv `shouldReturn` Just ISOpen
+  (fst <$> answeredAtOnce ctx (invoicePath inv <> following ISOpen nrVersion "" False)) `shouldReturn` 200
+
+testFundedStaysOpen :: IO ()
+testFundedStaysOpen = bounded "funded stays open" $ withPolls holdMicros $ \Polls {pCtx = ctx, pSetNow} -> do
+  (inv, _) <- placed ctx aliceOrder
+  settleNow ctx inv (SigFunded (rcv 5000 (Just "0.00078")) PaidInPart) `shouldReturn` Right ISOpen
+  Just InvoiceRow {irExpiresAt} <- getInvoice (cStore ctx) inv
+  NameRegistration {nrVersion} <- invoiceRegistration ctx inv
+  pSetNow $ addUTCTime 60 irExpiresAt
+  (status, o) <- get ctx (invoicePath inv)
+  (status, key "status" o) `shouldBe` (200, Just "open")
+  poll <- held ctx (1, 1) $ invoicePath inv <> following ISOpen nrVersion "0.00078" False
+  cancel poll
+
+testLapseReadsFailed :: IO ()
+testLapseReadsFailed = bounded "lapse" $ withPolls holdMicros $ \Polls {pCtx = ctx@Ctx {cOrders}, pSetNow} -> do
+  (inv, _) <- placed ctx aliceOrder
+  settleNow ctx inv settled `shouldReturn` Right ISPaid
+  NameRegistration {nrId} <- invoiceRegistration ctx inv
+  now <- oeNow cOrders
+  let revealBefore = seconds now + 600
+      lapsedAt = posixSecondsToUTCTime (fromInteger revealBefore)
+  pSetNow $ addUTCTime (negate shortOfMoment) lapsedAt
+  v <- change ctx nrId $ \r -> r {nrPhase = PCommitted, nrRevealAfter = Just (fromInteger $ revealBefore - 3600), nrRevealBefore = Just (fromInteger revealBefore)}
+  (_, r) <- get ctx (registrationPath nrId)
+  key "phase" r `shouldBe` Just "committed"
+  invoicePoll <- held ctx (0, 1) $ invoicePath inv <> following ISPaid v settledPaid True
+  poll <- held ctx (0, 1) $ registrationPath nrId <> seenVersion v
+  (status, lapsed) <- woken "registration poll at the lapse" poll
+  (status, key "phase" lapsed, key "error" lapsed, key "version" lapsed) `shouldBe` (200, Just "failed", Just "The name was not signed in time", Just (J.toJSON v))
+  (_, o) <- woken "invoice poll at the lapse" invoicePoll
+  (key "status" o, key "phase" (registrationOf o), key "error" (registrationOf o)) `shouldBe` (Just "paid", Just "failed", Just "The name was not signed in time")
+  (nrPhase <$> invoiceRegistration ctx inv) `shouldReturn` PCommitted
+  -- one with a reveal set stays committed past revealBefore
+  revealed <- change ctx nrId $ \r' -> r' {nrReveal = Just reveal}
+  pSetNow $ addUTCTime 3600 lapsedAt
+  (_, r') <- get ctx (registrationPath nrId)
+  (key "phase" r', key "label" r', key "version" r') `shouldBe` (Just "committed", Just "alicebakery", Just (J.toJSON revealed))
+
+testAnswersAtOnce :: IO ()
+testAnswersAtOnce = bounded "at once" $ withPolls holdMicros $ \Polls {pCtx = ctx} -> do
+  (inv, _) <- placed ctx aliceOrder
+  NameRegistration {nrId = rid@(RegistrationId ridText), nrVersion} <- invoiceRegistration ctx inv
+  forM_ ["", seenVersion (nrVersion + 1), seenVersion (nrVersion - 1), "?seenVersion=one", "?seenVersion=-1", "?seenVersion=99999999999999999999"] $ \q -> do
+    (status, r) <- answeredAtOnce ctx (registrationPath rid <> q)
+    (q, status, key "id" r, key "version" r, key "phase" r) `shouldBe` (q, 200, Just (J.String ridText), Just (J.toJSON nrVersion), Just "unpaid")
+
+testHoldTimesOut :: IO ()
+testHoldTimesOut = bounded "hold times out" $ withPolls shortHold $ \Polls {pCtx = ctx} -> do
+  (inv, _) <- placed ctx aliceOrder
+  NameRegistration {nrId, nrVersion} <- invoiceRegistration ctx inv
+  started <- getCurrentTime
+  (status, r) <- get ctx $ registrationPath nrId <> seenVersion nrVersion
+  waited <- (`diffUTCTime` started) <$> getCurrentTime
+  (status, key "version" r) `shouldBe` (200, Just (J.toJSON nrVersion))
+  waited `shouldSatisfy` (>= (fromIntegral shortHold / 1000000 :: NominalDiffTime))
+
+testUnknownRegistration :: IO ()
+testUnknownRegistration = bounded "unknown" $ withPolls holdMicros $ \Polls {pCtx = ctx} -> do
+  (status, o) <- answeredAtOnce ctx (registrationPath (RegistrationId "t2Jk8RmQ4vXw9NcP3yLb6g") <> seenVersion 1)
+  (status, o) `shouldBe` (404, KM.fromList [("error", "not_found")])
+
+-- | The poller reads providers sooner while a page waits on a payment; a hold on a version waits on none.
+testWaitingCount :: IO ()
+testWaitingCount = bounded "waiting count" $ withPolls holdMicros $ \Polls {pCtx = ctx} -> do
+  (paid, _) <- placed ctx aliceOrder
+  settleNow ctx paid settled `shouldReturn` Right ISPaid
+  NameRegistration {nrId, nrVersion} <- invoiceRegistration ctx paid
+  polls <- mapM (held ctx (0, 1)) [registrationPath nrId <> seenVersion nrVersion, invoicePath paid <> following ISPaid nrVersion settledPaid True]
+  atomically (subscriptions ctx) `shouldReturn` (0, 2)
+  (open, _) <- placed ctx aliceOrder {oLabel = "dynamis", oPrice = 20000, oCommitment = commitmentOf 2}
+  NameRegistration {nrVersion = openVersion} <- invoiceRegistration ctx open
+  openPoll <- held ctx (1, 1) $ invoicePath open <> following ISOpen openVersion "" False
+  atomically (subscriptions ctx) `shouldReturn` (1, 3)
+  mapM_ cancel (openPoll : polls)

tests/Bots/StoreService/NamesStoreTests.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Bots.StoreService.NamesStoreTests (namesStoreTests, issue, order, ownerA, ownerB, placeCode, placePaid, t0, usable) where
+module Bots.StoreService.NamesStoreTests (namesStoreTests, issue, order, ownerA, ownerB, placeCode, placePaid, reveal, t0, usable) where
 
 import Bots.StoreService.WebTests (columnsOf, digestFixture, runMigrations, withServiceStore)
 import Control.Arrow ((&&&))

tests/Test.hs

@@ -16,6 +16,7 @@ import Bots.StoreService.NamesContractsTests
 import Bots.StoreService.NamesLabelTests
 import Bots.StoreService.NamesLinksTests
 import Bots.StoreService.NamesOrdersTests
+import Bots.StoreService.NamesPhasesTests
 import Bots.StoreService.NamesProfilesTests
 import Bots.StoreService.NamesRecordsTests
 import Bots.StoreService.NamesSearchTests
@@ -106,6 +107,7 @@ main = do
       namesLabelTests
       namesLinksTests
       namesOrdersTests
+      namesPhasesTests
       namesProfilesTests
       namesRecordsTests
       namesSearchTests