@@ -1,9 +1,8 @@
1−-- Skrepka Relay Server (simplified)
1+-- Skrepka Relay Server (maximally simplified)
22-- 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
5−-- helpers. Performance under load is significantly worse than the sharded original;
6−-- correctness and clarity are the only goals here.
3+-- Every collection is a flat list; rate limiters are plain count-per-window.
4+-- Token comparison is plain `==` (timing-attack vulnerable), retry backoff is linear,
5+-- and many helpers are inlined. Performance suffers; clarity is the only goal.
76
87-- ============================================
98-- Configuration
@@ -22,7 +21,6 @@ maxPresenceTtl = 3600
2221maxPubkeyLen = 256
2322maxBlobLen = 65536
2423maxSignatureLen = 256
25−maxIpLen = 45
2624maxMessageIds = 100
2725maxBatchSize = 100
2826maxMessagePriority = 10
@@ -34,12 +32,9 @@ maxMessages = 100000
3432clockSkewTolerance : Int<Ms>
3533clockSkewTolerance = 5000
3634maxForwardsEntries = 10000
37−maxForwardsPerKey = 50
38−maxForwardsPerSenderPerKey = 10
3935maxForwardsPerServer = 2000
4036maxServerNameLen = 128
4137maxMessageIdLen = 128
42−maxCorrelationIdLen = 128
4338maxTokenLen = 256
4439maxChallenges = 10000
4540maxSessions = 10000
@@ -87,7 +82,6 @@ onlineGossipTtl = 5400
8782offlineGossipMinTtl : Int<S>
8883offlineGossipMinTtl = 60
8984maxForwardRetries = 10
90−maxAckRetries = 10
9185maxGossipHops = 5
9286gossipOriginHops = 2
9387
@@ -100,9 +94,6 @@ verificationTokenExpiry : Int<Ms>
10094verificationTokenExpiry = 30000
10195maxPendingVerifications = 10000
10296
103−federationFetchTimeoutMs : Int<Ms>
104−federationFetchTimeoutMs = 30000
105−
10697backgroundPruneInterval : Int<Ms>
10798backgroundPruneInterval = 30000
10899pollTimeoutMs : Int<Ms>
@@ -469,16 +460,13 @@ maxBy = \items getKey -> fold (\acc x -> case acc of
469460 Nothing {} -> Just {value: x}
470461 Just {value: v} -> if getKey x > getKey v then Just {value: x} else acc) Nothing {} items
471462
472−-- Drop the single oldest entry by key (LRU-style eviction)
463+-- Drop entries with the oldest key (LRU-style eviction; ties drop together)
473464evictOldest = \items getKey ->
474465 case minBy items getKey of
475466 Nothing {} -> items
476467 Just {value: oldest} ->
477− let key = getKey oldest in
478− let r = fold (\acc 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
468+ let k = getKey oldest in
469+ do x <- items; where getKey x != k; yield x
482470
483471capList = \items maxN getKey ->
484472 if count items > maxN then evictOldest items getKey else items
@@ -508,73 +496,24 @@ genToken = genTokenN 8
508496tooLong : Text -> Int -> Bool
509497tooLong = \s maxLen -> drop maxLen s != ""
510498
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
546−isHexChar = \c -> contains c "0123456789abcdef"
547−
548−isValidHexPairs : Text -> Bool
549−isValidHexPairs = \s ->
550− if s == "" then True {}
499+isValidHex : Text -> Bool
500+isValidHex = \s ->
501+ if s == "" then False {}
551502 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)
553505 else False {}
554506
555−isValidHex : Text -> Bool
556−isValidHex = \s -> s != "" && isValidHexPairs s
557−
558507normalizeHex : Text -> Text
559508normalizeHex = \s -> bytesToHex (bytesFromHex s)
560509
561−isDigitChar : Text -> Bool
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−
510+-- Strip all trailing dots by recursing left-to-right; once the tail is all dots, it's dropped.
573511stripTrailingDot : Text -> Text
574512stripTrailingDot = \s ->
575513 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
578517
579518normalizeServerName : Text -> Text
580519normalizeServerName = \s -> toLower (stripTrailingDot s)
@@ -596,8 +535,8 @@ containsSuffix = \suffix s ->
596535isBadServerName : Text -> Bool
597536isBadServerName = \sn ->
598537 let fc = take 1 sn in
599− fc == "" || fc == "." || fc == ":"
600− || containsBadUrlChar sn
538+ fc == "" || fc == "." || fc == ":" || fc == "["
539+ || any (chars sn) (\c -> not (contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:"))
601540 || sn == "localhost"
602541 || containsSuffix ".localhost" sn
603542 || containsSuffix ".local" sn
@@ -610,57 +549,30 @@ isBadServerName = \sn ->
610549 || take 8 sn == "169.254."
611550 || take 2 sn == "0."
612551 || take 2 sn == "::"
613− || fc == "["
614552
615553-- ============================================
616554-- Auth helpers
617555-- ============================================
618556
619−safeCompareLen = maxTokenLen + 16
620−
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
557+-- Plain ip match (sessions with empty ip skip the check).
558+matchIp = \clientIp sessionIp -> sessionIp == "" || clientIp == sessionIp
643559
644560extractToken = \authHeader ->
645561 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)
647563 then Just {value: token}
648564 else Nothing {}
649565
650−verifySecret : Text -> Text -> Bool
651−verifySecret = \token secret -> secret != "" && safeCompare token secret
652−
653566verifyMaintenanceAuth : Text -> IO Bool
654567verifyMaintenanceAuth = \authorization -> do
655568 secret <- *runtimeMaintenanceSecret
656− if secret == "" then yield False
657− else case extractToken authorization of
658− Nothing {} -> yield False
659− Just {value: token} -> yield (verifySecret token secret)
569+ case extractToken authorization of
570+ Just {value: token} -> yield (secret != "" && token == secret)
571+ _ -> yield False
660572
661573authenticateSession : [Session] -> Text -> Timestamp -> AuthResult
662574authenticateSession = \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
664576 Nothing {} -> Unauthorized {}
665577 Just {value: s} -> Authorized {pubkey: s.pubkey, ip: s.ip}
666578
@@ -670,10 +582,9 @@ withSessionAuth = \authorization t clientIp onUnauth onAuth -> do
670582 Just {value: token} -> do
671583 sessions <- *sessions
672584 case authenticateSession sessions token t of
673− Unauthorized {} -> onUnauth
674585 Authorized {pubkey, ip} ->
675− if not (matchIp clientIp ip) then onUnauth
676− else onAuth pubkey
586+ if matchIp clientIp ip then onAuth pubkey else onUnauth
587+ _ -> onUnauth
677588
678589isBlockedPeer : Text -> [Text] -> Bool
679590isBlockedPeer = \server blocked -> any blocked (\b -> b == server)
@@ -706,78 +617,61 @@ generateFederationAuth = \scope requestTimestamp ->
706617 set *pendingVerifications = capList updated maxPendingVerifications (\p -> p.createdAt)
707618 yield ("Bearer " ++ token)
708619
709−verifyFederationCallback : Text -> Text -> Text -> IO {network} Bool
710−verifyFederationCallback = \fromServer authorization scope ->
711− case extractToken authorization of
712− Nothing {} -> yield False
620+-- Verify a federation request: signed (Ed25519 over scope|ts|fromServer|nonce) or callback Bearer token.
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
635+ else case extractToken authorization of
713636 Just {value: token} -> do
714637 result <- fetch (federationUrl fromServer) (VerifyToken {token: token, scope: scope})
715− case result of
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
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))
638+ case result of Ok r -> yield r.ok; _ -> yield False
639+ _ -> yield False
732640
733641withFederationAuth = \authorization t respond fromServer scope requestTimestamp precondition action -> do
734642 blocked <- *blockedPeers
735− if isBlockedPeer fromServer blocked
736− then yield (respond {ok: False {}, error: "blocked", retryAfterMs: 0})
737− else do
738643 allowed <- *allowedPeers
739− if not (isAllowedByAllowlist fromServer allowed)
740− then yield (respond {ok: False {}, error: "not_allowed", retryAfterMs: 0})
741− 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
750− else verifyFederationCallback fromServer authorization scope
751− if not verified
752− then yield (respond {ok: False {}, error: "unauthorized", retryAfterMs: 0})
644+ let denyReason =
645+ if isBlockedPeer fromServer blocked then "blocked"
646+ else if not (isAllowedByAllowlist fromServer allowed) then "not_allowed"
647+ else ""
648+ if denyReason != "" then yield (respond {ok: False {}, error: denyReason, retryAfterMs: 0})
649+ else do
650+ verified <- verifyFederationAuth authorization fromServer scope requestTimestamp
651+ if not verified then yield (respond {ok: False {}, error: "unauthorized", retryAfterMs: 0})
753652 else if requestTimestamp > 0 && (requestTimestamp > t + clockSkewTolerance || requestTimestamp < t - clockSkewTolerance)
754653 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})
757655 else do
758656 limited <- checkServerRateGate fromServer t
759− if limited
760− then yield (respond {ok: False {}, error: "rate_limited", retryAfterMs: federationRateWindowMs})
761− else action
657+ if limited then yield (respond {ok: False {}, error: "rate_limited", retryAfterMs: federationRateWindowMs})
658+ else action
762659
763660-- ============================================
764661-- Rate limiting (plain count-per-window, no sliding interpolation)
765662-- ============================================
766663
767664-- 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.
768666checkRate = \entries key maxRate windowMs maxEntries t ->
769− let entry = headOf (do r <- entries; where r.key == key; yield r) in
770− case entry of
771− Nothing {} ->
772− if 1 >= maxRate
773− then {limited: True {}, entries: entries}
774− else {limited: False {}, entries: capList (union entries [{key: key, windowStart: t, count: 1}]) 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)}
667+ let cur = headOf (do r <- entries; where r.key == key && t - r.windowStart < windowMs; yield r) in
668+ let nextCount = case cur of Just {value: r} -> r.count + 1; _ -> 1 in
669+ if nextCount > maxRate
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
674+ {limited: False {}, entries: capList (union others [{key: key, windowStart: windowStart, count: nextCount}]) maxEntries (\r -> r.windowStart)}
781675
782676checkGlobalRate = \t -> atomic do
783677 ws <- *globalRateWindowStart
@@ -805,11 +699,7 @@ checkAuthGlobalRate = \t -> atomic do
805699
806700checkIpRateGate = \ip t ->
807701 if ip == "" then yield False
808− else atomic do
809− rates <- *ipRates
810− let r = checkRate rates ip maxIpRatePerIp ipRateWindowMs 5000 t
811− set *ipRates = r.entries
812− yield r.limited
702+ else checkPubkeyRateGate ipRates ip maxIpRatePerIp ipRateWindowMs t
813703
814704checkPubkeyRateGate = \rateRef pubkey maxRate windowMs t -> atomic do
815705 rates <- *rateRef
@@ -817,17 +707,8 @@ checkPubkeyRateGate = \rateRef pubkey maxRate windowMs t -> atomic do
817707 set *rateRef = r.entries
818708 yield r.limited
819709
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
827− rates <- *federationRates
828− let r = checkRate rates server maxFederationRatePerServer federationRateWindowMs 5000 t
829− set *federationRates = r.entries
830− yield r.limited
710+checkServerRateGate = \server t ->
711+ checkPubkeyRateGate federationRates server maxFederationRatePerServer federationRateWindowMs t
831712
832713checkPreAuth = \clientIp t -> do
833714 dp <- *drainPhase
@@ -837,19 +718,14 @@ checkPreAuth = \clientIp t -> do
837718 if g then yield "global_rate_limited"
838719 else do
839720 i <- checkIpRateGate clientIp t
840− if i then yield "ip_rate_limited"
841− else yield ""
721+ yield (if i then "ip_rate_limited" else "")
842722
843723-- ============================================
844724-- Federation failure tracking (simple, no circuit breaker)
845725-- ============================================
846726
847−pow2 : Int -> Int
848−pow2 = \n -> if n <= 0 then 1 else 2 * pow2 (n - 1)
849−
850727retryBackoff : Int -> Int<Ms>
851−retryBackoff = \failures ->
852− min retryBackoffMax (retryBackoffBase * pow2 (max 0 (failures - 1)))
728+retryBackoff = \failures -> min retryBackoffMax (retryBackoffBase * max 1 failures)
853729
854730shouldRetryServer : Text -> Timestamp -> [ForwardFailure] -> Bool
855731shouldRetryServer = \server t failures ->
@@ -861,10 +737,11 @@ recordFailure = \server -> do
861737 t <- now
862738 atomic do
863739 failures <- *forwardFailures
864− let existing = headOf (do f <- failures; where f.server == server; yield f)
865− case existing of
866− Nothing {} -> set *forwardFailures = union failures [{server: server, failedAt: t, failures: 1, firstFailedAt: t}]
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)
740+ let others = do f <- failures; where f.server != server; yield f
741+ let prior = headOf (do f <- failures; where f.server == server; yield f)
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
744+ set *forwardFailures = union others [{server: server, failedAt: t, failures: nextN, firstFailedAt: firstAt}]
868745
869746clearFailure = \server -> atomic do
870747 failures <- *forwardFailures
@@ -896,9 +773,10 @@ dedupMessageIds = \ids ->
896773presenceForKey = \presence pubkey t ->
897774 do p <- presence; where p.pubkey == pubkey && p.expiresAt > t; yield p
898775
776+-- Pick local if present, else the remote with the latest expiresAt; "" when none.
899777bestServerForKey = \entries ->
900778 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
902780 Just {value: p} -> p.server
903781 Nothing {} -> ""
904782
@@ -915,13 +793,11 @@ collectPeers = \items getServer ->
915793knownPeerServersFromPresence : [PresenceEntry] -> [Text]
916794knownPeerServersFromPresence = \presence -> collectPeers presence (\p -> p.server)
917795
918−samePubkeyServer = \a b -> a.pubkey == b.pubkey && a.server == b.server
919−
920796-- Last-write-wins merge by (pubkey, server), keeping the entry with the larger expiresAt.
921797mergePresence = \existing incoming ->
922798 fold (\acc e ->
923− if any acc (\a -> samePubkeyServer a e && a.expiresAt >= e.expiresAt) then acc
924− else union (do x <- acc; where not (samePubkeyServer x e); yield x) [e]) existing incoming
799+ if any acc (\a -> a.pubkey == e.pubkey && a.server == e.server && a.expiresAt >= e.expiresAt) then acc
800+ else union (do x <- acc; where x.pubkey != e.pubkey || x.server != e.server; yield x) [e]) existing incoming
925801
926802-- ============================================
927803-- Pruning
@@ -1039,23 +915,15 @@ sendForwardsToServer = \fwds server ->
1039915 fromServer: serverHostN, requestTimestamp: t,
1040916 authorization: auth, correlationId: "",
1041917 expiresAt: f.expiresAt, priority: f.priority, protocolVersion: federationProtocolVersion})
1042− case result of
1043− Err _ -> do
1044− recordFailure 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
1054− cur <- *forwards
1055− set *forwards = do x <- cur; where not (x.messageId == f.messageId && x.toServer == server); yield x
1056− else atomic do
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)
918+ let success = case result of Ok r -> r.ok; _ -> False {}
919+ case result of Err _ -> recordFailure server; Ok _ -> when success (clearFailure server)
920+ atomic do
921+ cur <- *forwards
922+ set *forwards = do
923+ x <- cur
924+ where x.messageId != f.messageId || x.toServer != server || (not success && x.retries + 1 < maxForwardRetries)
925+ yield (if success || x.messageId != f.messageId || x.toServer != server then 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})
1059927 sendForwardsToServer rest server
1060928
1061929sendAcksAndClean : [AckedEntry] -> IO {network} {}
@@ -1184,7 +1052,7 @@ handleVerifyAuth = \pubkey challenge signature revokeOthers clientIp respond ->
11841052 token <- genToken
11851053 result <- atomic do
11861054 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)
11881056 if not hasMatch then yield {valid: False {}, peers: []}
11891057 else
11901058 if not (verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature))
@@ -1225,10 +1093,10 @@ handleRevoke = \targetToken authorization clientIp respond -> do
12251093 (\caller -> do
12261094 result <- atomic do
12271095 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)
12291097 if not found then yield False
12301098 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
12321100 yield True
12331101 yield (respond {ok: result, authorized: True {}}))
12341102
@@ -1244,7 +1112,7 @@ handleLogout = \authorization clientIp respond -> do
12441112 Authorized {pubkey, ip} ->
12451113 if not (matchIp clientIp ip) then yield {ok: False {}, pubkey: "", peers: []}
12461114 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
12481116 -- If no remaining sessions for this key, drop local presence
12491117 after <- *sessions
12501118 let stillHas = any after (\s -> s.pubkey == pubkey)
@@ -1393,13 +1261,12 @@ handleSendMessage = \to encryptedBlob timestamp messageId expiresInMs priority a
13931261 withSessionAuth authorization t clientIp
13941262 (yield {status: MsUnauthorized {}, remoteServers: []})
13951263 (\senderKey -> sendMessageCore senderKey to encryptedBlob clampedTs effMsgId expiresInMs clampedPriority t)
1396− forkSendForwards effMsgId to encryptedBlob clampedTs result.remoteServers
1397− yield (case result.status of
1398− MsDuplicate {} -> respond {status: MsDuplicate {}, messageId: effMsgId, retryAfterMs: 0, error: "", loadPct: 0}
1399− MsDelivered {} -> respond {status: MsDelivered {}, messageId: effMsgId, retryAfterMs: 0, error: "", loadPct: 0}
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})
1264+ when (federationEnabled && count result.remoteServers > 0)
1265+ (fork (forkForwardsTo effMsgId to encryptedBlob clampedTs result.remoteServers))
1266+ let ok = case result.status of
1267+ MsDelivered {} -> True {}; MsFederated {} -> True {}
1268+ MsQueued {} -> True {}; MsDuplicate {} -> True {}; _ -> False {}
1269+ yield (respond {status: result.status, messageId: if ok then effMsgId else "", retryAfterMs: 0, error: if ok then "" else "rejected", loadPct: 0})
14031270
14041271sendMessageCore = \senderKey to encryptedBlob clampedTs effMsgId expiresInMs msgPriority t ->
14051272 if senderKey == to then yield {status: MsRejected {}, remoteServers: []}
@@ -1454,10 +1321,6 @@ sendMessageCore = \senderKey to encryptedBlob clampedTs effMsgId expiresInMs msg
14541321 else MsQueued {}
14551322 yield {status: status, remoteServers: remoteServers}
14561323
1457−forkSendForwards = \effMsgId to encryptedBlob clampedTs remoteServers ->
1458− when (count remoteServers > 0 && federationEnabled)
1459− (fork (forkForwardsTo effMsgId to encryptedBlob clampedTs remoteServers))
1460−
14611324forkForwardsTo = \effMsgId to encryptedBlob clampedTs servers ->
14621325 case headOf servers of
14631326 Nothing {} -> yield {}
@@ -1598,15 +1461,12 @@ handleListMessages = \offset authorization clientIp respond -> do
15981461 let myMsgs = sortBy (\m -> m.receivedAt) (do m <- msgs; where m.toKey == pubkey && m.expiresAt > t; yield m)
15991462 let total = count myMsgs
16001463 let effectiveOffset = clamp 0 total offset
1601− let after = skipN effectiveOffset myMsgs
1464+ -- Index using a fold so we can drop items by position; simple O(n).
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
16021466 let capped = takeRelation maxPollEvents after
16031467 let result = do m <- capped; yield {messageId: m.messageId, timestamp: m.timestamp, receivedAt: m.receivedAt}
16041468 yield (respond {messages: result, authorized: True {}, count: total, error: ""}))
16051469
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−
16101470handleDeleteMessages = \messageIds authorization clientIp respond -> do
16111471 t <- now
16121472 dp <- *drainPhase
@@ -1758,7 +1618,8 @@ sendBatchEach = \senderKey msgs t acc ->
17581618 r <- if t - m.timestamp > messageMaxAge
17591619 then yield {status: MsRejected {}, remoteServers: []}
17601620 else atomic do sendMessageCore senderKey m.to m.encryptedBlob clampedTs effMsgId m.expiresInMs clampedPri t
1761− forkSendForwards effMsgId m.to m.encryptedBlob clampedTs r.remoteServers
1621+ when (federationEnabled && count r.remoteServers > 0)
1622+ (fork (forkForwardsTo effMsgId m.to m.encryptedBlob clampedTs r.remoteServers))
17621623 sendBatchEach senderKey rest t (union acc [{messageId: effMsgId, status: r.status}])
17631624
17641625-- ============================================
@@ -1778,24 +1639,14 @@ handleVerifyToken = \token scope clientIp respond -> do
17781639 found <- atomic do
17791640 pending <- *pendingVerifications
17801641 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)
1782− when match (set *pendingVerifications = do p <- pending; where p.scope != scope || not (safeCompare p.token token); yield p)
1642+ let match = any candidates (\p -> p.token == token)
1643+ when match (set *pendingVerifications = do p <- pending; where p.scope != scope || p.token != token; yield p)
17831644 yield match
17841645 yield (respond {ok: found})
17851646
17861647handleFederationPubkey = \respond -> do
17871648 yield (respond {pubkey: serverFederationPublicKeyHex, ok: serverFederationPublicKeyHex != ""})
17881649
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−
17991650handleRecvGossip = \events hopsRemaining fromServer requestTimestamp correlationId authorization respond -> do
18001651 t <- now
18011652 let cappedHops = clamp 0 maxGossipHops hopsRemaining
@@ -1805,23 +1656,21 @@ handleRecvGossip = \events hopsRemaining fromServer requestTimestamp correlation
18051656 let validEvents = do
18061657 e <- events
18071658 where not (isLocalServer e.server) && e.timestamp <= t + clockSkewTolerance
1808− let ttl = clampTtl e.ttl
1809− let effectiveTs = min e.timestamp t
1810− let expiresAt = effectiveTs + ttl * 1000
1659+ let expiresAt = min e.timestamp t + clampTtl e.ttl * 1000
18111660 where expiresAt > t
18121661 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}
1814− let offline = do v <- validEvents; where isOfflineEvent v.eventType; yield {pubkey: v.pubkey, server: v.server, 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}
1663+ let offline = do v <- validEvents; where (case v.eventType of GossipOffline {} -> True {}; _ -> False {}); yield {pubkey: v.pubkey, server: v.server, timestamp: v.timestamp}
18151664 let withoutOffline = do
18161665 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)
18181667 yield p
18191668 let merged = mergePresence withoutOffline online
18201669 set *presence = capList merged maxPresenceEntries (\p -> p.expiresAt)
18211670 let newlyOnline = do
18221671 e <- online
18231672 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)
18251674 yield {pubkey: e.pubkey, server: e.server}
18261675 yield {newlyOnline: newlyOnline}
18271676 when (count valid.newlyOnline > 0)
@@ -2007,13 +1856,11 @@ handleFederationDeliveryReceipt = \messageIds toKeys fromServer requestTimestamp
20071856 set *senderDeliveries = capList (union sd receipts) 10000 (\d -> d.deliveredAt)
20081857 yield (respond {ok: True {}, error: "", receivedCount: count pairs, retryAfterMs: 0}))
20091858
1859+-- Pair up parallel lists by index. Builds index arrays and joins on i (O(n*m) but trivial code).
20101860zipPairs = \mids keys ->
2011− case headOf mids of
2012− Nothing {} -> []
2013− Just {value: mid} -> case headOf keys of
2014− Nothing {} -> []
2015− Just {value: key} ->
2016− union [{messageId: mid, toKey: key}] (zipPairs (skipN 1 mids) (skipN 1 keys))
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
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
1863+ do mp <- mIdx; kp <- kIdx; where mp.i == kp.i; yield {messageId: mp.v, toKey: kp.v}
20171864
20181865-- ============================================
20191866-- Maintenance handlers