@@ -177,7 +177,7 @@ impl FromJSON GossipEventType where
178-- True when `s` is non-empty lowercase hex of even length, with `maxLen` ceiling.
178-- True when `s` is non-empty lowercase hex of even length, with `maxLen` ceiling.
179isValidBoundedHex : Int -> Text -> Bool
179isValidBoundedHex : Int -> Text -> Bool
180−isValidBoundedHex = \maxLen s -> not tooLong s maxLen && isValidHex s
180+isValidBoundedHex = \maxLen s -> count (chars s) <= maxLen && isValidHex s
181-- True when `s` is lowercase hex of exactly `exactLen` characters (even by definition).
181-- True when `s` is lowercase hex of exactly `exactLen` characters (even by definition).
182isValidExactHex : Int -> Text -> Bool
182isValidExactHex : Int -> Text -> Bool
183isValidExactHex = \exactLen s -> count (chars s) == exactLen && isValidHex s
183isValidExactHex = \exactLen s -> count (chars s) == exactLen && isValidHex s
@@ -193,7 +193,7 @@ type SignatureHex = Text where isValidExactHex 128
193-- `serverHost = "localhost"` flow through presence rows in a non-federated
193-- `serverHost = "localhost"` flow through presence rows in a non-federated
194-- single-node deployment.
194-- single-node deployment.
195isValidServerName : Text -> Bool
195isValidServerName : Text -> Bool
196−isValidServerName = \s -> not tooLong s maxServerNameLen && s == normalizeServerName s
196+isValidServerName = \s -> count (chars s) <= maxServerNameLen && s == toLower (stripTrailingDot s)
197type ServerName = Text where isValidServerName
197type ServerName = Text where isValidServerName
199-- Wall-clock time in milliseconds since epoch.
199-- Wall-clock time in milliseconds since epoch.
@@ -331,10 +331,6 @@ else do
331genToken : IO {random} Text
331genToken : IO {random} Text
332genToken = genTokenN 48
332genToken = genTokenN 48
334−-- True when `s` exceeds `maxLen` characters.
335−tooLong : Text -> Int -> Bool
336−tooLong = \s maxLen -> count (chars s) > maxLen
338-- True when `s` is non-empty, even-length, and only lowercase hex digits.
334-- True when `s` is non-empty, even-length, and only lowercase hex digits.
339isValidHex : Text -> Bool
335isValidHex : Text -> Bool
340isValidHex = \s -> do
336isValidHex = \s -> do
@@ -348,10 +344,6 @@ stripTrailingDot = \s -> if containsSuffix "." s
348then stripTrailingDot (take (count (chars s) - 1) s)
344then stripTrailingDot (take (count (chars s) - 1) s)
351−-- Canonical form of a hostname: lowercase, no trailing dot.
352−normalizeServerName : Text -> Text
353−normalizeServerName = \s -> toLower (stripTrailingDot s)
355-- True when `s` refers to this server.
347-- True when `s` refers to this server.
356isLocalServer : Text -> Bool
348isLocalServer : Text -> Bool
357isLocalServer = \s -> s == serverHost
349isLocalServer = \s -> s == serverHost
@@ -372,7 +364,7 @@ containsSuffix = \suffix s -> drop (max 0 (count (chars s) - count (chars suffix
372-- (so we never `fetch` a peer pubkey from loopback) and on inbound requests
364-- (so we never `fetch` a peer pubkey from loopback) and on inbound requests
373-- (so a peer can't claim a bogus `fromServer`).
365-- (so a peer can't claim a bogus `fromServer`).
374isBadServerName : Text -> Bool
366isBadServerName : Text -> Bool
375−isBadServerName = \sn -> sn == "" || sn == "localhost" || not all (\c -> contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:") (chars sn) || any (\p -> hasPrefix p sn) [
367+isBadServerName = \sn -> sn == "" || sn == "localhost" || any (\c -> not contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:") (chars sn) || any (\p -> hasPrefix p sn) [
@@ -766,23 +758,16 @@ handleSendMessages = \messages authorization clientIp -> do
766 m.encryptedBlob,
758 m.encryptedBlob,
767 remoteServers: collectPeers (filter (\p -> p.pubkey == m.to && p.expiresAt > t) pres) (\p -> p.server)
759 remoteServers: collectPeers (filter (\p -> p.pubkey == m.to && p.expiresAt > t) pres) (\p -> p.server)
768 }) limited
760 }) limited
769− forEach staged (\c -> commitSendMessage c.to c.encryptedBlob c.remoteServers t)
761+ forEach staged (\c -> do
762+ appendMessage c.to c.encryptedBlob t
763+ when federationEnabled (do
765+ let newFwds = map (\s -> {toServer: s, toKey: c.to, encryptedBlob: c.encryptedBlob, retries: 0}) (filter (\s -> not any (\f -> f.encryptedBlob == c.encryptedBlob && f.toServer == s) fwds) c.remoteServers)
766+ *forwards = union fwds newFwds))
770 yield staged)
767 yield staged)
771 when federationEnabled (forEach committed (\c -> fork (forkForwardsTo c.to c.encryptedBlob c.remoteServers)))
768 when federationEnabled (forEach committed (\c -> fork (forkForwardsTo c.to c.encryptedBlob c.remoteServers)))
772 yield (Ok {value: {}}))
769 yield (Ok {value: {}}))
774−-- Allocate a monotonic receivedAt via `seqCounter`, append the message to
775−-- the mailbox, and pre-stage forwards for any remote presence rows that
776−-- already exist for `to`. Caller must have already validated the message
777−-- via `resolveSendTarget`.
778−commitSendMessage : PubkeyHex -> BlobHex -> [Text] -> Int<Ms> -> IO {rw *forwards, rw *messages, rw *pollWakeup, rw *seqCounter} {}
779−commitSendMessage = \to encryptedBlob remoteServers t -> do
780− appendMessage to encryptedBlob t
781− when federationEnabled (do
783− let newFwds = map (\s -> {toServer: s, toKey: to, encryptedBlob, retries: 0}) (filter (\s -> not any (\f -> f.encryptedBlob == encryptedBlob && f.toServer == s) fwds) remoteServers)
784− *forwards = union fwds newFwds)
786-- Fire one /federation/forward call per pre-staged server. On success the
771-- Fire one /federation/forward call per pre-staged server. On success the
787-- corresponding row in `forwards` is pruned, and if no other forwards remain
772-- corresponding row in `forwards` is pruned, and if no other forwards remain
788-- for this blob AND the recipient has no local presence, the backing
773-- for this blob AND the recipient has no local presence, the backing
@@ -832,16 +817,13 @@ handleRecvGossip = \events fromServer -> do
833 newlyOnline <- atomic (do
818 newlyOnline <- atomic (do
834 pres <- *presence
819 pres <- *presence
835− let touchedPubkeys = fold (\acc e -> case e of
820+ let combined = fold (\acc e -> case e of
836− GossipOnline {pubkey} -> union acc [pubkey]
837− GossipOffline {pubkey} -> union acc [pubkey]
839− let added = fold (\acc e -> case e of
840− GossipOnline {pubkey} -> union acc [{pubkey, server: fromServer, expiresAt: t + onlineGossipTtl}]
821+ GossipOnline {pubkey} -> {touchedPubkeys: union acc.touchedPubkeys [pubkey], added: union acc.added [{pubkey, server: fromServer, expiresAt: t + onlineGossipTtl}]}
822+ GossipOffline {pubkey} -> {touchedPubkeys: union acc.touchedPubkeys [pubkey], acc.added}
841− _ -> acc) [] events
823+ _ -> acc) {touchedPubkeys: [], added: []} events
842− let kept = filter (\p -> p.server != fromServer || not elem p.pubkey touchedPubkeys) pres
824+ let kept = filter (\p -> p.server != fromServer || not elem p.pubkey combined.touchedPubkeys) pres
843− *presence = union kept added
825+ *presence = union kept combined.added
844− yield (filter (\pk -> not any (\p -> p.pubkey == pk && p.server == fromServer && p.expiresAt > t) pres) (map (\p -> p.pubkey) added)))
826+ yield (filter (\pk -> not any (\p -> p.pubkey == pk && p.server == fromServer && p.expiresAt > t) pres) (map (\p -> p.pubkey) combined.added)))
845 fork (forEach newlyOnline (\pk -> forwardQueuedToServer pk fromServer))
827 fork (forEach newlyOnline (\pk -> forwardQueuedToServer pk fromServer))
846 yield (Ok {value: {}})
828 yield (Ok {value: {}})