@@ -48,9 +48,7 @@ federationEnabled = federationSecret != ""
49-- ============================================
49-- ============================================
51−type PollEventType = Text where \s -> s == "message"
53−type PollEvent = {id: MessageIdHex, eventType: PollEventType, payload: {encryptedBlob: BlobHex, fromKey: PubkeyHex, timestamp: Timestamp, toKey: PubkeyHex}}
51+type PollEvent = {id: MessageIdHex, eventType: Text, payload: {encryptedBlob: BlobHex, fromKey: PubkeyHex, timestamp: Timestamp, toKey: PubkeyHex}}
55type GossipEventType = Text where \s -> s == "online" || s == "offline"
53type GossipEventType = Text where \s -> s == "online" || s == "offline"
@@ -58,26 +56,29 @@ type GossipEvent = {eventType: GossipEventType, pubkey: PubkeyHex, server: Serve
59type ValidGossipEntry = {eventType: GossipEventType, pubkey: PubkeyHex, server: ServerName, expiresAt: Timestamp, timestamp: Timestamp, ttl: Int<S>}
57type ValidGossipEntry = {eventType: GossipEventType, pubkey: PubkeyHex, server: ServerName, expiresAt: Timestamp, timestamp: Timestamp, ttl: Int<S>}
59+isDeliveryStatus = \s -> s == "delivered" || s == "federated" || s == "queued"
61−type MessageStatus = Text where \s -> s == "unauthorized" || s == "rejected" || s == "delivered" || s == "federated" || s == "queued"
60+type MessageStatus = Text where \s -> s == "unauthorized" || s == "rejected" || isDeliveryStatus s
63type PubkeyHex = Text where \s -> isValidHex s && not (tooLong s maxPubkeyLen) && s == normalizeHex s
62type PubkeyHex = Text where \s -> isValidHex s && not (tooLong s maxPubkeyLen) && s == normalizeHex s
64type BlobHex = Text where \s -> isValidHex s && not (tooLong s maxBlobLen) && s == normalizeHex s
63type BlobHex = Text where \s -> isValidHex s && not (tooLong s maxBlobLen) && s == normalizeHex s
65type SignatureHex = Text where \s -> isValidHex s && not (tooLong s maxSignatureLen) && s == normalizeHex s
64type SignatureHex = Text where \s -> isValidHex s && not (tooLong s maxSignatureLen) && s == normalizeHex s
66type MessageIdHex = Text where \s -> isValidHex s && not (tooLong s maxMessageIdLen) && s == normalizeHex s
65type MessageIdHex = Text where \s -> isValidHex s && not (tooLong s maxMessageIdLen) && s == normalizeHex s
67−type ServerName = Text where \s -> not (tooLong s maxServerNameLen) && s == normalizeServerName s && not (isBadServerName s)
66+isValidServerName = \s -> not (tooLong s maxServerNameLen) && s == normalizeServerName s && not (isBadServerName s)
67+type ServerName = Text where isValidServerName
68+type OptionalServerName = Text where \s -> s == "" || isValidServerName s
68−type OptionalServerName = Text where \s -> s == "" || (not (tooLong s maxServerNameLen) && s == normalizeServerName s && not (isBadServerName s))
69+type AnyServerName = Text where \s -> not (tooLong s maxServerNameLen) && s == normalizeServerName s
70type Timestamp = Int<Ms>
71type Timestamp = Int<Ms>
72type Challenge = {pubkey: PubkeyHex, challenge: Text, expiresAt: Timestamp}
73type Challenge = {pubkey: PubkeyHex, challenge: Text, expiresAt: Timestamp}
73type Session = {token: Text, pubkey: PubkeyHex, expiresAt: Timestamp}
74type Session = {token: Text, pubkey: PubkeyHex, expiresAt: Timestamp}
74type Message = {messageId: MessageIdHex, toKey: PubkeyHex, fromKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: OptionalServerName, receivedAt: Timestamp}
75type Message = {messageId: MessageIdHex, toKey: PubkeyHex, fromKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp, originServer: OptionalServerName, receivedAt: Timestamp}
75−type PresenceEntry = {pubkey: PubkeyHex, server: Text, expiresAt: Timestamp, timestamp: Timestamp}
76+type PresenceEntry = {pubkey: PubkeyHex, server: AnyServerName, expiresAt: Timestamp, timestamp: Timestamp}
76type ForwardEntry = {messageId: MessageIdHex, toServer: ServerName, createdAt: Timestamp, toKey: PubkeyHex, fromKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp}
77type ForwardEntry = {messageId: MessageIdHex, toServer: ServerName, createdAt: Timestamp, toKey: PubkeyHex, fromKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Timestamp}
77type AckedEntry = {messageId: MessageIdHex, toKey: PubkeyHex, ackedAt: Timestamp, originServer: ServerName}
78type AckedEntry = {messageId: MessageIdHex, toKey: PubkeyHex, ackedAt: Timestamp, originServer: ServerName}
78type AuthResult = Authorized {pubkey: PubkeyHex} | Unauthorized {}
79type AuthResult = Authorized {pubkey: PubkeyHex} | Unauthorized {}
79type PruneResult = {expiredLocal: [PresenceEntry], peerServers: [ServerName]}
80type PruneResult = {expiredLocal: [PresenceEntry], peerServers: [ServerName]}
80−type DeliveryStatus = Text where \s -> s == "delivered" || s == "federated" || s == "queued"
81+type DeliveryStatus = Text where isDeliveryStatus
81type SendResult = SendUnauthorized {} | SendRejected {} | SendDone {status: DeliveryStatus, remoteServers: [ServerName], fromKey: PubkeyHex}
82type SendResult = SendUnauthorized {} | SendRejected {} | SendDone {status: DeliveryStatus, remoteServers: [ServerName], fromKey: PubkeyHex}
@@ -265,14 +266,16 @@ normalizeServerName = \s -> toLower (stripTrailingDot s)
266serverHostN = normalizeServerName serverHost
267serverHostN = normalizeServerName serverHost
268−containsSuffix = \suffix suffixLen s ->
269+containsSuffixN = \suffix suffixLen s ->
269 if s == "" then False {}
270 if s == "" then False {}
270 else if take suffixLen s == suffix && (drop suffixLen s == "" || take 1 (drop suffixLen s) == ":") then True {}
271 else if take suffixLen s == suffix && (drop suffixLen s == "" || take 1 (drop suffixLen s) == ":") then True {}
271− else containsSuffix suffix suffixLen (drop 1 s)
272+ else containsSuffixN suffix suffixLen (drop 1 s)
274+containsSuffix = \suffix s -> containsSuffixN suffix (count (chars suffix)) s
273−containsLocalhostSuffix = \s -> containsSuffix ".localhost" 10 s
276+containsLocalhostSuffix = \s -> containsSuffix ".localhost" s
274−containsLocalSuffix = \s -> containsSuffix ".local" 6 s
277+containsLocalSuffix = \s -> containsSuffix ".local" s
275−containsInternalSuffix = \s -> containsSuffix ".internal" 9 s
278+containsInternalSuffix = \s -> containsSuffix ".internal" s
277is172Private = \sn ->
280is172Private = \sn ->
278 take 4 sn == "172."
281 take 4 sn == "172."
@@ -463,6 +466,22 @@ removeOffline = \presenceSet offlineOnlyKeys trustedOffline t ->
463 where samePubkeyServer p k && any trustedOffline (\o -> samePubkeyServer o k && (if o.timestamp > t then t else o.timestamp) > p.timestamp)
466 where samePubkeyServer p k && any trustedOffline (\o -> samePubkeyServer o k && (if o.timestamp > t then t else o.timestamp) > p.timestamp)
469+capGossipPresence = \afterOffline appliedOnline trustedDeduped presence offlineOnlyKeys trustedOffline t ->
470+ if count afterOffline <= maxPresenceEntries
471+ then {finalPresence: afterOffline, appliedOnline: appliedOnline, withinCapacity: True {}}
473+ let updatesOnly = do e <- trustedDeduped; where any presence (\p -> samePubkeyServer p e); yield e in
474+ let updatesOnlyMerged = mergeByPubkeyServer presence updatesOnly in
475+ let updatesOnlyAfterOffline = removeOffline updatesOnlyMerged offlineOnlyKeys trustedOffline t in
476+ let reclaimSlots = maxPresenceEntries - count updatesOnlyAfterOffline in
477+ let newEntries = do e <- trustedDeduped; where none presence (\p -> samePubkeyServer p e); yield e in
478+ let reclaimedEntries = takeN newEntries reclaimSlots in
479+ {finalPresence: union updatesOnlyAfterOffline reclaimedEntries,
480+ appliedOnline: union
481+ (do e <- updatesOnly; where none presence (\p -> samePubkeyServer p e && p.expiresAt >= e.expiresAt); yield {pubkey: e.pubkey, server: e.server})
482+ (do e <- reclaimedEntries; yield {pubkey: e.pubkey, server: e.server}),
483+ withinCapacity: False {}}
466countMessagesFor = \messages toKey t ->
485countMessagesFor = \messages toKey t ->
467 count (do
486 count (do
468 m <- messages
487 m <- messages
@@ -617,7 +636,7 @@ retryEvictedAcks = \evictedEntries pendingAcks ->
617 a <- evictedEntries
636 a <- evictedEntries
618 where none pendingAcks (\a2 -> a2.messageId == a.messageId && a2.toKey == a.toKey)
637 where none pendingAcks (\a2 -> a2.messageId == a.messageId && a2.toKey == a.toKey)
620− in when (count evictedToRetry > 0) (do
639+ in do
621 let evictedOriginServers = collectPeerServers evictedToRetry (\a -> a.originServer)
640 let evictedOriginServers = collectPeerServers evictedToRetry (\a -> a.originServer)
622 sendToEach evictedOriginServers (\server -> do
641 sendToEach evictedOriginServers (\server -> do
623 fetchResult <- fetch (federationScheme ++ server) (FederationAck {
642 fetchResult <- fetch (federationScheme ++ server) (FederationAck {
@@ -637,7 +656,7 @@ retryEvictedAcks = \evictedEntries pendingAcks ->
637 yield excess
656 yield excess
638 when (dropped > 0)
657 when (dropped > 0)
639 (println ("ackMessages: ackedIds at capacity (" ++ show maxAckedIds ++ "), " ++ show dropped ++ " ack entries permanently lost for " ++ server))
658 (println ("ackMessages: ackedIds at capacity (" ++ show maxAckedIds ++ "), " ++ show dropped ++ " ack entries permanently lost for " ++ server))
640− _ -> yield {}))
659+ _ -> yield {})
642pruneAndRetry = \t -> do
661pruneAndRetry = \t -> do
643 result <- atomic do
662 result <- atomic do
@@ -649,11 +668,9 @@ pruneAndRetry = \t -> do
649 yield {expiredLocal: pr.expiredLocal, peerServers: pr.peerServers, pendingForwards: forwards, pendingAcks: pendingAcks}
668 yield {expiredLocal: pr.expiredLocal, peerServers: pr.peerServers, pendingForwards: forwards, pendingAcks: pendingAcks}
650 broadcastOfflineGossip t result.peerServers result.expiredLocal
669 broadcastOfflineGossip t result.peerServers result.expiredLocal
651 when federationEnabled (do
670 when federationEnabled (do
652− when (count result.pendingForwards > 0)
653− (retryPendingForwards result.pendingForwards)
671+ retryPendingForwards result.pendingForwards
654− when (count result.pendingAcks > 0) (do
655− let ackOriginServers = collectPeerServers result.pendingAcks (\a -> a.originServer)
672+ let ackOriginServers = collectPeerServers result.pendingAcks (\a -> a.originServer)
656− sendAcksAndClean result.pendingAcks ackOriginServers))
673+ sendAcksAndClean result.pendingAcks ackOriginServers)
658pollOnce = \token cursor -> do
675pollOnce = \token cursor -> do
@@ -920,23 +937,10 @@ serve = \req -> case req of
920 where any presence (\p -> samePubkeyServer p k && any trustedOffline (\o -> samePubkeyServer o k && (if o.timestamp > t then t else o.timestamp) > p.timestamp))
937 where any presence (\p -> samePubkeyServer p k && any trustedOffline (\o -> samePubkeyServer o k && (if o.timestamp > t then t else o.timestamp) > p.timestamp))
921 yield {pubkey: k.pubkey, server: k.server}
938 yield {pubkey: k.pubkey, server: k.server}
922 let afterOffline = removeOffline merged offlineOnlyKeys trustedOffline t
939 let afterOffline = removeOffline merged offlineOnlyKeys trustedOffline t
923− let withinCapacity = count afterOffline <= maxPresenceEntries
940+ let capResult = capGossipPresence afterOffline appliedOnline trustedDeduped presence offlineOnlyKeys trustedOffline t
924− let capResult = if withinCapacity
925− then {finalPresence: afterOffline, appliedOnline: appliedOnline}
927− let updatesOnly = do e <- trustedDeduped; where any presence (\p -> samePubkeyServer p e); yield e in
928− let updatesOnlyMerged = mergeByPubkeyServer presence updatesOnly in
929− let updatesOnlyAfterOffline = removeOffline updatesOnlyMerged offlineOnlyKeys trustedOffline t in
930− let reclaimSlots = maxPresenceEntries - count updatesOnlyAfterOffline in
931− let newEntries = do e <- trustedDeduped; where none presence (\p -> samePubkeyServer p e); yield e in
932− let reclaimedEntries = takeN newEntries reclaimSlots in
933− {finalPresence: union updatesOnlyAfterOffline reclaimedEntries,
934− appliedOnline: union
935− (do e <- updatesOnly; where none presence (\p -> samePubkeyServer p e && p.expiresAt >= e.expiresAt); yield {pubkey: e.pubkey, server: e.server})
936− (do e <- reclaimedEntries; yield {pubkey: e.pubkey, server: e.server})}
937 set *presence = capResult.finalPresence
941 set *presence = capResult.finalPresence
938 let gossipPeerServers = collectPeerServers capResult.finalPresence (\p -> p.server)
942 let gossipPeerServers = collectPeerServers capResult.finalPresence (\p -> p.server)
939− yield {appliedKeys: union capResult.appliedOnline appliedOffline, pr: pr, gossipPeerServers: gossipPeerServers, withinCapacity: withinCapacity}
943+ yield {appliedKeys: union capResult.appliedOnline appliedOffline, pr: pr, gossipPeerServers: gossipPeerServers, withinCapacity: capResult.withinCapacity}
940 let effectiveEvents = do
944 let effectiveEvents = do
941 e <- union filteredOnline filteredOffline
945 e <- union filteredOnline filteredOffline
942 where any gossipResult.appliedKeys (\a -> samePubkeyServer a e)
946 where any gossipResult.appliedKeys (\a -> samePubkeyServer a e)