store: normalise names hosts and the Host header

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

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

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

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"