store: refuse a site build that is not there

apps/simplex-store-service/README.md

@@ -394,7 +394,8 @@ The names site is on when, and only when, the ini has `[names]`. Its `[listener]
   beside `badges_port` (by default 8080), which serves the badges site. The two must differ.
 
 The service refuses to start with any of these keys but no `[names]`, and with `names_port` and
-`serve_webapp = off`.
+`serve_webapp = off`. It also refuses to start when a build it serves or exports is not a
+directory, naming the setting, so a local run that keeps a default path stops there.
 
 With `serve_webapp = on` (all in one), the service listens on both ports, and each serves only its
 own site: every path outside `/api/` and `/webhooks/` is a file of that site, `/` and `/index.html`

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

@@ -53,7 +53,7 @@ import StoreService.StoreReceipts.Apple (readAppleRoot, verifyAppleTransaction)
 import StoreService.StoreReceipts.Google (playStoreVerifier)
 import StoreService.StoreReceipts.Mock (mockStoreVerifier)
 import StoreService.Waiters (Waiters, newWaiters)
-import StoreService.Web.Server (exportWebapp, newWebEnv, runWebListeners)
+import StoreService.Web.Server (checkSiteDirs, exportWebapp, newWebEnv, runWebListeners)
 import Control.Applicative (optional)
 import Control.Concurrent.STM
 import StoreService.Log (logError, logInfo, logWarn)
@@ -213,6 +213,7 @@ configureStoreVerifier serviceCfg env@ServiceState {storeVerifier = v} = case se
 storeService :: StoreServiceOpts -> ChatConfig -> ServiceState -> IO ()
 storeService opts@StoreServiceOpts {serviceConfigFile} baseCfg env = do
   serviceCfg <- traverse readConfigOrExit serviceConfigFile
+  forM_ serviceCfg $ \sc -> checkSiteDirs (listener sc) >>= orExit
   cfg <- requireDevKeys serviceCfg baseCfg
   key <- requireIssuerKey opts serviceCfg cfg
   waiters <- newWaiters

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

@@ -12,6 +12,7 @@ module StoreService.Web.Server
     webListeners,
     webSettings,
     runWebListeners,
+    checkSiteDirs,
   )
 where
 
@@ -34,7 +35,7 @@ import StoreService.Web.Names.Registration (heldFor, registrationChangedResponse
 import Control.Concurrent.Async (race)
 import qualified Control.Exception as E
 import StoreService.Log (logError, logInfo, logWarn)
-import Control.Monad (forM_, void, when)
+import Control.Monad (filterM, forM_, void, when)
 import Data.Aeson ((.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.KeyMap as KM
@@ -42,8 +43,9 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LB
 import Data.Char (toLower)
+import Data.Functor ((<&>))
 import Data.List (isPrefixOf)
-import Data.Maybe (catMaybes, fromMaybe)
+import Data.Maybe (catMaybes, fromMaybe, isJust)
 import Data.String (fromString)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -556,6 +558,17 @@ runWebListeners env = do
   where
     lc = listenerConfig env
 
+-- | Each build that is served or exported must be a directory, or the service would serve nothing or fail its export.
+checkSiteDirs :: ListenerConfig -> IO (Either String ())
+checkSiteDirs ListenerConfig {lServeWebapp, lBadgesStaticDir, lBadgesExportDir, lNamesStaticDir, lNamesExportDir, lNamesPort} =
+  filterM (fmap not . doesDirectoryExist . snd) used <&> \case
+    (site, dir) : _ -> Left ("listener." <> site <> "_static_dir = " <> dir <> " is not a directory; set it to the " <> site <> " build, since the default is the Docker image's path")
+    [] -> Right ()
+  where
+    used =
+      [("badges", lBadgesStaticDir) | lServeWebapp || isJust lBadgesExportDir]
+        <> [("names", dir) | Just dir <- [lNamesStaticDir], isJust lNamesPort || isJust lNamesExportDir]
+
 warnIfHeaderTrustIsExposed :: ListenerConfig -> IO ()
 warnIfHeaderTrustIsExposed ListenerConfig {lHost, lTrustForwardedFor} =
   when (lTrustForwardedFor && not (isLoopbackHost lHost)) $

tests/Bots/StoreService/WebTests.hs

@@ -248,6 +248,7 @@ badgeWebTests = do
     it "listens on the badges port alone without the names site" testOneListenerWithoutTheNamesSite
     it "serves a names asset with its type" testServesANamesAsset
     it "keeps every traversal spelling on the names port inside the names build" testNamesTraversalRefused
+    it "refuses a build folder that is not there, only where it is served or exported" testSiteDirsMustExist
   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
@@ -1199,6 +1200,25 @@ testNamesTraversalRefused = bounded "names traversal" $ withBothSites $ \_ names
     r <- webGet names target
     (target, statusOf r, responseBody r) `shouldBe` (target, 404, notFoundBody)
 
+testSiteDirsMustExist :: IO ()
+testSiteDirsMustExist = do
+  createDirectoryIfMissing True "tests/tmp"
+  withTempDirectory "tests/tmp" "site-dirs" $ \root -> do
+    staticDir <- prepareStaticDir root
+    namesDir <- prepareNamesDir root
+    let absent = root </> "absent"
+        lc = listener (testServiceConfig staticDir False)
+        missing site dir = Left ("listener." <> site <> "_static_dir = " <> dir <> " is not a directory; set it to the " <> site <> " build, since the default is the Docker image's path")
+    checkSiteDirs lc `shouldReturn` Right ()
+    checkSiteDirs lc {lNamesStaticDir = Just namesDir, lNamesPort = Just 8081} `shouldReturn` Right ()
+    checkSiteDirs lc {lBadgesStaticDir = absent} `shouldReturn` missing "badges" absent
+    checkSiteDirs lc {lBadgesStaticDir = absent, lServeWebapp = False} `shouldReturn` Right ()
+    checkSiteDirs lc {lBadgesStaticDir = absent, lServeWebapp = False, lBadgesExportDir = Just (root </> "out")} `shouldReturn` missing "badges" absent
+    checkSiteDirs lc {lNamesStaticDir = Just absent, lNamesPort = Just 8081} `shouldReturn` missing "names" absent
+    checkSiteDirs lc {lServeWebapp = False, lNamesStaticDir = Just absent} `shouldReturn` Right ()
+    checkSiteDirs lc {lServeWebapp = False, lNamesStaticDir = Just absent, lNamesExportDir = Just (root </> "names-out")} `shouldReturn` missing "names" absent
+    checkSiteDirs lc {lBadgesStaticDir = root </> "secret.txt"} `shouldReturn` missing "badges" (root </> "secret.txt")
+
 type WebClient = (Manager, String)
 
 withWebApp :: (WebEnv -> WebClient -> IO a) -> IO a