@@ -145,16 +145,48 @@ pruneExpired = \t -> do
145 s <- sessions
145 s <- sessions
146 where s.expiresAt > t
146 where s.expiresAt > t
148− presence <- *presence
148+ presenceBefore <- *presence
149− set *presence = do
149+ let presenceAfter = do
150− p <- presence
150+ p <- presenceBefore
151 where p.expiresAt > t
151 where p.expiresAt > t
153+ set *presence = presenceAfter
153 messages <- *messages
154 messages <- *messages
154 set *messages = do
155 set *messages = do
155 m <- messages
156 m <- messages
156 where m.timestamp >= t - messageMaxAge
157 where m.timestamp >= t - messageMaxAge
161+ where p.expiresAt <= t
162+ where p.server == serverHost
165+ where q.pubkey == p.pubkey
166+ where q.server == serverHost
170+broadcastOfflineGossip = \t expiredLocal -> do
171+ let expiredPubkeys = fold (\acc p ->
172+ if count (do a <- acc; where a == p.pubkey; yield a) > 0 then acc
173+ else union acc [p.pubkey]) [] expiredLocal
174+ if not (federationSecret == "") && count expiredPubkeys > 0
176+ peerServers <- atomic do
177+ presence <- *presence
178+ yield (fold (\acc p ->
179+ if p.server == serverHost then acc
180+ else if count (do a <- acc; where a == p.server; yield a) > 0 then acc
181+ else union acc [p.server]) [] presence)
182+ let gossipEvents = do
183+ pk <- expiredPubkeys
184+ yield {eventType: "offline", pubkey: pk, server: serverHost, timestamp: t, ttl: 3600}
185+ sendToEach peerServers (\server ->
186+ httpPost (federationScheme ++ server ++ "/federation/gossip")
187+ {authorization: "Bearer " ++ federationSecret}
188+ {events: gossipEvents, hopsRemaining: 2, fromServer: serverHost})
159-- ============================================
191-- ============================================
160-- Request Handler
192-- Request Handler
@@ -180,7 +212,7 @@ serve = \req -> case req of
180 token <- genToken
212 token <- genToken
181 let expiry = t + 3600000
213 let expiry = t + 3600000
182 result <- atomic do
214 result <- atomic do
183− pruneExpired t
215+ expiredLocal <- pruneExpired t
184 challenges <- *challenges
216 challenges <- *challenges
185 sessions <- *sessions
217 sessions <- *sessions
186 presence <- *presence
218 presence <- *presence
@@ -192,7 +224,9 @@ serve = \req -> case req of
193 let sigValid = case matched of
225 let sigValid = case matched of
194 Nothing {} -> False {}
226 Nothing {} -> False {}
227+ _ -> if tooLong signature maxSignatureLen
195− _ -> verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature)
229+ else verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature)
196 set *challenges = if sigValid
230 set *challenges = if sigValid
198 c <- challenges
232 c <- challenges
@@ -230,7 +264,7 @@ serve = \req -> case req of
230 else if count (do a <- acc; where a == p.server; yield a) > 0 then acc
264 else if count (do a <- acc; where a == p.server; yield a) > 0 then acc
231 else union acc [p.server]) [] updatedPresence
265 else union acc [p.server]) [] updatedPresence
233− yield {sigValid: sigValid, peerServers: peerServers}
267+ yield {sigValid: sigValid, peerServers: peerServers, expiredLocal: expiredLocal}
234 if result.sigValid
268 if result.sigValid
235 then respond {token: token, expiresAt: expiry}
269 then respond {token: token, expiresAt: expiry}
236 else respond {token: "", expiresAt: 0}
270 else respond {token: "", expiresAt: 0}
@@ -240,24 +274,13 @@ serve = \req -> case req of
240 {authorization: "Bearer " ++ federationSecret}
274 {authorization: "Bearer " ++ federationSecret}
241 {events: [{eventType: "online", pubkey: pubkey, server: serverHost, timestamp: t, ttl: 3600}], hopsRemaining: 2, fromServer: serverHost})
275 {events: [{eventType: "online", pubkey: pubkey, server: serverHost, timestamp: t, ttl: 3600}], hopsRemaining: 2, fromServer: serverHost})
242 else yield {}
276 else yield {}
277+ broadcastOfflineGossip t result.expiredLocal
244 Poll {cursor, authorization, respond} -> do
279 Poll {cursor, authorization, respond} -> do
246 let token = extractToken authorization
281 let token = extractToken authorization
247 result <- atomic do
282 result <- atomic do
248− presenceBeforePrune <- *presence
250− presenceAfterPrune <- *presence
251− let expiredLocal = do
283+ expiredLocal <- pruneExpired t
252− p <- presenceBeforePrune
253− where p.expiresAt <= t
254− where p.server == serverHost
256− q <- presenceAfterPrune
257− where q.pubkey == p.pubkey
258− where q.server == serverHost
261 sessions <- *sessions
284 sessions <- *sessions
262 messages <- *messages
285 messages <- *messages
263 let session = lookupSession sessions token t
286 let session = lookupSession sessions token t
@@ -275,28 +298,10 @@ serve = \req -> case req of
275 timestamp: m.timestamp}}
298 timestamp: m.timestamp}}
276 let newCursor = case session of
299 let newCursor = case session of
277 Nothing {} -> 0
300 Nothing {} -> 0
278− _ -> maxReceived
301+ _ -> if maxReceived > cursor then maxReceived else cursor
279 yield {events: evts, cursor: newCursor, expiredLocal: expiredLocal}
302 yield {events: evts, cursor: newCursor, expiredLocal: expiredLocal}
280 respond {events: result.events, cursor: result.cursor}
303 respond {events: result.events, cursor: result.cursor}
281− let expiredPubkeys = fold (\acc p ->
282− if count (do a <- acc; where a == p.pubkey; yield a) > 0 then acc
283− else union acc [p.pubkey]) [] result.expiredLocal
304+ broadcastOfflineGossip t result.expiredLocal
284− if not (federationSecret == "") && count expiredPubkeys > 0
286− peerServers <- atomic do
287− presence <- *presence
288− yield (fold (\acc p ->
289− if p.server == serverHost then acc
290− else if count (do a <- acc; where a == p.server; yield a) > 0 then acc
291− else union acc [p.server]) [] presence)
292− let gossipEvents = do
293− pk <- expiredPubkeys
294− yield {eventType: "offline", pubkey: pk, server: serverHost, timestamp: t, ttl: 3600}
295− sendToEach peerServers (\server ->
296− httpPost (federationScheme ++ server ++ "/federation/gossip")
297− {authorization: "Bearer " ++ federationSecret}
298− {events: gossipEvents, hopsRemaining: 2, fromServer: serverHost})
301 SendMessage {to, encryptedBlob, timestamp, authorization, respond} -> do
306 SendMessage {to, encryptedBlob, timestamp, authorization, respond} -> do
@@ -304,7 +309,7 @@ serve = \req -> case req of
304 let clampedTs = if timestamp > t then t else if timestamp < t - messageMaxAge then t else timestamp
309 let clampedTs = if timestamp > t then t else if timestamp < t - messageMaxAge then t else timestamp
305 let validInput = not (to == "") && not (encryptedBlob == "") && not (tooLong to maxPubkeyLen) && not (tooLong encryptedBlob maxBlobLen)
310 let validInput = not (to == "") && not (encryptedBlob == "") && not (tooLong to maxPubkeyLen) && not (tooLong encryptedBlob maxBlobLen)
306 result <- atomic do
311 result <- atomic do
307− pruneExpired t
312+ expiredLocal <- pruneExpired t
308 sessions <- *sessions
313 sessions <- *sessions
309 messages <- *messages
314 messages <- *messages
310 presence <- *presence
315 presence <- *presence
@@ -343,7 +348,7 @@ serve = \req -> case req of
343 else if localOnline then "delivered"
348 else if localOnline then "delivered"
344 else if count remoteServers > 0 then "federated"
349 else if count remoteServers > 0 then "federated"
345 else "queued"
350 else "queued"
346− yield {status: status, remoteServers: remoteServers, fromKey: fromKey}
351+ yield {status: status, remoteServers: remoteServers, fromKey: fromKey, expiredLocal: expiredLocal}
347 finalStatus <- if result.status == "federated" && not (federationSecret == "")
352 finalStatus <- if result.status == "federated" && not (federationSecret == "")
349 anyOk <- forwardToAll result.remoteServers "/federation/forward"
354 anyOk <- forwardToAll result.remoteServers "/federation/forward"
@@ -353,6 +358,7 @@ serve = \req -> case req of
353 yield (if anyOk then "federated" else "queued")
358 yield (if anyOk then "federated" else "queued")
354 else yield result.status
359 else yield result.status
355 respond {status: finalStatus, messageId: (if result.status == "unauthorized" then "" else if result.status == "invalid" then "" else msgId)}
360 respond {status: finalStatus, messageId: (if result.status == "unauthorized" then "" else if result.status == "invalid" then "" else msgId)}
361+ broadcastOfflineGossip t result.expiredLocal
357 AckMessages {messageIds, authorization, respond} -> do
363 AckMessages {messageIds, authorization, respond} -> do
@@ -362,7 +368,7 @@ serve = \req -> case req of
362 else if count (do a <- acc; where a == mid; yield a) > 0 then acc
368 else if count (do a <- acc; where a == mid; yield a) > 0 then acc
363 else union acc [mid]) [] messageIds
369 else union acc [mid]) [] messageIds
364 result <- atomic do
370 result <- atomic do
365− pruneExpired t
371+ expiredLocal <- pruneExpired t
366 sessions <- *sessions
372 sessions <- *sessions
367 messages <- *messages
373 messages <- *messages
368 let session = lookupSession sessions (extractToken authorization) t
374 let session = lookupSession sessions (extractToken authorization) t
@@ -380,7 +386,7 @@ serve = \req -> case req of
380 let ok = case session of
386 let ok = case session of
381 Nothing {} -> False {}
387 Nothing {} -> False {}
382 _ -> True {}
388 _ -> True {}
383− yield {ok: ok, ackedMessages: ackedMessages}
389+ yield {ok: ok, ackedMessages: ackedMessages, expiredLocal: expiredLocal}
384 let fedMessages = do
390 let fedMessages = do
385 m <- result.ackedMessages
391 m <- result.ackedMessages
386 where not (m.originServer == "")
392 where not (m.originServer == "")
@@ -397,6 +403,7 @@ serve = \req -> case req of
397 originServer: server, fromServer: serverHost})
403 originServer: server, fromServer: serverHost})
398 else yield {}
404 else yield {}
399 respond {ok: result.ok}
405 respond {ok: result.ok}
406+ broadcastOfflineGossip t result.expiredLocal
401 LookupPresence {pubkey, authorization, respond} -> do
408 LookupPresence {pubkey, authorization, respond} -> do
@@ -438,6 +445,8 @@ serve = \req -> case req of
438 where e.eventType == "online"
445 where e.eventType == "online"
439 where not (e.server == "")
446 where not (e.server == "")
440 where not (e.pubkey == "")
447 where not (e.pubkey == "")
448+ where not (tooLong e.pubkey maxPubkeyLen)
449+ where not (tooLong e.server maxPubkeyLen)
441 where not (e.server == serverHost)
450 where not (e.server == serverHost)
442 where e.timestamp <= t
451 where e.timestamp <= t
443 where e.timestamp + (clampTtl e.ttl) * 1000 > t
452 where e.timestamp + (clampTtl e.ttl) * 1000 > t
@@ -448,6 +457,8 @@ serve = \req -> case req of
448 where e.eventType == "offline"
457 where e.eventType == "offline"
449 where not (e.server == "")
458 where not (e.server == "")
450 where not (e.pubkey == "")
459 where not (e.pubkey == "")
460+ where not (tooLong e.pubkey maxPubkeyLen)
461+ where not (tooLong e.server maxPubkeyLen)
451 where not (e.server == serverHost)
462 where not (e.server == serverHost)
452 where e.timestamp <= t
463 where e.timestamp <= t
453 where t - e.timestamp < (clampTtl e.ttl) * 1000
464 where t - e.timestamp < (clampTtl e.ttl) * 1000
@@ -482,9 +493,18 @@ serve = \req -> case req of
482 where not (a.pubkey == e.pubkey && a.server == e.server)
493 where not (a.pubkey == e.pubkey && a.server == e.server)
484 [e]) [] filteredOnline
495 [e]) [] filteredOnline
485− atomic do
496+ appliedKeys <- atomic do
486 pruneExpired t
497 pruneExpired t
487 presence <- *presence
498 presence <- *presence
499+ let appliedOnline = do
503+ where p.pubkey == e.pubkey
504+ where p.server == e.server
505+ where p.expiresAt >= e.expiresAt
507+ yield {pubkey: e.pubkey, server: e.server}
488 let merged = fold (\acc e ->
508 let merged = fold (\acc e ->
489 if count (do
509 if count (do
@@ -503,6 +523,20 @@ serve = \req -> case req of
503 k <- affectedKeys
523 k <- affectedKeys
504 where count (do d <- deduped; where d.pubkey == k.pubkey; where d.server == k.server; yield d) == 0
524 where count (do d <- deduped; where d.pubkey == k.pubkey; where d.server == k.server; yield d) == 0
526+ let appliedOffline = do
527+ k <- offlineOnlyKeys
530+ where p.pubkey == k.pubkey
531+ where p.server == k.server
534+ where o.pubkey == k.pubkey
535+ where o.server == k.server
536+ where o.timestamp >= p.timestamp
539+ yield {pubkey: k.pubkey, server: k.server}
506 let afterOffline = diff merged (do
540 let afterOffline = diff merged (do
507 p <- merged
541 p <- merged
508 k <- offlineOnlyKeys
542 k <- offlineOnlyKeys
@@ -518,16 +552,23 @@ serve = \req -> case req of
518 set *presence = if validRequest
552 set *presence = if validRequest
519 then afterOffline
553 then afterOffline
520 else presence
554 else presence
555+ yield (union appliedOnline appliedOffline)
521 let validEvents = do
556 let validEvents = do
522 e <- events
557 e <- events
523 where validRequest
558 where validRequest
524 where not (e.server == "")
559 where not (e.server == "")
525 where not (e.pubkey == "")
560 where not (e.pubkey == "")
561+ where not (tooLong e.pubkey maxPubkeyLen)
562+ where not (tooLong e.server maxPubkeyLen)
526 where not (e.server == serverHost)
563 where not (e.server == serverHost)
527 where e.timestamp <= t
564 where e.timestamp <= t
528 where e.timestamp + (clampTtl e.ttl) * 1000 > t
565 where e.timestamp + (clampTtl e.ttl) * 1000 > t
567+ let effectiveEvents = do
569+ where count (do a <- appliedKeys; where a.pubkey == e.pubkey; where a.server == e.server; yield a) > 0
530− if validRequest && cappedHops > 1 && not (federationSecret == "") && count validEvents > 0
571+ if validRequest && cappedHops > 1 && not (federationSecret == "") && count effectiveEvents > 0
532 peerServers <- atomic do
573 peerServers <- atomic do
533 presence <- *presence
574 presence <- *presence
@@ -537,7 +578,7 @@ serve = \req -> case req of
537 else union acc [p.server]) [] presence)
578 else union acc [p.server]) [] presence)
538 let senderServers = fold (\acc e ->
579 let senderServers = fold (\acc e ->
539 if count (do a <- acc; where a == e.server; yield a) > 0 then acc
580 if count (do a <- acc; where a == e.server; yield a) > 0 then acc
540− else union acc [e.server]) (if fromServer == "" then [] else [fromServer]) events
581+ else union acc [e.server]) (if fromServer == "" then [] else [fromServer]) validEvents
541 let targets = do
582 let targets = do
542 s <- peerServers
583 s <- peerServers
543 where count (do ss <- senderServers; where ss == s; yield ss) == 0
584 where count (do ss <- senderServers; where ss == s; yield ss) == 0
@@ -545,7 +586,7 @@ serve = \req -> case req of
545 sendToEach targets (\server ->
586 sendToEach targets (\server ->
546 httpPost (federationScheme ++ server ++ "/federation/gossip")
587 httpPost (federationScheme ++ server ++ "/federation/gossip")
547 {authorization: "Bearer " ++ federationSecret}
588 {authorization: "Bearer " ++ federationSecret}
548− {events: validEvents, hopsRemaining: cappedHops - 1, fromServer: serverHost})
589+ {events: effectiveEvents, hopsRemaining: cappedHops - 1, fromServer: serverHost})
549 else yield {}
590 else yield {}
550 respond {ok: validRequest}
591 respond {ok: validRequest}
@@ -553,7 +594,7 @@ serve = \req -> case req of
554 let authorized = verifyFederationAuth authorization
595 let authorized = verifyFederationAuth authorization
555 let validOrigin = not (originServer == "") && not (originServer == serverHost)
596 let validOrigin = not (originServer == "") && not (originServer == serverHost)
556− let validFields = not (toKey == "") && not (fromKey == "") && not (encryptedBlob == "") && not (messageId == "") && not (tooLong toKey maxPubkeyLen) && not (tooLong fromKey maxPubkeyLen) && not (tooLong encryptedBlob maxBlobLen)
597+ let validFields = not (toKey == "") && not (fromKey == "") && not (encryptedBlob == "") && not (messageId == "") && not (tooLong toKey maxPubkeyLen) && not (tooLong fromKey maxPubkeyLen) && not (tooLong encryptedBlob maxBlobLen) && not (tooLong messageId maxPubkeyLen)
557 let clampedTs = if timestamp > t then t else if timestamp < t - messageMaxAge then t else timestamp
598 let clampedTs = if timestamp > t then t else if timestamp < t - messageMaxAge then t else timestamp
558 atomic do
599 atomic do
559 pruneExpired t
600 pruneExpired t
@@ -576,7 +617,12 @@ serve = \req -> case req of
576 FederationAck {messageIds, originServer, fromServer, authorization, respond} -> do
617 FederationAck {messageIds, originServer, fromServer, authorization, respond} -> do
578 let authorized = verifyFederationAuth authorization
619 let authorized = verifyFederationAuth authorization
620+ let dedupedIds = fold (\acc mid ->
621+ if mid == "" then acc
622+ else if count acc >= maxMessageIds then acc
623+ else if count (do a <- acc; where a == mid; yield a) > 0 then acc
624+ else union acc [mid]) [] messageIds
579− let validAck = authorized && originServer == serverHost && not (fromServer == "") && not (fromServer == serverHost) && count messageIds <= maxMessageIds
625+ let validAck = authorized && originServer == serverHost && not (fromServer == "") && not (fromServer == serverHost) && not (tooLong fromServer maxPubkeyLen) && count messageIds <= maxMessageIds
580 atomic do
626 atomic do
581 pruneExpired t
627 pruneExpired t
582 messages <- *messages
628 messages <- *messages
@@ -584,7 +630,7 @@ serve = \req -> case req of
584 set *messages = if validAck
630 set *messages = if validAck
585 then diff messages (do
631 then diff messages (do
586 m <- messages
632 m <- messages
587− mid <- messageIds
633+ mid <- dedupedIds
588 where m.messageId == mid
634 where m.messageId == mid
589 where count (do
635 where count (do
590 p <- presence
636 p <- presence