@@ -40,10 +40,16 @@ maxForwardRetriesPerServer = 100
4040-- Types
4141-- ============================================
4242
43−type PollEvent = {id: Text, eventType: Text, payload: Text}
43+type PollEvent = {id: Text, eventType: Text, payload: {encryptedBlob: Text, fromKey: Text, timestamp: Int, toKey: Text}}
4444
4545type GossipEvent = {eventType: Text, pubkey: Text, server: Text, timestamp: Int, ttl: Int}
4646
47+type PubkeyHex = Text where \s -> isValidHex s && not (tooLong s maxPubkeyLen)
48+type BlobHex = Text where \s -> isValidHex s && not (tooLong s maxBlobLen)
49+type SignatureHex = Text where \s -> isValidHex s && not (tooLong s maxSignatureLen)
50+type MessageIdHex = Text where \s -> isValidHex s && not (tooLong s maxMessageIdLen)
51+type ServerName = Text where \s -> not (tooLong s maxServerNameLen) && not (isBadServerName s)
52+
4753-- ============================================
4854-- Persisted State
4955-- ============================================
@@ -70,10 +76,10 @@ type GossipEvent = {eventType: Text, pubkey: Text, server: Text, timestamp: Int,
7076
7177route AuthApi where
7278 /auth
73− POST {pubkey: Text} /challenge
79+ POST {pubkey: PubkeyHex} /challenge
7480 -> {challenge: Text}
7581 = ReqChallenge
76− POST {pubkey: Text, challenge: Text, signature: Text} /verify
82+ POST {pubkey: PubkeyHex, challenge: Text, signature: SignatureHex} /verify
7783 -> {token: Text, expiresAt: Int}
7884 = VerifyAuth
7985
@@ -82,25 +88,25 @@ route ClientApi where
8288 -> {events: [PollEvent], cursor: Int, authorized: Bool}
8389 = Poll
8490 /messages
85− POST {to: Text, encryptedBlob: Text, timestamp: Int} / headers {authorization: Text}
91+ POST {to: PubkeyHex, encryptedBlob: BlobHex, timestamp: Int} / headers {authorization: Text}
8692 -> {status: Text, messageId: Text}
8793 = SendMessage
88− POST {messageIds: [Text]} /ack headers {authorization: Text}
94+ POST {messageIds: [MessageIdHex]} /ack headers {authorization: Text}
8995 -> {ok: Bool}
9096 = AckMessages
91− GET /lookup/{pubkey: Text} headers {authorization: Text}
97+ GET /lookup/{pubkey: PubkeyHex} headers {authorization: Text}
9298 -> {online: Bool, server: Text, authorized: Bool}
9399 = LookupPresence
94100
95101route FederationApi where
96102 /federation
97− POST {events: [GossipEvent], hopsRemaining: Int, fromServer: Text} /gossip headers {authorization: Text}
103+ POST {events: [GossipEvent], hopsRemaining: Int, fromServer: ServerName} /gossip headers {authorization: Text}
98104 -> {ok: Bool}
99105 = RecvGossip
100− POST {toKey: Text, fromKey: Text, encryptedBlob: Text, timestamp: Int, originServer: Text, messageId: Text} /forward headers {authorization: Text}
106+ POST {toKey: PubkeyHex, fromKey: PubkeyHex, encryptedBlob: BlobHex, timestamp: Int, originServer: ServerName, messageId: MessageIdHex} /forward headers {authorization: Text}
101107 -> {ok: Bool}
102108 = ForwardMessage
103− POST {messageIds: [Text], originServer: Text, fromServer: Text} /ack headers {authorization: Text}
109+ POST {messageIds: [Text], originServer: Text, fromServer: ServerName} /ack headers {authorization: Text}
104110 -> {ok: Bool}
105111 = FederationAck
106112
@@ -563,6 +569,7 @@ sendAcksAndClean = \pendingAcks servers ->
563569 )
564570 sendAcksAndClean pendingAcks rest
565571
572+pollOnce : Text -> Int -> IO {clock} {authorized: Bool, cursor: Int, events: [PollEvent]}
566573pollOnce = \token cursor -> do
567574 t <- now
568575 atomic do
@@ -604,16 +611,16 @@ pollOnce = \token cursor -> do
604611 let evts = do
605612 m <- limitedMsgs
606613 yield {id: m.messageId, eventType: "message",
607− payload: toJson {toKey: m.toKey, fromKey: m.fromKey,
608− encryptedBlob: m.encryptedBlob,
609− timestamp: m.timestamp}}
614+ payload: {toKey: m.toKey, fromKey: m.fromKey,
615+ encryptedBlob: m.encryptedBlob,
616+ timestamp: m.timestamp}}
610617 let lastReceivedAt = fold (\acc m -> if m.receivedAt > acc then m.receivedAt else acc) clampedCursor limitedMsgs
611618 let newCursor = case session of
612619 Nothing {} -> -1
613620 _ -> lastReceivedAt
614621 yield {events: evts, cursor: newCursor, authorized: authorized}
615622
616−pollLoop : Text -> Int -> Int -> IO {clock} {authorized: Bool, cursor: Int, events: [{eventType: Text, id: Text, payload: Text}]}
623+pollLoop : Text -> Int -> Int -> IO {clock} {authorized: Bool, cursor: Int, events: [PollEvent]}
617624pollLoop = \token cursor deadline -> do
618625 result <- pollOnce token cursor
619626 t <- now
@@ -632,45 +639,41 @@ pollLoop = \token cursor deadline -> do
632639serve = \req -> case req of
633640
634641 ReqChallenge {pubkey, respond} -> do
635− let valid = not (pubkey == "") && not (tooLong pubkey maxPubkeyLen) && isValidHex pubkey
636− let pubkey = if isValidHex pubkey then normalizeHex pubkey else pubkey
642+ let pubkey = normalizeHex pubkey
637643 challenge <- genToken
638644 t <- now
639− if valid
640− then do
641− pruneResult <- atomic do
642− pr <- maybePrune t
643− challenges <- *challenges
644− let existingCount = count (do c <- challenges; where c.pubkey == pubkey; where c.expiresAt > t; yield c)
645− let oldestChallengeExpiry = fold (\acc c2 -> if c2.pubkey == pubkey && c2.expiresAt > t && (acc == -1 || c2.expiresAt < acc) then c2.expiresAt else acc) (-1) challenges
646− let cappedChallenges = if existingCount >= maxChallengesPerKey && oldestChallengeExpiry >= 0
647− then fold (\acc c ->
648− if not acc.removed && c.pubkey == pubkey && c.expiresAt == oldestChallengeExpiry
649− then {removed: True {}, items: acc.items}
650− else {removed: acc.removed, items: union acc.items [c]}) {removed: False {}, items: []} challenges
651− else {removed: False {}, items: challenges}
652− let withoutExpired = if count cappedChallenges.items >= maxChallenges
653− then do c <- cappedChallenges.items; where c.expiresAt > t; yield c
654− else cappedChallenges.items
655− let globalOldestExpiry = if count withoutExpired >= maxChallenges
656− then fold (\acc c -> if acc == -1 || c.expiresAt < acc then c.expiresAt else acc) (-1) withoutExpired
657− else -1
658− let globalCapped = if globalOldestExpiry >= 0
659− then (fold (\acc c ->
660− if not acc.removed && c.expiresAt == globalOldestExpiry
661− then {removed: True {}, items: acc.items}
662− else {removed: acc.removed, items: union acc.items [c]}) {removed: False {}, items: []} withoutExpired).items
663− else withoutExpired
664− set *challenges = union
665− globalCapped
666− [{pubkey: pubkey, challenge: challenge, expiresAt: t + challengeExpiry}]
667− yield pr
668− fork (broadcastOfflineGossip t pruneResult.peerServers pruneResult.expiredLocal)
669− yield (respond {challenge: challenge})
670− else yield (respond {challenge: ""})
645+ pruneResult <- atomic do
646+ pr <- maybePrune t
647+ challenges <- *challenges
648+ let existingCount = count (do c <- challenges; where c.pubkey == pubkey; where c.expiresAt > t; yield c)
649+ let oldestChallengeExpiry = fold (\acc c2 -> if c2.pubkey == pubkey && c2.expiresAt > t && (acc == -1 || c2.expiresAt < acc) then c2.expiresAt else acc) (-1) challenges
650+ let cappedChallenges = if existingCount >= maxChallengesPerKey && oldestChallengeExpiry >= 0
651+ then fold (\acc c ->
652+ if not acc.removed && c.pubkey == pubkey && c.expiresAt == oldestChallengeExpiry
653+ then {removed: True {}, items: acc.items}
654+ else {removed: acc.removed, items: union acc.items [c]}) {removed: False {}, items: []} challenges
655+ else {removed: False {}, items: challenges}
656+ let withoutExpired = if count cappedChallenges.items >= maxChallenges
657+ then do c <- cappedChallenges.items; where c.expiresAt > t; yield c
658+ else cappedChallenges.items
659+ let globalOldestExpiry = if count withoutExpired >= maxChallenges
660+ then fold (\acc c -> if acc == -1 || c.expiresAt < acc then c.expiresAt else acc) (-1) withoutExpired
661+ else -1
662+ let globalCapped = if globalOldestExpiry >= 0
663+ then (fold (\acc c ->
664+ if not acc.removed && c.expiresAt == globalOldestExpiry
665+ then {removed: True {}, items: acc.items}
666+ else {removed: acc.removed, items: union acc.items [c]}) {removed: False {}, items: []} withoutExpired).items
667+ else withoutExpired
668+ set *challenges = union
669+ globalCapped
670+ [{pubkey: pubkey, challenge: challenge, expiresAt: t + challengeExpiry}]
671+ yield pr
672+ fork (broadcastOfflineGossip t pruneResult.peerServers pruneResult.expiredLocal)
673+ yield (respond {challenge: challenge})
671674
672675 VerifyAuth {pubkey, challenge, signature, respond} -> do
673− let pubkey = if isValidHex pubkey then normalizeHex pubkey else pubkey
676+ let pubkey = normalizeHex pubkey
674677 t <- now
675678 token <- genToken
676679 let expiry = t + sessionExpiry
@@ -687,11 +690,7 @@ serve = \req -> case req of
687690 yield c)
688691 let sigValid = case matched of
689692 Nothing {} -> False {}
690− _ -> if tooLong signature maxSignatureLen
691− then False {}
692− else if not (isValidHex pubkey) || not (isValidHex signature)
693− then False {}
694− else verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature)
693+ _ -> verify (bytesFromHex pubkey) (textToBytes challenge) (bytesFromHex signature)
695694 set *challenges = if sigValid
696695 then case matched of
697696 Just {value: _} -> do
@@ -780,9 +779,8 @@ serve = \req -> case req of
780779 yield (respond {events: result.events, cursor: result.cursor, authorized: result.authorized})
781780
782781 SendMessage {to, encryptedBlob, timestamp, authorization, respond} -> do
783− let validInput = not (to == "") && not (encryptedBlob == "") && not (tooLong to maxPubkeyLen) && not (tooLong encryptedBlob maxBlobLen) && isValidHex to && isValidHex encryptedBlob
784− let to = if isValidHex to then normalizeHex to else to
785− let encryptedBlob = if isValidHex encryptedBlob then normalizeHex encryptedBlob else encryptedBlob
782+ let to = normalizeHex to
783+ let encryptedBlob = normalizeHex encryptedBlob
786784 t <- now
787785 msgId <- genToken
788786 let clampedTs = if timestamp > t then t else if timestamp < t - messageMaxAge then t - messageMaxAge else timestamp
@@ -801,11 +799,11 @@ serve = \req -> case req of
801799 yield m)
802800 let shouldInsert = case session of
803801 Nothing {} -> False {}
804− Just {value: _} -> validInput && recipientMsgCount < maxMessagesPerRecipient
802+ Just {value: _} -> recipientMsgCount < maxMessagesPerRecipient
805803 set *seqCounter = if shouldInsert then seqTs else seqCounter
806804 set *messages = case session of
807805 Nothing {} -> messages
808− Just {value: s} -> if validInput && recipientMsgCount < maxMessagesPerRecipient
806+ Just {value: s} -> if recipientMsgCount < maxMessagesPerRecipient
809807 then union messages
810808 [{messageId: msgId, toKey: to, fromKey: s.pubkey,
811809 encryptedBlob: encryptedBlob, timestamp: clampedTs, originServer: "", receivedAt: seqTs}]
@@ -831,8 +829,7 @@ serve = \req -> case req of
831829 Just {value: s} -> s.pubkey
832830 let status = case session of
833831 Nothing {} -> "unauthorized"
834− _ -> if not validInput then "invalid"
835− else if recipientMsgCount >= maxMessagesPerRecipient then "rejected"
832+ _ -> if recipientMsgCount >= maxMessagesPerRecipient then "rejected"
836833 else if localOnline then "delivered"
837834 else if count remoteServers > 0 then "federated"
838835 else "queued"
@@ -848,7 +845,7 @@ serve = \req -> case req of
848845 yield {status: status, remoteServers: remoteServers, fromKey: fromKey, expiredLocal: pr.expiredLocal, peerServers: pr.peerServers, forwardsAtCapacity: forwardsAtCapacity}
849846 let finalStatus = if result.status == "federated" && (federationSecret == "" || result.forwardsAtCapacity) then "queued" else result.status
850847 fork (do
851− if count result.remoteServers > 0 && not (result.status == "unauthorized") && not (result.status == "invalid") && not (result.status == "rejected") && not (federationSecret == "")
848+ if count result.remoteServers > 0 && not (result.status == "unauthorized") && not (result.status == "rejected") && not (federationSecret == "")
852849 then sendToEach result.remoteServers (\server -> do
853850 fwdResult <- fetch (federationScheme ++ server) (ForwardMessage {
854851 toKey: to, fromKey: result.fromKey, encryptedBlob: encryptedBlob,
@@ -864,21 +861,19 @@ serve = \req -> case req of
864861 Err _ -> yield {}
865862 )
866863 else yield {}
867− if result.forwardsAtCapacity && count result.remoteServers > 0 && not (result.status == "unauthorized") && not (result.status == "invalid") && not (result.status == "rejected")
864+ if result.forwardsAtCapacity && count result.remoteServers > 0 && not (result.status == "unauthorized") && not (result.status == "rejected")
868865 then println ("sendMessage: forwards at capacity (" ++ show maxForwardsEntries ++ "), skipping forward tracking")
869866 else yield {}
870867 broadcastOfflineGossip t result.peerServers result.expiredLocal)
871− yield (respond {status: finalStatus, messageId: (if result.status == "unauthorized" then "" else if result.status == "invalid" then "" else if result.status == "rejected" then "" else msgId)})
868+ yield (respond {status: finalStatus, messageId: (if result.status == "unauthorized" then "" else if result.status == "rejected" then "" else msgId)})
872869
873870 AckMessages {messageIds, authorization, respond} -> do
874871 t <- now
875872 let dedupedIds = fold (\acc mid ->
876− if mid == "" then acc
877− else if count acc >= maxMessageIds then acc
878− else if tooLong mid maxMessageIdLen then acc
879− else if not (isValidHex mid) then acc
880− else if count (do a <- acc; where a == normalizeHex mid; yield a) > 0 then acc
881− else union acc [normalizeHex mid]) [] messageIds
873+ let nmid = normalizeHex mid in
874+ if count acc >= maxMessageIds then acc
875+ else if count (do a <- acc; where a == nmid; yield a) > 0 then acc
876+ else union acc [nmid]) [] messageIds
882877 result <- atomic do
883878 pr <- maybePrune t
884879 sessions <- *sessions
@@ -966,8 +961,7 @@ serve = \req -> case req of
966961 yield (respond {ok: result.ok})
967962
968963 LookupPresence {pubkey, authorization, respond} -> do
969− let validPubkey = not (pubkey == "") && not (tooLong pubkey maxPubkeyLen) && isValidHex pubkey
970− let pubkey = if isValidHex pubkey then normalizeHex pubkey else pubkey
964+ let pubkey = normalizeHex pubkey
971965 t <- now
972966 result <- atomic do
973967 pr <- maybePrune t
@@ -977,7 +971,7 @@ serve = \req -> case req of
977971 let authorized = case session of
978972 Nothing {} -> False {}
979973 _ -> True {}
980− let valid = if not validPubkey then [] else do
974+ let valid = do
981975 p <- presence
982976 where p.pubkey == pubkey
983977 where p.expiresAt > t
@@ -985,7 +979,7 @@ serve = \req -> case req of
985979 let foundServer = case session of
986980 Nothing {} -> ""
987981 Just {value: _} ->
988− if not validPubkey || count valid == 0
982+ if count valid == 0
989983 then ""
990984 else if count (do p <- valid; where p.server == serverHostN; yield p) > 0
991985 then serverHostN
@@ -998,8 +992,8 @@ serve = \req -> case req of
998992 t <- now
999993 let authorized = verifyFederationAuth authorization
1000994 let cappedHops = if hopsRemaining > 5 then 5 else hopsRemaining
1001− let fromServer = if tooLong fromServer maxServerNameLen then fromServer else normalizeServerName fromServer
1002− let validRequest = authorized && cappedHops >= 1 && not (fromServer == "") && not (fromServer == serverHostN) && not (tooLong fromServer maxServerNameLen) && not (isBadServerName fromServer) && count events <= maxGossipEvents
995+ let fromServer = normalizeServerName fromServer
996+ let validRequest = authorized && cappedHops >= 1 && not (fromServer == serverHostN) && count events <= maxGossipEvents
1003997 let onlineEntries = do
1004998 e <- events
1005999 where validRequest
@@ -1245,42 +1239,41 @@ serve = \req -> case req of
12451239 yield (respond {ok: validRequest})
12461240
12471241 ForwardMessage {toKey, fromKey, encryptedBlob, timestamp, originServer, messageId, authorization, respond} -> do
1248− 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 maxMessageIdLen) && isValidHex toKey && isValidHex fromKey && isValidHex encryptedBlob && isValidHex messageId
1249− let toKey = if isValidHex toKey then normalizeHex toKey else toKey
1250− let fromKey = if isValidHex fromKey then normalizeHex fromKey else fromKey
1251− let encryptedBlob = if isValidHex encryptedBlob then normalizeHex encryptedBlob else encryptedBlob
1252− let messageId = if isValidHex messageId then normalizeHex messageId else messageId
1253− let originServer = if tooLong originServer maxServerNameLen then originServer else normalizeServerName originServer
1242+ let toKey = normalizeHex toKey
1243+ let fromKey = normalizeHex fromKey
1244+ let encryptedBlob = normalizeHex encryptedBlob
1245+ let messageId = normalizeHex messageId
1246+ let originServer = normalizeServerName originServer
12541247 t <- now
12551248 let authorized = verifyFederationAuth authorization
1256− let validOrigin = not (originServer == "") && not (originServer == serverHostN) && not (tooLong originServer maxServerNameLen) && not (isBadServerName originServer)
1249+ let validOrigin = not (originServer == serverHostN)
12571250 let clampedTs = if timestamp > t then t else if timestamp < t - messageMaxAge then t - messageMaxAge else timestamp
12581251 result <- atomic do
12591252 pr <- maybePrune t
12601253 messages <- *messages
12611254 seqCounter <- *seqCounter
12621255 let seqTs = if t > seqCounter then t else seqCounter + 1
1263− let recipientMsgCount = if not (authorized && validOrigin && validFields) then 0
1256+ let recipientMsgCount = if not (authorized && validOrigin) then 0
12641257 else count (do
12651258 m <- messages
12661259 where m.toKey == toKey
12671260 where m.receivedAt >= t - messageMaxAge
12681261 yield m)
1269− let existsInMessages = if not (authorized && validOrigin && validFields) then False {}
1262+ let existsInMessages = if not (authorized && validOrigin) then False {}
12701263 else count (do
12711264 m <- messages
12721265 where m.messageId == messageId
12731266 where m.toKey == toKey
12741267 yield m) > 0
12751268 ackedIds <- *ackedIds
1276− let existsInAcked = if not (authorized && validOrigin && validFields) then False {}
1269+ let existsInAcked = if not (authorized && validOrigin) then False {}
12771270 else count (do
12781271 a <- ackedIds
12791272 where a.messageId == messageId
12801273 where a.toKey == toKey
12811274 yield a) > 0
12821275 let exists = existsInMessages || existsInAcked
1283− let shouldInsert = authorized && validOrigin && validFields && not exists && recipientMsgCount < maxMessagesPerRecipient
1276+ let shouldInsert = authorized && validOrigin && not exists && recipientMsgCount < maxMessagesPerRecipient
12841277 set *seqCounter = if shouldInsert then seqTs else seqCounter
12851278 set *messages = if shouldInsert
12861279 then union messages
@@ -1289,10 +1282,10 @@ serve = \req -> case req of
12891282 else messages
12901283 yield {peerServers: pr.peerServers, expiredLocal: pr.expiredLocal, inserted: shouldInsert, alreadyExists: exists}
12911284 fork (broadcastOfflineGossip t result.peerServers result.expiredLocal)
1292− yield (respond {ok: result.inserted || (authorized && validOrigin && validFields && result.alreadyExists)})
1285+ yield (respond {ok: result.inserted || (authorized && validOrigin && result.alreadyExists)})
12931286
12941287 FederationAck {messageIds, originServer, fromServer, authorization, respond} -> do
1295− let fromServer = if tooLong fromServer maxServerNameLen then fromServer else normalizeServerName fromServer
1288+ let fromServer = normalizeServerName fromServer
12961289 let originServer = if tooLong originServer maxServerNameLen then originServer else normalizeServerName originServer
12971290 t <- now
12981291 let authorized = verifyFederationAuth authorization
@@ -1303,7 +1296,7 @@ serve = \req -> case req of
13031296 else if not (isValidHex mid) then acc
13041297 else if count (do a <- acc; where a == normalizeHex mid; yield a) > 0 then acc
13051298 else union acc [normalizeHex mid]) [] messageIds
1306− let validAckFields = authorized && originServer == serverHostN && not (fromServer == "") && not (fromServer == serverHostN) && not (tooLong fromServer maxServerNameLen) && not (isBadServerName fromServer)
1299+ let validAckFields = authorized && originServer == serverHostN && not (fromServer == serverHostN)
13071300 pruneResult <- atomic do
13081301 pr <- maybePrune t
13091302 forwards <- *forwards