{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE StandaloneDeriving         #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Ouroboros.Network.PeerSelection.Instances
  ( -- test types
    PeerAddr (..)
    -- generators
  , genIPv4
  , genIPv6
    -- generator tests
  , prop_arbitrary_PeerSelectionTargets
  , prop_shrink_PeerSelectionTargets
  ) where

import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word32, Word64)

import Cardano.Slotting.Slot (SlotNo (..))

import Ouroboros.Network.PeerSelection.Governor

import Data.Hashable
import Data.IP qualified as IP
import Ouroboros.Network.ConsensusMode
import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..))
import Ouroboros.Network.PeerSelection.LedgerPeers.Type (AfterSlot (..),
           UseLedgerPeers (..))
import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..))
import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable (..))
import Ouroboros.Network.PeerSelection.RelayAccessPoint (DomainAccessPoint (..),
           RelayAccessPoint (..))
import Ouroboros.Network.Testing.Utils (ShrinkCarefully, prop_shrink_nonequal,
           prop_shrink_valid)
import Test.QuickCheck


--
-- QuickCheck instances
--

-- | Simple address representation for the tests
--
newtype PeerAddr = PeerAddr Int
  deriving (PeerAddr -> PeerAddr -> Bool
(PeerAddr -> PeerAddr -> Bool)
-> (PeerAddr -> PeerAddr -> Bool) -> Eq PeerAddr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PeerAddr -> PeerAddr -> Bool
== :: PeerAddr -> PeerAddr -> Bool
$c/= :: PeerAddr -> PeerAddr -> Bool
/= :: PeerAddr -> PeerAddr -> Bool
Eq, Eq PeerAddr
Eq PeerAddr =>
(PeerAddr -> PeerAddr -> Ordering)
-> (PeerAddr -> PeerAddr -> Bool)
-> (PeerAddr -> PeerAddr -> Bool)
-> (PeerAddr -> PeerAddr -> Bool)
-> (PeerAddr -> PeerAddr -> Bool)
-> (PeerAddr -> PeerAddr -> PeerAddr)
-> (PeerAddr -> PeerAddr -> PeerAddr)
-> Ord PeerAddr
PeerAddr -> PeerAddr -> Bool
PeerAddr -> PeerAddr -> Ordering
PeerAddr -> PeerAddr -> PeerAddr
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 :: PeerAddr -> PeerAddr -> Ordering
compare :: PeerAddr -> PeerAddr -> Ordering
$c< :: PeerAddr -> PeerAddr -> Bool
< :: PeerAddr -> PeerAddr -> Bool
$c<= :: PeerAddr -> PeerAddr -> Bool
<= :: PeerAddr -> PeerAddr -> Bool
$c> :: PeerAddr -> PeerAddr -> Bool
> :: PeerAddr -> PeerAddr -> Bool
$c>= :: PeerAddr -> PeerAddr -> Bool
>= :: PeerAddr -> PeerAddr -> Bool
$cmax :: PeerAddr -> PeerAddr -> PeerAddr
max :: PeerAddr -> PeerAddr -> PeerAddr
$cmin :: PeerAddr -> PeerAddr -> PeerAddr
min :: PeerAddr -> PeerAddr -> PeerAddr
Ord, Int -> PeerAddr -> ShowS
[PeerAddr] -> ShowS
PeerAddr -> String
(Int -> PeerAddr -> ShowS)
-> (PeerAddr -> String) -> ([PeerAddr] -> ShowS) -> Show PeerAddr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PeerAddr -> ShowS
showsPrec :: Int -> PeerAddr -> ShowS
$cshow :: PeerAddr -> String
show :: PeerAddr -> String
$cshowList :: [PeerAddr] -> ShowS
showList :: [PeerAddr] -> ShowS
Show, Eq PeerAddr
Eq PeerAddr =>
(Int -> PeerAddr -> Int) -> (PeerAddr -> Int) -> Hashable PeerAddr
Int -> PeerAddr -> Int
PeerAddr -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> PeerAddr -> Int
hashWithSalt :: Int -> PeerAddr -> Int
$chash :: PeerAddr -> Int
hash :: PeerAddr -> Int
Hashable)

-- | We mostly avoid using this instance since we need careful control over
-- the peer addrs, e.g. to make graphs work, and sets overlap etc. But it's
-- here for the few cases that need it, and it is used for (lack-of) shrinking.
--
instance Arbitrary PeerAddr where
  arbitrary :: Gen PeerAddr
arbitrary = Int -> PeerAddr
PeerAddr (Int -> PeerAddr) -> Gen Int -> Gen PeerAddr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Integral a => Gen a
arbitrarySizedNatural
  shrink :: PeerAddr -> [PeerAddr]
shrink PeerAddr
_  = []

deriving via Word64 instance Arbitrary SlotNo

instance Arbitrary PeerAdvertise where
  arbitrary :: Gen PeerAdvertise
arbitrary = [PeerAdvertise] -> Gen PeerAdvertise
forall a. [a] -> Gen a
elements [ PeerAdvertise
DoAdvertisePeer, PeerAdvertise
DoNotAdvertisePeer ]

  shrink :: PeerAdvertise -> [PeerAdvertise]
shrink PeerAdvertise
DoAdvertisePeer    = []
  shrink PeerAdvertise
DoNotAdvertisePeer = [PeerAdvertise
DoAdvertisePeer]

instance Arbitrary PeerSharing where
  arbitrary :: Gen PeerSharing
arbitrary = [PeerSharing] -> Gen PeerSharing
forall a. [a] -> Gen a
elements [ PeerSharing
PeerSharingDisabled, PeerSharing
PeerSharingEnabled ]
  shrink :: PeerSharing -> [PeerSharing]
shrink PeerSharing
PeerSharingDisabled = []
  shrink PeerSharing
PeerSharingEnabled  = [PeerSharing
PeerSharingDisabled]

instance Arbitrary ConsensusMode where
  arbitrary :: Gen ConsensusMode
arbitrary = [ConsensusMode] -> Gen ConsensusMode
forall a. [a] -> Gen a
elements [ConsensusMode
PraosMode, ConsensusMode
GenesisMode]
  shrink :: ConsensusMode -> [ConsensusMode]
shrink ConsensusMode
GenesisMode = [ConsensusMode
PraosMode]
  shrink ConsensusMode
PraosMode   = []

instance Arbitrary AfterSlot where
  arbitrary :: Gen AfterSlot
arbitrary = [Gen AfterSlot] -> Gen AfterSlot
forall a. [Gen a] -> Gen a
oneof [ AfterSlot -> Gen AfterSlot
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AfterSlot
Always
                    , SlotNo -> AfterSlot
After (SlotNo -> AfterSlot) -> Gen SlotNo -> Gen AfterSlot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SlotNo
forall a. Arbitrary a => Gen a
arbitrary
                    ]

instance Arbitrary UseBootstrapPeers where
  arbitrary :: Gen UseBootstrapPeers
arbitrary = [(Int, Gen UseBootstrapPeers)] -> Gen UseBootstrapPeers
forall a. [(Int, Gen a)] -> Gen a
frequency [ (Int
1, UseBootstrapPeers -> Gen UseBootstrapPeers
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UseBootstrapPeers
DontUseBootstrapPeers)
                        , (Int
1, [RelayAccessPoint] -> UseBootstrapPeers
UseBootstrapPeers ([RelayAccessPoint] -> UseBootstrapPeers)
-> Gen [RelayAccessPoint] -> Gen UseBootstrapPeers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [RelayAccessPoint]
forall a. Arbitrary a => Gen a
arbitrary)
                        ]

  shrink :: UseBootstrapPeers -> [UseBootstrapPeers]
shrink UseBootstrapPeers
DontUseBootstrapPeers = []
  shrink (UseBootstrapPeers [RelayAccessPoint]
bp) | [] <- [RelayAccessPoint]
bp = [UseBootstrapPeers
DontUseBootstrapPeers]
                                | [RelayAccessPoint
_] <- [RelayAccessPoint]
bp = [UseBootstrapPeers
DontUseBootstrapPeers]
  shrink (UseBootstrapPeers (RelayAccessPoint
hd : [RelayAccessPoint]
_)) = [[RelayAccessPoint] -> UseBootstrapPeers
UseBootstrapPeers [RelayAccessPoint
hd]]

instance Arbitrary UseLedgerPeers where
    arbitrary :: Gen UseLedgerPeers
arbitrary = [(Int, Gen UseLedgerPeers)] -> Gen UseLedgerPeers
forall a. [(Int, Gen a)] -> Gen a
frequency
      [ (Int
2, UseLedgerPeers -> Gen UseLedgerPeers
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UseLedgerPeers
DontUseLedgerPeers)
      , (Int
8, AfterSlot -> UseLedgerPeers
UseLedgerPeers (AfterSlot -> UseLedgerPeers)
-> Gen AfterSlot -> Gen UseLedgerPeers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen AfterSlot
forall a. Arbitrary a => Gen a
arbitrary)
      ]

instance Arbitrary PeerTrustable where
  arbitrary :: Gen PeerTrustable
arbitrary = [PeerTrustable] -> Gen PeerTrustable
forall a. [a] -> Gen a
elements [ PeerTrustable
IsNotTrustable, PeerTrustable
IsTrustable ]

instance Arbitrary PeerSelectionTargets where
  arbitrary :: Gen PeerSelectionTargets
arbitrary = do
    targetNumberOfKnownPeers       <- NonNegative Int -> Int
forall a. NonNegative a -> a
getNonNegative (NonNegative Int -> Int) -> Gen (NonNegative Int) -> Gen Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen (NonNegative Int) -> Gen (NonNegative Int)
forall a. Int -> Gen a -> Gen a
resize Int
1000 Gen (NonNegative Int)
forall a. Arbitrary a => Gen a
arbitrary
    targetNumberOfRootPeers        <- choose (0, min 100  targetNumberOfKnownPeers)
    targetNumberOfEstablishedPeers <- choose (0, min 1000 targetNumberOfKnownPeers)
    targetNumberOfActivePeers      <- choose (0, min 100  targetNumberOfEstablishedPeers)

    targetNumberOfKnownBigLedgerPeers
      <- getNonNegative <$> resize 1000 arbitrary
    targetNumberOfEstablishedBigLedgerPeers
      <- choose (0 , min 1000 targetNumberOfKnownBigLedgerPeers)
    targetNumberOfActiveBigLedgerPeers
      <- choose (0, min 100 targetNumberOfEstablishedBigLedgerPeers)

    return PeerSelectionTargets {
      targetNumberOfRootPeers,
      targetNumberOfKnownPeers,
      targetNumberOfEstablishedPeers,
      targetNumberOfActivePeers,
      targetNumberOfKnownBigLedgerPeers,
      targetNumberOfEstablishedBigLedgerPeers,
      targetNumberOfActiveBigLedgerPeers
    }

  shrink :: PeerSelectionTargets -> [PeerSelectionTargets]
shrink (PeerSelectionTargets Int
r Int
k Int
e Int
a Int
kb Int
eb Int
ab) =
    [ PeerSelectionTargets
targets'
    | (Int
r',Int
k',Int
e',Int
a',Int
kb',Int
eb',Int
ab') <- (Int, Int, Int, Int, Int, Int, Int)
-> [(Int, Int, Int, Int, Int, Int, Int)]
forall a. Arbitrary a => a -> [a]
shrink (Int
r,Int
k,Int
e,Int
a,Int
kb,Int
eb,Int
ab)
    , let targets' :: PeerSelectionTargets
targets' = Int
-> Int -> Int -> Int -> Int -> Int -> Int -> PeerSelectionTargets
PeerSelectionTargets Int
r' Int
k' Int
e' Int
a' Int
kb' Int
eb' Int
ab'
    , PeerSelectionTargets -> Bool
sanePeerSelectionTargets PeerSelectionTargets
targets' ]

-- GovernorMockEnvironment is responsible for generating valid targets
-- which account for local roots from random peer graph, but a shrink
-- is useful here for recursively shrinking TimedScript.
--
instance Arbitrary ConsensusModePeerTargets where
  arbitrary :: Gen ConsensusModePeerTargets
arbitrary = String -> Gen ConsensusModePeerTargets
forall a. HasCallStack => String -> a
error String
"not implemented"

  shrink :: ConsensusModePeerTargets -> [ConsensusModePeerTargets]
shrink ConsensusModePeerTargets { PeerSelectionTargets
deadlineTargets :: PeerSelectionTargets
deadlineTargets :: ConsensusModePeerTargets -> PeerSelectionTargets
deadlineTargets, PeerSelectionTargets
syncTargets :: PeerSelectionTargets
syncTargets :: ConsensusModePeerTargets -> PeerSelectionTargets
syncTargets } =
    let syncTargets' :: [PeerSelectionTargets]
syncTargets'     = PeerSelectionTargets -> [PeerSelectionTargets]
forall a. Arbitrary a => a -> [a]
shrink PeerSelectionTargets
syncTargets
        deadlineTargets' :: [PeerSelectionTargets]
deadlineTargets' = PeerSelectionTargets -> [PeerSelectionTargets]
forall a. Arbitrary a => a -> [a]
shrink PeerSelectionTargets
deadlineTargets
    in [ConsensusModePeerTargets { deadlineTargets :: PeerSelectionTargets
deadlineTargets = PeerSelectionTargets
deadlineTargets'', syncTargets :: PeerSelectionTargets
syncTargets = PeerSelectionTargets
syncTargets'' }
       | PeerSelectionTargets
deadlineTargets'' <- [PeerSelectionTargets]
deadlineTargets',
         PeerSelectionTargets
syncTargets'' <- [PeerSelectionTargets]
syncTargets']

instance Arbitrary DomainAccessPoint where
  arbitrary :: Gen DomainAccessPoint
arbitrary =
    Domain -> PortNumber -> DomainAccessPoint
DomainAccessPoint (Domain -> PortNumber -> DomainAccessPoint)
-> (Text -> Domain) -> Text -> PortNumber -> DomainAccessPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Domain
encodeUtf8
      (Text -> PortNumber -> DomainAccessPoint)
-> Gen Text -> Gen (PortNumber -> DomainAccessPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Gen Text
forall a. [a] -> Gen a
elements [Text]
domains
      Gen (PortNumber -> DomainAccessPoint)
-> Gen PortNumber -> Gen DomainAccessPoint
forall a b. Gen (a -> b) -> Gen a -> Gen 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 -> PortNumber) -> Gen Int -> Gen PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Gen Int
forall a. Arbitrary a => Gen a
arbitrary :: Gen Int))
    where
      domains :: [Text]
domains = [ Text
"test1"
                , Text
"test2"
                , Text
"test3"
                , Text
"test4"
                , Text
"test5"
                ]

genIPv4 :: Gen IP.IP
genIPv4 :: Gen IP
genIPv4 =
    IPv4 -> IP
IP.IPv4 (IPv4 -> IP) -> (Word32 -> IPv4) -> Word32 -> IP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> IPv4
IP.toIPv4w (Word32 -> IP) -> Gen Word32 -> Gen IP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary Gen Word32 -> (Word32 -> Bool) -> Gen Word32
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
100)

genIPv6 :: Gen IP.IP
genIPv6 :: Gen IP
genIPv6 =
    IPv6 -> IP
IP.IPv6 (IPv6 -> IP)
-> ((Word32, Word32, Word32, Word32) -> IPv6)
-> (Word32, Word32, Word32, Word32)
-> IP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32, Word32, Word32, Word32) -> IPv6
IP.toIPv6w ((Word32, Word32, Word32, Word32) -> IP)
-> Gen (Word32, Word32, Word32, Word32) -> Gen IP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Word32, Word32, Word32, Word32)
genFourWord32
  where
    genFourWord32 :: Gen (Word32, Word32, Word32, Word32)
    genFourWord32 :: Gen (Word32, Word32, Word32, Word32)
genFourWord32 =
       (,,,) (Word32
 -> Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32))
-> Gen Word32
-> Gen
     (Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary Gen Word32 -> (Word32 -> Bool) -> Gen Word32
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
100)
             Gen
  (Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32))
-> Gen Word32
-> Gen (Word32 -> Word32 -> (Word32, Word32, Word32, Word32))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary
             Gen (Word32 -> Word32 -> (Word32, Word32, Word32, Word32))
-> Gen Word32 -> Gen (Word32 -> (Word32, Word32, Word32, Word32))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary
             Gen (Word32 -> (Word32, Word32, Word32, Word32))
-> Gen Word32 -> Gen (Word32, Word32, Word32, Word32)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary

instance Arbitrary RelayAccessPoint where
  arbitrary :: Gen RelayAccessPoint
arbitrary =
      [Gen RelayAccessPoint] -> Gen RelayAccessPoint
forall a. [Gen a] -> Gen a
oneof [ DomainAccessPoint -> RelayAccessPoint
RelayDomainAccessPoint (DomainAccessPoint -> RelayAccessPoint)
-> Gen DomainAccessPoint -> Gen RelayAccessPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen DomainAccessPoint
forall a. Arbitrary a => Gen a
arbitrary
            , IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress (IP -> PortNumber -> RelayAccessPoint)
-> Gen IP -> Gen (PortNumber -> RelayAccessPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Gen IP] -> Gen IP
forall a. [Gen a] -> Gen a
oneof [Gen IP
genIPv4, Gen IP
genIPv6]
                                 Gen (PortNumber -> RelayAccessPoint)
-> Gen PortNumber -> Gen RelayAccessPoint
forall a b. Gen (a -> b) -> Gen a -> Gen 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 -> PortNumber) -> Gen Int -> Gen PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Gen Int
forall a. Arbitrary a => Gen a
arbitrary :: Gen Int))
            ]

prop_arbitrary_PeerSelectionTargets :: PeerSelectionTargets -> Bool
prop_arbitrary_PeerSelectionTargets :: PeerSelectionTargets -> Bool
prop_arbitrary_PeerSelectionTargets =
    PeerSelectionTargets -> Bool
sanePeerSelectionTargets

prop_shrink_PeerSelectionTargets :: ShrinkCarefully PeerSelectionTargets -> Property
prop_shrink_PeerSelectionTargets :: ShrinkCarefully PeerSelectionTargets -> Property
prop_shrink_PeerSelectionTargets ShrinkCarefully PeerSelectionTargets
x =
      (PeerSelectionTargets -> Bool)
-> ShrinkCarefully PeerSelectionTargets -> Property
forall a prop.
(Arbitrary a, Show a, Testable prop) =>
(a -> prop) -> ShrinkCarefully a -> Property
prop_shrink_valid PeerSelectionTargets -> Bool
sanePeerSelectionTargets ShrinkCarefully PeerSelectionTargets
x
 Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. ShrinkCarefully PeerSelectionTargets -> Property
forall a.
(Arbitrary a, Eq a, Show a) =>
ShrinkCarefully a -> Property
prop_shrink_nonequal ShrinkCarefully PeerSelectionTargets
x