19734ff · skrepka · git.iko.soy

git.iko.soy/skrepka

on master help sign in

Simplify server: drop dead helpers, inline single-use functions, use plain == for tokens, linear backoff

19734ffiko6 months ago

server.knot+113−266

compare with master

unifiedsplit

@@ -1,9 +1,8 @@

1−-- Skrepka Relay Server (simplified)

1+-- Skrepka Relay Server (maximally simplified)

2-- Single-server implementation of the Skrepka protocol (v0.1).

3−-- This is a deliberately simplified rewrite: every collection is a single flat list,

4−-- rate limiters use a plain count-per-window, no caches, no histograms, no TCO accumulator

3+-- Every collection is a flat list; rate limiters are plain count-per-window.

5−-- helpers. Performance under load is significantly worse than the sharded original;

4+-- Token comparison is plain `==` (timing-attack vulnerable), retry backoff is linear,

6−-- correctness and clarity are the only goals here.

5+-- and many helpers are inlined. Performance suffers; clarity is the only goal.

8-- ============================================

7-- ============================================

9-- Configuration

8-- Configuration

@@ -22,7 +21,6 @@ maxPresenceTtl = 3600

22maxPubkeyLen = 256

21maxPubkeyLen = 256

23maxBlobLen = 65536

22maxBlobLen = 65536

24maxSignatureLen = 256

23maxSignatureLen = 256

25−maxIpLen = 45

26maxMessageIds = 100

24maxMessageIds = 100

27maxBatchSize = 100

25maxBatchSize = 100

28maxMessagePriority = 10

26maxMessagePriority = 10

@@ -34,12 +32,9 @@ maxMessages = 100000

34clockSkewTolerance : Int<Ms>

32clockSkewTolerance : Int<Ms>

35clockSkewTolerance = 5000

33clockSkewTolerance = 5000

36maxForwardsEntries = 10000

34maxForwardsEntries = 10000

37−maxForwardsPerKey = 50

38−maxForwardsPerSenderPerKey = 10

39maxForwardsPerServer = 2000

35maxForwardsPerServer = 2000

40maxServerNameLen = 128

36maxServerNameLen = 128

41maxMessageIdLen = 128

37maxMessageIdLen = 128

42−maxCorrelationIdLen = 128

43maxTokenLen = 256

38maxTokenLen = 256

44maxChallenges = 10000

39maxChallenges = 10000

45maxSessions = 10000

40maxSessions = 10000

@@ -87,7 +82,6 @@ onlineGossipTtl = 5400

87offlineGossipMinTtl : Int<S>

82offlineGossipMinTtl : Int<S>

88offlineGossipMinTtl = 60

83offlineGossipMinTtl = 60

89maxForwardRetries = 10

84maxForwardRetries = 10

90−maxAckRetries = 10

91maxGossipHops = 5

85maxGossipHops = 5

92gossipOriginHops = 2

86gossipOriginHops = 2

@@ -100,9 +94,6 @@ verificationTokenExpiry : Int<Ms>

100verificationTokenExpiry = 30000

94verificationTokenExpiry = 30000

101maxPendingVerifications = 10000

95maxPendingVerifications = 10000

102

103−federationFetchTimeoutMs : Int<Ms>

104−federationFetchTimeoutMs = 30000

105−

106backgroundPruneInterval : Int<Ms>

97backgroundPruneInterval : Int<Ms>

107backgroundPruneInterval = 30000

98backgroundPruneInterval = 30000

108pollTimeoutMs : Int<Ms>

99pollTimeoutMs : Int<Ms>

@@ -469,16 +460,13 @@ maxBy = \items getKey -> fold (\acc x -> case acc of

469 Nothing {} -> Just {value: x}

460 Nothing {} -> Just {value: x}

470 Just {value: v} -> if getKey x > getKey v then Just {value: x} else acc) Nothing {} items

461 Just {value: v} -> if getKey x > getKey v then Just {value: x} else acc) Nothing {} items

471

462

472−-- Drop the single oldest entry by key (LRU-style eviction)

463+-- Drop entries with the oldest key (LRU-style eviction; ties drop together)

473evictOldest = \items getKey ->

464evictOldest = \items getKey ->

474 case minBy items getKey of

465 case minBy items getKey of

475 Nothing {} -> items

466 Nothing {} -> items

476 Just {value: oldest} ->

467 Just {value: oldest} ->

477− let key = getKey oldest in

468+ let k = getKey oldest in

478− let r = fold (\acc x ->

469+ do x <- items; where getKey x != k; yield x

479− if not acc.done && getKey x == key then {items: acc.items, done: True {}}

480− else {items: union acc.items [x], done: acc.done}) {items: [], done: False {}} items

481− in r.items

482

470

483capList = \items maxN getKey ->

471capList = \items maxN getKey ->

484 if count items > maxN then evictOldest items getKey else items

472 if count items > maxN then evictOldest items getKey else items

@@ -508,73 +496,24 @@ genToken = genTokenN 8

508tooLong : Text -> Int -> Bool

496tooLong : Text -> Int -> Bool

509tooLong = \s maxLen -> drop maxLen s != ""

497tooLong = \s maxLen -> drop maxLen s != ""

510

498

511−-- Printable ASCII allowlist

512−printableAscii : Text

513−printableAscii = " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~"

514−

515−-- Strip non-printable characters via simple recursion (no accumulator)

516−stripNonPrintable : Text -> Text

517−stripNonPrintable = \s ->

518− if s == "" then ""

519− else let c = take 1 s in

520− if contains c printableAscii then c ++ stripNonPrintable (drop 1 s)

521− else stripNonPrintable (drop 1 s)

522−

523−sanitizeCorrelationId : Text -> Text

524−sanitizeCorrelationId = \cid -> stripNonPrintable (take maxCorrelationIdLen cid)

525−

526−-- Escape JSON string via simple recursion

527−escapeJsonString : Text -> Text

528−escapeJsonString = \s ->

529− if s == "" then ""

530− else let c = take 1 s in

531− if c == "\\" then "\\\\" ++ escapeJsonString (drop 1 s)

532− else if c == "\"" then "\\\"" ++ escapeJsonString (drop 1 s)

533− else if c == "\n" then "\\n" ++ escapeJsonString (drop 1 s)

534− else if c == "\r" then "\\r" ++ escapeJsonString (drop 1 s)

535− else if c == "\t" then "\\t" ++ escapeJsonString (drop 1 s)

536− else if contains c printableAscii then c ++ escapeJsonString (drop 1 s)

537− else escapeJsonString (drop 1 s)

538−

539−logEvent = \level event msg ->

540− let formatted = "{\"level\":\"" ++ escapeJsonString level ++ "\",\"event\":\"" ++ escapeJsonString event ++ "\",\"msg\":\"" ++ escapeJsonString msg ++ "\"}"

541− in if level == "error" then logError formatted

542− else if level == "warn" then logWarn formatted

543− else logInfo formatted

544−

545−isHexChar : Text -> Bool

499+isValidHex : Text -> Bool

546−isHexChar = \c -> contains c "0123456789abcdef"

500+isValidHex = \s ->

547−

548−isValidHexPairs : Text -> Bool

549−isValidHexPairs = \s ->

550− if s == "" then True {}

501+ if s == "" then False {}

551 else if drop 1 s == "" then False {}

502 else if drop 1 s == "" then False {}

552− else if isHexChar (take 1 s) && isHexChar (take 1 (drop 1 s)) then isValidHexPairs (drop 2 s)

503+ else if contains (take 1 s) "0123456789abcdef" && contains (take 1 (drop 1 s)) "0123456789abcdef"

504+ then drop 2 s == "" || isValidHex (drop 2 s)

553 else False {}

505 else False {}

554

506

555−isValidHex : Text -> Bool

556−isValidHex = \s -> s != "" && isValidHexPairs s

557−

558normalizeHex : Text -> Text

507normalizeHex : Text -> Text

559normalizeHex = \s -> bytesToHex (bytesFromHex s)

508normalizeHex = \s -> bytesToHex (bytesFromHex s)

560

509

561−isDigitChar : Text -> Bool

510+-- Strip all trailing dots by recursing left-to-right; once the tail is all dots, it's dropped.

562−isDigitChar = \c -> contains c "0123456789"

563−

564−isAllowedServerChar : Text -> Bool

565−isAllowedServerChar = \c -> contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:"

566−

567−containsBadUrlChar : Text -> Bool

568−containsBadUrlChar = \s -> any (chars s) (\c -> not (isAllowedServerChar c))

569−

570−isAllDots : Text -> Bool

571−isAllDots = \s -> if s == "" then True {} else if take 1 s == "." then isAllDots (drop 1 s) else False {}

572−

573stripTrailingDot : Text -> Text

511stripTrailingDot : Text -> Text

574stripTrailingDot = \s ->

512stripTrailingDot = \s ->

575 if s == "" then ""

513 if s == "" then ""

576− else if isAllDots s then ""

577− else take 1 s ++ stripTrailingDot (drop 1 s)

514+ else if take 1 s != "." then take 1 s ++ stripTrailingDot (drop 1 s)

515+ else let rest = stripTrailingDot (drop 1 s) in

516+ if rest == "" then "" else "." ++ rest

578

517

579normalizeServerName : Text -> Text

518normalizeServerName : Text -> Text

580normalizeServerName = \s -> toLower (stripTrailingDot s)

519normalizeServerName = \s -> toLower (stripTrailingDot s)

@@ -596,8 +535,8 @@ containsSuffix = \suffix s ->

596isBadServerName : Text -> Bool

535isBadServerName : Text -> Bool

597isBadServerName = \sn ->

536isBadServerName = \sn ->

598 let fc = take 1 sn in

537 let fc = take 1 sn in

599− fc == "" || fc == "." || fc == ":"

538+ fc == "" || fc == "." || fc == ":" || fc == "["

600− || containsBadUrlChar sn

539+ || any (chars sn) (\c -> not (contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:"))

601 || sn == "localhost"

540 || sn == "localhost"

602 || containsSuffix ".localhost" sn

541 || containsSuffix ".localhost" sn

603 || containsSuffix ".local" sn

542 || containsSuffix ".local" sn

@@ -610,57 +549,30 @@ isBadServerName = \sn ->

610 || take 8 sn == "169.254."

549 || take 8 sn == "169.254."

611 || take 2 sn == "0."

550 || take 2 sn == "0."

612 || take 2 sn == "::"

551 || take 2 sn == "::"

613− || fc == "["

614

552

615-- ============================================

553-- ============================================

616-- Auth helpers

554-- Auth helpers

617-- ============================================

555-- ============================================

618

556

619−safeCompareLen = maxTokenLen + 16

557+-- Plain ip match (sessions with empty ip skip the check).

620−

558+matchIp = \clientIp sessionIp -> sessionIp == "" || clientIp == sessionIp

621−-- Simple non-TCO constant-time comparison: compares character-by-character.

622−-- Returns True iff strings are non-empty and equal up to safeCompareLen.

623−safeCompareLoop : Text -> Text -> Int -> Int

624−safeCompareLoop = \s1 s2 n ->

625− if n <= 0 then 0

626− else

627− let c1 = take 1 s1 in

628− let c2 = take 1 s2 in

629− let d = if c1 == c2 then 0 else 1 in

630− let endMismatch = if c1 == "" then (if c2 == "" then 0 else 1) else (if c2 == "" then 1 else 0) in

631− d + endMismatch + safeCompareLoop (drop 1 s1) (drop 1 s2) (n - 1)

632−

633−safeCompare : Text -> Text -> Bool

634−safeCompare = \a b ->

635− if take 1 a == "" || take 1 b == "" then False {}

636− else safeCompareLoop a b safeCompareLen == 0

637−

638−matchIp : Text -> Text -> Bool

639−matchIp = \clientIp sessionIp ->

640− if sessionIp == "" then True {}

641− else if clientIp == "" then False {}

642− else safeCompare clientIp sessionIp

643

559

644extractToken = \authHeader ->

560extractToken = \authHeader ->

645 let token = drop 7 authHeader in

561 let token = drop 7 authHeader in

646− if toLower (take 7 authHeader) == "bearer " && token != "" && not (tooLong token maxTokenLen)

562+ if take 7 authHeader == "Bearer " && token != "" && not (tooLong token maxTokenLen)

647 then Just {value: token}

563 then Just {value: token}

648 else Nothing {}

564 else Nothing {}

649

565

650−verifySecret : Text -> Text -> Bool

651−verifySecret = \token secret -> secret != "" && safeCompare token secret

652−

653verifyMaintenanceAuth : Text -> IO Bool

566verifyMaintenanceAuth : Text -> IO Bool

654verifyMaintenanceAuth = \authorization -> do

567verifyMaintenanceAuth = \authorization -> do

655 secret <- *runtimeMaintenanceSecret

568 secret <- *runtimeMaintenanceSecret

656− if secret == "" then yield False

657− else case extractToken authorization of

569+ case extractToken authorization of

658− Nothing {} -> yield False

659− Just {value: token} -> yield (verifySecret token secret)

570+ Just {value: token} -> yield (secret != "" && token == secret)

571+ _ -> yield False

660

572

661authenticateSession : [Session] -> Text -> Timestamp -> AuthResult

573authenticateSession : [Session] -> Text -> Timestamp -> AuthResult

662authenticateSession = \sessions token t ->

574authenticateSession = \sessions token t ->

663− case headOf (do s <- sessions; where s.expiresAt > t && safeCompare s.token token; yield s) of

575+ case headOf (do s <- sessions; where s.expiresAt > t && s.token == token; yield s) of

664 Nothing {} -> Unauthorized {}

576 Nothing {} -> Unauthorized {}

665 Just {value: s} -> Authorized {pubkey: s.pubkey, ip: s.ip}

577 Just {value: s} -> Authorized {pubkey: s.pubkey, ip: s.ip}

666

578

@@ -670,10 +582,9 @@ withSessionAuth = \authorization t clientIp onUnauth onAuth -> do

670 Just {value: token} -> do

582 Just {value: token} -> do

671 sessions <- *sessions

583 sessions <- *sessions

672 case authenticateSession sessions token t of

584 case authenticateSession sessions token t of

673− Unauthorized {} -> onUnauth

674 Authorized {pubkey, ip} ->

585 Authorized {pubkey, ip} ->

675− if not (matchIp clientIp ip) then onUnauth

586+ if matchIp clientIp ip then onAuth pubkey else onUnauth

676− else onAuth pubkey

587+ _ -> onUnauth

677

588

678isBlockedPeer : Text -> [Text] -> Bool

589isBlockedPeer : Text -> [Text] -> Bool

679isBlockedPeer = \server blocked -> any blocked (\b -> b == server)

590isBlockedPeer = \server blocked -> any blocked (\b -> b == server)

@@ -706,78 +617,61 @@ generateFederationAuth = \scope requestTimestamp ->

706 set *pendingVerifications = capList updated maxPendingVerifications (\p -> p.createdAt)

617 set *pendingVerifications = capList updated maxPendingVerifications (\p -> p.createdAt)

707 yield ("Bearer " ++ token)

618 yield ("Bearer " ++ token)

708

619

709−verifyFederationCallback : Text -> Text -> Text -> IO {network} Bool

620+-- Verify a federation request: signed (Ed25519 over scope|ts|fromServer|nonce) or callback Bearer token.

710−verifyFederationCallback = \fromServer authorization scope ->

621+verifyFederationAuth = \authorization fromServer scope requestTimestamp -> do

622+ if take 7 authorization == "Signed " then do

623+ let payload = drop 7 authorization

624+ if payload == "" || tooLong payload (maxSignatureLen + 25) then yield False

625+ else do

626+ let parts = splitOnColon payload

627+ result <- fetch (federationUrl fromServer) (FederationPubkey {})

628+ case result of

629+ Ok r ->

630+ if not r.ok || r.pubkey == "" then yield False

631+ else

632+ let msg = scope ++ "|" ++ show requestTimestamp ++ "|" ++ fromServer ++ (if parts.after == "" then "" else "|" ++ parts.after) in

633+ yield (verify (bytesFromHex r.pubkey) (textToBytes msg) (bytesFromHex parts.before))

634+ _ -> yield False

711− case extractToken authorization of

635+ else case extractToken authorization of

712− Nothing {} -> yield False

713 Just {value: token} -> do

636 Just {value: token} -> do

714 result <- fetch (federationUrl fromServer) (VerifyToken {token: token, scope: scope})

637 result <- fetch (federationUrl fromServer) (VerifyToken {token: token, scope: scope})

715− case result of

638+ case result of Ok r -> yield r.ok; _ -> yield False

716− Err _ -> yield False

717− Ok r -> yield r.ok

718−

719−-- Verify Ed25519 signed federation request, with optional nonce.

720−verifyFederationSignature : Text -> Text -> Text -> Text -> Timestamp -> IO {network} Bool

721−verifyFederationSignature = \fromServer signatureHex nonce scope requestTimestamp -> do

722− result <- fetch (federationUrl fromServer) (FederationPubkey {})

723− case result of

724− Err _ -> yield False

725− Ok r ->

726− if not r.ok || r.pubkey == "" then yield False

639+ _ -> yield False

727− else

728− let msg = if nonce == ""

729− then scope ++ "|" ++ show requestTimestamp ++ "|" ++ fromServer

730− else scope ++ "|" ++ show requestTimestamp ++ "|" ++ fromServer ++ "|" ++ nonce

731− in yield (verify (bytesFromHex r.pubkey) (textToBytes msg) (bytesFromHex signatureHex))

732

640

733withFederationAuth = \authorization t respond fromServer scope requestTimestamp precondition action -> do

641withFederationAuth = \authorization t respond fromServer scope requestTimestamp precondition action -> do

734 blocked <- *blockedPeers

642 blocked <- *blockedPeers

735− if isBlockedPeer fromServer blocked

736− then yield (respond {ok: False {}, error: "blocked", retryAfterMs: 0})

737− else do

738 allowed <- *allowedPeers

643 allowed <- *allowedPeers

644+ let denyReason =

645+ if isBlockedPeer fromServer blocked then "blocked"

739− if not (isAllowedByAllowlist fromServer allowed)

646+ else if not (isAllowedByAllowlist fromServer allowed) then "not_allowed"

740− then yield (respond {ok: False {}, error: "not_allowed", retryAfterMs: 0})

647+ else ""

648+ if denyReason != "" then yield (respond {ok: False {}, error: denyReason, retryAfterMs: 0})

741− else do

649+ else do

742− verified <- if take 7 authorization == "Signed "

743− then

744− let payload = drop 7 authorization in

745− if payload == "" || tooLong payload (maxSignatureLen + 25)

746− then yield False

747− else

748− let parts = splitOnColon payload in

749− verifyFederationSignature fromServer parts.before parts.after scope requestTimestamp

650+ verified <- verifyFederationAuth authorization fromServer scope requestTimestamp

750− else verifyFederationCallback fromServer authorization scope

751− if not verified

752− then yield (respond {ok: False {}, error: "unauthorized", retryAfterMs: 0})

651+ if not verified then yield (respond {ok: False {}, error: "unauthorized", retryAfterMs: 0})

753 else if requestTimestamp > 0 && (requestTimestamp > t + clockSkewTolerance || requestTimestamp < t - clockSkewTolerance)

652 else if requestTimestamp > 0 && (requestTimestamp > t + clockSkewTolerance || requestTimestamp < t - clockSkewTolerance)

754 then yield (respond {ok: False {}, error: "clock_skew", retryAfterMs: 0})

653 then yield (respond {ok: False {}, error: "clock_skew", retryAfterMs: 0})

755− else if not precondition

756− then yield (respond {ok: False {}, error: "invalid_request", retryAfterMs: 0})

654+ else if not precondition then yield (respond {ok: False {}, error: "invalid_request", retryAfterMs: 0})

757 else do

655 else do

758 limited <- checkServerRateGate fromServer t

656 limited <- checkServerRateGate fromServer t

759− if limited

760− then yield (respond {ok: False {}, error: "rate_limited", retryAfterMs: federationRateWindowMs})

657+ if limited then yield (respond {ok: False {}, error: "rate_limited", retryAfterMs: federationRateWindowMs})

761− else action

658+ else action

762

659

763-- ============================================

660-- ============================================

764-- Rate limiting (plain count-per-window, no sliding interpolation)

661-- Rate limiting (plain count-per-window, no sliding interpolation)

765-- ============================================

662-- ============================================

766

663

767-- Returns {limited, entries}. Increments count when the key fits within the window.

664-- Returns {limited, entries}. Increments count when the key fits within the window.

665+-- Simplified: drop any stale/matching entry, then either reject or insert a fresh entry.

768checkRate = \entries key maxRate windowMs maxEntries t ->

666checkRate = \entries key maxRate windowMs maxEntries t ->

769− let entry = headOf (do r <- entries; where r.key == key; yield r) in

667+ let cur = headOf (do r <- entries; where r.key == key && t - r.windowStart < windowMs; yield r) in

770− case entry of

668+ let nextCount = case cur of Just {value: r} -> r.count + 1; _ -> 1 in

771− Nothing {} ->

772− if 1 >= maxRate

669+ if nextCount > maxRate

773− then {limited: True {}, entries: entries}

670+ then {limited: True {}, entries: entries}

671+ else

672+ let others = do x <- entries; where x.key != key; yield x in

673+ let windowStart = case cur of Just {value: r} -> r.windowStart; _ -> t in

774− else {limited: False {}, entries: capList (union entries [{key: key, windowStart: t, count: 1}]) maxEntries (\r -> r.windowStart)}

674+ {limited: False {}, entries: capList (union others [{key: key, windowStart: windowStart, count: nextCount}]) maxEntries (\r -> r.windowStart)}

775− Just {value: r} ->

776− if t - r.windowStart >= windowMs

777− then {limited: False {}, entries: do x <- entries; yield (if x.key == key then {key: x.key, windowStart: t, count: 1} else x)}

778− else if r.count >= maxRate

779− then {limited: True {}, entries: entries}

780− else {limited: False {}, entries: do x <- entries; yield (if x.key == key then {key: x.key, windowStart: x.windowStart, count: x.count + 1} else x)}

781

675

782checkGlobalRate = \t -> atomic do

676checkGlobalRate = \t -> atomic do

783 ws <- *globalRateWindowStart

677 ws <- *globalRateWindowStart

@@ -805,11 +699,7 @@ checkAuthGlobalRate = \t -> atomic do

805

699

806checkIpRateGate = \ip t ->

700checkIpRateGate = \ip t ->

807 if ip == "" then yield False

701 if ip == "" then yield False

808− else atomic do

809− rates <- *ipRates

810− let r = checkRate rates ip maxIpRatePerIp ipRateWindowMs 5000 t

702+ else checkPubkeyRateGate ipRates ip maxIpRatePerIp ipRateWindowMs t

811− set *ipRates = r.entries

812− yield r.limited

813

703

814checkPubkeyRateGate = \rateRef pubkey maxRate windowMs t -> atomic do

704checkPubkeyRateGate = \rateRef pubkey maxRate windowMs t -> atomic do

815 rates <- *rateRef

705 rates <- *rateRef

@@ -817,17 +707,8 @@ checkPubkeyRateGate = \rateRef pubkey maxRate windowMs t -> atomic do

817 set *rateRef = r.entries

707 set *rateRef = r.entries

818 yield r.limited

708 yield r.limited

819

709

820−checkPairRateGate = \sender recipient t -> atomic do

821− rates <- *pairRates

822− let r = checkRate rates (sender ++ "|" ++ recipient) maxPairRatePerPair pairRateWindowMs 5000 t

823− set *pairRates = r.entries

824− yield r.limited

825−

826−checkServerRateGate = \server t -> atomic do

710+checkServerRateGate = \server t ->

827− rates <- *federationRates

828− let r = checkRate rates server maxFederationRatePerServer federationRateWindowMs 5000 t

711+ checkPubkeyRateGate federationRates server maxFederationRatePerServer federationRateWindowMs t

829− set *federationRates = r.entries

830− yield r.limited

831

712

832checkPreAuth = \clientIp t -> do

713checkPreAuth = \clientIp t -> do

833 dp <- *drainPhase

714 dp <- *drainPhase

@@ -837,19 +718,14 @@ checkPreAuth = \clientIp t -> do

837 if g then yield "global_rate_limited"

718 if g then yield "global_rate_limited"

838 else do

719 else do

839 i <- checkIpRateGate clientIp t

720 i <- checkIpRateGate clientIp t

840− if i then yield "ip_rate_limited"

721+ yield (if i then "ip_rate_limited" else "")

841− else yield ""

842

722

843-- ============================================

723-- ============================================

844-- Federation failure tracking (simple, no circuit breaker)

724-- Federation failure tracking (simple, no circuit breaker)

845-- ============================================

725-- ============================================

846

726

847−pow2 : Int -> Int

848−pow2 = \n -> if n <= 0 then 1 else 2 * pow2 (n - 1)

849−

850retryBackoff : Int -> Int<Ms>

727retryBackoff : Int -> Int<Ms>

851−retryBackoff = \failures ->

852− min retryBackoffMax (retryBackoffBase * pow2 (max 0 (failures - 1)))

728+retryBackoff = \failures -> min retryBackoffMax (retryBackoffBase * max 1 failures)

853

729

854shouldRetryServer : Text -> Timestamp -> [ForwardFailure] -> Bool

730shouldRetryServer : Text -> Timestamp -> [ForwardFailure] -> Bool

855shouldRetryServer = \server t failures ->

731shouldRetryServer = \server t failures ->

@@ -861,10 +737,11 @@ recordFailure = \server -> do

861 t <- now

737 t <- now

862 atomic do

738 atomic do

863 failures <- *forwardFailures

739 failures <- *forwardFailures

740+ let others = do f <- failures; where f.server != server; yield f

864− let existing = headOf (do f <- failures; where f.server == server; yield f)

741+ let prior = headOf (do f <- failures; where f.server == server; yield f)

865− case existing of

742+ let firstAt = case prior of Just {value: f} -> f.firstFailedAt; _ -> t

743+ let nextN = case prior of Just {value: f} -> min (f.failures + 1) 10; _ -> 1

866− Nothing {} -> set *forwardFailures = union failures [{server: server, failedAt: t, failures: 1, firstFailedAt: t}]

744+ set *forwardFailures = union others [{server: server, failedAt: t, failures: nextN, firstFailedAt: firstAt}]

867− Just {value: f} -> set *forwardFailures = do x <- failures; yield (if x.server == server then {server: x.server, failedAt: t, failures: min (x.failures + 1) 10, firstFailedAt: x.firstFailedAt} else x)

868

745

869clearFailure = \server -> atomic do

746clearFailure = \server -> atomic do

870 failures <- *forwardFailures

747 failures <- *forwardFailures

@@ -896,9 +773,10 @@ dedupMessageIds = \ids ->

896presenceForKey = \presence pubkey t ->

773presenceForKey = \presence pubkey t ->

897 do p <- presence; where p.pubkey == pubkey && p.expiresAt > t; yield p

774 do p <- presence; where p.pubkey == pubkey && p.expiresAt > t; yield p

898

775

776+-- Pick local if present, else the remote with the latest expiresAt; "" when none.

899bestServerForKey = \entries ->

777bestServerForKey = \entries ->

900 if any entries (\p -> isLocalServer p.server) then serverHostN

778 if any entries (\p -> isLocalServer p.server) then serverHostN

901− else case maxBy (do p <- entries; where not (isLocalServer p.server); yield p) (\p -> p.expiresAt) of

779+ else case maxBy entries (\p -> p.expiresAt) of

902 Just {value: p} -> p.server

780 Just {value: p} -> p.server

903 Nothing {} -> ""

781 Nothing {} -> ""

904

782

@@ -915,13 +793,11 @@ collectPeers = \items getServer ->

915knownPeerServersFromPresence : [PresenceEntry] -> [Text]

793knownPeerServersFromPresence : [PresenceEntry] -> [Text]

916knownPeerServersFromPresence = \presence -> collectPeers presence (\p -> p.server)

794knownPeerServersFromPresence = \presence -> collectPeers presence (\p -> p.server)

917

795

918−samePubkeyServer = \a b -> a.pubkey == b.pubkey && a.server == b.server

919−

920-- Last-write-wins merge by (pubkey, server), keeping the entry with the larger expiresAt.

796-- Last-write-wins merge by (pubkey, server), keeping the entry with the larger expiresAt.

921mergePresence = \existing incoming ->

797mergePresence = \existing incoming ->

922 fold (\acc e ->

798 fold (\acc e ->

923− if any acc (\a -> samePubkeyServer a e && a.expiresAt >= e.expiresAt) then acc

799+ if any acc (\a -> a.pubkey == e.pubkey && a.server == e.server && a.expiresAt >= e.expiresAt) then acc

924− else union (do x <- acc; where not (samePubkeyServer x e); yield x) [e]) existing incoming

800+ else union (do x <- acc; where x.pubkey != e.pubkey || x.server != e.server; yield x) [e]) existing incoming

925

801

926-- ============================================

802-- ============================================

927-- Pruning

803-- Pruning

@@ -1039,23 +915,15 @@ sendForwardsToServer = \fwds server ->

1039 fromServer: serverHostN, requestTimestamp: t,

915 fromServer: serverHostN, requestTimestamp: t,

1040 authorization: auth, correlationId: "",

916 authorization: auth, correlationId: "",

1041 expiresAt: f.expiresAt, priority: f.priority, protocolVersion: federationProtocolVersion})

917 expiresAt: f.expiresAt, priority: f.priority, protocolVersion: federationProtocolVersion})

1042− case result of

918+ let success = case result of Ok r -> r.ok; _ -> False {}

1043− Err _ -> do

1044− recordFailure server

919+ case result of Err _ -> recordFailure server; Ok _ -> when success (clearFailure server)

1045− atomic do

1046− cur <- *forwards

1047− set *forwards = do x <- cur; yield (if x.messageId == f.messageId && x.toServer == server then {messageId: x.messageId, toServer: x.toServer, createdAt: x.createdAt, toKey: x.toKey, encryptedBlob: x.encryptedBlob, timestamp: x.timestamp, originServer: x.originServer, retries: x.retries + 1, expiresAt: x.expiresAt, priority: x.priority, senderKey: x.senderKey} else x)

1048− cur2 <- *forwards

1049− set *forwards = do x <- cur2; where not (x.messageId == f.messageId && x.toServer == server && x.retries >= maxForwardRetries); yield x

1050− Ok r ->

1051− if r.ok then do

1052− clearFailure server

1053− atomic do

920+ atomic do

1054− cur <- *forwards

921+ cur <- *forwards

922+ set *forwards = do

923+ x <- cur

1055− set *forwards = do x <- cur; where not (x.messageId == f.messageId && x.toServer == server); yield x

924+ where x.messageId != f.messageId || x.toServer != server || (not success && x.retries + 1 < maxForwardRetries)

1056− else atomic do

925+ yield (if success || x.messageId != f.messageId || x.toServer != server then x

1057− cur <- *forwards

1058− set *forwards = do x <- cur; yield (if x.messageId == f.messageId && x.toServer == server then {messageId: x.messageId, toServer: x.toServer, createdAt: x.createdAt, toKey: x.toKey, encryptedBlob: x.encryptedBlob, timestamp: x.timestamp, originServer: x.originServer, retries: x.retries + 1, expiresAt: x.expiresAt, priority: x.priority, senderKey: x.senderKey} else x)

926+ else {messageId: x.messageId, toServer: x.toServer, createdAt: x.createdAt, toKey: x.toKey, encryptedBlob: x.encryptedBlob, timestamp: x.timestamp, originServer: x.originServer, retries: x.retries + 1, expiresAt: x.expiresAt, priority: x.priority, senderKey: x.senderKey})

1059 sendForwardsToServer rest server

927 sendForwardsToServer rest server

1060

928

1061sendAcksAndClean : [AckedEntry] -> IO {network} {}

929sendAcksAndClean : [AckedEntry] -> IO {network} {}

@@ -1184,7 +1052,7 @@ handleVerifyAuth = \pubkey challenge signature revokeOthers clientIp respond ->

1184 token <- genToken

1052 token <- genToken

1185 result <- atomic do

1053 result <- atomic do

1186 ch <- *challenges

1054 ch <- *challenges

1187− let hasMatch = any ch (\c -> c.pubkey == pubkey && safeCompare c.challenge challenge && c.expiresAt > t && matchIp clientIp c.ip)

1055+ let hasMatch = any ch (\c -> c.pubkey == pubkey && c.challenge == challenge && c.expiresAt > t && matchIp clientIp c.ip)

1188 if not hasMatch then yield {valid: False {}, peers: []}

1056 if not hasMatch then yield {valid: False {}, peers: []}

1189 else

1057 else

1190 if not (verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature))

1058 if not (verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature))

@@ -1225,10 +1093,10 @@ handleRevoke = \targetToken authorization clientIp respond -> do

1225 (\caller -> do

1093 (\caller -> do

1226 result <- atomic do

1094 result <- atomic do

1227 ses <- *sessions

1095 ses <- *sessions

1228− let found = any ses (\s -> s.pubkey == caller && safeCompare s.token targetToken)

1096+ let found = any ses (\s -> s.pubkey == caller && s.token == targetToken)

1229 if not found then yield False

1097 if not found then yield False

1230 else do

1098 else do

1231− set *sessions = do s <- ses; where s.pubkey != caller || not (safeCompare s.token targetToken); yield s

1099+ set *sessions = do s <- ses; where s.pubkey != caller || s.token != targetToken; yield s

1232 yield True

1100 yield True

1233 yield (respond {ok: result, authorized: True {}}))

1101 yield (respond {ok: result, authorized: True {}}))

1234

1102

@@ -1244,7 +1112,7 @@ handleLogout = \authorization clientIp respond -> do

1244 Authorized {pubkey, ip} ->

1112 Authorized {pubkey, ip} ->

1245 if not (matchIp clientIp ip) then yield {ok: False {}, pubkey: "", peers: []}

1113 if not (matchIp clientIp ip) then yield {ok: False {}, pubkey: "", peers: []}

1246 else do

1114 else do

1247− set *sessions = do s <- ses; where not (safeCompare s.token token); yield s

1115+ set *sessions = do s <- ses; where s.token != token; yield s

1248 -- If no remaining sessions for this key, drop local presence

1116 -- If no remaining sessions for this key, drop local presence

1249 after <- *sessions

1117 after <- *sessions

1250 let stillHas = any after (\s -> s.pubkey == pubkey)

1118 let stillHas = any after (\s -> s.pubkey == pubkey)

@@ -1393,13 +1261,12 @@ handleSendMessage = \to encryptedBlob timestamp messageId expiresInMs priority a

1393 withSessionAuth authorization t clientIp

1261 withSessionAuth authorization t clientIp

1394 (yield {status: MsUnauthorized {}, remoteServers: []})

1262 (yield {status: MsUnauthorized {}, remoteServers: []})

1395 (\senderKey -> sendMessageCore senderKey to encryptedBlob clampedTs effMsgId expiresInMs clampedPriority t)

1263 (\senderKey -> sendMessageCore senderKey to encryptedBlob clampedTs effMsgId expiresInMs clampedPriority t)

1264+ when (federationEnabled && count result.remoteServers > 0)

1396− forkSendForwards effMsgId to encryptedBlob clampedTs result.remoteServers

1265+ (fork (forkForwardsTo effMsgId to encryptedBlob clampedTs result.remoteServers))

1397− yield (case result.status of

1266+ let ok = case result.status of

1398− MsDuplicate {} -> respond {status: MsDuplicate {}, messageId: effMsgId, retryAfterMs: 0, error: "", loadPct: 0}

1267+ MsDelivered {} -> True {}; MsFederated {} -> True {}

1399− MsDelivered {} -> respond {status: MsDelivered {}, messageId: effMsgId, retryAfterMs: 0, error: "", loadPct: 0}

1268+ MsQueued {} -> True {}; MsDuplicate {} -> True {}; _ -> False {}

1400− MsFederated {} -> respond {status: MsFederated {}, messageId: effMsgId, retryAfterMs: 0, error: "", loadPct: 0}

1401− MsQueued {} -> respond {status: MsQueued {}, messageId: effMsgId, retryAfterMs: 0, error: "", loadPct: 0}

1402− _ -> respond {status: result.status, messageId: "", retryAfterMs: 0, error: "rejected", loadPct: 0})

1269+ yield (respond {status: result.status, messageId: if ok then effMsgId else "", retryAfterMs: 0, error: if ok then "" else "rejected", loadPct: 0})

1403

1270

1404sendMessageCore = \senderKey to encryptedBlob clampedTs effMsgId expiresInMs msgPriority t ->

1271sendMessageCore = \senderKey to encryptedBlob clampedTs effMsgId expiresInMs msgPriority t ->

1405 if senderKey == to then yield {status: MsRejected {}, remoteServers: []}

1272 if senderKey == to then yield {status: MsRejected {}, remoteServers: []}

@@ -1454,10 +1321,6 @@ sendMessageCore = \senderKey to encryptedBlob clampedTs effMsgId expiresInMs msg

1454 else MsQueued {}

1321 else MsQueued {}

1455 yield {status: status, remoteServers: remoteServers}

1322 yield {status: status, remoteServers: remoteServers}

1456

1323

1457−forkSendForwards = \effMsgId to encryptedBlob clampedTs remoteServers ->

1458− when (count remoteServers > 0 && federationEnabled)

1459− (fork (forkForwardsTo effMsgId to encryptedBlob clampedTs remoteServers))

1460−

1461forkForwardsTo = \effMsgId to encryptedBlob clampedTs servers ->

1324forkForwardsTo = \effMsgId to encryptedBlob clampedTs servers ->

1462 case headOf servers of

1325 case headOf servers of

1463 Nothing {} -> yield {}

1326 Nothing {} -> yield {}

@@ -1598,15 +1461,12 @@ handleListMessages = \offset authorization clientIp respond -> do

1598 let myMsgs = sortBy (\m -> m.receivedAt) (do m <- msgs; where m.toKey == pubkey && m.expiresAt > t; yield m)

1461 let myMsgs = sortBy (\m -> m.receivedAt) (do m <- msgs; where m.toKey == pubkey && m.expiresAt > t; yield m)

1599 let total = count myMsgs

1462 let total = count myMsgs

1600 let effectiveOffset = clamp 0 total offset

1463 let effectiveOffset = clamp 0 total offset

1464+ -- Index using a fold so we can drop items by position; simple O(n).

1601− let after = skipN effectiveOffset myMsgs

1465+ let after = (fold (\acc m -> if acc.i < effectiveOffset then {i: acc.i + 1, out: acc.out} else {i: acc.i, out: union acc.out [m]}) {i: 0, out: []} myMsgs).out

1602 let capped = takeRelation maxPollEvents after

1466 let capped = takeRelation maxPollEvents after

1603 let result = do m <- capped; yield {messageId: m.messageId, timestamp: m.timestamp, receivedAt: m.receivedAt}

1467 let result = do m <- capped; yield {messageId: m.messageId, timestamp: m.timestamp, receivedAt: m.receivedAt}

1604 yield (respond {messages: result, authorized: True {}, count: total, error: ""}))

1468 yield (respond {messages: result, authorized: True {}, count: total, error: ""}))

1605

1469

1606−skipN = \n items ->

1607− let r = fold (\acc x -> if acc.skipped < n then {skipped: acc.skipped + 1, result: acc.result} else {skipped: acc.skipped, result: union acc.result [x]}) {skipped: 0, result: []} items

1608− in r.result

1609−

1610handleDeleteMessages = \messageIds authorization clientIp respond -> do

1470handleDeleteMessages = \messageIds authorization clientIp respond -> do

1611 t <- now

1471 t <- now

1612 dp <- *drainPhase

1472 dp <- *drainPhase

@@ -1758,7 +1618,8 @@ sendBatchEach = \senderKey msgs t acc ->

1758 r <- if t - m.timestamp > messageMaxAge

1618 r <- if t - m.timestamp > messageMaxAge

1759 then yield {status: MsRejected {}, remoteServers: []}

1619 then yield {status: MsRejected {}, remoteServers: []}

1760 else atomic do sendMessageCore senderKey m.to m.encryptedBlob clampedTs effMsgId m.expiresInMs clampedPri t

1620 else atomic do sendMessageCore senderKey m.to m.encryptedBlob clampedTs effMsgId m.expiresInMs clampedPri t

1621+ when (federationEnabled && count r.remoteServers > 0)

1761− forkSendForwards effMsgId m.to m.encryptedBlob clampedTs r.remoteServers

1622+ (fork (forkForwardsTo effMsgId m.to m.encryptedBlob clampedTs r.remoteServers))

1762 sendBatchEach senderKey rest t (union acc [{messageId: effMsgId, status: r.status}])

1623 sendBatchEach senderKey rest t (union acc [{messageId: effMsgId, status: r.status}])

1763

1624

1764-- ============================================

1625-- ============================================

@@ -1778,24 +1639,14 @@ handleVerifyToken = \token scope clientIp respond -> do

1778 found <- atomic do

1639 found <- atomic do

1779 pending <- *pendingVerifications

1640 pending <- *pendingVerifications

1780 let candidates = do p <- pending; where p.scope == scope && t - p.createdAt < verificationTokenExpiry; yield p

1641 let candidates = do p <- pending; where p.scope == scope && t - p.createdAt < verificationTokenExpiry; yield p

1781− let match = any candidates (\p -> safeCompare p.token token)

1642+ let match = any candidates (\p -> p.token == token)

1782− when match (set *pendingVerifications = do p <- pending; where p.scope != scope || not (safeCompare p.token token); yield p)

1643+ when match (set *pendingVerifications = do p <- pending; where p.scope != scope || p.token != token; yield p)

1783 yield match

1644 yield match

1784 yield (respond {ok: found})

1645 yield (respond {ok: found})

1785

1646

1786handleFederationPubkey = \respond -> do

1647handleFederationPubkey = \respond -> do

1787 yield (respond {pubkey: serverFederationPublicKeyHex, ok: serverFederationPublicKeyHex != ""})

1648 yield (respond {pubkey: serverFederationPublicKeyHex, ok: serverFederationPublicKeyHex != ""})

1788

1649

1789−isOnlineEvent : GossipEventType -> Bool

1790−isOnlineEvent = \et -> case et of

1791− GossipOnline {} -> True {}

1792− _ -> False {}

1793−

1794−isOfflineEvent : GossipEventType -> Bool

1795−isOfflineEvent = \et -> case et of

1796− GossipOffline {} -> True {}

1797− _ -> False {}

1798−

1799handleRecvGossip = \events hopsRemaining fromServer requestTimestamp correlationId authorization respond -> do

1650handleRecvGossip = \events hopsRemaining fromServer requestTimestamp correlationId authorization respond -> do

1800 t <- now

1651 t <- now

1801 let cappedHops = clamp 0 maxGossipHops hopsRemaining

1652 let cappedHops = clamp 0 maxGossipHops hopsRemaining

@@ -1805,23 +1656,21 @@ handleRecvGossip = \events hopsRemaining fromServer requestTimestamp correlation

1805 let validEvents = do

1656 let validEvents = do

1806 e <- events

1657 e <- events

1807 where not (isLocalServer e.server) && e.timestamp <= t + clockSkewTolerance

1658 where not (isLocalServer e.server) && e.timestamp <= t + clockSkewTolerance

1808− let ttl = clampTtl e.ttl

1809− let effectiveTs = min e.timestamp t

1659+ let expiresAt = min e.timestamp t + clampTtl e.ttl * 1000

1810− let expiresAt = effectiveTs + ttl * 1000

1811 where expiresAt > t

1660 where expiresAt > t

1812 yield {pubkey: e.pubkey, server: e.server, expiresAt: expiresAt, timestamp: e.timestamp, eventType: e.eventType}

1661 yield {pubkey: e.pubkey, server: e.server, expiresAt: expiresAt, timestamp: e.timestamp, eventType: e.eventType}

1813− let online = do v <- validEvents; where isOnlineEvent v.eventType; yield {pubkey: v.pubkey, server: v.server, expiresAt: v.expiresAt, timestamp: v.timestamp}

1662+ let online = do v <- validEvents; where (case v.eventType of GossipOnline {} -> True {}; _ -> False {}); yield {pubkey: v.pubkey, server: v.server, expiresAt: v.expiresAt, timestamp: v.timestamp}

1814− let offline = do v <- validEvents; where isOfflineEvent v.eventType; yield {pubkey: v.pubkey, server: v.server, timestamp: v.timestamp}

1663+ let offline = do v <- validEvents; where (case v.eventType of GossipOffline {} -> True {}; _ -> False {}); yield {pubkey: v.pubkey, server: v.server, timestamp: v.timestamp}

1815 let withoutOffline = do

1664 let withoutOffline = do

1816 p <- pres

1665 p <- pres

1817− where none offline (\o -> samePubkeyServer o p && o.timestamp > p.timestamp)

1666+ where none offline (\o -> o.pubkey == p.pubkey && o.server == p.server && o.timestamp > p.timestamp)

1818 yield p

1667 yield p

1819 let merged = mergePresence withoutOffline online

1668 let merged = mergePresence withoutOffline online

1820 set *presence = capList merged maxPresenceEntries (\p -> p.expiresAt)

1669 set *presence = capList merged maxPresenceEntries (\p -> p.expiresAt)

1821 let newlyOnline = do

1670 let newlyOnline = do

1822 e <- online

1671 e <- online

1823 where not (isLocalServer e.server)

1672 where not (isLocalServer e.server)

1824− where none pres (\p -> samePubkeyServer p e && p.expiresAt >= e.expiresAt)

1673+ where none pres (\p -> p.pubkey == e.pubkey && p.server == e.server && p.expiresAt >= e.expiresAt)

1825 yield {pubkey: e.pubkey, server: e.server}

1674 yield {pubkey: e.pubkey, server: e.server}

1826 yield {newlyOnline: newlyOnline}

1675 yield {newlyOnline: newlyOnline}

1827 when (count valid.newlyOnline > 0)

1676 when (count valid.newlyOnline > 0)

@@ -2007,13 +1856,11 @@ handleFederationDeliveryReceipt = \messageIds toKeys fromServer requestTimestamp

2007 set *senderDeliveries = capList (union sd receipts) 10000 (\d -> d.deliveredAt)

1856 set *senderDeliveries = capList (union sd receipts) 10000 (\d -> d.deliveredAt)

2008 yield (respond {ok: True {}, error: "", receivedCount: count pairs, retryAfterMs: 0}))

1857 yield (respond {ok: True {}, error: "", receivedCount: count pairs, retryAfterMs: 0}))

2009

1858

1859+-- Pair up parallel lists by index. Builds index arrays and joins on i (O(n*m) but trivial code).

2010zipPairs = \mids keys ->

1860zipPairs = \mids keys ->

2011− case headOf mids of

1861+ let mIdx = (fold (\acc m -> {i: acc.i + 1, out: union acc.out [{i: acc.i, v: m}]}) {i: 0, out: []} mids).out in

2012− Nothing {} -> []

1862+ let kIdx = (fold (\acc k -> {i: acc.i + 1, out: union acc.out [{i: acc.i, v: k}]}) {i: 0, out: []} keys).out in

2013− Just {value: mid} -> case headOf keys of

1863+ do mp <- mIdx; kp <- kIdx; where mp.i == kp.i; yield {messageId: mp.v, toKey: kp.v}

2014− Nothing {} -> []

2015− Just {value: key} ->

2016− union [{messageId: mid, toKey: key}] (zipPairs (skipN 1 mids) (skipN 1 keys))

2017

1864

2018-- ============================================

1865-- ============================================

2019-- Maintenance handlers

1866-- Maintenance handlers