@@ -43,6 +43,8 @@ offlineGossipMinTtl : Int<S>
4343offlineGossipMinTtl = 60 -- minimum TTL for offline gossip events
4444maxForwardRetriesPerServer = 100
4545federationEnabled = federationSecret != ""
46+federationAuth = "Bearer " ++ federationSecret
47+federationUrl = \server -> federationScheme ++ server
4648
4749-- ============================================
4850-- Types
@@ -84,10 +86,11 @@ impl ToJSON MessageStatus where
8486 MsUnauthorized {} -> "unauthorized"
8587 MsRejected {} -> "rejected")
8688
87−type PubkeyHex = Text where \s -> isValidHex s && not (tooLong s maxPubkeyLen) && s == normalizeHex s
88−type BlobHex = Text where \s -> isValidHex s && not (tooLong s maxBlobLen) && s == normalizeHex s
89−type SignatureHex = Text where \s -> isValidHex s && not (tooLong s maxSignatureLen) && s == normalizeHex s
90−isValidMessageId = \s -> isValidHex s && not (tooLong s maxMessageIdLen) && s == normalizeHex s
89+isValidBoundedHex = \maxLen s -> isValidHex s && not (tooLong s maxLen) && s == normalizeHex s
90+type PubkeyHex = Text where isValidBoundedHex maxPubkeyLen
91+type BlobHex = Text where isValidBoundedHex maxBlobLen
92+type SignatureHex = Text where isValidBoundedHex maxSignatureLen
93+isValidMessageId = isValidBoundedHex maxMessageIdLen
9194type MessageIdHex = Text where isValidMessageId
9295type OptionalMessageId = Text where \s -> s == "" || isValidMessageId s
9396isValidServerName = \s -> not (tooLong s maxServerNameLen) && s == normalizeServerName s && not (isBadServerName s)
@@ -235,44 +238,30 @@ isAllowedServerChar = \c -> contains c "0123456789abcdefghijklmnopqrstuvwxyz-.:"
235238containsBadUrlChar = \s -> any (chars s) (\c -> not (isAllowedServerChar c))
236239
237240isCgnatRange = \s ->
238− if take 4 s != "100." then False {}
239− else let d4 = take 1 (drop 4 s) in
241+ take 4 s == "100."
242+ && let d4 = take 1 (drop 4 s) in
240243 let d5 = take 1 (drop 5 s) in
241244 let d6 = take 1 (drop 6 s) in
242245 let d7 = take 1 (drop 7 s) in
243− if contains d4 "789" && isDigitChar d5 && d6 == "."
244− && isAllDigitsOrDotsUntilColonOrEnd (drop 7 s)
245− then True {}
246− else if d4 == "6" && contains d5 "456789" && d6 == "."
247− && isAllDigitsOrDotsUntilColonOrEnd (drop 7 s)
248− then True {}
249− else if d4 == "1" && contains d5 "01" && isDigitChar d6 && d7 == "."
250− && isAllDigitsOrDotsUntilColonOrEnd (drop 8 s)
251− then True {}
252− else if d4 == "1" && d5 == "2" && contains d6 "01234567" && d7 == "."
253− && isAllDigitsOrDotsUntilColonOrEnd (drop 8 s)
254− then True {}
255− else False {}
246+ let twoDigitOctet = d6 == "." && isAllDigitsOrDotsUntilColonOrEnd (drop 7 s) in
247+ let threeDigitOctet = d7 == "." && isAllDigitsOrDotsUntilColonOrEnd (drop 8 s) in
248+ ((contains d4 "789" && isDigitChar d5 && twoDigitOctet)
249+ || (d4 == "6" && contains d5 "456789" && twoDigitOctet)
250+ || (d4 == "1" && contains d5 "01" && isDigitChar d6 && threeDigitOctet)
251+ || (d4 == "1" && d5 == "2" && contains d6 "01234567" && threeDigitOctet))
256252
257253containsMultipleColons = \s -> count (do c <- chars s; where c == ":"; yield c) > 1
258254
259−hasOctalOctet = \s ->
260− if take 1 s == "0" && isDigitChar (take 1 (drop 1 s)) && isAllDigitsOrDotsUntilColonOrEnd (drop 2 s) then True {}
261− else hasOctalOctetAfterDot s
262−
263−hasOctalOctetAfterDot = \s ->
255+hasPatternAfterDot = \pred s ->
264256 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 {}
266− else hasOctalOctetAfterDot (drop 1 s)
257+ else if take 1 s == "." && pred (drop 1 s) then True {}
258+ else hasPatternAfterDot pred (drop 1 s)
267259
268−hasHexPrefix = \s ->
269− if take 2 s == "0x" || take 2 s == "0X" then True {}
270− else hasHexPrefixAfterDot s
260+isOctalStart = \s -> take 1 s == "0" && isDigitChar (take 1 (drop 1 s)) && isAllDigitsOrDotsUntilColonOrEnd (drop 2 s)
261+hasOctalOctet = \s -> isOctalStart s || hasPatternAfterDot isOctalStart s
271262
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 {}
275− else hasHexPrefixAfterDot (drop 1 s)
263+isHexStart = \s -> take 2 s == "0x" || take 2 s == "0X"
264+hasHexPrefix = \s -> isHexStart s || hasPatternAfterDot isHexStart s
276265
277266isAllDigitsOrDotsUntilColonOrEnd = \s ->
278267 if s == "" then True {}
@@ -324,18 +313,18 @@ matchesHostname = \sn name ->
324313 let nameLen = count (chars name) in
325314 take nameLen sn == name && (drop nameLen sn == "" || take 1 (drop nameLen sn) == ":")
326315
316+matchesHostnameOrSubdomain = \sn name ->
317+ matchesHostname sn name || containsSuffix ("." ++ name) sn
318+
327319isBadServerName = \sn ->
328320 sn == ""
329321 || take 1 sn == "."
330322 || take 1 sn == ":"
331323 || containsBadUrlChar sn
332− || matchesHostname sn "localhost"
324+ || matchesHostnameOrSubdomain sn "localhost"
333325 || matchesHostname sn "localhost.localdomain"
334− || containsSuffix ".localhost" sn
335− || matchesHostname sn "local"
336− || containsSuffix ".local" sn
337− || matchesHostname sn "internal"
338− || containsSuffix ".internal" sn
326+ || matchesHostnameOrSubdomain sn "local"
327+ || matchesHostnameOrSubdomain sn "internal"
339328 || matchesHostname sn "metadata"
340329 || take 4 sn == "127." || take 3 sn == "10."
341330 || take 8 sn == "192.168." || take 8 sn == "169.254."
@@ -594,8 +583,8 @@ forEachBatch = \items batchSize process ->
594583sendBatchedGossipToServer : ServerName -> [GossipEvent] -> Int -> IO {network} {}
595584sendBatchedGossipToServer = \server allEvents hops ->
596585 forEachBatch allEvents maxGossipEvents (\batch -> do
597− _ <- fetch (federationScheme ++ server) (RecvGossip {
598− authorization: "Bearer " ++ federationSecret,
586+ _ <- fetch (federationUrl server) (RecvGossip {
587+ authorization: federationAuth,
599588 events: batch, hopsRemaining: hops, fromServer: serverHostN})
600589 yield {})
601590
@@ -637,10 +626,10 @@ retryForwardsForServer = \entries remaining ->
637626 Nothing {} -> yield {}
638627 Just {value: f} -> do
639628 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 {
641630 toKey: f.toKey, fromKey: f.fromKey, encryptedBlob: f.encryptedBlob,
642631 timestamp: f.timestamp, originServer: serverHostN, messageId: f.messageId,
643− authorization: "Bearer " ++ federationSecret})
632+ authorization: federationAuth})
644633 whenOk result (removeForward f.messageId f.toServer)
645634 retryForwardsForServer rest (remaining - 1)
646635
@@ -654,8 +643,8 @@ retryPendingForwards = \pending -> do
654643sendBatchedAcksToServer : [{messageId: MessageIdHex, toKey: PubkeyHex, originServer: ServerName, | a}] -> ServerName -> IO {network} {}
655644sendBatchedAcksToServer = \serverAcks server ->
656645 forEachBatch serverAcks maxMessageIds (\batch -> do
657− result <- fetch (federationScheme ++ server) (FederationAck {
658− authorization: "Bearer " ++ federationSecret,
646+ result <- fetch (federationUrl server) (FederationAck {
647+ authorization: federationAuth,
659648 messageIds: (do a <- batch; yield a.messageId),
660649 originServer: server, fromServer: serverHostN})
661650 whenOk result (atomic do
@@ -679,8 +668,8 @@ retryEvictedAcks = \evictedEntries pendingAcks ->
679668 in do
680669 let evictedOriginServers = collectPeerServers evictedToRetry (\a -> a.originServer)
681670 sendToEach evictedOriginServers (\server -> do
682− fetchResult <- fetch (federationScheme ++ server) (FederationAck {
683− authorization: "Bearer " ++ federationSecret,
671+ fetchResult <- fetch (federationUrl server) (FederationAck {
672+ authorization: federationAuth,
684673 messageIds: (do a <- evictedToRetry; where a.originServer == server; yield a.messageId),
685674 originServer: server, fromServer: serverHostN})
686675 case fetchResult of
@@ -737,6 +726,7 @@ pollOnce = \token cursor -> do
737726 let lastReceivedAt = fold (\acc m -> max acc m.receivedAt) clampedCursor limitedMsgs
738727 yield PollDone {events: evts, cursor: lastReceivedAt}
739728
729+pollLoop : Text -> Int -> Int<Ms> -> IO {clock} PollResult
740730pollLoop = \token cursor deadline -> do
741731 result <- pollOnce token cursor
742732 case result of
@@ -864,15 +854,16 @@ serve = \req -> case req of
864854 SendDone {status, remoteServers, fromKey} ->
865855 when (count remoteServers > 0 && federationEnabled) (do
866856 sendToEach remoteServers (\server -> do
867− fwdResult <- fetch (federationScheme ++ server) (ForwardMessage {
857+ fwdResult <- fetch (federationUrl server) (ForwardMessage {
868858 toKey: to, fromKey: fromKey, encryptedBlob: encryptedBlob,
869859 timestamp: clampedTs, originServer: serverHostN, messageId: msgId,
870− authorization: "Bearer " ++ federationSecret})
860+ authorization: federationAuth})
871861 whenOk fwdResult (removeForward msgId server))
872862 case status of
873863 MsQueued {} -> println ("sendMessage: forwards at capacity (" ++ show maxForwardsEntries ++ "), skipping forward tracking")
874864 _ -> yield {})
875− _ -> yield {}
865+ SendUnauthorized {} -> yield {}
866+ SendRejected {} -> yield {}
876867 broadcastOfflineGossip t result.pr.peerServers result.pr.expiredLocal)
877868 yield (case result.send of
878869 SendUnauthorized {} -> respond {status: MsUnauthorized {}, messageId: ""}
@@ -912,9 +903,9 @@ serve = \req -> case req of
912903 when federationEnabled (do
913904 sendAcksAndClean pendingAcks
914905 retryEvictedAcks evictedEntries pendingAcks)
915− _ -> yield {}
906+ AckUnauthorized {} -> yield {}
916907 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 {}})
918909
919910 LookupPresence {pubkey, authorization, respond} -> do
920911 t <- now
@@ -990,8 +981,7 @@ serve = \req -> case req of
990981 ForwardMessage {toKey, fromKey, encryptedBlob, timestamp, originServer, messageId, authorization, respond} -> do
991982 t <- now
992983 let authorized = verifyFederationAuth authorization
993− let validOrigin = originServer != serverHostN
994− if not authorized || not validOrigin
984+ if not authorized || originServer == serverHostN
995985 then rejectFederation t respond
996986 else do
997987 let clampedTs = clampTimestamp timestamp t
@@ -1013,7 +1003,7 @@ serve = \req -> case req of
10131003 encryptedBlob: encryptedBlob, timestamp: clampedTs, origin: FederatedOrigin {server: originServer}, receivedAt: seqTs}]
10141004 yield {pr: pr, forward: ForwardStored {}}
10151005 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 {}})
10171007
10181008 FederationAck {messageIds, originServer, fromServer, authorization, respond} -> do
10191009 t <- now