@@ -43,6 +43,8 @@ offlineGossipMinTtl : Int<S>
43offlineGossipMinTtl = 60 -- minimum TTL for offline gossip events
43offlineGossipMinTtl = 60 -- minimum TTL for offline gossip events
44maxForwardRetriesPerServer = 100
44maxForwardRetriesPerServer = 100
45federationEnabled = federationSecret != ""
45federationEnabled = federationSecret != ""
46+federationAuth = "Bearer " ++ federationSecret
47+federationUrl = \server -> federationScheme ++ server
47-- ============================================
49-- ============================================
@@ -84,10 +86,11 @@ impl ToJSON MessageStatus where
84 MsUnauthorized {} -> "unauthorized"
86 MsUnauthorized {} -> "unauthorized"
85 MsRejected {} -> "rejected")
87 MsRejected {} -> "rejected")
89+isValidBoundedHex = \maxLen s -> isValidHex s && not (tooLong s maxLen) && s == normalizeHex s
87−type PubkeyHex = Text where \s -> isValidHex s && not (tooLong s maxPubkeyLen) && s == normalizeHex s
90+type PubkeyHex = Text where isValidBoundedHex maxPubkeyLen
88−type BlobHex = Text where \s -> isValidHex s && not (tooLong s maxBlobLen) && s == normalizeHex s
91+type BlobHex = Text where isValidBoundedHex maxBlobLen
89−type SignatureHex = Text where \s -> isValidHex s && not (tooLong s maxSignatureLen) && s == normalizeHex s
92+type SignatureHex = Text where isValidBoundedHex maxSignatureLen
90−isValidMessageId = \s -> isValidHex s && not (tooLong s maxMessageIdLen) && s == normalizeHex s
93+isValidMessageId = isValidBoundedHex maxMessageIdLen
91type MessageIdHex = Text where isValidMessageId
94type MessageIdHex = Text where isValidMessageId
92type OptionalMessageId = Text where \s -> s == "" || isValidMessageId s
95type OptionalMessageId = Text where \s -> s == "" || isValidMessageId s
93isValidServerName = \s -> not (tooLong s maxServerNameLen) && s == normalizeServerName s && not (isBadServerName s)
96isValidServerName = \s -> not (tooLong s maxServerNameLen) && s == normalizeServerName s && not (isBadServerName s)
@@ -235,44 +238,30 @@ isAllowedServerChar = \c -> contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:"
235containsBadUrlChar = \s -> any (chars s) (\c -> not (isAllowedServerChar c))
238containsBadUrlChar = \s -> any (chars s) (\c -> not (isAllowedServerChar c))
237isCgnatRange = \s ->
240isCgnatRange = \s ->
238− if take 4 s != "100." then False {}
241+ take 4 s == "100."
239− else let d4 = take 1 (drop 4 s) in
242+ && let d4 = take 1 (drop 4 s) in
240 let d5 = take 1 (drop 5 s) in
243 let d5 = take 1 (drop 5 s) in
241 let d6 = take 1 (drop 6 s) in
244 let d6 = take 1 (drop 6 s) in
242 let d7 = take 1 (drop 7 s) in
245 let d7 = take 1 (drop 7 s) in
246+ let twoDigitOctet = d6 == "." && isAllDigitsOrDotsUntilColonOrEnd (drop 7 s) in
247+ let threeDigitOctet = d7 == "." && isAllDigitsOrDotsUntilColonOrEnd (drop 8 s) in
243− if contains d4 "789" && isDigitChar d5 && d6 == "."
248+ ((contains d4 "789" && isDigitChar d5 && twoDigitOctet)
244− && isAllDigitsOrDotsUntilColonOrEnd (drop 7 s)
246− else if d4 == "6" && contains d5 "456789" && d6 == "."
249+ || (d4 == "6" && contains d5 "456789" && twoDigitOctet)
247− && isAllDigitsOrDotsUntilColonOrEnd (drop 7 s)
249− else if d4 == "1" && contains d5 "01" && isDigitChar d6 && d7 == "."
250+ || (d4 == "1" && contains d5 "01" && isDigitChar d6 && threeDigitOctet)
250− && isAllDigitsOrDotsUntilColonOrEnd (drop 8 s)
252− else if d4 == "1" && d5 == "2" && contains d6 "01234567" && d7 == "."
251+ || (d4 == "1" && d5 == "2" && contains d6 "01234567" && threeDigitOctet))
253− && isAllDigitsOrDotsUntilColonOrEnd (drop 8 s)
257containsMultipleColons = \s -> count (do c <- chars s; where c == ":"; yield c) > 1
253containsMultipleColons = \s -> count (do c <- chars s; where c == ":"; yield c) > 1
259−hasOctalOctet = \s ->
255+hasPatternAfterDot = \pred s ->
260− if take 1 s == "0" && isDigitChar (take 1 (drop 1 s)) && isAllDigitsOrDotsUntilColonOrEnd (drop 2 s) then True {}
261− else hasOctalOctetAfterDot s
263−hasOctalOctetAfterDot = \s ->
264 if s == "" then False {}
256 if s == "" then False {}
265− else if take 1 s == "." && take 1 (drop 1 s) == "0" && isDigitChar (take 1 (drop 2 s)) && isAllDigitsOrDotsUntilColonOrEnd (drop 3 s) then True {}
257+ else if take 1 s == "." && pred (drop 1 s) then True {}
266− else hasOctalOctetAfterDot (drop 1 s)
258+ else hasPatternAfterDot pred (drop 1 s)
268−hasHexPrefix = \s ->
260+isOctalStart = \s -> take 1 s == "0" && isDigitChar (take 1 (drop 1 s)) && isAllDigitsOrDotsUntilColonOrEnd (drop 2 s)
269− if take 2 s == "0x" || take 2 s == "0X" then True {}
261+hasOctalOctet = \s -> isOctalStart s || hasPatternAfterDot isOctalStart s
270− else hasHexPrefixAfterDot s
272−hasHexPrefixAfterDot = \s ->
273− if s == "" then False {}
274− else if take 1 s == "." && (take 2 (drop 1 s) == "0x" || take 2 (drop 1 s) == "0X") then True {}
263+isHexStart = \s -> take 2 s == "0x" || take 2 s == "0X"
275− else hasHexPrefixAfterDot (drop 1 s)
264+hasHexPrefix = \s -> isHexStart s || hasPatternAfterDot isHexStart s
277isAllDigitsOrDotsUntilColonOrEnd = \s ->
266isAllDigitsOrDotsUntilColonOrEnd = \s ->
278 if s == "" then True {}
267 if s == "" then True {}
@@ -324,18 +313,18 @@ matchesHostname = \sn name ->
324 let nameLen = count (chars name) in
313 let nameLen = count (chars name) in
325 take nameLen sn == name && (drop nameLen sn == "" || take 1 (drop nameLen sn) == ":")
314 take nameLen sn == name && (drop nameLen sn == "" || take 1 (drop nameLen sn) == ":")
316+matchesHostnameOrSubdomain = \sn name ->
317+ matchesHostname sn name || containsSuffix ("." ++ name) sn
327isBadServerName = \sn ->
319isBadServerName = \sn ->
329 || take 1 sn == "."
321 || take 1 sn == "."
330 || take 1 sn == ":"
322 || take 1 sn == ":"
331 || containsBadUrlChar sn
323 || containsBadUrlChar sn
332− || matchesHostname sn "localhost"
324+ || matchesHostnameOrSubdomain sn "localhost"
333 || matchesHostname sn "localhost.localdomain"
325 || matchesHostname sn "localhost.localdomain"
334− || containsSuffix ".localhost" sn
326+ || matchesHostnameOrSubdomain sn "local"
335− || matchesHostname sn "local"
327+ || matchesHostnameOrSubdomain sn "internal"
336− || containsSuffix ".local" sn
337− || matchesHostname sn "internal"
338− || containsSuffix ".internal" sn
339 || matchesHostname sn "metadata"
328 || matchesHostname sn "metadata"
340 || take 4 sn == "127." || take 3 sn == "10."
329 || take 4 sn == "127." || take 3 sn == "10."
341 || take 8 sn == "192.168." || take 8 sn == "169.254."
330 || take 8 sn == "192.168." || take 8 sn == "169.254."
@@ -594,8 +583,8 @@ forEachBatch = \items batchSize process ->
594sendBatchedGossipToServer : ServerName -> [GossipEvent] -> Int -> IO {network} {}
583sendBatchedGossipToServer : ServerName -> [GossipEvent] -> Int -> IO {network} {}
595sendBatchedGossipToServer = \server allEvents hops ->
584sendBatchedGossipToServer = \server allEvents hops ->
596 forEachBatch allEvents maxGossipEvents (\batch -> do
585 forEachBatch allEvents maxGossipEvents (\batch -> do
597− _ <- fetch (federationScheme ++ server) (RecvGossip {
586+ _ <- fetch (federationUrl server) (RecvGossip {
598− authorization: "Bearer " ++ federationSecret,
587+ authorization: federationAuth,
599 events: batch, hopsRemaining: hops, fromServer: serverHostN})
588 events: batch, hopsRemaining: hops, fromServer: serverHostN})
600 yield {})
589 yield {})
@@ -637,10 +626,10 @@ retryForwardsForServer = \entries remaining ->
637 Nothing {} -> yield {}
626 Nothing {} -> yield {}
638 Just {value: f} -> do
627 Just {value: f} -> do
639 let rest = do x <- entries; where x.messageId != f.messageId; yield x
628 let rest = do x <- entries; where x.messageId != f.messageId; yield x
640− result <- fetch (federationScheme ++ f.toServer) (ForwardMessage {
629+ result <- fetch (federationUrl f.toServer) (ForwardMessage {
641 toKey: f.toKey, fromKey: f.fromKey, encryptedBlob: f.encryptedBlob,
630 toKey: f.toKey, fromKey: f.fromKey, encryptedBlob: f.encryptedBlob,
642 timestamp: f.timestamp, originServer: serverHostN, messageId: f.messageId,
631 timestamp: f.timestamp, originServer: serverHostN, messageId: f.messageId,
643− authorization: "Bearer " ++ federationSecret})
632+ authorization: federationAuth})
644 whenOk result (removeForward f.messageId f.toServer)
633 whenOk result (removeForward f.messageId f.toServer)
645 retryForwardsForServer rest (remaining - 1)
634 retryForwardsForServer rest (remaining - 1)
@@ -654,8 +643,8 @@ retryPendingForwards = \pending -> do
654sendBatchedAcksToServer : [{messageId: MessageIdHex, toKey: PubkeyHex, originServer: ServerName, | a}] -> ServerName -> IO {network} {}
643sendBatchedAcksToServer : [{messageId: MessageIdHex, toKey: PubkeyHex, originServer: ServerName, | a}] -> ServerName -> IO {network} {}
655sendBatchedAcksToServer = \serverAcks server ->
644sendBatchedAcksToServer = \serverAcks server ->
656 forEachBatch serverAcks maxMessageIds (\batch -> do
645 forEachBatch serverAcks maxMessageIds (\batch -> do
657− result <- fetch (federationScheme ++ server) (FederationAck {
646+ result <- fetch (federationUrl server) (FederationAck {
658− authorization: "Bearer " ++ federationSecret,
647+ authorization: federationAuth,
659 messageIds: (do a <- batch; yield a.messageId),
648 messageIds: (do a <- batch; yield a.messageId),
660 originServer: server, fromServer: serverHostN})
649 originServer: server, fromServer: serverHostN})
661 whenOk result (atomic do
650 whenOk result (atomic do
@@ -679,8 +668,8 @@ retryEvictedAcks = \evictedEntries pendingAcks ->
680 let evictedOriginServers = collectPeerServers evictedToRetry (\a -> a.originServer)
669 let evictedOriginServers = collectPeerServers evictedToRetry (\a -> a.originServer)
681 sendToEach evictedOriginServers (\server -> do
670 sendToEach evictedOriginServers (\server -> do
682− fetchResult <- fetch (federationScheme ++ server) (FederationAck {
671+ fetchResult <- fetch (federationUrl server) (FederationAck {
683− authorization: "Bearer " ++ federationSecret,
672+ authorization: federationAuth,
684 messageIds: (do a <- evictedToRetry; where a.originServer == server; yield a.messageId),
673 messageIds: (do a <- evictedToRetry; where a.originServer == server; yield a.messageId),
685 originServer: server, fromServer: serverHostN})
674 originServer: server, fromServer: serverHostN})
686 case fetchResult of
675 case fetchResult of
@@ -737,6 +726,7 @@ pollOnce = \token cursor -> do
737 let lastReceivedAt = fold (\acc m -> max acc m.receivedAt) clampedCursor limitedMsgs
726 let lastReceivedAt = fold (\acc m -> max acc m.receivedAt) clampedCursor limitedMsgs
738 yield PollDone {events: evts, cursor: lastReceivedAt}
727 yield PollDone {events: evts, cursor: lastReceivedAt}
729+pollLoop : Text -> Int -> Int<Ms> -> IO {clock} PollResult
740pollLoop = \token cursor deadline -> do
730pollLoop = \token cursor deadline -> do
741 result <- pollOnce token cursor
731 result <- pollOnce token cursor
742 case result of
732 case result of
@@ -864,15 +854,16 @@ serve = \req -> case req of
864 SendDone {status, remoteServers, fromKey} ->
854 SendDone {status, remoteServers, fromKey} ->
865 when (count remoteServers > 0 && federationEnabled) (do
855 when (count remoteServers > 0 && federationEnabled) (do
866 sendToEach remoteServers (\server -> do
856 sendToEach remoteServers (\server -> do
867− fwdResult <- fetch (federationScheme ++ server) (ForwardMessage {
857+ fwdResult <- fetch (federationUrl server) (ForwardMessage {
868 toKey: to, fromKey: fromKey, encryptedBlob: encryptedBlob,
858 toKey: to, fromKey: fromKey, encryptedBlob: encryptedBlob,
869 timestamp: clampedTs, originServer: serverHostN, messageId: msgId,
859 timestamp: clampedTs, originServer: serverHostN, messageId: msgId,
870− authorization: "Bearer " ++ federationSecret})
860+ authorization: federationAuth})
871 whenOk fwdResult (removeForward msgId server))
861 whenOk fwdResult (removeForward msgId server))
872 case status of
862 case status of
873 MsQueued {} -> println ("sendMessage: forwards at capacity (" ++ show maxForwardsEntries ++ "), skipping forward tracking")
863 MsQueued {} -> println ("sendMessage: forwards at capacity (" ++ show maxForwardsEntries ++ "), skipping forward tracking")
874 _ -> yield {})
864 _ -> yield {})
865+ SendUnauthorized {} -> yield {}
875− _ -> yield {}
866+ SendRejected {} -> yield {}
876 broadcastOfflineGossip t result.pr.peerServers result.pr.expiredLocal)
867 broadcastOfflineGossip t result.pr.peerServers result.pr.expiredLocal)
877 yield (case result.send of
868 yield (case result.send of
878 SendUnauthorized {} -> respond {status: MsUnauthorized {}, messageId: ""}
869 SendUnauthorized {} -> respond {status: MsUnauthorized {}, messageId: ""}
@@ -912,9 +903,9 @@ serve = \req -> case req of
912 when federationEnabled (do
903 when federationEnabled (do
913 sendAcksAndClean pendingAcks
904 sendAcksAndClean pendingAcks
914 retryEvictedAcks evictedEntries pendingAcks)
905 retryEvictedAcks evictedEntries pendingAcks)
915− _ -> yield {}
906+ AckUnauthorized {} -> yield {}
916 broadcastOfflineGossip t result.pr.peerServers result.pr.expiredLocal)
907 broadcastOfflineGossip t result.pr.peerServers result.pr.expiredLocal)
917− yield (respond {ok: case result.ack of AckDone _ -> True {}; _ -> False {}})
908+ yield (respond {ok: case result.ack of AckDone _ -> True {}; AckUnauthorized {} -> False {}})
919 LookupPresence {pubkey, authorization, respond} -> do
910 LookupPresence {pubkey, authorization, respond} -> do
@@ -990,8 +981,7 @@ serve = \req -> case req of
990 ForwardMessage {toKey, fromKey, encryptedBlob, timestamp, originServer, messageId, authorization, respond} -> do
981 ForwardMessage {toKey, fromKey, encryptedBlob, timestamp, originServer, messageId, authorization, respond} -> do
992 let authorized = verifyFederationAuth authorization
983 let authorized = verifyFederationAuth authorization
993− let validOrigin = originServer != serverHostN
994− if not authorized || not validOrigin
984+ if not authorized || originServer == serverHostN
995 then rejectFederation t respond
985 then rejectFederation t respond
997 let clampedTs = clampTimestamp timestamp t
987 let clampedTs = clampTimestamp timestamp t
@@ -1013,7 +1003,7 @@ serve = \req -> case req of
1013 encryptedBlob: encryptedBlob, timestamp: clampedTs, origin: FederatedOrigin {server: originServer}, receivedAt: seqTs}]
1003 encryptedBlob: encryptedBlob, timestamp: clampedTs, origin: FederatedOrigin {server: originServer}, receivedAt: seqTs}]
1014 yield {pr: pr, forward: ForwardStored {}}
1004 yield {pr: pr, forward: ForwardStored {}}
1015 forkBroadcastOffline t result.pr
1005 forkBroadcastOffline t result.pr
1016− yield (respond {ok: case result.forward of ForwardFull {} -> False {}; _ -> True {}})
1006+ yield (respond {ok: case result.forward of ForwardDuplicate {} -> True {}; ForwardStored {} -> True {}; ForwardFull {} -> False {}})
1018 FederationAck {messageIds, originServer, fromServer, authorization, respond} -> do
1008 FederationAck {messageIds, originServer, fromServer, authorization, respond} -> do
1019 t <- now
1009 t <- now