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

module Ouroboros.Network.PeerSelection.RelayAccessPoint
  ( RelayAccessPoint (..)
  , LedgerRelayAccessPoint (..)
  , LedgerRelayAccessPointV1 (..)
  , SRVPrefix
  , prefixLedgerRelayAccessPoint
  , 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 qualified as BSC
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
                        -- ^ SRV domain, prefixed (as defined in CIP#0155)
                      | 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
BSC.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)
BSC.unsnoc Domain
domain -> Domain
domain
               | Bool
otherwise -> Domain
domain Domain -> Char -> Domain
`BSC.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
<> 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)
    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
        port <- Decoder s PortNumber
forall {s}. Decoder s PortNumber
decodePort
        domain <- fromCBOR
        return $ RelayAccessDomain domain port
      Word8
1 -> do
        port <- Decoder s PortNumber
forall {s}. Decoder s PortNumber
decodePort
        ip <- IP.IPv4 . IP.toIPv4 <$> fromCBOR
        return $ RelayAccessAddress ip port
      Word8
2 -> do
        port <- Decoder s PortNumber
forall {s}. Decoder s PortNumber
decodePort
        ip <- IP.IPv6 . IP.toIPv6 <$> fromCBOR
        return $ RelayAccessAddress ip port
      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


-- | A Relay as registered on the ledger.
--
-- The only difference with  `RelayAccessPoint` is that
-- `LedgerRelayAccessSRVDomain` is not prefixed, as required by CIP#0155.
--
data LedgerRelayAccessPoint =
    LedgerRelayAccessDomain    !DNS.Domain !Socket.PortNumber
  | LedgerRelayAccessSRVDomain !DNS.Domain
    -- ^ SRV domain as registered on the ledger
  | LedgerRelayAccessAddress   !IP.IP      !Socket.PortNumber
  deriving (LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool
(LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool)
-> (LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool)
-> Eq LedgerRelayAccessPoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool
== :: LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool
$c/= :: LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool
/= :: LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool
Eq, Eq LedgerRelayAccessPoint
Eq LedgerRelayAccessPoint =>
(LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Ordering)
-> (LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool)
-> (LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool)
-> (LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool)
-> (LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool)
-> (LedgerRelayAccessPoint
    -> LedgerRelayAccessPoint -> LedgerRelayAccessPoint)
-> (LedgerRelayAccessPoint
    -> LedgerRelayAccessPoint -> LedgerRelayAccessPoint)
-> Ord LedgerRelayAccessPoint
LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool
LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Ordering
LedgerRelayAccessPoint
-> LedgerRelayAccessPoint -> LedgerRelayAccessPoint
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 :: LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Ordering
compare :: LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Ordering
$c< :: LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool
< :: LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool
$c<= :: LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool
<= :: LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool
$c> :: LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool
> :: LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool
$c>= :: LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool
>= :: LedgerRelayAccessPoint -> LedgerRelayAccessPoint -> Bool
$cmax :: LedgerRelayAccessPoint
-> LedgerRelayAccessPoint -> LedgerRelayAccessPoint
max :: LedgerRelayAccessPoint
-> LedgerRelayAccessPoint -> LedgerRelayAccessPoint
$cmin :: LedgerRelayAccessPoint
-> LedgerRelayAccessPoint -> LedgerRelayAccessPoint
min :: LedgerRelayAccessPoint
-> LedgerRelayAccessPoint -> LedgerRelayAccessPoint
Ord)

instance Show LedgerRelayAccessPoint where
    show :: LedgerRelayAccessPoint -> String
show (LedgerRelayAccessDomain Domain
domain PortNumber
port) =
      String
"LedgerRelayAccessDomain " 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 (LedgerRelayAccessSRVDomain Domain
domain) =
      String
"LedgerRelayAccessSRVDomain " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Domain -> String
forall a. Show a => a -> String
show Domain
domain
    show (LedgerRelayAccessAddress 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 LedgerRelayAccessPoint where
  rnf :: LedgerRelayAccessPoint -> ()
rnf (LedgerRelayAccessDomain !Domain
_domain !PortNumber
_port) = ()
  rnf (LedgerRelayAccessSRVDomain !Domain
_domain) = ()
  rnf (LedgerRelayAccessAddress 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 LedgerRelayAccessPoint where
  parseJSON :: Value -> Parser LedgerRelayAccessPoint
parseJSON = String
-> (Object -> Parser LedgerRelayAccessPoint)
-> Value
-> Parser LedgerRelayAccessPoint
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RelayAccessPoint" ((Object -> Parser LedgerRelayAccessPoint)
 -> Value -> Parser LedgerRelayAccessPoint)
-> (Object -> Parser LedgerRelayAccessPoint)
-> Value
-> Parser LedgerRelayAccessPoint
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 LedgerRelayAccessPoint)
 -> Object -> Maybe LedgerRelayAccessPoint)
-> Object
-> (Object -> Parser LedgerRelayAccessPoint)
-> Maybe LedgerRelayAccessPoint
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Object -> Parser LedgerRelayAccessPoint)
-> Object -> Maybe LedgerRelayAccessPoint
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Object
o ((Object -> Parser LedgerRelayAccessPoint)
 -> Maybe LedgerRelayAccessPoint)
-> (Object -> Parser LedgerRelayAccessPoint)
-> Maybe LedgerRelayAccessPoint
forall a b. (a -> b) -> a -> b
$ Parser LedgerRelayAccessPoint
-> Object -> Parser LedgerRelayAccessPoint
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 LedgerRelayAccessPoint
Nothing  -> LedgerRelayAccessPoint -> Parser LedgerRelayAccessPoint
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerRelayAccessPoint -> Parser LedgerRelayAccessPoint)
-> LedgerRelayAccessPoint -> Parser LedgerRelayAccessPoint
forall a b. (a -> b) -> a -> b
$ Domain -> LedgerRelayAccessPoint
LedgerRelayAccessSRVDomain (Domain -> Domain
fullyQualified Domain
addr)
      Just LedgerRelayAccessPoint
rap -> LedgerRelayAccessPoint -> Parser LedgerRelayAccessPoint
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return LedgerRelayAccessPoint
rap

    where
      toRelayAccessPoint :: DNS.Domain -> Int -> LedgerRelayAccessPoint
      toRelayAccessPoint :: Domain -> Int -> LedgerRelayAccessPoint
toRelayAccessPoint Domain
address Int
port =
          case String -> Maybe IP
forall a. Read a => String -> Maybe a
readMaybe (Domain -> String
BSC.unpack Domain
address) of
            Maybe IP
Nothing   -> Domain -> PortNumber -> LedgerRelayAccessPoint
LedgerRelayAccessDomain (Domain -> Domain
fullyQualified Domain
address) (Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port)
            Just IP
addr -> IP -> PortNumber -> LedgerRelayAccessPoint
LedgerRelayAccessAddress 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)
BSC.unsnoc Domain
domain -> Domain
domain
               | Bool
otherwise -> Domain
domain Domain -> Char -> Domain
`BSC.snoc` Char
'.'

instance ToJSON LedgerRelayAccessPoint where
  toJSON :: LedgerRelayAccessPoint -> Value
toJSON (LedgerRelayAccessDomain 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 (LedgerRelayAccessSRVDomain 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 (LedgerRelayAccessAddress 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 LedgerRelayAccessPoint where
  toCBOR :: LedgerRelayAccessPoint -> Encoding
toCBOR LedgerRelayAccessPoint
rap = case LedgerRelayAccessPoint
rap of
    LedgerRelayAccessDomain 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
    LedgerRelayAccessAddress (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)
    LedgerRelayAccessAddress (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)
    LedgerRelayAccessSRVDomain 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 LedgerRelayAccessPoint where
  fromCBOR :: forall s. Decoder s LedgerRelayAccessPoint
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 LedgerRelayAccessPoint list length "
               <> show listLen <> "for constructor tag "
               <> show constructorTag
    case constructorTag of
      Word8
0 -> do
        port <- Decoder s PortNumber
forall {s}. Decoder s PortNumber
decodePort
        domain <- fromCBOR
        return $ LedgerRelayAccessDomain domain port
      Word8
1 -> do
        port <- Decoder s PortNumber
forall {s}. Decoder s PortNumber
decodePort
        ip <- IP.IPv4 . IP.toIPv4 <$> fromCBOR
        return $ LedgerRelayAccessAddress ip port
      Word8
2 -> do
        port <- Decoder s PortNumber
forall {s}. Decoder s PortNumber
decodePort
        ip <- IP.IPv6 . IP.toIPv6 <$> fromCBOR
        return $ LedgerRelayAccessAddress ip port
      Word8
3 -> do
        Domain -> LedgerRelayAccessPoint
LedgerRelayAccessSRVDomain (Domain -> LedgerRelayAccessPoint)
-> Decoder s Domain -> Decoder s LedgerRelayAccessPoint
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 LedgerRelayAccessPoint
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s LedgerRelayAccessPoint)
-> String -> Decoder s LedgerRelayAccessPoint
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized LedgerRelayAccessPoint 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


-- | A new type wrapper which provides backward compatible `FromJSON` instance
-- for `LedgerRelayAccessPoint`.
--
newtype LedgerRelayAccessPointV1 = LedgerRelayAccessPointV1 { LedgerRelayAccessPointV1 -> LedgerRelayAccessPoint
getLedgerReelayAccessPointV1 :: LedgerRelayAccessPoint }

instance FromJSON LedgerRelayAccessPointV1 where
  parseJSON :: Value -> Parser LedgerRelayAccessPointV1
parseJSON = String
-> (Object -> Parser LedgerRelayAccessPointV1)
-> Value
-> Parser LedgerRelayAccessPointV1
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RelayAccessPoint" ((Object -> Parser LedgerRelayAccessPointV1)
 -> Value -> Parser LedgerRelayAccessPointV1)
-> (Object -> Parser LedgerRelayAccessPointV1)
-> Value
-> Parser LedgerRelayAccessPointV1
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 LedgerRelayAccessPoint)
 -> Object -> Maybe LedgerRelayAccessPoint)
-> Object
-> (Object -> Parser LedgerRelayAccessPoint)
-> Maybe LedgerRelayAccessPoint
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Object -> Parser LedgerRelayAccessPoint)
-> Object -> Maybe LedgerRelayAccessPoint
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Object
o ((Object -> Parser LedgerRelayAccessPoint)
 -> Maybe LedgerRelayAccessPoint)
-> (Object -> Parser LedgerRelayAccessPoint)
-> Maybe LedgerRelayAccessPoint
forall a b. (a -> b) -> a -> b
$ Parser LedgerRelayAccessPoint
-> Object -> Parser LedgerRelayAccessPoint
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 LedgerRelayAccessPoint
Nothing  -> LedgerRelayAccessPointV1 -> Parser LedgerRelayAccessPointV1
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerRelayAccessPointV1 -> Parser LedgerRelayAccessPointV1)
-> LedgerRelayAccessPointV1 -> Parser LedgerRelayAccessPointV1
forall a b. (a -> b) -> a -> b
$ LedgerRelayAccessPoint -> LedgerRelayAccessPointV1
LedgerRelayAccessPointV1 (LedgerRelayAccessPoint -> LedgerRelayAccessPointV1)
-> LedgerRelayAccessPoint -> LedgerRelayAccessPointV1
forall a b. (a -> b) -> a -> b
$ Domain -> LedgerRelayAccessPoint
LedgerRelayAccessSRVDomain (Domain -> Domain
fullyQualified Domain
addr)
      Just LedgerRelayAccessPoint
rap -> LedgerRelayAccessPointV1 -> Parser LedgerRelayAccessPointV1
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerRelayAccessPointV1 -> Parser LedgerRelayAccessPointV1)
-> LedgerRelayAccessPointV1 -> Parser LedgerRelayAccessPointV1
forall a b. (a -> b) -> a -> b
$ LedgerRelayAccessPoint -> LedgerRelayAccessPointV1
LedgerRelayAccessPointV1 LedgerRelayAccessPoint
rap

    where
      toRelayAccessPoint :: DNS.Domain -> Int -> LedgerRelayAccessPoint
      toRelayAccessPoint :: Domain -> Int -> LedgerRelayAccessPoint
toRelayAccessPoint Domain
address Int
port =
          case String -> Maybe IP
forall a. Read a => String -> Maybe a
readMaybe (Domain -> String
BSC.unpack Domain
address) of
            Maybe IP
Nothing   -> Domain -> PortNumber -> LedgerRelayAccessPoint
LedgerRelayAccessDomain (Domain -> Domain
fullyQualified Domain
address) (Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port)
            Just IP
addr -> IP -> PortNumber -> LedgerRelayAccessPoint
LedgerRelayAccessAddress 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)
BSC.unsnoc Domain
domain -> Domain
domain
               | Bool
otherwise -> Domain
domain Domain -> Char -> Domain
`BSC.snoc` Char
'.'


-- | Type of a DNS SRV prefix as defined by CIP#0155
--
type SRVPrefix = DNS.Domain

prefixLedgerRelayAccessPoint
  :: SRVPrefix
  -> LedgerRelayAccessPoint
  -> RelayAccessPoint
prefixLedgerRelayAccessPoint :: Domain -> LedgerRelayAccessPoint -> RelayAccessPoint
prefixLedgerRelayAccessPoint Domain
_prefix (LedgerRelayAccessDomain Domain
domain PortNumber
port)
  = Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain Domain
domain PortNumber
port
prefixLedgerRelayAccessPoint  Domain
prefix (LedgerRelayAccessSRVDomain Domain
domain)
  = Domain -> RelayAccessPoint
RelayAccessSRVDomain (Domain
prefix Domain -> Domain -> Domain
forall a. Semigroup a => a -> a -> a
<> Domain
"." Domain -> Domain -> Domain
forall a. Semigroup a => a -> a -> a
<> Domain
domain)
prefixLedgerRelayAccessPoint Domain
_prefix (LedgerRelayAccessAddress IP
ip PortNumber
port)
  = IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress IP
ip PortNumber
port