@@ -360,18 +360,21 @@ authenticateSession = \sessions token t ->
360extractToken = \authHeader ->
360extractToken = \authHeader ->
361 let token = drop 7 authHeader in
361 let token = drop 7 authHeader in
362 if toLower (take 7 authHeader) == "bearer " && not (tooLong token maxTokenLen)
362 if toLower (take 7 authHeader) == "bearer " && not (tooLong token maxTokenLen)
363− then token
363+ then Just {value: token}
364− else ""
364+ else Nothing {}
366verifySecret = \token secret ->
366verifySecret = \token secret ->
367 secret != "" && safeCompare token secret
367 secret != "" && safeCompare token secret
369verifyFederationAuth = \authorization ->
369verifyFederationAuth = \authorization ->
370− verifySecret (extractToken authorization) federationSecret
370+ case extractToken authorization of
371+ Nothing {} -> False {}
372+ Just {value: token} -> verifySecret token federationSecret
372verifyMaintenanceAuth = \authorization ->
374verifyMaintenanceAuth = \authorization ->
373− let token = extractToken authorization in
375+ case extractToken authorization of
376+ Nothing {} -> False {}
374− verifySecret token federationSecret || verifySecret token maintenanceSecret
377+ Just {value: token} -> verifySecret token federationSecret || verifySecret token maintenanceSecret
376clampTtl = clamp 1 maxPresenceTtl
379clampTtl = clamp 1 maxPresenceTtl
@@ -435,17 +438,7 @@ safeCompare = \a b ->
435 safeCompareLoop a b maxTokenLen 0 + (if a == "" then 1 else 0) + (if b == "" then 1 else 0) == 0
438 safeCompareLoop a b maxTokenLen 0 + (if a == "" then 1 else 0) + (if b == "" then 1 else 0) == 0
437evictOneOldest = \items getKey ->
440evictOneOldest = \items getKey ->
438− let oldest = fold (\acc x -> let k = getKey x in Just {value: case acc of
441+ diff items (boundedSmallest items 1 getKey)
440− Just {value: v} -> min k v
441− }) Nothing {} items in
444− Just {value: oldestKey} ->
446− if not acc.removed && getKey x == oldestKey
447− then {removed: True {}, items: acc.items}
448− else {removed: acc.removed, items: union acc.items [x]}) {removed: False {}, items: []} items).items
450capPerKey = \items matchKey maxPerKey getExpiry t ->
443capPerKey = \items matchKey maxPerKey getExpiry t ->
451 let active = do x <- items; where getExpiry x > t; yield x in
444 let active = do x <- items; where getExpiry x > t; yield x in
@@ -638,8 +631,8 @@ rejectFederation = \t respond -> do
638 maybePruneAndBroadcast t
631 maybePruneAndBroadcast t
639 yield (respond {ok: False {}})
632 yield (respond {ok: False {}})
641−withFederationAuth = \authorization t respond extraCheck action ->
634+withFederationAuth = \authorization t respond precondition action ->
642− if not (verifyFederationAuth authorization) || extraCheck
635+ if not (verifyFederationAuth authorization) || not precondition
643 then rejectFederation t respond
636 then rejectFederation t respond
644 else action
637 else action
@@ -647,6 +640,15 @@ maybePruneAndBroadcast = \t -> do
647 pruneResult <- atomic do maybePrune t
640 pruneResult <- atomic do maybePrune t
648 forkBroadcastOffline t pruneResult
641 forkBroadcastOffline t pruneResult
643+withSessionAuth = \authorization t onUnauth onAuth -> do
644+ sessions <- *sessions
645+ case extractToken authorization of
646+ Nothing {} -> onUnauth
647+ Just {value: token} ->
648+ case authenticateSession sessions token t of
649+ Unauthorized {} -> onUnauth
650+ Authorized {pubkey} -> onAuth pubkey
650removeForward = \mid srv -> atomic do
652removeForward = \mid srv -> atomic do
651 forwards <- *forwards
653 forwards <- *forwards
652 set *forwards = do
654 set *forwards = do
@@ -842,8 +844,9 @@ serve = \req -> case req of
843 let clampedTimeout = clamp 0 maxPollTimeout timeout
845 let clampedTimeout = clamp 0 maxPollTimeout timeout
844 let deadline = t + clampedTimeout
846 let deadline = t + clampedTimeout
845− let token = extractToken authorization
847+ result <- case extractToken authorization of
848+ Nothing {} -> yield (PollUnauthorized {})
846− result <- pollLoop token cursor deadline
849+ Just {value: token} -> pollLoop token cursor deadline
847 tAfterPoll <- now
850 tAfterPoll <- now
848 maybePruneAndBroadcast tAfterPoll
851 maybePruneAndBroadcast tAfterPoll
849 yield (respond (case result of
852 yield (respond (case result of
@@ -856,12 +859,9 @@ serve = \req -> case req of
856 let clampedTs = clampTimestamp timestamp t
859 let clampedTs = clampTimestamp timestamp t
857 result <- atomic do
860 result <- atomic do
858 pr <- maybePrune t
861 pr <- maybePrune t
859− sessions <- *sessions
862+ withSessionAuth authorization t
860− let auth = authenticateSession sessions (extractToken authorization) t
863− yield {pr: pr, send: SendFailed {status: MsUnauthorized {}}}
863+ (yield {pr: pr, send: SendFailed {status: MsUnauthorized {}}})
864− Authorized {pubkey: fromKey} -> do
864+ (\fromKey -> do
865 messages <- *messages
865 messages <- *messages
866 if countMessagesFor messages to t >= maxMessagesPerRecipient
866 if countMessagesFor messages to t >= maxMessagesPerRecipient
867 then yield {pr: pr, send: SendFailed {status: MsRejected {}}}
867 then yield {pr: pr, send: SendFailed {status: MsRejected {}}}
@@ -885,7 +885,7 @@ serve = \req -> case req of
885 set *forwards = if shouldForward
885 set *forwards = if shouldForward
886 then union forwards (do s <- forwardServers; yield {messageId: msgId, toServer: s, createdAt: t, toKey: to, fromKey: fromKey, encryptedBlob: encryptedBlob, timestamp: clampedTs})
886 then union forwards (do s <- forwardServers; yield {messageId: msgId, toServer: s, createdAt: t, toKey: to, fromKey: fromKey, encryptedBlob: encryptedBlob, timestamp: clampedTs})
887 else forwards
887 else forwards
888− yield {pr: pr, send: SendDone {delivery: delivery, remoteServers: remoteServers, forwardServers: forwardServers, fromKey: fromKey}}
888+ yield {pr: pr, send: SendDone {delivery: delivery, remoteServers: remoteServers, forwardServers: forwardServers, fromKey: fromKey}})
889 case result.send of
889 case result.send of
890 SendDone {delivery, remoteServers, forwardServers, fromKey} ->
890 SendDone {delivery, remoteServers, forwardServers, fromKey} ->
@@ -897,9 +897,8 @@ serve = \req -> case req of
897 authorization: federationAuth})
897 authorization: federationAuth})
898 when (any forwardServers (\s -> s == server))
898 when (any forwardServers (\s -> s == server))
899 (whenOk fwdResult (removeForward msgId server)))
899 (whenOk fwdResult (removeForward msgId server)))
900− case delivery of
900+ when (case delivery of DsQueued {} -> True {}; _ -> False {})
901− DsQueued {} -> println ("sendMessage: forwards at capacity (" ++ show maxForwardsEntries ++ "), skipping forward tracking")
901+ (println ("sendMessage: forwards at capacity (" ++ show maxForwardsEntries ++ "), skipping forward tracking")))
903 broadcastOfflineGossip t result.pr.peerServers result.pr.expiredLocal)
902 broadcastOfflineGossip t result.pr.peerServers result.pr.expiredLocal)
904 _ -> forkBroadcastOffline t result.pr
903 _ -> forkBroadcastOffline t result.pr
905 yield (case result.send of
904 yield (case result.send of
@@ -911,12 +910,9 @@ serve = \req -> case req of
911 let dedupedIds = dedupMessageIds messageIds
910 let dedupedIds = dedupMessageIds messageIds
912 result <- atomic do
911 result <- atomic do
913 pr <- maybePrune t
912 pr <- maybePrune t
914− sessions <- *sessions
913+ withSessionAuth authorization t
915− let auth = authenticateSession sessions (extractToken authorization) t
918− yield {pr: pr, ack: AckUnauthorized {}}
914+ (yield {pr: pr, ack: AckUnauthorized {}})
919− Authorized {pubkey} -> do
915+ (\pubkey -> do
920 messages <- *messages
916 messages <- *messages
921 let ackedMessages = do
917 let ackedMessages = do
922 m <- messages
918 m <- messages
@@ -933,7 +929,7 @@ serve = \req -> case req of
933 let evictedEntries = let excessCount = count combinedAckedIds - maxAckedIds in
929 let evictedEntries = let excessCount = count combinedAckedIds - maxAckedIds in
934 if excessCount <= 0 then [] else boundedSmallest combinedAckedIds excessCount (\a -> a.ackedAt)
930 if excessCount <= 0 then [] else boundedSmallest combinedAckedIds excessCount (\a -> a.ackedAt)
935 set *ackedIds = diff combinedAckedIds evictedEntries
931 set *ackedIds = diff combinedAckedIds evictedEntries
936− yield {pr: pr, ack: AckDone {pendingAcks: ackedFederated, evictedEntries: evictedEntries}}
932+ yield {pr: pr, ack: AckDone {pendingAcks: ackedFederated, evictedEntries: evictedEntries}})
938 case result.ack of
934 case result.ack of
939 AckDone {pendingAcks, evictedEntries} ->
935 AckDone {pendingAcks, evictedEntries} ->
@@ -948,12 +944,9 @@ serve = \req -> case req of
949 result <- atomic do
945 result <- atomic do
950 pr <- maybePrune t
946 pr <- maybePrune t
951− sessions <- *sessions
947+ withSessionAuth authorization t
952− let auth = authenticateSession sessions (extractToken authorization) t
955− yield {pr: pr, server: "", authorized: False {}}
948+ (yield {pr: pr, server: "", authorized: False {}})
956− Authorized _ -> do
949+ (\_ -> do
957 presence <- *presence
950 presence <- *presence
958 let valid = do
951 let valid = do
959 p <- presence
952 p <- presence
@@ -964,14 +957,14 @@ serve = \req -> case req of
964 let bestRemote = maxBy remoteValid (\p -> p.expiresAt)
957 let bestRemote = maxBy remoteValid (\p -> p.expiresAt)
965 let foundServer = if localOnline then serverHostN
958 let foundServer = if localOnline then serverHostN
966 else case bestRemote of Just {value: p} -> p.server; Nothing {} -> ""
959 else case bestRemote of Just {value: p} -> p.server; Nothing {} -> ""
967− yield {pr: pr, server: foundServer, authorized: True {}}
960+ yield {pr: pr, server: foundServer, authorized: True {}})
968 forkBroadcastOffline t result.pr
961 forkBroadcastOffline t result.pr
969 yield (respond {server: result.server, authorized: result.authorized})
962 yield (respond {server: result.server, authorized: result.authorized})
971 RecvGossip {events, hopsRemaining, fromServer, authorization, respond} -> do
964 RecvGossip {events, hopsRemaining, fromServer, authorization, respond} -> do
973 let cappedHops = clamp 0 maxGossipHops hopsRemaining
966 let cappedHops = clamp 0 maxGossipHops hopsRemaining
974− withFederationAuth authorization t respond (cappedHops < 1 || isLocalServer fromServer || count events > maxGossipEvents) (do
967+ withFederationAuth authorization t respond (cappedHops >= 1 && not (isLocalServer fromServer) && count events <= maxGossipEvents) (do
975 let validated = validGossipEvents events t
968 let validated = validGossipEvents events t
976 let onlineEntries = validated.online
969 let onlineEntries = validated.online
977 let trustedOffline = do e <- validated.offline; where e.server == fromServer; yield e
970 let trustedOffline = do e <- validated.offline; where e.server == fromServer; yield e
@@ -999,7 +992,7 @@ serve = \req -> case req of
1000 ForwardMessage {toKey, fromKey, encryptedBlob, timestamp, originServer, messageId, authorization, respond} -> do
993 ForwardMessage {toKey, fromKey, encryptedBlob, timestamp, originServer, messageId, authorization, respond} -> do
1001 t <- now
994 t <- now
1002− withFederationAuth authorization t respond (isLocalServer originServer) (do
995+ withFederationAuth authorization t respond (not (isLocalServer originServer)) (do
1003 let clampedTs = clampTimestamp timestamp t
996 let clampedTs = clampTimestamp timestamp t
1004 result <- atomic do
997 result <- atomic do
1005 pr <- maybePrune t
998 pr <- maybePrune t
@@ -1020,12 +1013,11 @@ serve = \req -> case req of
1020 forkBroadcastOffline t result.pr
1013 forkBroadcastOffline t result.pr
1021 yield (respond {ok: case result.forward of
1014 yield (respond {ok: case result.forward of
1022 ForwardRejected {} -> False {}
1015 ForwardRejected {} -> False {}
1023− ForwardDuplicate {} -> True {}
1016+ _ -> True {}}))
1024− ForwardStored {} -> True {}}))
1026 FederationAck {messageIds, originServer, fromServer, authorization, respond} -> do
1018 FederationAck {messageIds, originServer, fromServer, authorization, respond} -> do
1027 t <- now
1019 t <- now
1028− withFederationAuth authorization t respond (not (isLocalServer originServer) || isLocalServer fromServer) (do
1020+ withFederationAuth authorization t respond (isLocalServer originServer && not (isLocalServer fromServer)) (do
1029 let dedupedIds = dedupMessageIds messageIds
1021 let dedupedIds = dedupMessageIds messageIds
1030 pruneResult <- atomic do
1022 pruneResult <- atomic do
1031 pr <- maybePrune t
1023 pr <- maybePrune t