diff --git a/apps/simplex-store-service/src/StoreService/Names/Profiles.hs b/apps/simplex-store-service/src/StoreService/Names/Profiles.hs index b1724050fd..7261cf7dad 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Profiles.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Profiles.hs @@ -277,7 +277,7 @@ publicAddress = \case THIPv6 a -> publicIPv6 a _ -> False --- | Unspecified ("this network"), private, CGNAT, loopback, link-local and multicast. +-- | Unspecified ("this network"), private, CGNAT, loopback, link-local, benchmarking, multicast and reserved with broadcast. refusedIPv4 :: [(Word32, Int)] refusedIPv4 = [ (ipv4Word (0, 0, 0, 0), 8), @@ -287,24 +287,31 @@ refusedIPv4 = (ipv4Word (169, 254, 0, 0), 16), (ipv4Word (172, 16, 0, 0), 12), (ipv4Word (192, 168, 0, 0), 16), - (ipv4Word (224, 0, 0, 0), 4) + (ipv4Word (198, 18, 0, 0), 15), + (ipv4Word (224, 0, 0, 0), 4), + (ipv4Word (240, 0, 0, 0), 4) ] --- | Unique-local, link-local and multicast, as prefixes of the address's first 32 bits. +-- | Unique-local, link-local, site-local and multicast, as prefixes of the address's first 32 bits. refusedIPv6 :: [(Word32, Int)] -refusedIPv6 = [(0xfc000000, 7), (0xfe800000, 10), (0xff000000, 8)] +refusedIPv6 = [(0xfc000000, 7), (0xfe800000, 10), (0xfec00000, 10), (0xff000000, 8)] -- | The third 32-bit word of an IPv4-mapped IPv6 address, @::ffff:a.b.c.d@. ipv4MappedWord :: Word32 ipv4MappedWord = 0xffff +-- | The first 32-bit word of the NAT64 prefix @64:ff9b::/96@. +nat64Word :: Word32 +nat64Word = 0x0064ff9b + publicIPv4 :: Word32 -> Bool publicIPv4 a = not $ any (inPrefix a) refusedIPv4 +-- | An address that carries an IPv4 address in its last 32 bits is judged by it: IPv4-mapped, IPv4-compatible (with @::@ and @::1@) and NAT64. publicIPv6 :: (Word32, Word32, Word32, Word32) -> Bool publicIPv6 (w0, w1, w2, w3) - | w0 == 0 && w1 == 0 && w2 == ipv4MappedWord = publicIPv4 w3 - | w0 == 0 && w1 == 0 && w2 == 0 && w3 <= 1 = False + | w0 == 0 && w1 == 0 && (w2 == ipv4MappedWord || w2 == 0) = publicIPv4 w3 + | w0 == nat64Word && w1 == 0 && w2 == 0 = publicIPv4 w3 | otherwise = not $ any (inPrefix w0) refusedIPv6 inPrefix :: Word32 -> (Word32, Int) -> Bool diff --git a/tests/Bots/StoreService/NamesProfilesTests.hs b/tests/Bots/StoreService/NamesProfilesTests.hs index be0f1948e7..5c4e93c723 100644 --- a/tests/Bots/StoreService/NamesProfilesTests.hs +++ b/tests/Bots/StoreService/NamesProfilesTests.hs @@ -70,6 +70,7 @@ namesProfilesTests = describe "StoreService names: profiles" $ do H.it "refuses private, loopback, CGNAT, link-local and unique-local literals" testPrivateLiterals H.it "refuses names resolving to those addresses" testPrivateNames H.it "refuses unspecified, multicast and IPv4-mapped private addresses" testOtherRefused + H.it "refuses reserved, broadcast, benchmarking and site-local addresses, and private IPv4 in IPv4-compatible and NAT64 addresses" testEmbeddedAndReserved H.it "refuses .onion hosts without resolving them, and unresolvable names" testOnionUnresolvable H.it "refuses a link with one public and one private host, and a name with one private address" testMixedHosts H.it "answers a refused link unavailable without fetching it" testRefusedNotFetched @@ -418,6 +419,17 @@ testOtherRefused = do mapM_ (\h -> (h,) <$> fetchable [h] `shouldReturn` (h, False)) ["0.0.0.0", "::", "224.0.0.1", "ff02::1", mapped (127, 0, 0, 1), mapped (10, 0, 0, 1)] fetchable [mapped (1, 1, 1, 1)] `shouldReturn` True +testEmbeddedAndReserved :: IO () +testEmbeddedAndReserved = do + mapM_ (\h -> (h,) <$> fetchable [h] `shouldReturn` (h, False)) $ + ["240.0.0.1", "255.255.255.255", "198.18.0.1", "198.19.255.254", "fec0::1"] + <> map compatible [(127, 0, 0, 1), (10, 0, 0, 1)] + <> map nat64 [(127, 0, 0, 1), (192, 168, 1, 1), (100, 64, 0, 1)] + mapM_ (\h -> (h,) <$> fetchable [h] `shouldReturn` (h, True)) ["198.20.0.1", "198.17.255.255", compatible (1, 1, 1, 1), nat64 (1, 1, 1, 1)] + where + compatible = THIPv6 . (0, 0, 0,) . ipv4 + nat64 = THIPv6 . (0x0064ff9b, 0, 0,) . ipv4 + testOnionUnresolvable :: IO () testOnionUnresolvable = do asked <- newTVarIO [] @@ -429,7 +441,10 @@ testOnionUnresolvable = do -- | An IPv4-mapped IPv6 address, @::ffff:a.b.c.d@. mapped :: (Word32, Word32, Word32, Word32) -> TransportHost -mapped (a, b, c, d) = THIPv6 (0, 0, 0xffff, a * 0x1000000 + b * 0x10000 + c * 0x100 + d) +mapped = THIPv6 . (0, 0, 0xffff,) . ipv4 + +ipv4 :: (Word32, Word32, Word32, Word32) -> Word32 +ipv4 (a, b, c, d) = a * 0x1000000 + b * 0x10000 + c * 0x100 + d testMixedHosts :: IO () testMixedHosts = do