store: merge names wiring

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

@@ -12,6 +12,8 @@ module StoreService.Config
     PollConfig (..),
     BadgeIssuerKey (..),
     GroupConfig (..),
+    NamesConfig (..),
+    ChainConfig (..),
     ServiceConfig (..),
     defaultExpiryMinutes,
     defaultSessionMinutes,
@@ -22,17 +24,26 @@ where
 
 import qualified Control.Exception as E
 import StoreService.Log (logWarn)
-import Control.Monad (mfilter)
+import Control.Monad (mfilter, unless, when)
 import Data.Attoparsec.Text (Parser, endOfInput, isEndOfLine, parseOnly, satisfy, skipMany, skipSpace, skipWhile)
+import qualified Data.ByteArray as BA
+import Data.ByteArray.Encoding (Base (Base16), convertFromBase)
 import qualified Data.ByteString.Char8 as B
 import Data.Ini (Ini, iniGlobals, iniParser, keys, lookupValue, sections)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
 import qualified Data.Text.IO as TIO
+import Data.Time.Clock (UTCTime)
+import Data.Time.Format.ISO8601 (iso8601ParseM)
+import Data.Word (Word64)
 import Simplex.Chat.Library.Commands (mkValidName)
 import Simplex.Messaging.Crypto.BBS (BBSSecretKey)
+import Simplex.Messaging.Crypto.Secp256k1 (Secp256k1PrivateKey, mkPrivateKey)
 import Simplex.Messaging.Encoding.String (strDecode)
+import Simplex.Messaging.Eth.Address (Address)
+import Simplex.Messaging.SimplexName (SimplexTLD (..))
 import System.IO.Error (ioeGetErrorString)
 import Text.Read (readMaybe)
 
@@ -42,7 +53,10 @@ data ListenerConfig = ListenerConfig
     lStaticDir :: FilePath,
     lServeWebapp :: Bool,
     lWebappExportDir :: Maybe FilePath,
-    lTrustForwardedFor :: Bool
+    lTrustForwardedFor :: Bool,
+    lNamesStaticDir :: Maybe FilePath,
+    lNamesExportDir :: Maybe FilePath,
+    lNamesHosts :: [Text]
   }
   deriving (Eq, Show)
 
@@ -107,13 +121,42 @@ data GroupConfig = GroupConfig
   }
   deriving (Eq, Show)
 
+data NamesConfig = NamesConfig
+  { nTLD :: SimplexTLD,
+    nYears :: Int,
+    nTermStart :: UTCTime,
+    nTermSlackSeconds :: Int,
+    nRevealMarginSeconds :: Int,
+    nMaxOrderMoves :: Int,
+    nChain :: ChainConfig
+  }
+  deriving (Eq, Show)
+
+data ChainConfig = ChainConfig
+  { cRpcUrl :: String,
+    cChainId :: Word64,
+    cController :: Address,
+    cSponsor :: Address,
+    cBaseRegistrar :: Address,
+    cResolver :: Address,
+    cServiceKey :: Secp256k1PrivateKey,
+    cConfirmations :: Int,
+    cGasLimitCap :: Word64
+  }
+  deriving (Eq)
+
+-- The RPC URL can carry a provider's API key, so neither it nor the service key is shown.
+instance Show ChainConfig where
+  show ChainConfig {cChainId} = "chain " <> show cChainId
+
 data ServiceConfig = ServiceConfig
   { listener :: ListenerConfig,
     btcpay :: Maybe BTCPayConfig,
     stripe :: Maybe StripeConfig,
     poll :: PollConfig,
     issuer :: Maybe BadgeIssuerKey,
-    group :: Maybe GroupConfig
+    group :: Maybe GroupConfig,
+    names :: Maybe NamesConfig
   }
   deriving (Eq, Show)
 
@@ -137,6 +180,16 @@ requireHttps u
   | "https://" `T.isPrefixOf` u = Right u
   | otherwise = Left "btcpay.host must be an absolute https URL"
 
+-- | The controller refuses a registration under 730 days.
+minNameYears :: Int
+minNameYears = 2
+
+defaultTermStart :: String
+defaultTermStart = "2027-01-01T00:00:00Z"
+
+serviceKeyBytes :: Int
+serviceKeyBytes = 32
+
 -- | Well below 100, where BTCPay settles an invoice for one satoshi.
 maxTolerance :: Double
 maxTolerance = 10
@@ -160,12 +213,14 @@ trailingNoise = skipSpace *> skipMany (comment *> skipSpace)
 
 knownSettings :: [(Text, [Text])]
 knownSettings =
-  [ ("listener", ["host", "port", "static_dir", "serve_webapp", "webapp_export_dir", "trust_forwarded_for"]),
+  [ ("listener", ["host", "port", "static_dir", "serve_webapp", "webapp_export_dir", "trust_forwarded_for", "names_static_dir", "names_export_dir", "names_hosts"]),
     ("btcpay", ["host", "api_key", "store_id", "webhook_secret", "expiry_minutes", "speed_policy", "payment_tolerance"]),
     ("stripe", ["secret_key", "publishable_key", "webhook_secret", "session_minutes"]),
     ("poll", ["waiting_seconds", "idle_seconds"]),
     ("group", ["display_name", "description"]),
-    ("issuer", ["index", "private_key"])
+    ("issuer", ["index", "private_key"]),
+    ("names", ["tld", "years", "term_start", "term_slack_seconds", "reveal_margin_seconds", "max_order_moves"]),
+    ("chain", ["rpc_url", "chain_id", "controller", "sponsor", "base_registrar", "resolver", "service_key", "confirmations", "gas_limit_cap"])
   ]
 
 unknownKeys :: Ini -> [Text]
@@ -190,20 +245,25 @@ parseConfig ini = do
   lServeWebapp <- bool "listener" "serve_webapp" True
   let lWebappExportDir = T.unpack <$> present "listener" "webapp_export_dir"
   lTrustForwardedFor <- bool "listener" "trust_forwarded_for" False
+  let lNamesStaticDir = T.unpack <$> present "listener" "names_static_dir"
+      lNamesExportDir = T.unpack <$> present "listener" "names_export_dir"
+      lNamesHosts = maybe [] (filter (not . T.null) . map (T.toLower . T.strip) . T.splitOn ",") (present "listener" "names_hosts")
   btc <- btcpaySection
   str <- stripeSection
   iss <- issuerSection
   grp <- groupSection
+  nms <- namesSection
   pWaitingSeconds <- cadence "waiting_seconds" 3
   pIdleSeconds <- cadence "idle_seconds" 60
   pure
     ServiceConfig
-      { listener = ListenerConfig {lHost, lPort, lStaticDir, lServeWebapp, lWebappExportDir, lTrustForwardedFor},
+      { listener = ListenerConfig {lHost, lPort, lStaticDir, lServeWebapp, lWebappExportDir, lTrustForwardedFor, lNamesStaticDir, lNamesExportDir, lNamesHosts},
         btcpay = btc,
         stripe = str,
         poll = PollConfig {pWaitingSeconds, pIdleSeconds},
         issuer = iss,
-        group = grp
+        group = grp,
+        names = nms
       }
   where
     hasSection s = s `elem` sections ini
@@ -295,6 +355,61 @@ parseConfig ini = do
           sSessionMinutes <- sessionMinutes
           let sHost = defaultStripeHost
           pure (Just StripeConfig {sSecretKey, sPublishableKey, sWebhookSecret, sSessionMinutes, sHost})
+    namesSection
+      | not (hasSection "names") = if hasSection "chain" then Left "[chain] is set but [names] is absent, so nothing would use it" else Right Nothing
+      | not (hasSection "chain") = Left "[names] needs a [chain] section"
+      | otherwise = do
+          nTLD <- tldSetting
+          nYears <- num "names" "years" minNameYears
+          when (nYears < minNameYears) $ Left ("names.years must be at least " <> show minNameYears)
+          nTermStart <- termStart
+          nTermSlackSeconds <- atLeast 0 "names" "term_slack_seconds" 3600
+          nRevealMarginSeconds <- atLeast 0 "names" "reveal_margin_seconds" 900
+          nMaxOrderMoves <- atLeast 0 "names" "max_order_moves" 3
+          nChain <- chainSection
+          pure (Just NamesConfig {nTLD, nYears, nTermStart, nTermSlackSeconds, nRevealMarginSeconds, nMaxOrderMoves, nChain})
+    tldSetting =
+      required "names" "tld" >>= \case
+        "simplex" -> Right TLDSimplex
+        "testing" -> Right TLDTesting
+        other -> Left ("names.tld must be simplex or testing, not " <> T.unpack other)
+    termStart =
+      maybe (Left ("names.term_start must be an ISO 8601 UTC time such as " <> defaultTermStart)) Right $
+        iso8601ParseM (maybe defaultTermStart T.unpack (present "names" "term_start"))
+    atLeast lowest s k d = do
+      v <- num s k d
+      if v >= lowest then Right v else Left (T.unpack s <> "." <> T.unpack k <> " must be at least " <> show lowest)
+    -- No error below quotes a value, since the URL and the key are secrets.
+    chainSection = do
+      cRpcUrl <- rpcUrl
+      cChainId <- positiveWord "chain_id" Nothing
+      cController <- address "controller"
+      cSponsor <- address "sponsor"
+      cBaseRegistrar <- address "base_registrar"
+      cResolver <- address "resolver"
+      cServiceKey <- serviceKey
+      cConfirmations <- atLeast 0 "chain" "confirmations" 3
+      cGasLimitCap <- positiveWord "gas_limit_cap" (Just 8000000)
+      pure ChainConfig {cRpcUrl, cChainId, cController, cSponsor, cBaseRegistrar, cResolver, cServiceKey, cConfirmations, cGasLimitCap}
+    rpcUrl = do
+      v <- required "chain" "rpc_url"
+      unless (any (`T.isPrefixOf` v) ["http://", "https://"]) $ Left "chain.rpc_url must be an http or https URL"
+      Right (T.unpack v)
+    positiveWord k d = case (present "chain" k, d) of
+      (Nothing, Just v) -> Right v
+      (Nothing, Nothing) -> Left ("chain." <> T.unpack k <> " is required")
+      (Just v, _) -> case readMaybe (T.unpack v) :: Maybe Integer of
+        Just n | n >= 1, n <= toInteger (maxBound :: Word64) -> Right (fromInteger n)
+        _ -> Left ("chain." <> T.unpack k <> " must be a positive whole number")
+    address k = do
+      v <- required "chain" k
+      either (const (Left ("chain." <> T.unpack k <> " is not an Ethereum address"))) Right (strDecode (encodeUtf8 v) :: Either String Address)
+    serviceKey = do
+      v <- required "chain" "service_key"
+      let bad = Left "chain.service_key must be 0x and 64 hex digits of a valid secp256k1 key"
+      case T.stripPrefix "0x" v of
+        Just h | T.length h == 2 * serviceKeyBytes, Right bytes <- convertFromBase Base16 (encodeUtf8 h) -> either (const bad) Right (mkPrivateKey (BA.convert (bytes :: B.ByteString)))
+        _ -> bad
     sessionMinutes = do
       v <- num "stripe" "session_minutes" defaultSessionMinutes
       if v >= minSessionMinutes && v <= maxSessionMinutes

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

@@ -0,0 +1,25 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module StoreService.Names.Env (NamesEnv (..), newNamesEnv) where
+
+import Simplex.Chat.Controller (ChatController)
+import Simplex.Messaging.Agent.Protocol (UserId)
+import Simplex.Messaging.Agent.Store.Common (DBStore)
+import StoreService.Config (NamesConfig)
+import StoreService.Names.Phases (Phases, newPhases)
+import StoreService.Names.Turns (Turns, newTurns)
+
+data NamesEnv = NamesEnv
+  { neChat :: ChatController,
+    neUserId :: UserId,
+    neConfig :: NamesConfig,
+    neStore :: DBStore,
+    nePhases :: Phases,
+    neTurns :: Turns
+  }
+
+newNamesEnv :: ChatController -> UserId -> NamesConfig -> DBStore -> IO NamesEnv
+newNamesEnv neChat neUserId neConfig neStore = do
+  nePhases <- newPhases
+  neTurns <- newTurns
+  pure NamesEnv {neChat, neUserId, neConfig, neStore, nePhases, neTurns}

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

@@ -0,0 +1,57 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module StoreService.Names.Phases (Phases, RegistrationId (..), newPhases, publish, awaitChange) where
+
+import Control.Concurrent.STM
+import Control.Exception (bracket)
+import Data.Int (Int64)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Text (Text)
+
+newtype RegistrationId = RegistrationId Text
+  deriving (Eq, Ord, Show)
+
+-- | wVersion only grows, so a publish that arrives after a newer one cannot wake anyone.
+data Watch = Watch {wVersion :: TVar Int64, wRefs :: TVar Int}
+
+newtype Phases = Phases (TVar (Map RegistrationId Watch))
+
+newPhases :: IO Phases
+newPhases = Phases <$> newTVarIO Map.empty
+
+-- | Call after the transaction that wrote this version commits.
+publish :: Phases -> RegistrationId -> Int64 -> STM ()
+publish (Phases watches) rid version =
+  readTVar watches >>= mapM_ (\Watch {wVersion} -> modifyTVar' wVersion (max version)) . Map.lookup rid
+
+subscribe :: Phases -> RegistrationId -> STM Watch
+subscribe (Phases watches) rid =
+  readTVar watches >>= \ws -> case Map.lookup rid ws of
+    Just watch@Watch {wRefs} -> watch <$ modifyTVar' wRefs (+ 1)
+    Nothing -> do
+      watch <- Watch <$> newTVar minBound <*> newTVar 1
+      watch <$ writeTVar watches (Map.insert rid watch ws)
+
+release :: Phases -> RegistrationId -> STM ()
+release (Phases watches) rid =
+  readTVar watches >>= \ws -> mapM_ (drop' ws) (Map.lookup rid ws)
+  where
+    drop' ws Watch {wRefs} = do
+      n <- pred <$> readTVar wRefs
+      if n <= 0 then writeTVar watches (Map.delete rid ws) else writeTVar wRefs n
+
+-- | True once the version differs from @seen@, False after @micros@ without a change.
+-- Subscribes before reading the version, so a publish between the read and the wait is not missed.
+awaitChange :: Phases -> RegistrationId -> IO Int64 -> Int64 -> Int -> IO Bool
+awaitChange phases rid readVersion seen micros =
+  bracket (atomically $ subscribe phases rid) (const . atomically $ release phases rid) $ \Watch {wVersion} -> do
+    current <- readVersion
+    atomically $ modifyTVar' wVersion (max current)
+    if current /= seen
+      then pure True
+      else do
+        timer <- registerDelay micros
+        atomically $
+          (readTVar wVersion >>= \v -> if v > seen then pure True else retry)
+            `orElse` (False <$ (readTVar timer >>= check))

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

@@ -0,0 +1,46 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module StoreService.Names.Turns (Turns, newTurns, withLabelTurn, withLabelTurns, withCodeTurn) where
+
+import Control.Concurrent.STM
+import Control.Exception (bracket, bracket_)
+import Data.ByteString (ByteString)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Simplex.Messaging.SimplexName (LabelHash (..))
+
+-- | Each lock counts the requests holding or waiting for it, and its entry goes when none are left.
+type TurnLocks = TVar (Map ByteString (TMVar (), Int))
+
+data Turns = Turns {labelTurns :: TurnLocks, codeTurns :: TurnLocks}
+
+newTurns :: IO Turns
+newTurns = Turns <$> newTVarIO Map.empty <*> newTVarIO Map.empty
+
+withLabelTurn :: Turns -> LabelHash -> IO a -> IO a
+withLabelTurn Turns {labelTurns} (LabelHash h) = withTurn labelTurns h
+
+-- | Taken in hash order, so two requests moving between the same names cannot each hold one and wait for the other.
+withLabelTurns :: Turns -> LabelHash -> LabelHash -> IO a -> IO a
+withLabelTurns turns a@(LabelHash ha) b@(LabelHash hb) action
+  | ha == hb = withLabelTurn turns a action
+  | ha < hb = withLabelTurn turns a $ withLabelTurn turns b action
+  | otherwise = withLabelTurn turns b $ withLabelTurn turns a action
+
+-- | Keyed by the code's SHA-256 hash.
+withCodeTurn :: Turns -> ByteString -> IO a -> IO a
+withCodeTurn Turns {codeTurns} = withTurn codeTurns
+
+withTurn :: TurnLocks -> ByteString -> IO a -> IO a
+withTurn locks key action =
+  bracket (atomically enter) (const $ atomically leave) $ \lock ->
+    bracket_ (atomically $ takeTMVar lock) (atomically $ putTMVar lock ()) action
+  where
+    enter = do
+      held <- readTVar locks
+      case Map.lookup key held of
+        Just (lock, n) -> lock <$ writeTVar locks (Map.insert key (lock, n + 1) held)
+        Nothing -> do
+          lock <- newTMVar ()
+          lock <$ writeTVar locks (Map.insert key (lock, 1) held)
+    leave = modifyTVar' locks (Map.update (\(lock, n) -> if n <= 1 then Nothing else Just (lock, n - 1)) key)

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

@@ -20,9 +20,10 @@ where
 
 import StoreService.Catalog (defaultCatalog)
 import StoreService.Codes (issueFailedText, issueOneCode, singleUse)
-import StoreService.Config (BadgeIssuerKey (..), ServiceConfig (..), readServiceConfig)
+import StoreService.Config (BadgeIssuerKey (..), ChainConfig (..), NamesConfig (..), ServiceConfig (..), readServiceConfig)
 import StoreService.Group (GroupEvent, ensureManagedGroup, groupEvent, hasTracker, refreshTracker, revokeWithTracker, runGroupLane)
 import StoreService.Group.Command (badgeTypeP, codeP, maxMonths, textTokenP)
+import StoreService.Names.Env (NamesEnv, newNamesEnv)
 import StoreService.Options
 import StoreService.Poller (newPollerEnv, newReadHints, runPoller)
 import StoreService.Providers.BTCPay (btcpayProvider)
@@ -150,18 +151,27 @@ storeService opts@StoreServiceOpts {serviceConfigFile} cfg env = do
   simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc -> raceAny_ [readEvents cc, startLanes cc]
   where
     serviceLanes :: Waiters -> ChatController -> ServiceConfig -> IO [IO ()]
-    serviceLanes ws ChatController {chatStore} sc = do
+    serviceLanes ws 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
-      webEnv <- newWebEnv chatStore sc ws hints providers
+      namesEnv <- forM (names sc) (startNames cc)
+      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]
 
+startNames :: ChatController -> NamesConfig -> IO NamesEnv
+startNames cc@ChatController {chatStore} 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
+
 seedServiceCatalog :: DBStore -> IO ()
 seedServiceCatalog st = do
   now <- truncateToSecond <$> getCurrentTime

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

@@ -0,0 +1,283 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module StoreService.Web.Http
+  ( HttpEnv (..),
+    newHttpEnv,
+    Respond,
+    Limit (..),
+    takeToken,
+    limited,
+    only,
+    clientKey,
+    maxBuckets,
+    readLimit,
+    createLimit,
+    searchLimit,
+    previewLimit,
+    codeLimit,
+    findLimit,
+    recordsLimit,
+    holdMicros,
+    jsonResponse,
+    jsonError,
+    notFound,
+    badRequest,
+    codeConflict,
+    providerUnavailable,
+    rateLimited,
+    methodNotAllowed,
+    internalError,
+    readBoundedBody,
+    maxBodyBytes,
+    nameBodyBytes,
+    parseCodeHash,
+  )
+where
+
+import Control.Concurrent.STM
+import Data.Aeson ((.=))
+import qualified Data.Aeson as J
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base64.URL as B64U
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as LB
+import Data.List (sortOn)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8', encodeUtf8)
+import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
+import Data.Word (Word16)
+import Network.HTTP.Types (Header, Method, Status, hCacheControl, hContentType, status400, status404, status405, status409, status429, status500, status503)
+import Network.Socket (SockAddr (..), hostAddress6ToTuple, hostAddressToTuple)
+import Network.Wai
+import Numeric (showHex)
+import Simplex.Messaging.Util (safeDecodeUtf8)
+import StoreService.Config (ListenerConfig (..))
+import Text.Read (readMaybe)
+
+data HttpEnv = HttpEnv
+  { heBuckets :: TVar (Map Text Bucket),
+    heTrustForwardedFor :: Bool
+  }
+
+newHttpEnv :: ListenerConfig -> IO HttpEnv
+newHttpEnv ListenerConfig {lTrustForwardedFor} = do
+  heBuckets <- newTVarIO Map.empty
+  pure HttpEnv {heBuckets, heTrustForwardedFor = lTrustForwardedFor}
+
+type Respond = Response -> IO ResponseReceived
+
+-- | Short enough to stay under the idle timeout of any proxy in front of us.
+holdMicros :: Int
+holdMicros = 30 * 1000000
+
+readLimit, createLimit, searchLimit, previewLimit, codeLimit, findLimit, recordsLimit :: Limit
+readLimit = Limit {lmName = "read", lmPerMinute = 60}
+createLimit = Limit {lmName = "create", lmPerMinute = 5}
+searchLimit = Limit {lmName = "search", lmPerMinute = 30}
+previewLimit = Limit {lmName = "preview", lmPerMinute = 20}
+codeLimit = Limit {lmName = "code", lmPerMinute = 10}
+findLimit = Limit {lmName = "find", lmPerMinute = 5}
+recordsLimit = Limit {lmName = "records", lmPerMinute = 10}
+
+maxBodyBytes :: Int
+maxBodyBytes = 8192
+
+-- | The cap of the names endpoints whose bodies carry a sealed name code.
+nameBodyBytes :: Int
+nameBodyBytes = 16384
+
+sha256Bytes :: Int
+sha256Bytes = 32
+
+codeHashChars :: Int
+codeHashChars = 43
+
+data Limit = Limit {lmName :: Text, lmPerMinute :: Int}
+  deriving (Eq, Show)
+
+data Bucket = Bucket {bkCount :: Int, bkStarted :: UTCTime}
+
+limitWindow :: NominalDiffTime
+limitWindow = 60
+
+maxBuckets :: Int
+maxBuckets = 32768
+
+reclaim :: UTCTime -> Map Text Bucket -> Map Text Bucket
+reclaim now buckets
+  | Map.size buckets < maxBuckets = buckets
+  | Map.size live * 2 <= maxBuckets = live
+  | otherwise = Map.fromList (drop (Map.size live `div` 2) (sortOn (bkCount . snd) (Map.toList live)))
+  where
+    live = Map.filter (fresh now) buckets
+
+fresh :: UTCTime -> Bucket -> Bool
+fresh now Bucket {bkStarted} = diffUTCTime now bkStarted < limitWindow
+
+takeToken :: HttpEnv -> Limit -> Text -> IO (Maybe Int)
+takeToken HttpEnv {heBuckets} Limit {lmName, lmPerMinute} client = do
+  now <- getCurrentTime
+  atomically $ do
+    buckets <- reclaim now <$> readTVar heBuckets
+    let key = lmName <> "\t" <> client
+        count bucket = writeTVar heBuckets (Map.insert key bucket buckets) >> pure Nothing
+        -- write the reclaimed map back here too, or a refused request redoes the filtering every time and the map stays at the limit
+        refuse seconds = writeTVar heBuckets buckets >> pure (Just seconds)
+    case Map.lookup key buckets of
+      Just bucket@Bucket {bkCount, bkStarted}
+        | fresh now bucket ->
+            if bkCount < lmPerMinute
+              then count bucket {bkCount = bkCount + 1}
+              else refuse (secondsLeft now bkStarted)
+      _ -> count Bucket {bkCount = 1, bkStarted = now}
+  where
+    secondsLeft :: UTCTime -> UTCTime -> Int
+    secondsLeft now started = max 1 (ceiling (limitWindow - diffUTCTime now started))
+
+limited :: HttpEnv -> Limit -> Request -> Respond -> IO ResponseReceived -> IO ResponseReceived
+limited env limit req respond action =
+  takeToken env limit (clientKey env req) >>= \case
+    Nothing -> action
+    Just seconds -> respond (rateLimited seconds)
+
+only :: Method -> Request -> Respond -> IO ResponseReceived -> IO ResponseReceived
+only method req respond action
+  | requestMethod req == method = action
+  | otherwise = respond (methodNotAllowed method)
+
+-- | Every line is joined first, so a second header line a caller adds cannot leave its own line the one we read.
+clientKey :: HttpEnv -> Request -> Text
+clientKey HttpEnv {heTrustForwardedFor} req = fromMaybe (peerText (remoteHost req)) forwarded
+  where
+    forwarded
+      | not heTrustForwardedFor = Nothing
+      | otherwise = case reverse (concatMap entries (requestHeaders req)) of
+          (ip : _) | isIpAddress ip -> Just ip
+          _ -> Nothing
+    entries (name, raw)
+      | name /= "x-forwarded-for" = []
+      | otherwise = either (const []) (filter (not . T.null) . map T.strip . T.splitOn ",") (decodeUtf8' raw)
+
+isIpAddress :: Text -> Bool
+isIpAddress t = isIPv4 t || isIPv6 t
+
+asciiDigit :: Char -> Bool
+asciiDigit c = c >= '0' && c <= '9'
+
+-- Data.Char.isDigit and isHexDigit accept Unicode digits, which are not addresses.
+asciiHexDigit :: Char -> Bool
+asciiHexDigit c = asciiDigit c || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F')
+
+-- | A leading zero is refused, so "010.0.0.1" cannot be a second key for "10.0.0.1".
+isIPv4 :: Text -> Bool
+isIPv4 t = case T.splitOn "." t of
+  [a, b, c, d] -> all octet [a, b, c, d]
+  _ -> False
+  where
+    octet s =
+      not (T.null s)
+        && T.length s <= 3
+        && T.all asciiDigit s
+        && (T.length s == 1 || T.head s /= '0')
+        && maybe False (<= 255) (readMaybe (T.unpack s) :: Maybe Int)
+
+isIPv6 :: Text -> Bool
+isIPv6 t
+  | T.any (== '%') t = False
+  | otherwise = case T.splitOn "::" t of
+      [full] -> groupCount True (segments full) == Just 8
+      [before, after] -> case (groupCount False (segments before), groupCount True (segments after)) of
+        (Just b, Just a) -> b + a <= 7 -- "::" stands for at least one omitted group
+        _ -> False
+      _ -> False
+  where
+    segments s = if T.null s then [] else T.splitOn ":" s
+
+groupCount :: Bool -> [Text] -> Maybe Int
+groupCount endsAddress gs
+  | null gs = Just 0
+  | endsAddress && isIPv4 (last gs) = (+ 2) <$> plainGroups (init gs)
+  | otherwise = plainGroups gs
+  where
+    plainGroups ps = if all hexGroup ps then Just (length ps) else Nothing
+    hexGroup g = not (T.null g) && T.length g <= 4 && T.all asciiHexDigit g
+
+peerText :: SockAddr -> Text
+peerText = \case
+  SockAddrInet _ addr ->
+    let (a, b, c, d) = hostAddressToTuple addr
+     in T.intercalate "." (map tshowInt [a, b, c, d])
+  SockAddrInet6 _ _ addr _ ->
+    let (a, b, c, d, e, f, g, h) = hostAddress6ToTuple addr
+     in T.intercalate ":" (map hex16 [a, b, c, d, e, f, g, h])
+  SockAddrUnix p -> "unix:" <> T.pack p
+  where
+    tshowInt :: Show a => a -> Text
+    tshowInt = T.pack . show
+    hex16 :: Word16 -> Text
+    hex16 w = T.pack (showHex w "")
+
+apiHeaders :: [Header]
+apiHeaders = [(hContentType, "application/json"), (hCacheControl, "no-store")]
+
+jsonResponse :: Status -> J.Value -> Response
+jsonResponse st = responseLBS st apiHeaders . J.encode
+
+jsonError :: Status -> Text -> Response
+jsonError st code = jsonResponse st (J.object ["error" .= code])
+
+notFound :: Response
+notFound = jsonError status404 "not_found"
+
+badRequest :: Response
+badRequest = jsonError status400 "bad_request"
+
+codeConflict :: Response
+codeConflict = jsonError status409 "code_conflict"
+
+providerUnavailable :: Response
+providerUnavailable = jsonError status503 "provider_unavailable"
+
+rateLimited :: Int -> Response
+rateLimited seconds =
+  responseLBS
+    status429
+    (("Retry-After", B.pack (show seconds)) : apiHeaders)
+    (J.encode (J.object ["error" .= ("rate_limited" :: Text)]))
+
+methodNotAllowed :: Method -> Response
+methodNotAllowed allow = responseLBS status405 (("Allow", allow) : apiHeaders) (J.encode (J.object ["error" .= ("method_not_allowed" :: Text)]))
+
+internalError :: Response
+internalError = jsonError status500 "internal"
+
+-- | Returns the bytes exactly as they arrived, since the webhook signature is over those bytes.
+readBoundedBody :: Int -> Request -> IO (Maybe LB.ByteString)
+readBoundedBody cap req = go 0 []
+  where
+    go :: Int -> [ByteString] -> IO (Maybe LB.ByteString)
+    go read' acc = do
+      chunk <- getRequestBodyChunk req
+      if BS.null chunk
+        then pure (Just (LB.fromChunks (reverse acc)))
+        else
+          let read'' = read' + BS.length chunk
+           in if read'' > cap then pure Nothing else go read'' (chunk : acc)
+
+-- | The last character of a 43-character base64 string has two bits no digest byte uses, so a lax
+-- decoder would accept four spellings of the same digest, which the re-encode check rejects.
+parseCodeHash :: Text -> Maybe ByteString
+parseCodeHash t
+  | T.length t /= codeHashChars = Nothing
+  | otherwise = case B64U.decode (encodeUtf8 (t <> "=")) of
+      Right bytes | BS.length bytes == sha256Bytes, canonical bytes == t -> Just bytes
+      _ -> Nothing
+  where
+    canonical = T.filter (/= '=') . safeDecodeUtf8 . B64U.encode

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

@@ -0,0 +1,25 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module StoreService.Web.Names (Route (..), namesRoutes, namesApp) where
+
+import Data.Text (Text)
+import Network.HTTP.Types (Method)
+import Network.Wai (Request, ResponseReceived, pathInfo)
+import StoreService.Names.Env (NamesEnv)
+import StoreService.Web.Http (HttpEnv, Limit, Respond, limited, only)
+
+data Route = Route
+  { rMethod :: Method,
+    rLimit :: Limit,
+    rHandler :: Request -> Respond -> IO ResponseReceived
+  }
+
+namesRoutes :: NamesEnv -> [Text] -> Maybe Route
+namesRoutes _ _ = Nothing
+
+-- | Nothing for a path no route knows. The limit is taken only once the route and the method match.
+namesApp :: HttpEnv -> ([Text] -> Maybe Route) -> Request -> Respond -> Maybe (IO ResponseReceived)
+namesApp http routes req respond = serve <$> routes (pathInfo req)
+  where
+    serve Route {rMethod, rLimit, rHandler} =
+      only rMethod req respond $ limited http rLimit req respond $ rHandler req respond

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

@@ -5,17 +5,12 @@
 
 module StoreService.Web.Server
   ( WebEnv (..),
-    Limit (..),
     newWebEnv,
     exportWebapp,
-    takeToken,
-    maxBuckets,
     maxWebhookBytes,
     webApp,
     webSettings,
     runWebListener,
-    holdMicros,
-    readLimit,
   )
 where
 
@@ -24,7 +19,10 @@ import StoreService.Config (BTCPayConfig (..), ListenerConfig (..), ServiceConfi
 import StoreService.Poller (ReadHints, queueReadHint)
 import StoreService.Providers (OrderDraft (..), Provider (..), ProviderError (..), ProviderInvoice (..), WebhookError (..))
 import StoreService.Store.Invoices (CreateError (..), InvoicePayment (..), InvoiceRow (..), NewInvoice (..), cancelOpenInvoice, codeHashExists, createInvoiceRows, cryptoCurrencyText, getInvoice, getInvoiceByProviderRef, invoiceStatusText, newInvoiceId, paymentHolds, readCatalogRows, textToInvoiceStatus, truncateToSecond)
+import StoreService.Names.Env (NamesEnv)
 import StoreService.Waiters (Seen, Waiters, awaitStatus, publish)
+import StoreService.Web.Http
+import StoreService.Web.Names (namesApp, namesRoutes)
 import Control.Concurrent.STM
 import qualified Control.Exception as E
 import StoreService.Log (logError, logInfo, logWarn)
@@ -35,33 +33,25 @@ import qualified Data.Aeson.KeyMap as KM
 import Data.Aeson.Types (Pair)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
-import qualified Data.ByteString.Base64.URL as B64U
-import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as LB
 import Data.Char (toLower)
-import Data.List (find, isPrefixOf, sortOn)
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
+import Data.List (find, isPrefixOf)
 import Data.Maybe (fromMaybe)
 import Data.String (fromString)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8', encodeUtf8)
-import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
-import Data.Word (Word16)
-import Network.HTTP.Types (Header, Status, hCacheControl, hContentType, status200, status400, status404, status405, status409, status413, status429, status500, status503)
-import Network.Socket (SockAddr (..), hostAddress6ToTuple, hostAddressToTuple)
+import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
+import Network.HTTP.Types (Header, Status, hCacheControl, hContentType, status200, status400, status409, status413)
 import Network.Wai
 import qualified Network.Wai.Handler.Warp as Warp
-import Numeric (showHex)
 import Simplex.Chat.Badges.Types (BadgeOfferId (..), BadgePriceId (..))
 import Simplex.Chat.PaymentService.Types (CardProvider (..), CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), ServicePaymentDestination (..), ServicePaymentMethod (..))
 import Simplex.Messaging.Agent.Store.Common (DBStore)
 import Simplex.Messaging.Encoding.String (textEncode)
-import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
+import Simplex.Messaging.Util (tshow)
 import System.Directory (canonicalizePath, copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removePathForcibly)
 import System.FilePath (pathSeparator, takeExtension, (</>))
-import Text.Read (readMaybe)
 
 data WebEnv = WebEnv
   { weStore :: DBStore,
@@ -70,201 +60,28 @@ data WebEnv = WebEnv
     weProviders :: [Provider],
     weHoldMicros :: Int,
     weHints :: ReadHints,
-    weBuckets :: TVar (Map Text Bucket),
+    weHttp :: HttpEnv,
     -- | @Nothing@ when no Stripe key is configured, and the pristine @static_dir@ shell is served instead.
-    weShell :: Maybe LB.ByteString
+    weShell :: Maybe LB.ByteString,
+    -- | @Nothing@ when the ini has no @[names]@ section.
+    weNames :: Maybe NamesEnv
   }
 
-newWebEnv :: DBStore -> ServiceConfig -> Waiters -> ReadHints -> [Provider] -> IO WebEnv
-newWebEnv weStore weConfig weWaiters weHints weProviders = do
-  weBuckets <- newTVarIO Map.empty
+newWebEnv :: DBStore -> ServiceConfig -> Waiters -> ReadHints -> [Provider] -> Maybe NamesEnv -> IO WebEnv
+newWebEnv weStore weConfig weWaiters weHints weProviders weNames = do
+  weHttp <- newHttpEnv (listener weConfig)
   weShell <- prepareShell (listener weConfig) (stripe weConfig)
-  pure WebEnv {weStore, weConfig, weWaiters, weProviders, weHoldMicros = holdMicros, weHints, weBuckets, weShell}
+  pure WebEnv {weStore, weConfig, weWaiters, weProviders, weHoldMicros = holdMicros, weHints, weHttp, weShell, weNames}
 
 listenerConfig :: WebEnv -> ListenerConfig
 listenerConfig WebEnv {weConfig} = listener weConfig
 
-type Respond = Response -> IO ResponseReceived
-
--- | Short enough to stay under the idle timeout of any proxy in front of us.
-holdMicros :: Int
-holdMicros = 30 * 1000000
-
-readLimit :: Limit
-readLimit = Limit {lmName = "read", lmPerMinute = 60}
-
-createLimit :: Limit
-createLimit = Limit {lmName = "create", lmPerMinute = 5}
-
-maxBodyBytes :: Int
-maxBodyBytes = 8192
-
 maxWebhookBytes :: Int
 maxWebhookBytes = 64 * 1024
 
-sha256Bytes :: Int
-sha256Bytes = 32
-
-codeHashChars :: Int
-codeHashChars = 43
-
-data Limit = Limit {lmName :: Text, lmPerMinute :: Int}
-  deriving (Eq, Show)
-
-data Bucket = Bucket {bkCount :: Int, bkStarted :: UTCTime}
-
-limitWindow :: NominalDiffTime
-limitWindow = 60
-
-maxBuckets :: Int
-maxBuckets = 8192
-
-reclaim :: UTCTime -> Map Text Bucket -> Map Text Bucket
-reclaim now buckets
-  | Map.size buckets < maxBuckets = buckets
-  | Map.size live * 2 <= maxBuckets = live
-  | otherwise = Map.fromList (drop (Map.size live `div` 2) (sortOn (bkCount . snd) (Map.toList live)))
-  where
-    live = Map.filter (fresh now) buckets
-
-fresh :: UTCTime -> Bucket -> Bool
-fresh now Bucket {bkStarted} = diffUTCTime now bkStarted < limitWindow
-
-takeToken :: WebEnv -> Limit -> Text -> IO (Maybe Int)
-takeToken WebEnv {weBuckets} Limit {lmName, lmPerMinute} client = do
-  now <- getCurrentTime
-  atomically $ do
-    buckets <- reclaim now <$> readTVar weBuckets
-    let key = lmName <> "\t" <> client
-        count bucket = writeTVar weBuckets (Map.insert key bucket buckets) >> pure Nothing
-        -- write the reclaimed map back here too, or a refused request redoes the filtering every time and the map stays at the limit
-        refuse seconds = writeTVar weBuckets buckets >> pure (Just seconds)
-    case Map.lookup key buckets of
-      Just bucket@Bucket {bkCount, bkStarted}
-        | fresh now bucket ->
-            if bkCount < lmPerMinute
-              then count bucket {bkCount = bkCount + 1}
-              else refuse (secondsLeft now bkStarted)
-      _ -> count Bucket {bkCount = 1, bkStarted = now}
-  where
-    secondsLeft :: UTCTime -> UTCTime -> Int
-    secondsLeft now started = max 1 (ceiling (limitWindow - diffUTCTime now started))
-
-limited :: WebEnv -> Limit -> Request -> Respond -> IO ResponseReceived -> IO ResponseReceived
-limited env limit req respond action =
-  takeToken env limit (clientKey env req) >>= \case
-    Nothing -> action
-    Just seconds -> respond (rateLimited seconds)
-
--- | Every line is joined first, so a second header line a caller adds cannot leave its own line the one we read.
-clientKey :: WebEnv -> Request -> Text
-clientKey env req = fromMaybe (peerText (remoteHost req)) forwarded
-  where
-    forwarded
-      | not (lTrustForwardedFor (listenerConfig env)) = Nothing
-      | otherwise = case reverse (concatMap entries (requestHeaders req)) of
-          (ip : _) | isIpAddress ip -> Just ip
-          _ -> Nothing
-    entries (name, raw)
-      | name /= "x-forwarded-for" = []
-      | otherwise = either (const []) (filter (not . T.null) . map T.strip . T.splitOn ",") (decodeUtf8' raw)
-
-isIpAddress :: Text -> Bool
-isIpAddress t = isIPv4 t || isIPv6 t
-
-asciiDigit :: Char -> Bool
-asciiDigit c = c >= '0' && c <= '9'
-
--- Data.Char.isDigit and isHexDigit accept Unicode digits, which are not addresses.
-asciiHexDigit :: Char -> Bool
-asciiHexDigit c = asciiDigit c || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F')
-
--- | A leading zero is refused, so "010.0.0.1" cannot be a second key for "10.0.0.1".
-isIPv4 :: Text -> Bool
-isIPv4 t = case T.splitOn "." t of
-  [a, b, c, d] -> all octet [a, b, c, d]
-  _ -> False
-  where
-    octet s =
-      not (T.null s)
-        && T.length s <= 3
-        && T.all asciiDigit s
-        && (T.length s == 1 || T.head s /= '0')
-        && maybe False (<= 255) (readMaybe (T.unpack s) :: Maybe Int)
-
-isIPv6 :: Text -> Bool
-isIPv6 t
-  | T.any (== '%') t = False
-  | otherwise = case T.splitOn "::" t of
-      [full] -> groupCount True (segments full) == Just 8
-      [before, after] -> case (groupCount False (segments before), groupCount True (segments after)) of
-        (Just b, Just a) -> b + a <= 7 -- "::" stands for at least one omitted group
-        _ -> False
-      _ -> False
-  where
-    segments s = if T.null s then [] else T.splitOn ":" s
-
-groupCount :: Bool -> [Text] -> Maybe Int
-groupCount endsAddress gs
-  | null gs = Just 0
-  | endsAddress && isIPv4 (last gs) = (+ 2) <$> plainGroups (init gs)
-  | otherwise = plainGroups gs
-  where
-    plainGroups ps = if all hexGroup ps then Just (length ps) else Nothing
-    hexGroup g = not (T.null g) && T.length g <= 4 && T.all asciiHexDigit g
-
-peerText :: SockAddr -> Text
-peerText = \case
-  SockAddrInet _ addr ->
-    let (a, b, c, d) = hostAddressToTuple addr
-     in T.intercalate "." (map tshowInt [a, b, c, d])
-  SockAddrInet6 _ _ addr _ ->
-    let (a, b, c, d, e, f, g, h) = hostAddress6ToTuple addr
-     in T.intercalate ":" (map hex16 [a, b, c, d, e, f, g, h])
-  SockAddrUnix p -> "unix:" <> T.pack p
-  where
-    tshowInt :: Show a => a -> Text
-    tshowInt = T.pack . show
-    hex16 :: Word16 -> Text
-    hex16 w = T.pack (showHex w "")
-
-apiHeaders :: [Header]
-apiHeaders = [(hContentType, "application/json"), (hCacheControl, "no-store")]
-
-jsonResponse :: Status -> J.Value -> Response
-jsonResponse st = responseLBS st apiHeaders . J.encode
-
-jsonError :: Status -> Text -> Response
-jsonError st code = jsonResponse st (J.object ["error" .= code])
-
-notFound :: Response
-notFound = jsonError status404 "not_found"
-
-badRequest :: Response
-badRequest = jsonError status400 "bad_request"
-
 catalogChanged :: Response
 catalogChanged = jsonError status400 "catalog_changed"
 
-codeConflict :: Response
-codeConflict = jsonError status409 "code_conflict"
-
-providerUnavailable :: Response
-providerUnavailable = jsonError status503 "provider_unavailable"
-
-rateLimited :: Int -> Response
-rateLimited seconds =
-  responseLBS
-    status429
-    (("Retry-After", B.pack (show seconds)) : apiHeaders)
-    (J.encode (J.object ["error" .= ("rate_limited" :: Text)]))
-
-methodNotAllowed :: ByteString -> Response
-methodNotAllowed allow = responseLBS status405 (("Allow", allow) : apiHeaders) (J.encode (J.object ["error" .= ("method_not_allowed" :: Text)]))
-
-internalError :: Response
-internalError = jsonError status500 "internal"
-
 webhookOk, webhookRefused, webhookTooLarge :: Response
 webhookOk = webhookResponse status200
 webhookRefused = webhookResponse status400
@@ -274,23 +91,21 @@ webhookResponse :: Status -> Response
 webhookResponse st = responseLBS st [(hCacheControl, "no-store")] ""
 
 webApp :: WebEnv -> Application
-webApp env req respond = case pathInfo req of
-  [] | serving -> only "GET" $ case weShell env of
+webApp env@WebEnv {weHttp} req respond = case pathInfo req of
+  [] | serving -> only "GET" req respond $ case weShell env of
     Just shell -> respond (responseLBS status200 shellHeaders shell)
     Nothing -> serveStatic env ["index.html"] respond
-  "assets" : rest | serving -> only "GET" $ serveStatic env ("assets" : rest) respond
-  ["sw.js"] | serving -> only "GET" $ serveStatic env ["sw.js"] respond
-  ["api", "invoice"] -> only "POST" $ limited env createLimit req respond $ createInvoiceHandler env req respond
-  ["api", "invoice", iid] -> only "GET" $ limited env readLimit req respond $ readInvoiceHandler env (InvoiceId iid) req respond
-  ["api", "invoice", iid, "cancel"] -> only "POST" $ limited env createLimit req respond $ cancelInvoiceHandler env (InvoiceId iid) respond
-  ["webhooks", "btcpay"] -> only "POST" $ webhookHandler env PPCrypto "POST /webhooks/btcpay" req respond
-  ["webhooks", "stripe"] -> only "POST" $ webhookHandler env PPStripe "POST /webhooks/stripe" req respond
-  _ -> respond notFound
+  "assets" : rest | serving -> only "GET" req respond $ serveStatic env ("assets" : rest) respond
+  ["sw.js"] | serving -> only "GET" req respond $ serveStatic env ["sw.js"] respond
+  ["api", "invoice"] -> only "POST" req respond $ limited weHttp createLimit req respond $ createInvoiceHandler env req respond
+  ["api", "invoice", iid] -> only "GET" req respond $ limited weHttp readLimit req respond $ readInvoiceHandler env (InvoiceId iid) req respond
+  ["api", "invoice", iid, "cancel"] -> only "POST" req respond $ limited weHttp createLimit req respond $ cancelInvoiceHandler env (InvoiceId iid) respond
+  ["webhooks", "btcpay"] -> only "POST" req respond $ webhookHandler env PPCrypto "POST /webhooks/btcpay" req respond
+  ["webhooks", "stripe"] -> only "POST" req respond $ webhookHandler env PPStripe "POST /webhooks/stripe" req respond
+  _ -> fromMaybe (respond notFound) names
   where
     serving = lServeWebapp (listenerConfig env)
-    only method action
-      | requestMethod req == method = action
-      | otherwise = respond (methodNotAllowed method)
+    names = weNames env >>= \n -> namesApp weHttp (namesRoutes n) req respond
 
 -- | A @".."@ check would miss separators WAI has already decoded, an absolute path, and a symlink out of the tree.
 serveStatic :: WebEnv -> [Text] -> Respond -> IO ResponseReceived
@@ -610,19 +425,6 @@ providerOf = \case
   SPMCard CPStripe -> PPStripe
   SPMCrypto _ -> PPCrypto
 
--- | Returns the bytes exactly as they arrived, since the webhook signature is over those bytes.
-readBoundedBody :: Int -> Request -> IO (Maybe LB.ByteString)
-readBoundedBody cap req = go 0 []
-  where
-    go :: Int -> [ByteString] -> IO (Maybe LB.ByteString)
-    go read' acc = do
-      chunk <- getRequestBodyChunk req
-      if BS.null chunk
-        then pure (Just (LB.fromChunks (reverse acc)))
-        else
-          let read'' = read' + BS.length chunk
-           in if read'' > cap then pure Nothing else go read'' (chunk : acc)
-
 parseCreateRequest :: LB.ByteString -> Maybe CreateRequest
 parseCreateRequest body = case J.decode body of
   Just (J.Object o) -> do
@@ -649,17 +451,6 @@ methodFromText = \case
   "xmr" -> Just (SPMCrypto CCXmr)
   _ -> Nothing
 
--- | The last character of a 43-character base64 string has two bits no digest byte uses, so a lax
--- decoder would accept four spellings of the same digest, which the re-encode check rejects.
-parseCodeHash :: Text -> Maybe ByteString
-parseCodeHash t
-  | T.length t /= codeHashChars = Nothing
-  | otherwise = case B64U.decode (encodeUtf8 (t <> "=")) of
-      Right bytes | BS.length bytes == sha256Bytes, canonical bytes == t -> Just bytes
-      _ -> Nothing
-  where
-    canonical = T.filter (/= '=') . safeDecodeUtf8 . B64U.encode
-
 -- | A provider retries a delivery it sees fail, so anything thrown below is caught and answered 200 anyway.
 webhookHandler :: WebEnv -> PaymentProvider -> Text -> Request -> Respond -> IO ResponseReceived
 webhookHandler env@WebEnv {weStore, weHints} provider route req respond =

apps/simplex-store-service/store_service.ini.example

@@ -15,6 +15,11 @@ serve_webapp = on
 ; proxy's own address, so one bucket is shared by everyone. Set it off only where this
 ; listener is reached directly, since a client can write the header itself.
 trust_forwarded_for = on
+; the names site (simplex.domains): its build directory, the directory it is exported to for a
+; reverse proxy, and the comma-separated hosts it is served on in the all-in-one deployment
+; names_static_dir = /srv/names
+; names_export_dir = /srv/names-export
+; names_hosts = simplex.domains
 
 ; omit this whole section to disable Bitcoin and Monero (the browser shows the provider-unavailable screen)
 [btcpay]
@@ -60,3 +65,34 @@ idle_seconds = 60
 ;[group]
 ;display_name = SimpleX Badges
 ;description = Welcome to the badges group
+;
+; the names store: omit [names] and [chain] together to turn it off.
+;[names]
+; testing until the .simplex TLD is deployed
+;tld = testing
+; the paid years of a name; at least 2, the controller's minimum
+;years = 2
+; a name's term starts here; the days until then are free
+;term_start = 2027-01-01T00:00:00Z
+; how far an order's duration may be from the one the service computes
+;term_slack_seconds = 3600
+; a commitment with less than this left before its reveal deadline is not reused
+;reveal_margin_seconds = 900
+; how many times one order may move to another name
+;max_order_moves = 3
+;
+; the chain the names are registered on. rpc_url can carry a provider's API key and service_key
+; pays for every commit and register: keep both secret. Neither is ever logged.
+;[chain]
+;rpc_url = http://127.0.0.1:8545
+;chain_id = 31337
+;controller = 0x...
+;sponsor = 0x...
+;base_registrar = 0x...
+;resolver = 0x...
+; 0x and 64 hex digits: the registrar key the service sends transactions with
+;service_key = 0x...
+; blocks after a register's receipt before a name counts as registered
+;confirmations = 3
+; the most gas any one transaction may use
+;gas_limit_cap = 8000000

simplex-chat.cabal

@@ -442,6 +442,11 @@ executable simplex-store-service
       StoreService.Group
       StoreService.Group.Command
       StoreService.Log
+      StoreService.Names.Chain
+      StoreService.Names.Env
+      StoreService.Names.Phases
+      StoreService.Names.Registration
+      StoreService.Names.Turns
       StoreService.Options
       StoreService.Orders
       StoreService.Poller
@@ -453,6 +458,8 @@ executable simplex-store-service
       StoreService.Store.Invoices
       StoreService.Store.Migrate
       StoreService.Waiters
+      StoreService.Web.Http
+      StoreService.Web.Names
       StoreService.Web.Server
       Paths_simplex_chat
   ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -Werror=name-shadowing -threaded -rtsopts
@@ -738,6 +745,7 @@ test-suite simplex-chat-test
       Bots.StoreService.GroupIntegrationTests
       Bots.StoreService.GroupTests
       Bots.StoreService.NameRegistrationTests
+      Bots.StoreService.NamesWiringTests
       Bots.StoreService.StripeTests
       Bots.StoreService.WaitersTests
       Bots.StoreService.WebTests
@@ -760,7 +768,10 @@ test-suite simplex-chat-test
       StoreService.Group.Command
       StoreService.Log
       StoreService.Names.Chain
+      StoreService.Names.Env
+      StoreService.Names.Phases
       StoreService.Names.Registration
+      StoreService.Names.Turns
       StoreService.Options
       StoreService.Orders
       StoreService.Poller
@@ -772,6 +783,8 @@ test-suite simplex-chat-test
       StoreService.Store.Invoices
       StoreService.Store.Migrate
       StoreService.Waiters
+      StoreService.Web.Http
+      StoreService.Web.Names
       StoreService.Web.Server
       Paths_simplex_chat
   if flag(client_postgres)

tests/Bots/StoreService/ConfigTests.hs

@@ -4,12 +4,18 @@
 module Bots.StoreService.ConfigTests where
 
 import StoreService.Config
+import qualified Data.ByteArray as BA
 import qualified Data.ByteString.Char8 as B
 import Data.Either (isLeft)
 import Data.Ini (readIniFile)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
+import Data.Time.Calendar (fromGregorian)
+import Data.Time.Clock (UTCTime (..))
+import Simplex.Messaging.Crypto.Secp256k1 (mkPrivateKey)
 import Simplex.Messaging.Encoding.String (strDecode)
+import Simplex.Messaging.Eth.Address (Address)
+import Simplex.Messaging.SimplexName (SimplexTLD (..))
 import System.Directory (createDirectoryIfMissing)
 import System.FilePath ((</>))
 import Test.Hspec
@@ -408,3 +414,185 @@ testGroupAbsent :: IO ()
 testGroupAbsent = do
   r <- parseIni listenerIni
   fmap group r `shouldBe` Right Nothing
+
+namesConfigTests :: Spec
+namesConfigTests = describe "StoreService names: config" $ do
+  it "reads [names] and [chain], applying every documented default" testNamesDefaults
+  it "reads every [names] and [chain] setting written out" testNamesWrittenOut
+  it "reads the names keys of [listener]" testNamesListenerKeys
+  it "leaves the names side off when [names] is absent" testNamesAbsent
+  it "refuses [names] without [chain], and [chain] without [names]" testNamesNeedsChain
+  it "refuses years below 2" testNamesYearsBelowTwo
+  it "refuses a term_start that is not an ISO 8601 UTC time" testNamesBadTermStart
+  it "refuses a TLD other than simplex or testing" testNamesBadTLD
+  it "refuses a bad or wrongly checksummed contract address, naming the key" testNamesBadAddress
+  it "refuses a bad service key without quoting it" testNamesBadServiceKey
+  it "keeps the RPC URL and the service key out of errors and the shown config" testNamesSecretsHidden
+  it "names a [names] or [chain] setting nothing reads, and still boots" testNamesUnknownKeys
+
+rpcUrl :: T.Text
+rpcUrl = "https://eth.example.org/v2/rpc-token-value"
+
+-- anvil's first dev account, a real secp256k1 key
+serviceKeyHex :: T.Text
+serviceKeyHex = "0xac0974bec39a17e36ba4a6b4d238ff944bacb478cbed5efcae784d7bf4f2ff80"
+
+controllerAddr, sponsorAddr, registrarAddr, resolverAddr :: T.Text
+controllerAddr = "0x5aAeb6053F3E94C9b9A09f33669435E7Ef1BeAed"
+sponsorAddr = "0x0B306BF915C4d645ff596e518fAf3F9669b97016"
+registrarAddr = "0x014f9c09CcEeDEF1B713110d04D3a07d5B5D9b73"
+resolverAddr = "0x8A791620dd6260079BF849Dc5567aDC3F2FdC318"
+
+namesSection :: [T.Text]
+namesSection = ["[names]", "tld = testing"]
+
+chainSection :: [T.Text]
+chainSection =
+  [ "[chain]",
+    "rpc_url = " <> rpcUrl,
+    "chain_id = 31337",
+    "controller = " <> controllerAddr,
+    "sponsor = " <> sponsorAddr,
+    "base_registrar = " <> registrarAddr,
+    "resolver = " <> resolverAddr,
+    "service_key = " <> serviceKeyHex
+  ]
+
+namesIni :: [T.Text] -> [T.Text] -> T.Text
+namesIni ns cs = fullIni <> T.unlines (ns <> cs)
+
+namesRefusal :: [T.Text] -> [T.Text] -> IO String
+namesRefusal ns cs =
+  parseIni (namesIni ns cs) >>= \r -> case r of
+    Left e -> pure e
+    Right cfg -> expectationFailure ("must not boot, it read " <> show (names cfg)) >> pure ""
+
+parsedNames :: [T.Text] -> [T.Text] -> IO NamesConfig
+parsedNames ns cs =
+  parseIni (namesIni ns cs) >>= \r -> case r of
+    Right cfg -> maybe (fail "[names] was present but not read") pure (names cfg)
+    Left e -> fail ("must boot, but: " <> e)
+
+address :: HasCallStack => T.Text -> Address
+address t = either error id (strDecode (B.pack (T.unpack t)))
+
+testNamesDefaults :: IO ()
+testNamesDefaults = do
+  NamesConfig {nTLD, nYears, nTermStart, nTermSlackSeconds, nRevealMarginSeconds, nMaxOrderMoves, nChain} <- parsedNames namesSection chainSection
+  nTLD `shouldBe` TLDTesting
+  nYears `shouldBe` 2
+  nTermStart `shouldBe` UTCTime (fromGregorian 2027 1 1) 0
+  nTermSlackSeconds `shouldBe` 3600
+  nRevealMarginSeconds `shouldBe` 900
+  nMaxOrderMoves `shouldBe` 3
+  let ChainConfig {cRpcUrl, cChainId, cController, cSponsor, cBaseRegistrar, cResolver, cServiceKey, cConfirmations, cGasLimitCap} = nChain
+  cRpcUrl `shouldBe` T.unpack rpcUrl
+  cChainId `shouldBe` 31337
+  (cController, cSponsor, cBaseRegistrar, cResolver) `shouldBe` (address controllerAddr, address sponsorAddr, address registrarAddr, address resolverAddr)
+  Right expectedKey <- pure (mkPrivateKey (BA.pack [0xac, 0x09, 0x74, 0xbe, 0xc3, 0x9a, 0x17, 0xe3, 0x6b, 0xa4, 0xa6, 0xb4, 0xd2, 0x38, 0xff, 0x94, 0x4b, 0xac, 0xb4, 0x78, 0xcb, 0xed, 0x5e, 0xfc, 0xae, 0x78, 0x4d, 0x7b, 0xf4, 0xf2, 0xff, 0x80]))
+  (cServiceKey == expectedKey) `shouldBe` True
+  cConfirmations `shouldBe` 3
+  cGasLimitCap `shouldBe` 8000000
+
+testNamesWrittenOut :: IO ()
+testNamesWrittenOut = do
+  let ns = ["[names]", "tld = simplex", "years = 5", "term_start = 2027-03-01T12:00:00Z", "term_slack_seconds = 60", "reveal_margin_seconds = 0", "max_order_moves = 0"]
+      cs = chainSection <> ["confirmations = 0", "gas_limit_cap = 500000"]
+  NamesConfig {nTLD, nYears, nTermStart, nTermSlackSeconds, nRevealMarginSeconds, nMaxOrderMoves, nChain = ChainConfig {cConfirmations, cGasLimitCap}} <- parsedNames ns cs
+  nTLD `shouldBe` TLDSimplex
+  nYears `shouldBe` 5
+  nTermStart `shouldBe` UTCTime (fromGregorian 2027 3 1) (12 * 3600)
+  (nTermSlackSeconds, nRevealMarginSeconds, nMaxOrderMoves) `shouldBe` (60, 0, 0)
+  (cConfirmations, cGasLimitCap) `shouldBe` (0, 500000)
+  namesRefusal ns (chainSection <> ["confirmations = -1"]) `shouldReturn` "chain.confirmations must be at least 0"
+  namesRefusal ns (chainSection <> ["gas_limit_cap = 0"]) `shouldReturn` "chain.gas_limit_cap must be a positive whole number"
+  namesRefusal ns (filter (not . ("chain_id" `T.isPrefixOf`)) chainSection) `shouldReturn` "chain.chain_id is required"
+  namesRefusal (namesSection <> ["max_order_moves = -1"]) chainSection `shouldReturn` "names.max_order_moves must be at least 0"
+
+testNamesListenerKeys :: IO ()
+testNamesListenerKeys = do
+  let withKeys = T.replace "static_dir = /srv/badges\n" "static_dir = /srv/badges\nnames_static_dir = /srv/names\nnames_export_dir = /srv/names-out\nnames_hosts = simplex.domains, WWW.simplex.domains ,\n" fullIni
+  Right cfg <- parseIni withKeys
+  let ListenerConfig {lNamesStaticDir, lNamesExportDir, lNamesHosts} = listener cfg
+  lNamesStaticDir `shouldBe` Just "/srv/names"
+  lNamesExportDir `shouldBe` Just "/srv/names-out"
+  lNamesHosts `shouldBe` ["simplex.domains", "www.simplex.domains"]
+  Right plain <- parseIni fullIni
+  let ListenerConfig {lNamesStaticDir = noDir, lNamesExportDir = noExport, lNamesHosts = noHosts} = listener plain
+  (noDir, noExport, noHosts) `shouldBe` (Nothing, Nothing, [])
+
+testNamesAbsent :: IO ()
+testNamesAbsent = do
+  Right cfg <- parseIni fullIni
+  names cfg `shouldBe` Nothing
+
+testNamesNeedsChain :: IO ()
+testNamesNeedsChain = do
+  namesRefusal namesSection [] `shouldReturn` "[names] needs a [chain] section"
+  namesRefusal [] chainSection `shouldReturn` "[chain] is set but [names] is absent, so nothing would use it"
+
+testNamesYearsBelowTwo :: IO ()
+testNamesYearsBelowTwo = do
+  mapM_ (\v -> namesRefusal (namesSection <> ["years = " <> v]) chainSection `shouldReturn` "names.years must be at least 2") ["1", "0", "-2"]
+  NamesConfig {nYears} <- parsedNames (namesSection <> ["years = 2"]) chainSection
+  nYears `shouldBe` 2
+
+testNamesBadTermStart :: IO ()
+testNamesBadTermStart =
+  mapM_
+    (\v -> namesRefusal (namesSection <> ["term_start = " <> v]) chainSection >>= (`shouldContain` "names.term_start must be an ISO 8601 UTC time"))
+    ["2027-01-01", "2027-01-01T00:00:00", "2027-13-01T00:00:00Z", "1 January 2027"]
+
+testNamesBadTLD :: IO ()
+testNamesBadTLD = do
+  namesRefusal ["[names]", "tld = simplex.chat"] chainSection `shouldReturn` "names.tld must be simplex or testing, not simplex.chat"
+  namesRefusal ["[names]", "years = 2"] chainSection `shouldReturn` "names.tld is required"
+
+testNamesBadAddress :: IO ()
+testNamesBadAddress = do
+  let withSponsor v = map (\l -> if "sponsor =" `T.isPrefixOf` l then "sponsor = " <> v else l) chainSection
+      refused v = namesRefusal namesSection (withSponsor v) `shouldReturn` "chain.sponsor is not an Ethereum address"
+  -- the mixed-case form of sponsorAddr with one letter's case flipped fails its EIP-55 checksum
+  refused "0x0b306BF915C4d645ff596e518fAf3F9669b97016"
+  refused "0x0B306BF915C4d645ff596e518fAf3F9669b970"
+  refused "0x0B306BF915C4d645ff596e518fAf3F9669b97016ff"
+  refused "not-an-address"
+  NamesConfig {nChain = ChainConfig {cSponsor}} <- parsedNames namesSection (withSponsor (T.toLower sponsorAddr))
+  cSponsor `shouldBe` address sponsorAddr
+
+testNamesBadServiceKey :: IO ()
+testNamesBadServiceKey = do
+  let withKey v = map (\l -> if "service_key =" `T.isPrefixOf` l then "service_key = " <> v else l) chainSection
+      refused v = do
+        e <- namesRefusal namesSection (withKey v)
+        e `shouldBe` "chain.service_key must be 0x and 64 hex digits of a valid secp256k1 key"
+  refused (T.drop 2 serviceKeyHex)
+  refused (T.dropEnd 2 serviceKeyHex)
+  refused ("0x" <> T.replicate 64 "0")
+  -- the curve order n is not a valid key
+  refused "0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141"
+  refused "0xzz0974bec39a17e36ba4a6b4d238ff944bacb478cbed5efcae784d7bf4f2ff80"
+
+testNamesSecretsHidden :: IO ()
+testNamesSecretsHidden = do
+  let secretUrl = "ftp://eth.example.org/v2/rpc-token-value"
+      withUrl v = map (\l -> if "rpc_url =" `T.isPrefixOf` l then "rpc_url = " <> v else l) chainSection
+  e <- namesRefusal namesSection (withUrl secretUrl)
+  e `shouldBe` "chain.rpc_url must be an http or https URL"
+  e `shouldNotContain` "rpc-token-value"
+  other <- namesRefusal namesSection (chainSection <> ["confirmations = many"])
+  other `shouldNotContain` "rpc-token-value"
+  other `shouldNotContain` T.unpack (T.drop 2 serviceKeyHex)
+  Right cfg <- parseIni (namesIni namesSection chainSection)
+  show cfg `shouldNotContain` "rpc-token-value"
+  show cfg `shouldNotContain` T.unpack (T.drop 2 serviceKeyHex)
+  show cfg `shouldContain` "chain 31337"
+
+testNamesUnknownKeys :: IO ()
+testNamesUnknownKeys = do
+  let t = namesIni (namesSection <> ["yeers = 3"]) (chainSection <> ["rpc = x"])
+  withIni t $ \p -> do
+    Right ini <- readIniFile p
+    unknownKeys ini `shouldMatchList` ["names.yeers", "chain.rpc"]
+  NamesConfig {nYears} <- parsedNames (namesSection <> ["yeers = 3"]) (chainSection <> ["rpc = x"])
+  nYears `shouldBe` 2

tests/Bots/StoreService/NamesWiringTests.hs

@@ -0,0 +1,225 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Bots.StoreService.NamesWiringTests (namesWiringTests) where
+
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (async, concurrently_, replicateConcurrently_, wait)
+import qualified Control.Concurrent.Async as Async
+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
+import Control.Concurrent.STM
+import qualified Control.Exception as E
+import Control.Monad (replicateM_)
+import qualified Data.Aeson as J
+import qualified Data.Aeson.KeyMap as KM
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as LB
+import Data.Maybe (fromMaybe, isNothing)
+import Network.HTTP.Client (Manager, Response, defaultManagerSettings, httpLbs, newManager, parseRequest, responseBody, responseHeaders, responseStatus)
+import qualified Network.HTTP.Client as HTTP
+import Network.HTTP.Types (Method, hCacheControl, hContentType, status200)
+import Network.HTTP.Types.Status (statusCode)
+import qualified Network.Wai.Handler.Warp as Warp
+import Simplex.Messaging.SimplexName (labelHash)
+import StoreService.Config (ListenerConfig (..))
+import StoreService.Names.Phases
+import StoreService.Names.Turns
+import StoreService.Web.Http
+import StoreService.Web.Names (Route (..), namesApp)
+import System.Timeout (timeout)
+import Test.Hspec
+
+namesWiringTests :: Spec
+namesWiringTests = describe "StoreService names: wiring" $ do
+  describe "phases" $ do
+    it "wakes a waiter on a newer published version, not on an older or the same one" testPublishWakesOnNewer
+    it "answers at once when the version read is not the one seen" testVersionAlreadyMoved
+    it "catches a publish that lands between subscribing and reading" testPublishBeforeRead
+    it "gives up after the hold when nothing is published" testHoldTimesOut
+    it "is not woken by another registration's publish" testOtherRegistration
+  describe "router" $ do
+    it "answers a known path with another method 405 with Allow, spending no token" testWrongMethod
+    it "leaves an unknown path to the caller" testUnknownPath
+  describe "turns" $ do
+    it "runs two holders of one label hash one after the other" testOneLabelSerialized
+    it "runs holders of different label hashes at once" testDifferentLabelsConcurrent
+    it "runs two holders of one code hash one after the other" testOneCodeSerialized
+    it "holds both label hashes in withLabelTurns, and one when they are equal" testLabelTurnsHoldBoth
+    it "never deadlocks withLabelTurns A->B against B->A" testLabelTurnsNoDeadlock
+    it "releases a turn whose holder throws" testTurnReleasedOnThrow
+
+-- | Long enough that only a missed wake-up could make a test wait it out.
+longHold :: Int
+longHold = 10000000
+
+-- | How long a test waits for something that must happen promptly.
+prompt :: Int
+prompt = 2000000
+
+parkDelay :: Int
+parkDelay = 100000
+
+rid1, rid2 :: RegistrationId
+rid1 = RegistrationId "reg-1"
+rid2 = RegistrationId "reg-2"
+
+testPublishWakesOnNewer :: IO ()
+testPublishWakesOnNewer = do
+  phases <- newPhases
+  parked <- newEmptyMVar
+  waiter <- async $ awaitChange phases rid1 (putMVar parked () >> pure 3) 3 longHold
+  takeMVar parked
+  atomically $ publish phases rid1 2
+  atomically $ publish phases rid1 3
+  threadDelay parkDelay
+  Async.poll waiter >>= (`shouldSatisfy` isNothing)
+  atomically $ publish phases rid1 4
+  timeout prompt (wait waiter) `shouldReturn` Just True
+
+testVersionAlreadyMoved :: IO ()
+testVersionAlreadyMoved = do
+  phases <- newPhases
+  timeout prompt (awaitChange phases rid1 (pure 5) 3 longHold) `shouldReturn` Just True
+
+testPublishBeforeRead :: IO ()
+testPublishBeforeRead = do
+  phases <- newPhases
+  -- the row read here is the old one, though version 4 was committed and published while it ran
+  let staleRead = atomically (publish phases rid1 4) >> pure 3
+  timeout prompt (awaitChange phases rid1 staleRead 3 longHold) `shouldReturn` Just True
+
+testHoldTimesOut :: IO ()
+testHoldTimesOut = do
+  phases <- newPhases
+  timeout prompt (awaitChange phases rid1 (pure 3) 3 parkDelay) `shouldReturn` Just False
+
+testOtherRegistration :: IO ()
+testOtherRegistration = do
+  phases <- newPhases
+  parked <- newEmptyMVar
+  waiter <- async $ awaitChange phases rid1 (putMVar parked () >> pure 1) 1 (3 * parkDelay)
+  takeMVar parked
+  atomically $ publish phases rid2 7
+  timeout prompt (wait waiter) `shouldReturn` Just False
+
+type Client = (Manager, String)
+
+probeLimit :: Limit
+probeLimit = Limit {lmName = "probe", lmPerMinute = 1}
+
+withProbeRouter :: (Client -> IO a) -> IO a
+withProbeRouter action = do
+  http <- newHttpEnv ListenerConfig {lHost = "127.0.0.1", lPort = 0, lStaticDir = "", lServeWebapp = False, lWebappExportDir = Nothing, lTrustForwardedFor = False, lNamesStaticDir = Nothing, lNamesExportDir = Nothing, lNamesHosts = []}
+  let routes = \case
+        ["api", "probe", _] -> Just Route {rMethod = "GET", rLimit = probeLimit, rHandler = \_ respond -> respond (jsonResponse status200 (J.object []))}
+        _ -> Nothing
+      app req respond = fromMaybe (respond notFound) (namesApp http routes req respond)
+  mgr <- newManager defaultManagerSettings
+  Warp.testWithApplication (pure app) $ \port -> action (mgr, "http://127.0.0.1:" <> show port)
+
+send :: Client -> Method -> String -> IO (Response LB.ByteString)
+send (mgr, base) verb target = do
+  req <- parseRequest (base <> target)
+  httpLbs req {HTTP.method = verb} mgr
+
+errorTag :: Response LB.ByteString -> Maybe J.Value
+errorTag r = case J.decode (responseBody r) of
+  Just (J.Object o) -> KM.lookup "error" o
+  _ -> Nothing
+
+testWrongMethod :: IO ()
+testWrongMethod = withProbeRouter $ \client -> do
+  replicateM_ 2 $ do
+    r <- send client "POST" "/api/probe/x"
+    statusCode (responseStatus r) `shouldBe` 405
+    lookup "Allow" (responseHeaders r) `shouldBe` Just "GET"
+    lookup hContentType (responseHeaders r) `shouldBe` Just "application/json"
+    lookup hCacheControl (responseHeaders r) `shouldBe` Just "no-store"
+    errorTag r `shouldBe` Just (J.String "method_not_allowed")
+  allowed <- send client "GET" "/api/probe/x"
+  statusCode (responseStatus allowed) `shouldBe` 200
+  limitedR <- send client "GET" "/api/probe/x"
+  statusCode (responseStatus limitedR) `shouldBe` 429
+  errorTag limitedR `shouldBe` Just (J.String "rate_limited")
+  lookup "Retry-After" (responseHeaders limitedR) `shouldSatisfy` maybe False (BC.all (`elem` ['0' .. '9']))
+
+testUnknownPath :: IO ()
+testUnknownPath = withProbeRouter $ \client -> do
+  r <- send client "POST" "/api/probe"
+  statusCode (responseStatus r) `shouldBe` 404
+  errorTag r `shouldBe` Just (J.String "not_found")
+
+-- | Runs the holders concurrently and returns the most that were inside at once.
+mostInside :: Int -> ((IO () -> IO ()) -> IO ()) -> IO Int
+mostInside n holder = do
+  inside <- newTVarIO (0 :: Int)
+  most <- newTVarIO 0
+  let enter = atomically $ do
+        k <- (+ 1) <$> readTVar inside
+        writeTVar inside k
+        modifyTVar' most (max k)
+      leave = atomically $ modifyTVar' inside (subtract 1)
+  replicateConcurrently_ n $ holder (\work -> enter >> work >> leave)
+  readTVarIO most
+
+testOneLabelSerialized :: IO ()
+testOneLabelSerialized = do
+  turns <- newTurns
+  r <- timeout (5 * prompt) $ mostInside 8 $ \inTurn -> withLabelTurn turns (labelHash "alice1") (inTurn (threadDelay 20000))
+  r `shouldBe` Just 1
+
+testOneCodeSerialized :: IO ()
+testOneCodeSerialized = do
+  turns <- newTurns
+  r <- timeout (5 * prompt) $ mostInside 8 $ \inTurn -> withCodeTurn turns (BC.replicate 32 'c') (inTurn (threadDelay 20000))
+  r `shouldBe` Just 1
+
+-- | Each holder waits inside its turn for the other to be inside its own, which only concurrent turns allow.
+testDifferentLabelsConcurrent :: IO ()
+testDifferentLabelsConcurrent = do
+  turns <- newTurns
+  aInside <- newEmptyMVar
+  bInside <- newEmptyMVar
+  r <-
+    timeout prompt $
+      concurrently_
+        (withLabelTurn turns (labelHash "alice1") (putMVar aInside () >> takeMVar bInside))
+        (withLabelTurn turns (labelHash "bobby2") (putMVar bInside () >> takeMVar aInside))
+  r `shouldBe` Just ()
+
+testLabelTurnsHoldBoth :: IO ()
+testLabelTurnsHoldBoth = do
+  turns <- newTurns
+  let a = labelHash "alice1"
+      b = labelHash "bobby2"
+  withLabelTurns turns a b $ do
+    timeout parkDelay (withLabelTurn turns a (pure ())) `shouldReturn` Nothing
+    timeout parkDelay (withLabelTurn turns b (pure ())) `shouldReturn` Nothing
+  timeout prompt (withLabelTurns turns a a (pure ())) `shouldReturn` Just ()
+
+testLabelTurnsNoDeadlock :: IO ()
+testLabelTurnsNoDeadlock = do
+  turns <- newTurns
+  let a = labelHash "alice1"
+      b = labelHash "bobby2"
+      rounds = 200
+  r <-
+    timeout (5 * prompt) $
+      concurrently_
+        (replicateConcurrently_ rounds (withLabelTurns turns a b (threadDelay 50)))
+        (replicateConcurrently_ rounds (withLabelTurns turns b a (threadDelay 50)))
+  r `shouldBe` Just ()
+
+data Boom = Boom
+  deriving (Show)
+
+instance E.Exception Boom
+
+testTurnReleasedOnThrow :: IO ()
+testTurnReleasedOnThrow = do
+  turns <- newTurns
+  let a = labelHash "alice1"
+  E.try (withLabelTurn turns a (E.throwIO Boom)) >>= \case
+    Left Boom -> pure ()
+    Right () -> expectationFailure "the holder's exception must reach the caller"
+  timeout prompt (withLabelTurn turns a (pure ())) `shouldReturn` Just ()

tests/Bots/StoreService/WebTests.hs

@@ -17,6 +17,7 @@ import StoreService.Providers.Stripe (stripeProvider)
 import StoreService.Store (KeyPurchase (..), KeyRedemption (..), ManagedGroup (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getCodePurchaseForKey, getManagedGroup, insertBadgeCode, insertManagedGroup, markOwnerBootstrapped, revokeCode)
 import StoreService.Store.Invoices
 import StoreService.Waiters (awaitStatus, newWaiters, publish, waitingCount)
+import StoreService.Web.Http
 import StoreService.Web.Server
 import Bots.StoreService.BotTests (codeCounts, newPurchaseKeys)
 import Bots.StoreService.CatalogTests (WebOffer (..), WebPrice (..), parseCatalogSource)
@@ -974,12 +975,13 @@ prepareStaticDir root = do
 testServiceConfig :: FilePath -> Bool -> ServiceConfig
 testServiceConfig staticDir trustForwarded =
   ServiceConfig
-    { listener = ListenerConfig {lHost = "127.0.0.1", lPort = 0, lStaticDir = staticDir, lServeWebapp = True, lWebappExportDir = Nothing, lTrustForwardedFor = trustForwarded},
+    { listener = ListenerConfig {lHost = "127.0.0.1", lPort = 0, lStaticDir = staticDir, lServeWebapp = True, lWebappExportDir = Nothing, lTrustForwardedFor = trustForwarded, lNamesStaticDir = Nothing, lNamesExportDir = Nothing, lNamesHosts = []},
       btcpay = Nothing,
       stripe = Nothing,
       poll = PollConfig {pWaitingSeconds = 3, pIdleSeconds = 60},
       issuer = Nothing,
-      group = Nothing
+      group = Nothing,
+      names = Nothing
     }
 
 testServeWebappOff :: IO ()
@@ -1003,7 +1005,7 @@ testExportWebapp = do
   withTempDirectory "tests/tmp" "badge-export" $ \root -> do
     staticDir <- prepareStaticDir root
     let outDir = root </> "out"
-        lc = ListenerConfig {lHost = "127.0.0.1", lPort = 0, lStaticDir = staticDir, lServeWebapp = False, lWebappExportDir = Just outDir, lTrustForwardedFor = False}
+        lc = ListenerConfig {lHost = "127.0.0.1", lPort = 0, lStaticDir = staticDir, lServeWebapp = False, lWebappExportDir = Just outDir, lTrustForwardedFor = False, lNamesStaticDir = Nothing, lNamesExportDir = Nothing, lNamesHosts = []}
         stripeCfg = Just StripeConfig {sSecretKey = "rk_test_x", sPublishableKey = "pk_test_injected", sWebhookSecret = "whsec_x", sSessionMinutes = 60, sHost = "https://api.stripe.com"}
     exportWebapp lc stripeCfg
     idx <- LB.readFile (outDir </> "index.html")
@@ -1038,7 +1040,7 @@ withListener providers rethrow hold st cfg action = do
   let runner = if rethrow then Warp.testWithApplicationSettings else Warp.withApplicationSettings
   waiters <- newWaiters
   hints <- newReadHints
-  built <- newWebEnv st cfg waiters hints providers
+  built <- newWebEnv st cfg waiters hints providers Nothing
   let env = built {weHoldMicros = hold}
   mgr <- newManager defaultManagerSettings
   runner (webSettings (listener cfg)) (pure (webApp env)) $ \prt ->
@@ -1433,23 +1435,23 @@ testForwardedForMustBeAnAddress = bounded "forwarded-for is an address" $ withWe
 testBucketsStayBounded :: IO ()
 testBucketsStayBounded = bounded "bucket cap" $ withWebApp $ \env _ -> do
   let clients = map (\i -> T.pack ("198.51." <> show (i `div` 256) <> "." <> show (i `mod` 256))) [1 .. maxBuckets * 2 + 100]
-  mapM_ (takeToken env readLimit) clients
-  held <- Map.size <$> readTVarIO (weBuckets env)
+  mapM_ (takeToken (weHttp env) readLimit) clients
+  held <- Map.size <$> readTVarIO (heBuckets (weHttp env))
   held `shouldSatisfy` \n -> n > 0 && n <= maxBuckets
-  answers <- mapM (\_ -> takeToken env readLimit "203.0.113.9") [1 .. readsPerMinute + 1]
+  answers <- mapM (\_ -> takeToken (weHttp env) readLimit "203.0.113.9") [1 .. readsPerMinute + 1]
   length (filter isJust answers) `shouldBe` 1
 
   let fill i = do
-        n <- Map.size <$> readTVarIO (weBuckets env)
+        n <- Map.size <$> readTVarIO (heBuckets (weHttp env))
         when (n < maxBuckets) $ do
-          _ <- takeToken env readLimit (T.pack ("192.0." <> show (i `div` 256) <> "." <> show (i `mod` 256)))
+          _ <- takeToken (weHttp env) readLimit (T.pack ("192.0." <> show (i `div` 256) <> "." <> show (i `mod` 256)))
           fill (i + 1)
   fill (1 :: Int)
-  atTheCap <- Map.size <$> readTVarIO (weBuckets env)
+  atTheCap <- Map.size <$> readTVarIO (heBuckets (weHttp env))
   atTheCap `shouldBe` maxBuckets
-  refusedAgain <- takeToken env readLimit "203.0.113.9"
+  refusedAgain <- takeToken (weHttp env) readLimit "203.0.113.9"
   refusedAgain `shouldSatisfy` isJust
-  afterARefusal <- Map.size <$> readTVarIO (weBuckets env)
+  afterARefusal <- Map.size <$> readTVarIO (heBuckets (weHttp env))
   afterARefusal `shouldSatisfy` (<= atTheCap `div` 2 + 1)
 
 testHoldReportsTheRowNotTheWake :: IO ()

tests/Test.hs

@@ -10,6 +10,7 @@ import Bots.StoreService.ConfigTests
 import Bots.StoreService.GroupIntegrationTests
 import Bots.StoreService.GroupTests
 import Bots.StoreService.NameRegistrationTests
+import Bots.StoreService.NamesWiringTests
 import Bots.StoreService.StripeTests
 import Bots.StoreService.WaitersTests
 import Bots.StoreService.WebTests
@@ -86,6 +87,8 @@ main = do
         badgeBTCPayTests
         badgeStripeTests
         badgeNameRegistrationTests
+      namesConfigTests
+      namesWiringTests
       describe "SimpleX chat markdown" markdownTests
       describe "JSON Tests" jsonTests
       describe "Member relations" memberRelationsTests