{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE BlockArguments    #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications  #-}

module Ouroboros.Network.PeerSelection.RelayAccessPoint
  ( RelayAccessPoint (..)
  , IP.IP (..)
    -- * Socket type re-exports
  , Socket.PortNumber
  ) where

import Control.DeepSeq (NFData (..))
import Control.Monad (unless)

import Data.Aeson
import Data.Aeson.Types
import Data.ByteString.Char8 (snoc, unpack, unsnoc)
import Data.IP qualified as IP
import Data.Text qualified as Text
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Text.Read (readMaybe)

import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import Cardano.Binary qualified as Codec
import Network.DNS qualified as DNS
import Network.Socket qualified as Socket

-- | A relay can have either an IP address and a port number or
-- a domain with a port number
--
data RelayAccessPoint = RelayAccessDomain    !DNS.Domain !Socket.PortNumber
                      | RelayAccessSRVDomain !DNS.Domain
                      | RelayAccessAddress   !IP.IP      !Socket.PortNumber
  deriving (RelayAccessPoint -> RelayAccessPoint -> Bool
(RelayAccessPoint -> RelayAccessPoint -> Bool)
-> (RelayAccessPoint -> RelayAccessPoint -> Bool)
-> Eq RelayAccessPoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RelayAccessPoint -> RelayAccessPoint -> Bool
== :: RelayAccessPoint -> RelayAccessPoint -> Bool
$c/= :: RelayAccessPoint -> RelayAccessPoint -> Bool
/= :: RelayAccessPoint -> RelayAccessPoint -> Bool
Eq, Eq RelayAccessPoint
Eq RelayAccessPoint =>
(RelayAccessPoint -> RelayAccessPoint -> Ordering)
-> (RelayAccessPoint -> RelayAccessPoint -> Bool)
-> (RelayAccessPoint -> RelayAccessPoint -> Bool)
-> (RelayAccessPoint -> RelayAccessPoint -> Bool)
-> (RelayAccessPoint -> RelayAccessPoint -> Bool)
-> (RelayAccessPoint -> RelayAccessPoint -> RelayAccessPoint)
-> (RelayAccessPoint -> RelayAccessPoint -> RelayAccessPoint)
-> Ord RelayAccessPoint
RelayAccessPoint -> RelayAccessPoint -> Bool
RelayAccessPoint -> RelayAccessPoint -> Ordering
RelayAccessPoint -> RelayAccessPoint -> RelayAccessPoint
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RelayAccessPoint -> RelayAccessPoint -> Ordering
compare :: RelayAccessPoint -> RelayAccessPoint -> Ordering
$c< :: RelayAccessPoint -> RelayAccessPoint -> Bool
< :: RelayAccessPoint -> RelayAccessPoint -> Bool
$c<= :: RelayAccessPoint -> RelayAccessPoint -> Bool
<= :: RelayAccessPoint -> RelayAccessPoint -> Bool
$c> :: RelayAccessPoint -> RelayAccessPoint -> Bool
> :: RelayAccessPoint -> RelayAccessPoint -> Bool
$c>= :: RelayAccessPoint -> RelayAccessPoint -> Bool
>= :: RelayAccessPoint -> RelayAccessPoint -> Bool
$cmax :: RelayAccessPoint -> RelayAccessPoint -> RelayAccessPoint
max :: RelayAccessPoint -> RelayAccessPoint -> RelayAccessPoint
$cmin :: RelayAccessPoint -> RelayAccessPoint -> RelayAccessPoint
min :: RelayAccessPoint -> RelayAccessPoint -> RelayAccessPoint
Ord)

instance Show RelayAccessPoint where
    show :: RelayAccessPoint -> String
show (RelayAccessDomain Domain
domain PortNumber
port) =
      String
"RelayAccessDomain " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Domain -> String
forall a. Show a => a -> String
show Domain
domain String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PortNumber -> String
forall a. Show a => a -> String
show PortNumber
port
    show (RelayAccessSRVDomain Domain
domain) =
      String
"RelayAccessSRVDomain " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Domain -> String
forall a. Show a => a -> String
show Domain
domain
    show (RelayAccessAddress IP
ip PortNumber
port) =
      String
"RelayAccessAddress \"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ IP -> String
forall a. Show a => a -> String
show IP
ip String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PortNumber -> String
forall a. Show a => a -> String
show PortNumber
port

-- 'IP' nor 'IPv6' is strict, 'IPv4' is strict only because it's a newtype for
-- a primitive type ('Word32').
--
instance NFData RelayAccessPoint where
  rnf :: RelayAccessPoint -> ()
rnf (RelayAccessDomain !Domain
_domain !PortNumber
_port) = ()
  rnf (RelayAccessSRVDomain !Domain
_domain) = ()
  rnf (RelayAccessAddress IP
ip !PortNumber
_port) =
    case IP
ip of
      IP.IPv4 IPv4
ipv4 -> Word32 -> ()
forall a. NFData a => a -> ()
rnf (IPv4 -> Word32
IP.fromIPv4w IPv4
ipv4)
      IP.IPv6 IPv6
ipv6 -> (Word32, Word32, Word32, Word32) -> ()
forall a. NFData a => a -> ()
rnf (IPv6 -> (Word32, Word32, Word32, Word32)
IP.fromIPv6w IPv6
ipv6)

instance FromJSON RelayAccessPoint where
  parseJSON :: Value -> Parser RelayAccessPoint
parseJSON = String
-> (Object -> Parser RelayAccessPoint)
-> Value
-> Parser RelayAccessPoint
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RelayAccessPoint" ((Object -> Parser RelayAccessPoint)
 -> Value -> Parser RelayAccessPoint)
-> (Object -> Parser RelayAccessPoint)
-> Value
-> Parser RelayAccessPoint
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    addr <- Text -> Domain
encodeUtf8 (Text -> Domain) -> Parser Text -> Parser Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"address"
    let res = ((Object -> Parser RelayAccessPoint)
 -> Object -> Maybe RelayAccessPoint)
-> Object
-> (Object -> Parser RelayAccessPoint)
-> Maybe RelayAccessPoint
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Object -> Parser RelayAccessPoint)
-> Object -> Maybe RelayAccessPoint
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Object
o ((Object -> Parser RelayAccessPoint) -> Maybe RelayAccessPoint)
-> (Object -> Parser RelayAccessPoint) -> Maybe RelayAccessPoint
forall a b. (a -> b) -> a -> b
$ Parser RelayAccessPoint -> Object -> Parser RelayAccessPoint
forall a b. a -> b -> a
const do
          port <- Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"port"
          return (toRelayAccessPoint addr port)
    case res of
      Maybe RelayAccessPoint
Nothing  -> RelayAccessPoint -> Parser RelayAccessPoint
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (RelayAccessPoint -> Parser RelayAccessPoint)
-> RelayAccessPoint -> Parser RelayAccessPoint
forall a b. (a -> b) -> a -> b
$ Domain -> RelayAccessPoint
RelayAccessSRVDomain (Domain -> Domain
fullyQualified Domain
addr)
      Just RelayAccessPoint
rap -> RelayAccessPoint -> Parser RelayAccessPoint
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return RelayAccessPoint
rap

    where
      toRelayAccessPoint :: DNS.Domain -> Int -> RelayAccessPoint
      toRelayAccessPoint :: Domain -> Int -> RelayAccessPoint
toRelayAccessPoint Domain
address Int
port =
          case String -> Maybe IP
forall a. Read a => String -> Maybe a
readMaybe (Domain -> String
unpack Domain
address) of
            Maybe IP
Nothing   -> Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain (Domain -> Domain
fullyQualified Domain
address) (Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port)
            Just IP
addr -> IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress IP
addr (Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port)
      fullyQualified :: Domain -> Domain
fullyQualified = \case
        Domain
domain | Just (Domain
_, Char
'.') <- Domain -> Maybe (Domain, Char)
unsnoc Domain
domain -> Domain
domain
               | Bool
otherwise -> Domain
domain Domain -> Char -> Domain
`snoc` Char
'.'

instance ToJSON RelayAccessPoint where
  toJSON :: RelayAccessPoint -> Value
toJSON (RelayAccessDomain Domain
addr PortNumber
port) =
    [Pair] -> Value
object
      [ Key
"address" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Domain -> Text
decodeUtf8 Domain
addr
      , Key
"port" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port :: Int)
      ]
  toJSON (RelayAccessSRVDomain Domain
domain) =
    [Pair] -> Value
object
      [ Key
"address" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Domain -> Text
decodeUtf8 Domain
domain
      ]
  toJSON (RelayAccessAddress IP
ip PortNumber
port) =
    [Pair] -> Value
object
      [ Key
"address" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String -> Text
Text.pack (IP -> String
forall a. Show a => a -> String
show IP
ip)
      , Key
"port" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port :: Int)
      ]

instance ToCBOR RelayAccessPoint where
  toCBOR :: RelayAccessPoint -> Encoding
toCBOR RelayAccessPoint
rap = case RelayAccessPoint
rap of
    RelayAccessDomain Domain
domain PortNumber
port ->
         Word -> Encoding
Codec.encodeListLen Word
3
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
Codec.encodeWord8 Word8
0
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Domain -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Domain
domain
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PortNumber -> Encoding
serialise' PortNumber
port
    RelayAccessAddress (IP.IPv4 IPv4
ipv4) PortNumber
port ->
         Word -> Encoding
Codec.encodeListLen Word
3
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
Codec.encodeWord8 Word8
1
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [Int] -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (IPv4 -> [Int]
IP.fromIPv4 IPv4
ipv4)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PortNumber -> Encoding
serialise' PortNumber
port
    RelayAccessAddress (IP.IPv6 IPv6
ip6) PortNumber
port ->
         Word -> Encoding
Codec.encodeListLen Word
3
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
Codec.encodeWord8 Word8
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [Int] -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (IPv6 -> [Int]
IP.fromIPv6 IPv6
ip6)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PortNumber -> Encoding
serialise' PortNumber
port
    RelayAccessSRVDomain Domain
domain ->
         Word -> Encoding
Codec.encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
Codec.encodeWord8 Word8
3
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Domain -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Domain
domain
    where
      serialise' :: PortNumber -> Encoding
serialise' = Integer -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Integer -> Encoding)
-> (PortNumber -> Integer) -> PortNumber -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortNumber -> Integer
forall a. Integral a => a -> Integer
toInteger

instance FromCBOR RelayAccessPoint where
  fromCBOR :: forall s. Decoder s RelayAccessPoint
fromCBOR = do
    listLen <- Decoder s Int
forall s. Decoder s Int
Codec.decodeListLen
    constructorTag <- Codec.decodeWord8
    unless (   listLen == 3
            || (listLen == 2 && constructorTag == 3))
      $ fail $ "Unrecognized RelayAccessPoint list length "
               <> show listLen <> "for constructor tag "
               <> show constructorTag
    case constructorTag of
      Word8
0 -> do
        Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain (Domain -> PortNumber -> RelayAccessPoint)
-> Decoder s Domain -> Decoder s (PortNumber -> RelayAccessPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Domain
forall s. Decoder s Domain
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (PortNumber -> RelayAccessPoint)
-> Decoder s PortNumber -> Decoder s RelayAccessPoint
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s PortNumber
forall {s}. Decoder s PortNumber
decodePort
      Word8
1 -> do
        let ip4 :: Decoder s IP
ip4 = IPv4 -> IP
IP.IPv4 (IPv4 -> IP) -> ([Int] -> IPv4) -> [Int] -> IP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> IPv4
IP.toIPv4 ([Int] -> IP) -> Decoder s [Int] -> Decoder s IP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s [Int]
forall s. Decoder s [Int]
forall a s. FromCBOR a => Decoder s a
fromCBOR
        IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress (IP -> PortNumber -> RelayAccessPoint)
-> Decoder s IP -> Decoder s (PortNumber -> RelayAccessPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s IP
forall {s}. Decoder s IP
ip4 Decoder s (PortNumber -> RelayAccessPoint)
-> Decoder s PortNumber -> Decoder s RelayAccessPoint
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s PortNumber
forall {s}. Decoder s PortNumber
decodePort
      Word8
2 -> do
        let ip6 :: Decoder s IP
ip6 = IPv6 -> IP
IP.IPv6 (IPv6 -> IP) -> ([Int] -> IPv6) -> [Int] -> IP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> IPv6
IP.toIPv6 ([Int] -> IP) -> Decoder s [Int] -> Decoder s IP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s [Int]
forall s. Decoder s [Int]
forall a s. FromCBOR a => Decoder s a
fromCBOR
        IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress (IP -> PortNumber -> RelayAccessPoint)
-> Decoder s IP -> Decoder s (PortNumber -> RelayAccessPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s IP
forall {s}. Decoder s IP
ip6 Decoder s (PortNumber -> RelayAccessPoint)
-> Decoder s PortNumber -> Decoder s RelayAccessPoint
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s PortNumber
forall {s}. Decoder s PortNumber
decodePort
      Word8
3 -> do
        Domain -> RelayAccessPoint
RelayAccessSRVDomain (Domain -> RelayAccessPoint)
-> Decoder s Domain -> Decoder s RelayAccessPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Domain
forall s. Decoder s Domain
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Word8
_ -> String -> Decoder s RelayAccessPoint
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s RelayAccessPoint)
-> String -> Decoder s RelayAccessPoint
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized RelayAccessPoint tag: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show Word8
constructorTag
    where
      decodePort :: Decoder s PortNumber
decodePort = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int (Int -> PortNumber) -> Decoder s Int -> Decoder s PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Int
forall s. Decoder s Int
forall a s. FromCBOR a => Decoder s a
fromCBOR