-- | Multiaddr: self-describing, composable network addresses.
--
-- A multiaddr is a binary-encoded, composable network address that describes
-- the entire protocol stack needed to reach a peer.
module LibP2P.Multiaddr
  ( Multiaddr (..)
  , fromText
  , toText
  , fromBytes
  , toBytes
  , encapsulate
  , decapsulate
  , protocols
  , splitP2P
  , isPublicAddr
  , isRelayedAddr
  ) where

import Data.Bits (shiftL, (.&.))
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.List (isSuffixOf)
import qualified Data.Text as T
import Data.Word (Word32, Word8)
import Data.List (isPrefixOf, tails)
import Data.Text (Text)
import LibP2P.Crypto.PeerId (PeerId (..))
import LibP2P.Multiaddr.Codec
  ( decodeProtocols
  , encodeProtocols
  , protocolsToText
  , textToProtocols
  )
import LibP2P.Multiaddr.Protocol (Protocol (..))

-- | A multiaddr is a list of protocol components.
newtype Multiaddr = Multiaddr [Protocol]
  deriving (Int -> Multiaddr -> ShowS
[Multiaddr] -> ShowS
Multiaddr -> String
(Int -> Multiaddr -> ShowS)
-> (Multiaddr -> String)
-> ([Multiaddr] -> ShowS)
-> Show Multiaddr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Multiaddr -> ShowS
showsPrec :: Int -> Multiaddr -> ShowS
$cshow :: Multiaddr -> String
show :: Multiaddr -> String
$cshowList :: [Multiaddr] -> ShowS
showList :: [Multiaddr] -> ShowS
Show, Multiaddr -> Multiaddr -> Bool
(Multiaddr -> Multiaddr -> Bool)
-> (Multiaddr -> Multiaddr -> Bool) -> Eq Multiaddr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Multiaddr -> Multiaddr -> Bool
== :: Multiaddr -> Multiaddr -> Bool
$c/= :: Multiaddr -> Multiaddr -> Bool
/= :: Multiaddr -> Multiaddr -> Bool
Eq)

-- | Parse a multiaddr from its text representation (e.g. "/ip4/127.0.0.1/tcp/4001").
fromText :: Text -> Either String Multiaddr
fromText :: Text -> Either String Multiaddr
fromText Text
t = [Protocol] -> Multiaddr
Multiaddr ([Protocol] -> Multiaddr)
-> Either String [Protocol] -> Either String Multiaddr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either String [Protocol]
textToProtocols Text
t

-- | Render a multiaddr as text.
toText :: Multiaddr -> Text
toText :: Multiaddr -> Text
toText (Multiaddr [Protocol]
ps) = [Protocol] -> Text
protocolsToText [Protocol]
ps

-- | Parse a multiaddr from binary format.
fromBytes :: ByteString -> Either String Multiaddr
fromBytes :: ByteString -> Either String Multiaddr
fromBytes ByteString
bs = [Protocol] -> Multiaddr
Multiaddr ([Protocol] -> Multiaddr)
-> Either String [Protocol] -> Either String Multiaddr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String [Protocol]
decodeProtocols ByteString
bs

-- | Encode a multiaddr to binary format.
toBytes :: Multiaddr -> ByteString
toBytes :: Multiaddr -> ByteString
toBytes (Multiaddr [Protocol]
ps) = [Protocol] -> ByteString
encodeProtocols [Protocol]
ps

-- | Encapsulate: append another multiaddr's protocols.
encapsulate :: Multiaddr -> Multiaddr -> Multiaddr
encapsulate :: Multiaddr -> Multiaddr -> Multiaddr
encapsulate (Multiaddr [Protocol]
a) (Multiaddr [Protocol]
b) = [Protocol] -> Multiaddr
Multiaddr ([Protocol]
a [Protocol] -> [Protocol] -> [Protocol]
forall a. Semigroup a => a -> a -> a
<> [Protocol]
b)

-- | Decapsulate: remove the last occurrence of the given suffix multiaddr
-- and everything after it (specs/addressing). Returns the original
-- multiaddr unchanged when the suffix does not occur. Decapsulating the
-- empty multiaddr is a no-op, making 'decapsulate' a left inverse of
-- 'encapsulate': @decapsulate (encapsulate a b) b == a@ for non-empty b.
decapsulate :: Multiaddr -> Multiaddr -> Multiaddr
decapsulate :: Multiaddr -> Multiaddr -> Multiaddr
decapsulate ma :: Multiaddr
ma@(Multiaddr [Protocol]
a) (Multiaddr [Protocol]
b)
  | [Protocol] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Protocol]
b = Multiaddr
ma
  | Bool
otherwise =
      case [Int
i | (Int
i, [Protocol]
suffix) <- [Int] -> [[Protocol]] -> [(Int, [Protocol])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] ([Protocol] -> [[Protocol]]
forall a. [a] -> [[a]]
tails [Protocol]
a), [Protocol]
b [Protocol] -> [Protocol] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Protocol]
suffix] of
        [] -> Multiaddr
ma
        [Int]
matches -> [Protocol] -> Multiaddr
Multiaddr (Int -> [Protocol] -> [Protocol]
forall a. Int -> [a] -> [a]
take ([Int] -> Int
forall a. HasCallStack => [a] -> a
last [Int]
matches) [Protocol]
a)

-- | Get the list of protocols in a multiaddr.
protocols :: Multiaddr -> [Protocol]
protocols :: Multiaddr -> [Protocol]
protocols (Multiaddr [Protocol]
ps) = [Protocol]
ps

-- | Split off the trailing /p2p/<peerId> component from a multiaddr.
-- Returns the transport address and the peer ID, or Nothing if the
-- multiaddr does not end with a /p2p/ component.
splitP2P :: Multiaddr -> Maybe (Multiaddr, PeerId)
splitP2P :: Multiaddr -> Maybe (Multiaddr, PeerId)
splitP2P (Multiaddr [Protocol]
ps) = case [Protocol] -> [Protocol]
forall a. [a] -> [a]
reverse [Protocol]
ps of
  (P2P ByteString
mhBytes : [Protocol]
rest) -> (Multiaddr, PeerId) -> Maybe (Multiaddr, PeerId)
forall a. a -> Maybe a
Just ([Protocol] -> Multiaddr
Multiaddr ([Protocol] -> [Protocol]
forall a. [a] -> [a]
reverse [Protocol]
rest), ByteString -> PeerId
PeerId ByteString
mhBytes)
  [Protocol]
_ -> Maybe (Multiaddr, PeerId)
forall a. Maybe a
Nothing

-- Address classification

-- | Whether the address goes through a circuit relay, i.e. contains a
-- @/p2p-circuit@ component.
isRelayedAddr :: Multiaddr -> Bool
isRelayedAddr :: Multiaddr -> Bool
isRelayedAddr (Multiaddr [Protocol]
ps) = Protocol
P2PCircuit Protocol -> [Protocol] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Protocol]
ps


-- | Whether the address is publicly routable.
--
-- Mirrors go-multiaddr's @manet.IsPublicAddr@ (net/private.go), which
-- the DCUtR unilateral-upgrade check depends on: a peer is only worth
-- dialling directly if it advertises an address that can be reached.
--
-- IPv4 is classified by exclusion (anything outside the private and
-- unroutable ranges is public); IPv6 by inclusion (only the global
-- unicast allocation, minus documentation and multicast, plus the NAT64
-- prefixes). A DNS name is public unless it is a special-use domain.
-- An address with no IP or DNS component is not public.
isPublicAddr :: Multiaddr -> Bool
isPublicAddr :: Multiaddr -> Bool
isPublicAddr (Multiaddr [Protocol]
ps) = (Protocol -> Bool) -> [Protocol] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Protocol -> Bool
componentIsPublic [Protocol]
ps
  where
    componentIsPublic :: Protocol -> Bool
componentIsPublic (IP4 Word32
w)     = Word32 -> Bool
publicIPv4 Word32
w
    componentIsPublic (IP6 ByteString
bs)    = ByteString -> Bool
publicIPv6 ByteString
bs
    componentIsPublic (DNS Text
h)     = Text -> Bool
publicDomain Text
h
    componentIsPublic (DNS4 Text
h)    = Text -> Bool
publicDomain Text
h
    componentIsPublic (DNS6 Text
h)    = Text -> Bool
publicDomain Text
h
    componentIsPublic (DNSAddr Text
h) = Text -> Bool
publicDomain Text
h
    componentIsPublic Protocol
_           = Bool
False

-- | IPv4 is public unless it falls in a private or unroutable range.
publicIPv4 :: Word32 -> Bool
publicIPv4 :: Word32 -> Bool
publicIPv4 Word32
w = Bool -> Bool
not (((Word32, Int) -> Bool) -> [(Word32, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Word32 -> (Word32, Int) -> Bool
inRange4 Word32
w) ([(Word32, Int)]
privateRanges4 [(Word32, Int)] -> [(Word32, Int)] -> [(Word32, Int)]
forall a. [a] -> [a] -> [a]
++ [(Word32, Int)]
unroutableRanges4))

-- | Private IPv4 ranges: loopback, RFC1918, CGNAT and link-local.
privateRanges4 :: [(Word32, Int)]
privateRanges4 :: [(Word32, Int)]
privateRanges4 =
  [ (Word32
0x7F000000, Int
8)   -- 127.0.0.0/8    localhost
  , (Word32
0x0A000000, Int
8)   -- 10.0.0.0/8
  , (Word32
0x64400000, Int
10)  -- 100.64.0.0/10  CGNAT
  , (Word32
0xAC100000, Int
12)  -- 172.16.0.0/12
  , (Word32
0xC0A80000, Int
16)  -- 192.168.0.0/16
  , (Word32
0xA9FE0000, Int
16)  -- 169.254.0.0/16 link local
  ]

-- | Well-known unroutable IPv4 ranges.
unroutableRanges4 :: [(Word32, Int)]
unroutableRanges4 :: [(Word32, Int)]
unroutableRanges4 =
  [ (Word32
0x00000000, Int
8)   -- 0.0.0.0/8
  , (Word32
0xC0000000, Int
26)  -- 192.0.0.0/26
  , (Word32
0xC0000200, Int
24)  -- 192.0.2.0/24
  , (Word32
0xC0586300, Int
24)  -- 192.88.99.0/24
  , (Word32
0xC6120000, Int
15)  -- 198.18.0.0/15
  , (Word32
0xC6336400, Int
24)  -- 198.51.100.0/24
  , (Word32
0xCB007100, Int
24)  -- 203.0.113.0/24
  , (Word32
0xE0000000, Int
4)   -- 224.0.0.0/4    multicast
  , (Word32
0xF0000000, Int
4)   -- 240.0.0.0/4
  , (Word32
0xFFFFFFFF, Int
32)  -- 255.255.255.255/32
  ]

-- | Whether an IPv4 address falls inside a CIDR block.
inRange4 :: Word32 -> (Word32, Int) -> Bool
inRange4 :: Word32 -> (Word32, Int) -> Bool
inRange4 Word32
addr (Word32
base, Int
bits) = Word32
addr Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
mask Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
base Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
mask
  where
    mask :: Word32
mask | Int
bits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0  = Word32
0
         | Int
bits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
32 = Word32
0xFFFFFFFF
         | Bool
otherwise  = Int -> Word32
forall {a}. (Bits a, Num a) => Int -> a
complementLow (Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bits)
    complementLow :: Int -> a
complementLow Int
n = a
0xFFFFFFFF a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
n a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFFFFFFFF

-- | IPv6 is public only inside the global unicast allocation (minus the
-- documentation prefix) or inside a NAT64 prefix.
--
-- The NAT64 well-known prefix (RFC 6052) can only reference a public
-- IPv4 address. The local-use prefix (RFC 8215) may reference a private
-- one, but the translation is left to the operator, so go-multiaddr
-- counts both as public on the grounds that a false negative here is
-- worse than a false positive. This follows that choice.
publicIPv6 :: ByteString -> Bool
publicIPv6 :: ByteString -> Bool
publicIPv6 ByteString
bs
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
16 = Bool
False
  | Bool
globalUnicast Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
documentation = Bool
True
  | Bool
otherwise = Bool
nat64
  where
    globalUnicast :: Bool
globalUnicast = ByteString -> (ByteString, Int) -> Bool
inRange6 ByteString
bs ([Word8] -> ByteString
BS.pack [Word8
0x20, Word8
0x00], Int
3)
    documentation :: Bool
documentation = ByteString -> (ByteString, Int) -> Bool
inRange6 ByteString
bs ([Word8] -> ByteString
BS.pack [Word8
0x20, Word8
0x01, Word8
0x0D, Word8
0xB8], Int
32)
    nat64 :: Bool
nat64 = ByteString -> (ByteString, Int) -> Bool
inRange6 ByteString
bs ([Word8] -> ByteString
BS.pack [Word8
0x00, Word8
0x64, Word8
0xFF, Word8
0x9B, Word8
0x00, Word8
0x00], Int
96)
              Bool -> Bool -> Bool
|| ByteString -> (ByteString, Int) -> Bool
inRange6 ByteString
bs ([Word8] -> ByteString
BS.pack [Word8
0x00, Word8
0x64, Word8
0xFF, Word8
0x9B, Word8
0x00, Word8
0x01], Int
48)

-- | Whether an IPv6 address falls inside a CIDR block, given the
-- block's leading bytes and its prefix length.
inRange6 :: ByteString -> (ByteString, Int) -> Bool
inRange6 :: ByteString -> (ByteString, Int) -> Bool
inRange6 ByteString
addr (ByteString
prefix, Int
bits) =
  ByteString -> Int
BS.length ByteString
padded Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
wholeBytes
    Bool -> Bool -> Bool
&& Int -> ByteString -> ByteString
BS.take Int
wholeBytes ByteString
addr ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> ByteString -> ByteString
BS.take Int
wholeBytes ByteString
padded
    Bool -> Bool -> Bool
&& Bool
remainderMatches
  where
    padded :: ByteString
padded = ByteString
prefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Word8 -> ByteString
BS.replicate (Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
prefix) Word8
0
    (Int
wholeBytes, Int
spare) = Int
bits Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
8
    remainderMatches :: Bool
remainderMatches
      | Int
spare Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Bool
True
      | Bool
otherwise  = Word8 -> Word8
maskByte (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
addr Int
wholeBytes) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8 -> Word8
maskByte (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
padded Int
wholeBytes)
    maskByte :: Word8 -> Word8
    maskByte :: Word8 -> Word8
maskByte Word8
b = Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. (Word8
0xFF Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
spare) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xFF)

-- | A DNS name is public unless it is a special-use domain that either
-- does not resolve or is reserved for private use.
publicDomain :: T.Text -> Bool
publicDomain :: Text -> Bool
publicDomain Text
host = Bool -> Bool
not ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
lowered) [String]
specialUseDomains)
  where
    lowered :: String
lowered = Text -> String
T.unpack (Text -> Text
T.toLower Text
host)

-- | Special-use domains that never denote a publicly routable host.
specialUseDomains :: [String]
specialUseDomains :: [String]
specialUseDomains =
  [ String
".localhost"
  , String
".in-addr.arpa"
  , String
".ip6.arpa"
  , String
".invalid"
  , String
".home.arpa"
  , String
".local"
  , String
".test"
  ]