{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE ViewPatterns      #-}

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

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

import Data.Aeson
import Data.IP qualified as IP
import Data.Text (Text)
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 product of a 'DNS.Domain' and 'Socket.PortNumber'.  After resolving the
-- domain we will use the 'Socket.PortNumber' to form 'Socket.SockAddr'.
--
data DomainAccessPoint = DomainAccessPoint {
    DomainAccessPoint -> Domain
dapDomain     :: !DNS.Domain,
    DomainAccessPoint -> PortNumber
dapPortNumber :: !Socket.PortNumber
  }
  deriving (Int -> DomainAccessPoint -> ShowS
[DomainAccessPoint] -> ShowS
DomainAccessPoint -> String
(Int -> DomainAccessPoint -> ShowS)
-> (DomainAccessPoint -> String)
-> ([DomainAccessPoint] -> ShowS)
-> Show DomainAccessPoint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DomainAccessPoint -> ShowS
showsPrec :: Int -> DomainAccessPoint -> ShowS
$cshow :: DomainAccessPoint -> String
show :: DomainAccessPoint -> String
$cshowList :: [DomainAccessPoint] -> ShowS
showList :: [DomainAccessPoint] -> ShowS
Show, DomainAccessPoint -> DomainAccessPoint -> Bool
(DomainAccessPoint -> DomainAccessPoint -> Bool)
-> (DomainAccessPoint -> DomainAccessPoint -> Bool)
-> Eq DomainAccessPoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DomainAccessPoint -> DomainAccessPoint -> Bool
== :: DomainAccessPoint -> DomainAccessPoint -> Bool
$c/= :: DomainAccessPoint -> DomainAccessPoint -> Bool
/= :: DomainAccessPoint -> DomainAccessPoint -> Bool
Eq, Eq DomainAccessPoint
Eq DomainAccessPoint =>
(DomainAccessPoint -> DomainAccessPoint -> Ordering)
-> (DomainAccessPoint -> DomainAccessPoint -> Bool)
-> (DomainAccessPoint -> DomainAccessPoint -> Bool)
-> (DomainAccessPoint -> DomainAccessPoint -> Bool)
-> (DomainAccessPoint -> DomainAccessPoint -> Bool)
-> (DomainAccessPoint -> DomainAccessPoint -> DomainAccessPoint)
-> (DomainAccessPoint -> DomainAccessPoint -> DomainAccessPoint)
-> Ord DomainAccessPoint
DomainAccessPoint -> DomainAccessPoint -> Bool
DomainAccessPoint -> DomainAccessPoint -> Ordering
DomainAccessPoint -> DomainAccessPoint -> DomainAccessPoint
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 :: DomainAccessPoint -> DomainAccessPoint -> Ordering
compare :: DomainAccessPoint -> DomainAccessPoint -> Ordering
$c< :: DomainAccessPoint -> DomainAccessPoint -> Bool
< :: DomainAccessPoint -> DomainAccessPoint -> Bool
$c<= :: DomainAccessPoint -> DomainAccessPoint -> Bool
<= :: DomainAccessPoint -> DomainAccessPoint -> Bool
$c> :: DomainAccessPoint -> DomainAccessPoint -> Bool
> :: DomainAccessPoint -> DomainAccessPoint -> Bool
$c>= :: DomainAccessPoint -> DomainAccessPoint -> Bool
>= :: DomainAccessPoint -> DomainAccessPoint -> Bool
$cmax :: DomainAccessPoint -> DomainAccessPoint -> DomainAccessPoint
max :: DomainAccessPoint -> DomainAccessPoint -> DomainAccessPoint
$cmin :: DomainAccessPoint -> DomainAccessPoint -> DomainAccessPoint
min :: DomainAccessPoint -> DomainAccessPoint -> DomainAccessPoint
Ord)

instance FromJSON DomainAccessPoint where
  parseJSON :: Value -> Parser DomainAccessPoint
parseJSON = String
-> (Object -> Parser DomainAccessPoint)
-> Value
-> Parser DomainAccessPoint
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"DomainAccessPoint" ((Object -> Parser DomainAccessPoint)
 -> Value -> Parser DomainAccessPoint)
-> (Object -> Parser DomainAccessPoint)
-> Value
-> Parser DomainAccessPoint
forall a b. (a -> b) -> a -> b
$ \Object
v ->
    Domain -> PortNumber -> DomainAccessPoint
DomainAccessPoint
      (Domain -> PortNumber -> DomainAccessPoint)
-> Parser Domain -> Parser (PortNumber -> DomainAccessPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Domain
encodeUtf8 (Text -> Domain) -> Parser Text -> Parser Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"address")
      Parser (PortNumber -> DomainAccessPoint)
-> Parser PortNumber -> Parser DomainAccessPoint
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Socket.PortNumber) (Int -> PortNumber) -> Parser Int -> Parser PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"port")

instance ToJSON DomainAccessPoint where
  toJSON :: DomainAccessPoint -> Value
toJSON DomainAccessPoint
da =
    [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 (DomainAccessPoint -> Domain
dapDomain DomainAccessPoint
da)
      , 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 (DomainAccessPoint -> PortNumber
dapPortNumber DomainAccessPoint
da) :: Int)
      ]

-- | 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
                      | 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)

newtype RelayAccessPointCoded = RelayAccessPointCoded { RelayAccessPointCoded -> RelayAccessPoint
unRelayAccessPointCoded :: RelayAccessPoint }

-- | These instances are used to serialize 'LedgerPeerSnapshot'
-- consensus LocalStateQuery server which uses these instances
-- for all its query responses. It appears they provide some improved
-- debugging diagnostics over Serialize instances.
instance ToCBOR RelayAccessPointCoded where
  toCBOR :: RelayAccessPointCoded -> Encoding
toCBOR (RelayAccessPointCoded 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
<> PortNumber -> Encoding
serialise' PortNumber
port
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Domain -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Domain
domain
    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
<> PortNumber -> Encoding
serialise' PortNumber
port
      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)
    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
<> PortNumber -> Encoding
serialise' PortNumber
port
      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)
    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 RelayAccessPointCoded where
  fromCBOR :: forall s. Decoder s RelayAccessPointCoded
fromCBOR = do
    listLen <- Decoder s Int
forall s. Decoder s Int
Codec.decodeListLen
    when (listLen /= 3) . fail $    "Unrecognized RelayAccessPoint list length "
                                 <> show listLen
    constructorTag <- Codec.decodeWord8
    port <- fromInteger <$> fromCBOR @Integer
    case constructorTag of
      Word8
0 -> do
        domain <- Decoder s Domain
forall s. Decoder s Domain
forall a s. FromCBOR a => Decoder s a
fromCBOR
        return . RelayAccessPointCoded $ RelayAccessDomain domain port
      Word8
1 -> do
        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
        return . RelayAccessPointCoded $ RelayAccessAddress ip4 port
      Word8
2 -> do
        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
        return . RelayAccessPointCoded $ RelayAccessAddress ip6 port
      Word8
_ -> String -> Decoder s RelayAccessPointCoded
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s RelayAccessPointCoded)
-> String -> Decoder s RelayAccessPointCoded
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

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 (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


-- | 'RelayDomainAccessPoint' a bidirectional pattern which links
-- 'RelayAccessDomain' and 'DomainAccessPoint'.
--
pattern RelayDomainAccessPoint :: DomainAccessPoint -> RelayAccessPoint
pattern $bRelayDomainAccessPoint :: DomainAccessPoint -> RelayAccessPoint
$mRelayDomainAccessPoint :: forall {r}.
RelayAccessPoint -> (DomainAccessPoint -> r) -> ((# #) -> r) -> r
RelayDomainAccessPoint dap <- (viewRelayAccessPoint -> Just dap)
  where
    RelayDomainAccessPoint DomainAccessPoint {Domain
dapDomain :: DomainAccessPoint -> Domain
dapDomain :: Domain
dapDomain, PortNumber
dapPortNumber :: DomainAccessPoint -> PortNumber
dapPortNumber :: PortNumber
dapPortNumber} =
      Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain Domain
dapDomain PortNumber
dapPortNumber

{-# COMPLETE RelayDomainAccessPoint, RelayAccessAddress #-}

viewRelayAccessPoint :: RelayAccessPoint -> Maybe DomainAccessPoint
viewRelayAccessPoint :: RelayAccessPoint -> Maybe DomainAccessPoint
viewRelayAccessPoint (RelayAccessDomain Domain
dapDomain PortNumber
dapPortNumber) =
    DomainAccessPoint -> Maybe DomainAccessPoint
forall a. a -> Maybe a
Just DomainAccessPoint {Domain
dapDomain :: Domain
dapDomain :: Domain
dapDomain, PortNumber
dapPortNumber :: PortNumber
dapPortNumber :: PortNumber
dapPortNumber}
viewRelayAccessPoint  RelayAccessAddress {} =
    Maybe DomainAccessPoint
forall a. Maybe a
Nothing


-- '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 (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
v -> do
    addr <- Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"address"
    port <- v .: "port"
    return (toRelayAccessPoint addr port)

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 (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)
      ]

-- | Parse a address field as either an IP address or a DNS address.
-- Returns corresponding RelayAccessPoint.
--
toRelayAccessPoint :: Text -> Int -> RelayAccessPoint
toRelayAccessPoint :: Text -> Int -> RelayAccessPoint
toRelayAccessPoint Text
address Int
port =
    case String -> Maybe IP
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
address) of
      Maybe IP
Nothing   -> Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain (Text -> Domain
encodeUtf8 Text
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)