From 483592f2848c6b3890e4a1dd4ff5abadc7df2bec Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 05:25:27 +0000 Subject: [PATCH] store: normalise names hosts and the Host header --- apps/simplex-store-service/src/StoreService/Config.hs | 9 ++++++++- .../simplex-store-service/src/StoreService/Web/Server.hs | 5 ++--- tests/Bots/StoreService/ConfigTests.hs | 7 +++++++ tests/Bots/StoreService/WebTests.hs | 2 +- 4 files changed, 18 insertions(+), 5 deletions(-) diff --git a/apps/simplex-store-service/src/StoreService/Config.hs b/apps/simplex-store-service/src/StoreService/Config.hs index e702e7038e..d490af7211 100644 --- a/apps/simplex-store-service/src/StoreService/Config.hs +++ b/apps/simplex-store-service/src/StoreService/Config.hs @@ -18,6 +18,7 @@ module StoreService.Config defaultExpiryMinutes, defaultSessionMinutes, minNameYears, + hostName, readServiceConfig, unknownKeys, ) @@ -218,6 +219,12 @@ trailingNoise = skipSpace *> skipMany (comment *> skipSpace) where comment = satisfy (\c -> c == ';' || c == '#') *> skipWhile (not . isEndOfLine) +-- | A host as names_hosts compares it: in lower case, without a port or the root's trailing dot. +hostName :: Text -> Text +hostName h = fromMaybe name (T.stripSuffix "." name) + where + name = T.takeWhile (/= ':') (T.toLower (T.strip h)) + knownSettings :: [(Text, [Text])] knownSettings = [ ("listener", ["host", "port", "static_dir", "serve_webapp", "webapp_export_dir", "trust_forwarded_for", "names_static_dir", "names_export_dir", "names_hosts"]), @@ -254,7 +261,7 @@ parseConfig ini = do 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") + lNamesHosts = maybe [] (filter (not . T.null) . map hostName . T.splitOn ",") (present "listener" "names_hosts") when (isNothing lNamesStaticDir && (not (null lNamesHosts) || isJust lNamesExportDir)) $ Left "listener.names_static_dir is required with names_hosts or names_export_dir" btc <- btcpaySection diff --git a/apps/simplex-store-service/src/StoreService/Web/Server.hs b/apps/simplex-store-service/src/StoreService/Web/Server.hs index 8af0c151e5..bbc3c373a8 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Server.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Server.hs @@ -15,7 +15,7 @@ module StoreService.Web.Server where import StoreService.Catalog (PricedOffer (..), priceOffer) -import StoreService.Config (ListenerConfig (..), ServiceConfig (..), StripeConfig (..)) +import StoreService.Config (ListenerConfig (..), ServiceConfig (..), StripeConfig (..), hostName) import StoreService.Names.Env (NamesEnv) import StoreService.Names.Orders (OrdersEnv (..), ordersEnv) import StoreService.Names.Phases (RegistrationId, awaitChange) @@ -132,9 +132,8 @@ servedSite env@WebEnv {weBadgesSite, weNamesSite} req where ListenerConfig {lServeWebapp, lNamesHosts} = listenerConfig env --- | The Host header without its port, in lower case as names_hosts is read. requestHost :: Request -> Maybe Text -requestHost req = T.takeWhile (/= ':') . T.toLower . safeDecodeUtf8 <$> requestHeaderHost req +requestHost req = hostName . safeDecodeUtf8 <$> requestHeaderHost req -- | The names build keeps files at its root, so every path outside the API and the webhooks is the site's. sitePath :: [Text] -> Bool diff --git a/tests/Bots/StoreService/ConfigTests.hs b/tests/Bots/StoreService/ConfigTests.hs index af36e29d3d..ab23df819c 100644 --- a/tests/Bots/StoreService/ConfigTests.hs +++ b/tests/Bots/StoreService/ConfigTests.hs @@ -422,6 +422,7 @@ namesConfigTests = describe "StoreService names: config" $ do it "reads every [names] and [chain] setting written out" testNamesWrittenOut it "reads the names keys of [listener]" testNamesListenerKeys it "refuses names_hosts or names_export_dir without names_static_dir" testNamesSiteNeedsItsBuild + it "reads names_hosts entries without a port or the root's trailing dot" testNamesHostsNormalised 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 @@ -533,6 +534,12 @@ testNamesSiteNeedsItsBuild = r <- parseIni withKey either id (const "parsed") r `shouldBe` "listener.names_static_dir is required with names_hosts or names_export_dir" +testNamesHostsNormalised :: IO () +testNamesHostsNormalised = do + let withHosts = T.replace "static_dir = /srv/badges\n" "static_dir = /srv/badges\nnames_static_dir = /srv/names\nnames_hosts = simplex.domains:8443, Names.Example., www.simplex.domains.:443\n" fullIni + Right cfg <- parseIni withHosts + lNamesHosts (listener cfg) `shouldBe` ["simplex.domains", "names.example", "www.simplex.domains"] + testNamesAbsent :: IO () testNamesAbsent = do Right cfg <- parseIni fullIni diff --git a/tests/Bots/StoreService/WebTests.hs b/tests/Bots/StoreService/WebTests.hs index ebcab4899d..90f221665e 100644 --- a/tests/Bots/StoreService/WebTests.hs +++ b/tests/Bots/StoreService/WebTests.hs @@ -1112,7 +1112,7 @@ webGetAt client host target = webRequest client "GET" target [("Host", host)] testHostPicksTheSite :: IO () testHostPicksTheSite = bounded "host picks the site" $ withBothSites $ \client -> do - forM_ [namesHost, "SIMPLEX.Domains:8443", "simplex.domains:80"] $ \host -> do + forM_ [namesHost, "SIMPLEX.Domains:8443", "simplex.domains:80", "simplex.domains.", "simplex.domains.:443"] $ \host -> do shell <- webGetAt client host "/" (statusOf shell, responseBody shell) `shouldBe` (200, namesShellWithKey) headerOf shell hContentType `shouldBe` Just "text/html; charset=utf-8"