Skip to content

Commit

Permalink
Tests wip
Browse files Browse the repository at this point in the history
  • Loading branch information
@crocodile-dentist
crocodile-dentist committed Dec 11, 2024
1 parent 735842e commit 4649b5a
Show file tree
Hide file tree
Showing 8 changed files with 678 additions and 571 deletions.
1 change: 1 addition & 0 deletions ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -79,6 +79,7 @@ instance Arbitrary ArbitraryRelayAccessPoint where
ArbitraryRelayAccessPoint <$>
oneof [ RelayAccessAddress (read "1.1.1.1") . getArbitraryPortNumber <$> arbitrary
, RelayAccessDomain "relay.iohk.example" . getArbitraryPortNumber <$> arbitrary
, pure $ RelayAccessSRVDomain "_cardano._tcp.iohk.example"
]

newtype ArbitraryLedgerStateJudgement =
Expand Down
206 changes: 103 additions & 103 deletions ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3760,109 +3760,109 @@ selectEnvTargets f =
-- This is a manual test that runs in IO and has to be observed to see that it
-- is doing something sensible. It is not run automatically.
--
_governorFindingPublicRoots :: Int
-> STM IO (Map RelayAccessPoint PeerAdvertise)
-> STM IO UseBootstrapPeers
-> STM IO LedgerStateJudgement
-> PeerSharing
-> StrictTVar IO OutboundConnectionsState
-> ConsensusMode
-> IO Void
_governorFindingPublicRoots targetNumberOfRootPeers readDomains readUseBootstrapPeers readLedgerStateJudgement peerSharing olocVar consensusMode = do
countersVar <- newTVarIO emptyPeerSelectionCounters
publicStateVar <- makePublicPeerSelectionStateVar
debugStateVar <- newTVarIO $ emptyPeerSelectionState (mkStdGen 42) consensusMode (MinBigLedgerPeersForTrustedState 0)
dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore
let interfaces = PeerSelectionInterfaces {
countersVar,
publicStateVar,
debugStateVar,
readUseLedgerPeers = return DontUseLedgerPeers
}

publicRootPeersProvider
tracer
(curry IP.toSockAddr)
dnsSemaphore
DNS.defaultResolvConf
readDomains
(ioDNSActions LookupReqAAndAAAA) $ \requestPublicRootPeers -> do
peerSelectionGovernor
tracer tracer tracer
-- TODO: #3182 Rng seed should come from quickcheck.
(mkStdGen 42)
consensusMode
(MinBigLedgerPeersForTrustedState 0)
actions
{ requestPublicRootPeers = \_ ->
transformPeerSelectionAction requestPublicRootPeers }
policy
interfaces
where
tracer :: Show a => Tracer IO a
tracer = Tracer (BS.putStrLn . BS.pack . show)

actions :: PeerSelectionActions SockAddr PeerSharing IO
actions = PeerSelectionActions {
peerTargets,
readLocalRootPeers = return [],
peerSharing = peerSharing,
readPeerSelectionTargets = return targets,
requestPeerShare = \_ _ -> return (PeerSharingResult []),
peerConnToPeerSharing = id,
requestPublicRootPeers = \_ _ -> return (PublicRootPeers.empty, 0),
peerStateActions = PeerStateActions {
establishPeerConnection = error "establishPeerConnection",
monitorPeerConnection = error "monitorPeerConnection",
activatePeerConnection = error "activatePeerConnection",
deactivatePeerConnection = error "deactivatePeerConnection",
closePeerConnection = error "closePeerConnection"
},
readUseBootstrapPeers,
readInboundPeers = pure Map.empty,
updateOutboundConnectionsState = \a -> do
a' <- readTVar olocVar
when (a /= a') $
writeTVar olocVar a,
getLedgerStateCtx =
LedgerPeersConsensusInterface {
lpGetLatestSlot = pure Origin,
lpGetLedgerStateJudgement = readLedgerStateJudgement,
lpGetLedgerPeers = pure [] },
readLedgerPeerSnapshot = pure Nothing
}

targets :: PeerSelectionTargets
targets = nullPeerSelectionTargets {
targetNumberOfRootPeers = targetNumberOfRootPeers,
targetNumberOfKnownPeers = targetNumberOfRootPeers
}

peerTargets = ConsensusModePeerTargets {
deadlineTargets = targets,
syncTargets = targets}

policy :: PeerSelectionPolicy SockAddr IO
policy = PeerSelectionPolicy {
policyPickKnownPeersForPeerShare = \_ _ _ -> pickTrivially,
policyPickColdPeersToForget = \_ _ _ -> pickTrivially,
policyPickColdPeersToPromote = \_ _ _ -> pickTrivially,
policyPickWarmPeersToPromote = \_ _ _ -> pickTrivially,
policyPickHotPeersToDemote = \_ _ _ -> pickTrivially,
policyPickWarmPeersToDemote = \_ _ _ -> pickTrivially,
policyPickInboundPeers = \_ _ _ -> pickTrivially,
policyFindPublicRootTimeout = 5,
policyMaxInProgressPeerShareReqs = 0,
policyPeerShareRetryTime = 0, -- seconds
policyPeerShareBatchWaitTime = 0, -- seconds
policyPeerShareOverallTimeout = 0, -- seconds
policyPeerShareActivationDelay = 2, -- seconds
policyErrorDelay = 0 -- seconds
}
pickTrivially :: Applicative m => Set SockAddr -> Int -> m (Set SockAddr)
pickTrivially m n = pure . Set.take n $ m

transformPeerSelectionAction = fmap (fmap (\(a, b) -> (PublicRootPeers.fromMapAndSet a Set.empty Set.empty Set.empty, b)))
-- _governorFindingPublicRoots :: Int
-- -> STM IO (Map RelayAccessPoint PeerAdvertise)
-- -> STM IO UseBootstrapPeers
-- -> STM IO LedgerStateJudgement
-- -> PeerSharing
-- -> StrictTVar IO OutboundConnectionsState
-- -> ConsensusMode
-- -> IO Void
-- _governorFindingPublicRoots targetNumberOfRootPeers readDomains readUseBootstrapPeers readLedgerStateJudgement peerSharing olocVar consensusMode = do
-- countersVar <- newTVarIO emptyPeerSelectionCounters
-- publicStateVar <- makePublicPeerSelectionStateVar
-- debugStateVar <- newTVarIO $ emptyPeerSelectionState (mkStdGen 42) consensusMode (MinBigLedgerPeersForTrustedState 0)
-- dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore
-- let interfaces = PeerSelectionInterfaces {
-- countersVar,
-- publicStateVar,
-- debugStateVar,
-- readUseLedgerPeers = return DontUseLedgerPeers
-- }

-- publicRootPeersProvider
-- tracer
-- (curry IP.toSockAddr)
-- dnsSemaphore
-- DNS.defaultResolvConf
-- readDomains
-- (ioDNSActions LookupReqAAndAAAA) $ \requestPublicRootPeers -> do
-- peerSelectionGovernor
-- tracer tracer tracer
-- -- TODO: #3182 Rng seed should come from quickcheck.
-- (mkStdGen 42)
-- consensusMode
-- (MinBigLedgerPeersForTrustedState 0)
-- actions
-- { requestPublicRootPeers = \_ ->
-- transformPeerSelectionAction requestPublicRootPeers }
-- policy
-- interfaces
-- where
-- tracer :: Show a => Tracer IO a
-- tracer = Tracer (BS.putStrLn . BS.pack . show)

-- actions :: PeerSelectionActions SockAddr PeerSharing IO
-- actions = PeerSelectionActions {
-- peerTargets,
-- readLocalRootPeers = return [],
-- peerSharing = peerSharing,
-- readPeerSelectionTargets = return targets,
-- requestPeerShare = \_ _ -> return (PeerSharingResult []),
-- peerConnToPeerSharing = id,
-- requestPublicRootPeers = \_ _ -> return (PublicRootPeers.empty, 0),
-- peerStateActions = PeerStateActions {
-- establishPeerConnection = error "establishPeerConnection",
-- monitorPeerConnection = error "monitorPeerConnection",
-- activatePeerConnection = error "activatePeerConnection",
-- deactivatePeerConnection = error "deactivatePeerConnection",
-- closePeerConnection = error "closePeerConnection"
-- },
-- readUseBootstrapPeers,
-- readInboundPeers = pure Map.empty,
-- updateOutboundConnectionsState = \a -> do
-- a' <- readTVar olocVar
-- when (a /= a') $
-- writeTVar olocVar a,
-- getLedgerStateCtx =
-- LedgerPeersConsensusInterface {
-- lpGetLatestSlot = pure Origin,
-- lpGetLedgerStateJudgement = readLedgerStateJudgement,
-- lpGetLedgerPeers = pure [] },
-- readLedgerPeerSnapshot = pure Nothing
-- }

-- targets :: PeerSelectionTargets
-- targets = nullPeerSelectionTargets {
-- targetNumberOfRootPeers = targetNumberOfRootPeers,
-- targetNumberOfKnownPeers = targetNumberOfRootPeers
-- }

-- peerTargets = ConsensusModePeerTargets {
-- deadlineTargets = targets,
-- syncTargets = targets}

-- policy :: PeerSelectionPolicy SockAddr IO
-- policy = PeerSelectionPolicy {
-- policyPickKnownPeersForPeerShare = \_ _ _ -> pickTrivially,
-- policyPickColdPeersToForget = \_ _ _ -> pickTrivially,
-- policyPickColdPeersToPromote = \_ _ _ -> pickTrivially,
-- policyPickWarmPeersToPromote = \_ _ _ -> pickTrivially,
-- policyPickHotPeersToDemote = \_ _ _ -> pickTrivially,
-- policyPickWarmPeersToDemote = \_ _ _ -> pickTrivially,
-- policyPickInboundPeers = \_ _ _ -> pickTrivially,
-- policyFindPublicRootTimeout = 5,
-- policyMaxInProgressPeerShareReqs = 0,
-- policyPeerShareRetryTime = 0, -- seconds
-- policyPeerShareBatchWaitTime = 0, -- seconds
-- policyPeerShareOverallTimeout = 0, -- seconds
-- policyPeerShareActivationDelay = 2, -- seconds
-- policyErrorDelay = 0 -- seconds
-- }
-- pickTrivially :: Applicative m => Set SockAddr -> Int -> m (Set SockAddr)
-- pickTrivially m n = pure . Set.take n $ m

-- transformPeerSelectionAction = fmap (fmap (\(a, b) -> (PublicRootPeers.fromMapAndSet a Set.empty Set.empty Set.empty, b)))

prop_issue_3550 :: Property
prop_issue_3550 = prop_governor_target_established_below defaultMaxTime $
Expand Down
46 changes: 30 additions & 16 deletions ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/Instances.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,11 +12,14 @@ module Test.Ouroboros.Network.PeerSelection.Instances
-- generators
, genIPv4
, genIPv6
, genPort
-- generator tests
, prop_arbitrary_PeerSelectionTargets
, prop_shrink_PeerSelectionTargets
) where

import Network.DNS qualified as DNS
import Ouroboros.Network.PeerSelection.RelayAccessPoint
import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word32, Word64)

Expand All @@ -26,6 +29,7 @@ import Ouroboros.Network.PeerSelection.Governor

import Data.Hashable
import Data.IP qualified as IP
import Network.Socket
import Ouroboros.Network.ConsensusMode
import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..))
import Ouroboros.Network.PeerSelection.LedgerPeers.Type (AfterSlot (..),
Expand Down Expand Up @@ -144,22 +148,28 @@ instance Arbitrary ConsensusModePeerTargets where
syncTargets'' <- syncTargets']

instance Arbitrary DomainAccessPoint where
arbitrary =
DomainAccessPoint . encodeUtf8
<$> elements domains
<*> (fromIntegral <$> (arbitrary :: Gen Int))
arbitrary = oneof [plain, srv]
where
domains = [ "test1"
, "test2"
, "test3"
, "test4"
, "test5"
]
plain = DomainAccessPoint <$> (DomainPlain
<$> elements domains
<*> genPort)
srv = DomainSRVAccessPoint <$> (DomainSRV <$> elements domains)
domains = encodeUtf8 <$>
[ "test1"
, "test2"
, "test3"
, "test4"
, "test5"
]

genIPv4 :: Gen IP.IP
genIPv4 =
IP.IPv4 . IP.toIPv4w <$> resize 200 arbitrary `suchThat` (> 100)

genPort :: Gen PortNumber
genPort =
fromIntegral <$> (arbitrary :: Gen Int)

genIPv6 :: Gen IP.IP
genIPv6 =
IP.IPv6 . IP.toIPv6w <$> genFourWord32
Expand All @@ -173,11 +183,16 @@ genIPv6 =

instance Arbitrary RelayAccessPoint where
arbitrary =
oneof [ RelayDomainAccessPoint <$> arbitrary
, RelayAccessAddress <$> oneof [genIPv4, genIPv6]
<*> (fromIntegral
<$> (arbitrary :: Gen Int))
]
frequency [ (4, RelayAccessAddress <$> oneof [genIPv4, genIPv6] <*> genPort)
, (4, RelayAccessDomain <$> elements domains <*> genPort)
, (1, RelayAccessSRVDomain <$> elements domains)]
where
domains = encodeUtf8 <$> [ "test1"
, "test2"
, "test3"
, "test4"
, "test5"
]

prop_arbitrary_PeerSelectionTargets :: PeerSelectionTargets -> Bool
prop_arbitrary_PeerSelectionTargets =
Expand All @@ -187,4 +202,3 @@ prop_shrink_PeerSelectionTargets :: ShrinkCarefully PeerSelectionTargets -> Prop
prop_shrink_PeerSelectionTargets x =
prop_shrink_valid sanePeerSelectionTargets x
.&&. prop_shrink_nonequal x

17 changes: 8 additions & 9 deletions ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/Json.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -21,20 +21,19 @@ tests =
]

prop_roundtrip_DomainAccessPoint_JSON :: DomainAccessPoint -> Property
prop_roundtrip_DomainAccessPoint_JSON da =
decode (encode da) === Just da
.&&.
fromJSON (toJSON da) === pure da
prop_roundtrip_DomainAccessPoint_JSON da = undefined
-- decode (encode da) === Just da
-- .&&.
-- fromJSON (toJSON da) === pure da

prop_roundtrip_RelayAccessPoint_JSON :: RelayAccessPoint -> Property
prop_roundtrip_RelayAccessPoint_JSON ra =
decode (encode ra) === Just ra
.&&.
fromJSON (toJSON ra) === pure ra
prop_roundtrip_RelayAccessPoint_JSON ra = undefined
-- decode (encode ra) === Just ra
-- .&&.
-- fromJSON (toJSON ra) === pure ra

prop_roundtrip_PeerAdvertise_JSON :: PeerAdvertise -> Property
prop_roundtrip_PeerAdvertise_JSON pa =
decode (encode pa) === Just pa
.&&.
fromJSON (toJSON pa) === pure pa

Loading

0 comments on commit 4649b5a

Please sign in to comment.