From 83393b04ea36908a975ec12a95e698d16e426749 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 29 Oct 2026 10:25:58 +0000 Subject: [PATCH] store: serve the names shell in codes mode --- .../src/StoreService/Service.hs | 2 +- .../src/StoreService/Web/Server.hs | 58 ++++++++----- tests/Bots/StoreService/WebTests.hs | 85 +++++++++++++++++-- 3 files changed, 114 insertions(+), 31 deletions(-) diff --git a/apps/simplex-store-service/src/StoreService/Service.hs b/apps/simplex-store-service/src/StoreService/Service.hs index efcd064731..965c0db1f3 100644 --- a/apps/simplex-store-service/src/StoreService/Service.hs +++ b/apps/simplex-store-service/src/StoreService/Service.hs @@ -288,7 +288,7 @@ storeService opts@StoreServiceOpts {serviceConfigFile} baseCfg env = do hints <- newReadHints namesEnv <- forM (names sc) (startNames cc turns ws providers) webEnv <- newWebEnv chatStore sc ws hints providers namesEnv - exportWebapp (listener sc) (stripe sc) + exportWebapp sc pollerEnv <- newPollerEnv chatStore ws (nePhases <$> namesEnv) hints providers (poll sc) nameLanes <- maybe (pure []) namesLanes namesEnv pure $ [runWebListeners webEnv, runPoller pollerEnv] <> nameLanes diff --git a/apps/simplex-store-service/src/StoreService/Web/Server.hs b/apps/simplex-store-service/src/StoreService/Web/Server.hs index eba9f2943a..3787315986 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Server.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Server.hs @@ -17,7 +17,7 @@ module StoreService.Web.Server where import StoreService.Catalog (PricedOffer (..), priceOffer) -import StoreService.Config (ListenerConfig (..), ServiceConfig (..), StripeConfig (..), isLoopbackHost) +import StoreService.Config (ListenerConfig (..), NamesConfig (..), ServiceConfig (..), StripeConfig (..), isLoopbackHost) import StoreService.Names.Abi (hex) import StoreService.Names.Env (NamesEnv) import StoreService.Names.Orders (OrdersEnv (..), ordersEnv) @@ -86,19 +86,19 @@ data WebEnv = WebEnv -- | A built site, served when @serve_webapp@ is on. data Site = Site { siteDir :: FilePath, - -- | @Nothing@ when no Stripe key is configured, and the pristine shell is served instead. + -- | @Nothing@ when the shell has nothing to fill, and the pristine one is served instead. siteShell :: Maybe LB.ByteString } newWebEnv :: DBStore -> ServiceConfig -> Waiters -> ReadHints -> [Provider] -> Maybe NamesEnv -> IO WebEnv newWebEnv weStore weConfig weWaiters weHints weProviders weNames = do weHttp <- newHttpEnv lc - weBadgesSite <- if lServeWebapp then Just <$> loadSite lBadgesStaticDir else pure Nothing - weNamesSite <- mapM loadSite (lNamesPort *> lNamesStaticDir) + weBadgesSite <- if lServeWebapp then Just <$> loadSite (keyFills weConfig) lBadgesStaticDir else pure Nothing + weNamesSite <- mapM (loadSite (namesFills weConfig)) (lNamesPort *> lNamesStaticDir) pure WebEnv {weStore, weConfig, weWaiters, weProviders, weHoldMicros = holdMicros, weHints, weHttp, weBadgesSite, weNamesSite, weNames, weOrders = ordersEnv <$> weNames} where lc@ListenerConfig {lServeWebapp, lBadgesStaticDir, lNamesStaticDir, lNamesPort} = listener weConfig - loadSite dir = Site dir <$> prepareShell dir (stripe weConfig) + loadSite fills dir = Site dir <$> prepareShell dir fills listenerConfig :: WebEnv -> ListenerConfig listenerConfig WebEnv {weConfig} = listener weConfig @@ -153,14 +153,30 @@ serveSite Site {siteDir, siteShell} path respond = shellFile :: FilePath shellFile = "index.html" --- | The badges shell also has an @id@ before @name@, and the names shell has none. -publishableKeyMeta :: Text -publishableKeyMeta = "name=\"stripe-publishable-key\" content=\"" +-- | A meta tag of the shell by its name, the content the build ships it with, and the content served instead. +type MetaFill = (Text, Text, Text) --- | @Nothing@ (serve the pristine file) when no key is set, no shell is present, or it cannot be read. -prepareShell :: FilePath -> Maybe StripeConfig -> IO (Maybe LB.ByteString) -prepareShell _ Nothing = pure Nothing -prepareShell dir (Just StripeConfig {sPublishableKey}) = +-- | The badges shell also has an @id@ before @name@, and the names shell has none. +fillMeta :: MetaFill -> Text -> Text +fillMeta (name, shipped, served) = T.replace (meta shipped) (meta served) + where + meta content = "name=\"" <> name <> "\" content=\"" <> content <> "\"" + +keyFills :: ServiceConfig -> [MetaFill] +keyFills ServiceConfig {stripe} = [("stripe-publishable-key", "", sPublishableKey) | Just StripeConfig {sPublishableKey} <- [stripe]] + +-- | The badges site's shell never carries the names mode. +namesFills :: ServiceConfig -> [MetaFill] +namesFills cfg@ServiceConfig {names} = keyFills cfg <> [codesMode | Just NamesConfig {nCodesOnly = True} <- [names]] + +-- | The page offers only prepaid codes when it reads this mode. +codesMode :: MetaFill +codesMode = ("simplex-names-mode", "open", "codes") + +-- | @Nothing@ (serve the pristine file) when there is nothing to fill, no shell is present, or it cannot be read. +prepareShell :: FilePath -> [MetaFill] -> IO (Maybe LB.ByteString) +prepareShell _ [] = pure Nothing +prepareShell dir fills = E.try attempt >>= \case Right out -> pure out Left (e :: E.IOException) -> do @@ -180,17 +196,18 @@ prepareShell dir (Just StripeConfig {sPublishableKey}) = Left e -> do logWarn ("the shell in " <> T.pack dir <> " is not valid UTF-8, serving the pristine one: " <> tshow e) pure Nothing - Right html -> pure (Just (LB.fromStrict (encodeUtf8 (injectPublishableKey sPublishableKey html)))) + Right html -> pure (Just (LB.fromStrict (encodeUtf8 (foldr fillMeta html fills)))) -exportWebapp :: ListenerConfig -> Maybe StripeConfig -> IO () -exportWebapp ListenerConfig {lBadgesStaticDir, lBadgesExportDir, lNamesStaticDir, lNamesExportDir} stripeCfg = do - forM_ lBadgesExportDir $ exportSite lBadgesStaticDir - forM_ ((,) <$> lNamesStaticDir <*> lNamesExportDir) $ uncurry exportSite +exportWebapp :: ServiceConfig -> IO () +exportWebapp cfg = do + forM_ lBadgesExportDir $ exportSite (keyFills cfg) lBadgesStaticDir + forM_ ((,) <$> lNamesStaticDir <*> lNamesExportDir) $ uncurry (exportSite (namesFills cfg)) where - exportSite dir out = do + ListenerConfig {lBadgesStaticDir, lBadgesExportDir, lNamesStaticDir, lNamesExportDir} = listener cfg + exportSite fills dir out = do emptyDir out copyTree dir out - prepareShell dir stripeCfg >>= mapM_ (LB.writeFile (out shellFile)) + prepareShell dir fills >>= mapM_ (LB.writeFile (out shellFile)) logInfo ("store service: exported " <> T.pack dir <> " to " <> T.pack out) -- | Contents only: the directory itself may be a bind or volume mount point that cannot be removed. @@ -209,9 +226,6 @@ copyTree src dst = do listDirectory src >>= mapM_ (\e -> copyTree (src e) (dst e)) else copyFile src dst -injectPublishableKey :: Text -> Text -> Text -injectPublishableKey key = T.replace (publishableKeyMeta <> "\"") (publishableKeyMeta <> key <> "\"") - resolveInside :: FilePath -> [Text] -> IO (Maybe (FilePath, FilePath)) resolveInside dir segments = either ioFailed id <$> E.try attempt where diff --git a/tests/Bots/StoreService/WebTests.hs b/tests/Bots/StoreService/WebTests.hs index 4422256799..6238734c4e 100644 --- a/tests/Bots/StoreService/WebTests.hs +++ b/tests/Bots/StoreService/WebTests.hs @@ -31,11 +31,16 @@ module Bots.StoreService.WebTests fieldOf, rcv, bounded, + seedCheckoutCatalog, + createBody, + supporterPriceId, + codeHashText, + sampleCode, ) where import StoreService.Catalog (catalogCurrency, defaultCatalog) -import StoreService.Config (BTCPayConfig (..), ListenerConfig (..), PollConfig (..), ServiceConfig (..), SpeedPolicy (..), StripeConfig (..)) +import StoreService.Config (BTCPayConfig (..), ListenerConfig (..), NamesConfig, PollConfig (..), ServiceConfig (..), SpeedPolicy (..), StripeConfig (..)) import StoreService.Log (logInfo) import StoreService.Names.Abi (hex) import StoreService.Orders (cancelOpenInvoice, codeLifetime, expireOverdue, settleOrder) @@ -51,6 +56,7 @@ import StoreService.Web.Http import StoreService.Web.Server import Bots.StoreService.BotTests (codeCounts, newPurchaseKeys) import Bots.StoreService.CatalogTests (WebOffer (..), WebPrice (..), parseCatalogSource) +import Bots.StoreService.ConfigTests (chainSection, namesSection, parsedNames) import Bots.StoreService.FakeBTCPay import Bots.StoreService.FakeStripe (FakeStripe (..), fakeIntentStatus, setIntentState, stripeEvent, stripeSigHeader, withFakeStripe) import Control.Concurrent (forkIO, threadDelay) @@ -258,6 +264,9 @@ badgeWebTests = do it "logs a handler exception as one service log record, never a bare line" testHandlerExceptionIsLogged describe "StoreService names: sites" $ do it "exports both sites, each with the publishable key" testExportsBothSites + it "serves the names shell in codes mode with codes_only on, with or without a publishable key, and the badges shell without it" testServesCodesMode + it "serves the names shell as built with codes_only off" testServesOpenMode + it "exports the names shell in codes mode only with codes_only on, and the badges shell as built" testExportsCodesMode it "serves each site on its own port only, whatever the Host, and the API on both" testEachPortServesItsSite it "listens on the badges port alone without the names site" testOneListenerWithoutTheNamesSite it "serves a names asset with its type" testServesANamesAsset @@ -1260,17 +1269,28 @@ testExportWebapp = do let outDir = root "out" lc = ListenerConfig {lHost = "127.0.0.1", lBadgesPort = 0, lBadgesStaticDir = staticDir, lServeWebapp = False, lBadgesExportDir = Just outDir, lTrustForwardedFor = False, lNamesStaticDir = Nothing, lNamesExportDir = Nothing, lNamesPort = Nothing} stripeCfg = Just StripeConfig {sSecretKey = "rk_test_x", sPublishableKey = "pk_test_injected", sWebhookSecret = "whsec_x", sSessionMinutes = 60, sHost = "https://api.stripe.com"} - exportWebapp lc stripeCfg + exportWebapp (testServiceConfig staticDir False) {listener = lc, stripe = stripeCfg} idx <- LB.readFile (outDir "index.html") LB.toStrict idx `shouldSatisfy` BC.isInfixOf "content=\"pk_test_injected\"" LB.readFile (outDir "sw.js") >>= (`shouldBe` workerJs) LB.readFile (outDir "assets" buildHash "main.js") >>= (`shouldBe` assetJs) +-- | The names shell with its publishable key and its mode. +namesShellAs :: LB.ByteString -> LB.ByteString -> LB.ByteString +namesShellAs key mode = "simplex.domains key <> "\">" <> namesModeMeta mode + +namesModeMeta :: LB.ByteString -> LB.ByteString +namesModeMeta mode = " mode <> "\">" + namesShellHtml :: LB.ByteString -namesShellHtml = "simplex.domains" +namesShellHtml = namesShellAs "" "open" namesShellWithKey :: LB.ByteString -namesShellWithKey = "simplex.domains" +namesShellWithKey = namesShellAs "pk_test_injected" "open" + +-- | A badges shell carrying the names mode too, so a fill meant only for the names shell shows on it. +badgesShellWithMode :: LB.ByteString -> LB.ByteString +badgesShellWithMode key = "SimpleX badges key <> "\">" <> namesModeMeta "open" namesFont :: LB.ByteString namesFont = "wOF2 Manrope Bold" @@ -1298,8 +1318,9 @@ testExportsBothSites = do namesDir <- prepareNamesDir root let badgesOut = root "badges-out" namesOut = root "names-out" - lc = (listener (testServiceConfig staticDir False)) {lServeWebapp = False, lBadgesExportDir = Just badgesOut, lNamesStaticDir = Just namesDir, lNamesExportDir = Just namesOut} - exportWebapp lc (Just publishTestStripe) + base = testServiceConfig staticDir False + lc = (listener base) {lServeWebapp = False, lBadgesExportDir = Just badgesOut, lNamesStaticDir = Just namesDir, lNamesExportDir = Just namesOut} + exportWebapp base {listener = lc, stripe = Just publishTestStripe} badgesShell <- LB.readFile (badgesOut "index.html") LB.toStrict badgesShell `shouldSatisfy` BC.isInfixOf "content=\"pk_test_injected\"" LB.readFile (badgesOut "assets" buildHash "main.js") >>= (`shouldBe` assetJs) @@ -1311,20 +1332,68 @@ testExportsBothSites = do -- | The badges site's client and the names site's, each on the port the env listens on for it. withBothSites :: (WebClient -> WebClient -> IO a) -> IO a -withBothSites action = +withBothSites = withBothSitesAs (\cfg -> cfg {stripe = Just publishTestStripe}) + +-- | With the settings changed, the badges shell carrying the names mode. +withBothSitesAs :: (ServiceConfig -> ServiceConfig) -> (WebClient -> WebClient -> IO a) -> IO a +withBothSitesAs settings action = withServiceStore $ \st -> do createDirectoryIfMissing True "tests/tmp" withTempDirectory "tests/tmp" "names-static" $ \root -> do staticDir <- prepareStaticDir root + LB.writeFile (staticDir "index.html") (badgesShellWithMode "") namesDir <- prepareNamesDir root let base = testServiceConfig staticDir True - cfg = base {listener = (listener base) {lBadgesPort = 8080, lNamesStaticDir = Just namesDir, lNamesPort = Just 8081}, stripe = Just publishTestStripe} + cfg = settings base {listener = (listener base) {lBadgesPort = 8080, lNamesStaticDir = Just namesDir, lNamesPort = Just 8081}} withListener [] True holdMicros st cfg $ \env badges@(mgr, _) -> do map fst (webListeners env) `shouldBe` [8080, 8081] [_, (_, namesSite)] <- pure (webListeners env) Warp.testWithApplicationSettings (webSettings (listener cfg)) (pure namesSite) $ \prt -> action badges (mgr, "http://127.0.0.1:" <> show prt) +-- | The [names] settings read from the ini, with codes_only on or off. +namesWithCodesOnly :: Bool -> IO NamesConfig +namesWithCodesOnly on = parsedNames (namesSection <> ["codes_only = " <> if on then "on" else "off"]) chainSection + +shells :: WebClient -> WebClient -> IO ((Int, LB.ByteString), (Int, LB.ByteString)) +shells badges namesSite = (,) <$> shellOf badges <*> shellOf namesSite + where + shellOf client = (\r -> (statusOf r, responseBody r)) <$> webGet client "/" + +testServesCodesMode :: IO () +testServesCodesMode = bounded "codes mode served" $ do + codesOnly <- namesWithCodesOnly True + withBothSitesAs (\cfg -> cfg {names = Just codesOnly}) $ \badges namesSite -> + shells badges namesSite `shouldReturn` ((200, badgesShellWithMode ""), (200, namesShellAs "" "codes")) + withBothSitesAs (\cfg -> cfg {names = Just codesOnly, stripe = Just publishTestStripe}) $ \badges namesSite -> + shells badges namesSite `shouldReturn` ((200, badgesShellWithMode "pk_test_injected"), (200, namesShellAs "pk_test_injected" "codes")) + +testServesOpenMode :: IO () +testServesOpenMode = bounded "open mode served" $ do + open <- namesWithCodesOnly False + withBothSitesAs (\cfg -> cfg {names = Just open}) $ \badges namesSite -> + shells badges namesSite `shouldReturn` ((200, badgesShellWithMode ""), (200, namesShellHtml)) + +testExportsCodesMode :: IO () +testExportsCodesMode = do + codesOnly <- namesWithCodesOnly True + open <- namesWithCodesOnly False + createDirectoryIfMissing True "tests/tmp" + withTempDirectory "tests/tmp" "names-export" $ \root -> do + staticDir <- prepareStaticDir root + LB.writeFile (staticDir "index.html") (badgesShellWithMode "") + namesDir <- prepareNamesDir root + let badgesOut = root "badges-out" + namesOut = root "names-out" + base = testServiceConfig staticDir False + lc = (listener base) {lServeWebapp = False, lBadgesExportDir = Just badgesOut, lNamesStaticDir = Just namesDir, lNamesExportDir = Just namesOut} + exported namesCfg = do + exportWebapp base {listener = lc, names = namesCfg} + (,) <$> LB.readFile (badgesOut "index.html") <*> LB.readFile (namesOut "index.html") + exported (Just codesOnly) `shouldReturn` (badgesShellWithMode "", namesShellAs "" "codes") + exported (Just open) `shouldReturn` (badgesShellWithMode "", namesShellHtml) + exported Nothing `shouldReturn` (badgesShellWithMode "", namesShellHtml) + webGetAt :: WebClient -> ByteString -> String -> IO (Response LB.ByteString) webGetAt client host target = webRequest client "GET" target [("Host", host)]