store: serve and export the names site by host

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

@@ -56,7 +56,7 @@ import Simplex.Chat.Badges.Types (BadgeOfferId (..), BadgePriceId (..))
 import Simplex.Chat.PaymentService.Types (InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), ServicePaymentDestination (..), ServicePaymentMethod (..))
 import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
 import Simplex.Messaging.Encoding.String (textEncode)
-import Simplex.Messaging.Util (tshow)
+import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
 import System.Directory (canonicalizePath, copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removePathForcibly)
 import System.FilePath (pathSeparator, takeExtension, (</>))
 
@@ -68,19 +68,31 @@ data WebEnv = WebEnv
     weHoldMicros :: Int,
     weHints :: ReadHints,
     weHttp :: HttpEnv,
-    -- | @Nothing@ when no Stripe key is configured, and the pristine @static_dir@ shell is served instead.
-    weShell :: Maybe LB.ByteString,
+    weBadgesSite :: Site,
+    -- | @Nothing@ when @names_static_dir@ is unset.
+    weNamesSite :: Maybe Site,
     -- | @Nothing@ when the ini has no @[names]@ section.
     weNames :: Maybe NamesEnv,
     -- | The name orders' part of weNames, which tests set without a chat controller.
     weOrders :: Maybe OrdersEnv
   }
 
+-- | 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.
+    siteShell :: Maybe LB.ByteString
+  }
+
 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, weHttp, weShell, weNames, weOrders = ordersEnv <$> weNames}
+  weHttp <- newHttpEnv lc
+  weBadgesSite <- loadSite (lStaticDir lc)
+  weNamesSite <- mapM loadSite (lNamesStaticDir lc)
+  pure WebEnv {weStore, weConfig, weWaiters, weProviders, weHoldMicros = holdMicros, weHints, weHttp, weBadgesSite, weNamesSite, weNames, weOrders = ordersEnv <$> weNames}
+  where
+    lc = listener weConfig
+    loadSite dir = Site dir <$> prepareShell dir (stripe weConfig)
 
 listenerConfig :: WebEnv -> ListenerConfig
 listenerConfig WebEnv {weConfig} = listener weConfig
@@ -101,11 +113,7 @@ webhookResponse st = responseLBS st [(hCacheControl, "no-store")] ""
 
 webApp :: WebEnv -> Application
 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" req respond $ serveStatic env ("assets" : rest) respond
-  ["sw.js"] | serving -> only "GET" req respond $ serveStatic env ["sw.js"] respond
+  path | Just site <- servedSite env req, sitePath path -> only "GET" req respond $ serveSite site path 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
@@ -113,35 +121,57 @@ webApp env@WebEnv {weHttp} req respond = case pathInfo req of
   ["webhooks", "stripe"] -> only "POST" req respond $ webhookHandler env PPStripe "POST /webhooks/stripe" req respond
   _ -> fromMaybe (respond notFound) names
   where
-    serving = lServeWebapp (listenerConfig env)
     names = weNames env >>= \n -> namesApp weHttp (namesRoutes n) req respond
 
+-- | The names site on a names host, the badges site on any other.
+servedSite :: WebEnv -> Request -> Maybe Site
+servedSite env@WebEnv {weBadgesSite, weNamesSite} req
+  | not lServeWebapp = Nothing
+  | Just site <- weNamesSite, maybe False (`elem` lNamesHosts) (requestHost req) = Just site
+  | otherwise = Just weBadgesSite
+  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
+
+-- | The names build keeps files at its root, so every path outside the API and the webhooks is the site's.
+sitePath :: [Text] -> Bool
+sitePath = \case
+  "api" : _ -> False
+  "webhooks" : _ -> False
+  _ -> True
+
 -- | 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
-serveStatic env segments respond =
-  resolveInside (lStaticDir (listenerConfig env)) segments >>= \case
+serveSite :: Site -> [Text] -> Respond -> IO ResponseReceived
+serveSite Site {siteDir, siteShell} path respond =
+  resolveInside siteDir (if null path then [T.pack shellFile] else path) >>= \case
     Nothing -> respond notFound
-    Just (root, file) -> respond (responseFile status200 (staticHeaders root file) file Nothing)
+    Just (root, file)
+      | Just shell <- siteShell, file == root </> shellFile -> respond (responseLBS status200 (staticHeaders root file) shell)
+      | otherwise -> respond (responseFile status200 (staticHeaders root file) file Nothing)
 
-shellHeaders :: [Header]
-shellHeaders = [(hContentType, "text/html; charset=utf-8"), (hCacheControl, "no-cache")]
+shellFile :: FilePath
+shellFile = "index.html"
 
+-- | The badges shell also has an @id@ before @name@, and the names shell has none.
 publishableKeyMeta :: Text
-publishableKeyMeta = "id=\"stripe-publishable-key\" name=\"stripe-publishable-key\" content=\""
+publishableKeyMeta = "name=\"stripe-publishable-key\" content=\""
 
 -- | @Nothing@ (serve the pristine file) when no key is set, no shell is present, or it cannot be read.
-prepareShell :: ListenerConfig -> Maybe StripeConfig -> IO (Maybe LB.ByteString)
+prepareShell :: FilePath -> Maybe StripeConfig -> IO (Maybe LB.ByteString)
 prepareShell _ Nothing = pure Nothing
-prepareShell ListenerConfig {lStaticDir} (Just StripeConfig {sPublishableKey}) =
+prepareShell dir (Just StripeConfig {sPublishableKey}) =
   E.try attempt >>= \case
     Right out -> pure out
     Left (e :: E.IOException) -> do
-      logWarn ("could not read the shell in " <> T.pack lStaticDir <> ", serving the pristine one: " <> tshow e)
+      logWarn ("could not read the shell in " <> T.pack dir <> ", serving the pristine one: " <> tshow e)
       pure Nothing
   where
     attempt :: IO (Maybe LB.ByteString)
     attempt = do
-      let shell = lStaticDir </> "index.html"
+      let shell = dir </> shellFile
       present <- doesFileExist shell
       if not present
         then pure Nothing
@@ -150,17 +180,20 @@ prepareShell ListenerConfig {lStaticDir} (Just StripeConfig {sPublishableKey}) =
           bytes <- BS.readFile shell
           case decodeUtf8' bytes of
             Left e -> do
-              logWarn ("the shell in " <> T.pack lStaticDir <> " is not valid UTF-8, serving the pristine one: " <> tshow e)
+              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))))
 
 exportWebapp :: ListenerConfig -> Maybe StripeConfig -> IO ()
-exportWebapp lc@ListenerConfig {lStaticDir, lWebappExportDir} stripeCfg =
-  forM_ lWebappExportDir $ \out -> do
-    emptyDir out
-    copyTree lStaticDir out
-    prepareShell lc stripeCfg >>= mapM_ (LB.writeFile (out </> "index.html"))
-    logInfo ("store service: exported the webapp to " <> T.pack out)
+exportWebapp ListenerConfig {lStaticDir, lWebappExportDir, lNamesStaticDir, lNamesExportDir} stripeCfg = do
+  forM_ lWebappExportDir $ exportSite lStaticDir
+  forM_ ((,) <$> lNamesStaticDir <*> lNamesExportDir) $ uncurry exportSite
+  where
+    exportSite dir out = do
+      emptyDir out
+      copyTree dir out
+      prepareShell dir stripeCfg >>= 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.
 emptyDir :: FilePath -> IO ()

tests/Bots/StoreService/WebTests.hs

@@ -230,6 +230,10 @@ badgeWebTests = do
     it "answers a hold from the row it read, not from the status it woke on" testHoldReportsTheRowNotTheWake
     it "answers a hold that timed out with a change nothing published" testHoldTimeoutReportsAnUnpublishedChange
     it "answers a handler exception with 500 internal, and keeps serving" testHandlerExceptionIsContained
+  describe "StoreService names: sites" $ do
+    it "exports both sites, each with the publishable key" testExportsBothSites
+    it "picks the site by Host against names_hosts" testHostPicksTheSite
+    it "serves a names asset with its type" testServesANamesAsset
   describe "store service settlement" $ do
     it "settles an open invoice: paid, a settled payment row, and the code" testSettlesAnOpenInvoice
     it "settles an expired invoice, because late settlement is routine" testLateSettlementIsLegal
@@ -1042,6 +1046,100 @@ testExportWebapp = do
     LB.readFile (outDir </> "sw.js") >>= (`shouldBe` workerJs)
     LB.readFile (outDir </> "assets" </> buildHash </> "main.js") >>= (`shouldBe` assetJs)
 
+namesShellHtml :: LB.ByteString
+namesShellHtml = "<!doctype html><title>simplex.domains</title><meta name=\"stripe-publishable-key\" content=\"\">"
+
+namesShellWithKey :: LB.ByteString
+namesShellWithKey = "<!doctype html><title>simplex.domains</title><meta name=\"stripe-publishable-key\" content=\"pk_test_injected\">"
+
+namesFont :: LB.ByteString
+namesFont = "wOF2 Manrope Bold"
+
+namesFontPath :: FilePath
+namesFontPath = "fonts" </> "Manrope" </> "Manrope-Bold.woff2"
+
+namesManifest :: LB.ByteString
+namesManifest = "{\"name\":\"SimpleX names\"}"
+
+namesHost :: ByteString
+namesHost = "simplex.domains"
+
+prepareNamesDir :: FilePath -> IO FilePath
+prepareNamesDir root = do
+  let namesDir = root </> "names"
+  createDirectoryIfMissing True (namesDir </> "fonts" </> "Manrope")
+  LB.writeFile (namesDir </> "index.html") namesShellHtml
+  LB.writeFile (namesDir </> namesFontPath) namesFont
+  LB.writeFile (namesDir </> "manifest.webmanifest") namesManifest
+  pure namesDir
+
+testExportsBothSites :: IO ()
+testExportsBothSites = do
+  createDirectoryIfMissing True "tests/tmp"
+  withTempDirectory "tests/tmp" "names-export" $ \root -> do
+    staticDir <- prepareStaticDir root
+    namesDir <- prepareNamesDir root
+    let badgesOut = root </> "badges-out"
+        namesOut = root </> "names-out"
+        lc = (listener (testServiceConfig staticDir False)) {lServeWebapp = False, lWebappExportDir = Just badgesOut, lNamesStaticDir = Just namesDir, lNamesExportDir = Just namesOut}
+    exportWebapp lc (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)
+    doesFileExist (badgesOut </> namesFontPath) `shouldReturn` False
+    LB.readFile (namesOut </> "index.html") >>= (`shouldBe` namesShellWithKey)
+    LB.readFile (namesOut </> namesFontPath) >>= (`shouldBe` namesFont)
+    LB.readFile (namesOut </> "manifest.webmanifest") >>= (`shouldBe` namesManifest)
+    doesFileExist (namesOut </> "sw.js") `shouldReturn` False
+
+withBothSites :: (WebClient -> IO a) -> IO a
+withBothSites action =
+  withServiceStore $ \st -> do
+    createDirectoryIfMissing True "tests/tmp"
+    withTempDirectory "tests/tmp" "names-static" $ \root -> do
+      staticDir <- prepareStaticDir root
+      namesDir <- prepareNamesDir root
+      let base = testServiceConfig staticDir True
+          cfg = base {listener = (listener base) {lNamesStaticDir = Just namesDir, lNamesHosts = [safeDecodeUtf8 namesHost]}, stripe = Just publishTestStripe}
+      withListener [] True holdMicros st cfg (const action)
+
+webGetAt :: WebClient -> ByteString -> String -> IO (Response LB.ByteString)
+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
+    shell <- webGetAt client host "/"
+    (statusOf shell, responseBody shell) `shouldBe` (200, namesShellWithKey)
+    headerOf shell hContentType `shouldBe` Just "text/html; charset=utf-8"
+  namesIndex <- webGetAt client namesHost "/index.html"
+  (statusOf namesIndex, responseBody namesIndex) `shouldBe` (200, namesShellWithKey)
+  forM_ ["badges.simplex.chat", "www.simplex.domains", "simplex.domains.example.org"] $ \host -> do
+    shell <- webGetAt client host "/"
+    statusOf shell `shouldBe` 200
+    LB.toStrict (responseBody shell) `shouldSatisfy` BC.isInfixOf "SimpleX badges"
+    LB.toStrict (responseBody shell) `shouldSatisfy` BC.isInfixOf "content=\"pk_test_injected\""
+  plain <- webGet client "/"
+  LB.toStrict (responseBody plain) `shouldSatisfy` BC.isInfixOf "SimpleX badges"
+  (statusOf <$> webGetAt client namesHost ("/assets/" <> buildHash <> "/main.js")) `shouldReturn` 404
+  (statusOf <$> webGetAt client namesHost "/sw.js") `shouldReturn` 404
+  (statusOf <$> webGetAt client "badges.simplex.chat" ("/" <> namesFontPath)) `shouldReturn` 404
+  postShell <- webRequest client "POST" "/" [("Host", namesHost)]
+  statusOf postShell `shouldBe` 405
+  api <- webGetAt client namesHost "/api/invoice"
+  statusOf api `shouldBe` 405
+  headerOf api "Allow" `shouldBe` Just "POST"
+
+testServesANamesAsset :: IO ()
+testServesANamesAsset = bounded "names asset" $ withBothSites $ \client -> do
+  font <- webGetAt client namesHost ("/" <> namesFontPath)
+  (statusOf font, responseBody font) `shouldBe` (200, namesFont)
+  headerOf font hContentType `shouldBe` Just "font/woff2"
+  manifest <- webGetAt client namesHost "/manifest.webmanifest"
+  (statusOf manifest, responseBody manifest) `shouldBe` (200, namesManifest)
+  headerOf manifest hContentType `shouldBe` Just "application/manifest+json"
+  (statusOf <$> webGetAt client namesHost "/fonts/Manrope/absent.woff2") `shouldReturn` 404
+
 type WebClient = (Manager, String)
 
 withWebApp :: (WebEnv -> WebClient -> IO a) -> IO a