@@ -267,6 +267,16 @@ containsLocalhostSuffix = \s ->
267 else if take 10 s == ".localhost" && (drop 10 s == "" || take 1 (drop 10 s) == ":") then True {}
267 else if take 10 s == ".localhost" && (drop 10 s == "" || take 1 (drop 10 s) == ":") then True {}
268 else containsLocalhostSuffix (drop 1 s)
268 else containsLocalhostSuffix (drop 1 s)
270+containsLocalSuffix = \s ->
271+ if s == "" then False {}
272+ else if take 6 s == ".local" && (drop 6 s == "" || take 1 (drop 6 s) == ":") then True {}
273+ else containsLocalSuffix (drop 1 s)
275+containsInternalSuffix = \s ->
276+ if s == "" then False {}
277+ else if take 9 s == ".internal" && (drop 9 s == "" || take 1 (drop 9 s) == ":") then True {}
278+ else containsInternalSuffix (drop 1 s)
270isBadServerName = \s ->
280isBadServerName = \s ->
271 let sn = toLower (stripTrailingDot s)
281 let sn = toLower (stripTrailingDot s)
@@ -276,6 +286,9 @@ isBadServerName = \s ->
276 || sn == "localhost" || take 10 sn == "localhost:"
286 || sn == "localhost" || take 10 sn == "localhost:"
277 || sn == "localhost.localdomain" || take 22 sn == "localhost.localdomain:"
287 || sn == "localhost.localdomain" || take 22 sn == "localhost.localdomain:"
278 || containsLocalhostSuffix sn
288 || containsLocalhostSuffix sn
289+ || containsLocalSuffix sn
290+ || containsInternalSuffix sn
291+ || sn == "metadata" || take 9 sn == "metadata:"
279 || take 4 sn == "127." || take 3 sn == "10."
292 || take 4 sn == "127." || take 3 sn == "10."
280 || take 8 sn == "192.168." || take 7 sn == "169.254."
293 || take 8 sn == "192.168." || take 7 sn == "169.254."
281 || take 2 sn == "0." || take 1 sn == "["
294 || take 2 sn == "0." || take 1 sn == "["
@@ -365,8 +378,8 @@ evictOldestAckedIds = \items n ->
365 in diff items toEvict
378 in diff items toEvict
367safeCompareLoop = \s1 s2 n result ->
380safeCompareLoop = \s1 s2 n result ->
368− if n <= 0
381+ if n <= 0 && s1 == "" && s2 == ""
369− then result + (if s1 == "" then 0 else 1) + (if s2 == "" then 0 else 1)
382+ then result
370 else safeCompareLoop (drop 1 s1) (drop 1 s2) (n - 1) (result + (if take 1 s1 == take 1 s2 then 0 else 1))
383 else safeCompareLoop (drop 1 s1) (drop 1 s2) (n - 1) (result + (if take 1 s1 == take 1 s2 then 0 else 1))
372safeCompare = \a b ->
385safeCompare = \a b ->
@@ -945,7 +958,7 @@ serve = \req -> case req of
946 let authorized = verifyFederationAuth authorization
959 let authorized = verifyFederationAuth authorization
947 let cappedHops = if hopsRemaining > 5 then 5 else hopsRemaining
960 let cappedHops = if hopsRemaining > 5 then 5 else hopsRemaining
948− let fromServer = normalizeServerName fromServer
961+ let fromServer = if tooLong fromServer maxServerNameLen then fromServer else normalizeServerName fromServer
949 let validRequest = authorized && cappedHops >= 1 && not (fromServer == "") && not (fromServer == serverHostN) && not (tooLong fromServer maxServerNameLen) && not (isBadServerName fromServer) && count events <= maxGossipEvents
962 let validRequest = authorized && cappedHops >= 1 && not (fromServer == "") && not (fromServer == serverHostN) && not (tooLong fromServer maxServerNameLen) && not (isBadServerName fromServer) && count events <= maxGossipEvents
950 let onlineEntries = do
963 let onlineEntries = do
951 e <- events
964 e <- events
@@ -1191,7 +1204,7 @@ serve = \req -> case req of
1191 let fromKey = if isValidHex fromKey then normalizeHex fromKey else fromKey
1204 let fromKey = if isValidHex fromKey then normalizeHex fromKey else fromKey
1192 let encryptedBlob = if isValidHex encryptedBlob then normalizeHex encryptedBlob else encryptedBlob
1205 let encryptedBlob = if isValidHex encryptedBlob then normalizeHex encryptedBlob else encryptedBlob
1193 let messageId = if isValidHex messageId then normalizeHex messageId else messageId
1206 let messageId = if isValidHex messageId then normalizeHex messageId else messageId
1194− let originServer = normalizeServerName originServer
1207+ let originServer = if tooLong originServer maxServerNameLen then originServer else normalizeServerName originServer
1195 t <- now
1208 t <- now
1196 let authorized = verifyFederationAuth authorization
1209 let authorized = verifyFederationAuth authorization
1197 let validOrigin = not (originServer == "") && not (originServer == serverHostN) && not (tooLong originServer maxServerNameLen) && not (isBadServerName originServer)
1210 let validOrigin = not (originServer == "") && not (originServer == serverHostN) && not (tooLong originServer maxServerNameLen) && not (isBadServerName originServer)
@@ -1233,8 +1246,8 @@ serve = \req -> case req of
1233 broadcastOfflineGossip t result.peerServers result.expiredLocal
1246 broadcastOfflineGossip t result.peerServers result.expiredLocal
1235 FederationAck {messageIds, originServer, fromServer, authorization, respond} -> do
1248 FederationAck {messageIds, originServer, fromServer, authorization, respond} -> do
1236− let fromServer = normalizeServerName fromServer
1249+ let fromServer = if tooLong fromServer maxServerNameLen then fromServer else normalizeServerName fromServer
1237− let originServer = normalizeServerName originServer
1250+ let originServer = if tooLong originServer maxServerNameLen then originServer else normalizeServerName originServer
1238 t <- now
1251 t <- now
1239 let authorized = verifyFederationAuth authorization
1252 let authorized = verifyFederationAuth authorization
1240 let dedupedIds = fold (\acc mid ->
1253 let dedupedIds = fold (\acc mid ->
@@ -1335,7 +1348,7 @@ backgroundPrune = do
1335 else yield {}) (\err ->
1348 else yield {}) (\err ->
1336 println ("background prune: ack send failed: " ++ show err))) (\err ->
1349 println ("background prune: ack send failed: " ++ show err))) (\err ->
1337 println ("background prune: " ++ show err))
1350 println ("background prune: " ++ show err))
1338− backgroundPrune
1351+ spawn backgroundPrune
1340main = do
1353main = do
1341 println "Skrepka relay server starting on port 8080..."
1354 println "Skrepka relay server starting on port 8080..."