core, tests, plan: serve the badge site over http

This commit is contained in:
shum
2026-08-27 10:28:27 +00:00
parent 34e1d975ab
commit 3421107907
8 changed files with 978 additions and 34 deletions
+16
View File
@@ -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/<buildHash>/<name>` 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).
@@ -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"]
@@ -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
@@ -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
'&' -> "&amp;"
'<' -> "&lt;"
'>' -> "&gt;"
'"' -> "&quot;"
'\'' -> "&#39;"
c -> T.singleton c
@@ -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\/\<buildHash\>\/@ 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")])
@@ -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/<buildHash>/<name>`, 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**: `@@<name>@@` resolves to `/assets/<buildHash>/<name>` for any `<name>` 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/<hash>/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/<hash>/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 `<meta charset>`, 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 `<script>`, `<style>` or `on*` handler, and `ui.js` sets no `style` attribute, all four checked by reading `web/dist` and `web/index.html` — so this is on the list for what a *later* step's markup could add, not for a known problem. Everything else D4 could be asked to show over a browser is asserted mechanically instead (its Verify line), including the module graph resolving under one prefix, which is the served-site half of D1's third item above.
- From D2: a keyboard-only pass through every screen, reaching and activating **every** option and the Continue button, with browser back and forward landing on the right screen — the hash-to-screen mapping is unit-tested but `pushState`/`popstate` wiring is not; at 320 px in both colour schemes, that no screen scrolls horizontally; that the selected card's 2 px accent border is visible in both schemes; that the `:focus-visible` ring is visible against both backgrounds, **including the ring the visually hidden radio projects onto its card** — the one place where hiding an input could silently cost the focus indicator; that the 150 ms fade runs, and does not under `prefers-reduced-motion: reduce`; that selection stays distinguishable under forced colours; and that submitting a question unanswered **shows the error banner** — the other half of that claim, that no *native validation bubble* can appear instead, is statically decidable and has been moved off this list: it needs a constraint attribute to fail and a submit that reaches the browser's default handling, and `static.test.mjs` asserts that no input carries `required`, `pattern`, `min`, `max`, `minlength` or `maxlength` and that the built shell calls `preventDefault()` on submit. Only "the banner is visible and announced" still needs eyes.
- **Before adding anything to this list, check whether it is statically decidable, and if it is, check it instead.** "Each scheme shows its own logo" was on this list and has been struck from it: it is not a rendering question but a stylesheet *ordering* question, and it shipped broken precisely because the list absorbed it. All four logo selectors are specificity (0,1,0), a conditional group rule adds none and does not reorder its contents, so the dark-scheme rules won nothing by being in a media query — they sat above the defaults they had to override, lost the cascade, and dark mode rendered the `#023789` logo on the `#000832` background with no error anywhere. `static.test.mjs` now asserts that the dark-scheme `display` declarations for `.logo--light`/`.logo--dark` are the **last** ones in the file for those selectors, and the fix moved that block to the end of the stylesheet. A list that absorbs statically-checkable items stops being a way to hold them and becomes a way to defer them.
- **D2 — the shell is four modules, not the two the Files list named, and there is now a `web/test/` directory.** The step named `src/{ui.ts,main.ts}`. Splitting out `router.ts` (the pure hash-to-screen mapping) and `view.ts` (each screen as a pure element tree, with no DOM call in it) is what makes the entry above a short list instead of the whole step: with the pure half separated, "every screen has exactly one `<h1>`", "every radio is inside a `<label>`" and "all six hashes resolve" are assertions a machine can run, and only *rendering* needs a human. `ui.ts` is the only module that touches the DOM and stays unasserted. The tests are `node:test` and `node:assert`, **built-in modules**, run by a new `npm test` script: nothing was added to `package.json`'s dependencies or to the lockfile, so decision 7's one-devDependency cap is intact. They import from `dist/`, not `src/`, so they assert on the bytes a browser is served. `test/css.mjs` is a 60-line reader for the stylesheet — a CSS parser is a dependency this project may not have, and grepping raw text cannot tell a declaration inside the dark media query from one outside it, which is the exact distinction the light-mode trap turns on. **Files** corrected; `package.json` added to it.
@@ -1512,6 +1513,13 @@ Append here when a step contradicts this plan: the step id, what was wrong, and
**Two silent-wrong paths remain in `declaration()`, both unreachable in today's `styles.css` and both older than this round.** The round-3 re-review probed for what the four refusals still miss and found exactly two. First, `declaration()`'s regex carries no `/g` flag, so a property declared **twice in one rule block** returns the *first* match where the cascade takes the last. Second, a `display: var(--x)` indirection is returned as the literal string `var(--x)`, and because the logo test only asks whether the value differs from `none`, an unresolved custom property would count as visible whatever it resolves to. Neither is reachable now — no rule block in `styles.css` declares a property twice, and no `display` anywhere uses `var()` — so neither was fixed, on the same "unreachable is not a defect" ground the plan applies elsewhere. They are recorded because the guard against them is a property of the *stylesheet*, not of the helper: whoever adds a duplicated declaration or a `var()`-valued `display` re-opens them, and will get a confidently wrong answer with a green suite, which is precisely what rounds 2 and 3 were spent eliminating.
- **D4 — the step's two `Service.hs` citations were stale, and its concern about `raceAny_` was already resolved.** It cited `badgeServiceCLI` at `:86` and `badgeService` at `:55-69`, and said the default entry point's "`simplexChatCore … forever` loop must also be raced against the web listener". By D4 `badgeService` is at `:144` and **already** uses `raceAny_`, over `processServiceEvents` and B7's `sweepSignerBucketsLoop`; `badgeServiceCLI` is at `:167` with three arms. The listener is therefore a third (fourth) arm on an existing race, on both entry points. The bullet is corrected above, with the consequence the original phrasing hid: `raceAny_` is `waitAnyCancel`, so the arm must **not return** when `[web]` is absent — a "nothing to do" arm that finishes would cancel the bot with it. It parks instead.
- **D4 — the Verify line was "Manual" while the step's Files list named `tests/Bots/BadgeServiceTests.hs`, which §4 rule 10 forbids.** Every item on that manual list is mechanically checkable over HTTP against the harness's own service, and all of them now are (the line is rewritten above); only rendering and CSP-violation reporting need a browser, and those went to the phase's one browser entry. Fifteen mutations were applied one at a time and each was watched to fail on the named assertion: a per-file asset hash (the module graph 404s and the "one prefix" assertion reports four), `dev.html` left in the served set, the build-hash check skipped, the security headers dropped from the 404 path only (the happy-path example stayed green, which is the point), `catalogTotals` dropped (`total` goes null), the catalog served from `Catalog.hs`'s defaults (the disabled price comes back), `web_dir` answered from the startup-cached page (the edit is invisible), `web_dir` assets marked `immutable` (embedded mode stayed green), the request name joined onto the directory (the percent-encoded `../../` traversal returns 200 on a file outside `web_dir`), an unresolvable token passed through as literal text, `support_contact` resolved to a constant instead of the ini value, `base_url` validation removed, the method guard removed, the content-type table defeated, and the index page marked immutable.
- **D4 — `withBadgeService` keeps its arity; the base URL is handed to bodies that want it by a sibling `withBadgeServiceWeb`.** The step said to "pass the base URL to the test body". Threading a third argument through `withBadgeService`/`withBadgeServiceConfig`/`withBadgeServiceClock` would have added an unused binder to more than forty bodies that never make an HTTP request. `[web]` **is** written into the shared ini as the step requires (which is what E2 and F1 need, since A6 rejects a provider section without one); only the URL travels by a separate entry point.
- **D4 — the two service starts in the test harness cannot share a web port, because `runSimplexChat` orphans the service's own callback thread.** `Simplex.Chat.Core`'s `runSimplexChat` runs the callback as `a2 <- async $ chat u cc` and never cancels it, so killing a badge service in-process leaves that thread — and now the web listener's socket with it — running until the test process exits. The address-creating start therefore runs from a copy of the ini with `[web] port` rewritten to 0 (an ephemeral port), and only the serving start binds the port the body talks to, which the harness holds bound until the moment that start begins so nothing else can take it. Every start that no test addresses uses the ephemeral port too, so a body that restarts the service (C5's `withService`, called twice) does not collide with itself. **This is a real defect in `Core.hs`, not merely a test inconvenience** — every bot leaks its callback thread the same way — but fixing it changes the shutdown semantics of every chat client in the repo, including `tests/ChatClient.hs`, and validating that needs the whole test suite, not the badge subset. Recorded here for whoever owns `Core.hs`; nothing in production depends on it, since a service process starts once.
- **D4 — `index.html` is itself in the served set, and is reachable under the asset prefix.** The step lists it as embedded but does not say whether a token may name it. `build.mjs` resolves `@@index.html@@` (it is in `ROOT_FILES`), so the service must too, or a token would resolve in the development build and fail at startup in production. It is served under the prefix with the same substituted bytes and the same `no-cache` as `/`, so a resolved `@@index.html@@` is a URL that works rather than a 404.
- **D4 — `@@support_contact@@` is HTML-escaped on the way into the page; `build.mjs` does not escape its placeholder.** The value is operator-controlled and lands inside an `href` attribute, so a quote in it would end the attribute. The asset URLs are not escaped and need no escaping: they are built from a hex digest and a name in the token charset. This is a deliberate divergence from `build.mjs`, which substitutes a fixed development placeholder that contains nothing to escape; the token *resolution rule* — which names resolve, and to what — is identical in both.
## 10. End-to-end verification
After F5:
+4
View File
@@ -428,6 +428,8 @@ executable simplex-badge-service
BadgeService.Service
BadgeService.Store
BadgeService.Store.Migrate
BadgeService.Web.Assets
BadgeService.Web.Server
Paths_simplex_chat
ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -Werror=name-shadowing -threaded -rtsopts
build-depends:
@@ -712,6 +714,8 @@ test-suite simplex-chat-test
BadgeService.Service
BadgeService.Store
BadgeService.Store.Migrate
BadgeService.Web.Assets
BadgeService.Web.Server
Bots.BadgeCodeTests
Bots.BadgeLedgerTests
Bots.BadgeManagerTests
+475 -25
View File
@@ -27,6 +27,7 @@ import BadgeService.Config
IssuerConfig (IssuerConfig),
SignerBucketFamily (..),
ThrottleConfig (..),
WebConfig (..),
checkFailureBuckets,
debitFailureBuckets,
newBadgeServiceEnv,
@@ -37,15 +38,16 @@ import BadgeService.Credentials (issueSignedBadge, loadIssuerKey)
import BadgeService.Options
import BadgeService.Service
import BadgeService.Store
import BadgeService.Web.Server (resolveWebPage)
import Bots.BadgeManagerTests (allowPass, gatedClockAt, newBadgeGate, waitPasses)
import ChatClient
import ChatTests.DBUtils
import ChatTests.Profiles (testBadgeKeys)
import ChatTests.Utils
import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Concurrent.Async (async, wait)
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (async, wait, withAsync)
import Control.Concurrent.STM (atomically, readTVarIO, writeTVar)
import Control.Exception (SomeException, finally, try)
import Control.Exception (SomeException, bracket, finally, try)
import Control.Monad (forM_, replicateM, unless, void)
import Control.Monad.Except (ExceptT)
import Control.Monad.IO.Class (liftIO)
@@ -57,9 +59,10 @@ import qualified Data.Aeson.Types as JT
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy.Char8 as LBC
import qualified Data.CaseInsensitive as CI
import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
import Data.Int (Int64)
import Data.List (find, isInfixOf, isPrefixOf, nub, sort, stripPrefix)
import Data.List (find, isInfixOf, isPrefixOf, isSuffixOf, nub, sort, stripPrefix)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust, isJust, mapMaybe)
import Data.String (fromString)
@@ -72,6 +75,10 @@ import Data.Time.Clock (DiffTime, NominalDiffTime, UTCTime (..), addUTCTime, dif
import Data.Word (Word8, Word32)
import GHC.IO.Handle (hDuplicate, hDuplicateTo)
-- qualified: 'defaultPrefs' collides with ChatTests.Utils' own (chat preferences, unrelated)
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Types (Status (statusCode))
import Network.Socket (close)
import qualified Network.Wai.Handler.Warp as Warp
import qualified Options.Applicative as O
import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey (..), BadgeRequest (..), BadgeType (..), VerifiedBadgeRequest (..), generateMasterKey, issueBadge, verifyCredential)
import Simplex.Chat.Badges.Months (addMonths)
@@ -130,6 +137,7 @@ import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.BBS (BBSPublicKey (..), BBSSecretKey (..), bbsKeyGen)
import Simplex.Messaging.Encoding.String (strDecode, strEncode)
import System.Directory (createDirectoryIfMissing)
import System.Exit (ExitCode (..))
import System.FilePath ((</>))
import System.IO (IOMode (..), hClose, hFlush, openFile, stdout)
@@ -189,6 +197,14 @@ badgeServiceTests = do
it "should respond unknown_purchase_key to a signed getBadgeCatalog from an unknown key" testBadgeServiceGetCatalogUnknownSignerKey
it "should heal the ledger on a signed getBadgeCatalog, appending exactly one debit(lapse), and heal nothing on a repeat" testBadgeServiceGetCatalogHealsLedger
it "should rate_limit a third unsigned getBadgeCatalog once the catalog bucket is drained, without affecting a signed one" testBadgeServiceGetCatalogBucketThrottle
it "should serve the index with every token resolved and every asset it names fetchable under one prefix" testBadgeServiceWebIndexResolvesTokens
it "should serve every module a served module imports under that module's own prefix" testBadgeServiceWebModuleGraphUnderOnePrefix
it "should answer 404 for dev.html and for an asset under a stale build hash" testBadgeServiceWebDevHtmlAndStalePrefixAre404
it "should set the four security headers on every response, including a 404 and a rejected method" testBadgeServiceWebSecurityHeadersEverywhere
it "should serve the database catalog with computed totals from /api/catalog" testBadgeServiceWebCatalogEndpoint
it "should serve web_dir from disk with no-store, pick up an edit without a restart and refuse a path outside it" testBadgeServiceWebDirServesFromDisk
it "should fail before the service starts when a token names no served file, naming the token" testBadgeServiceWebUnresolvableTokenFails
it "should reject a non-loopback http base_url and accept https and loopback ones" testBadgeServiceConfigBaseUrlValidated
it "should create a purchase and append ledger entries readable back in order" testBadgeStorePurchaseAndLedger
it "should disable a price out of the active catalog while both stay reachable by id" testBadgeStoreSetPriceStatusDisabled
it "should return the redeeming purchase key from getCodeByHash" testBadgeStoreGetCodeByHashRedeemer
@@ -309,23 +325,64 @@ issuerCodesIniLines issuerKeyFile codeSecretFile =
"default_expiry_days = 365"
]
-- The '[web]' section the harness writes into every ini it builds (D4), on the free port
-- 'withBadgeServiceAddress' bound for this test. 'base_url' is http, which the config parser
-- accepts only because the host is a loopback address.
webIniLines :: Int -> [String]
webIniLines port =
[ "[web]",
"port = " <> show port,
"base_url = " <> testWebBaseUrl port,
"support_contact = " <> testSupportContact
]
testWebBaseUrl :: Int -> String
testWebBaseUrl port = "http://127.0.0.1:" <> show port
-- Deliberately unlike anything the site, build.mjs or the plan carries, so that finding it in
-- the served page proves the value came from THIS ini rather than from a default, a fallback or
-- dev.html's placeholder.
testSupportContact :: String
testSupportContact = "https://example.invalid/support-from-ini"
-- Binds port 0, reads back the port the OS chose and closes the socket again. Used where an ini
-- needs a '[web] port' value that nothing will ever bind; the harness itself HOLDS the socket it
-- reserves instead (see 'withBadgeServiceWebAddress').
freeWebPort :: IO Int
freeWebPort = do
(port, sock) <- Warp.openFreePort
close sock
pure port
-- Writes a complete but minimal badge_service.ini (required sections only, no provider
-- section) at the path mkBadgeServiceOpts points BadgeServiceOpts's configFile at. Provider
-- sections are omitted until E2 and F1 add them.
writeTestBadgeServiceConfig :: TestParams -> IO ()
-- sections are omitted until E2 and F1 add them, and '[web]' is written for them: A6 requires
-- it whenever a provider is configured. The port is the caller's, because the site's base URL
-- has to be known before the service starts (D4).
writeTestBadgeServiceConfig :: TestParams -> Int -> IO ()
writeTestBadgeServiceConfig ps = writeTestBadgeServiceConfigWith ps []
-- The same file with extra ini lines appended -- so far only a '[throttle]' override (B5
-- decision 5), which is how B10 drives the failure buckets to their limits in a handful of
-- requests instead of hundreds.
writeTestBadgeServiceConfigWith :: TestParams -> [String] -> IO ()
writeTestBadgeServiceConfigWith TestParams {tmpPath} extraLines = do
writeTestBadgeServiceConfigWith :: TestParams -> [String] -> Int -> IO ()
writeTestBadgeServiceConfigWith TestParams {tmpPath} extraLines port = do
(issuerKeyFile, codeSecretFile) <- writeTestBadgeServiceSecrets tmpPath
writeFile (badgeServiceConfigPath tmpPath) $ unlines (issuerCodesIniLines issuerKeyFile codeSecretFile ++ extraLines)
writeFile (badgeServiceConfigPath tmpPath) $
unlines (issuerCodesIniLines issuerKeyFile codeSecretFile ++ ("" : webIniLines port) ++ extraLines)
withBadgeService :: HasCallStack => TestParams -> (TestCC -> String -> IO ()) -> IO ()
withBadgeService ps = withBadgeServiceConfig ps (writeTestBadgeServiceConfig ps) (pure ())
-- | 'withBadgeService' with the site's base URL handed to the body as a third argument (D4).
-- It is a separate entry point rather than a third argument on every existing body, because
-- forty-odd bodies that never make an HTTP request would gain an unused binder each.
withBadgeServiceWeb :: HasCallStack => TestParams -> (TestCC -> String -> String -> IO ()) -> IO ()
withBadgeServiceWeb ps = withBadgeServiceWebConfig ps (writeTestBadgeServiceConfig ps) (pure ())
withBadgeServiceWebConfig :: HasCallStack => TestParams -> (Int -> IO ()) -> IO () -> (TestCC -> String -> String -> IO ()) -> IO ()
withBadgeServiceWebConfig ps = withBadgeServiceWebClock ps getCurrentTime
-- Shared by withBadgeService and testBadgeServiceCompleteConfigStarts: the two-phase startup
-- dance (CreateMyAddress, then ShowMyAddress) is the same regardless of what the config looks
-- like, as long as it's valid; writeConfig is what varies. 'betweenPhases' runs after the
@@ -335,7 +392,7 @@ withBadgeService ps = withBadgeServiceConfig ps (writeTestBadgeServiceConfig ps)
-- 'withFreshBadgeStore' -- opening a second connection to the SAME sqlite file WHILE the
-- service's own phase is running deadlocks against its writer lock (verified: reliably fails
-- 'createDBStore' with a pattern-match-on-Right, i.e. sqlite busy, when tried in that window).
withBadgeServiceConfig :: HasCallStack => TestParams -> IO () -> IO () -> (TestCC -> String -> IO ()) -> IO ()
withBadgeServiceConfig :: HasCallStack => TestParams -> (Int -> IO ()) -> IO () -> (TestCC -> String -> IO ()) -> IO ()
withBadgeServiceConfig ps = withBadgeServiceClock ps getCurrentTime
-- The same harness with the service's own clock replaced (A6: 'BadgeServiceEnv.now' is the only
@@ -343,7 +400,7 @@ withBadgeServiceConfig ps = withBadgeServiceClock ps getCurrentTime
-- 'newBadgeServiceEnv' installs there). Both service starts get the same clock, so time is
-- continuous across the between-phases window. This is what lets B10 cross a month boundary or a
-- throttle bucket's refill window without any test sleeping -- see 'newTestClock'.
withBadgeServiceClock :: HasCallStack => TestParams -> IO UTCTime -> IO () -> IO () -> (TestCC -> String -> IO ()) -> IO ()
withBadgeServiceClock :: HasCallStack => TestParams -> IO UTCTime -> (Int -> IO ()) -> IO () -> (TestCC -> String -> IO ()) -> IO ()
withBadgeServiceClock ps clock writeConfig betweenPhases test =
withBadgeServiceAddress ps clock writeConfig betweenPhases $ \(sLink, _fullLink) withService ->
-- Second start: badge service takes the ShowMyAddress branch, then serves the test body.
@@ -351,6 +408,15 @@ withBadgeServiceClock ps clock writeConfig betweenPhases test =
withNewTestChatCfg ps testCfg "client" bobProfile $ \client ->
test client sLink
-- | The same, with the site's base URL as a third argument to the body -- see
-- 'withBadgeServiceWeb'.
withBadgeServiceWebClock :: HasCallStack => TestParams -> IO UTCTime -> (Int -> IO ()) -> IO () -> (TestCC -> String -> String -> IO ()) -> IO ()
withBadgeServiceWebClock ps clock writeConfig betweenPhases test =
withBadgeServiceWebAddress ps clock writeConfig betweenPhases $ \webUrl (sLink, _fullLink) withService ->
withService $
withNewTestChatCfg ps testCfg "client" bobProfile $ \client ->
test client sLink webUrl
-- | The same first phase, with the SECOND phase handed to the body as @withService@ instead of
-- wrapped around it, and with the service's contact address in both published forms.
--
@@ -363,13 +429,35 @@ withBadgeServiceClock ps clock writeConfig betweenPhases test =
-- The full contact request URI is the second element: it is one of the four target forms
-- 'Simplex.Chat.Library.Commands.resolveServiceTarget' accepts and, without it, only the short
-- link would ever be exercised.
withBadgeServiceAddress :: HasCallStack => TestParams -> IO UTCTime -> IO () -> IO () -> ((String, String) -> (IO () -> IO ()) -> IO ()) -> IO ()
withBadgeServiceAddress ps clock writeConfig betweenPhases test = do
withBadgeServiceAddress :: HasCallStack => TestParams -> IO UTCTime -> (Int -> IO ()) -> IO () -> ((String, String) -> (IO () -> IO ()) -> IO ()) -> IO ()
withBadgeServiceAddress ps clock writeConfig betweenPhases test =
badgeServicePhases ps ephemeralWebPort (pure ()) clock writeConfig betweenPhases test
-- | The same, with a web port the body can actually address, and its base URL as the FIRST
-- argument to the body. The port is reserved -- bound and HELD -- until the moment the serving
-- start begins, so that no other socket in this process, including the first phase's listener,
-- can be handed it in the meantime.
--
-- Only this family gets an addressable port, and no body in it starts the service more than
-- once: see 'ephemeralWebPort' for what goes wrong when two starts in one test process are given
-- the same port.
withBadgeServiceWebAddress :: HasCallStack => TestParams -> IO UTCTime -> (Int -> IO ()) -> IO () -> (String -> (String, String) -> (IO () -> IO ()) -> IO ()) -> IO ()
withBadgeServiceWebAddress ps clock writeConfig betweenPhases test =
bracket Warp.openFreePort (close . snd) $ \(port, reservedSocket) ->
badgeServicePhases ps port (close reservedSocket) clock writeConfig betweenPhases (test (testWebBaseUrl port))
-- The two-phase startup itself, shared by both: 'writeConfig' gets the port the SERVING start may
-- bind, the address-creating start always runs on an ephemeral one, and 'releasePort' runs
-- immediately before the serving start (the web variant hands back the port it reserved; the
-- plain one has nothing to release).
badgeServicePhases :: HasCallStack => TestParams -> Int -> IO () -> IO UTCTime -> (Int -> IO ()) -> IO () -> ((String, String) -> (IO () -> IO ()) -> IO ()) -> IO ()
badgeServicePhases ps webPort releasePort clock writeConfig betweenPhases test = do
let opts = (mkBadgeServiceOpts ps) {serviceClock = clock}
writeConfig
writeConfig webPort
phase1Config <- writeConfigOnEphemeralWebPort (badgeServiceConfigPath (tmpPath ps))
withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_ -> pure ()
-- First start: badge service takes the CreateMyAddress branch.
runBadgeService testCfg opts (pure ())
runBadgeService testCfg opts {configFile = phase1Config} (pure ())
-- Reopen the DB to read the links the service created.
links <- withTestChat ps serviceDbPrefix $ \bs -> do
bs <## "subscribed 1 connections on server localhost"
@@ -378,13 +466,51 @@ withBadgeServiceAddress ps clock writeConfig betweenPhases test = do
bs <## "auto_accept off"
pure links
betweenPhases
releasePort
test links (runBadgeService testCfg opts)
-- | Port 0 makes Warp bind an ephemeral port: the listener runs exactly as it does in production,
-- but nothing in the test can address it -- and nothing else in the process can collide with it.
-- Every service start uses this except the single serving start of a web test, because two starts
-- in one test process cannot share a port:
--
-- * 'runSimplexChat' starts the service's own callback with 'async' and never cancels it
-- ('Simplex.Chat.Core'), so killing a badge service leaves its 'raceAny_' -- and the web
-- listener's socket with it -- running until the test process exits. Production starts the
-- service once per process, so nothing there depends on that thread being reclaimed.
-- * a failed bind takes the whole service down, since the listener is an arm of that 'raceAny_'.
-- A second start on a port the first still holds leaves the test with no bot at all, not
-- merely without a site.
ephemeralWebPort :: Int
ephemeralWebPort = 0
-- The ini the address-creating start reads: the same file with '[web] port' rewritten to
-- 'ephemeralWebPort'. The section is rewritten rather than dropped, because A6 refuses to start a
-- config that has a provider section and no '[web]', which is what
-- 'testBadgeServiceCompleteConfigStarts' writes.
writeConfigOnEphemeralWebPort :: FilePath -> IO FilePath
writeConfigOnEphemeralWebPort path = do
ls <- T.lines <$> TIO.readFile path
let dest = path <> ".phase1"
TIO.writeFile dest $ T.unlines (rewrite "" ls)
pure dest
where
rewrite _ [] = []
rewrite section (l : ls)
| "[" `T.isPrefixOf` T.strip l = l : rewrite (T.strip l) ls
| section == "[web]" && "port" `T.isPrefixOf` T.strip l = T.pack ("port = " <> show ephemeralWebPort) : rewrite section ls
| otherwise = l : rewrite section ls
-- 'withAsync' rather than 'forkIO'/'killThread': its cleanup WAITS for the service thread to finish
-- unwinding instead of returning as soon as the exception is delivered, so what a start holds --
-- the web listener's socket above all (D4) -- is released before the next start of the same test.
-- It is not sufficient on its own: the thread it cancels is not the one that owns the listener,
-- because 'runSimplexChat' orphans that one. See 'ephemeralWebPort'.
runBadgeService :: ChatConfig -> BadgeServiceOpts -> IO () -> IO ()
runBadgeService cfg opts action = do
t <- forkIO $ badgeService opts cfg
threadDelay 500000
action `finally` killThread t
runBadgeService cfg opts action =
withAsync (badgeService opts cfg) $ \_ -> do
threadDelay 500000
action
-- B5 RPC dispatcher -----------------------------------------------------------
@@ -547,7 +673,9 @@ testBadgeServicePurchaseBadgeAppleBadRequest ps =
testBadgeServicePurchaseCodeThrottlePreCheck :: HasCallStack => TestParams -> IO ()
testBadgeServicePurchaseCodeThrottlePreCheck ps = do
(issuerKeyFile, codeSecretFile) <- writeTestBadgeServiceSecrets (tmpPath ps)
let writeConfig =
-- no [web] section: this ini also covers the case where the service runs with no listener at
-- all, which must leave the bot answering exactly as it does with one (D4)
let writeConfig _port =
writeFile (badgeServiceConfigPath (tmpPath ps)) $
unlines $
issuerCodesIniLines issuerKeyFile codeSecretFile
@@ -967,7 +1095,7 @@ testBadgeServiceCompleteConfigStarts ps@TestParams {tmpPath} =
client ##> ("/_service_request 1 " <> bsLink <> " " <> redeemReq)
client <## "service response: {\"code\":\"bad_request\",\"type\":\"error\"}"
where
writeCompleteConfig = do
writeCompleteConfig port = do
(issuerKeyFile, codeSecretFile) <- writeTestBadgeServiceSecrets tmpPath
let apiKeyFile = tmpPath </> "btcpay-api.key"
btcWebhookFile = tmpPath </> "btcpay-webhook.secret"
@@ -982,7 +1110,7 @@ testBadgeServiceCompleteConfigStarts ps@TestParams {tmpPath} =
issuerCodesIniLines issuerKeyFile codeSecretFile
++ [ "",
"[web]",
"port = 0",
"port = " <> show port,
"base_url = https://badges.example.org",
"support_contact = https://simplex.chat/contact",
"",
@@ -1014,7 +1142,7 @@ testBadgeServiceCompleteConfigStarts ps@TestParams {tmpPath} =
testBadgeServicePublishesAddressFile :: HasCallStack => TestParams -> IO ()
testBadgeServicePublishesAddressFile ps@TestParams {tmpPath} = do
let addressFile = tmpPath </> "bot_address.txt"
writeConfig = do
writeConfig _port = do
(issuerKeyFile, codeSecretFile) <- writeTestBadgeServiceSecrets tmpPath
writeFile (badgeServiceConfigPath tmpPath) $
unlines $
@@ -1171,7 +1299,7 @@ testBadgeServiceGetCatalogBucketThrottle ps = do
(issuerKeyFile, codeSecretFile) <- writeTestBadgeServiceSecrets (tmpPath ps)
(pub, priv) <- mkTestKeyPair
masterKey <- BadgeMasterKey <$> getRandomBytes 32
let writeConfig =
let writeConfig _port =
writeFile (badgeServiceConfigPath (tmpPath ps)) $
unlines $
issuerCodesIniLines issuerKeyFile codeSecretFile
@@ -2119,7 +2247,8 @@ testBadgeServiceNoTableLinksOrdersToPurchases ps =
-- nowhere else.
testBadgeServiceCodesIssueRevokeStatus :: HasCallStack => TestParams -> IO ()
testBadgeServiceCodesIssueRevokeStatus ps@TestParams {tmpPath} = do
writeTestBadgeServiceConfig ps
-- the admin subcommand never starts a listener, so this port is only ever written to the ini
freeWebPort >>= writeTestBadgeServiceConfig ps
let adminOpts cmd =
AdminOpts
{ adminCoreOptions = coreOptions (mkBadgeServiceOpts ps),
@@ -3645,3 +3774,324 @@ testC5UnreadableResponsesAreReported ps =
answerStubRequest stub undecodable
alice <##. "badge service error: internal, The badge service answered with something this app version cannot read."
noClientBadgeRows "after unreadable responses" alice
-- D4 web listener -------------------------------------------------------------
-- One HTTP response, reduced to what the assertions below need. The body is a String because
-- everything asserted about it is a substring or an exact small file, and 'isInfixOf' is already
-- how this module reads text.
data WebResponse = WebResponse
{ wrStatus :: Int,
wrHeaders :: [(CI.CI BC.ByteString, BC.ByteString)],
wrBody :: String
}
-- One manager per test rather than one per request: a request-per-manager leaves a connection
-- pool behind for each call, and these tests make dozens.
newWebManager :: IO HTTP.Manager
newWebManager = HTTP.newManager HTTP.defaultManagerSettings
-- 'HTTP.parseRequest' (unlike 'parseUrlThrow') installs no status check, so a 404 comes back as
-- a response to assert on rather than as an exception. The path is sent as written, which is what
-- lets the traversal cases below reach the server percent-encoded.
webGet :: HTTP.Manager -> String -> IO WebResponse
webGet mgr url = do
req <- HTTP.parseRequest url
r <- HTTP.httpLbs req mgr
pure
WebResponse
{ wrStatus = statusCode (HTTP.responseStatus r),
wrHeaders = HTTP.responseHeaders r,
wrBody = LBC.unpack (HTTP.responseBody r)
}
webHeader :: WebResponse -> BC.ByteString -> String
webHeader r name = maybe "" BC.unpack $ lookup (CI.mk name) (wrHeaders r)
-- The four headers D4 requires on EVERY response, checked as a client sees them. Called on a
-- 200, on a 404 and on the JSON endpoint, since "every response" is the actual requirement.
assertSecurityHeaders :: HasCallStack => String -> WebResponse -> IO ()
assertSecurityHeaders what r = do
(what, webHeader r "content-security-policy") `shouldBe` (what, "default-src 'self'")
(what, webHeader r "x-content-type-options") `shouldBe` (what, "nosniff")
(what, webHeader r "referrer-policy") `shouldBe` (what, "no-referrer")
(what, webHeader r "x-frame-options") `shouldBe` (what, "DENY")
-- Every asset URL the served page references, in document order: the tokens resolve into quoted
-- attributes and an asset URL contains no quote, so this reads what the browser would follow.
webAssetUrls :: String -> [String]
webAssetUrls body = map (T.unpack . ("/assets/" <>) . T.takeWhile (/= '"')) . drop 1 $ T.splitOn "/assets/" (T.pack body)
-- "/assets/<buildHash>/main.js" -> "<buildHash>"
webAssetHash :: HasCallStack => String -> String
webAssetHash url = case T.splitOn "/" (T.pack url) of
("" : "assets" : h : _ : _) -> T.unpack h
_ -> error $ "not an asset URL: " <> url
-- The relative specifiers in an emitted module, as `import ... from "./ui.js"` leaves them: tsc
-- does not rewrite them (decision 7), so the browser resolves them against the module's own URL.
relativeImports :: String -> [String]
relativeImports js = nub [t | (i, t) <- zip [0 :: Int ..] (map T.unpack (T.splitOn "\"" (T.pack js))), odd i, "./" `isPrefixOf` t]
-- GET / must return the page with every token resolved -- not one @@name@@ left, the non-file
-- token carrying the value from THIS ini, and every URL it names actually fetchable, which is the
-- outcome the tokens exist for. All of them sit under ONE prefix: see
-- testBadgeServiceWebModuleGraphUnderOnePrefix for why that is load-bearing.
testBadgeServiceWebIndexResolvesTokens :: HasCallStack => TestParams -> IO ()
testBadgeServiceWebIndexResolvesTokens ps =
withBadgeServiceWeb ps $ \_client _bsLink webUrl -> do
mgr <- newWebManager
index <- webGet mgr webUrl
wrStatus index `shouldBe` 200
webHeader index "content-type" `shouldBe` "text/html; charset=utf-8"
-- the page itself is never cached: its asset URLs and its support link both change without
-- the page's own URL changing
webHeader index "cache-control" `shouldBe` "no-cache"
wrBody index `shouldSatisfy` (not . isInfixOf "@@")
wrBody index `shouldSatisfy` isInfixOf testSupportContact
let urls = webAssetUrls (wrBody index)
names = sort $ map (T.unpack . last . T.splitOn "/" . T.pack) urls
-- D2's index.html names four files; a later step that adds one adds a token and nothing else
names `shouldBe` ["logo-symbol-dark.svg", "logo-symbol-light.svg", "main.js", "styles.css"]
nub (map webAssetHash urls) `shouldSatisfy` ((== 1) . length)
forM_ urls $ \u -> do
r <- webGet mgr (webUrl <> u)
(u, wrStatus r) `shouldBe` (u, 200)
(u, webHeader r "cache-control") `shouldBe` (u, "public, max-age=31536000, immutable")
assertSecurityHeaders u r
-- and the two files that are not in dist/ are served with their own content types
css <- webGet mgr (webUrl <> head (filter ("/styles.css" `isSuffixOf`) urls))
webHeader css "content-type" `shouldBe` "text/css; charset=utf-8"
logo <- webGet mgr (webUrl <> head (filter ("-light.svg" `isSuffixOf`) urls))
webHeader logo "content-type" `shouldBe` "image/svg+xml"
-- The reason the build hash is one hash for the whole set and not one per file: tsc leaves
-- `from "./ui.js"` alone, so the browser resolves it against main.js's own directory. Every
-- sibling main.js imports must therefore answer under main.js's OWN prefix -- with a per-file
-- hash each would sit at a different one and the module graph would 404 after the entry point.
-- Asserted by following the specifiers out of the served bytes, not by reading the source.
testBadgeServiceWebModuleGraphUnderOnePrefix :: HasCallStack => TestParams -> IO ()
testBadgeServiceWebModuleGraphUnderOnePrefix ps =
withBadgeServiceWeb ps $ \_client _bsLink webUrl -> do
mgr <- newWebManager
index <- webGet mgr webUrl
let mainUrl = head $ filter ("/main.js" `isSuffixOf`) (webAssetUrls (wrBody index))
prefix = "/assets/" <> webAssetHash mainUrl
mainJs <- webGet mgr (webUrl <> mainUrl)
wrStatus mainJs `shouldBe` 200
webHeader mainJs "content-type" `shouldBe` "text/javascript; charset=utf-8"
let specifiers = relativeImports (wrBody mainJs)
specifiers `shouldSatisfy` (not . null)
forM_ specifiers $ \specifier -> do
let url = prefix <> "/" <> drop 2 specifier
r <- webGet mgr (webUrl <> url)
(specifier, wrStatus r) `shouldBe` (specifier, 200)
-- the imported module's own imports must resolve at the same prefix, one level deeper
forM_ (relativeImports (wrBody r)) $ \nested -> do
nestedR <- webGet mgr (webUrl <> prefix <> "/" <> drop 2 nested)
(specifier, nested, wrStatus nestedR) `shouldBe` (specifier, nested, 200)
-- dev.html is in the binary (embedDir takes no predicate) and must never be routed, under the
-- asset prefix or at the root; and an asset named under any other prefix is 404, which is what
-- makes the immutable long-cache above safe. The same name under the RIGHT prefix is fetched in
-- the same test, so neither 404 can be passing for the wrong reason.
testBadgeServiceWebDevHtmlAndStalePrefixAre404 :: HasCallStack => TestParams -> IO ()
testBadgeServiceWebDevHtmlAndStalePrefixAre404 ps =
withBadgeServiceWeb ps $ \_client _bsLink webUrl -> do
mgr <- newWebManager
index <- webGet mgr webUrl
let mainUrl = head $ filter ("/main.js" `isSuffixOf`) (webAssetUrls (wrBody index))
buildHash = webAssetHash mainUrl
staleHash = map (\c -> if c == 'a' then 'b' else 'a') buildHash
served <- webGet mgr (webUrl <> mainUrl)
wrStatus served `shouldBe` 200
stale <- webGet mgr (webUrl <> "/assets/" <> staleHash <> "/main.js")
wrStatus stale `shouldBe` 404
forM_ ["/dev.html", "/assets/" <> buildHash <> "/dev.html"] $ \path -> do
r <- webGet mgr (webUrl <> path)
(path, wrStatus r) `shouldBe` (path, 404)
-- the banner npm run build writes into dev.html: not merely a 404 status, but none of the
-- file's bytes in the response
(path, "Generated from index.html" `isInfixOf` wrBody r) `shouldBe` (path, False)
assertSecurityHeaders path r
-- "Every response" includes the ones no route produced: a 404 and a rejected method carry the
-- same four headers as the page. A framing or CSP header present only on the happy path is the
-- one a browser needs on the response an attacker can reach.
testBadgeServiceWebSecurityHeadersEverywhere :: HasCallStack => TestParams -> IO ()
testBadgeServiceWebSecurityHeadersEverywhere ps =
withBadgeServiceWeb ps $ \_client _bsLink webUrl -> do
mgr <- newWebManager
forM_ ["", "/api/catalog", "/no-such-path", "/assets", "/assets/deadbeef/main.js"] $ \path -> do
r <- webGet mgr (webUrl <> path)
assertSecurityHeaders path r
postReq <- HTTP.parseRequest (webUrl <> "/api/catalog")
postResp <- HTTP.httpLbs postReq {HTTP.method = "POST"} mgr
let post = WebResponse {wrStatus = statusCode (HTTP.responseStatus postResp), wrHeaders = HTTP.responseHeaders postResp, wrBody = LBC.unpack (HTTP.responseBody postResp)}
wrStatus post `shouldBe` 405
assertSecurityHeaders "POST /api/catalog" post
-- /api/catalog answers from the DATABASE through catalogTotals, never from Catalog.hs's
-- defaults: the fixture disables one seeded price and deprecates the other, so the default
-- catalog (two prices, four offers) is the WRONG answer and an endpoint that served it would
-- fail here. The payload is decoded as the RPC 'BadgeCatalog' the app parses (A2), so the shape
-- is asserted by the decode and the totals by the values.
testBadgeServiceWebCatalogEndpoint :: HasCallStack => TestParams -> IO ()
testBadgeServiceWebCatalogEndpoint ps = do
priceIdsRef <- newIORef Nothing
let seedStatuses =
withTestChat ps serviceDbPrefix $ \bs -> do
bs <## "subscribed 1 connections on server localhost"
priceIds <- expectRight $ withServiceTransaction (chatStore (chatController bs)) $ \db -> do
BadgeCatalog {prices} <- getActiveCatalog db
case prices of
[BadgePrice {priceId = pid1}, BadgePrice {priceId = pid2}] -> do
setPriceStatus db pid1 BISDisabled
setPriceStatus db pid2 BISDeprecated
pure (pid1, pid2)
_ -> error "expected exactly the two default seeded prices"
writeIORef priceIdsRef (Just priceIds)
withBadgeServiceWebConfig ps (writeTestBadgeServiceConfig ps) seedStatuses $ \_client _bsLink webUrl -> do
Just (disabledId, deprecatedId) <- readIORef priceIdsRef
mgr <- newWebManager
r <- webGet mgr (webUrl <> "/api/catalog")
wrStatus r `shouldBe` 200
webHeader r "content-type" `shouldBe` "application/json"
case J.decode (LBC.pack (wrBody r)) :: Maybe BadgeCatalog of
Nothing -> expectationFailure $ "/api/catalog did not decode as BadgeCatalog: " <> wrBody r
Just BadgeCatalog {prices, offers} -> do
map (\BadgePrice {priceId} -> priceId) prices `shouldBe` [deprecatedId]
map (\BadgePrice {status} -> status) prices `shouldBe` [BISDeprecated]
any (\BadgeOffer {priceId} -> priceId == Just disabledId) offers `shouldBe` False
sort (map (\BadgeOffer {months} -> months) offers) `shouldBe` [3, 12]
-- the legend price is 7000/month: 3 months with one free is 14000 and 12 with six free
-- is 42000. Without catalogTotals every total here would be null.
sort (map (\BadgeOffer {total} -> fmap (\(CurrencyAmount n) -> n) total) offers) `shouldBe` [Just 14000, Just 42000]
-- A minimal site on disk for web_dir mode, in the same shape the embedded set has: dist/ beside
-- index.html and styles.css. Small enough that every byte the assertions compare is written here.
writeTestWebDir :: FilePath -> IO ()
writeTestWebDir dir = do
createDirectoryIfMissing True (dir </> "dist")
writeFile (dir </> "index.html") $
"<!doctype html><html><head><link rel=\"stylesheet\" href=\"@@styles.css@@\" /></head>"
<> "<body><a href=\"@@support_contact@@\">support</a>"
<> "<script type=\"module\" src=\"@@main.js@@\"></script></body></html>\n"
writeFile (dir </> "styles.css") webDirCssBefore
writeFile (dir </> "dist" </> "main.js") "export const site = \"web_dir\";\n"
writeFile (dir </> "dist" </> "dev.html") "<!-- dev.html must never be served -->\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 "../../<file>", 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") "<img src=\"@@logo-symbol-light.svg@@\" alt=\"\" />\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))