diff --git a/apps/simplex-badge-service/README.md b/apps/simplex-badge-service/README.md index 2d3c2153f3..aa80badbe8 100644 --- a/apps/simplex-badge-service/README.md +++ b/apps/simplex-badge-service/README.md @@ -11,6 +11,22 @@ At this stage the service: Business logic — command dispatch, ledger writes, credential signing, provider webhooks — is left for follow-up per the plans. +## Site + +With a `[web]` section in `badge_service.ini` the same process runs the checkout site on `[web] +port`, bound to `[web] host` (default `127.0.0.1`, so a default deployment is not exposed without +a reverse proxy). It serves `/` (the page), `/assets//` and `/api/catalog`. + +The site is built by `web/` and its `dist/` is committed and embedded into the binary, so building +the service never needs node. Change anything under `web/src` or `web/assets` and run `npm run +build` in `web/`, committing the result — the running service serves the bytes that were embedded +when it was compiled. + +`[web] web_dir` overrides that and serves the same URLs from a directory on disk (the `web/` +directory itself: `dist/` under it, plus `index.html` and `styles.css` beside it), re-read on +every request so an edit is visible on reload. **It is for front-end development only**: every +response is `no-store`, and each request re-reads and re-hashes the whole directory. + ## Build Build prerequisites and the general contribution flow are in [`docs/CONTRIBUTING.md`](../../docs/CONTRIBUTING.md). diff --git a/apps/simplex-badge-service/src/BadgeService/Config.hs b/apps/simplex-badge-service/src/BadgeService/Config.hs index 2dda66c797..097b90b5e4 100644 --- a/apps/simplex-badge-service/src/BadgeService/Config.hs +++ b/apps/simplex-badge-service/src/BadgeService/Config.hs @@ -41,6 +41,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime, diffUTCTime) import Data.Word (Word32) +import qualified Network.HTTP.Client as HTTP import Simplex.Messaging.Agent.Store.Common (DBStore) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.BBS (BBSSecretKey) @@ -208,6 +209,7 @@ parseWeb path ini checkKnownKeys path "web" webKeys ini port <- requiredInt path "web" "port" ini baseUrl <- requiredValue path "web" "base_url" ini + validateBaseUrl path baseUrl supportContact <- requiredValue path "web" "support_contact" ini let host = optionalValue "127.0.0.1" "web" "host" ini dir = T.unpack <$> optionalMaybeValue "web" "web_dir" ini @@ -223,6 +225,22 @@ parseWeb path ini webDir = dir } +-- | '[web] base_url' is the origin the site is reached at: it goes into a provider's return and +-- webhook URLs (E2, F1) and into the app's browser hand-off (G1), so a relative or scheme-less +-- value is not something to discover at the first payment. 'https' is required, because a card +-- return URL over plaintext is a real downgrade, EXCEPT on the loopback hosts, where the local +-- mock stack (plan \'10) runs everything over http. +validateBaseUrl :: FilePath -> Text -> Either String () +validateBaseUrl path url = case HTTP.parseRequest (T.unpack url) :: Maybe HTTP.Request of + Nothing -> bad "must be an absolute http:// or https:// URL" + Just req + | HTTP.host req == "" -> bad "must name a host" + | HTTP.secure req -> Right () + | HTTP.host req `elem` ["localhost", "127.0.0.1"] -> Right () + | otherwise -> bad "must use https unless its host is localhost or 127.0.0.1" + where + bad why = configError path ("key 'base_url' in section [web] " <> why <> ", got: " <> T.unpack url) + btcPayKeys :: [Text] btcPayKeys = ["url", "store_id", "api_key_file", "webhook_secret_file", "xmr_method_id", "btc_expiry_minutes", "xmr_expiry_minutes"] diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 8016964719..9b18a7012d 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -53,6 +53,7 @@ import BadgeService.Store withServiceTransaction, ) import BadgeService.Store.Migrate (runBadgeServiceMigrations) +import BadgeService.Web.Server (WebServer, newWebServer, runWebServer) import Control.Concurrent (threadDelay) import Control.Concurrent.STM import Control.Exception (IOException, SomeAsyncException (..), SomeException, catch, evaluate, fromException, throwIO) @@ -121,6 +122,10 @@ import System.Exit (exitFailure) data ServiceState = ServiceState { serviceCC :: TMVar ChatController, serviceEnv :: TMVar BadgeServiceEnv, + -- | The site's listener (D4), or 'Nothing' when the ini has no @[web]@ section. Filled by + -- 'badgePreStartHook' alongside 'serviceEnv', so that an unresolvable asset token fails the + -- service at startup rather than at the first page load. + serviceWeb :: TMVar (Maybe WebServer), serviceRequestQ :: TQueue (User, AgentInvId, Maybe C.PublicKeyEd25519, J.Object) } @@ -128,8 +133,9 @@ newServiceState :: IO ServiceState newServiceState = do serviceCC <- newEmptyTMVarIO serviceEnv <- newEmptyTMVarIO + serviceWeb <- newEmptyTMVarIO serviceRequestQ <- newTQueueIO - pure ServiceState {serviceCC, serviceEnv, serviceRequestQ} + pure ServiceState {serviceCC, serviceEnv, serviceWeb, serviceRequestQ} welcomeGetOpts :: IO BadgeServiceOpts welcomeGetOpts = do @@ -150,7 +156,7 @@ badgeService opts cfg = do postStartHook = Just $ badgePostStartHook opts env } simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc -> - raceAny_ [processServiceEvents env cc, sweepSignerBucketsLoop env] + raceAny_ [processServiceEvents env cc, sweepSignerBucketsLoop env, webListenerLoop env] processServiceEvents :: ServiceState -> ChatController -> IO () processServiceEvents env cc = do @@ -182,7 +188,8 @@ badgeServiceCLI opts = do raceAny_ [ simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing, processQueuedRequests env, - sweepSignerBucketsLoop env + sweepSignerBucketsLoop env, + webListenerLoop env ] processQueuedRequests :: ServiceState -> IO () @@ -193,6 +200,24 @@ processQueuedRequests env = do (u, reqId, sigKey_, reqData) <- atomically $ readTQueue $ serviceRequestQ env handleServiceRequest bsEnv cc u reqId sigKey_ reqData +-- | The site's Warp listener (D4), as a third arm of both entry points' 'raceAny_' -- the default +-- 'badgeService' as much as 'badgeServiceCLI', or the site would run only under @--run-cli@ and +-- not in production. 'badgePreStartHook' has already built it (or decided there is none) by the +-- time this read completes, the same way 'processServiceEvents' reads 'serviceEnv'. +-- +-- With no @[web]@ section this arm has nothing to run and must nevertheless never return: +-- 'raceAny_' is @waitAnyCancel@, so an arm that finishes cancels the bot with it. +webListenerLoop :: ServiceState -> IO () +webListenerLoop ServiceState {serviceWeb} = + atomically (readTMVar serviceWeb) >>= \case + Just ws -> runWebServer ws + Nothing -> forever $ threadDelay idleWebListenerDelay + +-- | How long the web arm parks between wake-ups when there is no listener to run. Nothing happens +-- on either side of the wait -- see 'webListenerLoop' for why it waits at all. +idleWebListenerDelay :: Int +idleWebListenerDelay = 3600 * 1000000 + -- | How often the per-signer failure-bucket map is swept. Ten minutes is short against the -- hour a default bucket takes to refill and long against how often a bucket is created (only a -- classified redemption failure creates one), so the sweep is close to free while keeping the @@ -242,14 +267,21 @@ logSweepFailure e = case fromException e of -- and validates badge_service.ini, exits on a bad config (naming the file and the offending -- key), and stores the built env for badgePostStartHook and the request handlers to reach. badgePreStartHook :: BadgeServiceOpts -> ServiceState -> ChatController -> IO () -badgePreStartHook opts@BadgeServiceOpts {configFile, serviceClock} ServiceState {serviceEnv} ChatController {config, chatStore} = do +badgePreStartHook opts@BadgeServiceOpts {configFile, serviceClock} ServiceState {serviceEnv, serviceWeb} ChatController {config, chatStore} = do runBadgeServiceMigrations opts config chatStore seedCatalog chatStore readBadgeServiceConfig configFile >>= \case Left e -> putStrLn e >> exitFailure Right bsConfig -> do bsEnv <- newBadgeServiceEnv bsConfig chatStore serviceClock - atomically $ putTMVar serviceEnv bsEnv + -- Built here, before the bot starts: the site's assets are resolved and index.html's tokens + -- are substituted once, so a token naming a file that is not served fails the service at + -- startup, naming the token, rather than serving a page with a dead link in it (D4). + newWebServer bsEnv >>= \case + Left e -> putStrLn e >> exitFailure + Right web -> atomically $ do + putTMVar serviceEnv bsEnv + putTMVar serviceWeb web badgePostStartHook :: BadgeServiceOpts -> ServiceState -> ChatController -> IO () badgePostStartHook BadgeServiceOpts {noAddress, testing} env cc = do diff --git a/apps/simplex-badge-service/src/BadgeService/Web/Assets.hs b/apps/simplex-badge-service/src/BadgeService/Web/Assets.hs new file mode 100644 index 0000000000..843eec74ff --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Web/Assets.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | The set of files the site serves, and the token resolver that turns @\@\@name\@\@@ in +-- @index.html@ into the URL that file is served at (D4). +-- +-- Two rules here are load-bearing and are shared with @web/build.mjs@, which resolves the same +-- tokens at build time for @dist/dev.html@ (D1). If the two disagree, a token resolves in the +-- development build and fails in production: +-- +-- * a file is named by its path relative to the root of the built output -- @main.js@, and +-- @img\/x.svg@ if an asset is ever nested -- and the two files that stay at @web\/@ +-- (@index.html@ and @styles.css@) by their bare name; +-- * a token name is @[A-Za-z0-9_.-]+@, JavaScript's @[\\w.-]+@. That charset cannot contain a +-- @\/@, so no token can name a nested asset at all. Harmless while every asset is flat, and +-- deliberately identical to @build.mjs@'s pattern rather than quietly wider here. +-- +-- The build hash is ONE SHA-256 over the whole set, not one per file, and every file is served +-- under that single prefix. @tsc@ does not rewrite import specifiers (decision 7), so @main.js@ +-- resolves @.\/ui.js@ against its own directory: a per-file hash would put every sibling module +-- at a different prefix and 404 the whole module graph. One prefix still changes whenever any +-- file changes, which is the cache-busting property that matters. +module BadgeService.Web.Assets + ( ServedAssets (..), + embeddedAssets, + readServedAssets, + assetContentType, + substituteTokens, + indexHtmlName, + ) +where + +import Control.Monad (foldM, forM) +import qualified Data.ByteArray.Encoding as BA +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) +import Data.FileEmbed (embedDir, embedFile) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Simplex.Messaging.Crypto as C +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) +import System.FilePath (splitDirectories, ()) + +-- | Every file the service serves, keyed as a token names it, and the one hash they are all +-- served under. Built once at startup from the embedded bytes, or per request from @web_dir@. +data ServedAssets = ServedAssets + { assetsHash :: Text, + assetFiles :: Map Text ByteString + } + deriving (Eq, Show) + +-- | @index.html@ is served at @\/@ with its tokens substituted, and is in the served set as +-- well, so that @\@\@index.html\@\@@ resolves the same way it does in @build.mjs@. +indexHtmlName :: Text +indexHtmlName = "index.html" + +-- | Served from @web\/@ rather than from @dist\/@ (D1), so a @web_dir@ edit needs no rebuild. +stylesheetName :: Text +stylesheetName = "styles.css" + +-- | @npm run build@ writes this into @dist\/@ for design work over a local static server. It is +-- filtered out of the served set here and is never routed; 'embedDir' takes no predicate, so its +-- bytes are still in the binary. +devHtmlName :: Text +devHtmlName = "dev.html" + +-- | The only token that does not name a file: its value is @[web] support_contact@. +supportContactToken :: Text +supportContactToken = "support_contact" + +-- | The path a served file is fetched at. One prefix for the whole set -- see the module header. +assetUrlPath :: ServedAssets -> Text -> Text +assetUrlPath ServedAssets {assetsHash} name = "/assets/" <> assetsHash <> "/" <> name + +mkServedAssets :: [(Text, ByteString)] -> Either String ServedAssets +mkServedAssets files = do + m <- foldM insertUnique M.empty files + pure ServedAssets {assetsHash = setHash m, assetFiles = m} + where + insertUnique m (name, bs) + | M.member name m = + Left $ + "two served files are both named " <> T.unpack name + <> "; compiled modules, copied assets and the files at web/ share one flat namespace" + | otherwise = Right $ M.insert name bs m + +-- | One SHA-256 over the names and bytes of the whole set, in name order (see the module +-- header). Each file contributes its name and its own digest, both of fixed or newline-free +-- form, so no two different sets can produce the same input to the outer hash. +setHash :: Map Text ByteString -> Text +setHash m = base16 . C.sha256Hash . BS.concat $ concatMap entry (M.toAscList m) + where + entry (name, bs) = [encodeUtf8 name, "\n", base16Bytes (C.sha256Hash bs), "\n"] + base16Bytes = BA.convertToBase BA.Base16 + base16 = decodeUtf8 . base16Bytes + +-- | The @Content-Type@ for a served file, by extension. A file with no known extension is served +-- as @application\/octet-stream@ rather than guessed at: with @X-Content-Type-Options: nosniff@ +-- the browser will not second-guess it either, so a wrong type fails visibly. +assetContentType :: Text -> ByteString +assetContentType name = case T.toLower (T.takeWhileEnd (/= '.') name) of + "js" -> "text/javascript; charset=utf-8" + "css" -> "text/css; charset=utf-8" + "html" -> "text/html; charset=utf-8" + "json" -> "application/json" + "svg" -> "image/svg+xml" + "png" -> "image/png" + _ -> "application/octet-stream" + +-- Embedded assets ------------------------------------------------------------ + +-- | The committed build (decision 2 and 7): read at COMPILE time, which is why D8 gates +-- @web\/dist\/@ in CI -- a stale @dist\/@ is embedded silently otherwise. +embeddedDist :: [(FilePath, ByteString)] +embeddedDist = $(embedDir "apps/simplex-badge-service/web/dist") + +embeddedIndexHtml :: ByteString +embeddedIndexHtml = $(embedFile "apps/simplex-badge-service/web/index.html") + +embeddedStylesheet :: ByteString +embeddedStylesheet = $(embedFile "apps/simplex-badge-service/web/styles.css") + +-- | The served set as embedded in the binary. 'Left' only for a name collision, which is a build +-- mistake and is reported at startup by 'BadgeService.Web.Server.newWebServer'. +embeddedAssets :: Either String ServedAssets +embeddedAssets = + mkServedAssets $ + [(indexHtmlName, embeddedIndexHtml), (stylesheetName, embeddedStylesheet)] + <> [(name, bs) | (path, bs) <- embeddedDist, let name = toAssetName path, name /= devHtmlName] + +-- | A path relative to the built output, as a token names it: POSIX separators whatever +-- 'embedDir' or the local filesystem used. +toAssetName :: FilePath -> Text +toAssetName = T.intercalate "/" . map T.pack . splitDirectories + +-- web_dir assets ------------------------------------------------------------- + +-- | The same set read from disk instead of from the binary -- @[web] web_dir@, development only +-- (decision 2). The directory is @web\/@ itself: @dist\/@ under it, less @dev.html@, plus +-- @index.html@ and @styles.css@ beside it, which is exactly what is embedded, so the same tokens +-- resolve to the same URLs in both modes. +-- +-- The set is ENUMERATED from the directory, and 'BadgeService.Web.Server' serves a request only +-- if its name is a key of this map. No request path is ever joined onto @dir@, so a @..@ segment +-- or an absolute path cannot escape the directory: it is simply not a key. (A symlink inside the +-- directory that points outside it would be followed, which is the operator's own doing in a +-- mode documented as development-only.) +readServedAssets :: FilePath -> IO (Either String ServedAssets) +readServedAssets dir = do + let distDir = dir "dist" + hasDist <- doesDirectoryExist distDir + if not hasDist + then pure . Left $ "[web] web_dir " <> dir <> ": no " <> distDir <> " directory (run npm run build there)" + else do + roots <- forM [indexHtmlName, stylesheetName] $ \name -> do + let path = dir T.unpack name + exists <- doesFileExist path + if exists then Right . (name,) <$> BS.readFile path else pure . Left $ "[web] web_dir " <> dir <> ": no " <> path + names <- listAssetNames distDir + dist <- forM (filter (/= devHtmlName) names) $ \name -> (name,) <$> BS.readFile (distDir T.unpack name) + pure $ (\rs -> mkServedAssets (rs <> dist)) =<< sequence roots + +-- | Every file under @dir@, as a name relative to it. Hidden files are skipped, matching both +-- 'embedDir' (which skips them too) and @build.mjs@, so @.gitkeep@ and an editor's swap file are +-- not part of the set and do not change the build hash. +listAssetNames :: FilePath -> IO [Text] +listAssetNames dir = map toAssetName <$> walk "" + where + walk prefix = do + entries <- filter visible <$> listDirectory (dir prefix) + concat <$> mapM (child prefix) entries + child prefix name = do + let path = if null prefix then name else prefix name + isDir <- doesDirectoryExist (dir path) + if isDir then walk path else pure [path] + visible = \case + '.' : _ -> False + _ -> True + +-- Token substitution --------------------------------------------------------- + +-- | @index.html@ with every @\@\@name\@\@@ resolved: to the served URL of the file of that name, +-- or, for the one non-file token, to @[web] support_contact@. A token naming nothing is an +-- error, never a page served with a dead link or a literal token in it -- 'newWebServer' runs +-- this at startup for exactly that reason, so the service refuses to start rather than serve a +-- broken page. +-- +-- The rule is generic on purpose: a later step that adds an asset adds a token and nothing else. +substituteTokens :: Text -> ServedAssets -> Text -> Either String Text +substituteTokens supportContact assets = go + where + go t = case T.breakOn "@@" t of + (before, rest) + | T.null rest -> Right before + | otherwise -> + let body = T.drop 2 rest + (name, rest') = T.span isTokenChar body + in if not (T.null name) && "@@" `T.isPrefixOf` rest' + then do + value <- resolve name + after <- go (T.drop 2 rest') + pure $ before <> value <> after + else do + -- not a token: emit the "@@" and keep scanning from just after it, which is + -- how build.mjs's regex behaves on the same input + after <- go body + pure $ before <> "@@" <> after + resolve name + | name == supportContactToken = Right $ escapeHtml supportContact + | M.member name (assetFiles assets) = Right $ assetUrlPath assets name + | otherwise = + Left $ + "index.html references @@" <> T.unpack name <> "@@, which is neither a served file (" + <> T.unpack (T.intercalate ", " (M.keys (assetFiles assets))) + <> ") nor the " + <> T.unpack supportContactToken + <> " token" + isTokenChar c = isAsciiUpper c || isAsciiLower c || isDigit c || c == '_' || c == '.' || c == '-' + +-- | Only the support contact needs this: it comes from the operator's ini and is substituted into +-- an @href@ attribute, so an unescaped quote in it would end the attribute. The asset URLs are +-- built here out of a hex digest and a token-charset name, and contain nothing to escape. +escapeHtml :: Text -> Text +escapeHtml = T.concatMap $ \case + '&' -> "&" + '<' -> "<" + '>' -> ">" + '"' -> """ + '\'' -> "'" + c -> T.singleton c diff --git a/apps/simplex-badge-service/src/BadgeService/Web/Server.hs b/apps/simplex-badge-service/src/BadgeService/Web/Server.hs new file mode 100644 index 0000000000..c336857d58 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Web/Server.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | The site's Warp listener (D4, decision 1): one process, one origin, no CORS. It serves the +-- index page at @\/@, the built site under @\/assets\/\\/@ and the catalog at +-- @\/api\/catalog@; @\/api\/checkout@ (D6) and @\/webhooks\/*@ (E3, F2) are added to the same +-- listener by later steps. +-- +-- The listener binds @[web] host@, which defaults to @127.0.0.1@ (A6), so a default deployment is +-- not exposed without a reverse proxy in front of it. +module BadgeService.Web.Server + ( WebServer, + ServedPage (..), + newWebServer, + resolveWebPage, + runWebServer, + ) +where + +import BadgeService.Catalog (catalogTotals) +import BadgeService.Config (BadgeServiceConfig (web), BadgeServiceEnv (..), WebConfig (..)) +import BadgeService.Store (getActiveCatalog, withServiceTransaction) +import BadgeService.Web.Assets +import Control.Logger.Simple +import qualified Data.Aeson as J +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map.Strict as M +import Data.Maybe (isJust) +import Data.String (fromString) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8', encodeUtf8) +import Network.HTTP.Types (Header, ResponseHeaders, Status, hCacheControl, hContentType, internalServerError500, methodNotAllowed405, notFound404, ok200) +import Network.Wai (Application, Response, pathInfo, requestMethod, responseLBS) +import qualified Network.Wai.Handler.Warp as Warp +import Simplex.Messaging.Util (tshow) + +-- | What a request is answered from: the served set and the index page with its tokens already +-- resolved. Built once at startup from the embedded bytes, and per request in @web_dir@ mode. +data ServedPage = ServedPage + { spAssets :: ServedAssets, + spIndex :: ByteString + } + deriving (Eq, Show) + +data WebServer = WebServer + { wsConfig :: WebConfig, + wsService :: BadgeServiceEnv, + -- | 'Nothing' in @web_dir@ mode, where the page is re-read from disk on every request. + wsPage :: Maybe ServedPage + } + +-- | The served set with @index.html@'s tokens resolved against it, from the binary or, in +-- @web_dir@ mode, from disk. Every failure is a message naming what is wrong: an unresolvable +-- token here is why the service refuses to start rather than serving a page with a dead asset +-- link or a literal @\@\@token\@\@@ in it. +resolveWebPage :: WebConfig -> IO (Either String ServedPage) +resolveWebPage cfg@WebConfig {webDir} = servedPage cfg <$> maybe (pure embeddedAssets) readServedAssets webDir + +servedPage :: WebConfig -> Either String ServedAssets -> Either String ServedPage +servedPage WebConfig {webSupportContact} assets' = do + assets <- assets' + indexBytes <- maybe (Left $ "the served set has no " <> T.unpack indexHtmlName) Right $ M.lookup indexHtmlName (assetFiles assets) + indexText <- first (\e -> T.unpack indexHtmlName <> " is not valid UTF-8: " <> show e) (decodeUtf8' indexBytes) + html <- substituteTokens webSupportContact assets indexText + pure ServedPage {spAssets = assets, spIndex = encodeUtf8 html} + +-- | 'Nothing' when @[web]@ is absent: the service then runs with no listener at all, which is +-- what a bot-only deployment (no payment provider, codes minted by @codes@) wants. Every other +-- failure is fatal at startup, before the bot answers anything. +newWebServer :: BadgeServiceEnv -> IO (Either String (Maybe WebServer)) +newWebServer env = case web (config env) of + Nothing -> pure $ Right Nothing + Just cfg -> + resolveWebPage cfg >>= \case + Left e -> pure $ Left e + Right page -> + pure . Right . Just $ + WebServer + { wsConfig = cfg, + wsService = env, + -- web_dir re-reads on every request, so that an edited file is visible on reload + wsPage = if isJust (webDir cfg) then Nothing else Just page + } + +runWebServer :: WebServer -> IO () +runWebServer ws@WebServer {wsConfig = WebConfig {webPort, webHost, webDir}} = do + logInfo $ "badge service web listener on " <> webHost <> ":" <> tshow webPort <> maybe "" (\d -> " serving " <> T.pack d <> " (web_dir, development only)") webDir + -- Warp.run takes a port alone and cannot bind a configured host, so runSettings is used. + Warp.runSettings (Warp.setPort webPort $ Warp.setHost (fromString $ T.unpack webHost) Warp.defaultSettings) (webApp ws) + +webApp :: WebServer -> Application +webApp ws req respond + | requestMethod req `notElem` ["GET", "HEAD"] = + respond $ textResponse methodNotAllowed405 [("Allow", "GET, HEAD")] "method not allowed" + | otherwise = case pathInfo req of + [] -> withPage serveIndex + [""] -> withPage serveIndex + ["api", "catalog"] -> respond =<< serveCatalog ws + ("assets" : buildHash : name : names) -> withPage $ \page -> serveAsset ws page buildHash (T.intercalate "/" (name : names)) + _ -> respond notFoundResponse + where + withPage serve = + currentPage ws >>= \case + Right page -> respond $ serve page + Left e -> do + logError $ "badge service web assets are unreadable: " <> T.pack e + respond $ textResponse internalServerError500 [] "internal error" + +-- | In @web_dir@ mode the whole set, its hash and the substituted index are recomputed per +-- request, so an edited file is visible on reload; every response in that mode is @no-store@, or +-- an edited @styles.css@ would keep its URL under an @immutable@ response and the browser would +-- not re-fetch it until the service restarted. +currentPage :: WebServer -> IO (Either String ServedPage) +currentPage WebServer {wsConfig, wsPage} = maybe (resolveWebPage wsConfig) (pure . Right) wsPage + +serveIndex :: ServedPage -> Response +serveIndex ServedPage {spIndex} = + responseLBS ok200 (securityHeaders <> [(hContentType, assetContentType indexHtmlName), (hCacheControl, "no-cache")]) (LBS.fromStrict spIndex) + +-- | The whole served set sits under one hash prefix (see "BadgeService.Web.Assets"), so a +-- request under any other prefix is 404: an old prefix is a stale page's cached URL, and there is +-- no version of the site to answer it with. +-- +-- @index.html@ is served here as well as at @\/@, with the same substituted bytes and the same +-- @no-cache@, so that a token naming it resolves to a URL that works. @dev.html@ is not in the +-- set at all and 404s here like any other unknown name. +serveAsset :: WebServer -> ServedPage -> Text -> Text -> Response +serveAsset ws page@ServedPage {spAssets} buildHash name + | buildHash /= assetsHash spAssets = notFoundResponse + | name == indexHtmlName = serveIndex page + | otherwise = case M.lookup name (assetFiles spAssets) of + Nothing -> notFoundResponse + Just bytes -> + responseLBS + ok200 + (securityHeaders <> [(hContentType, assetContentType name), (hCacheControl, assetCacheControl ws)]) + (LBS.fromStrict bytes) + +assetCacheControl :: WebServer -> ByteString +assetCacheControl WebServer {wsConfig = WebConfig {webDir}} + | isJust webDir = "no-store" + | otherwise = "public, max-age=31536000, immutable" + +-- | The catalog in the RPC encoding (A2), so the site and the app parse the same shape. It is +-- read from the database through the same 'getActiveCatalog' and 'catalogTotals' the RPC handler +-- uses, never from @Catalog.hs@'s defaults, so a price deprecated or disabled by an operator is +-- reflected without a rebuild (decision 8). +serveCatalog :: WebServer -> IO Response +serveCatalog WebServer {wsService = BadgeServiceEnv {store}} = + withServiceTransaction store (fmap catalogTotals . getActiveCatalog) >>= \case + Right catalog -> pure $ jsonResponse ok200 (J.encode catalog) + Left e -> do + logError $ "badge service /api/catalog failed: " <> tshow e + pure $ jsonResponse internalServerError500 "{\"error\":\"internal\"}" + +-- | On every response, including a 404 and an error: the site loads no cross-origin resource, so +-- @default-src 'self'@ blocks nothing it needs. +securityHeaders :: ResponseHeaders +securityHeaders = + [ ("Content-Security-Policy", "default-src 'self'"), + ("X-Content-Type-Options", "nosniff"), + ("Referrer-Policy", "no-referrer"), + ("X-Frame-Options", "DENY") + ] + +notFoundResponse :: Response +notFoundResponse = textResponse notFound404 [] "not found" + +textResponse :: Status -> [Header] -> LBS.ByteString -> Response +textResponse status headers = + responseLBS status (securityHeaders <> headers <> [(hContentType, "text/plain; charset=utf-8"), (hCacheControl, "no-store")]) + +jsonResponse :: Status -> LBS.ByteString -> Response +jsonResponse status = + responseLBS status (securityHeaders <> [(hContentType, "application/json"), (hCacheControl, "no-store")]) diff --git a/plans/badges-codes/2026-08-21-badges-web-checkout.md b/plans/badges-codes/2026-08-21-badges-web-checkout.md index 8c5918323e..6ed14e1dce 100644 --- a/plans/badges-codes/2026-08-21-badges-web-checkout.md +++ b/plans/badges-codes/2026-08-21-badges-web-checkout.md @@ -153,7 +153,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat | D1 | Web project skeleton and tsc build | — | ☑ | | D2 | Design system and site wizard shell | D1 | ☑ | | D3 | Catalog fetch and the four site screens | D2, D4 | ☐ | -| D4 | Warp listener, asset embedding, routing | A2, A4, A6, B1, D1 | ☐ | +| D4 | Warp listener, asset embedding, routing | A2, A4, A6, B1, D1 | ☑ | | D5 | URL prefill | D3 | ☐ | | D6 | `POST /api/checkout`, provider interface, order creation | A4, B3, D0, D4 | ☐ | | D7 | Pay button and checkout error states | D3, D6 | ☐ | @@ -827,7 +827,7 @@ Phase D ends with a browsable, priced site wizard whose Pay button reaches a rea **Do:** - Warp listener on `[web] port`, bound to `[web] host`, which defaults to `127.0.0.1` so a default deployment is not exposed without a reverse proxy. Use `runSettings` with `setPort` and `setHost` from `[web] port` and `[web] host`. `Warp.run` takes a port alone and cannot bind a configured host, so it is not used. `tests/NameResolver.hs:38` shows the in-repo `Application` shape, but it uses `withApplication` on a free port; that pattern belongs to E1's mock, not to a configured listener. Configuration errors in `[web]`, including its absence, are A6's rules and are enforced there. -- Run the listener alongside the bot with `raceAny_`. `badgeServiceCLI` already does this (`Service.hs:86`), but it runs only under `--run-cli` (`Main.hs:12`). The default entry point is `badgeService` (`Service.hs:55-69`), whose `simplexChatCore … forever` loop must also be raced against the web listener, or the site will not run in production. +- Run the listener alongside the bot with `raceAny_`. **Both** entry points already race two arms each — `badgeService` (`Service.hs:144`, racing `processServiceEvents` and `sweepSignerBucketsLoop`) and `badgeServiceCLI` (`:167`, which also runs the terminal) — so the listener is a third arm on each, not a race being introduced. It must go on `badgeService` as well as on the `--run-cli` path (`Main.hs:12`), or the site will not run in production. An arm that returns cancels its siblings (`raceAny_` is `waitAnyCancel`), so the arm must not finish when `[web]` is absent and there is no listener to run. - `Assets.hs`: `embedDir` of `web/dist/`, plus `embedFile` of `web/index.html` and `web/styles.css`, following `Operators.hs:70`. Compute **one** SHA-256 over the whole served set at startup, the file names and bytes in sorted order, and serve every asset under that single prefix at `/assets//`, with `Cache-Control: public, max-age=31536000, immutable`. The hash must be per build, not per file: `tsc` does not rewrite import specifiers, so `main.js` resolves `./catalog.js` against its own directory, and a per-file hash would put every sibling module at a different prefix and 404 the whole graph. One prefix changes on any change to any asset, which is the same cache-busting property. - `Server.hs` substitutes tokens in `index.html` on the way out, in both embedded and `web_dir` modes; `index.html` is `no-cache`. Substitution is **generic**: `@@@@` resolves to `/assets//` for any `` present in the served set, so a later step that adds an asset adds a token and nothing else. The single exception is `@@support_contact@@`, which is not a file and comes from `[web] support_contact`. A token naming a file that is not in the served set fails at startup rather than serving a broken page. `dist/dev.html` is removed from the served set by an ordinary `filter` over `embedDir`'s `[(FilePath, ByteString)]`; `embedDir` takes no predicate, so its bytes stay in the binary. It is never routed. - `[web] web_dir` (decision 2) serves from disk instead, for front-end iteration. In that mode the build hash is recomputed per request and every asset is served `Cache-Control: no-store`, so an edited file is visible on reload; the immutable long-cache belongs to the embedded mode alone. Without this an edited `styles.css` would keep the same URL under an `immutable` response and the browser would not re-fetch it until the service restarted. Development only: document it as such and refuse paths outside the given directory. @@ -845,7 +845,7 @@ Phase D ends with a browsable, priced site wizard whose Pay button reaches a rea - Security headers on every response: `Content-Security-Policy: default-src 'self'`, `X-Content-Type-Options: nosniff`, `Referrer-Policy: no-referrer`, `X-Frame-Options: DENY`. The site loads no cross-origin resource, so `default-src 'self'` blocks nothing it needs. -**Verify:** Manual: the service serves `index.html` with every `@@…@@` token substituted, including `@@support_contact@@` from the ini, and the module graph loading without a console error; `GET /dev.html` and `GET /assets//dev.html` both return 404; `curl -I` shows the headers and the immutable asset caching; `curl /api/catalog` matches the seeded catalog; `web_dir` picks up an edited CSS file without a rebuild. The site wizard itself is reviewable after D3. +**Verify:** In `tests/Bots/BadgeServiceTests.hs`, over HTTP against the running service: `GET /` carries no `@@…@@`, resolves `@@support_contact@@` to the value in the ini specifically, and every asset URL it names is fetchable under ONE prefix; every relative specifier in a served module resolves under that module's own prefix (the reason the hash is per build); `GET /dev.html` and `/assets//dev.html` are both 404 and carry none of `dev.html`'s bytes; an asset under a stale hash is 404 while the same name under the current one is 200; the four security headers are on every response, including a 404 and a rejected method; `/api/catalog` decodes as the RPC `BadgeCatalog` and reflects a price the fixture disabled and one it deprecated, with each offer's computed `total`; `web_dir` serves from disk with `no-store`, picks up an edited stylesheet with no restart and refuses a path outside its directory, percent-encoded traversal included; a token naming no served file fails `resolveWebPage`, which is what startup calls, naming the token; `base_url` rejects a non-loopback `http` URL and accepts `https` and loopback ones. Not automated: that a browser renders and executes the served page (§9 browser pass). The site wizard itself is reviewable after D3. #### D5 — URL prefill @@ -1492,12 +1492,13 @@ Append here when a step contradicts this plan: the step id, what was wrong, and - **D1 — `index.html` may not use the token syntax in prose, and its charset declaration has a byte budget. Both bind D2 onwards.** The step requires a header comment saying `dist/` is committed, and the first draft of that comment used `@@name@@` to describe the mechanism — which the generic substitution then tried to resolve, correctly failing the build. Under D4 the same stray token fails the *service* at startup. Separately, the comment sits above ``, and HTML5 requires the encoding declaration to be complete within the first 1024 bytes; `dev.html` prepends a generated banner on top of it, so the budget is shared. The comment is short and ASCII-only for that reason, the banner is one line, and `index.html` says so. A step that grows the header comment has to re-check both. - **D1 — its Verify line was rewritten from a manual browser check to a mechanical one, and the browser half is now carried by D2's Verify.** The original line was "Manual: `npm ci && npm run build` … `npx tsc --noEmit` is clean", which under rule 4 made D1 unfalsifiable in CI and in any environment without a display. It now specifies the reproducible rebuild (which is what D8 gates), the token resolution in `dev.html`, the emitted relative import, and a `curl` of every URL the page references over `python3 -m http.server`. **Exactly four things were therefore not run when D1 landed, and none of them is claimed to work:** that `dev.html` renders at all; that the browser executes the `main.js` → `ui.js` module graph; that `../styles.css` is applied rather than merely served with a `text/css` header; and that a `file://` open fails where HTTP succeeds, which the step asserts and which was not tested in either direction. Under rule 10 a deferral needs the deferring step to own the assertions, so **D2's Verify line now names the first three explicitly** — D2 replaces `main.ts`, `ui.ts`, `styles.css` and `index.html` wholesale, and without that its implementer would read a blank page as their own markup rather than as D1's mechanism. The `file://` claim is carried untested; nothing in the plan depends on it beyond the instruction not to do it, which `dev.html`'s own banner repeats. - **D1/D8 — `git diff --exit-code -- dist` does not see untracked files, so the staleness gate has a blind spot.** The check now sits in D1's Verify line and is what D8 is to gate CI on. `dist/` is wiped and rebuilt every run, so a *deleted* module or asset is caught: the file vanishes from the working tree and the diff reports it. But a *new* asset that was built and never `git add`ed is untracked, and `git diff` ignores untracked paths entirely — CI would run `npm ci && npm run build`, produce a file that is not in the repository, and report the tree clean. The service would then embed a `dist/` missing that asset while `index.html` carries its token, which under D4's rule fails at **startup**, not in CI. **D8 must assert on untracked files too** — `git status --porcelain apps/simplex-badge-service/web/dist` being empty covers both directions, where `git diff --exit-code` covers only one. -- **D1/D4 — a nested asset gets a served-set key no token can name, and the two resolvers must agree on this.** `dist/` is walked recursively, so an asset at `assets/img/x.svg` enters the served set keyed `img/x.svg`, while the token pattern is `@@([\w.-]+)@@` and does not accept `/`. Nothing can reference such a file, and the mismatch surfaces as the ordinary "token names nothing" build failure rather than as anything explaining itself. No asset is nested today and none is planned — D2's two logos and E5's encoder are all flat — so this is recorded rather than fixed. **D4 implements the same resolver server-side over `embedDir`'s `[(FilePath, ByteString)]`, whose keys are also relative paths**, and must use the same key and the same token charset; if it accepts `/` in a token while the build script does not, or keys its set differently, the two resolvers diverge on the first nested asset and the page that builds cleanly fails at startup. Whichever step first needs a subdirectory decides for both, in one place. +- **D1/D4 — a nested asset gets a served-set key no token can name, and the two resolvers must agree on this.** `dist/` is walked recursively, so an asset at `assets/img/x.svg` enters the served set keyed `img/x.svg`, while the token pattern is `@@([\w.-]+)@@` and does not accept `/`. Nothing can reference such a file, and the mismatch surfaces as the ordinary "token names nothing" build failure rather than as anything explaining itself. No asset is nested today and none is planned — D2's two logos and E5's encoder are all flat — so this is recorded rather than fixed. **D4 implements the same resolver server-side over `embedDir`'s `[(FilePath, ByteString)]`, whose keys are also relative paths**, and must use the same key and the same token charset; if it accepts `/` in a token while the build script does not, or keys its set differently, the two resolvers diverge on the first nested asset and the page that builds cleanly fails at startup. Whichever step first needs a subdirectory decides for both, in one place. **D4 implemented it identically**: the key is the path relative to the built output in POSIX form (`toAssetName` over `embedDir`'s pairs and over the `web_dir` walk), the two files at `web/` keep their bare names as `build.mjs`'s `ROOT_FILES` do, and the token charset is `[A-Za-z0-9_.-]`, JavaScript's `[\w.-]` written out because Haskell's `isAlphaNum` is Unicode-wide and JavaScript's `\w` is not. - **D8 — the step text's `git diff --exit-code` was implemented as `git status --porcelain`, per the D1/D8 entry above.** The blind spot was already recorded but the step text still named the blind command; it now names the porcelain one. This is not theoretical: in the clean clone used to verify the job, building a new asset into `dist/` without `git add`ing it leaves `git diff --exit-code -- dist` **exiting 0** while the porcelain check exits 1 — the gate as the plan first wrote it would have gone green on precisely the failure it exists to catch, and that failure surfaces at D4 as a *startup* error in the service. The untracked case includes a nested asset, whose whole directory `git status` collapses to one `?? …/dist/img/` line — still non-empty, so still a failure. - **D8 — "a job gated on `apps/simplex-badge-service/web/**`" is not expressible; the job runs on every trigger of `build.yml` instead.** GitHub Actions `paths:` filters are a *workflow* trigger, not a per-job condition, so the only ways to gate a single job are a separate workflow file with its own `paths:` or a third-party changed-files action. Neither was taken. `build.yml` is this repository's one PR gate and its `pull_request` paths already list `apps/simplex-badge-service/**` (`:19`), so a PR touching `web/` already runs this workflow and the gating would buy nothing there; `web.yml`, the only `paths:`-triggered workflow here, is a gh-pages *deploy* pipeline, not a check, so following its shape would be copying a different kind of thing. On pushes to `master`/`stable` and on tags, where `build.yml` has no `paths` filter, running unconditionally is what is wanted — a merge can leave `dist/` inconsistent with `src/` while touching neither, and a path-filtered workflow would skip exactly that commit. The cost is `npm ci` of one package plus `tsc`, seconds, in parallel with builds that take tens of minutes. A separate workflow would also add a second path list to keep in step with the first and a second required-check name; a `paths`-filtered check that is marked required leaves PRs that do not touch those paths pending forever. - **D8 — the step's Verify was manual and unrunnable before merge; it is now the same command sequence run locally.** "Edit a `.ts` and confirm the job fails" cannot be executed before the workflow is on the default branch. The line now specifies a clean clone of HEAD, the job's own commands in it, and both failure modes with the exact output each produces — which is what was run. What remains unverified is only what no local run can cover: that GitHub resolves `actions/checkout@v6` and `actions/setup-node@v6` and provisions node 24 on `ubuntu-latest`. The first CI run on this branch confirms that. - **Phase D — ONE outstanding browser pass, held here. Do not defer it step to step.** D1 deferred three assertions to D2, D2 has no browser either, and a chain of hand-offs evaporates: each step ticks, each points at the next, and nothing is ever run. So there is one list, in this entry, and a later step that cannot run a browser **appends to it** rather than writing "D3 will cover it". Everything on it needs a human at a browser, opening `/dist/dev.html` over `python3 -m http.server` rooted at `apps/simplex-badge-service/web`, or the served site once D4 exists. Nothing in the plan may claim any of it is verified until someone reports having seen it. - From D1: that `dev.html` **loads at all** rather than rendering an empty shell; that `../styles.css` is **applied** and not merely served with a `text/css` header, for which the colour tokens are the visible proof; and that the browser **executes the module graph across files** — `main.js` importing `./ui.js`, and `ui.js` importing `./router.js` and `./view.js`, by the relative specifiers `tsc` does not rewrite. The third is what decision 7 and D4's single-prefix asset hash both rest on. A blank or unstyled page at this pass is as likely to be D1's mechanism as D2's markup, so confirm each separately. (D1's fourth deferral, that a `file://` open fails where HTTP succeeds, is still carried untested and nothing depends on it.) + - From D4: that the served site (not only `dist/dev.html`) loads under `Content-Security-Policy: default-src 'self'` with **no console violation**. The shipped bytes are statically clean today — `index.html` has no inline `\n" + writeFile (dir "styles.css") webDirCssBefore + writeFile (dir "dist" "main.js") "export const site = \"web_dir\";\n" + writeFile (dir "dist" "dev.html") "\n" + +webDirCssBefore :: String +webDirCssBefore = "body { color: rgb(1, 2, 3); }\n" + +webDirCssAfter :: String +webDirCssAfter = "body { color: rgb(4, 5, 6); }\n" + +-- What a traversal must not reach: a real, readable file one level above the served directory. +webDirSecret :: String +webDirSecret = "OUTSIDE-WEB-DIR-SECRET\n" + +-- [web] web_dir (decision 2) serves the same URLs from disk, so an edit is visible on reload: +-- the assertions are the outcome of an edit (new bytes, new prefix, old prefix gone) rather than +-- the mechanism that produces it. Every response is no-store, because with the immutable +-- long-cache of the embedded mode a browser would not re-fetch the edited file at all. +-- +-- The traversal cases are the one security-relevant route in this step. The percent-encoded one +-- is the case that matters: WAI decodes it into a SINGLE path segment "../../", which a +-- server that joined the request path onto the directory would happily read. +testBadgeServiceWebDirServesFromDisk :: HasCallStack => TestParams -> IO () +testBadgeServiceWebDirServesFromDisk ps@TestParams {tmpPath} = do + let dir = tmpPath "web_dir_site" + secretFile = tmpPath "outside-web-dir.txt" + writeConfig port = do + (issuerKeyFile, codeSecretFile) <- writeTestBadgeServiceSecrets tmpPath + writeFile (badgeServiceConfigPath tmpPath) $ + unlines $ + issuerCodesIniLines issuerKeyFile codeSecretFile + ++ ("" : webIniLines port) + ++ ["web_dir = " <> dir] + writeTestWebDir dir + writeFile secretFile webDirSecret + withBadgeServiceWebConfig ps writeConfig (pure ()) $ \_client _bsLink webUrl -> do + mgr <- newWebManager + index <- webGet mgr webUrl + wrStatus index `shouldBe` 200 + wrBody index `shouldSatisfy` (not . isInfixOf "@@") + wrBody index `shouldSatisfy` isInfixOf testSupportContact + let cssUrl = head $ filter ("/styles.css" `isSuffixOf`) (webAssetUrls (wrBody index)) + css <- webGet mgr (webUrl <> cssUrl) + wrStatus css `shouldBe` 200 + wrBody css `shouldBe` webDirCssBefore + webHeader css "cache-control" `shouldBe` "no-store" + -- the edit: no restart, no rebuild + writeFile (dir "styles.css") webDirCssAfter + index' <- webGet mgr webUrl + let cssUrl' = head $ filter ("/styles.css" `isSuffixOf`) (webAssetUrls (wrBody index')) + cssUrl' `shouldSatisfy` (/= cssUrl) + css' <- webGet mgr (webUrl <> cssUrl') + wrBody css' `shouldBe` webDirCssAfter + -- the pre-edit URL is gone with the old build hash, which is the cache-busting property + stale <- webGet mgr (webUrl <> cssUrl) + wrStatus stale `shouldBe` 404 + let buildHash = webAssetHash cssUrl' + dev <- webGet mgr (webUrl <> "/assets/" <> buildHash <> "/dev.html") + wrStatus dev `shouldBe` 404 + -- nothing outside the directory, however the path is spelled + forM_ ["..%2F..%2Foutside-web-dir.txt", "../../outside-web-dir.txt", "%2E%2E%2F%2E%2E%2Foutside-web-dir.txt", ".%2E/..%2Foutside-web-dir.txt"] $ \path -> do + r <- webGet mgr (webUrl <> "/assets/" <> buildHash <> "/" <> path) + (path, wrStatus r) `shouldBe` (path, 404) + (path, webDirSecret `isInfixOf` wrBody r) `shouldBe` (path, False) + -- the file the traversals aimed at exists and is readable: the 404s above are the server + -- refusing, not a missing target + readFile secretFile `shouldReturn` webDirSecret + +-- A token naming a file that is not served must fail at STARTUP, naming the token, rather than +-- serving a page with a dead link in it. 'resolveWebPage' is what 'newWebServer' calls from +-- 'badgePreStartHook', before the bot starts. The same directory without the bad token resolves, +-- so the failure is the token and not the fixture. +testBadgeServiceWebUnresolvableTokenFails :: HasCallStack => TestParams -> IO () +testBadgeServiceWebUnresolvableTokenFails TestParams {tmpPath} = do + let dir = tmpPath "web_dir_bad_token" + cfg = + WebConfig + { webPort = 0, + webHost = "127.0.0.1", + webBaseUrl = "http://127.0.0.1", + webSupportContact = T.pack testSupportContact, + webBehindProxy = False, + webDir = Just dir + } + writeTestWebDir dir + resolveWebPage cfg >>= \case + Left e -> expectationFailure $ "expected the fixture to resolve, got: " <> e + Right _ -> pure () + appendFile (dir "index.html") "\"\"\n" + resolveWebPage cfg >>= \case + Right _ -> expectationFailure "expected a token naming no served file to fail" + Left e -> do + ("logo-symbol-light.svg" `isInfixOf` e) `shouldBe` True + -- and it says what is in the set, since that is the only way to see the misspelling + ("main.js" `isInfixOf` e) `shouldBe` True + +-- [web] base_url is validated at startup as an absolute URL, https unless the host is a loopback +-- one -- the exception the local mock stack (plan §10) runs on. It ends up in provider return and +-- webhook URLs (E2, F1), which is not where a scheme-less value should first be noticed. +testBadgeServiceConfigBaseUrlValidated :: HasCallStack => TestParams -> IO () +testBadgeServiceConfigBaseUrlValidated TestParams {tmpPath} = do + (issuerKeyFile, codeSecretFile) <- writeTestBadgeServiceSecrets tmpPath + let path = tmpPath "base-url.ini" + writeBaseUrl baseUrl = + writeFile path $ + unlines $ + issuerCodesIniLines issuerKeyFile codeSecretFile + ++ ["", "[web]", "port = 8080", "base_url = " <> baseUrl, "support_contact = " <> testSupportContact] + forM_ ["http://badges.example.org", "http://badges.example.org:8080", "badges.example.org", "/checkout", "ftp://badges.example.org"] $ \baseUrl -> do + writeBaseUrl baseUrl + readBadgeServiceConfig path >>= \case + Right _ -> expectationFailure $ "expected " <> baseUrl <> " to be rejected" + Left err -> (baseUrl, "base_url" `isInfixOf` err) `shouldBe` (baseUrl, True) + forM_ ["https://badges.example.org", "http://localhost:8080", "http://127.0.0.1:8080"] $ \baseUrl -> do + writeBaseUrl baseUrl + readBadgeServiceConfig path >>= \case + Left err -> expectationFailure $ "expected " <> baseUrl <> " to be accepted, got: " <> err + Right BadgeServiceConfig {web} -> (baseUrl, fmap webBaseUrl web) `shouldBe` (baseUrl, Just (T.pack baseUrl))