@@ -28,8 +28,28 @@
2828-- and other private/reserved names), so two default-built servers cannot
2929-- federate with each other. The default is only suitable for a single-node,
3030-- non-federated deployment.
31−serverHost : ServerName
31+--
32+-- Typed `Text`, not `ServerName`: a refined type cannot be given a bare literal
33+-- default (the compiler requires an explicit `refine`), and this constant is
34+-- overridable at startup. `localServerName` below is where the `ServerName`
35+-- predicate is actually checked — an operator who overrides this with a name
36+-- that fails `isValidServerName` (too long, not lowercase, or trailing-dotted)
37+-- gets federation egress disabled and a loud startup warning, rather than an
38+-- invalid name on the wire.
39+serverHost : Text
3240serverHost = "localhost"
41+
42+-- `serverHost` refined to a `ServerName`, or `Nothing` when it fails
43+-- `isValidServerName`. This is the only place the predicate is checked for our
44+-- own hostname; peer-supplied names are validated by the runtime at the
45+-- `/federation/gossip` route boundary (`fromServer: ServerName`). Federation
46+-- egress (`sendBatchedGossip`) needs a `ServerName` to put in the gossip body,
47+-- so a misconfigured host simply stops gossiping — see `main`, which warns at
48+-- startup.
49+localServerName : Maybe ServerName
50+localServerName = case refine serverHost of
51+ Ok {value: sn} -> Just {value: sn}
52+ Err _ -> Nothing {}
3353-- Network interface the HTTP listener binds to. "0.0.0.0" accepts connections
3454-- on every IPv4 interface (the typical default behind a reverse proxy);
3555-- "127.0.0.1" restricts the listener to localhost-only; "::" / "::1" do the
@@ -381,8 +401,8 @@ else do
381401-- `chars` yields the *distinct* character set (relations dedupe), which is
382402-- fine for the membership check; the length checks must use `length`.
383403isValidHex : Text -> Bool
384−isValidHex = \s -> do
385− let n = length s
404+isValidHex = \s ->
405+ let n = length s in
386406 n > 0 && n / 2 * 2 == n && all (\c -> contains c "0123456789abcdef") (chars s)
387407
388408-- Recursively strip every trailing "." from `s` (DNS root form).
@@ -423,8 +443,8 @@ else take 1 s ++ beforeColon (drop 1 s)
423443-- carry no dotted octets, so the prefix list below never matches them, yet
424444-- they resolve to the same internal addresses.
425445isNumericHost : Text -> Bool
426−isNumericHost = \sn -> do
427− let host = beforeColon sn
446+isNumericHost = \sn ->
447+ let host = beforeColon sn in
428448 host != "" && all (\c -> contains c "0123456789") (chars host)
429449
430450-- Decimal value of a single hex/ascii digit character.
@@ -468,9 +488,9 @@ isDottedNumeric = \host -> host != "" && contains "." host && all (\c -> contain
468488-- literals (`isDottedNumeric`) so hostnames are never caught. Shorthand forms
469489-- like "100.64" still match — only the first two octets are inspected.
470490isReservedIPv4 : Text -> Bool
471−isReservedIPv4 = \host -> do
472− let o1 = decimalValue (beforeDot host)
473− let o2 = decimalValue (beforeDot (afterDot host))
491+isReservedIPv4 = \host ->
492+ let o1 = decimalValue (beforeDot host) in
493+ let o2 = decimalValue (beforeDot (afterDot host)) in
474494 isDottedNumeric host && (o1 >= 224 || (o1 == 100 && o2 >= 64 && o2 <= 127) || (o1 == 198 && (o2 == 18 || o2 == 19)))
475495
476496-- True when a dotted-numeric host carries an octet with a redundant leading
@@ -485,9 +505,9 @@ isReservedIPv4 = \host -> do
485505hasLeadingZeroOctet : Text -> Bool
486506hasLeadingZeroOctet = \host -> isDottedNumeric host && anyOctetLeadingZero host
487507anyOctetLeadingZero : Text -> Bool
488−anyOctetLeadingZero = \host -> do
489− let octet = beforeDot host
490− let rest = afterDot host
508+anyOctetLeadingZero = \host ->
509+ let octet = beforeDot host in
510+ let rest = afterDot host in
491511 (length octet > 1 && take 1 octet == "0") || (rest != "" && anyOctetLeadingZero rest)
492512
493513-- Block private/reserved/internal hostnames (SSRF defense).
@@ -667,7 +687,14 @@ hasLocalPresence = \pres pk t -> any (\p -> p.pubkey == pk && isLocalServer p.se
667687
668688-- Project items through `getServer`, drop our own hostname, and dedupe.
669689-- Used to derive peer recipient lists from forwards/presence/etc.
670−collectPeers : [a] -> (a -> Text) -> [Text]
690+--
691+-- Returns `[ServerName]`, not `[Text]`: every caller projects a field that is
692+-- already a `ServerName` (`PresenceEntry.server`, `ForwardEntry.toServer`), so
693+-- carrying the refinement through costs nothing and keeps the peer names usable
694+-- where a `ServerName` is required (`forwardMatches`, the `*forwards` /
695+-- `deliveredTo` writes, the gossip body). Erasing to `Text` here is what forces
696+-- an unchecked re-`refine` at every downstream use.
697+collectPeers : [a] -> (a -> ServerName) -> [ServerName]
671698collectPeers = \items getServer -> filter (\s -> not isLocalServer s) (map getServer items)
672699
673700-- Current sequence value, or 0 before the first message seeds it. Reads the
@@ -696,7 +723,7 @@ forwardMatches = \blob server f -> f.encryptedBlob == blob && f.toServer == serv
696723-- Replace any local presence rows for `pubkey` with one fresh row at
697724-- `expiry`, and return the post-update peer broadcast set. Caller wraps in
698725-- `atomic`.
699−refreshLocalPresence : PubkeyHex -> Timestamp -> IO {rw *presence} [Text]
726+refreshLocalPresence : PubkeyHex -> Timestamp -> IO {rw *presence} [ServerName]
700727refreshLocalPresence = \pubkey expiry -> do
701728 pres <- *presence
702729 *presence = union (filter (\p -> not (p.pubkey == pubkey && isLocalServer p.server)) pres) [
@@ -740,15 +767,21 @@ pruneExpired = \t -> atomic do
740767-- Fan out one bundle of gossip events to each peer, skipping denylisted
741768-- peers and peers in backoff. No-op when `events` is empty so callers don't
742769-- need to guard. Records or clears federation-failure counters per call.
743−sendBatchedGossip : [Text] -> [GossipEvent] -> IO {rw *forwardFailures, network, clock} {}
744−sendBatchedGossip = \peers events -> when (count events > 0) (do
745− t <- now
746− failures <- *forwardFailures
747− forEach peers (\server -> when (not (isBadServerName server) && shouldRetryServer server t failures) (do
748− result <- fetch (federationUrl server) (RecvGossip {events, fromServer: serverHost})
749− case result of
750− Err _ -> recordFailure server t
751− Ok _ -> clearFailure server t)))
770+--
771+-- Also a no-op when `serverHost` fails the `ServerName` predicate: the gossip
772+-- body must carry a valid `fromServer`, and a peer would reject (400) a name we
773+-- could not have refined anyway. `main` warns about this at startup.
774+sendBatchedGossip : [ServerName] -> [GossipEvent] -> IO {rw *forwardFailures, network, clock} {}
775+sendBatchedGossip = \peers events -> case localServerName of
776+ Nothing {} -> yield {}
777+ Just {value: me} -> when (count events > 0) (do
778+ t <- now
779+ failures <- *forwardFailures
780+ forEach peers (\server -> when (not (isBadServerName server) && shouldRetryServer server t failures) (do
781+ result <- fetch (federationUrl server) (RecvGossip {events, fromServer: me})
782+ case result of
783+ Err _ -> recordFailure server t
784+ Ok _ -> clearFailure server t)))
752785
753786-- ============================================
754787-- Forward retries
@@ -1076,7 +1109,7 @@ handleSendMessages = \messages authorization clientIp -> do
10761109-- the message), and `deliveredTo` prevents re-forwards to peers that already
10771110-- have the message. On failure the forwards row stays so
10781111-- `retryPendingForwards` can re-attempt with backoff.
1079−forkForwardsTo : PubkeyHex -> BlobHex -> [Text] -> IO {rw *forwardFailures, rw *forwards, rw *messages, network, clock} {}
1112+forkForwardsTo : PubkeyHex -> BlobHex -> [ServerName] -> IO {rw *forwardFailures, rw *forwards, rw *messages, network, clock} {}
10801113forkForwardsTo = \to encryptedBlob servers -> forEach servers (\server -> when (not isBadServerName server) (do
10811114 t <- now
10821115 result <- fetch (federationUrl server) (ForwardMessage {toKey: to, encryptedBlob})
@@ -1135,7 +1168,7 @@ forkForwardsTo = \to encryptedBlob servers -> forEach servers (\server -> when (
11351168-- cannot inject presence at all. Deferred past v0.1 because it needs a
11361169-- key-to-home-server binding the protocol does not yet define.
11371170-- PROTOCOL.md §10 enumerates what open federation does and does not protect.
1138−handleRecvGossip : [GossipEvent] -> Text -> IO {r *messages, rw *forwards, rw *presence, clock} (Result HttpError {})
1171+handleRecvGossip : [GossipEvent] -> ServerName -> IO {r *messages, rw *forwards, rw *presence, clock} (Result HttpError {})
11391172handleRecvGossip = \events fromServer -> do
11401173 t <- now
11411174 if not federationEnabled
@@ -1267,7 +1300,6 @@ backgroundRetryForwards = do
12671300-- Fork the background prune loop (which runs an immediate sweep on its
12681301-- first tick) and start the HTTP listener. The forward-retry loop only
12691302-- runs when federation is enabled.
1270−main : IO _ {}
12711303main = do
12721304 logInfo ("Skrepka relay server starting on " ++ bindHost ++ ":" ++ show listenPort ++ " ...")
12731305 logInfo (" federation: " ++ (if federationEnabled then "enabled" else "disabled"))