6969a09 · skrepka · git.iko.soy

git.iko.soy/skrepka

Improve server.knot correctness, reliability, and performance: drain signals, auth block during drain, health rate limit exemption, federation ack grace period, forward cleanup, message count tracking, prune generation safety, gossip optimization, and self-send rejection

6969a09iko6 months ago

server.knot+92−56

compare with master

unifiedsplit

@@ -18,6 +18,10 @@ serverHost = "localhost:8080"

18federationSecret = "" -- must be set to enable federation

19maintenanceSecret = "" -- set to enable /maintenance/prune independently of federation

20federationScheme = "https://" -- scheme for federation HTTP calls

21+-- NOTE: Outbound federation HTTP calls have no timeout. A slow/unresponsive peer can hold

22+-- a concurrency slot (maxFederationConcurrency) indefinitely. Add a fetch timeout if the

23+-- Knot runtime supports it; until then, exponential backoff on failed fetches mitigates

24+-- but does not fully prevent resource exhaustion from hung connections.

21-- Per-peer federation secrets (overrides global federationSecret for specific peers)

25-- Per-peer federation secrets (overrides global federationSecret for specific peers)

22-- Format: [{server: "peer.example.com", secret: "peer-specific-secret"}]

26-- Format: [{server: "peer.example.com", secret: "peer-specific-secret"}]

23federationPeerSecrets : [{server: Text, secret: Text}]

27federationPeerSecrets : [{server: Text, secret: Text}]

@@ -125,6 +129,9 @@ maxLookupRateEntries = 1000

125-- Unacked message aging (messages pruned after this regardless of ack status)

129-- Unacked message aging (messages pruned after this regardless of ack status)

126unackedMessageMaxAge : Int<Ms>

130unackedMessageMaxAge : Int<Ms>

127unackedMessageMaxAge = 604800000 -- 7 days

131unackedMessageMaxAge = 604800000 -- 7 days

132+-- Grace period before federation ack can delete the original message (allows local client to poll)

133+ackGracePeriod : Int<Ms>

134+ackGracePeriod = 30000 -- 30 seconds

128-- Health check thresholds (background task freshness)

135-- Health check thresholds (background task freshness)

129healthPruneMaxAge : Int<Ms>

136healthPruneMaxAge : Int<Ms>

130healthPruneMaxAge = backgroundPruneInterval * 3

137healthPruneMaxAge = backgroundPruneInterval * 3

@@ -163,7 +170,7 @@ type ValidGossipEntry = {pubkey: PubkeyHex, server: ServerName, expiresAt: Times

163-- Status returned to the sender after SendMessage

170-- Status returned to the sender after SendMessage

164-- Delivered: recipient is online locally; Federated: forwarded to remote server;

171-- Delivered: recipient is online locally; Federated: forwarded to remote server;

165-- Queued: stored but recipient location unknown; Unauthorized/Rejected: not accepted

172-- Queued: stored but recipient location unknown; Unauthorized/Rejected: not accepted

166−data MessageStatus = MsDelivered {} | MsFederated {} | MsQueued {} | MsUnauthorized {} | MsRejected {} | MsRateLimited {} | MsDuplicate {}

173+data MessageStatus = MsDelivered {} | MsFederated {} | MsQueued {} | MsUnauthorized {} | MsRejected {} | MsRateLimited {} | MsDuplicate {} | MsDraining {}

167

174

168impl ToJSON MessageStatus where

175impl ToJSON MessageStatus where

169 toJson ms = toJson (case ms of

176 toJson ms = toJson (case ms of

@@ -173,7 +180,8 @@ impl ToJSON MessageStatus where

173 MsUnauthorized {} -> "unauthorized"

180 MsUnauthorized {} -> "unauthorized"

174 MsRejected {} -> "rejected"

181 MsRejected {} -> "rejected"

175 MsRateLimited {} -> "rate_limited"

182 MsRateLimited {} -> "rate_limited"

176− MsDuplicate {} -> "duplicate")

183+ MsDuplicate {} -> "duplicate"

184+ MsDraining {} -> "draining")

177

185

178-- Internal delivery status (same as MessageStatus but without error variants)

186-- Internal delivery status (same as MessageStatus but without error variants)

179data DeliveryStatus = DsDelivered {} | DsFederated {} | DsQueued {}

187data DeliveryStatus = DsDelivered {} | DsFederated {} | DsQueued {}

@@ -244,6 +252,8 @@ type KeyPresenceEntry = {server: Text, expiresAt: Timestamp}

244

252

245*messages : [Message]

253*messages : [Message]

246

254

255+*totalMessageCount : Int

256+

247*presence : [PresenceEntry]

257*presence : [PresenceEntry]

248

258

249-- Monotonic counter ensuring unique receivedAt ordering even within the same millisecond

259-- Monotonic counter ensuring unique receivedAt ordering even within the same millisecond

@@ -314,6 +324,8 @@ type KeyPresenceEntry = {server: Text, expiresAt: Timestamp}

314

324

315*pruneRunning : Timestamp

325*pruneRunning : Timestamp

316

326

327+*pruneGeneration : Int

328+

317*ipRates : [IpRateEntry]

329*ipRates : [IpRateEntry]

318

330

319*lookupRates : [LookupRateEntry]

331*lookupRates : [LookupRateEntry]

@@ -345,7 +357,7 @@ route AuthApi where

345route ClientApi where

357route ClientApi where

346 -- Long-poll for new messages; cursor tracks last-seen receivedAt timestamp

358 -- Long-poll for new messages; cursor tracks last-seen receivedAt timestamp

347 POST {cursor: Timestamp} /poll headers {authorization: Text}

359 POST {cursor: Timestamp} /poll headers {authorization: Text}

348− -> {events: [PollEvent], cursor: Timestamp, authorized: Bool, rateLimited: Bool}

360+ -> {events: [PollEvent], cursor: Timestamp, authorized: Bool, rateLimited: Bool, draining: Bool}

349 = Poll

361 = Poll

350 /messages

362 /messages

351 -- Send an E2E encrypted message to a recipient pubkey

363 -- Send an E2E encrypted message to a recipient pubkey

@@ -894,12 +906,16 @@ pruneExpired = \t -> do

894 atomic do

906 atomic do

895 let messageCutoff = t - unackedMessageMaxAge

907 let messageCutoff = t - unackedMessageMaxAge

896 messages <- *messages

908 messages <- *messages

897− set *messages = do m <- messages; where m.receivedAt > messageCutoff; yield m

909+ let prunedMessages = do m <- messages; where m.receivedAt > messageCutoff; yield m

910+ set *messages = prunedMessages

911+ set *totalMessageCount = count prunedMessages

898 -- Prune federation state

912 -- Prune federation state

899 atomic do

913 atomic do

900 let retainCutoff = t - messageMaxAge

914 let retainCutoff = t - messageMaxAge

901 forwards <- *forwards

915 forwards <- *forwards

916+ -- Clear all forwards when federation is disabled (they can never be retried)

917+ set *forwards = if not federationEnabled then []

902− set *forwards = do f <- forwards; where f.createdAt > retainCutoff; yield f

918+ else do f <- forwards; where f.createdAt > retainCutoff; yield f

903 ackedIds <- *ackedIds

919 ackedIds <- *ackedIds

904 set *ackedIds = do a <- ackedIds; where a.ackedAt > retainCutoff; yield a

920 set *ackedIds = do a <- ackedIds; where a.ackedAt > retainCutoff; yield a

905 forwardFailures <- *forwardFailures

921 forwardFailures <- *forwardFailures

@@ -1269,10 +1285,10 @@ pruneAndRetry = \t -> do

1269 retryPendingForwards result.pendingForwards

1285 retryPendingForwards result.pendingForwards

1270 sendAcksAndClean result.pendingAcks

1286 sendAcksAndClean result.pendingAcks

1271 retryOverflowAcks result.pendingOverflow))

1287 retryOverflowAcks result.pendingOverflow))

1288+ -- Only gossip extended sessions; keys nearing expiry without active sessions will naturally

1289+ -- trigger offline gossip when they expire (avoids wasted federation traffic)

1272 when result.shouldRefresh (do

1290 when result.shouldRefresh (do

1273− let extendedEvents = do p <- result.extendedActive; yield {eventType: GossipOnline {}, pubkey: p.pubkey, server: serverHostN, timestamp: t, ttl: clampTtl (sessionExpiry / 1000)}

1291+ let refreshEvents = do p <- result.extendedActive; yield {eventType: GossipOnline {}, pubkey: p.pubkey, server: serverHostN, timestamp: t, ttl: clampTtl (sessionExpiry / 1000)}

1274− let nearExpiryEvents = do p <- result.nearExpiryActive; yield {eventType: GossipOnline {}, pubkey: p.pubkey, server: serverHostN, timestamp: p.timestamp, ttl: clampTtl ((p.expiresAt - p.timestamp) / 1000)}

1275− let refreshEvents = union extendedEvents nearExpiryEvents

1276 when (count result.refreshPeers > 0 && count refreshEvents > 0)

1292 when (count result.refreshPeers > 0 && count refreshEvents > 0)

1277 (fork (sendBatchedGossip result.refreshPeers refreshEvents gossipOriginHops)))

1293 (fork (sendBatchedGossip result.refreshPeers refreshEvents gossipOriginHops)))

1278

1294

@@ -1338,6 +1354,8 @@ ackPolledMessages = \pubkey cursor t -> do

1338 if count toAck > 0

1354 if count toAck > 0

1339 then do

1355 then do

1340 set *messages = diff messages toAck

1356 set *messages = diff messages toAck

1357+ totalCount <- *totalMessageCount

1358+ set *totalMessageCount = totalCount - count toAck

1341 let ackedMsgIds = do m <- toAck; yield m.messageId

1359 let ackedMsgIds = do m <- toAck; yield m.messageId

1342 forwards <- *forwards

1360 forwards <- *forwards

1343 set *forwards = do f <- forwards; where none ackedMsgIds (\mid -> f.messageId == mid && f.toKey == pubkey); yield f

1361 set *forwards = do f <- forwards; where none ackedMsgIds (\mid -> f.messageId == mid && f.toKey == pubkey); yield f

@@ -1635,6 +1653,10 @@ verifyAuthInner = \pubkey challenge signature revokeOthers clientIp respond t ->

1635 else yield {valid: True {}}

1653 else yield {valid: True {}}

1636 if validation.valid

1654 if validation.valid

1637 then do

1655 then do

1656+ -- Reject if server started draining after challenge was issued

1657+ isDraining <- *draining

1658+ if isDraining then yield (respond {token: "", expiresAt: 0})

1659+ else do

1638 token <- genToken

1660 token <- genToken

1639 peerServers <- atomic do

1661 peerServers <- atomic do

1640 sessions <- *sessions

1662 sessions <- *sessions

@@ -1660,10 +1682,10 @@ verifyAuthInner = \pubkey challenge signature revokeOthers clientIp respond t ->

1660handlePoll = \cursor authorization respond -> do

1682handlePoll = \cursor authorization respond -> do

1661 t <- now

1683 t <- now

1662 draining <- *draining

1684 draining <- *draining

1663− if draining then yield (respond {events: [], cursor: 0, authorized: False {}, rateLimited: False {}})

1685+ if draining then yield (respond {events: [], cursor: 0, authorized: True {}, rateLimited: False {}, draining: True {}})

1664 else do

1686 else do

1665 globalRateLimited <- checkGlobalRate t

1687 globalRateLimited <- checkGlobalRate t

1666− if globalRateLimited then yield (respond {events: [], cursor: 0, authorized: False {}, rateLimited: True {}})

1688+ if globalRateLimited then yield (respond {events: [], cursor: 0, authorized: False {}, rateLimited: True {}, draining: False {}})

1667 else do

1689 else do

1668 result <- case extractToken authorization of

1690 result <- case extractToken authorization of

1669 Nothing {} -> yield {authorized: False {}, events: [], cursor: 0, pendingAcks: [], evictedEntries: []}

1691 Nothing {} -> yield {authorized: False {}, events: [], cursor: 0, pendingAcks: [], evictedEntries: []}

@@ -1671,7 +1693,7 @@ handlePoll = \cursor authorization respond -> do

1671 fork (when federationEnabled (do

1693 fork (when federationEnabled (do

1672 sendAcksAndClean result.pendingAcks

1694 sendAcksAndClean result.pendingAcks

1673 retryEvictedAcks result.evictedEntries result.pendingAcks))

1695 retryEvictedAcks result.evictedEntries result.pendingAcks))

1674− yield (respond {events: result.events, cursor: result.cursor, authorized: result.authorized, rateLimited: False {}})

1696+ yield (respond {events: result.events, cursor: result.cursor, authorized: result.authorized, rateLimited: False {}, draining: False {}})

1675

1697

1676-- POST /messages: Send an encrypted message to a recipient.

1698-- POST /messages: Send an encrypted message to a recipient.

1677-- Deduplicates by messageId across messages, ackedIds, and deliveredIds.

1699-- Deduplicates by messageId across messages, ackedIds, and deliveredIds.

@@ -1679,7 +1701,7 @@ handlePoll = \cursor authorization respond -> do

1679handleSendMessage = \to encryptedBlob timestamp messageId authorization respond -> do

1701handleSendMessage = \to encryptedBlob timestamp messageId authorization respond -> do

1680 t <- now

1702 t <- now

1681 draining <- *draining

1703 draining <- *draining

1682− if draining then yield (respond {status: MsRejected {}, messageId: ""})

1704+ if draining then yield (respond {status: MsDraining {}, messageId: ""})

1683 else do

1705 else do

1684 globalRateLimited <- checkGlobalRate t

1706 globalRateLimited <- checkGlobalRate t

1685 if globalRateLimited then yield (respond {status: MsRateLimited {}, messageId: ""})

1707 if globalRateLimited then yield (respond {status: MsRateLimited {}, messageId: ""})

@@ -1690,6 +1712,9 @@ handleSendMessage = \to encryptedBlob timestamp messageId authorization respond

1690 withSessionAuth authorization t

1712 withSessionAuth authorization t

1691 (yield {send: SendFailed {status: MsUnauthorized {}}, senderRateLimited: False {}, globalCapReached: False {}})

1713 (yield {send: SendFailed {status: MsUnauthorized {}}, senderRateLimited: False {}, globalCapReached: False {}})

1692 (\senderKey -> do

1714 (\senderKey -> do

1715+ -- Reject self-sends (sender == recipient wastes a mailbox slot)

1716+ if senderKey == to then yield {send: SendFailed {status: MsRejected {}}, senderRateLimited: False {}, globalCapReached: False {}}

1717+ else do

1693 messages <- *messages

1718 messages <- *messages

1694 ackedIds <- *ackedIds

1719 ackedIds <- *ackedIds

1695 deliveredIds <- *deliveredIds

1720 deliveredIds <- *deliveredIds

@@ -1714,10 +1739,10 @@ handleSendMessage = \to encryptedBlob timestamp messageId authorization respond

1714 then yield {send: SendFailed {status: MsRateLimited {}}, senderRateLimited: False {}, globalCapReached: False {}}

1739 then yield {send: SendFailed {status: MsRateLimited {}}, senderRateLimited: False {}, globalCapReached: False {}}

1715 else do

1740 else do

1716 set *recvRates = recvResult.entries

1741 set *recvRates = recvResult.entries

1717− let msgStats = messageCounts messages to t

1742+ totalMsgCount <- *totalMessageCount

1718− if msgStats.total >= maxMessages

1743+ if totalMsgCount >= maxMessages

1719 then yield {send: SendFailed {status: MsRejected {}}, senderRateLimited: False {}, globalCapReached: True {}}

1744 then yield {send: SendFailed {status: MsRejected {}}, senderRateLimited: False {}, globalCapReached: True {}}

1720− else if msgStats.forKey >= maxMessagesPerRecipient

1745+ else if countMessagesFor messages to t >= maxMessagesPerRecipient

1721 then yield {send: SendFailed {status: MsRejected {}}, senderRateLimited: False {}, globalCapReached: False {}}

1746 then yield {send: SendFailed {status: MsRejected {}}, senderRateLimited: False {}, globalCapReached: False {}}

1722 else do

1747 else do

1723 presence <- *presence

1748 presence <- *presence

@@ -1727,6 +1752,7 @@ handleSendMessage = \to encryptedBlob timestamp messageId authorization respond

1727 set *messages = union messages

1752 set *messages = union messages

1728 [{messageId: effectiveMsgId, toKey: to,

1753 [{messageId: effectiveMsgId, toKey: to,

1729 encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: "", receivedAt: seqTs}]

1754 encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: "", receivedAt: seqTs}]

1755+ set *totalMessageCount = totalMsgCount + 1

1730 signalMessageForKey to seqTs

1756 signalMessageForKey to seqTs

1731 let toPresence = presenceForKey presence to t

1757 let toPresence = presenceForKey presence to t

1732 let localOnline = hasLocalPresence toPresence

1758 let localOnline = hasLocalPresence toPresence

@@ -1855,10 +1881,10 @@ handleForwardMessage = \toKey encryptedBlob timestamp originServer messageId fro

1855 if hasMessage messageId toKey messages || hasMessage messageId toKey ackedIds || hasMessage messageId toKey deliveredIds

1881 if hasMessage messageId toKey messages || hasMessage messageId toKey ackedIds || hasMessage messageId toKey deliveredIds

1856 then yield {forward: ForwardDuplicate {}, globalCapReached: False {}}

1882 then yield {forward: ForwardDuplicate {}, globalCapReached: False {}}

1857 else do

1883 else do

1858− let msgStats = messageCounts messages toKey t

1884+ totalMsgCount <- *totalMessageCount

1859− if msgStats.total >= maxMessages

1885+ if totalMsgCount >= maxMessages

1860 then yield {forward: ForwardRejected {}, globalCapReached: True {}}

1886 then yield {forward: ForwardRejected {}, globalCapReached: True {}}

1861− else if msgStats.forKey >= maxMessagesPerRecipient

1887+ else if countMessagesFor messages toKey t >= maxMessagesPerRecipient

1862 then yield {forward: ForwardRejected {}, globalCapReached: False {}}

1888 then yield {forward: ForwardRejected {}, globalCapReached: False {}}

1863 else do

1889 else do

1864 recvRates <- *recvRates

1890 recvRates <- *recvRates

@@ -1877,6 +1903,7 @@ handleForwardMessage = \toKey encryptedBlob timestamp originServer messageId fro

1877 [{messageId: messageId, toKey: toKey,

1903 [{messageId: messageId, toKey: toKey,

1878 encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: originServer, receivedAt: seqTs}]

1904 encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: originServer, receivedAt: seqTs}]

1879 set *messages = updatedMessages

1905 set *messages = updatedMessages

1906+ set *totalMessageCount = totalMsgCount + 1

1880 signalMessageForKey toKey seqTs

1907 signalMessageForKey toKey seqTs

1881 yield {forward: ForwardStored {}, globalCapReached: False {}}

1908 yield {forward: ForwardStored {}, globalCapReached: False {}}

1882 case result.forward of

1909 case result.forward of

@@ -1908,7 +1935,11 @@ handleFederationAck = \messageIds originServer fromServer authorization respond

1908 where none updatedForwards (\rf -> rf.messageId == f.messageId && rf.toKey == f.toKey)

1935 where none updatedForwards (\rf -> rf.messageId == f.messageId && rf.toKey == f.toKey)

1909 where none presence (\p -> p.pubkey == f.toKey && isLocalServer p.server && p.expiresAt > t)

1936 where none presence (\p -> p.pubkey == f.toKey && isLocalServer p.server && p.expiresAt > t)

1910 yield f

1937 yield f

1938+ -- Only remove messages stored long enough for local clients to have polled them (grace period)

1939+ let pastGrace = do f <- removable; where any messages (\m -> m.messageId == f.messageId && m.toKey == f.toKey && t - m.receivedAt >= ackGracePeriod); yield f

1911− set *messages = do m <- messages; where none removable (\f -> m.messageId == f.messageId && m.toKey == f.toKey); yield m

1940+ let updatedMessages = do m <- messages; where none pastGrace (\f -> m.messageId == f.messageId && m.toKey == f.toKey); yield m

1941+ set *messages = updatedMessages

1942+ set *totalMessageCount = count updatedMessages

1912 yield (respond {ok: True {}, error: ""}))

1943 yield (respond {ok: True {}, error: ""}))

1913

1944

1914-- POST /maintenance/drain: Broadcast offline gossip for all local keys (graceful shutdown).

1945-- POST /maintenance/drain: Broadcast offline gossip for all local keys (graceful shutdown).

@@ -1953,40 +1984,38 @@ handlePrune = \authorization respond -> do

1953

1984

1954handleHealth = \respond -> do

1985handleHealth = \respond -> do

1955 t <- now

1986 t <- now

1956− globalLimited <- checkGlobalRate t

1987+ -- Health checks exempt from global rate limiting (monitoring traffic shouldn't starve real requests)

1957− if globalLimited then yield (respond {ok: False {}, pruneHealthy: False {}, heartbeatHealthy: False {}, capacityHealthy: False {}, federationHealthy: False {}})

1958− else do

1959− result <- atomic do

1988+ result <- atomic do

1960− lastPrune <- *lastPrunedAt

1989+ lastPrune <- *lastPrunedAt

1961− lastHb <- *lastHeartbeatAt

1990+ lastHb <- *lastHeartbeatAt

1962− sa <- *startedAt

1991+ sa <- *startedAt

1963− presence <- *presence

1992+ presence <- *presence

1964− forwards <- *forwards

1993+ forwards <- *forwards

1965− sessions <- *sessions

1994+ sessions <- *sessions

1966− activePolls <- *activePolls

1995+ activePolls <- *activePolls

1967− messages <- *messages

1996+ messages <- *messages

1968− lastFedSuccess <- *lastFederationSuccessAt

1997+ lastFedSuccess <- *lastFederationSuccessAt

1969− forwardFailures <- *forwardFailures

1998+ forwardFailures <- *forwardFailures

1970− let warmup = t - sa < healthPruneMaxAge

1999+ let warmup = t - sa < healthPruneMaxAge

1971− -- Capacity pressure: flag when any capped collection exceeds 90% full

2000+ -- Capacity pressure: flag when any capped collection exceeds 90% full

1972− let capacityOk = count messages * 10 <= maxMessages * 9

2001+ let capacityOk = count messages * 10 <= maxMessages * 9

1973− && count presence * 10 <= maxPresenceEntries * 9

2002+ && count presence * 10 <= maxPresenceEntries * 9

1974− && count forwards * 10 <= maxForwardsEntries * 9

2003+ && count forwards * 10 <= maxForwardsEntries * 9

1975− && count sessions * 10 <= maxSessions * 9

2004+ && count sessions * 10 <= maxSessions * 9

1976− && count activePolls * 10 <= maxActivePolls * 9

2005+ && count activePolls * 10 <= maxActivePolls * 9

1977− -- Federation: healthy if disabled, in warmup, no peer issues, or recent success

2006+ -- Federation: healthy if disabled, in warmup, no peer issues, or recent success

1978− let fedOk = not federationEnabled || warmup

2007+ let fedOk = not federationEnabled || warmup

1979− || count forwardFailures == 0

2008+ || count forwardFailures == 0

1980− || (lastFedSuccess > 0 && t - lastFedSuccess < backgroundPruneInterval * 5)

2009+ || (lastFedSuccess > 0 && t - lastFedSuccess < backgroundPruneInterval * 5)

1981− yield {pruneOk: warmup || t - lastPrune < healthPruneMaxAge,

2010+ yield {pruneOk: warmup || t - lastPrune < healthPruneMaxAge,

1982− heartbeatOk: warmup || t - lastHb < healthHeartbeatMaxAge,

2011+ heartbeatOk: warmup || t - lastHb < healthHeartbeatMaxAge,

1983− capacityOk: capacityOk,

2012+ capacityOk: capacityOk,

1984− federationOk: fedOk}

2013+ federationOk: fedOk}

1985− yield (respond {ok: result.pruneOk && result.heartbeatOk && result.capacityOk && result.federationOk,

2014+ yield (respond {ok: result.pruneOk && result.heartbeatOk && result.capacityOk && result.federationOk,

1986− pruneHealthy: result.pruneOk,

2015+ pruneHealthy: result.pruneOk,

1987− heartbeatHealthy: result.heartbeatOk,

2016+ heartbeatHealthy: result.heartbeatOk,

1988− capacityHealthy: result.capacityOk,

2017+ capacityHealthy: result.capacityOk,

1989− federationHealthy: result.federationOk})

2018+ federationHealthy: result.federationOk})

1990

2019

1991handleStats = \authorization respond -> do

2020handleStats = \authorization respond -> do

1992 let authorized = verifyMaintenanceAuth authorization

2021 let authorized = verifyMaintenanceAuth authorization

@@ -2092,18 +2121,25 @@ backgroundPrune = do

2092 status <- atomic do

2121 status <- atomic do

2093 running <- *pruneRunning

2122 running <- *pruneRunning

2094 if running > 0 && t - running < backgroundPruneInterval * 3

2123 if running > 0 && t - running < backgroundPruneInterval * 3

2095− then yield {canRun: False {}, recovered: False {}}

2124+ then yield {canRun: False {}, recovered: False {}, gen: 0}

2096 else do

2125 else do

2097 set *pruneRunning = t

2126 set *pruneRunning = t

2127+ gen <- *pruneGeneration

2128+ let newGen = gen + 1

2129+ set *pruneGeneration = newGen

2098 pc <- *pruneCount

2130 pc <- *pruneCount

2099 set *pruneCount = pc + 1

2131 set *pruneCount = pc + 1

2100− yield {canRun: True {}, recovered: running > 0}

2132+ yield {canRun: True {}, recovered: running > 0, gen: newGen}

2101 when status.recovered

2133 when status.recovered

2102 (println "backgroundPrune: previous cycle appears stuck, forcing new cycle")

2134 (println "backgroundPrune: previous cycle appears stuck, forcing new cycle")

2103 if status.canRun

2135 if status.canRun

2104 then fork (do

2136 then fork (do

2105 pruneAndRetry t

2137 pruneAndRetry t

2138+ -- Only clear running flag if this is still the latest generation

2139+ -- (prevents a stuck old fork from clearing the flag after a recovery cycle started)

2106− atomic do set *pruneRunning = 0)

2140+ atomic do

2141+ currentGen <- *pruneGeneration

2142+ when (currentGen == status.gen) (set *pruneRunning = 0))

2107 else println "backgroundPrune: skipping (previous cycle still running)"

2143 else println "backgroundPrune: skipping (previous cycle still running)"

2108 backgroundPrune

2144 backgroundPrune

2109

2145